11:46 AM  20-SEP-95
AVA PATCHES 1-7
AVA200
AVA200 ; IHS/ORDC/LJF - ADD/ EDIT PERSONS TO VA(200 ; 27-MAY-1993 [ 07/13/95  8:42 AM ]
 ;;93.2;VA SUPPORT FILES;**1,4,7**;JUL 01, 1993
 ;
 ;
 Q
PERADD ;EP; ENTRY POINT to add or edit persons in ^va(200
 W @IOF,!!?22,"ADD/EDIT NEW PERSONS",!!
 W !!?10,"Use this option to enter names of employees, contractors, "
 W !?5,"and volunteers who will be referenced by other software.  If"
 W !?5,"the person is also a provider, you do NOT need to use this "
 W !?5,"option as the ADD/EDIT PROVIDERS option includes the data"
 W !?5,"fields asked for here.",!!
 ;
PER1 S AVAX=$$PERSON G PER1:AVAX>0
 K AVAX Q
 ;
 ;
PRVADD ;EP;ENTRY POINT to add or edit providers in ^va(200
 W @IOF,!!?22,"ADD/EDIT PROVIDERS",!!
 W !!?10,"Use this option to add new providers to your system OR to"
 W !?5,"edit those already in the system.  You do NOT need to enter the"
 W !?5,"provider as a person first.  Just use this option.",!
 ;
PRV1 S AVAX=$$PROVIDER G PRV1:AVAX>0
 K AVAX Q
 ;         
 ;
INACTIVE ;PEP;ENTRY POINT to inactivate a person and/or provider
 W @IOF,!!?20,"INACTIVATE/REACTIVATE A PERSON/PROVIDER",!!
 W !!?10,"Use this option to enter an INACTIVE DATE for a Person" ;PATCH #7
 W !?5,"or Provider.  To deactivate a user, please use the option on"
 W !?5,"the USER EDIT menu.  To REACTIVATE a person or provider, enter"
 W !?5,"an ""@"" at the Inactive Date prompt.  Then proceed to the" ;PATCH #7
 W !?5,"ADD/EDIT PROVIDERS option to insure all the data is current."
 W !!
 ;
ASK W !! K DIC S DIC=200,DIC(0)="AEMZQ" D ^DIC G INEXIT:Y=-1
 W ! S DIE=200,DA=+Y,DR="53.4" D ^DIE ;PATCH #7
 G ASK
 ;
INEXIT K DIC,DIE,DR,DA,X,Y Q
 ;
 ;
 ;
PERSON(AVADR,AVADR1) ;PEP;EXTR FUNC called to perform add or edit on one person
 ;AVADR can be set to fields to add as identifiers
 ;AVADR1 can be set to additional fields for DIE call
 ;to call, set variable to $$PERSON(with optional parameters)
 ;Identifiers already included:  by VA: Initials, SSN, Sex
 ;DR string below includes: VA Identifiers plus those you sent
 ;   Plus those stated below: DOB, Address fields, Phone, Office Phone
 ;
 N DIE,DA,DR,AVADA S AVADR=$G(AVADR)
 W ! S AVADA=$$ADD^XUSERNEW(AVADR) G EXIT1:AVADA'>0
 I $P(AVADA,U,3)=1 W !,"Identifiers Completed. Now for other data fields"
 I $P($G(^VA(200,+AVADA,"PS")),U,4)]"" W !!,$P(AVADA,U,2)," has been INACTIVATED.  Please use the INACTIVATE/REACTIVATE option.",!! G EXIT1 ;PATCH #7
 W ! S DIE=200,DA=+AVADA
 S DR=".01;1;4;5;8;9;.111:.116;.131;.132" S:$D(AVADR1) DR=DR_";"_AVADR1 ;PATCH #7
 D ^DIE
EXIT1 Q AVADA
 ;
 ;
PROVIDER(AVADR,AVADR1) ;PEP;EXTR FUNC called to add or edit one provider
 ;AVADR can be set to fields to add as identifiers
 ;AVADR1 can be set to additional fields for DR for ^DIE call
 ;to call, set variable to $$PROVIDER(with optional parameters)
 ;Identifiers already included:  by VA: Initials, SSN, Sex
 ;  By variable X set below: Affiliation, Provider Class, Code
 ;DR string includes: VA Identifiers plus those you sent to $$PROVIDER
 ;   Plus identifiers stated below in X
 ;   Plus those stated in $$PERSON: DOB, Address, Phone #
 ;   Plus those set into Y below: IHS Local Code, Medicare & Medicaid #,
 ;         UPIN #, and all VA provider fields except VA #
 ;
 N Y,X
 S X="53.5R;9999999.01;9999999.02" S:$D(AVADR) X=X_";"_AVADR ;IHS/ORDC/LJF 12/3/93 PATCH #4
 S Y=X_";9999999.05:9999999.08;53.1;53.2;53.6:53.9" ;PATCH #7
 S:$D(AVADR1) Y=Y_";"_AVADR1
 S AVADA=$$PERSON(X,Y)
 I $P($G(^VA(200,+AVADA,"PS")),U,5)]"" D  ;IHS/ORDC/LJF 9/13/93 PATCH #1
 .S DA=$P(^DIC(3,+AVADA,0),U,16) ;IHS/ORDC/LJF 9/13/93 PATCH #1
 .I DA S DIE=6,DR="9999999.21" D ^DIE ;IHS/ORDC/LJF 9/13/93 PATCH #1
 I +AVADA>0,$P($G(^VA(200,+AVADA,"PS")),U,5)="" W !!,*7,"MUST HAVE PROVIDER CLASS TO BE DESIGNATED AS A PROVIDER!!",!
 Q AVADA

AVAP2
AVAP2 ; DSD/GTH - AVA 93.2 PATCH 2, FILE SECURITY ; [ 10/21/93  3:34 PM ]
 ;;93.2;VA SUPPORT FILES;**2**;JUL 01, 1993
 ;
 W !!,"Resetting file protection for files 5 (STATE) and 16 (PERSON)"
 W !,"to pre-d93.2 values."
 D RPI
 E  W !,"LOCK UNAVAILABLE.  NOTIFY PROGRAMMER." Q
 W !!,"DONE."
 Q
 ;
RPI ;EP - Non-Interactive entry point for Remote Patch Installation.
 ;
 LOCK +^DIC(5,0,"RD"):60 E  G ABORT
 S ^DIC(5,0,"RD")="" LOCK -^DIC(5,0,"RD")
 ;
 LOCK +^DIC(16,0,"LAYGO"):60 E  G ABORT
 S ^DIC(16,0,"LAYGO")="#" LOCK -^DIC(16,0,"LAYGO")
 ;
 LOCK +^DIC(16,0,"WR"):60 E  G ABORT
 S ^DIC(16,0,"WR")="#" LOCK -^DIC(16,0,"WR")
 ;
 Q
 ;
 ;
ABORT D @^%ZOSF("ERRTN") I 0
 Q

AVAP3
AVAP3 ;IHS/ORDC/LJF - MOVE LICENSURE BACK TO FILE 6 [ 10/27/93  9:47 AM ]
 ;;7.0I4;Kernel;**3**;Jul 17, 1992
 ;
 Q  ;no direct entry to rtn
 ;
LOOP ; loop thru provider file
 Q:'$O(^DIC(6,0))  ;no data in provider file
 W !!,"Moving licensure data back to Provider file "
 S LJF6=0
 F  S LJF6=$O(^DIC(6,LJF6)) Q:LJF6'=+LJF6  D
 .Q:'$D(^DIC(6,LJF6,0))  ;bad entry
 .Q:$P(^DIC(6,LJF6,0),U)'=LJF6  ;also bad entry
 .I LJF6#10=0 W ". "
 .I '$D(^DIC(16,LJF6,"A3")) D  Q
 ..W !,"^DIC(16,",LJF6,",""A3"" DOES NOT EXIST.",!
 .S LJF200=$P(^DIC(16,LJF6,"A3"),U) ;user pointer
 .I LJF200="" D  Q
 ..W !,"^DIC(16,",LJF6," HAS NO A3 POINTER TO ^DIC(3.",!
 .Q:'$D(^VA(200,LJF200))  ;no entry in file 200
 .D MOVE ;move then delete licensure multiple
 .Q  ;get next provider
 ;
 ;
END ;***> eoj
 K LJF6,LJF200
 K X,Y Q
 ;
 ;
 ;
 ;
MOVE ;**> SUBRTN to move licensure data to file 6 then delete in file 200
 Q:'$O(^VA(200,LJF200,"PS1",0))  ;no data to move
 I $O(^DIC(6,LJF6,999999921,0)) G MOVE1 ;data in file 6; don't overwrite
 S ^DIC(6,LJF6,999999921,0)="^6.999999921P^"_$P(^VA(200,LJF200,"PS1",0),U,3,4) ;set zero node
 W "+ " S X=0
 F  S X=$O(^VA(200,LJF200,"PS1",X)) Q:X'=+X  D
 .S ^DIC(6,LJF6,999999921,X,0)=^VA(200,LJF200,"PS1",X,0)
MOVE1 K ^VA(200,LJF200,"PS1") ;remove data from file 200
 Q

AVAP4
AVAP4 ;IHS/ORDC/LJF - CLEANUP PROVIDER CLASS ENTRIES; [ 05/11/94  2:57 PM ]
 ;;93.2;VA SUPPORT FILES;**4,5,6**;JUL 01, 1993
 ;cleanup rtn for patches #4, 5, & 6
 ;
 Q  ;can only execute from line label
 ;
CLASS ;EP >> kill off file 6 entries if no zero node
 ;      then if provider class set in file 200, fire xrefs for
 ;      provider class, affiliation, and code
 ;
 S U="^"
 W !!!,"This program will cleanup bad entries in your PROVIDER file"
 W !,"and recreate them if a PROVIDER CLASS has been entered for the"
 W !,"provider in the NEW PERSON file."
 W !! K DIR S DIR(0)="YO",DIR("B")="NO"
 S DIR("A")="OKAY to run CLEANUP" D ^DIR Q:Y'=1
 ;
 S AVA6=0
 F  S AVA6=$O(^DIC(6,AVA6)) Q:AVA6'=+AVA6  D
 .Q:$D(^DIC(6,AVA6,0))  ;skip good entries
 .Q:'$D(^DIC(6,AVA6,9999999))  I $P(^(9999999),U,9)]""  D  ;PATCH 6
 ..K ^DIC(6,"GIHS",$P(^DIC(6,AVA6,9999999),U,9),AVA6) ;kill xref PATCH 6
 .K ^DIC(6,AVA6) ;kill bad entry in file 6
 .S AVA200=$P($G(^DIC(16,AVA6,"A3")),U) ;ifn in file 200
 .Q:AVA200=""  Q:'$D(^VA(200,AVA200,0))  ;no entry in file 200
 .Q:$P($G(^DIC(3,AVA200,0)),U,16)'=AVA6  ;bad pointers
 .S AVACLS=$P($G(^VA(200,AVA200,"PS")),U,5) ;IHS/ORDC/LJF PATCH 5
 .Q:AVACLS=""  ;no provider class entered
 .;
 .S DIE="^VA(200,",DA=AVA200,DR="53.5///@" D ^DIE
 .S DR="53.5////"_AVACLS D ^DIE
 .;
 .W !,"NEW PERSON entry #",AVA200," creating entry in file 6"
 ;
 W !!,"CLEANUP COMPLETE",!
 ;
EOJ ;     
 K AVA6,AVA200,DIR,DIE,DA,DR,X,Y
 Q

AVAP7
AVAP7 ;IHS/ORDC/LJF - PATCH 7 DATA DUPLICATION; [ 09/20/95  11:43 AM ]
 ;;93.2;VA SUPPORT FILES;**7**;JUL 01, 1993
 ;
 W !!?20,"AVA PATCH 7 DRIVER"
 W !! K DIR S DIR(0)="Y",DIR("B")="NO"
 S DIR("A")="Are you READY to proceed with this update"
 D ^DIR I Y'=1 K DIR,Y Q
 ;
 W !!,"We recommend capturing the output of this patch using a"
 W !,"slaved printer.  This is a cumulative patch.",!
 K DIR S DIR(0)="E",DIR("A")="Press ENTER when ready to proceed"
 D ^DIR
 ;
 ; -- run patch #2 update
 W !!,"Patch #2:",!
 D ^AVAP2
 ;
 ; -- run patch #3 update
 W !!,"Patch #3:",!
 D LOOP^AVAP3
 ;
 ; -- run patch #4 update
 W !!,"Patches #4 - #6:",!
 D ^AVAPINIT
 D CLASS^AVAP4
 ;
 ; -- patch 7 update: remove security from file 200 read access
 S ^DIC(200,0,"RD")=""
 ;
EXIT ;
 W !!,"PATCH #7 COMPLETE.",!
 Q

AVAPI001
AVAPI001 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 Q:'DIFQ(200)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DIC(200,0,"GL")
 ;;=^VA(200,
 ;;^DIC("B","NEW PERSON",200)
 ;;=
 ;;^DIC(200,"%",0)
 ;;=^1.005^2^2
 ;;^DIC(200,"%",1,0)
 ;;=QAM
 ;;^DIC(200,"%",2,0)
 ;;=QAP
 ;;^DIC(200,"%","B","QAM",1)
 ;;=
 ;;^DIC(200,"%","B","QAP",2)
 ;;=
 ;;^DIC(200,"%D",0)
 ;;=^^18^18^2941114^^^
 ;;^DIC(200,"%D",0,"LE")
 ;;=1
 ;;^DIC(200,"%D",1,0)
 ;;=This file contains data on employees, users, practitioners, etc.
 ;;^DIC(200,"%D",2,0)
 ;;=who were previously in Files 3,6,16 and others.
 ;;^DIC(200,"%D",3,0)
 ;;= 
 ;;^DIC(200,"%D",4,0)
 ;;=DHCP packages must check with the KERNEL developers to see that
 ;;^DIC(200,"%D",5,0)
 ;;=a given number/namespace is clear for them to use.
 ;;^DIC(200,"%D",6,0)
 ;;= 
 ;;^DIC(200,"%D",7,0)
 ;;=Field numbers 53-59.9 reserved for Pharm.
 ;;^DIC(200,"%D",8,0)
 ;;= Nodes and X-ref 'PS*'.
 ;;^DIC(200,"%D",9,0)
 ;;=Field numbers 70-79.9 reserved for Radiology
 ;;^DIC(200,"%D",10,0)
 ;;= Nodes and X-ref 'RA*'.
 ;;^DIC(200,"%D",11,0)
 ;;=Field numbers 720-725 reserved for DSSM
 ;;^DIC(200,"%D",12,0)
 ;;= Nodes and X-ref 'EC*' and 'AEC*'.
 ;;^DIC(200,"%D",13,0)
 ;;=Field numbers 740-749.9 reserved for QA
 ;;^DIC(200,"%D",14,0)
 ;;= Nodes and X-ref 'QA*'.
 ;;^DIC(200,"%D",15,0)
 ;;=Field numbers 654-654.9 reserved for Social work
 ;;^DIC(200,"%D",16,0)
 ;;= Node 654 and X-ref 'SW*'.
 ;;^DIC(200,"%D",17,0)
 ;;=Field numbers 500-500.9 reserved for mailman
 ;;^DIC(200,"%D",18,0)
 ;;= Node 500 and X-ref 'XM*' and 'AXM*'.
 ;;^DD(200,0)
 ;;=FIELD^NL^9999999.09^182
 ;;^DD(200,0,"DDA")
 ;;=N
 ;;^DD(200,0,"DT")
 ;;=2930511
 ;;^DD(200,0,"ID",1)
 ;;=W "   ",$P(^(0),U,2)
 ;;^DD(200,0,"ID",28)
 ;;=W:$D(^(5)) "   ",$P(^(5),U,2)
 ;;^DD(200,0,"IX","A",200,2)
 ;;=
 ;;^DD(200,0,"IX","A16",200,8980.16)
 ;;=
 ;;^DD(200,0,"IX","AB",200.051,.01)
 ;;=
 ;;^DD(200,0,"IX","AB2",200,200.09)
 ;;=
 ;;^DD(200,0,"IX","AC",200,14.9)
 ;;=
 ;;^DD(200,0,"IX","ACSW",200,654.3)
 ;;=
 ;;^DD(200,0,"IX","ACX1",200,.111)
 ;;=
 ;;^DD(200,0,"IX","ACX10",200,.1214)
 ;;=
 ;;^DD(200,0,"IX","ACX11",200,.1215)
 ;;=
 ;;^DD(200,0,"IX","ACX12",200,.1216)
 ;;=
 ;;^DD(200,0,"IX","ACX13",200,.131)
 ;;=
 ;;^DD(200,0,"IX","ACX14",200,.132)
 ;;=
 ;;^DD(200,0,"IX","ACX15",200,.133)
 ;;=
 ;;^DD(200,0,"IX","ACX16",200,.134)
 ;;=
 ;;^DD(200,0,"IX","ACX17",200,.1217)
 ;;=
 ;;^DD(200,0,"IX","ACX18",200,.1218)
 ;;=
 ;;^DD(200,0,"IX","ACX2",200,.112)
 ;;=
 ;;^DD(200,0,"IX","ACX20",200,20.2)
 ;;=
 ;;^DD(200,0,"IX","ACX21",200,20.3)
 ;;=
 ;;^DD(200,0,"IX","ACX22",200,5)
 ;;=
 ;;^DD(200,0,"IX","ACX23",200,20.4)
 ;;=
 ;;^DD(200,0,"IX","ACX25",200,3)
 ;;=
 ;;^DD(200,0,"IX","ACX26",200,28)
 ;;=
 ;;^DD(200,0,"IX","ACX27",200,13)
 ;;=
 ;;^DD(200,0,"IX","ACX28",200,29)
 ;;=
 ;;^DD(200,0,"IX","ACX29",200,9.2)
 ;;=
 ;;^DD(200,0,"IX","ACX3",200,.113)
 ;;=
 ;;^DD(200,0,"IX","ACX30",200,8)
 ;;=
 ;;^DD(200,0,"IX","ACX31",200,1)
 ;;=
 ;;^DD(200,0,"IX","ACX32",200,4)
 ;;=
 ;;^DD(200,0,"IX","ACX33",200,9)
 ;;=
 ;;^DD(200,0,"IX","ACX34",200,9.1)
 ;;=
 ;;^DD(200,0,"IX","ACX35",200,53.4)
 ;;=
 ;;^DD(200,0,"IX","ACX36",200,53.5)
 ;;=
 ;;^DD(200,0,"IX","ACX37",200,53.6)
 ;;=
 ;;^DD(200,0,"IX","ACX38",200,53.2)
 ;;=
 ;;^DD(200,0,"IX","ACX39",200,53.3)
 ;;=
 ;;^DD(200,0,"IX","ACX4",200,.114)
 ;;=
 ;;^DD(200,0,"IX","ACX5",200,.115)
 ;;=
 ;;^DD(200,0,"IX","ACX6",200,.116)
 ;;=
 ;;^DD(200,0,"IX","ACX7",200,.1211)
 ;;=
 ;;^DD(200,0,"IX","ACX8",200,.1212)
 ;;=
 ;;^DD(200,0,"IX","ACX9",200,.1213)
 ;;=
 ;;^DD(200,0,"IX","ACXIHS01",200,9999999.01)
 ;;=
 ;;^DD(200,0,"IX","ACXIHS02",200,9999999.02)
 ;;=
 ;;^DD(200,0,"IX","ACXIHS05",200,9999999.05)
 ;;=
 ;;^DD(200,0,"IX","ACXIHS06",200,9999999.06)
 ;;=
 ;;^DD(200,0,"IX","ACXIHS07",200,9999999.07)
 ;;=
 ;;^DD(200,0,"IX","ACXIHS08",200,9999999.08)
 ;;=
 ;;^DD(200,0,"IX","ACXIHS09",200,9999999.09)
 ;;=
 ;;^DD(200,0,"IX","AD",200.03,.01)
 ;;=
 ;;^DD(200,0,"IX","AE",200,.01)
 ;;=
 ;;^DD(200,0,"IX","AF",200,.01)
 ;;=
 ;;^DD(200,0,"IX","AG",200,.01)
 ;;=
 ;;^DD(200,0,"IX","AH",200,.01)
 ;;=
 ;;^DD(200,0,"IX","AIHS",200,53.5)
 ;;=
 ;;^DD(200,0,"IX","AK",200.051,.01)
 ;;=
 ;;^DD(200,0,"IX","AOA",200.03,.01)
 ;;=
 ;;^DD(200,0,"IX","AOB",200.03,2)
 ;;=
 ;;^DD(200,0,"IX","AOLD",200,2)
 ;;=
 ;;^DD(200,0,"IX","AP",200,201)
 ;;=
 ;;^DD(200,0,"IX","ASWB",200,654)
 ;;=
 ;;^DD(200,0,"IX","ASWC",200,654.1)
 ;;=
 ;;^DD(200,0,"IX","ASWD",200,654.2)
 ;;=
 ;;^DD(200,0,"IX","ASWE",200,654.15)
 ;;=
 ;;^DD(200,0,"IX","ASX",200,.01)
 ;;=
 ;;^DD(200,0,"IX","AXQA",200.194,.02)
 ;;=
 ;;^DD(200,0,"IX","AXQAN",200.194,.02)
 ;;=
 ;;^DD(200,0,"IX","B",200,.01)
 ;;=
 ;;^DD(200,0,"IX","BB",200.04,.01)
 ;;=
 ;;^DD(200,0,"IX","BS5",200,.01)
 ;;=
 ;;^DD(200,0,"IX","BS55",200,9)
 ;;=
 ;;^DD(200,0,"IX","C",200,1)
 ;;=
 ;;^DD(200,0,"IX","D",200,13)
 ;;=

AVAPI002
AVAPI002 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 Q:'DIFQ(200)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(200,0,"IX","F",200,9999999.02)
 ;;=
 ;;^DD(200,0,"IX","GIHS",200,9999999.09)
 ;;=
 ;;^DD(200,0,"IX","H",200,9999999.05)
 ;;=
 ;;^DD(200,0,"IX","PS1",200,53.2)
 ;;=
 ;;^DD(200,0,"IX","PS2",200,53.3)
 ;;=
 ;;^DD(200,0,"IX","SSN",200,9)
 ;;=
 ;;^DD(200,0,"IX","VOLD",200,11)
 ;;=
 ;;^DD(200,0,"NM","NEW PERSON")
 ;;=
 ;;^DD(200,0,"PT",.6,.04)
 ;;=
 ;;^DD(200,0,"PT",1,20)
 ;;=
 ;;^DD(200,0,"PT",1.1,.04)
 ;;=
 ;;^DD(200,0,"PT",1.11,5)
 ;;=
 ;;^DD(200,0,"PT",1.11,8)
 ;;=
 ;;^DD(200,0,"PT",1.11,9)
 ;;=
 ;;^DD(200,0,"PT",1.11,15)
 ;;=
 ;;^DD(200,0,"PT",3.05,5)
 ;;=
 ;;^DD(200,0,"PT",3.07,.01)
 ;;=
 ;;^DD(200,0,"PT",3.081,.01)
 ;;=
 ;;^DD(200,0,"PT",3.51,4)
 ;;=
 ;;^DD(200,0,"PT",3.5131,.01)
 ;;=
 ;;^DD(200,0,"PT",3.7,.01)
 ;;=
 ;;^DD(200,0,"PT",3.7,3.2)
 ;;=
 ;;^DD(200,0,"PT",3.703,.01)
 ;;=
 ;;^DD(200,0,"PT",3.73,1)
 ;;=
 ;;^DD(200,0,"PT",3.8,5)
 ;;=
 ;;^DD(200,0,"PT",3.8,5.1)
 ;;=
 ;;^DD(200,0,"PT",3.802,.01)
 ;;=
 ;;^DD(200,0,"PT",3.81,.01)
 ;;=
 ;;^DD(200,0,"PT",4.2995,2)
 ;;=
 ;;^DD(200,0,"PT",4.31,2)
 ;;=
 ;;^DD(200,0,"PT",4.32,.01)
 ;;=
 ;;^DD(200,0,"PT",4.34,.01)
 ;;=
 ;;^DD(200,0,"PT",9.2,6)
 ;;=
 ;;^DD(200,0,"PT",9.24,.01)
 ;;=
 ;;^DD(200,0,"PT",9.4901,.03)
 ;;=
 ;;^DD(200,0,"PT",9.823,3)
 ;;=
 ;;^DD(200,0,"PT",15,.01)
 ;;=
 ;;^DD(200,0,"PT",15,.02)
 ;;=
 ;;^DD(200,0,"PT",15,.09)
 ;;=
 ;;^DD(200,0,"PT",15,.11)
 ;;=
 ;;^DD(200,0,"PT",15,.12)
 ;;=
 ;;^DD(200,0,"PT",19.081,1)
 ;;=
 ;;^DD(200,0,"PT",49,16000)
 ;;=
 ;;^DD(200,0,"PT",50.0731,4)
 ;;=
 ;;^DD(200,0,"PT",50.0731,5)
 ;;=
 ;;^DD(200,0,"PT",50.0731,9)
 ;;=
 ;;^DD(200,0,"PT",50.07331,.01)
 ;;=
 ;;^DD(200,0,"PT",50.612,7)
 ;;=
 ;;^DD(200,0,"PT",50.612,9)
 ;;=
 ;;^DD(200,0,"PT",50.9001,.01)
 ;;=
 ;;^DD(200,0,"PT",50.9004,.01)
 ;;=
 ;;^DD(200,0,"PT",50.901,.01)
 ;;=
 ;;^DD(200,0,"PT",52,4)
 ;;=
 ;;^DD(200,0,"PT",52,16)
 ;;=
 ;;^DD(200,0,"PT",52,23)
 ;;=
 ;;^DD(200,0,"PT",52,104)
 ;;=
 ;;^DD(200,0,"PT",52,109)
 ;;=
 ;;^DD(200,0,"PT",52.032,3)
 ;;=
 ;;^DD(200,0,"PT",52.1,4)
 ;;=
 ;;^DD(200,0,"PT",52.1,6)
 ;;=
 ;;^DD(200,0,"PT",52.1,15)
 ;;=
 ;;^DD(200,0,"PT",52.2,.05)
 ;;=
 ;;^DD(200,0,"PT",52.2,.07)
 ;;=
 ;;^DD(200,0,"PT",52.2,6)
 ;;=
 ;;^DD(200,0,"PT",52.3,.03)
 ;;=
 ;;^DD(200,0,"PT",52.4,2)
 ;;=
 ;;^DD(200,0,"PT",52.52,2)
 ;;=
 ;;^DD(200,0,"PT",52.52,3)
 ;;=
 ;;^DD(200,0,"PT",53.45,.01)
 ;;=
 ;;^DD(200,0,"PT",55,57)
 ;;=
 ;;^DD(200,0,"PT",100,.63)
 ;;=
 ;;^DD(200,0,"PT",100,.66)
 ;;=
 ;;^DD(200,0,"PT",100,.69)
 ;;=
 ;;^DD(200,0,"PT",100,1)
 ;;=
 ;;^DD(200,0,"PT",100,1.1)
 ;;=
 ;;^DD(200,0,"PT",100,3)
 ;;=
 ;;^DD(200,0,"PT",100,40)
 ;;=
 ;;^DD(200,0,"PT",100,44)
 ;;=
 ;;^DD(200,0,"PT",100.09,.03)
 ;;=
 ;;^DD(200,0,"PT",100.2,.03)
 ;;=
 ;;^DD(200,0,"PT",100.212,.01)
 ;;=
 ;;^DD(200,0,"PT",100.213,.01)
 ;;=
 ;;^DD(200,0,"PT",100.4,2)
 ;;=
 ;;^DD(200,0,"PT",100.5,2)
 ;;=
 ;;^DD(200,0,"PT",100.9002,.01)
 ;;=
 ;;^DD(200,0,"PT",101,5)
 ;;=
 ;;^DD(200,0,"PT",120.8,5)
 ;;=
 ;;^DD(200,0,"PT",120.8,21)
 ;;=
 ;;^DD(200,0,"PT",120.8,24)
 ;;=
 ;;^DD(200,0,"PT",120.81,2)
 ;;=
 ;;^DD(200,0,"PT",120.813,1)
 ;;=
 ;;^DD(200,0,"PT",120.814,1)
 ;;=
 ;;^DD(200,0,"PT",120.826,1)
 ;;=
 ;;^DD(200,0,"PT",120.85,.5)
 ;;=
 ;;^DD(200,0,"PT",120.8502,2)
 ;;=
 ;;^DD(200,0,"PT",200,19)
 ;;=
 ;;^DD(200,0,"PT",200,31)
 ;;=
 ;;^DD(200,0,"PT",200,53.8)
 ;;=
 ;;^DD(200,0,"PT",200,100.25)
 ;;=
 ;;^DD(200,0,"PT",200,654.1)
 ;;=
 ;;^DD(200,0,"PT",200,654.3)
 ;;=
 ;;^DD(200,0,"PT",200.051,1)
 ;;=
 ;;^DD(200,0,"PT",200.052,1)
 ;;=
 ;;^DD(200,0,"PT",200.19,1)
 ;;=
 ;;^DD(200,0,"PT",350.9,1.08)
 ;;=
 ;;^DD(200,0,"PT",356,1.02)
 ;;=
 ;;^DD(200,0,"PT",356,1.04)
 ;;=
 ;;^DD(200,0,"PT",356,1.05)
 ;;=
 ;;^DD(200,0,"PT",356,1.06)
 ;;=
 ;;^DD(200,0,"PT",356.1,1.02)
 ;;=
 ;;^DD(200,0,"PT",356.1,1.04)
 ;;=
 ;;^DD(200,0,"PT",356.1,1.06)
 ;;=
 ;;^DD(200,0,"PT",356.2,1.02)
 ;;=
 ;;^DD(200,0,"PT",356.2,1.04)
 ;;=
 ;;^DD(200,0,"PT",356.94,.03)
 ;;=
 ;;^DD(200,0,"PT",2051,1)
 ;;=
 ;;^DD(200,0,"PT",2051,3)
 ;;=
 ;;^DD(200,0,"PT",8980,4)
 ;;=
 ;;^DD(200,0,"PT",8980.01,.01)
 ;;=
 ;;^DD(200,0,"PT",50001,2)
 ;;=
 ;;^DD(200,0,"PT",50001.02,.01)
 ;;=
 ;;^DD(200,0,"PT",50001.11,.01)
 ;;=
 ;;^DD(200,0,"PT",50001.12,.01)
 ;;=
 ;;^DD(200,0,"PT",50055.15,.01)
 ;;=
 ;;^DD(200,0,"PT",90001,.06)
 ;;=
 ;;^DD(200,0,"PT",90001.1,.07)
 ;;=
 ;;^DD(200,0,"PT",90050,.01)
 ;;=
 ;;^DD(200,0,"PT",90050.01,6)
 ;;=
 ;;^DD(200,0,"PT",90050.01,113)
 ;;=
 ;;^DD(200,0,"PT",90050.01,214)
 ;;=
 ;;^DD(200,0,"PT",90050.01,215)
 ;;=
 ;;^DD(200,0,"PT",90050.01,405)
 ;;=
 ;;^DD(200,0,"PT",90050.02,.01)
 ;;=
 ;;^DD(200,0,"PT",90050.02,4)
 ;;=
 ;;^DD(200,0,"PT",90050.03,13)
 ;;=
 ;;^DD(200,0,"PT",90051.01,5)
 ;;=
 ;;^DD(200,0,"PT",90051.01,6)
 ;;=
 ;;^DD(200,0,"PT",90051.01,11)
 ;;=
 ;;^DD(200,0,"PT",90051.01,13)
 ;;=
 ;;^DD(200,0,"PT",90051.1101,4)
 ;;=
 ;;^DD(200,0,"PT",90051.1101,15)
 ;;=

AVAPI003
AVAPI003 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 Q:'DIFQ(200)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(200,0,"PT",90051.1101,402)
 ;;=
 ;;^DD(200,0,"PT",90051.2101,.01)
 ;;=
 ;;^DD(200,0,"PT",90051.2201,.01)
 ;;=
 ;;^DD(200,0,"PT",90060.1,.02)
 ;;=
 ;;^DD(200,0,"PT",664003,.05)
 ;;=
 ;;^DD(200,0,"PT",800005.3,3)
 ;;=
 ;;^DD(200,0,"PT",800680.3,6)
 ;;=
 ;;^DD(200,0,"PT",800685.3,6)
 ;;=
 ;;^DD(200,0,"PT",8000010,.01)
 ;;=
 ;;^DD(200,0,"PT",8004100,.01)
 ;;=
 ;;^DD(200,0,"PT",8004102,11)
 ;;=
 ;;^DD(200,0,"PT",8008702.01,.01)
 ;;=
 ;;^DD(200,0,"PT",8008713.01,8)
 ;;=
 ;;^DD(200,0,"PT",8008713.01,10)
 ;;=
 ;;^DD(200,0,"PT",8008713.01,12)
 ;;=
 ;;^DD(200,0,"PT",8008713.01,14)
 ;;=
 ;;^DD(200,0,"PT",9000010,.23)
 ;;=
 ;;^DD(200,0,"PT",9000010.02,.14)
 ;;=
 ;;^DD(200,0,"PT",9000010.07,.14)
 ;;=
 ;;^DD(200,0,"PT",9000010.08,.09)
 ;;=
 ;;^DD(200,0,"PT",9001001.51101,.02)
 ;;=
 ;;^DD(200,0,"PT",9001200,.02)
 ;;=
 ;;^DD(200,0,"PT",9002080.02,11)
 ;;=
 ;;^DD(200,0,"PT",9002085,101.3)
 ;;=
 ;;^DD(200,0,"PT",9002089,36)
 ;;=
 ;;^DD(200,0,"PT",9002089,38)
 ;;=
 ;;^DD(200,0,"PT",9002089.01,.01)
 ;;=
 ;;^DD(200,0,"PT",9002163.4,.03)
 ;;=
 ;;^DD(200,0,"PT",9002163.4,.04)
 ;;=
 ;;^DD(200,0,"PT",9002163.4,.05)
 ;;=
 ;;^DD(200,0,"PT",9002165,.22)
 ;;=
 ;;^DD(200,0,"PT",9002165,.24)
 ;;=
 ;;^DD(200,0,"PT",9002166.7,.01)
 ;;=
 ;;^DD(200,0,"PT",9002167,.14)
 ;;=
 ;;^DD(200,0,"PT",9002167.01,.02)
 ;;=
 ;;^DD(200,0,"PT",9002168.5,.08)
 ;;=
 ;;^DD(200,0,"PT",9002168.5,.11)
 ;;=
 ;;^DD(200,0,"PT",9002168.9,.01)
 ;;=
 ;;^DD(200,0,"PT",9002168.9,.03)
 ;;=
 ;;^DD(200,0,"PT",9002168.9,.05)
 ;;=
 ;;^DD(200,0,"PT",9002169.82,.01)
 ;;=
 ;;^DD(200,0,"PT",9002185.01,.01)
 ;;=
 ;;^DD(200,0,"PT",9002185.3,.01)
 ;;=
 ;;^DD(200,0,"PT",9002185.6,.01)
 ;;=
 ;;^DD(200,0,"PT",9002186.01,.01)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1000)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1010)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1020)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1030)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1032)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1040)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1050)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1060)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1070)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1080)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1081)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1140)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1170)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1190)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1230)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1240)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1250)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1260)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1300)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1310)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1320)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1330)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1340)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1360)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1370)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1380)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1390)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1400)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1410)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1420)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1430)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1440)
 ;;=
 ;;^DD(200,0,"PT",9002186.5,1450)
 ;;=
 ;;^DD(200,0,"PT",9002187.04,.01)
 ;;=
 ;;^DD(200,0,"PT",9002187.1,.02)
 ;;=
 ;;^DD(200,0,"PT",9002188.04,.01)
 ;;=
 ;;^DD(200,0,"PT",9002189,.05)
 ;;=
 ;;^DD(200,0,"PT",9002189.01,.01)
 ;;=
 ;;^DD(200,0,"PT",9002189.1,.03)
 ;;=
 ;;^DD(200,0,"PT",9002190,.08)
 ;;=
 ;;^DD(200,0,"PT",9002190,.09)
 ;;=
 ;;^DD(200,0,"PT",9002190,2)
 ;;=
 ;;^DD(200,0,"PT",9002190,6)
 ;;=
 ;;^DD(200,0,"PT",9002190.01,.02)
 ;;=
 ;;^DD(200,0,"PT",9002190.01,.03)
 ;;=
 ;;^DD(200,0,"PT",9002190.55,.01)
 ;;=
 ;;^DD(200,0,"PT",9002190.55,1)
 ;;=
 ;;^DD(200,0,"PT",9002190.55,2)
 ;;=
 ;;^DD(200,0,"PT",9002190.55,3)
 ;;=
 ;;^DD(200,0,"PT",9002190.55,4)
 ;;=
 ;;^DD(200,0,"PT",9002191.6,.02)
 ;;=
 ;;^DD(200,0,"PT",9002192,3)
 ;;=
 ;;^DD(200,0,"PT",9002193,15.2)
 ;;=
 ;;^DD(200,0,"PT",9002193.2,.05)
 ;;=
 ;;^DD(200,0,"PT",9002193.2,.09)
 ;;=
 ;;^DD(200,0,"PT",9002193.2111,.02)
 ;;=
 ;;^DD(200,0,"PT",9002193.2121,.02)
 ;;=
 ;;^DD(200,0,"PT",9002194.2,.05)
 ;;=
 ;;^DD(200,0,"PT",9002196,.4)
 ;;=
 ;;^DD(200,0,"PT",9002196,10)
 ;;=
 ;;^DD(200,0,"PT",9002196,11)
 ;;=
 ;;^DD(200,0,"PT",9002196,12)
 ;;=
 ;;^DD(200,0,"PT",9002196,20)
 ;;=
 ;;^DD(200,0,"PT",9002196,22)
 ;;=
 ;;^DD(200,0,"PT",9002196,5203)
 ;;=
 ;;^DD(200,0,"PT",9002196,5205)
 ;;=
 ;;^DD(200,0,"PT",9002196,5208)
 ;;=
 ;;^DD(200,0,"PT",9002196,5211)
 ;;=
 ;;^DD(200,0,"PT",9002196,103220)
 ;;=
 ;;^DD(200,0,"PT",9002196,103990)
 ;;=
 ;;^DD(200,0,"PT",9002196,103998)
 ;;=
 ;;^DD(200,0,"PT",9002196,113070)
 ;;=
 ;;^DD(200,0,"PT",9002196,113160)
 ;;=
 ;;^DD(200,0,"PT",9002196,113170)
 ;;=
 ;;^DD(200,0,"PT",9002196,113180)
 ;;=
 ;;^DD(200,0,"PT",9002196,113190)
 ;;=
 ;;^DD(200,0,"PT",9002196,113200)
 ;;=
 ;;^DD(200,0,"PT",9002196,113220)
 ;;=
 ;;^DD(200,0,"PT",9002196,113230)
 ;;=

