AUM91112 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 2000FEB10 ; [ 02/28/2000 12:03 PM ]
;;99.1;TABLE MAINTENANCE;**11**;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 TRIBCHK,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^AUM9111A),";",3),":",1)
IEN(X,%,Y) ;
S Y=$O(@(X_"""C"",%,0)"))
I 'Y S Y=$$VAL^AUM9111M(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("AUM9111",$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
;
; -----------------------------------------------------
;
TRIBCHK ;
D RSLT("--> Checking .04 field of TRIBE file")
D RSLT(" to ensure a non-null value.")
S (C,P)=0,N=$P($G(^AUTTTRI(0)),U,3)
D PCT(P,N)
F S P=$O(^AUTTTRI(P)) Q:'(P=+P) D:'$D(ZTQUEUED) PCT(P,N) I '$L($P($G(^(P,0)),"^",4)) D
. S DA=P,DIE="^AUTTTRI(",DR=".04///N"
. D DIE
. I $D(Y) D RSLT(E(0)_E_" : EDIT .04 field of TRIBE FAILED => "_$P(^AUTTTRI(P,0),U)) Q
. S C=C+1
.Q
D RSLT($J("",5)_C_" entries in TRIBE were updated.")
Q
;
; -----------------------------------------------------
;
PCT(C,N) ;
I C=0 W !,"--10%--20%--30%--40%--50%--60%--70%--80%--90%-100%",! Q
F Q:$X>49 Q:(C/N)<($X*.02) W "|"
Q
;
AUM91112 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 2000FEB10 ; [ 02/28/2000 12:03 PM ]
+1 ;;99.1;TABLE MAINTENANCE;**11**;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 TRIBCHK
DO DASH
+6 QUIT
+7 ;
+8 ; -----------------------------------------------------
+9 ;
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^AUM9111A),";",3),":",1)
IEN(X,%,Y) ;
+1 SET Y=$ORDER(@(X_"""C"",%,0)"))
+2 IF 'Y
SET Y=$$VAL^AUM9111M(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("AUM9111",$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 ; -----------------------------------------------------
+11 ;
TRIBCHK ;
+1 DO RSLT("--> Checking .04 field of TRIBE file")
+2 DO RSLT(" to ensure a non-null value.")
+3 SET (C,P)=0
SET N=$PIECE($GET(^AUTTTRI(0)),U,3)
+4 DO PCT(P,N)
+5 FOR
SET P=$ORDER(^AUTTTRI(P))
IF '(P=+P)
QUIT
IF '$DATA(ZTQUEUED)
DO PCT(P,N)
IF '$LENGTH($PIECE($GET(^(P,0)),"^",4))
Begin DoDot:1
+6 SET DA=P
SET DIE="^AUTTTRI("
SET DR=".04///N"
+7 DO DIE
+8 IF $DATA(Y)
DO RSLT(E(0)_E_" : EDIT .04 field of TRIBE FAILED => "_$PIECE(^AUTTTRI(P,0),U))
QUIT
+9 SET C=C+1
+10 QUIT
End DoDot:1
+11 DO RSLT($JUSTIFY("",5)_C_" entries in TRIBE were updated.")
+12 QUIT
+13 ;
+14 ; -----------------------------------------------------
+15 ;
PCT(C,N) ;
+1 IF C=0
WRITE !,"--10%--20%--30%--40%--50%--60%--70%--80%--90%-100%",!
QUIT
+2 FOR
IF $X>49
QUIT
IF (C/N)<($X*.02)
QUIT
WRITE "|"
+3 QUIT
+4 ;
