10:16 AM  9-DEC-99
AUM v 99.1 Patch 10, 1999Dec01 SCB, etc.  Restore 7 routines and DO ^AUM9110.
A9AUM10
A9AUM10 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999DEC01, RPI ; [ 12/09/1999  10:15 AM ]
 ;;99.1;TABLE MAINTENANCE;**10**;NOV 6,1998
 ;
 D START^AUM9110
INTERACT ;EP - Delete routines from interactive call.
 Q:'$L($G(^%ZOSF("DEL")))
 NEW AUM,X
 F AUM=1:1 S X=$P($T(DEL+AUM),";",3) Q:X=""  X ^%ZOSF("DEL") I '$D(ZTQUEUED) W !,X,$E("...........",1,11-$L(X)),"<poof'd>"
 Q
 ;
DEL ;     
 ;;A9AUM9
 ;;AUM9110
 ;;AUM91101
 ;;AUM9110A
 ;;AUM9110M

AUM9110
AUM9110 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999DEC01 ; [ 12/09/1999  10:15 AM ]
 ;;99.1;TABLE MAINTENANCE;**10**;NOV 6,1998
 ;
 I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
 D HOME^%ZIS,DT^DICRW,HELP("INTRO")
 S (DIR(0),DIR("B"))="Y"
 S DIR("A")="Do you want to queue the update to TaskMan"
 S DIR("??")="^D HELP^AUM9110(""Q2"")"
 D ^DIR
 KILL DIR
 I $D(DIRUT) D HELP("Q2") Q
 G START:'Y
QUE ;
 S %DT="AERSX",%DT("A")="Requested Start Time: ",%DT("B")="T@2015",%DT(0)="NOW"
 D ^%DT
 I Y<1 W !,"QUEUE INFORMATION MISSING - NOT QUEUED" D HELP("Q2") G AUM9110
 S X=+Y
 D H^%DTC
 S ZTDTH=%H_","_%T
 S ZTRTN="START^AUM9110",ZTIO="",ZTDESC=$P($P($T(+1),";",2)," ",4,99)
 D ^%ZTLOAD,HOME^%ZIS
 I $D(ZTSK) W !!,"QUEUED TO TASK ",ZTSK,!!,"A mail message with the results will be sent to your MailMan 'IN' basket.",!
 E  W !!,*7,"QUEUE UNSUCCESSFUL.  RESTART UTILITY."
 Q
 ;
START ;EP - From Taskman
 ;
 NEW XMSUB,XMDUZ,XMTEXT,XMY
 KILL ^TMP("AUM9110",$J)
 D START^AUM91101,START^AUM91102
 S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AUM9110"",$J,",XMY(DUZ)=""
 F %="XUPROGMODE","AG TM MENU","ABMDZ TABLE MAINTENANCE","APCCZMGR" D SINGLE(%)
 D ^XMD
 KILL ^TMP("AUM9110",$J)
 I $D(ZTQUEUED) S ZTREQ="@" Q
 W !!,"The results are in your MailMan 'IN' basket.",!
 I $L($T(DIR^XBDIR)),$$DIR^XBDIR("Y","Want me to delete the routines in this patch","Y") G INTERACT^A9AUM10
 Q
 ;
INTRO ;EP - To write to mail message, too.
 ;;This updates standard tables according to the changes specified in
 ;;the message time stamped 01Dec99  3:43PM.  Please consult that message,
 ;;and the mail message produced by this update.                       
 ;;  
 ;;Additionally:
 ;;  * 11 Health Factors are added;
 ;;  * the entry in the DIAGNOSTIC PROCEDURE RESULT file is mod'd;
 ;;  * routine AUMXPORT is mod'd to -not- export deleted or inactive
 ;;    patients after a change to Location or Community codes.
 ;;        NOTE:  Patients must still be exported to NPIRS after
 ;;               changes to Location or Community *CODES*, in order
 ;;               for epidemiological data to be correct.
 ;;  
 ;;###
 ;
Q2 ;
 ;;Answer "Y" if you want to queue this standard table update to TaskMan.
 ;;Answer "N" if you want to run this update interactively.
 ;;
 ;;If you run interactively, results will be displayed on your screen,
 ;;as well as in the mail message sent to you and user 1.  If you queue
 ;;to TaskMan, please read the mail message for results of this update.
 ;;###
 ;
HELP(L) ;EP - Display text at label L.
 W !
 F %=1:1 W !?4,$P($T(@L+%),";",3) Q:$P($T(@L+%+1),";",3)="###"
 Q
 ;
SINGLE(K) ; Get holders of a single key K.
 NEW Y
 S Y=0
 Q:'$D(^XUSEC(K))
 F  S Y=$O(^XUSEC(K,Y)) Q:'Y  S XMY(Y)=""
 Q
 ;

AUM91101
AUM91101 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999DEC01 ; [ 12/09/1999  10:15 AM ]
 ;;99.1;TABLE MAINTENANCE;**10**;NOV 6,1998
 ;;  
 ;;Greetings.
 ;;Standard tables on your RPMS system have been updated.
 ;;  
 ;;You are receiving this message because of the particular security
 ;;keys that you hold.  This is for your information, only.  You
 ;;need do nothing in response to this message.
 ;;  
 ;;Requests for modifications or additions to RPMS standard tables can
 ;;be submitted to your Area Information System Coordinator (ISC).
 ;;  
 ;;###
 ;
 Q
 ;
