AUM91151 ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2000JUL21 ; [ 07/27/2000 10:47 AM ]
;;99.1;TABLE MAINTENANCE;**15**;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 RSLT($J("",5)_$P($T(UPDATE^AUM9115A),";",3))
F %=1:1 D RSLT($P($T(GREET+%^AUM9115),";",3)) Q:$P($T(GREET+%+1^AUM9115),";",3)="###"
F %=1:1 D RSLT($P($T(INTRO+%^AUM9115),";",3)) Q:$P($T(INTRO+%+1^AUM9115),";",3)="###"
D DASH,LOCNEW,DASH,LOCMOD,DASH,COMMNEW,DASH,COMMMOD,DASH,TRIBNEW,DASH,TRIBMOD,DASH,DOMNEW,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^AUM9115A),";",3),":",1)
IEN(X,%,Y) ;
S Y=$O(@(X_"""C"",%,0)"))
I 'Y S Y=$$VAL^AUM9115M(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("AUM9115",$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
;
; -----------------------------------------------------
LOCNEW ;
D RSLT($$E("LOCNEW"))
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^AUM9115A) 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///@;.28////"_DT 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=".28////"_DT_";.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_";.28////"_DT_";.31///"_P
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
KILL DINUM,DLAYGO
Q
;
; -----------------------------------------------------
;
LOCMOD ;
D RSLT($$E("LOCMOD"))
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^AUM9115A) Q:$P(L,";",3)="END" S L("TO")=$T(LOCMOD+T+1^AUM9115A) 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_";.28////"_DT_";.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
;
D DASH
D RSLT("Checking Location Code changes to determine export status.")
D RSLT("Patient data is not exported if the only change is to the Location NAME.")
D RSLT("Location Code changes must be rolled up into the national data repository...")
D DASH,RSLT($$LOCMOD^AUMXPORT("AUM9115A")_" patients marked for export because of the Location Code changes.")
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^AUM9115A) 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^AUM9115A) Q:$P(L,";",3)="END" S L("TO")=$T(COMMMOD+T+1^AUM9115A) 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
;
D DASH
D RSLT("Checking Community Code changes to determine export status.")
D RSLT("Patient data is not exported if the only change is to the Commnuity NAME.")
D RSLT("Commnity Code changes must be rolled up into the national data repository...")
D DASH,RSLT($$COMMMOD^AUMXPORT("AUM9115A")_" patients marked for export because of the Community Code changes.")
Q
;
; -----------------------------------------------------
;
TRIBNEW ;
D RSLT($$E("TRIBNEW"))
D RSLT($J("",13)_"CCC NAME")
D RSLT($J("",13)_"--- ----")
F T=1:1 S L=$T(TRIBNEW+T^AUM9115A) Q:$P(L,";",3)="END" D ADDTRIB
Q
;
ADDTRIB ;
S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3),L=C_" "_A
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_";.03///"_A_";.04///N"
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
KILL DLAYGO
Q
;
; -----------------------------------------------------
;
TRIBMOD ;
D RSLT($$E("TRIBMOD"))
D RSLT($J("",14)_"CODE NAME"_$J("",29)_"INACTIVE")
D RSLT($J("",14)_"---- ----"_$J("",29)_"--------")
F T=1:2 S L=$T(TRIBMOD+T^AUM9115A) Q:$P(L,";",3)="END" S L("TO")=$T(TRIBMOD+T+1^AUM9115A) D
. S L=$P(L,U,2,99),C=$P(L,U)
. S P=$O(^AUTTTRI("C",C,0))
. S L=$P(L("TO"),U,2,99),C=$P(L,U),N=$P(L,U,2),S=$P(L,U,3)
. I 'P S L=";;"_L D ADDTRIB Q
. S L=C_" "_N_$J("",40-$L(N))_S
. S DIE="^AUTTTRI(",DA=P,DR=".01///"_N_";.04///"_S
. D DIE
. I $D(Y) D RSLT(E(0)_E_" : EDIT TRIBE FAILED => "_L) Q
. D MODOK
.Q
Q
;
; -----------------------------------------------------
;
DOMNEW ;
D RSLT($$E("DOMNEW"))
D RSLT($J("",13)_"NAME")
D RSLT($J("",13)_"----")
F T=1:1 S L=$T(DOMNEW+T^AUM9115A) Q:$P(L,";",3)="END" D ADDDOM
Q
;
ADDDOM ;
S L=$P(L,";;",2),N=$P(L,U),L=N
I $D(^DIC(4.2,"B",N)) D RSLT($J("",5)_E(1)_"DOMAIN NAME EXISTS => "_N) Q
S DLAYGO=4.2,DIC="^DIC(4.2,",X=N
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
KILL DLAYGO
Q
;
; -----------------------------------------------------
;
AUM91151 ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2000JUL21 ; [ 07/27/2000 10:47 AM ]
+1 ;;99.1;TABLE MAINTENANCE;**15**;NOV 6,1998
+2 ;
+3 QUIT
+4 ;
START ;EP
+1 ;
+2 NEW A,C,DIC,DIE,DINUM,DLAYGO,DR,E,L,M,N,O,P,R,S,T
+3 ;
+4 SET E(0)="ERROR : "
SET E(1)="NOT ADDED : "
+5 DO RSLT($JUSTIFY("",5)_$PIECE($TEXT(UPDATE^AUM9115A),";",3))
+6 FOR %=1:1
DO RSLT($PIECE($TEXT(GREET+%^AUM9115),";",3))
IF $PIECE($TEXT(GREET+%+1^AUM9115),";",3)="###"
QUIT
+7 FOR %=1:1
DO RSLT($PIECE($TEXT(INTRO+%^AUM9115),";",3))
IF $PIECE($TEXT(INTRO+%+1^AUM9115),";",3)="###"
QUIT
+8 DO DASH
DO LOCNEW
DO DASH
DO LOCMOD
DO DASH
DO COMMNEW
DO DASH
DO COMMMOD
DO DASH
DO TRIBNEW
DO DASH
DO TRIBMOD
DO DASH
DO DOMNEW
DO DASH
+9 QUIT
+10 ;
+11 ; -----------------------------------------------------
+12 ;
ADDOK DO RSLT($JUSTIFY("",5)_"Added : "_L)
QUIT
ADDFAIL DO RSLT($JUSTIFY("",5)_E(0)_"ADD FAILED => "_L)
QUIT
DASH DO RSLT("")
DO RSLT($$REPEAT^XLFSTR("-",$SELECT($GET(IOM):IOM-10,1:70)))
DO RSLT("")
QUIT
DIE NEW A,C,E,L,M,N,O,P,R,S,T
+1 LOCK +(@(DIE_DA_")")):10
IF '$TEST
DO RSLT($JUSTIFY("",5)_E(0)_"Entry '"_DIE_DA_"' IS LOCKED. NOTIFY PROGRAMMER.")
SET Y=1
QUIT
+2 DO ^DIE
LOCK -(@(DIE_DA_")"))
KILL DA,DIE,DR
QUIT
E(L) QUIT $PIECE($PIECE($TEXT(@L^AUM9115A),";",3),":",1)
IEN(X,%,Y) ;
+1 SET Y=$ORDER(@(X_"""C"",%,0)"))
+2 IF 'Y
SET Y=$$VAL^AUM9115M(X,%)
IF Y
NEW Z
SET Z=E
Begin DoDot:1
+3 NEW A,C,L,M,N,O,P,R,S,V,%
+4 SET L=Y
+5 IF X["AREA"
NEW X
DO RSLT("(Add Missing Area)")
DO ADDAREA
DO RSLT("(END Add Missing Area)")
QUIT
+6 IF X["SU"
NEW X
DO RSLT("(Add Missing SU)")
DO ADDSU
DO RSLT("(END Add Missing SU)")
QUIT
+7 IF X["CTY"
NEW X
DO RSLT("(Add Missing County)")
DO ADDCNTY
DO RSLT("(END Add Missing County)")
QUIT
+8 QUIT
End DoDot:1
IF Y<0
SET Y=""
SET E=Z
+9 IF 'Y
DO RSLT($JUSTIFY("",5)_E(0)_$PIECE(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
+10 QUIT +Y
DIK NEW A,C,E,L,M,N,O,P,R,S,T
DO ^DIK
KILL DIK
QUIT
FILE NEW A,C,E,L,M,N,O,P,R,S,T
KILL DD,DO
SET DIC(0)="L"
DO FILE^DICN
KILL DIC
QUIT
MODOK DO RSLT($JUSTIFY("",5)_"Changed : "_L)
QUIT
RSLT(%) SET ^(0)=$GET(^TMP("AUM9115",$JOB,0))+1
SET ^(^(0))=%
IF '$DATA(ZTQUEUED)
WRITE !,%
QUIT
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ; Return 0th node. A is file #, rest fields.
+1 IF '$GET(A)
QUIT -1
+2 IF '$GET(B)
QUIT -1
+3 FOR %=67:1:75
IF '$GET(@($CHAR(%)))
QUIT
SET A=+$PIECE(^DD(A,B,0),U,2)
SET B=@($CHAR(%))
+4 IF 'A!('B)
QUIT -1
+5 IF '$DATA(^DD(A,B,0))
QUIT -1
+6 QUIT U_$PIECE(^DD(A,B,0),U,2)
+7 ;
+8 ; -----------------------------------------------------
+9 ;
ADDAREA ; PROGRAMMER NOTE: This s/r is required for every patch.
+1 SET L=$PIECE(L,";;",2)
SET A=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET R=$PIECE(L,U,3)
SET C=$PIECE(L,U,4)
SET L=A_" "_N_" "_R_" "_C
+2 IF $DATA(^AUTTAREA("B",N))
DO RSLT($JUSTIFY("",5)_E(1)_"NAME EXISTS => "_N)
QUIT
+3 IF $DATA(^AUTTAREA("C",A))
DO RSLT($JUSTIFY("",5)_E(1)_"CODE EXISTS => "_A)
QUIT
+4 SET DLAYGO=9999999.21
SET DIC="^AUTTAREA("
SET X=N
SET DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C
+5 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+6 KILL DLAYGO
+7 QUIT
+8 ;
+9 ; -----------------------------------------------------
+10 ;
ADDCNTY ; PROGRAMMER NOTE: This s/r is required for every patch.
+1 SET L=$PIECE(L,";;",2)
SET S=$PIECE(L,U)
SET C=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET L=S_" "_C_" "_N
+2 IF $DATA(^AUTTCTY("C",S_C))
DO RSLT($JUSTIFY("",5)_E(1)_"CODE EXISTS => "_S_C)
QUIT
+3 SET P("S")=$$IEN("^DIC(5,",S)
+4 IF 'P("S")
QUIT
+5 SET DIC="^AUTTCTY("
SET X=N
SET DIC("DR")=".02////"_P("S")_";.03///"_C
+6 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+7 QUIT
+8 ;
+9 ; -----------------------------------------------------
+10 ;
ADDSU ; PROGRAMMER NOTE: This s/r is required for every patch.
+1 SET L=$PIECE(L,";;",2)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET L=A_" "_S_" "_N
+2 IF $DATA(^AUTTSU("C",A_S))
DO RSLT($JUSTIFY("",5)_E(1)_"ASU EXISTS => "_A_S)
QUIT
+3 SET P=$$IEN("^AUTTAREA(",A)
+4 IF 'P
QUIT
+5 SET DLAYGO=9999999.22
SET DIC="^AUTTSU("
SET X=N
SET DIC("DR")=".02////"_P_";.03///"_S
+6 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+7 KILL DLAYGO
+8 QUIT
+9 ;
+10 ; -----------------------------------------------------
LOCNEW ;
+1 DO RSLT($$E("LOCNEW"))
+2 DO RSLT($JUSTIFY("",13)_"AA SU FA NAME"_$JUSTIFY("",28)_"PSEUDO")
+3 DO RSLT($JUSTIFY("",13)_"-- -- -- ----"_$JUSTIFY("",28)_"------")
+4 FOR T=1:1
SET L=$TEXT(LOCNEW+T^AUM9115A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDLOC
+5 QUIT
+6 ;
ADDLOC ;
+1 SET L=$PIECE(L,";;",2)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
SET P=$PIECE(L,U,5)
+2 SET L=A_" "_S_" "_F_" "_N_$JUSTIFY("",32-$LENGTH(N))_P
+3 SET %=A_S_F
SET %=$ORDER(^AUTTLOC("C",%,0))
+4 IF %
DO RSLT($JUSTIFY("",5)_E(1)_"ASUFAC EXISTS => "_A_S_F)
Begin DoDot:1
+5 IF $PIECE($GET(^AUTTLOC(%,0)),U,21)
SET DIE="^AUTTLOC("
SET DA=%
SET DR=".27///@;.28////"_DT
DO DIE
IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"DELETE INACTIVE DATE FAILED => "_L)
IF '$DATA(Y)
DO RSLT($JUSTIFY("",5)_"INACTIVE DATE DELETED => "_L)
+6 SET %=$ORDER(^AUTTLOC("C",A_S_F,0))
SET %=$PIECE(^AUTTLOC(%,0),U)
+7 IF %
IF $DATA(^DIC(4,%,0))
IF N'=$PIECE(^DIC(4,%,0),U)
SET DIE="^DIC(4,"
SET DA=%
SET DR=".01///"_N
DO DIE
IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT INSTITUTION FAILED => "_L)
IF '$DATA(Y)
DO RSLT($JUSTIFY("",5)_"INSTITUTION NAME UPDATED => "_L)
+8 SET %=$ORDER(^AUTTLOC("C",A_S_F,0))
+9 IF P'=$PIECE($GET(^AUTTLOC(%,1)),U,2)
SET DIE="^AUTTLOC("
SET DA=%
SET DR=".28////"_DT_";.31///"_P
DO DIE
IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT PSEUDO PREFIX FAILED => "_L)
IF '$DATA(Y)
DO RSLT($JUSTIFY("",5)_"PSEUDO PREFIX UPDATED => "_L)
+10 QUIT
End DoDot:1
QUIT
+11 SET P("A")=$$IEN("^AUTTAREA(",A)
+12 IF 'P("A")
QUIT
+13 SET P("S")=$$IEN("^AUTTSU(",A_S)
+14 IF 'P("S")
QUIT
+15 FOR DINUM=+$PIECE(^DIC(4,0),U,3):1
IF '$DATA(^DIC(4,DINUM))&('$DATA(^AUTTLOC(DINUM)))
QUIT
IF DINUM>99999
DO RSLT($JUSTIFY("",5)_E(0)_"DINUM FOR LOC/INSTITUTION TOO BIG. NOTIFY ISC.")
QUIT
+16 IF DINUM>99999
QUIT
+17 SET DLAYGO=4
SET DIC="^DIC(4,"
SET X=N
+18 DO FILE
+19 KILL DINUM,DLAYGO
+20 IF Y<0
DO RSLT($JUSTIFY("",5)_E(0)_"^DIC(4 ADD FAILED => "_L)
QUIT
+21 SET DINUM=+Y
SET DLAYGO=9999999.06
SET DIC="^AUTTLOC("
SET X=DINUM
SET DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P
+22 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+23 KILL DINUM,DLAYGO
+24 QUIT
+25 ;
+26 ; -----------------------------------------------------
+27 ;
LOCMOD ;
+1 DO RSLT($$E("LOCMOD"))
+2 DO RSLT($JUSTIFY("",15)_"AA SU FA NAME"_$JUSTIFY("",28)_"PSEUDO")
+3 DO RSLT($JUSTIFY("",15)_"-- -- -- ----"_$JUSTIFY("",28)_"------")
+4 FOR T=1:2
SET L=$TEXT(LOCMOD+T^AUM9115A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(LOCMOD+T+1^AUM9115A)
Begin DoDot:1
+5 SET L=$PIECE(L,U,2,99)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
+6 SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
+7 SET L=$PIECE(L("TO"),U,2,99)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
+8 IF 'P
SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
IF 'P
SET L=";;"_L
DO ADDLOC
QUIT
+9 SET L=A_" "_S_" "_F_" "_N_$JUSTIFY("",32-$LENGTH(N))_$PIECE(L("TO"),U,6)
+10 SET P("A")=$$IEN("^AUTTAREA(",A)
+11 IF 'P("A")
QUIT
+12 SET P("S")=$$IEN("^AUTTSU(",A_S)
+13 IF 'P("S")
QUIT
+14 SET DIE="^AUTTLOC("
SET DA=P
SET DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_$PIECE(L("TO"),U,6)
+15 DO DIE
+16 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT LOCATION FAILED => "_L)
QUIT
+17 SET DIE="^DIC(4,"
SET DA=$PIECE(^AUTTLOC(P,0),U)
SET DR=".01///"_N
+18 DO DIE
+19 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT INSTITUTION FAILED => "_L)
QUIT
+20 DO MODOK
+21 QUIT
End DoDot:1
+22 ;
+23 DO DASH
+24 DO RSLT("Checking Location Code changes to determine export status.")
+25 DO RSLT("Patient data is not exported if the only change is to the Location NAME.")
+26 DO RSLT("Location Code changes must be rolled up into the national data repository...")
+27 DO DASH
DO RSLT($$LOCMOD^AUMXPORT("AUM9115A")_" patients marked for export because of the Location Code changes.")
+28 QUIT
+29 ;
+30 ; -----------------------------------------------------
+31 ;
COMMNEW ;
+1 DO RSLT($$E("COMMNEW"))
+2 DO RSLT($JUSTIFY("",13)_"ST CT COM NAME"_$JUSTIFY("",28)_"AA SU")
+3 DO RSLT($JUSTIFY("",13)_"-- -- --- ----"_$JUSTIFY("",28)_"-- --")
+4 FOR T=1:1
SET L=$TEXT(COMMNEW+T^AUM9115A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDCOMM
+5 QUIT
+6 ;
ADDCOMM ;
+1 SET L=$PIECE(L,";;",2)
SET S=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
SET A=$PIECE(L,U,5)
SET V=$PIECE(L,U,6)
SET L=S_" "_O_" "_C_" "_N_$JUSTIFY("",32-$LENGTH(N))_A_" "_V
+2 IF $DATA(^AUTTCOM("C",S_O_C))
DO RSLT($JUSTIFY("",5)_E(1)_"STCTYCOM CODE EXISTS => "_S_O_C)
QUIT
+3 SET P("O")=$$IEN("^AUTTCTY(",S_O)
+4 IF 'P("O")
QUIT
+5 SET P("A")=$$IEN("^AUTTAREA(",A)
+6 IF 'P("A")
QUIT
+7 SET P("V")=$$IEN("^AUTTSU(",A_V)
+8 IF 'P("V")
QUIT
+9 SET DLAYGO=9999999.05
SET DIC="^AUTTCOM("
SET X=N
SET DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
+10 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+11 KILL DLAYGO
+12 QUIT
+13 ;
+14 ; -----------------------------------------------------
+15 ;
COMMMOD ;
+1 DO RSLT($$E("COMMMOD"))
+2 DO RSLT($JUSTIFY("",15)_"ST CT COM NAME"_$JUSTIFY("",28)_"AA SU")
+3 DO RSLT($JUSTIFY("",15)_"-- -- --- ----"_$JUSTIFY("",28)_"-- --")
+4 FOR T=1:2
SET L=$TEXT(COMMMOD+T^AUM9115A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(COMMMOD+T+1^AUM9115A)
Begin DoDot:1
+5 SET L=$PIECE(L,U,2,99)
SET S=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
+6 SET P=$ORDER(^AUTTCOM("C",S_O_C,0))
+7 SET L=$PIECE(L("TO"),U,2,99)
SET S=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
SET N=$PIECE(L,U,4)
SET A=$PIECE(L,U,5)
SET V=$PIECE(L,U,6)
+8 IF 'P
SET P=$ORDER(^AUTTCOM("C",S_O_C,0))
IF 'P
SET L=";;"_L
DO ADDCOMM
QUIT
+9 SET L=S_" "_O_" "_C_" "_N_$JUSTIFY("",32-$LENGTH(N))_A_" "_V
+10 SET P("O")=$$IEN("^AUTTCTY(",S_O)
+11 IF 'P("O")
QUIT
+12 SET P("A")=$$IEN("^AUTTAREA(",A)
+13 IF 'P("A")
QUIT
+14 SET P("V")=$$IEN("^AUTTSU(",A_V)
+15 IF 'P("V")
QUIT
+16 SET DIE="^AUTTCOM("
SET DA=P
SET DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
+17 DO DIE
+18 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"CHANGE FAILED => "_L)
QUIT
+19 DO MODOK
+20 QUIT
End DoDot:1
+21 ;
+22 DO DASH
+23 DO RSLT("Checking Community Code changes to determine export status.")
+24 DO RSLT("Patient data is not exported if the only change is to the Commnuity NAME.")
+25 DO RSLT("Commnity Code changes must be rolled up into the national data repository...")
+26 DO DASH
DO RSLT($$COMMMOD^AUMXPORT("AUM9115A")_" patients marked for export because of the Community Code changes.")
+27 QUIT
+28 ;
+29 ; -----------------------------------------------------
+30 ;
TRIBNEW ;
+1 DO RSLT($$E("TRIBNEW"))
+2 DO RSLT($JUSTIFY("",13)_"CCC NAME")
+3 DO RSLT($JUSTIFY("",13)_"--- ----")
+4 FOR T=1:1
SET L=$TEXT(TRIBNEW+T^AUM9115A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDTRIB
+5 QUIT
+6 ;
ADDTRIB ;
+1 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET A=$PIECE(L,U,3)
SET L=C_" "_A
+2 IF $DATA(^AUTTTRI("C",C))
DO RSLT($JUSTIFY("",5)_E(1)_"TRIBE CODE EXISTS => "_C)
QUIT
+3 SET DLAYGO=9999999.03
SET DIC="^AUTTTRI("
SET X=N
SET DIC("DR")=".02///"_C_";.03///"_A_";.04///N"
+4 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 KILL DLAYGO
+6 QUIT
+7 ;
+8 ; -----------------------------------------------------
+9 ;
TRIBMOD ;
+1 DO RSLT($$E("TRIBMOD"))
+2 DO RSLT($JUSTIFY("",14)_"CODE NAME"_$JUSTIFY("",29)_"INACTIVE")
+3 DO RSLT($JUSTIFY("",14)_"---- ----"_$JUSTIFY("",29)_"--------")
+4 FOR T=1:2
SET L=$TEXT(TRIBMOD+T^AUM9115A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(TRIBMOD+T+1^AUM9115A)
Begin DoDot:1
+5 SET L=$PIECE(L,U,2,99)
SET C=$PIECE(L,U)
+6 SET P=$ORDER(^AUTTTRI("C",C,0))
+7 SET L=$PIECE(L("TO"),U,2,99)
SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET S=$PIECE(L,U,3)
+8 IF 'P
SET L=";;"_L
DO ADDTRIB
QUIT
+9 SET L=C_" "_N_$JUSTIFY("",40-$LENGTH(N))_S
+10 SET DIE="^AUTTTRI("
SET DA=P
SET DR=".01///"_N_";.04///"_S
+11 DO DIE
+12 IF $DATA(Y)
DO RSLT(E(0)_E_" : EDIT TRIBE FAILED => "_L)
QUIT
+13 DO MODOK
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
+17 ; -----------------------------------------------------
+18 ;
DOMNEW ;
+1 DO RSLT($$E("DOMNEW"))
+2 DO RSLT($JUSTIFY("",13)_"NAME")
+3 DO RSLT($JUSTIFY("",13)_"----")
+4 FOR T=1:1
SET L=$TEXT(DOMNEW+T^AUM9115A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDDOM
+5 QUIT
+6 ;
ADDDOM ;
+1 SET L=$PIECE(L,";;",2)
SET N=$PIECE(L,U)
SET L=N
+2 IF $DATA(^DIC(4.2,"B",N))
DO RSLT($JUSTIFY("",5)_E(1)_"DOMAIN NAME EXISTS => "_N)
QUIT
+3 SET DLAYGO=4.2
SET DIC="^DIC(4.2,"
SET X=N
+4 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 KILL DLAYGO
+6 QUIT
+7 ;
+8 ; -----------------------------------------------------
+9 ;