AVAPI004
AVAPI004 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 Q:'DIFQ(200)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(200,0,"PT",9002196,113240)
 ;;=
 ;;^DD(200,0,"PT",9002196,113250)
 ;;=
 ;;^DD(200,0,"PT",9002196,113260)
 ;;=
 ;;^DD(200,0,"PT",9002196,113270)
 ;;=
 ;;^DD(200,0,"PT",9002196,113280)
 ;;=
 ;;^DD(200,0,"PT",9002196,113290)
 ;;=
 ;;^DD(200,0,"PT",9002196,113300)
 ;;=
 ;;^DD(200,0,"PT",9002196,113310)
 ;;=
 ;;^DD(200,0,"PT",9002196,113320)
 ;;=
 ;;^DD(200,0,"PT",9002196,113330)
 ;;=
 ;;^DD(200,0,"PT",9002196,113340)
 ;;=
 ;;^DD(200,0,"PT",9002196,113360)
 ;;=
 ;;^DD(200,0,"PT",9002196,113370)
 ;;=
 ;;^DD(200,0,"PT",9002196,113380)
 ;;=
 ;;^DD(200,0,"PT",9002196,113390)
 ;;=
 ;;^DD(200,0,"PT",9002196,113400)
 ;;=
 ;;^DD(200,0,"PT",9002196,113410)
 ;;=
 ;;^DD(200,0,"PT",9002196,130040)
 ;;=
 ;;^DD(200,0,"PT",9002196,130150)
 ;;=
 ;;^DD(200,0,"PT",9002196,130151)
 ;;=
 ;;^DD(200,0,"PT",9002196,130154)
 ;;=
 ;;^DD(200,0,"PT",9002196,130156)
 ;;=
 ;;^DD(200,0,"PT",9002196,130159)
 ;;=
 ;;^DD(200,0,"PT",9002196,130171)
 ;;=
 ;;^DD(200,0,"PT",9002196,130173)
 ;;=
 ;;^DD(200,0,"PT",9002196,148250)
 ;;=
 ;;^DD(200,0,"PT",9002196,148260)
 ;;=
 ;;^DD(200,0,"PT",9002196,148270)
 ;;=
 ;;^DD(200,0,"PT",9002196,148280)
 ;;=
 ;;^DD(200,0,"PT",9002196,148290)
 ;;=
 ;;^DD(200,0,"PT",9002196,148300)
 ;;=
 ;;^DD(200,0,"PT",9002196,148310)
 ;;=
 ;;^DD(200,0,"PT",9002196.0111,.02)
 ;;=
 ;;^DD(200,0,"PT",9002196.07,.01)
 ;;=
 ;;^DD(200,0,"PT",9002196.2001,.02)
 ;;=
 ;;^DD(200,0,"PT",9002199,.01)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,1)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,2)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,3)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,4)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,5)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,6)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,7)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,8)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,9)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,10)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,11)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,12)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,14)
 ;;=
 ;;^DD(200,0,"PT",9002199.2,15)
 ;;=
 ;;^DD(200,0,"PT",9002199.4,.11)
 ;;=
 ;;^DD(200,0,"PT",9002199.4,.12)
 ;;=
 ;;^DD(200,0,"PT",9002199.4,.13)
 ;;=
 ;;^DD(200,0,"PT",9002199.4,7)
 ;;=
 ;;^DD(200,0,"PT",9002199.4501,.01)
 ;;=
 ;;^DD(200,0,"PT",9002199.4501,.04)
 ;;=
 ;;^DD(200,0,"PT",9002226,.05)
 ;;=
 ;;^DD(200,0,"PT",9002227,.03)
 ;;=
 ;;^DD(200,0,"PT",9002228,.05)
 ;;=
 ;;^DD(200,0,"PT",9002274.12,.08)
 ;;=
 ;;^DD(200,0,"PT",9002274.2,.05)
 ;;=
 ;;^DD(200,0,"PT",9002325.01,8)
 ;;=
 ;;^DD(200,0,"PT",9002325.02,2)
 ;;=
 ;;^DD(200,0,"PT",9002325.02,26)
 ;;=
 ;;^DD(200,0,"PT",9002325.02,27)
 ;;=
 ;;^DD(200,0,"PT",9002325.1,.01)
 ;;=
 ;;^DD(200,0,"PT",9002325.12,.01)
 ;;=
 ;;^DD(200,0,"PT",9002325.4,2)
 ;;=
 ;;^DD(200,0,"PT",9002325.4,4)
 ;;=
 ;;^DD(200,0,"PT",9002325.5,1)
 ;;=
 ;;^DD(200,0,"PT",9002330,.08)
 ;;=
 ;;^DD(200,0,"PT",9002331.4,.01)
 ;;=
 ;;^DD(200,0,"PT",9002400.91,.01)
 ;;=
 ;;^DD(200,0,"PT",9002401,.02)
 ;;=
 ;;^DD(200,0,"PT",9003010,.03)
 ;;=
 ;;^DD(200,0,"PT",9009032.4,.03)
 ;;=
 ;;^DD(200,0,"PT",9009032.4,.04)
 ;;=
 ;;^DD(200,0,"PT",9009032.4,.11)
 ;;=
 ;;^DD(200,0,"SP",53.5)
 ;;=
 ;;^DD(200,0,"SP",9999999.01)
 ;;=
 ;;^DD(200,0,"SP",9999999.02)
 ;;=
 ;;^DD(200,53.5,0)
 ;;=PROVIDER CLASS^P7'^DIC(7,^PS;5^Q
 ;;^DD(200,53.5,1,0)
 ;;=^.1
 ;;^DD(200,53.5,1,1,0)
 ;;=200^AIHS^MUMPS
 ;;^DD(200,53.5,1,1,1)
 ;;=G F6S^AVA4A7
 ;;^DD(200,53.5,1,1,2)
 ;;=G F6K^AVA4A7
 ;;^DD(200,53.5,1,1,3)
 ;;=Gives provider key; updates entry in file 6
 ;;^DD(200,53.5,1,1,"%D",0)
 ;;=^^12^12^2940511^
 ;;^DD(200,53.5,1,1,"%D",1,0)
 ;;= 
 ;;^DD(200,53.5,1,1,"%D",2,0)
 ;;=     *** MUMPS X-REF "AIHS" CREATED BY INDIAN HEALTH SERVICE ***
 ;;^DD(200,53.5,1,1,"%D",3,0)
 ;;= 
 ;;^DD(200,53.5,1,1,"%D",4,0)
 ;;=MUST BE FIRST CROSS-REFERENCE FOR THIS FIELD!!! Creates entry in file 6.
 ;;^DD(200,53.5,1,1,"%D",5,0)
 ;;=All other x-refs on this field must be executed AFTER entry created in
 ;;^DD(200,53.5,1,1,"%D",6,0)
 ;;=file 6.
 ;;^DD(200,53.5,1,1,"%D",7,0)
 ;;= 
 ;;^DD(200,53.5,1,1,"%D",8,0)
 ;;=When you give a New Person entry a PROVIDER CLASS, they are then
 ;;^DD(200,53.5,1,1,"%D",9,0)
 ;;=designated as a provider.  This x-ref gives them the "PROVIDER" security
 ;;^DD(200,53.5,1,1,"%D",10,0)
 ;;=key.  The KEY field will create an entry in the Provider file if not
 ;;^DD(200,53.5,1,1,"%D",11,0)
 ;;=already there.  Then this x-ref will update all fields common to both
 ;;^DD(200,53.5,1,1,"%D",12,0)
 ;;=files by executing the set logic for all x-refs on this file.
 ;;^DD(200,53.5,1,1,"DT")
 ;;=2940511
 ;;^DD(200,53.5,1,2,0)
 ;;=200^ACX36^MUMPS
 ;;^DD(200,53.5,1,2,1)
 ;;=N % S %=$P(^DIC(3,DA,0),U,16) I %,$D(^DIC(6,%,0)) S $P(^DIC(6,%,0),U,4)=X
 ;;^DD(200,53.5,1,2,2)
 ;;=N % S %=$P(^DIC(3,DA,0),U,16) I %,$D(^DIC(6,%,0)) S $P(^DIC(6,%,0),U,4)=""

