AUM93062 ; DSD/GTH - STANDARD TABLE UPDATES (2), 16JUN93 MEMO ; [ 06/23/93 9:15 AM ]
;;93.1;TABLE MAINTENANCE;**4**;MARCH 23, 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 COMMNEW,COMMMOD,PKG
Q
; === utility sub-routines ====
;
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
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
;
; =================================
;
COMMNEW ;
S E="New Community Codes"
F T=1:1 S L=$T(COMMNEW+T^AUM9306A) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" 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(E(1)_E_" : STCTYCOM CODE EXISTS => "_S_O_C) Q
S P("O")=$$IEN^AUM93061("^AUTTCTY(",S_O) Q:'P("O")
S P("A")=$$IEN^AUM93061("^AUTTAREA(",A) Q:'P("A")
S P("V")=$$IEN^AUM93061("^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
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
COMMMOD ;
S E="Community Code Changes"
F T=1:2 S L=$T(COMMMOD+T^AUM9306A) Q:$P(L,";",3)="END" S L("TO")=$T(COMMMOD+T+1^AUM9306A) I $P(L("TO"),U,$L(L("TO"),U))="Y" 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^AUM93061("^AUTTCTY(",S_O) Q:'P("O")
.S P("A")=$$IEN^AUM93061("^AUTTAREA(",A) Q:'P("A")
.S P("V")=$$IEN^AUM93061("^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(E(0)_E_" : CHANGE FAILED => "_L) Q
.D MODOK
.Q
Q
;
CLINNEW ;
S E="New Clinic Codes"
F T=1:1 S L=$T(CLINNEW+T^AUM9306A) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" D ADDCLIN
Q
;
ADDCLIN ;
S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_" "_N
I $D(^DIC(40.7,"C",C)) D RSLT(E(1)_E_" : CLINIC STOP CODE EXISTS => "_C) Q
S DLAYGO=40.7,DIC="^DIC(40.7,",X=N,DIC("DR")="1///"_C D FILE
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
CLINMOD ;
Q
;
PKG ;
; This subroutine is for patch 4, to update the current version
; of AUM, and should not be included in subsequent patches.
;
NEW DA,DIC,DIE,DR
;
S DA=$O(^DIC(9.4,"C","AUM",0))
;
I 'DA KILL DA S DLAYGO=9.4,DIC="^DIC(9.4,",X="ICD UPDATE",DIC("DR")="1///AUM" D FILE S DA=+Y I Y<0 D RSLT(E(0)_"COULD NOT PUT AUM ENTRY IN PACKAGE FILE") Q
S DIE="^DIC(9.4,",DR="13///93.1" D DIE
I $D(Y) D RSLT(E(0)_"COULD NOT UPDATE CURRENT VERSION IN PACKAGE FILE") I 1
E D RSLT("CURRENT VERSION of AUM updated TO 93.1.")
S DA=$O(^DIC(9.4,"C","AUM",0))
I '$D(^DIC(9.4,DA,22,0)) S ^(0)="^9.49I^^"
Q:$O(^DIC(9.4,DA,22,"B",93.1,0))
S X=93.1,DIC="^DIC(9.4,"_DA_",22,",DIC("DR")="1///MARCH 23, 1993",DA(1)=DA D FILE
Q
;
AUM93062 ; DSD/GTH - STANDARD TABLE UPDATES (2), 16JUN93 MEMO ; [ 06/23/93 9:15 AM ]
+1 ;;93.1;TABLE MAINTENANCE;**4**;MARCH 23, 1993
+2 ;
+3 QUIT
+4 ;
START ;EP
+1 ;
+2 NEW A,C,DIC,DIE,DLAYGO,DR,E,L,N,O,P,R,S,T
+3 SET E(0)="ERROR : "
SET E(1)="NOT ADDED : "
+4 DO COMMNEW
DO COMMMOD
DO PKG
+5 QUIT
+6 ; === utility sub-routines ====
+7 ;
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
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 ;
+2 ; =================================
+3 ;
COMMNEW ;
+1 SET E="New Community Codes"
+2 FOR T=1:1
SET L=$TEXT(COMMNEW+T^AUM9306A)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
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(E(1)_E_" : STCTYCOM CODE EXISTS => "_S_O_C)
QUIT
+3 SET P("O")=$$IEN^AUM93061("^AUTTCTY(",S_O)
IF 'P("O")
QUIT
+4 SET P("A")=$$IEN^AUM93061("^AUTTAREA(",A)
IF 'P("A")
QUIT
+5 SET P("V")=$$IEN^AUM93061("^AUTTSU(",A_V)
IF 'P("V")
QUIT
+6 SET DLAYGO=9999999.05
SET DIC="^AUTTCOM("
SET X=N
SET DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
DO FILE
+7 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+8 QUIT
+9 ;
COMMMOD ;
+1 SET E="Community Code Changes"
+2 FOR T=1:2
SET L=$TEXT(COMMMOD+T^AUM9306A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(COMMMOD+T+1^AUM9306A)
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 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^AUM93061("^AUTTCTY(",S_O)
IF 'P("O")
QUIT
+9 SET P("A")=$$IEN^AUM93061("^AUTTAREA(",A)
IF 'P("A")
QUIT
+10 SET P("V")=$$IEN^AUM93061("^AUTTSU(",A_V)
IF 'P("V")
QUIT
+11 SET DIE="^AUTTCOM("
SET DA=P
SET DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C
DO DIE
+12 IF $DATA(Y)
DO RSLT(E(0)_E_" : CHANGE FAILED => "_L)
QUIT
+13 DO MODOK
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
CLINNEW ;
+1 SET E="New Clinic Codes"
+2 FOR T=1:1
SET L=$TEXT(CLINNEW+T^AUM9306A)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
DO ADDCLIN
+3 QUIT
+4 ;
ADDCLIN ;
+1 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET L=C_" "_N
+2 IF $DATA(^DIC(40.7,"C",C))
DO RSLT(E(1)_E_" : CLINIC STOP CODE EXISTS => "_C)
QUIT
+3 SET DLAYGO=40.7
SET DIC="^DIC(40.7,"
SET X=N
SET DIC("DR")="1///"_C
DO FILE
+4 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 QUIT
+6 ;
CLINMOD ;
+1 QUIT
+2 ;
PKG ;
+1 ; This subroutine is for patch 4, to update the current version
+2 ; of AUM, and should not be included in subsequent patches.
+3 ;
+4 NEW DA,DIC,DIE,DR
+5 ;
+6 SET DA=$ORDER(^DIC(9.4,"C","AUM",0))
+7 ;
+8 IF 'DA
KILL DA
SET DLAYGO=9.4
SET DIC="^DIC(9.4,"
SET X="ICD UPDATE"
SET DIC("DR")="1///AUM"
DO FILE
SET DA=+Y
IF Y<0
DO RSLT(E(0)_"COULD NOT PUT AUM ENTRY IN PACKAGE FILE")
QUIT
+9 SET DIE="^DIC(9.4,"
SET DR="13///93.1"
DO DIE
+10 IF $DATA(Y)
DO RSLT(E(0)_"COULD NOT UPDATE CURRENT VERSION IN PACKAGE FILE")
IF 1
+11 IF '$TEST
DO RSLT("CURRENT VERSION of AUM updated TO 93.1.")
+12 SET DA=$ORDER(^DIC(9.4,"C","AUM",0))
+13 IF '$DATA(^DIC(9.4,DA,22,0))
SET ^(0)="^9.49I^^"
+14 IF $ORDER(^DIC(9.4,DA,22,"B",93.1,0))
QUIT
+15 SET X=93.1
SET DIC="^DIC(9.4,"_DA_",22,"
SET DIC("DR")="1///MARCH 23, 1993"
SET DA(1)=DA
DO FILE
+16 QUIT
+17 ;
