AUM91102 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999DEC01 ; [ 12/09/1999 10:15 AM ]
;;99.1;TABLE MAINTENANCE;**10**;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 TRIBNEW,DASH,HFADD,DASH,DXPRMOD,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^AUM9110A),";",3),":",1)
IEN(X,%,Y) ;
S Y=$O(@(X_"""C"",%,0)"))
I 'Y S Y=$$VAL^AUM9110M(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("AUM9110",$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
;
; -----------------------------------------------------
;
HFADD ;
D RSLT($$E("HFADD"))
F T=1:1 S L=$T(HFADD+T^AUM9110A) Q:$P(L,";",3)="END" D ADDHF
KILL DLAYGO
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
;
; -----------------------------------------------------
;
TRIBNEW ;
S E=$$E("TRIBNEW")
D RSLT(E)
D RSLT($J("",13)_"CCC NAME")
D RSLT($J("",13)_"--- ----")
F T=1:1 S L=$T(TRIBNEW+T^AUM9110A) 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($J("",5)_E(1)_"TRIBE CODE EXISTS => "_C) Q
S DLAYGO=9999999.03,DIC="^AUTTTRI(",X=N,DIC("DR")=".02///"_C
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
Q
;
; -----------------------------------------------------
;
ADDDXPR ;
S L=$P(L,";;",2),R=$P(L,U),M=$P(L,U,2),N=$P(L,U,3),S=$P(L,U,4),C=$P(L,U,5),O=$P(L,U,6),L=R_"..."_M_"..."
I $D(^AUTTDXPR("B",R)) D RSLT($J("",5)_E(1)_"DIAGNOSTIC PROCEDURE RESULT EXISTS => "_R) Q
S DLAYGO=9999999.68,DIC="^AUTTDXPR(",X=R,DIC("DR")=".02///"_M_";.07///"_S_";3///"_O
;
; The Input Transform for the .01 field requires a variable from the
; Medicine Package be SET. I'll fix the dd next year.
; gth 12/08/99
S (DINUM,MCQSDXPR)=691.500002
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
KILL MCQSDXPR,DINUM
Q:Y<0
;
; Field .03 must be direct SET since value contains ";" and
; disrupts the parsing of DR by FileMan. gth 12/08/99
S $P(^AUTTDXPR(+Y,0),U,3)=N
;
; edit WP field DESCRIPTION.
S DIE="^AUTTDXPR(",DA=+Y,DR="2///"_C,DR(1,9999999.68)="2;",DR(2,9999999.682)=".01"
D DIE
I $D(Y) D RSLT($J("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT DESCRIPTION FAILED => "_L) Q
D DISDXPR
KILL DLAYGO
Q
;
DXPRMOD ;
S E=$$E("DXPRMOD")
D RSLT(E)
F T=1:2 S L=$T(DXPRMOD+T^AUM9110A) Q:$P(L,";",3)="END" S L("TO")=$T(DXPRMOD+T+1^AUM9110A) D
. S L=$P(L,U,2,99),R=$P(L,U)
. S P=$O(^AUTTDXPR("B",R,0))
. S L=$P(L("TO"),U,2,99),R=$P(L,U),M=$P(L,U,2),N=$P(L,U,3),S=$P(L,U,4),C=$P(L,U,5),O=$P(L,U,6)
. I 'P S L=";;"_L D ADDDXPR Q
. S L=R_"..."_M_"..."
. S DIE="^AUTTDXPR(",DA=P,DR=".02///"_M_";.07///"_S_";3///"_O
. D DIE
. I $D(Y) D RSLT($J("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT FAILED => "_L) Q
. ; Field .03 must be direct SET since value contains ";" and
. ; disrupts the parsing of DR by FileMan. gth 12/08/99
. S $P(^AUTTDXPR(P,0),U,3)=N
. ; edit WP field DESCRIPTION.
. S DIE="^AUTTDXPR(",DA=P,DR="2///"_C,DR(1,9999999.68)="2;",DR(2,9999999.682)=".01"
. D DIE
. I $D(Y) D RSLT($J("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT DESCRIPTION FAILED => "_L) Q
. D MODOK,DISDXPR
.Q
Q
;
DISDXPR ;
D RSLT(" RESULT: "_R),RSLT(" DATA TYPE: "_M),RSLT(" PARAMS: "_N),RSLT("AQ INDEX ACTIVE: "_S),RSLT(" DESCRIPTION: "_C),RSLT(" HELP MESSAGE: "_O)
Q
;
; -----------------------------------------------------
;
AUM91102 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 1999DEC01 ; [ 12/09/1999 10:15 AM ]
+1 ;;99.1;TABLE MAINTENANCE;**10**;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 TRIBNEW
DO DASH
DO HFADD
DO DASH
DO DXPRMOD
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^AUM9110A),";",3),":",1)
IEN(X,%,Y) ;
+1 SET Y=$ORDER(@(X_"""C"",%,0)"))
+2 IF 'Y
SET Y=$$VAL^AUM9110M(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("AUM9110",$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 ;
HFADD ;
+1 DO RSLT($$E("HFADD"))
+2 FOR T=1:1
SET L=$TEXT(HFADD+T^AUM9110A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDHF
+3 KILL DLAYGO
+4 QUIT
+5 ;
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 ;
TRIBNEW ;
+1 SET E=$$E("TRIBNEW")
+2 DO RSLT(E)
+3 DO RSLT($JUSTIFY("",13)_"CCC NAME")
+4 DO RSLT($JUSTIFY("",13)_"--- ----")
+5 FOR T=1:1
SET L=$TEXT(TRIBNEW+T^AUM9110A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDTRIB
+6 QUIT
+7 ;
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($JUSTIFY("",5)_E(1)_"TRIBE CODE EXISTS => "_C)
QUIT
+3 SET DLAYGO=9999999.03
SET DIC="^AUTTTRI("
SET X=N
SET DIC("DR")=".02///"_C
+4 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 QUIT
+6 ;
+7 ; -----------------------------------------------------
+8 ;
ADDDXPR ;
+1 SET L=$PIECE(L,";;",2)
SET R=$PIECE(L,U)
SET M=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET S=$PIECE(L,U,4)
SET C=$PIECE(L,U,5)
SET O=$PIECE(L,U,6)
SET L=R_"..."_M_"..."
+2 IF $DATA(^AUTTDXPR("B",R))
DO RSLT($JUSTIFY("",5)_E(1)_"DIAGNOSTIC PROCEDURE RESULT EXISTS => "_R)
QUIT
+3 SET DLAYGO=9999999.68
SET DIC="^AUTTDXPR("
SET X=R
SET DIC("DR")=".02///"_M_";.07///"_S_";3///"_O
+4 ;
+5 ; The Input Transform for the .01 field requires a variable from the
+6 ; Medicine Package be SET. I'll fix the dd next year.
+7 ; gth 12/08/99
+8 SET (DINUM,MCQSDXPR)=691.500002
+9 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+10 KILL MCQSDXPR,DINUM
+11 IF Y<0
QUIT
+12 ;
+13 ; Field .03 must be direct SET since value contains ";" and
+14 ; disrupts the parsing of DR by FileMan. gth 12/08/99
+15 SET $PIECE(^AUTTDXPR(+Y,0),U,3)=N
+16 ;
+17 ; edit WP field DESCRIPTION.
+18 SET DIE="^AUTTDXPR("
SET DA=+Y
SET DR="2///"_C
SET DR(1,9999999.68)="2;"
SET DR(2,9999999.682)=".01"
+19 DO DIE
+20 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT DESCRIPTION FAILED => "_L)
QUIT
+21 DO DISDXPR
+22 KILL DLAYGO
+23 QUIT
+24 ;
DXPRMOD ;
+1 SET E=$$E("DXPRMOD")
+2 DO RSLT(E)
+3 FOR T=1:2
SET L=$TEXT(DXPRMOD+T^AUM9110A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(DXPRMOD+T+1^AUM9110A)
Begin DoDot:1
+4 SET L=$PIECE(L,U,2,99)
SET R=$PIECE(L,U)
+5 SET P=$ORDER(^AUTTDXPR("B",R,0))
+6 SET L=$PIECE(L("TO"),U,2,99)
SET R=$PIECE(L,U)
SET M=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET S=$PIECE(L,U,4)
SET C=$PIECE(L,U,5)
SET O=$PIECE(L,U,6)
+7 IF 'P
SET L=";;"_L
DO ADDDXPR
QUIT
+8 SET L=R_"..."_M_"..."
+9 SET DIE="^AUTTDXPR("
SET DA=P
SET DR=".02///"_M_";.07///"_S_";3///"_O
+10 DO DIE
+11 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT FAILED => "_L)
QUIT
+12 ; Field .03 must be direct SET since value contains ";" and
+13 ; disrupts the parsing of DR by FileMan. gth 12/08/99
+14 SET $PIECE(^AUTTDXPR(P,0),U,3)=N
+15 ; edit WP field DESCRIPTION.
+16 SET DIE="^AUTTDXPR("
SET DA=P
SET DR="2///"_C
SET DR(1,9999999.68)="2;"
SET DR(2,9999999.682)=".01"
+17 DO DIE
+18 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_"EDIT DIAGNOSTIC PROCEDURE RESULT DESCRIPTION FAILED => "_L)
QUIT
+19 DO MODOK
DO DISDXPR
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
DISDXPR ;
+1 DO RSLT(" RESULT: "_R)
DO RSLT(" DATA TYPE: "_M)
DO RSLT(" PARAMS: "_N)
DO RSLT("AQ INDEX ACTIVE: "_S)
DO RSLT(" DESCRIPTION: "_C)
DO RSLT(" HELP MESSAGE: "_O)
+2 QUIT
+3 ;
+4 ; -----------------------------------------------------
+5 ;