AVAPI005
AVAPI005 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 Q:'DIFQ(200)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(200,53.5,1,2,3)
 ;;=Used to keep files 6 & 200 in sync.
 ;;^DD(200,53.5,1,2,"DT")
 ;;=2940511
 ;;^DD(200,53.5,1,999999901,0)
 ;;=^^TRIGGER^200^9999999.09
 ;;^DD(200,53.5,1,999999901,1)
 ;;=K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^VA(200,D0,9999999)):^(9999999),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y X ^DD(200,53.5,1,999999901,1.1) X ^DD(200,53.5,1,999999901,1.4)
 ;;^DD(200,53.5,1,999999901,1.1)
 ;;=S X=DIV X $P(^DD(200,9999999.039,0),U,5,99) S Y(1)=X S X=Y(1)
 ;;^DD(200,53.5,1,999999901,1.4)
 ;;=S DIH=$S($D(^VA(200,DIV(0),9999999)):^(9999999),1:""),DIV=X S $P(^(9999999),U,9)=DIV,DIH=200,DIG=9999999.09 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
 ;;^DD(200,53.5,1,999999901,2)
 ;;=K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^VA(200,D0,9999999)):^(9999999),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X="" X ^DD(200,53.5,1,999999901,2.4)
 ;;^DD(200,53.5,1,999999901,2.4)
 ;;=S DIH=$S($D(^VA(200,DIV(0),9999999)):^(9999999),1:""),DIV=X S $P(^(9999999),U,9)=DIV,DIH=200,DIG=9999999.09 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
 ;;^DD(200,53.5,1,999999901,"CREATE VALUE")
 ;;=IHS ADC
 ;;^DD(200,53.5,1,999999901,"DELETE VALUE")
 ;;=@
 ;;^DD(200,53.5,1,999999901,"DT")
 ;;=2930517
 ;;^DD(200,53.5,1,999999901,"FIELD")
 ;;=IHS ADC INDEX
 ;;^DD(200,53.5,3)
 ;;=Enter provider class of provider (MD, PA etc).
 ;;^DD(200,53.5,20,0)
 ;;=^.3LA^1^1
 ;;^DD(200,53.5,20,1,0)
 ;;=PS
 ;;^DD(200,53.5,21,0)
 ;;=^^1^1^2920930^
 ;;^DD(200,53.5,21,1,0)
 ;;=This field is used to show the provider class.
 ;;^DD(200,53.5,23,0)
 ;;=^^1^1^2920930^
 ;;^DD(200,53.5,23,1,0)
 ;;=pointer.
 ;;^DD(200,53.5,"DT")
 ;;=2940511
 ;;^DD(200,9999999.09,0)
 ;;=IHS ADC INDEX^FX^^9999999;9^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>6!($L(X)<4) X I $D(X),$D(^DIC(6,"GIHS",X)),'$D(^DIC(6,"GIHS",X,DA)) K X W:'$D(ZTQUEUED) "  THAT AFFIL-DISC-CODE ALREADY USED! "
 ;;^DD(200,9999999.09,1,0)
 ;;=^.1
 ;;^DD(200,9999999.09,1,1,0)
 ;;=200^ACXIHS09^MUMPS
 ;;^DD(200,9999999.09,1,1,1)
 ;;=N % S %=$P(^DIC(3,DA,0),U,16) I %]"" S:'$D(^DIC(6,%,9999999)) ^DIC(6,%,9999999)="" S $P(^(9999999),U,9)=X
 ;;^DD(200,9999999.09,1,1,2)
 ;;=N % S %=$P(^DIC(3,DA,0),U,16) I %]"",$D(^DIC(6,%,9999999)) S $P(^(9999999),U,9)=""
 ;;^DD(200,9999999.09,1,1,"DT")
 ;;=2930519
 ;;^DD(200,9999999.09,1,2,0)
 ;;=200^GIHS
 ;;^DD(200,9999999.09,1,2,1)
 ;;=S ^VA(200,"GIHS",$E(X,1,30),DA)=""
 ;;^DD(200,9999999.09,1,2,2)
 ;;=K ^VA(200,"GIHS",$E(X,1,30),DA)
 ;;^DD(200,9999999.09,1,2,"DT")
 ;;=2930518
 ;;^DD(200,9999999.09,3)
 ;;=Answer must be 4-6 characters in length.
 ;;^DD(200,9999999.09,5,1,0)
 ;;=200^53.5^999999901
 ;;^DD(200,9999999.09,5,2,0)
 ;;=200^9999999.01^2
 ;;^DD(200,9999999.09,5,3,0)
 ;;=200^9999999.02^3
 ;;^DD(200,9999999.09,9)
 ;;=^
 ;;^DD(200,9999999.09,"DT")
 ;;=2930519