START ;EP
 ;
 NEW A,C,DIC,DIE,DINUM,DLAYGO,DR,E,L,M,N,O,P,R,S,T
 ;
 S E(0)="ERROR : ",E(1)="NOT ADDED : "
 D RSLT($J("",5)_$P($T(UPDATE^AUM9110A),";",3))
 F %=4:1 D RSLT($P($T(+%),";",3)) Q:$P($T(+%+1),";",3)="###"
 F %=1:1 D RSLT($P($T(INTRO+%^AUM9110),";",3)) Q:$P($T(INTRO+(%+1)^AUM9110),";",3)="###"
 D DASH,LOCNEW,DASH,LOCMOD,DASH,COMMNEW,DASH,COMMMOD,DASH
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDOK D RSLT($J("",5)_"Added : "_L) Q
ADDFAIL D RSLT($J("",5)_E(0)_"ADD FAILED => "_L) Q
DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("") Q
DIE NEW A,C,E,L,M,N,O,P,R,S,T
 LOCK +(@(DIE_DA_")")):10 E  D RSLT($J("",5)_E(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.") S Y=1 Q
 D ^DIE LOCK -(@(DIE_DA_")")) KILL DA,DIE,DR Q
E(L) Q $P($P($T(@L^AUM9110A),";",3),":",1)
IEN(X,%,Y) ;
 S Y=$O(@(X_"""C"",%,0)"))
 I 'Y S Y=$$VAL^AUM9110M(X,%) I Y NEW Z S Z=E D  S:Y<0 Y="" S E=Z
 . NEW A,C,L,M,N,O,P,R,S,V,%
 . S L=Y
 . I X["AREA" NEW X D RSLT("(Add Missing Area)") D ADDAREA D RSLT("(END Add Missing Area)") Q
 . I X["SU" NEW X D RSLT("(Add Missing SU)") D ADDSU D RSLT("(END Add Missing SU)") Q
 . I X["CTY" NEW X D RSLT("(Add Missing County)") D ADDCNTY D RSLT("(END Add Missing County)") Q
 .Q
 D:'Y RSLT($J("",5)_E(0)_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
 Q +Y
DIK NEW A,C,E,L,M,N,O,P,R,S,T D ^DIK KILL DIK Q
FILE NEW A,C,E,L,M,N,O,P,R,S,T K DD,DO S DIC(0)="L" D FILE^DICN KILL DIC Q
MODOK D RSLT($J("",5)_"Changed : "_L) Q
RSLT(%) S ^(0)=$G(^TMP("AUM9110",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ; Return 0th node.  A is file #, rest fields.
 I '$G(A) Q -1
 I '$G(B) Q -1
 F %=67:1:75 Q:'$G(@($C(%)))  S A=+$P(^DD(A,B,0),U,2),B=@($C(%))
 I 'A!('B) Q -1
 I '$D(^DD(A,B,0)) Q -1
 Q U_$P(^DD(A,B,0),U,2)
 ;
 ; -----------------------------------------------------
 ;
ADDAREA ; PROGRAMMER NOTE:  This s/r is required for every patch.
 S L=$P(L,";;",2),A=$P(L,U),N=$P(L,U,2),R=$P(L,U,3),C=$P(L,U,4),L=A_" "_N_" "_R_" "_C
 I $D(^AUTTAREA("B",N)) D RSLT($J("",5)_E(1)_"NAME EXISTS => "_N) Q
 I $D(^AUTTAREA("C",A)) D RSLT($J("",5)_E(1)_"CODE EXISTS => "_A) Q
 S DLAYGO=9999999.21,DIC="^AUTTAREA(",X=N,DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDCNTY ; PROGRAMMER NOTE:  This s/r is required for every patch.
 S L=$P(L,";;",2),S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3),L=S_" "_C_" "_N
 I $D(^AUTTCTY("C",S_C)) D RSLT($J("",5)_E(1)_"CODE EXISTS => "_S_C) Q
 S P("S")=$$IEN("^DIC(5,",S)
 Q:'P("S")
 S DIC="^AUTTCTY(",X=N,DIC("DR")=".02////"_P("S")_";.03///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
SUNEW ;
 D RSLT($$E("SUNEW"))
 D RSLT($J("",13)_"AA SU NAME")
 D RSLT($J("",13)_"-- -- ----")
 F T=1:1 S L=$T(SUNEW+T^AUM9110A) Q:$P(L,";",3)="END"  D ADDSU
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDSU ; PROGRAMMER NOTE:  This s/r is required for every patch.
 S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3),L=A_" "_S_" "_N
 I $D(^AUTTSU("C",A_S)) D RSLT($J("",5)_E(1)_"ASU EXISTS => "_A_S) Q
 S P=$$IEN("^AUTTAREA(",A)
 Q:'P
 S DLAYGO=9999999.22,DIC="^AUTTSU(",X=N,DIC("DR")=".02////"_P_";.03///"_S
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
LOCNEW ;
 S E=$$E("LOCNEW")
 D RSLT(E)
 D RSLT($J("",13)_"AA SU FA NAME"_$J("",28)_"PSEUDO")
 D RSLT($J("",13)_"-- -- -- ----"_$J("",28)_"------")
 F T=1:1 S L=$T(LOCNEW+T^AUM9110A) Q:$P(L,";",3)="END"  D ADDLOC
 Q
 ;
ADDLOC ;
 S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3),N=$P(L,U,4),P=$P(L,U,5)
 S L=A_" "_S_" "_F_" "_N_$J("",32-$L(N))_P
 S %=A_S_F,%=$O(^AUTTLOC("C",%,0))
 I % D RSLT($J("",5)_E(1)_"ASUFAC EXISTS => "_A_S_F) D  Q
 . I $P($G(^AUTTLOC(%,0)),U,21) S DIE="^AUTTLOC(",DA=%,DR=".27///@" D DIE D:$D(Y) RSLT($J("",5)_E(0)_"DELETE INACTIVE DATE FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"INACTIVE DATE DELETED => "_L)
 . S %=$O(^AUTTLOC("C",A_S_F,0)),%=$P(^AUTTLOC(%,0),U)
 . I %,$D(^DIC(4,%,0)),N'=$P(^DIC(4,%,0),U) S DIE="^DIC(4,",DA=%,DR=".01///"_N D DIE D:$D(Y) RSLT($J("",5)_E(0)_"EDIT INSTITUTION FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"INSTITUTION NAME UPDATED => "_L)
 . S %=$O(^AUTTLOC("C",A_S_F,0))
 . I P'=$P($G(^AUTTLOC(%,1)),U,2) S DIE="^AUTTLOC(",DA=%,DR=".31///"_P D DIE D:$D(Y) RSLT($J("",5)_E(0)_"EDIT PSEUDO PREFIX FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"PSEUDO PREFIX UPDATED => "_L)
 .Q
 S P("A")=$$IEN("^AUTTAREA(",A)
 Q:'P("A")
 S P("S")=$$IEN("^AUTTSU(",A_S)
 Q:'P("S")
 F DINUM=+$P(^DIC(4,0),U,3):1 Q:'$D(^DIC(4,DINUM))&('$D(^AUTTLOC(DINUM)))  I DINUM>99999 D RSLT($J("",5)_E(0)_"DINUM FOR LOC/INSTITUTION TOO BIG. NOTIFY ISC.") Q
 Q:DINUM>99999
 S DLAYGO=4,DIC="^DIC(4,",X=N
 D FILE
 KILL DINUM,DLAYGO
 I Y<0 D RSLT($J("",5)_E(0)_"^DIC(4 ADD FAILED => "_L) Q
 S DINUM=+Y,DLAYGO=9999999.06,DIC="^AUTTLOC(",X=DINUM,DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.31///"_P
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DINUM,DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
LOCMOD ;
 S E=$$E("LOCMOD")
 D RSLT(E)
 D RSLT($J("",15)_"AA SU FA NAME"_$J("",28)_"PSEUDO")
 D RSLT($J("",15)_"-- -- -- ----"_$J("",28)_"------")
 F T=1:2 S L=$T(LOCMOD+T^AUM9110A) Q:$P(L,";",3)="END"  S L("TO")=$T(LOCMOD+T+1^AUM9110A) D
 . S L=$P(L,U,2,99),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3)
 . S P=$O(^AUTTLOC("C",A_S_F,0))
 . S L=$P(L("TO"),U,2,99),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3),N=$P(L,U,4)
 . I 'P S P=$O(^AUTTLOC("C",A_S_F,0)) I 'P S L=";;"_L D ADDLOC Q
 . S L=A_" "_S_" "_F_" "_N_$J("",32-$L(N))_$P(L("TO"),U,6)
 . S P("A")=$$IEN("^AUTTAREA(",A)
 . Q:'P("A")
 . S P("S")=$$IEN("^AUTTSU(",A_S)
 . Q:'P("S")
 . S DIE="^AUTTLOC(",DA=P,DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.31///"_$P(L("TO"),U,6)
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT LOCATION FAILED => "_L) Q
 . S DIE="^DIC(4,",DA=$P(^AUTTLOC(P,0),U),DR=".01///"_N
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT INSTITUTION FAILED => "_L) Q
 . D MODOK
 .Q
 ; If Locations were name changes, only, following line commented.
 D DASH,RSLT($$LOCMOD^AUMXPORT("AUM9110A")_" patients marked for export because of the Location Code changes."),XPORT
 ;
 Q
 ;
 ; -----------------------------------------------------
 ;
 ;
COMMNEW ;
 D RSLT($$E("COMMNEW"))
 D RSLT($J("",13)_"ST CT COM NAME"_$J("",28)_"AA SU")
 D RSLT($J("",13)_"-- -- --- ----"_$J("",28)_"-- --")
 F T=1:1 S L=$T(COMMNEW+T^AUM9110A) Q:$P(L,";",3)="END"  D ADDCOMM
 Q
 ;
ADDCOMM ;
 S L=$P(L,";;",2),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),N=$P(L,U,4),A=$P(L,U,5),V=$P(L,U,6),L=S_" "_O_" "_C_" "_N_$J("",32-$L(N))_A_" "_V
 I $D(^AUTTCOM("C",S_O_C)) D RSLT($J("",5)_E(1)_"STCTYCOM CODE EXISTS => "_S_O_C) Q
 S P("O")=$$IEN("^AUTTCTY(",S_O)
 Q:'P("O")
 S P("A")=$$IEN("^AUTTAREA(",A)
 Q:'P("A")
 S P("V")=$$IEN("^AUTTSU(",A_V)
 Q:'P("V")
 S DLAYGO=9999999.05,DIC="^AUTTCOM(",X=N,DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
COMMMOD ;
 D RSLT($$E("COMMMOD"))
 D RSLT($J("",15)_"ST CT COM NAME"_$J("",28)_"AA SU")
 D RSLT($J("",15)_"-- -- --- ----"_$J("",28)_"-- --")
 F T=1:2 S L=$T(COMMMOD+T^AUM9110A) Q:$P(L,";",3)="END"  S L("TO")=$T(COMMMOD+T+1^AUM9110A) D
 . S L=$P(L,U,2,99),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3)
 . S P=$O(^AUTTCOM("C",S_O_C,0))
 . S L=$P(L("TO"),U,2,99),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),N=$P(L,U,4),A=$P(L,U,5),V=$P(L,U,6)
 . I 'P S P=$O(^AUTTCOM("C",S_O_C,0)) I 'P S L=";;"_L D ADDCOMM Q
 . S L=S_" "_O_" "_C_" "_N_$J("",32-$L(N))_A_" "_V
 . S P("O")=$$IEN("^AUTTCTY(",S_O)
 . Q:'P("O")
 . S P("A")=$$IEN("^AUTTAREA(",A)
 . Q:'P("A")
 . S P("V")=$$IEN("^AUTTSU(",A_V)
 . Q:'P("V")
 . S DIE="^AUTTCOM(",DA=P,DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"CHANGE FAILED => "_L) Q
 . D MODOK
 .Q
 ;
 ; Line below is comment'd if the only change is to the name of the community.
 D DASH,RSLT($$COMMMOD^AUMXPORT("AUM9110A")_" patients marked for export because of the Community Code changes."),XPORT
 ;
 Q
 ;
 ; -----------------------------------------------------
 ;
XPORT ;
 F %=3:1:10 D RSLT($P($T(XPORT+%),";",3))
 Q
 ;;  NOTE:  Patients whose Community code or Location code is changed
 ;;         must be exported, in order to correct the information on
 ;;         file in the national epidemiological data repository in
 ;;         the National Patient Information Reporting System (NPIRS).
 ;;         This patch has modified routine AUMXPORT to *not* export
 ;;         deleted or inactive patients.
 ;;         If the change to the Community or Location is only to the
 ;;         name, no exporting will occur.
 ;;

AUM91102
AUM91102 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999DEC01 ; [ 12/09/1999  10:15 AM ]
 ;;99.1;TABLE MAINTENANCE;**10**;NOV 6,1998
 ;
 Q
 ;
START ;EP
 ;
 NEW A,C,DIC,DIE,DINUM,DLAYGO,DR,E,L,M,N,O,P,R,S,T
 ;
 S E(0)="ERROR : ",E(1)="NOT ADDED : "
 D TRIBNEW,DASH,HFADD,DASH,DXPRMOD,DASH
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDOK D RSLT($J("",5)_"Added : "_L) Q
ADDFAIL D RSLT($J("",5)_E(0)_"ADD FAILED => "_L) Q
DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("") Q
DIE NEW A,C,E,L,M,N,O,P,R,S,T
 LOCK +(@(DIE_DA_")")):10 E  D RSLT($J("",5)_E(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.") S Y=1 Q
 D ^DIE LOCK -(@(DIE_DA_")")) KILL DA,DIE,DR Q
E(L) Q $P($P($T(@L^AUM9110A),";",3),":",1)
IEN(X,%,Y) ;
 S Y=$O(@(X_"""C"",%,0)"))
 I 'Y S Y=$$VAL^AUM9110M(X,%) I Y NEW Z S Z=E D  S:Y<0 Y="" S E=Z
 . NEW A,C,L,M,N,O,P,R,S,V,%
 . S L=Y
 . I X["AREA" NEW X D RSLT("(Add Missing Area)") D ADDAREA D RSLT("(END Add Missing Area)") Q
 . I X["SU" NEW X D RSLT("(Add Missing SU)") D ADDSU D RSLT("(END Add Missing SU)") Q
 . I X["CTY" NEW X D RSLT("(Add Missing County)") D ADDCNTY D RSLT("(END Add Missing County)") Q
 .Q
 D:'Y RSLT($J("",5)_E(0)_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
 Q +Y
DIK NEW A,C,E,L,M,N,O,P,R,S,T D ^DIK KILL DIK Q
FILE NEW A,C,E,L,M,N,O,P,R,S,T K DD,DO S DIC(0)="L" D FILE^DICN KILL DIC Q
MODOK D RSLT($J("",5)_"Changed : "_L) Q
RSLT(%) S ^(0)=$G(^TMP("AUM9110",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ; Return 0th node.  A is file #, rest fields.
 I '$G(A) Q -1
 I '$G(B) Q -1
 F %=67:1:75 Q:'$G(@($C(%)))  S A=+$P(^DD(A,B,0),U,2),B=@($C(%))
 I 'A!('B) Q -1
 I '$D(^DD(A,B,0)) Q -1
 Q U_$P(^DD(A,B,0),U,2)
 ;
 ; -----------------------------------------------------
 ;
ADDAREA ; PROGRAMMER NOTE:  This s/r is required for every patch.
 S L=$P(L,";;",2),A=$P(L,U),N=$P(L,U,2),R=$P(L,U,3),C=$P(L,U,4),L=A_" "_N_" "_R_" "_C
 I $D(^AUTTAREA("B",N)) D RSLT($J("",5)_E(1)_"NAME EXISTS => "_N) Q
 I $D(^AUTTAREA("C",A)) D RSLT($J("",5)_E(1)_"CODE EXISTS => "_A) Q
 S DLAYGO=9999999.21,DIC="^AUTTAREA(",X=N,DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDCNTY ; PROGRAMMER NOTE:  This s/r is required for every patch.
 S L=$P(L,";;",2),S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3),L=S_" "_C_" "_N
 I $D(^AUTTCTY("C",S_C)) D RSLT($J("",5)_E(1)_"CODE EXISTS => "_S_C) Q
 S P("S")=$$IEN("^DIC(5,",S)
 Q:'P("S")
 S DIC="^AUTTCTY(",X=N,DIC("DR")=".02////"_P("S")_";.03///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDSU ; PROGRAMMER NOTE:  This s/r is required for every patch.
 S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3),L=A_" "_S_" "_N
 I $D(^AUTTSU("C",A_S)) D RSLT($J("",5)_E(1)_"ASU EXISTS => "_A_S) Q
 S P=$$IEN("^AUTTAREA(",A)
 Q:'P
 S DLAYGO=9999999.22,DIC="^AUTTSU(",X=N,DIC("DR")=".02////"_P_";.03///"_S
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL DLAYGO
 Q
 ;
 ; -----------------------------------------------------
 ;
HFADD ;
 D RSLT($$E("HFADD"))
 F T=1:1 S L=$T(HFADD+T^AUM9110A) Q:$P(L,";",3)="END"  D ADDHF
 KILL DLAYGO
 Q
 ;
ADDHF ;
 S L=$P(L,";;",2),N=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),R=$P(L,U,4),S=$P(L,U,5),L=N_" "_O_"  "_C_"  "_R_"  "_S
 I $D(^AUTTHF("B",N)) D RSLT($J("",5)_E(1)_"HEALTH FACTOR EXISTS => "_N) Q
 S DLAYGO=9999999.64,DIC="^AUTTHF(",X=N,DIC("DR")=".02///"_O_";.03///"_C_";.08///"_R_";.1///"_S
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
TRIBNEW ;
 S E=$$E("TRIBNEW")
 D RSLT(E)
 D RSLT($J("",13)_"CCC NAME")
 D RSLT($J("",13)_"--- ----")
 F T=1:1 S L=$T(TRIBNEW+T^AUM9110A) Q:$P(L,";",3)="END"  D ADDTRIB
 Q
 ;
ADDTRIB ;
 S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_" "_N
 I $D(^AUTTTRI("C",C)) D RSLT($J("",5)_E(1)_"TRIBE CODE EXISTS => "_C) Q
 S DLAYGO=9999999.03,DIC="^AUTTTRI(",X=N,DIC("DR")=".02///"_C
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 Q
 ;
 ; -----------------------------------------------------
 ;
ADDDXPR ;
 S L=$P(L,";;",2),R=$P(L,U),M=$P(L,U,2),N=$P(L,U,3),S=$P(L,U,4),C=$P(L,U,5),O=$P(L,U,6),L=R_"..."_M_"..."
 I $D(^AUTTDXPR("B",R)) D RSLT($J("",5)_E(1)_"DIAGNOSTIC PROCEDURE RESULT EXISTS => "_R) Q
 S DLAYGO=9999999.68,DIC="^AUTTDXPR(",X=R,DIC("DR")=".02///"_M_";.07///"_S_";3///"_O
 ;
 ; The Input Transform for the .01 field requires a variable from the
 ; Medicine Package be SET.  I'll fix the dd next year.
 ; gth 12/08/99
 S (DINUM,MCQSDXPR)=691.500002
 D FILE,ADDFAIL:Y<0,ADDOK:Y>0
 KILL MCQSDXPR,DINUM
 Q:Y<0
 ;
 ; Field .03 must be direct SET since value contains ";" and
 ; disrupts the parsing of DR by FileMan.  gth 12/08/99
 S $P(^AUTTDXPR(+Y,0),U,3)=N
 ;
 ; edit WP field DESCRIPTION.
 S DIE="^AUTTDXPR(",DA=+Y,DR="2///"_C,DR(1,9999999.68)="2;",DR(2,9999999.682)=".01"
 D DIE
 I $D(Y) D RSLT($J("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT DESCRIPTION FAILED => "_L) Q
 D DISDXPR
 KILL DLAYGO
 Q
 ;
DXPRMOD ;
 S E=$$E("DXPRMOD")
 D RSLT(E)
 F T=1:2 S L=$T(DXPRMOD+T^AUM9110A) Q:$P(L,";",3)="END"  S L("TO")=$T(DXPRMOD+T+1^AUM9110A) D
 . S L=$P(L,U,2,99),R=$P(L,U)
 . S P=$O(^AUTTDXPR("B",R,0))
 . S L=$P(L("TO"),U,2,99),R=$P(L,U),M=$P(L,U,2),N=$P(L,U,3),S=$P(L,U,4),C=$P(L,U,5),O=$P(L,U,6)
 . I 'P S L=";;"_L D ADDDXPR Q
 . S L=R_"..."_M_"..."
 . S DIE="^AUTTDXPR(",DA=P,DR=".02///"_M_";.07///"_S_";3///"_O
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT FAILED => "_L) Q
 . ; Field .03 must be direct SET since value contains ";" and
 . ; disrupts the parsing of DR by FileMan.  gth 12/08/99
 . S $P(^AUTTDXPR(P,0),U,3)=N
 . ; edit WP field DESCRIPTION.
 . S DIE="^AUTTDXPR(",DA=P,DR="2///"_C,DR(1,9999999.68)="2;",DR(2,9999999.682)=".01"
 . D DIE
 . I $D(Y) D RSLT($J("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT DESCRIPTION FAILED => "_L) Q
 . D MODOK,DISDXPR
 .Q
 Q
 ;
DISDXPR ;
 D RSLT("         RESULT: "_R),RSLT("      DATA TYPE: "_M),RSLT("         PARAMS: "_N),RSLT("AQ INDEX ACTIVE: "_S),RSLT("    DESCRIPTION: "_C),RSLT("   HELP MESSAGE: "_O)
 Q
 ;
 ; -----------------------------------------------------
 ;

AUM9110A
AUM9110A ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999DEC01 ; [ 12/09/1999  10:15 AM ]
 ;;99.1;TABLE MAINTENANCE;**10**;NOV 6,1998
 ;
UPDATE ;;IHS STANDARD CODE BOOK MODIFICATIONS  OCT/NOV 1999 12/1/99
 ;
LOCNEW ;;A.  NEW FACILITY CODES (SECTION VIII-C): AREA^S.U.^FAC.^NAME^PSEUDO
 ;;10^19^80^DUNSEITH DENTAL CLINIC^CCC
 ;;END
 ;
LOCMOD ;;B.  FACILITY CODE CHANGES (SECTION VIII-C): AREA^S.U.^FAC.^NAME^PSEUDO
 ;;FROM^65^63^01^OWYHEE HOSP^XEX
 ;;  TO^65^73^01^OWYHEE HOSP^XLN
 ;;FROM^65^63^62^DUCK VALLEY TRIBE^XSP
 ;;  TO^65^73^62^DUCK VALLEY TRIBE^XLO
 ;;END
 ;
COMMNEW ;;C.  NEW COMMUNITY CODES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^S.U.
 ;;55^21^200^HILES^18^28
 ;;55^21^201^PICKERAL^18^28
 ;;55^34^250^PEARSON^18^22
 ;;55^34^251^POST LAKE^18^22
 ;;55^34^252^SUMMIT LAKE^18^22
 ;;55^34^253^DEERBROOK^18^22
 ;;55^44^202^MONICO^18^28
 ;;END
 ;
COMMMOD ;;D.  COMMUNITY CODES CHANGES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^S.U.
 ;;FROM^16^37^143^MARSING^60^63
 ;;  TO^16^37^143^MARSING^65^73
 ;;FROM^16^37^144^BRUNEAU^60^63
 ;;  TO^16^37^144^BRUNEAU^65^73
 ;;FROM^16^37^145^GRAND VIEW^60^63
 ;;  TO^16^37^145^GRAND VIEW^65^73
 ;;FROM^16^37^450^RIDDLE^60^63
 ;;  TO^16^37^450^RIDDLE^65^73
 ;;FROM^32^04^001^SPRING CREEK^60^63
 ;;  TO^32^04^001^SPRING CREEK^65^63
 ;;FROM^32^04^452^MOUNTAIN CITY^60^63
 ;;  TO^32^04^452^MOUNTAIN CITY^65^73
 ;;FROM^32^04^453^TUSCARORA^60^63
 ;;  TO^32^04^453^TUSCARORA^65^73
 ;;FROM^32^04^454^WILD HORSE MAR.^60^63
 ;;  TO^32^04^454^WILD HORSE MAR.^65^73
 ;;FROM^32^04^556^CARLIN^60^63
 ;;  TO^32^04^556^CARLIN^65^63
 ;;FROM^32^04^557^ELKO^60^63
 ;;  TO^32^04^557^ELKO^65^63
 ;;FROM^32^04^558^JARBIDGE^60^63
 ;;  TO^32^04^558^JARBIDGE^65^63
 ;;FROM^32^04^559^MONTELLO^60^63
 ;;  TO^32^04^559^MONTELLO^65^63
 ;;FROM^32^04^560^OWYHEE^60^63
 ;;  TO^32^04^560^OWYHEE^65^73
 ;;FROM^32^04^561^RUBY VALLEY^60^63
 ;;  TO^32^04^561^RUBY VALLEY^65^63
 ;;FROM^32^04^562^WELLS^60^63
 ;;  TO^32^04^562^WELLS^65^63
 ;;FROM^32^04^564^SOUTH FORK^60^63
 ;;  TO^32^04^564^SOUTH FORK^65^63
 ;;FROM^32^06^576^BEOWAWE^60^63
 ;;  TO^32^06^576^BEOWAWE^65^63
 ;;FROM^32^06^578^EUREKA EAST^60^63
 ;;  TO^32^06^578^EUREKA EAST^65^63
 ;;FROM^32^08^597^BATTLE MOUNTAIN^60^63
 ;;  TO^32^08^597^BATTLE MOUNTAIN^65^63
 ;;FROM^32^12^627^DUCKWATER^60^63
 ;;  TO^32^12^627^DUCKWATER^65^63
 ;;FROM^32^17^661^BAKER^60^63
 ;;  TO^32^17^661^BAKER^65^63
 ;;FROM^32^17^662^ELY^60^63
 ;;  TO^32^17^662^ELY^65^63
 ;;FROM^32^17^663^LUND^60^63
 ;;  TO^32^17^663^LUND^65^63
 ;;FROM^32^17^664^MCGILL^60^63
 ;;  TO^32^17^664^MCGILL^65^63
 ;;FROM^32^17^665^RUTH^60^63
 ;;  TO^32^17^665^RUTH^65^63
 ;;FROM^41^15^671^SHADEY COVE^70^86
 ;;  TO^41^15^671^SHADY COVE^70^86
 ;;FROM^49^12^628^GOSHUTE (IBAPAH)^60^63
 ;;  TO^49^12^628^GOSHUTE (IBAPAH)^65^63
 ;;FROM^49^23^697^WENDOVER^60^63
 ;;  TO^49^23^697^WENDOVER^65^63
 ;;END
 ;
TRIBNEW ;;E. NEW TRIBE CODES (SECTION XVIII): CODE^NAME
 ;;459^DELAWARE TRIBE OF INDIANS, OK
 ;;460^SNOQUALMIE TRIBAL ORGANIZATION, WA
 ;;END
 ;
HFADD ;;Field request for HEALTH FACTORS: FACTOR^CODE^CATEGORY^DISPLAY ON HEALTH SUMMARY^ENTRY TYPE
 ;;STAGED DIABETES MANAGEMENT^^STAGED DIABETES MANAGEMENT^YES^CATEGORY
 ;;0-FOOD AND EXERCISE^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;1-ORAL AGENTS^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;2-ORAL AGENT COMBINATION^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;3-ORAL/INSULIN COMBINATION^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;4-INSULIN STAGE 2^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;5-INSULIN STAGE 3^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;6-INSULIN STAGE 4^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;7-FOOD AND EXERCISE (MAINTAIN)^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;8-ORAL AGENTS (MAINTAIN)^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;9-INSULIN (MAINTAIN)^^STAGED DIABETES MANAGEMENT^YES^FACTOR
 ;;END
 ;
DXPRMOD ;;Field request for DIAGNOSTIC PROCEDURE RESULT mod: RESULT^DATA TYPE^PARAMS^AQ INDEX ACTIVE^DESCRIPTION^HELP MESSAGE
 ;;FROM^ECG SUMMARY^SET OF CODES^N:NORMAL;A:ABNORMAL^YES^This is a summary of the test result.^Enter 'NORMAL' or 'ABNORMAL'.
 ;;  TO^ECG SUMMARY^SET OF CODES^N:NORMAL;A:ABNORMAL;B:BORDERLINE^YES^This is a summary of the test result.^Enter 'NORMAL', 'ABNORMAL' or 'BORDERLINE'.
 ;;END
 ;

AUM9110M
AUM9110M ; IHS/ASDST/GTH -  BACKGROUND VALUES FOR STANDARD TABLE UPDATES, 1999DEC01 ; [ 12/09/1999  10:15 AM ]
 ;;99.1;TABLE MAINTENANCE;**10**;NOV 6,1998
 ;
VAL(X,%,Y) ;EP - return background info.
 I X["AREA" Q $T(@%)
 S Y=0
 I X["SU" D  Q Y
 . NEW C,T
 . F C=1:1 S T=$P($T(SU+C),";",3) Q:T="END"  I $P(T,U,1,2)=($E(%,1,2)_U_$E(%,3,4)) S Y=1_";;"_T Q
 .Q
 I '(X["CTY") Q 0
 NEW C,T
 F C=1:1 S T=$P($T(COUNTY+C),";",3) Q:T="END"  I $P(T,U,1,2)=($E(%,1,2)_U_$E(%,3,4)) S Y=1_";;"_T Q
 Q Y
 ;
AREA ; CODE^NAME^PREFIX/REGION^CAN PREFIX
10 ;;10^ABERDEEN^C^J45
18 ;;18^BEMIDJI NON-IHS^D^J46
65 ;;65^PHOENIX TRIBE/638^X^J40
70 ;;70^PORTLAND^P^J64
 ;;END
 ;
SU ; AREA^SU^NAME
1019 ;;10^19^TURTLE MOUNT
1822 ;;18^22^CENTRAL WISCONSIN
1828 ;;18^28^NICOLET
6573 ;;65^73^DUCK VALLEY
7086 ;;70^86^SOUTHERN OREGON
 ;;END
 ;
COUNTY ; STATE^COUNTY^NAME
1637 ;;16^37^OWYHEE
3204 ;;32^04^ELKO
3206 ;;32^06^EUREKA
3208 ;;32^08^LANDER
3212 ;;32^12^NYE
3217 ;;32^17^WHITE PINE
4115 ;;41^15^JACKSON
4912 ;;49^12^JUAB
4923 ;;49^23^TOOELE
5521 ;;55^21^FOREST
5534 ;;55^34^LANGLADE
 ;;END
 ;

AUMXPORT
AUMXPORT ; IHS/ADC/GTH - MARK PT'S FOR REG EXPORT ; [ 12/09/1999  10:15 AM ]
 ;;99.1;TABLE MAINTENANCE;**10**;NOV 6,1998
 ; IHS/ASDST/GTH AUM*99.1*10 99/12/01 - Enable ALL in background, do not
 ;      export Inactive pts.  Enrich internal documentation.
 ;
 Q
 ;
 ; ----------------------------------------------------------------
 ;
SETUP ;
 D NOW^%DTC
 S N=%
 S W="W:'$D(ZTQUEUED) ""."""
 ; I '$D(ZTQUEUED) W !,"Checking Patients for Export..." D WAIT^DICD ; IHS/ASDST/GTH AUM*99.1*10
 I '$D(ZTQUEUED) W !,"Checking Patients for Export...",!,"NOTE:  Inactive Patients are no longer exported." D WAIT^DICD ; IHS/ASDST/GTH AUM*99.1*10
 Q
 ;
 ; ----------------------------------------------------------------
 ;
COMMMOD(AUMRTN) ;EP - SET ^AGPATCH for Community Code Changes.
 ;
 ;  SET ^AGPATCH(NOW,DUZ(2),DFN)="" for a changed community.
 ;  The above was confirmed and agreed upon with the owner of
 ;  ^AGPATCH (Registration).
 ;
 ;  Patients are not marked if the only change is to Name of Community.
 ;  Inactivated patients are not marked.
 ;
 ;  AUMRTN is the name of the routine containing the Community
 ;  Code changes, usually named in the form "AUM"_vv_pp_"A",
 ;  where vv is the last 2 digits of the version of AUM, and pp
 ;  is the patch number.
 ;
 NEW D,DFN,FROM,L,N,T,TO,W
 ;
 ; D = Site DUZ(2).
 ; L = Name of the community being processed.
 ; FROM = "FROM" string.
 ; TO = "TO" string.
 ; N = NOW
 ; T = Counter
 ; W = Write dot if not q'd.
 ;
 D SETUP
 ;
 F T=1:2 S L=$T(COMMMOD+T^@AUMRTN) Q:$P(L,";",3)="END"  D
 . X W
 . S FROM=$P(L,U,2,99),TO=$P($T(COMMMOD+T+1^@AUMRTN),U,2,99)
 . I $P(FROM,U,1,3)=$P(TO,U,1,3),$P(FROM,U,5,6)=$P(TO,U,5,6) Q
 . S L=$P(TO,U,4),DFN=0
 . ; F  S DFN=$O(^AUPNPAT("AC",L,DFN)) Q:'DFN  X W S D=$O(^AUPNPAT(DFN,41,0)) X W I D S ^AGPATCH(N,D,DFN)="" ; IHS/ASDST/GTH AUM*99.1*10
 . F  S DFN=$O(^AUPNPAT("AC",L,DFN)) Q:'DFN  X W S D=$O(^AUPNPAT(DFN,41,0)) X W I D,'$$INAC(DFN,D) S ^AGPATCH(N,D,DFN)="" ; IHS/ASDST/GTH AUM*99.1*10
 . ; If the Name changed, use the old name, too, since the CURRENT COMMUNITY field in PATIENT is free text, and doubtful to be updated.
 . ; I $P(FROM,U,4)'=$P(TO,U,4) S L=$P(FROM,U,4),DFN=0 F  S DFN=$O(^AUPNPAT("AC",L,DFN)) Q:'DFN  X W S D=$O(^AUPNPAT(DFN,41,0)) X W I D S ^AGPATCH(N,D,DFN)="" ; IHS/ASDST/GTH AUM*99.1*10
 . I $P(FROM,U,4)'=$P(TO,U,4) S L=$P(FROM,U,4),DFN=0 F  S DFN=$O(^AUPNPAT("AC",L,DFN)) Q:'DFN  X W S D=$O(^AUPNPAT(DFN,41,0)) X W I D,'$$INAC(DFN,D) S ^AGPATCH(N,D,DFN)="" ; IHS/ASDST/GTH AUM*99.1*10
 .Q
 G COUNT
 ;
 ; ----------------------------------------------------------------
 ;
LOCMOD(AUMRTN) ;EP - SET ^AGPATCH for Location Code Changes.
 ;  See Community Code documentation.
 ;
 NEW D,DFN,FROM,L,N,T,TO,W
 ;
 D SETUP
 ;
 KILL ^TMP("AUMXPORT",$J)
 ;
 F T=1:2 S L=$T(LOCMOD+T^@AUMRTN) Q:$P(L,";",3)="END"  D
 . X W
 . S FROM=$P(L,U,2,99),TO=$P($T(LOCMOD+T+1^@AUMRTN),U,2,99)
 . I $P(FROM,U,1,3)=$P(TO,U,1,3) Q
 . S L=$P(TO,U,1,3),L=$TR(L,"^",""),D=$O(^AUTTLOC("C",L,0))
 . I D S ^TMP("AUMXPORT",$J,D)=""
 .Q
 ;
 S %="^AUPNPAT(""D"",0,0,0)"
 ; F  S %=$Q(@%) Q:'$L(%)  X:'((+$P(%,",",3))#1000) W I $D(^TMP("AUMXPORT",$J,+$P(%,",",4))) S ^AGPATCH(N,+$P(%,",",4),+$P(%,",",3))="" ; IHS/ASDST/GTH AUM*99.1*10
 F  S %=$Q(@%) Q:'$L(%)  X:'((+$P(%,",",3))#1000) W I $D(^TMP("AUMXPORT",$J,+$P(%,",",4))),'$$INAC(+$P(%,",",3),+$P(%,",",4)) S ^AGPATCH(N,+$P(%,",",4),+$P(%,",",3))="" ; IHS/ASDST/GTH AUM*99.1*10
 ;
 KILL ^TMP("AUMXPORT",$J)
 ;
 G COUNT
 ;
 ; ----------------------------------------------------------------
 ;
 ;
CLINMOD(AUMRTN) D SETUP G COUNT ; Not used as of Aug 1999.
 ; ----------------------------------------------------------------
CNTYMOD(AUMRTN) D SETUP G COUNT ; Not used as of Aug 1999.
 ; ----------------------------------------------------------------
RESMOD(AUMRTN) D SETUP G COUNT ; Not used as of Aug 1999.
 ; ----------------------------------------------------------------
TRIBMOD(AUMRTN) D SETUP G COUNT ; Not used as of Aug 1999.
 ; ----------------------------------------------------------------
 ;
COUNT ; Return the number of patients marked for export because of change.
 ; All EPs come here.
 ; T is what gets returned, regardless of entry point.
 S (D,T)=0
 F  S D=$O(^AGPATCH(N,D)) Q:'D  X W S DFN=0 F  S DFN=$O(^AGPATCH(N,D,DFN)) Q:'DFN  X W S T=T+1
 Q T
 ;
ALL() ; W $$ALL^AUMXPORT() to mark all active Pts for export.
 NEW D,DFN,L,N,T,W
 D SETUP
 S DFN=0,L=$P(^AUPNPAT(0),U,3)
 ; W ! ; IHS/ASDST/GTH AUM*99.1*10
 W:'$D(ZTQUEUED) ! ; IHS/ASDST/GTH AUM*99.1*10
 S DX=$X,DY=$Y
 ; F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  I $D(^DPT(DFN)) S D=$O(^AUPNPAT(DFN,41,0)) I D S ^AGPATCH(N,D,DFN)="" I '(DFN#100) X IOXY W "On IEN ",DFN," of ",L," in ^AUPNPAT(..." ; IHS/ASDST/GTH AUM*99.1*10
 F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  D  I '(DFN#100),'$D(ZTQUEUED) X IOXY W "On IEN ",DFN," of ",L," in ^AUPNPAT(..." ; IHS/ASDST/GTH AUM*99.1*10
 . Q:'$D(^DPT(DFN))
 . S D=0
 . F  S D=$O(^AUPNPAT(DFN,41,D)) Q:'D  I '$$INAC(DFN,D) S ^AGPATCH(N,D,DFN)=""
 .Q
 ;
 ; W !!,"If you change your mind, you need to KILL ^AGPATCH(",N,").",!! ; IHS/ASDST/GTH AUM*99.1*10
 ; I $$DIR^XBDIR("E") ; IHS/ASDST/GTH AUM*99.1*10
 ; W ! ; IHS/ASDST/GTH AUM*99.1*10
 ; S DX=$X,DY=$Y,W="X IOXY W ""Counting..."",T" ; IHS/ASDST/GTH AUM*99.1*10
 W:'$D(ZTQUEUED) !!,"If you change your mind, you need to KILL ^AGPATCH(",N,").",!! ; IHS/ASDST/GTH AUM*99.1*10
 S DX=$X,DY=$Y,W=$S('$D(ZTQUEUED):"X IOXY W ""Counting..."",T",1:"") ; IHS/ASDST/GTH AUM*99.1*10
 G COUNT
 ;
INAC(DFN,D) ; Pt is inactive if inactive date, or status is Deleted or Inactive. ; IHS/ASDST/GTH AUM*99.1*10
 ;
 I $P($G(^AUPNPAT(DFN,41,D,0)),U,3) Q 1 ; Inactive Date
 I '$L($P($G(^AUPNPAT(DFN,41,D,0)),U,5)) Q 0
 I "DI"[$P($G(^AUPNPAT(DFN,41,D,0)),U,5) Q 1 ; Deleted or Inactive
 Q 0
 ;