AUM61021 ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 06DEC95 BANYAN ; [ 12/11/95 3:39 PM ]
;;96.1;TABLE MAINTENANCE;**2**;OCT 26,1995
;
Q
;
START ;EP
;
NEW A,C,DIC,DIE,DLAYGO,DR,E,L,N,O,P,R,S,T
;
S E(0)="ERROR : ",E(1)="NOT ADDED : "
D LOCNEW,DASH,LOCMOD,DASH,LOCINACT,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,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_")")) K DA,DIE,DR Q
IEN(X,%,Y) ;
S Y=$O(@(X_"""C"",%,0)"))
I 'Y S Y=$T(@%^AUM9511M) I Y NEW Z S Z=E D S:Y<0 Y="" S E=Z
. NEW A,C,L,N,O,P,R,S,V,%
. S L=Y
. I X["AREA" NEW X S E=E_" (Add Area) " D ADDAREA Q
. I X["SU" NEW X S E=E_" (Add SU) " D ADDSU Q
. I X["CTY" NEW X S E=E_" (Add County) " D ADDCNTY Q
.Q
D:'Y RSLT($J("",5)_E(0)_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
Q +Y
DIK NEW A,C,E,L,N,O,P,R,S,T D ^DIK K DIK Q
FILE NEW A,C,E,L,N,O,P,R,S,T K DD,DO S DIC(0)="L" D FILE^DICN K DIC Q
MODOK D RSLT($J("",5)_"Changed : "_L) Q
RSLT(%) S ^(0)=$G(^TMP("AUM SCB",$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)
;
; -----------------------------------------------------
AREANEW ;
D RSLT("New Area Codes")
F T=1:1 S L=$T(AREANEW+T^AUM6102A) Q:$P(L,";",3)="END" D ADDAREA
Q
;
ADDAREA ;
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
Q
;
; -----------------------------------------------------
SUNEW ;
D RSLT("New Service Unit Codes")
F T=1:1 S L=$T(SUNEW+T^AUM6102A) Q:$P(L,";",3)="END" D ADDSU
Q
;
ADDSU ;
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
Q
;
; -----------------------------------------------------
LOCNEW ;
D RSLT("New Location Codes")
F T=1:1 S L=$T(LOCNEW+T^AUM6102A) 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_" "_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
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
Q
;
LOCMOD ;
D RSLT("Location Code Changes")
F T=1:2 S L=$T(LOCMOD+T^AUM6102A) Q:$P(L,";",3)="END" S L("TO")=$T(LOCMOD+T+1^AUM6102A) 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_" "_$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
D DASH,RSLT($$LOCMOD^AUMXPORT("AUM6102A")_" patients marked for export because of the Location Code changes.")
;
Q
;
LOCINACT ;
D RSLT("Inactivated Location Codes")
F T=1:1 S L=$T(LOCINACT+T^AUM6102A) Q:$P(L,";",3)="END" D
. 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_" "_P
. S %=A_S_F,%=$O(^AUTTLOC("C",%,0))
. I '% D RSLT($J("",5)_"ASUFAC "_A_S_F_" not found (OK).") Q
. S DIE="^AUTTLOC(",DA=%,DR=".27////"_DT
. D DIE
. I $D(Y) D RSLT($J("",5)_E(0)_"EDIT INACTIVE DATE FAILED => "_L) I 1
. E D RSLT($J("",5)_"INACTIVATED => "_L)
.Q
Q
;
; -----------------------------------------------------
CNTYNEW ;
D RSLT("New County Codes")
F T=1:1 S L=$T(CNTYNEW+T^AUM6102A) Q:$P(L,";",3)="END" D ADDCNTY
Q
;
ADDCNTY ;
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
;
CNTYMOD ;
D RSLT("County Code Changes")
F T=1:2 S L=$T(CNTYMOD+T^AUM6102A) Q:$P(L,";",3)="END" S L("TO")=$T(CNTYMOD+T+1^AUM6102A) D
. S L=$P(L,U,2,99),S=$P(L,U),C=$P(L,U,2)
. S P=$O(^AUTTCTY("C",S_C,0))
. S L=$P(L("TO"),U,2,99),S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3)
. I 'P S P=$O(^AUTTCTY("C",S_C,0)) I 'P S L=";;"_L D ADDCNTY Q
. S L=S_" "_C_" "_N
. S P("S")=$$IEN("^DIC(5,",S)
. Q:'P("S")
. S DIE="^AUTTCTY(",DA=P,DR=".01///"_N_";.02////"_P("S")_";.03///"_C
. D DIE
. I $D(Y) D RSLT($J("",5)_E(0)_"EDIT COUNTY FAILED => "_L) Q
. D MODOK
.Q
Q
;
; -----------------------------------------------------
COMMNEW ;
D RSLT("New Community Codes")
F T=1:1 S L=$T(COMMNEW+T^AUM9511A) 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_" "_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^AUM95111("^AUTTCTY(",S_O)
Q:'P("O")
S P("A")=$$IEN^AUM95111("^AUTTAREA(",A)
Q:'P("A")
S P("V")=$$IEN^AUM95111("^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
Q
;
COMMMOD ;
D RSLT("Community Code Changes")
F T=1:2 S L=$T(COMMMOD+T^AUM6102A) Q:$P(L,";",3)="END" S L("TO")=$T(COMMMOD+T+1^AUM6102A) 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_" "_A_" "_V
. S P("O")=$$IEN^AUM61021("^AUTTCTY(",S_O)
. Q:'P("O")
. S P("A")=$$IEN^AUM61021("^AUTTAREA(",A)
. Q:'P("A")
. S P("V")=$$IEN^AUM61021("^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,RSLT($$COMMMOD^AUMXPORT("AUM6102A")_" patients marked for export because of the Community Code changes.")
Q
;
; -----------------------------------------------------
;
AUM61021 ; IHS/ADC/GTH - STANDARD TABLE UPDATES, 06DEC95 BANYAN ; [ 12/11/95 3:39 PM ]
+1 ;;96.1;TABLE MAINTENANCE;**2**;OCT 26,1995
+2 ;
+3 QUIT
+4 ;
START ;EP
+1 ;
+2 NEW A,C,DIC,DIE,DLAYGO,DR,E,L,N,O,P,R,S,T
+3 ;
+4 SET E(0)="ERROR : "
SET E(1)="NOT ADDED : "
+5 DO LOCNEW
DO DASH
DO LOCMOD
DO DASH
DO LOCINACT
DO DASH
DO COMMMOD
DO DASH
+6 ;
+7 QUIT
+8 ;
+9 ; -----------------------------------------------------
+10 ;
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,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
IEN(X,%,Y) ;
+1 SET Y=$ORDER(@(X_"""C"",%,0)"))
+2 IF 'Y
SET Y=$TEXT(@%^AUM9511M)
IF Y
NEW Z
SET Z=E
Begin DoDot:1
+3 NEW A,C,L,N,O,P,R,S,V,%
+4 SET L=Y
+5 IF X["AREA"
NEW X
SET E=E_" (Add Area) "
DO ADDAREA
QUIT
+6 IF X["SU"
NEW X
SET E=E_" (Add SU) "
DO ADDSU
QUIT
+7 IF X["CTY"
NEW X
SET E=E_" (Add County) "
DO ADDCNTY
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,N,O,P,R,S,T
DO ^DIK
KILL DIK
QUIT
FILE NEW A,C,E,L,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("AUM SCB",$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 ; -----------------------------------------------------
AREANEW ;
+1 DO RSLT("New Area Codes")
+2 FOR T=1:1
SET L=$TEXT(AREANEW+T^AUM6102A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDAREA
+3 QUIT
+4 ;
ADDAREA ;
+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 QUIT
+7 ;
+8 ; -----------------------------------------------------
SUNEW ;
+1 DO RSLT("New Service Unit Codes")
+2 FOR T=1:1
SET L=$TEXT(SUNEW+T^AUM6102A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDSU
+3 QUIT
+4 ;
ADDSU ;
+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 QUIT
+8 ;
+9 ; -----------------------------------------------------
LOCNEW ;
+1 DO RSLT("New Location Codes")
+2 FOR T=1:1
SET L=$TEXT(LOCNEW+T^AUM6102A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDLOC
+3 QUIT
+4 ;
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_" "_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///@"
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=".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 IF Y<0
DO RSLT($JUSTIFY("",5)_E(0)_"^DIC(4 ADD FAILED => "_L)
QUIT
+20 SET DINUM=+Y
SET DLAYGO=9999999.06
SET DIC="^AUTTLOC("
SET X=DINUM
SET DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.31///"_P
+21 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+22 QUIT
+23 ;
LOCMOD ;
+1 DO RSLT("Location Code Changes")
+2 FOR T=1:2
SET L=$TEXT(LOCMOD+T^AUM6102A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(LOCMOD+T+1^AUM6102A)
Begin DoDot:1
+3 SET L=$PIECE(L,U,2,99)
SET A=$PIECE(L,U)
SET S=$PIECE(L,U,2)
SET F=$PIECE(L,U,3)
+4 SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
+5 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)
+6 IF 'P
SET P=$ORDER(^AUTTLOC("C",A_S_F,0))
IF 'P
SET L=";;"_L
DO ADDLOC
QUIT
+7 SET L=A_" "_S_" "_F_" "_N_" "_$PIECE(L("TO"),U,6)
+8 SET P("A")=$$IEN("^AUTTAREA(",A)
+9 IF 'P("A")
QUIT
+10 SET P("S")=$$IEN("^AUTTSU(",A_S)
+11 IF 'P("S")
QUIT
+12 SET DIE="^AUTTLOC("
SET DA=P
SET DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.31///"_$PIECE(L("TO"),U,6)
+13 DO DIE
+14 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT LOCATION FAILED => "_L)
QUIT
+15 SET DIE="^DIC(4,"
SET DA=$PIECE(^AUTTLOC(P,0),U)
SET DR=".01///"_N
+16 DO DIE
+17 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT INSTITUTION FAILED => "_L)
QUIT
+18 DO MODOK
+19 QUIT
End DoDot:1
+20 DO DASH
DO RSLT($$LOCMOD^AUMXPORT("AUM6102A")_" patients marked for export because of the Location Code changes.")
+21 ;
+22 QUIT
+23 ;
LOCINACT ;
+1 DO RSLT("Inactivated Location Codes")
+2 FOR T=1:1
SET L=$TEXT(LOCINACT+T^AUM6102A)
IF $PIECE(L,";",3)="END"
QUIT
Begin DoDot:1
+3 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)
+4 SET L=A_" "_S_" "_F_" "_N_" "_P
+5 SET %=A_S_F
SET %=$ORDER(^AUTTLOC("C",%,0))
+6 IF '%
DO RSLT($JUSTIFY("",5)_"ASUFAC "_A_S_F_" not found (OK).")
QUIT
+7 SET DIE="^AUTTLOC("
SET DA=%
SET DR=".27////"_DT
+8 DO DIE
+9 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT INACTIVE DATE FAILED => "_L)
IF 1
+10 IF '$TEST
DO RSLT($JUSTIFY("",5)_"INACTIVATED => "_L)
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
+14 ; -----------------------------------------------------
CNTYNEW ;
+1 DO RSLT("New County Codes")
+2 FOR T=1:1
SET L=$TEXT(CNTYNEW+T^AUM6102A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDCNTY
+3 QUIT
+4 ;
ADDCNTY ;
+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 ;
CNTYMOD ;
+1 DO RSLT("County Code Changes")
+2 FOR T=1:2
SET L=$TEXT(CNTYMOD+T^AUM6102A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(CNTYMOD+T+1^AUM6102A)
Begin DoDot:1
+3 SET L=$PIECE(L,U,2,99)
SET S=$PIECE(L,U)
SET C=$PIECE(L,U,2)
+4 SET P=$ORDER(^AUTTCTY("C",S_C,0))
+5 SET L=$PIECE(L("TO"),U,2,99)
SET S=$PIECE(L,U)
SET C=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
+6 IF 'P
SET P=$ORDER(^AUTTCTY("C",S_C,0))
IF 'P
SET L=";;"_L
DO ADDCNTY
QUIT
+7 SET L=S_" "_C_" "_N
+8 SET P("S")=$$IEN("^DIC(5,",S)
+9 IF 'P("S")
QUIT
+10 SET DIE="^AUTTCTY("
SET DA=P
SET DR=".01///"_N_";.02////"_P("S")_";.03///"_C
+11 DO DIE
+12 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT COUNTY FAILED => "_L)
QUIT
+13 DO MODOK
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
+17 ; -----------------------------------------------------
COMMNEW ;
+1 DO RSLT("New Community Codes")
+2 FOR T=1:1
SET L=$TEXT(COMMNEW+T^AUM9511A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDCOMM
+3 QUIT
+4 ;
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_" "_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^AUM95111("^AUTTCTY(",S_O)
+4 IF 'P("O")
QUIT
+5 SET P("A")=$$IEN^AUM95111("^AUTTAREA(",A)
+6 IF 'P("A")
QUIT
+7 SET P("V")=$$IEN^AUM95111("^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 QUIT
+12 ;
COMMMOD ;
+1 DO RSLT("Community Code Changes")
+2 FOR T=1:2
SET L=$TEXT(COMMMOD+T^AUM6102A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(COMMMOD+T+1^AUM6102A)
Begin DoDot:1
+3 SET L=$PIECE(L,U,2,99)
SET S=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
+4 SET P=$ORDER(^AUTTCOM("C",S_O_C,0))
+5 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)
+6 IF 'P
SET P=$ORDER(^AUTTCOM("C",S_O_C,0))
IF 'P
SET L=";;"_L
DO ADDCOMM
QUIT
+7 SET L=S_" "_O_" "_C_" "_N_" "_A_" "_V
+8 SET P("O")=$$IEN^AUM61021("^AUTTCTY(",S_O)
+9 IF 'P("O")
QUIT
+10 SET P("A")=$$IEN^AUM61021("^AUTTAREA(",A)
+11 IF 'P("A")
QUIT
+12 SET P("V")=$$IEN^AUM61021("^AUTTSU(",A_V)
+13 IF 'P("V")
QUIT
+14 SET DIE="^AUTTCOM("
SET DA=P
SET DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
+15 DO DIE
+16 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"CHANGE FAILED => "_L)
QUIT
+17 DO MODOK
+18 QUIT
End DoDot:1
+19 DO DASH
DO RSLT($$COMMMOD^AUMXPORT("AUM6102A")_" patients marked for export because of the Community Code changes.")
+20 QUIT
+21 ;
+22 ; -----------------------------------------------------
+23 ;