AVAPI006
AVAPI006 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 I DSEC F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DIC(200,0,"DD")
 ;;=#
 ;;^DIC(200,0,"DEL")
 ;;=#
 ;;^DIC(200,0,"LAYGO")
 ;;=#
 ;;^DIC(200,0,"RD")
 ;;=#
 ;;^DIC(200,0,"WR")
 ;;=#

AVAPI007
AVAPI007 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"PKG",341,0)
 ;;=PATCHES FOR VA SUPPPORT FILES^AVAP^PATCHES FOR VA SUUPORT FILES
 ;;^UTILITY(U,$J,"PKG",341,4,0)
 ;;=^9.44PA^1^1
 ;;^UTILITY(U,$J,"PKG",341,4,1,0)
 ;;=200
 ;;^UTILITY(U,$J,"PKG",341,4,1,1,0)
 ;;=^9.45A^2^2
 ;;^UTILITY(U,$J,"PKG",341,4,1,1,1,0)
 ;;=PROVIDER CLASS
 ;;^UTILITY(U,$J,"PKG",341,4,1,1,2,0)
 ;;=IHS ADC INDEX
 ;;^UTILITY(U,$J,"PKG",341,4,1,1,"B","IHS ADC INDEX",2)
 ;;=
 ;;^UTILITY(U,$J,"PKG",341,4,1,1,"B","PROVIDER CLASS",1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",341,4,1,222)
 ;;=y
 ;;^UTILITY(U,$J,"PKG",341,4,"B",200,1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",341,22,0)
 ;;=^9.49I^1^1
 ;;^UTILITY(U,$J,"PKG",341,22,1,0)
 ;;=93.2^2950815^2950815
 ;;^UTILITY(U,$J,"PKG",341,22,"B",93.2,1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",341,"INIT")
 ;;=AVAPPOST^
 ;;^UTILITY(U,$J,"SBF",200,200)
 ;;=

AVAPINI1
AVAPINI1 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 ; LOADS AND INDEXES DD'S
 ;
 K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1
 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q
ASK I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q
 Q:'$D(DIFQ)  S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q
 I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0  S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2
 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD
 S DN="^AVAPI" F R=1:1:7 D @(DN_$$B36(R)) W "."
 F  S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0  K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0  K ^(D) D IX
DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0
 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0))  S Z=^(0) D I^DITR
 K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA
 ;
W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0))
 S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W
 S:%=2 DIFQ(X)=0 K:%<0 DIFQ
 Q
 ;
