AUM94122 ; DSD/GTH - STANDARD TABLE UPDATES (2), 05DEC94 BANYAN ; [ 12/06/94 11:41 AM ]
;;95.1;TABLE MAINTENANCE;**1**;NOV 1, 1994
;
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,COMMDEL
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^AUM9412A) 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(E(1)_E_" : STCTYCOM CODE EXISTS => "_S_O_C) Q
S P("O")=$$IEN^AUM94121("^AUTTCTY(",S_O) Q:'P("O")
S P("A")=$$IEN^AUM94121("^AUTTAREA(",A) Q:'P("A")
S P("V")=$$IEN^AUM94121("^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^AUM9412A) Q:$P(L,";",3)="END" S L("TO")=$T(COMMMOD+T+1^AUM9412A) 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^AUM94121("^AUTTCTY(",S_O) Q:'P("O")
.S P("A")=$$IEN^AUM94121("^AUTTAREA(",A) Q:'P("A")
.S P("V")=$$IEN^AUM94121("^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
;
COMMDEL ;
S E="Community Inactivation"
F T=1:1 S L=$T(COMMDEL+T^AUM9412A) Q:$P(L,";",3)="END" D
.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
.S P=$O(^AUTTCOM("C",S_O_C,0))
.I 'P D RSLT(E_" : COMMUNITY NOT FOUND (That's OK) => "_L) Q
.S DIE="^AUTTCOM(",DA=P,DR=".14///<INACTIVE>" D DIE
.I $D(Y) D RSLT(E(0)_E_" : EDIT FAILED => "_L) Q
.D RSLT(E_" : SHORT NAME MARKED '<INACTIVE>' => "_L) Q
.Q
Q
;
TRIBNEW ;
S E="New Tribe Codes"
F T=1:1 S L=$T(TRIBNEW+T^AUM9412A) 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(E(1)_E_" : TRIBE CODE EXISTS => "_C) Q
S DLAYGO=9999999.03,DIC="^AUTTTRI(",X=N,DIC("DR")=".02///"_C D FILE
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
RESNEW ;
S E="New Reservation Codes"
F T=1:1 S L=$T(RESNEW+T^AUM9412A) Q:$P(L,";",3)="END" D ADDRES
Q
;
ADDRES ;
S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3),S=$P(L,U,4),L=C_" "_N_" "_A_" "_S
I $D(^AUTTRES("C",C)) D RSLT(E(1)_E_" : RESERVATION CODE EXISTS => "_C) Q
S P("A")=$$IEN^AUM94121("^AUTTAREA(",A) Q:'P("A")
S P("S")=$$IEN^AUM94121("^DIC(5,",S) Q:'P("S")
S DLAYGO=9999999.47,DIC="^AUTTRES(",X=N,DIC("DR")=".02///"_C_";.03////"_P("S")_";.04////"_P("A") D FILE
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
PCLASNEW ;
S E="New Provider Class Codes"
F T=1:1 S L=$T(PCLASNEW+T^AUM9412B) Q:$P(L,";",3)="END" D ADDPCLAS
Q
;
ADDPCLAS ;
S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3),L=C_" "_N_" "_A
I $D(^DIC(7,"D",C)) D RSLT(E(1)_E_" : PROVIDER CLASS CODE EXISTS => "_C) Q
S DLAYGO=7,DIC="^DIC(7,",X=N,DIC("DR")="1///"_A_";9999999.01///"_C D FILE
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
AUM94122 ; DSD/GTH - STANDARD TABLE UPDATES (2), 05DEC94 BANYAN ; [ 12/06/94 11:41 AM ]
+1 ;;95.1;TABLE MAINTENANCE;**1**;NOV 1, 1994
+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 COMMDEL
+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^AUM9412A)
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(E(1)_E_" : STCTYCOM CODE EXISTS => "_S_O_C)
QUIT
+3 SET P("O")=$$IEN^AUM94121("^AUTTCTY(",S_O)
IF 'P("O")
QUIT
+4 SET P("A")=$$IEN^AUM94121("^AUTTAREA(",A)
IF 'P("A")
QUIT
+5 SET P("V")=$$IEN^AUM94121("^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^AUM9412A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(COMMMOD+T+1^AUM9412A)
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^AUM94121("^AUTTCTY(",S_O)
IF 'P("O")
QUIT
+9 SET P("A")=$$IEN^AUM94121("^AUTTAREA(",A)
IF 'P("A")
QUIT
+10 SET P("V")=$$IEN^AUM94121("^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 ;
COMMDEL ;
+1 SET E="Community Inactivation"
+2 FOR T=1:1
SET L=$TEXT(COMMDEL+T^AUM9412A)
IF $PIECE(L,";",3)="END"
QUIT
Begin DoDot:1
+3 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
+4 SET P=$ORDER(^AUTTCOM("C",S_O_C,0))
+5 IF 'P
DO RSLT(E_" : COMMUNITY NOT FOUND (That's OK) => "_L)
QUIT
+6 SET DIE="^AUTTCOM("
SET DA=P
SET DR=".14///<INACTIVE>"
DO DIE
+7 IF $DATA(Y)
DO RSLT(E(0)_E_" : EDIT FAILED => "_L)
QUIT
+8 DO RSLT(E_" : SHORT NAME MARKED '<INACTIVE>' => "_L)
QUIT
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
TRIBNEW ;
+1 SET E="New Tribe Codes"
+2 FOR T=1:1
SET L=$TEXT(TRIBNEW+T^AUM9412A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDTRIB
+3 QUIT
+4 ;
ADDTRIB ;
+1 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET L=C_" "_N
+2 IF $DATA(^AUTTTRI("C",C))
DO RSLT(E(1)_E_" : TRIBE CODE EXISTS => "_C)
QUIT
+3 SET DLAYGO=9999999.03
SET DIC="^AUTTTRI("
SET X=N
SET DIC("DR")=".02///"_C
DO FILE
+4 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 QUIT
+6 ;
RESNEW ;
+1 SET E="New Reservation Codes"
+2 FOR T=1:1
SET L=$TEXT(RESNEW+T^AUM9412A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDRES
+3 QUIT
+4 ;
ADDRES ;
+1 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET A=$PIECE(L,U,3)
SET S=$PIECE(L,U,4)
SET L=C_" "_N_" "_A_" "_S
+2 IF $DATA(^AUTTRES("C",C))
DO RSLT(E(1)_E_" : RESERVATION CODE EXISTS => "_C)
QUIT
+3 SET P("A")=$$IEN^AUM94121("^AUTTAREA(",A)
IF 'P("A")
QUIT
+4 SET P("S")=$$IEN^AUM94121("^DIC(5,",S)
IF 'P("S")
QUIT
+5 SET DLAYGO=9999999.47
SET DIC="^AUTTRES("
SET X=N
SET DIC("DR")=".02///"_C_";.03////"_P("S")_";.04////"_P("A")
DO FILE
+6 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+7 QUIT
+8 ;
PCLASNEW ;
+1 SET E="New Provider Class Codes"
+2 FOR T=1:1
SET L=$TEXT(PCLASNEW+T^AUM9412B)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDPCLAS
+3 QUIT
+4 ;
ADDPCLAS ;
+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_" "_N_" "_A
+2 IF $DATA(^DIC(7,"D",C))
DO RSLT(E(1)_E_" : PROVIDER CLASS CODE EXISTS => "_C)
QUIT
+3 SET DLAYGO=7
SET DIC="^DIC(7,"
SET X=N
SET DIC("DR")="1///"_A_";9999999.01///"_C
DO FILE
+4 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 QUIT
+6 ;
