AUM93121 ; DSD/GTH - STANDARD TABLE UPDATES (1), 23DEC93 BANYAN ; [ 01/27/94 4:19 PM ]
;;94.1;TABLE MAINTENANCE;**1**;DECEMBER 15, 1993
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 SUNEW,LOCNEW,LOCMOD
Q
;
ADDOK D RSLT(E_", Added : "_L) Q
ADDFAIL D RSLT(E(0)_E_" : ADD FAILED => "_L) Q
DIE NEW A,C,E,L,N,O,P,R,S,T
LOCK +(@(DIE_DA_")")):10 E D RSLT(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) ;EP
S Y=$O(@(X_"""C"",%,0)"))
I 'Y S Y=$T(@%^AUM9312M) 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(E(0)_E_" : "_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
Q +Y
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(E_", Changed : "_L) Q
RSLT(%) S ^(0)=$G(^TMP($J,"RSLT",0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
;
AREANEW ;
S E="New Area Codes"
F T=1:1 S L=$T(AREANEW+T^AUM9312A) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" 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(E(1)_E_" : NAME EXISTS => "_N) Q
I $D(^AUTTAREA("C",A)) D RSLT(E(1)_E_" : CODE EXISTS => "_A) Q
S DLAYGO=9999999.21,DIC="^AUTTAREA(",X=N,DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C D FILE
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
SUNEW ;
S E="New Service Unit Codes"
F T=1:1 S L=$T(SUNEW+T^AUM9312A) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" 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(E(1)_E_" : 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
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
LOCNEW ;
S E="New Location Codes"
F T=1:1 S L=$T(LOCNEW+T^AUM9312A) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" 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(E(1)_E_" : ASUFAC EXISTS => "_L) D Q
.I $P($G(^AUTTLOC(%,0)),U,21) S DIE="^AUTTLOC(",DA=%,DR=".27///@" D DIE D:$D(Y) RSLT(E(1)_E_" : DELETE INACTIVE DATE FAILED => "_L) D:'$D(Y) RSLT(E_" : 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(E(0)_E_" : EDIT INSTITUTION FAILED => "_L) D:'$D(Y) RSLT(E_" : 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(E(0)_E_" : EDIT PSEUDO PREFIX FAILED => "_L) D:'$D(Y) RSLT(E_" : 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(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(E(0)_E_" : ^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
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
LOCMOD ;
S E="Location Code Changes"
F T=1:2 S L=$T(LOCMOD+T^AUM9312A) Q:$P(L,";",3)="END" S L("TO")=$T(LOCMOD+T+1^AUM9312A) I $P(L("TO"),U,$L(L("TO"),U))="Y" 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(E(0)_E_" : 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(E(0)_E_" : EDIT INSTITUTION FAILED => "_L) Q
.D MODOK
.Q
Q
;
CNTYNEW ;
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
S P("S")=$$IEN("^DIC(5,",S) Q:'P("S")
S DIC="^AUTTCTY(",X=N,DIC("DR")=".02////"_P("S")_";.03///"_C D FILE
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
CNTYMOD ;
S E="County Code Changes"
F T=1:2 S L=$T(CNTYMOD+T^AUM9312A) Q:$P(L,";",3)="END" S L("TO")=$T(CNTYMOD+T+1^AUM9312A) I $P(L("TO"),U,$L(L("TO"),U))="Y" 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(E(0)_E_" : EDIT COUNTY FAILED => "_L) Q
.D MODOK
.Q
Q
AUM93121 ; DSD/GTH - STANDARD TABLE UPDATES (1), 23DEC93 BANYAN ; [ 01/27/94 4:19 PM ]
+1 ;;94.1;TABLE MAINTENANCE;**1**;DECEMBER 15, 1993
+2 QUIT
+3 ;
START ;EP
+1 NEW A,C,DIC,DIE,DLAYGO,DR,E,L,N,O,P,R,S,T
+2 SET E(0)="ERROR : "
SET E(1)="NOT ADDED : "
+3 DO SUNEW
DO LOCNEW
DO LOCMOD
+4 QUIT
+5 ;
ADDOK DO RSLT(E_", Added : "_L)
QUIT
ADDFAIL DO RSLT(E(0)_E_" : ADD FAILED => "_L)
QUIT
DIE NEW A,C,E,L,N,O,P,R,S,T
+1 LOCK +(@(DIE_DA_")")):10
IF '$TEST
DO RSLT(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) ;EP
+1 SET Y=$ORDER(@(X_"""C"",%,0)"))
+2 IF 'Y
SET Y=$TEXT(@%^AUM9312M)
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(E(0)_E_" : "_$PIECE(@(X_"0)"),U)_" DOES NOT EXIST => "_%)
+10 QUIT +Y
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(E_", Changed : "_L)
QUIT
RSLT(%) SET ^(0)=$GET(^TMP($JOB,"RSLT",0))+1
SET ^(^(0))=%
IF '$DATA(ZTQUEUED)
WRITE !,%
QUIT
+1 ;
AREANEW ;
+1 SET E="New Area Codes"
+2 FOR T=1:1
SET L=$TEXT(AREANEW+T^AUM9312A)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
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(E(1)_E_" : NAME EXISTS => "_N)
QUIT
+3 IF $DATA(^AUTTAREA("C",A))
DO RSLT(E(1)_E_" : CODE EXISTS => "_A)
QUIT
+4 SET DLAYGO=9999999.21
SET DIC="^AUTTAREA("
SET X=N
SET DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C
DO FILE
+5 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+6 QUIT
+7 ;
SUNEW ;
+1 SET E="New Service Unit Codes"
+2 FOR T=1:1
SET L=$TEXT(SUNEW+T^AUM9312A)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
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(E(1)_E_" : ASU EXISTS => "_A_S)
QUIT
+3 SET P=$$IEN("^AUTTAREA(",A)
IF 'P
QUIT
+4 SET DLAYGO=9999999.22
SET DIC="^AUTTSU("
SET X=N
SET DIC("DR")=".02////"_P_";.03///"_S
DO FILE
+5 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+6 QUIT
+7 ;
LOCNEW ;
+1 SET E="New Location Codes"
+2 FOR T=1:1
SET L=$TEXT(LOCNEW+T^AUM9312A)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
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(E(1)_E_" : ASUFAC EXISTS => "_L)
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(E(1)_E_" : DELETE INACTIVE DATE FAILED => "_L)
IF '$DATA(Y)
DO RSLT(E_" : 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(E(0)_E_" : EDIT INSTITUTION FAILED => "_L)
IF '$DATA(Y)
DO RSLT(E_" : 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(E(0)_E_" : EDIT PSEUDO PREFIX FAILED => "_L)
IF '$DATA(Y)
DO RSLT(E_" : PSEUDO PREFIX UPDATED => "_L)
+10 QUIT
End DoDot:1
QUIT
+11 SET P("A")=$$IEN("^AUTTAREA(",A)
IF 'P("A")
QUIT
+12 SET P("S")=$$IEN("^AUTTSU(",A_S)
IF 'P("S")
QUIT
+13 FOR DINUM=+$PIECE(^DIC(4,0),U,3):1
IF '$DATA(^DIC(4,DINUM))&('$DATA(^AUTTLOC(DINUM)))
QUIT
IF DINUM>99999
DO RSLT(E(0)_"DINUM FOR LOC/INSTITUTION TOO BIG. NOTIFY ISC.")
QUIT
+14 IF DINUM>99999
QUIT
+15 SET DLAYGO=4
SET DIC="^DIC(4,"
SET X=N
DO FILE
+16 IF Y<0
DO RSLT(E(0)_E_" : ^DIC(4 ADD FAILED => "_L)
QUIT
+17 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
DO FILE
+18 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+19 QUIT
+20 ;
LOCMOD ;
+1 SET E="Location Code Changes"
+2 FOR T=1:2
SET L=$TEXT(LOCMOD+T^AUM9312A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(LOCMOD+T+1^AUM9312A)
IF $PIECE(L("TO"),U,$LENGTH(L("TO"),U))="Y"
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)
IF 'P("A")
QUIT
+9 SET P("S")=$$IEN("^AUTTSU(",A_S)
IF 'P("S")
QUIT
+10 SET DIE="^AUTTLOC("
SET DA=P
SET DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.31///"_$PIECE(L("TO"),U,6)
DO DIE
+11 IF $DATA(Y)
DO RSLT(E(0)_E_" : EDIT LOCATION FAILED => "_L)
QUIT
+12 SET DIE="^DIC(4,"
SET DA=$PIECE(^AUTTLOC(P,0),U)
SET DR=".01///"_N
DO DIE
+13 IF $DATA(Y)
DO RSLT(E(0)_E_" : EDIT INSTITUTION FAILED => "_L)
QUIT
+14 DO MODOK
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
CNTYNEW ;
+1 QUIT
+2 ;
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 SET P("S")=$$IEN("^DIC(5,",S)
IF 'P("S")
QUIT
+3 SET DIC="^AUTTCTY("
SET X=N
SET DIC("DR")=".02////"_P("S")_";.03///"_C
DO FILE
+4 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 QUIT
+6 ;
CNTYMOD ;
+1 SET E="County Code Changes"
+2 FOR T=1:2
SET L=$TEXT(CNTYMOD+T^AUM9312A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(CNTYMOD+T+1^AUM9312A)
IF $PIECE(L("TO"),U,$LENGTH(L("TO"),U))="Y"
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)
IF 'P("S")
QUIT
+9 SET DIE="^AUTTCTY("
SET DA=P
SET DR=".01///"_N_";.02////"_P("S")_";.03///"_C
DO DIE
+10 IF $DATA(Y)
DO RSLT(E(0)_E_" : EDIT COUNTY FAILED => "_L)
QUIT
+11 DO MODOK
+12 QUIT
End DoDot:1
+13 QUIT