OPT ;OPTION
RTN ;ROUTINE DOCUMENTATION NOTE
FUN ;FUNCTION
BUL ;BULLETIN
KEY ;SECURITY KEY
HEL ;HELP FRAME
DIP ;PRINT TEMPLATE
DIE ;INPUT TEMPLATE
DIB ;SORT TEMPLATE
DIS ;SCREEN TEMPLATE
 ;
SBF ;FILE AND SUB FILE NUMBERS
IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK=""  K ^(DIK)
 S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
 I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK
 Q
B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)
N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)
MSG ;
 I $P(^XMB(3.9,XMZ,0),U,7)'="X" Q
 S X=$S($D(^XMB(3.9,XMZ,2,XCN,0)):^(0),1:"") Q:X=""
M0 D M1 Q:$P(X,"$END MESSAGE")=""  D SAVE,NT G M0
NT S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:XCN'?1.N  S X=^(XCN,0) Q
SAVE D NT Q:$E(X)="$"  S Y=X D NT Q:$E(X)="$"
 I $A(X)=126 S A0=X D NT S X=A0_$E(X,2,999) K A0
 S:% @Y=$E(X,2,999) G SAVE
 Q
M1 S Y=$E(X,2,4),%=0 I Y="DDD" S D=+$P(X,"(#",2),%=DIFQ(D) Q:D  S:$P(X,"(#",2)["FILE SECURITY" %=DSEC Q
 Q:Y="END"
 I Y="DTA" S %=DIFQR(D) Q
 I (Y="OR ")!(Y="PKG") S %=1 Q
 I $T(@Y)]"" S %=1 Q
 Q

