AUM61022 ; IHS/ADC/GTH - STANDARD TABLE UPDATES (2), FIELD REQUESTS ; [ 12/11/95 3:59 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 HFADD,DASH,EDTADD,DASH
Q
;
; === utility sub-routines ====
;
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
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)
;
;
; =================================
;
HFADD ;
D RSLT("New Health Factor Entries")
F T=1:1 S L=$T(HFADD+T^AUM6102B) Q:$P(L,";",3)="END" D ADDHF
Q
;
ADDHF ;
S L=$P(L,";;",2),N=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),R=$P(L,U,4),S=$P(L,U,5),L=N_" "_O_" "_C_" "_R_" "_S
I $D(^AUTTHF("B",N)) D RSLT($J("",5)_E(1)_"HEALTH FACTOR EXISTS => "_N) Q
S DLAYGO=9999999.64,DIC="^AUTTHF(",X=N,DIC("DR")=".02///"_O_";.03///"_C_";.08///"_R_";.1///"_S
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
Q
;
; =================================
;
EDTADD ;
D RSLT("New Education Topics")
F T=1:1 S L=$T(EDTADD+T^AUM6102B) Q:$P(L,";",3)="END" D ADDEDT
Q
;
ADDEDT ;
S L=$P(L,";;",2),N=$P(L,U),O=$P(L,U,2),L=N_" "_O
I $D(^AUTTEDT("B",N)) D RSLT($J("",5)_E(1)_"EDUCATION TOPIC EXISTS => "_N) Q
S DLAYGO=9999999.09,DIC="^AUTTEDT(",X=N,DIC("DR")="1///"_O
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
Q
;
AUM61022 ; IHS/ADC/GTH - STANDARD TABLE UPDATES (2), FIELD REQUESTS ; [ 12/11/95 3:59 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 SET E(0)="ERROR : "
SET E(1)="NOT ADDED : "
+4 DO HFADD
DO DASH
DO EDTADD
DO DASH
+5 QUIT
+6 ;
+7 ; === utility sub-routines ====
+8 ;
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
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 ;
+9 ; =================================
+10 ;
HFADD ;
+1 DO RSLT("New Health Factor Entries")
+2 FOR T=1:1
SET L=$TEXT(HFADD+T^AUM6102B)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDHF
+3 QUIT
+4 ;
ADDHF ;
+1 SET L=$PIECE(L,";;",2)
SET N=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
SET R=$PIECE(L,U,4)
SET S=$PIECE(L,U,5)
SET L=N_" "_O_" "_C_" "_R_" "_S
+2 IF $DATA(^AUTTHF("B",N))
DO RSLT($JUSTIFY("",5)_E(1)_"HEALTH FACTOR EXISTS => "_N)
QUIT
+3 SET DLAYGO=9999999.64
SET DIC="^AUTTHF("
SET X=N
SET DIC("DR")=".02///"_O_";.03///"_C_";.08///"_R_";.1///"_S
+4 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 QUIT
+6 ;
+7 ; =================================
+8 ;
EDTADD ;
+1 DO RSLT("New Education Topics")
+2 FOR T=1:1
SET L=$TEXT(EDTADD+T^AUM6102B)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDEDT
+3 QUIT
+4 ;
ADDEDT ;
+1 SET L=$PIECE(L,";;",2)
SET N=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET L=N_" "_O
+2 IF $DATA(^AUTTEDT("B",N))
DO RSLT($JUSTIFY("",5)_E(1)_"EDUCATION TOPIC EXISTS => "_N)
QUIT
+3 SET DLAYGO=9999999.09
SET DIC="^AUTTEDT("
SET X=N
SET DIC("DR")="1///"_O
+4 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 QUIT
+6 ;
