AUM81062 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 5&6OCT1998 MESSAGES ; [ 10/27/1998 11:32 AM ]
;;98.1;TABLE MAINTENANCE;**6**;NOV 17,1997
;
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 DASH,CHAADD,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_")"))
KILL DA,DIE,DR
Q
DIK NEW A,C,E,L,N,O,P,R,S,T D ^DIK KILL DIK Q
FILE NEW A,C,E,L,N,O,P,R,S,T KILL 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("AUM8106",$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)
;
; =================================
;
CHANEW ;
D RSLT("New CHA ICD Recode Table")
F T=1:1 S L=$T(CHANEW+T^AUM8106A) Q:$P(L,";",3)="END" D ADDCHA
Q
;
ADDCHA ;
S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_" "_N
I $D(^AUTTCHA("B",C)) D RSLT($J("",5)_E(1)_" : CHA ICD RECODE EXISTS => "_C) Q
S DLAYGO=9999999.74,DIC="^AUTTCHA(",X=C,DIC("DR")=".03///"_N
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
I Y>0,'$D(^AUTTCHA(+Y,11)) S %=$$ZEROTH(9999999.74,1101) I '(%=-1) S ^AUTTCHA(+Y,11,0)=%
Q
;
CHAADD ;
D RSLT("CHA ICD Recode, Add Range")
F T=1:1 S L=$T(CHAADD+T^AUM8106A) Q:$P(L,";",3)="END" D
. S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),O=$P(L,U,3),S=$P(L,U,4)
. S P=$O(^AUTTCHA("B",C,0))
. I 'P S L=";;"_L D ADDCHA Q:Y<0
. S L=C_" "_N_" "_O_" "_S
. I $O(^AUTTCHA(P,11,"B",$E(O,1,30),0)),$O(^AUTTCHA(P,11,"B",$E(O,1,30),0))=$O(^AUTTCHA("AH",S_" ",P,0)) D RSLT($J("",5)_"Range Exists (That's OK)"),RSLT($J("",10)_"=> "_L) Q
. I '$D(^AUTTCHA(P,11)) S %=$$ZEROTH(9999999.74,1101) I '(%=-1) S ^AUTTCHA(P,11,0)=%
. S DIC="^AUTTCHA("_P_",11,",X=O,DA(1)=P
. D FILE
. I Y<0 D RSLT($J("",5)_E(0)_" : ADD RANGE FAILED => "_L) Q
. S DIE="^AUTTCHA("_P_",11,",DA(1)=P,DA=+Y,P(1)=DA,DR=".02///"_S
. D DIE
. I $D(Y) D RSLT($J("",5)_E(0)_" : ADD RANGE FAILED => "_L) S DA(1)=P,DA=P(1),DIK="^AUTTCHA("_DA(1)_",11," D DIK Q
. D RSLT($J("",5)_"Added => "_L)
.Q
Q
;
AUM81062 ; IHS/ASDST/GTH - STANDARD TABLE UPDATES, 5&6OCT1998 MESSAGES ; [ 10/27/1998 11:32 AM ]
+1 ;;98.1;TABLE MAINTENANCE;**6**;NOV 17,1997
+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 DASH
DO CHAADD
DO DASH
+5 QUIT
+6 ; === utility sub-routines ====
+7 ;
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
+2 IF '$TEST
DO RSLT($JUSTIFY("",5)_E(0)_"Entry '"_DIE_DA_"' IS LOCKED. NOTIFY PROGRAMMER.")
SET Y=1
QUIT
+3 DO ^DIE
+4 LOCK -(@(DIE_DA_")"))
+5 KILL DA,DIE,DR
+6 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("AUM8106",$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 ;
CHANEW ;
+1 DO RSLT("New CHA ICD Recode Table")
+2 FOR T=1:1
SET L=$TEXT(CHANEW+T^AUM8106A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDCHA
+3 QUIT
+4 ;
ADDCHA ;
+1 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET L=C_" "_N
+2 IF $DATA(^AUTTCHA("B",C))
DO RSLT($JUSTIFY("",5)_E(1)_" : CHA ICD RECODE EXISTS => "_C)
QUIT
+3 SET DLAYGO=9999999.74
SET DIC="^AUTTCHA("
SET X=C
SET DIC("DR")=".03///"_N
+4 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 IF Y>0
IF '$DATA(^AUTTCHA(+Y,11))
SET %=$$ZEROTH(9999999.74,1101)
IF '(%=-1)
SET ^AUTTCHA(+Y,11,0)=%
+6 QUIT
+7 ;
CHAADD ;
+1 DO RSLT("CHA ICD Recode, Add Range")
+2 FOR T=1:1
SET L=$TEXT(CHAADD+T^AUM8106A)
IF $PIECE(L,";",3)="END"
QUIT
Begin DoDot:1
+3 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET O=$PIECE(L,U,3)
SET S=$PIECE(L,U,4)
+4 SET P=$ORDER(^AUTTCHA("B",C,0))
+5 IF 'P
SET L=";;"_L
DO ADDCHA
IF Y<0
QUIT
+6 SET L=C_" "_N_" "_O_" "_S
+7 IF $ORDER(^AUTTCHA(P,11,"B",$EXTRACT(O,1,30),0))
IF $ORDER(^AUTTCHA(P,11,"B",$EXTRACT(O,1,30),0))=$ORDER(^AUTTCHA("AH",S_" ",P,0))
DO RSLT($JUSTIFY("",5)_"Range Exists (That's OK)")
DO RSLT($JUSTIFY("",10)_"=> "_L)
QUIT
+8 IF '$DATA(^AUTTCHA(P,11))
SET %=$$ZEROTH(9999999.74,1101)
IF '(%=-1)
SET ^AUTTCHA(P,11,0)=%
+9 SET DIC="^AUTTCHA("_P_",11,"
SET X=O
SET DA(1)=P
+10 DO FILE
+11 IF Y<0
DO RSLT($JUSTIFY("",5)_E(0)_" : ADD RANGE FAILED => "_L)
QUIT
+12 SET DIE="^AUTTCHA("_P_",11,"
SET DA(1)=P
SET DA=+Y
SET P(1)=DA
SET DR=".02///"_S
+13 DO DIE
+14 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_E(0)_" : ADD RANGE FAILED => "_L)
SET DA(1)=P
SET DA=P(1)
SET DIK="^AUTTCHA("_DA(1)_",11,"
DO DIK
QUIT
+15 DO RSLT($JUSTIFY("",5)_"Added => "_L)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