AVAPINI2
AVAPINI2 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 ;
 ;
 K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5
 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD
 Q
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0  S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR
 S DIK=DIC
HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R=""  W !,"'"_R_"' Help Frame filed." S DA=^(R)
 F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99)
 S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X  I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0)
 I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I
IX D IX1^DIK G HELP
 ;
U I $D(DIRUT) S DIFQ=1
 W ! Q
REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF
 S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT)
 I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q
 S DIR("A")="Shall I replace your file with mine"
 S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y
 S DIU(0)="E",DIR("A")="Do you want to keep the Data"
 S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT)
 S:'Y DIU(0)=DIU(0)_"D"
 S DIR("A")="Do you want to keep the Templates"
 S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T"
 S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q

AVAPINI3
AVAPINI3 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 ;
 ;
 K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0))
 S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X=""  W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins."
 I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD
 G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT
 I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=%
OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^AVAPINI4
NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP
 I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J)
 I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD
 S DIC=.5,DLAYGO=0,N="FUN" D ADD
 S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD
 K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD
 S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD
 K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ
 K ^UTILITY("DIFROM",$J) Q
DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
 E  S DISYS=^DD("OS")
 Q:'$D(^DD("OS",DISYS,"ZS"))
 S DIFR1=""
DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1=""
 F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
 G DZ1
 ;
OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q
 W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP
 I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=%
 S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
 S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0
 D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C")
 F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X
 S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R=""  S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A
Q Q
A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'%  S %(%)=$G(^(%,0))
 K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^")
 I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'%  S @(DIC_"+Y,2,%,0)")=%(%)
 I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_" template "_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" not on your system!"
 I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1)
 I N="DIST(.403," D BLK
 S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR
 D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT
 Q
BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J  I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1
 K A0,A1,A2,J,L Q
B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L  S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0
 S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0=""  K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0
 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L  S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1
 S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK")
 Q
KAD(D0) N D1,X
 S X=0 F  S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0  S D1=0 F  S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0  K ^DIC(19,"AD",X,D0,D1)
 Q

AVAPINI4
AVAPINI4 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 ;
 ;
EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK
 S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_","
 S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1)
 D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4)
 I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=%
 D OR
 S DA(1)=1 D IX1^DIK
 Q
OR S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N  S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1
 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N  S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1
 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J
 Q
OR1 N X F  S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R  S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1
 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J
 Q
ADDP N I,J,N,R,DA,DLAYGO S %=""
 S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1  S %=+Y Q

AVAPINI5
AVAPINI5 ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:2 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1
 Q
IXF ;;PATCHES FOR VA SUPPPORT FILES^AVAP
 ;;200;NEW PERSON;^VA(200,;1;y
 ;;

AVAPINIS
AVAPINIS ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
PAC(PKG,VER) ; called from package init (DIFROM7 created this routine)
 ; PKG = $T(IXF) of the INIT routine.
 ; VER is an array that is contained in DIFROM from the INIT routine
 ;
 N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("AVAPINIS",$J)
 ;
 ; Site tracking updates only occur if run in a VA production primary domain
 ; account.
 I $G(^XMB("NETNAME"))'[".VA.GOV" Q
 Q:'$D(^%ZOSF("UCI"))  Q:'$D(^%ZOSF("PROD"))
 X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q
 ;
 S SERVER="S.A5CSTS@FORUM.VA.GOV"
 S PACKAGE=$P($P(PKG,";",3),U)
 S SITE=$G(^XMB("NETNAME"))
 S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown"
 D  ; check if ok to use kernel functions
 .S X="XLFDT" X ^%ZOSF("TEST") I $T D  Q
 ..S NOW=$$HTFM^XLFDT($H)
 ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3)
 ..S START=$$FMTE^XLFDT(START)
 ..S DATE=NOW\1
 ..S NOW=$$FMTE^XLFDT(NOW)
 .D NOW^%DTC S NOW=%,DATE=X
 .S RUN="" ; don't bother to compute
 .S Y=START D DD^%DT S START=Y
 .S Y=NOW D DD^%DT S NOW=Y
 ;
 ; Message for server
 S ^TMP("AVAPINIS",$J,1,0)="PACKAGE INSTALL"
 S ^TMP("AVAPINIS",$J,2,0)="SITE: "_SITE
 S ^TMP("AVAPINIS",$J,3,0)="PACKAGE: "_PACKAGE
 S ^TMP("AVAPINIS",$J,4,0)="VERSION: "_VER
 S ^TMP("AVAPINIS",$J,5,0)="Start time: "_START
 S ^TMP("AVAPINIS",$J,6,0)="Completion time: "_NOW
 S ^TMP("AVAPINIS",$J,7,0)="Run time: "_RUN
 S ^TMP("AVAPINIS",$J,8,0)="DATE: "_DATE
 ;
 ; Data is sent to server on FORUM - S.A5CSTS
 S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""AVAPINIS"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION"
 D ^XMD
 K ^TMP("AVAPINIS",$J)
 Q

AVAPINIT
AVAPINIT ; ; 15-AUG-1995
 ;;93.2;PATCHES FOR VA SUPPPORT FILES;;AUG 15, 1995
 ;
 K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT
 S U="^",DIFQ=0,DIFROM="93.2" W !,"This version (#93.2) of 'AVAPINIT' was created on 15-AUG-1995"
 W !?9,"(at DSDHQ1/DEV, by VA FileMan V.20.0)",!
 I $D(^DD("VERSION")),^("VERSION")'<20 G GO
 W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT
 I ^DD("VERSION")<20 W !,"BUT I NEED VERSION 20 OF THE VA FILEMAN!" G Q
GO ;
EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM
 S DIFQ=0 K DIRUT,DTOUT,DUOUT
 F DIFRIR=1:1:1 S DIFRRTN="^AVAPINI"_$E("5",DIFRIR) D @DIFRRTN
 W:1 !,"I AM GOING TO SET UP THE FOLLOWING FILES:" F I=1:2:2 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I)
 S DIFROM="93.2" D PKG:'$D(DIFROM(0)),^AVAPINI1 G Q:'$D(DIFQ) S DIK(0)="AB"
 F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N)
 K DIFQR D ^AVAPINI2,^AVAPINI3
 L  S DUZ=DIDUZ W:1 !,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE"
 D ^AVAPPOST,NOW^%DTC S DIFROM("INIT")=%
 I DIFROM F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM
 I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%)
 I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN
 I DIFROM,$D(^%ZTSK) S X="AVAPINIS" X ^%ZOSF("TEST") D:$T PAC^AVAPINIS($T(IXF),.DIFROM)
 S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0
D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U)
 S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ
 I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "."
 Q
R G REP^AVAPINI2
 ;
1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5)
 W !!?3,N,?13,DIF,$P("  (Partial Definition)",U,$P(DIF(I),";",6)),$P("  (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"")
 I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S
 I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ  G S:$D(DIFKEP(N)),1
 S DIFQ(N)=$P(DIF(I),";",7)'="n"
 I $L(Z) W $C(7),!,"Note:  You already have the '",$P(Z,U),"' File." S DIFQ(0)=1
 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S
 I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y
S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT)
 I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q
 S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1
 Q
Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0
 ;
PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC
 Q
 ;
IXF ;;PATCHES FOR VA SUPPPORT FILES^AVAP;0
ERX W $C(7),!!,"This INIT was built as a Network Mail Message and can ONLY be installed",!,"within the Mail system!!" G Q

AVAPPOST
AVAPPOST ;IHS/ORDC/LJF - POSTINIT TO DELETE AVAP PACKAGE ENTRY; [ 08/25/95  1:18 PM ]
 ;;93.2;VA SUPPORT FILES;;**6**;JUL 01, 1993
 ;
 ; delete package entry with namespace of AVAP
 ; FELS used as scratch package to send files, templates,etc.
 S DA=$O(^DIC(9.4,"C","AVAP",0)) Q:DA=""
 W !!,"DELETING 'AVAP' PACKAGE ENTRY. . . ",!
 S DIK="^DIC(9.4," D ^DIK
 K DA,DIK Q