AUM94034 ; DSD/GTH - STANDARD TABLE UPDATES (4), 31MAR94 BANYAN ; [ 04/08/94 1:06 PM ]
;;94.1;TABLE MAINTENANCE;**3**;DECEMBER 15, 1993
;
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 CHAADD,RCDNEW,RCDADD,RCDDEL,ICD0ACT,ICD0INAC
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
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(E_", Changed : "_L) Q
RSLT(%) S ^(0)=$G(^TMP($J,"RSLT",0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q
;
; =================================
;
CHANEW ;
S E="New CHA ICD Recode Table"
F T=1:1 S L=$T(CHANEW+T^AUM9403D) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" 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(E(1)_E_" : CHA ICD RECODE EXISTS => "_C) Q
S DLAYGO=9999999.74,DIC="^AUTTCHA(",X=C,DIC("DR")=".03///"_N D FILE
D ADDFAIL:Y<0,ADDOK:Y>0
I Y>0,'$D(^AUTTCHA(+Y,11)) S ^(11,0)="^9999999.7411^^"
Q
;
CHAADD ;
S E="CHA ICD Recode, add range"
F T=1:1 S L=$T(CHAADD+T^AUM9403D) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" 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(E_" : RANGE EXISTS => "_L) Q
.S DIC="^AUTTCHA("_P_",11,",X=O,DA(1)=P D FILE
.I Y<0 D RSLT(E(0)_E_" : 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(E(0)_E_" : ADD RANGE FAILED => "_L) S DA(1)=P,DA=P(1),DIK="^AUTTCHA("_DA(1)_",11," D DIK Q
.D RSLT(E_" : Added => "_L)
.Q
Q
;
RCDNEW ;
S E="New Recode ICD/APC"
F T=1:1 S L=$T(RCDNEW+T^AUM9403D) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" D ADDRCD
Q
;
ADDRCD ;
S L=$P(L,";;",2),C=$P(L,U),R=$P(L,U,2),N=$P(L,U,3),L=C_" "_R_" "_N
I $D(^AUTTRCD("B",C)) D RSLT(E(1)_E_" : RECODE ICD/APC EXISTS => "_C) Q
S DLAYGO=9999999.08,DIC="^AUTTRCD(",X=C,DIC("DR")=".02///"_R_";.03///"_N D FILE
D ADDFAIL:Y<0,ADDOK:Y>0
I Y>0,'$D(^AUTTRCD(+Y,11)) S ^(11,0)="^9999999.81101^^"
Q
;
RCDADD ;
S E="Recode ICD/APC, add range"
F T=1:1 S L=$T(RCDADD+T^AUM9403D) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" D
.S L=$P(L,";;",2),C=$P(L,U),R=$P(L,U,2),N=$P(L,U,3),O=$P(L,U,4),S=$P(L,U,5)
.S P=$O(^AUTTRCD("B",C,0))
.I 'P S L=";;"_L D ADDRCD Q:Y<0
.S L=C_" "_R_" "_N_" "_O_" "_S
.I $O(^AUTTRCD(P,11,"B",$E(O,1,30),0)),$O(^AUTTRCD(P,11,"B",$E(O,1,30),0))=$O(^AUTTRCD("AH",S_" ",P,0)) D RSLT(E_" : RANGE EXISTS => "_L) Q
.I '$D(^AUTTRCD(P,11)) S ^(11,0)="^9999999.81101^^"
.S DIC="^AUTTRCD("_P_",11,",X=O,DA(1)=P D FILE
.I Y<0 D RSLT(E(0)_E_" : ADD RANGE FAILED => "_L) Q
.S DIE="^AUTTRCD("_P_",11,",DA(1)=P,DA=+Y,P(1)=DA,DR=".02///"_S D DIE
.I $D(Y) D RSLT(E(0)_E_" : ADD RANGE FAILED => "_L) S DA(1)=P,DA=P(1),DIK="^AUTTRCD("_DA(1)_",11," D DIK Q
.D RSLT(E_" : Added => "_L)
.Q
Q
;
RCDDEL ;
S E="Recode ICD/APC, delete range"
F T=1:1 S L=$T(RCDDEL+T^AUM9403D) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" D
.S L=$P(L,";;",2),C=$P(L,U),R=$P(L,U,2),N=$P(L,U,3),O=$P(L,U,4),S=$P(L,U,5),L=C_" "_R_" "_N_" "_O_" "_S
.S P=$O(^AUTTRCD("B",C,0))
.I 'P D RSLT(E_" : Code does not exist => "_L) Q
.I '$O(^AUTTRCD(P,11,"B",$E(O,1,30),0)) D RSLT(E_" : Range does not exist => "_L) Q
.I $O(^AUTTRCD(P,11,"B",$E(O,1,30),0))'=$O(^AUTTRCD("AH",S_" ",P,0)) D RSLT(E_" : Range does not exist => "_L) Q
.S DA(1)=P,DA=$O(^AUTTRCD(P,11,"B",$E(O,1,30),0)),DIK="^AUTTRCD("_DA(1)_",11," D DIK
.D RSLT(E_" : Deleted => "_L)
.Q
Q
;
ICD0ACT ;
S E="ICD0, Activate"
F T=1:1 S L=$T(ICD0ACT+T^AUM9403D) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" D
.S L=$P(L,";;",2),C=$P(L,U),L=C
.S P=$O(^ICD0("B",C,0))
.I 'P S P=$O(^ICD0("AB",C,0))
.I 'P S P=$O(^ICD0("BA",C_" ",0))
.I 'P,+C[$P(C,".",1) S P=$O(^ICD0("BA",+C,0))
.I 'P D RSLT(E_" : Code does not exist => "_L) Q
.S DIE="^ICD0(",DA=P,DR="100///@;102///@" D DIE
.I $D(Y) D RSLT(E(0)_E_" : EDIT ICD0 FAILED => "_L) Q
.D RSLT(E_" : Activated => "_L)
.Q
Q
;
ICD0INAC ;
S E="ICD0, IN-Activate"
F T=1:1 S L=$T(ICD0INAC+T^AUM9403D) Q:$P(L,";",3)="END" I $P(L,U,$L(L,U))="Y" D
.S L=$P(L,";;",2),C=$P(L,U),O=$P(L,U,2),L=C_" "_O
.S P=$O(^ICD0("B",C,0))
.I 'P S P=$O(^ICD0("AB",C,0))
.I 'P S P=$O(^ICD0("BA",C_" ",0))
.I 'P,+C[$P(C,".",1) S P=$O(^ICD0("BA",+C,0))
.I 'P D RSLT(E_" : Code does not exist => "_L) Q
.S DIE="^ICD0(",DA=P,DR="100///1;102///"_O D DIE
.I $D(Y) D RSLT(E(0)_E_" : EDIT ICD0 FAILED => "_L) Q
.D RSLT(E_" : IN-Activated => "_L)
.Q
Q
;
AUM94034 ; DSD/GTH - STANDARD TABLE UPDATES (4), 31MAR94 BANYAN ; [ 04/08/94 1:06 PM ]
+1 ;;94.1;TABLE MAINTENANCE;**3**;DECEMBER 15, 1993
+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 CHAADD
DO RCDNEW
DO RCDADD
DO RCDDEL
DO ICD0ACT
DO ICD0INAC
+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
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(E_", Changed : "_L)
QUIT
RSLT(%) SET ^(0)=$GET(^TMP($JOB,"RSLT",0))+1
SET ^(^(0))=%
IF '$DATA(ZTQUEUED)
WRITE !,%
QUIT
+1 ;
+2 ; =================================
+3 ;
CHANEW ;
+1 SET E="New CHA ICD Recode Table"
+2 FOR T=1:1
SET L=$TEXT(CHANEW+T^AUM9403D)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
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(E(1)_E_" : CHA ICD RECODE EXISTS => "_C)
QUIT
+3 SET DLAYGO=9999999.74
SET DIC="^AUTTCHA("
SET X=C
SET DIC("DR")=".03///"_N
DO FILE
+4 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 IF Y>0
IF '$DATA(^AUTTCHA(+Y,11))
SET ^(11,0)="^9999999.7411^^"
+6 QUIT
+7 ;
CHAADD ;
+1 SET E="CHA ICD Recode, add range"
+2 FOR T=1:1
SET L=$TEXT(CHAADD+T^AUM9403D)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
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(E_" : RANGE EXISTS => "_L)
QUIT
+8 SET DIC="^AUTTCHA("_P_",11,"
SET X=O
SET DA(1)=P
DO FILE
+9 IF Y<0
DO RSLT(E(0)_E_" : ADD RANGE FAILED => "_L)
QUIT
+10 SET DIE="^AUTTCHA("_P_",11,"
SET DA(1)=P
SET DA=+Y
SET P(1)=DA
SET DR=".02///"_S
DO DIE
+11 IF $DATA(Y)
DO RSLT(E(0)_E_" : ADD RANGE FAILED => "_L)
SET DA(1)=P
SET DA=P(1)
SET DIK="^AUTTCHA("_DA(1)_",11,"
DO DIK
QUIT
+12 DO RSLT(E_" : Added => "_L)
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
RCDNEW ;
+1 SET E="New Recode ICD/APC"
+2 FOR T=1:1
SET L=$TEXT(RCDNEW+T^AUM9403D)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
DO ADDRCD
+3 QUIT
+4 ;
ADDRCD ;
+1 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET R=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET L=C_" "_R_" "_N
+2 IF $DATA(^AUTTRCD("B",C))
DO RSLT(E(1)_E_" : RECODE ICD/APC EXISTS => "_C)
QUIT
+3 SET DLAYGO=9999999.08
SET DIC="^AUTTRCD("
SET X=C
SET DIC("DR")=".02///"_R_";.03///"_N
DO FILE
+4 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 IF Y>0
IF '$DATA(^AUTTRCD(+Y,11))
SET ^(11,0)="^9999999.81101^^"
+6 QUIT
+7 ;
RCDADD ;
+1 SET E="Recode ICD/APC, add range"
+2 FOR T=1:1
SET L=$TEXT(RCDADD+T^AUM9403D)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
Begin DoDot:1
+3 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET R=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET O=$PIECE(L,U,4)
SET S=$PIECE(L,U,5)
+4 SET P=$ORDER(^AUTTRCD("B",C,0))
+5 IF 'P
SET L=";;"_L
DO ADDRCD
IF Y<0
QUIT
+6 SET L=C_" "_R_" "_N_" "_O_" "_S
+7 IF $ORDER(^AUTTRCD(P,11,"B",$EXTRACT(O,1,30),0))
IF $ORDER(^AUTTRCD(P,11,"B",$EXTRACT(O,1,30),0))=$ORDER(^AUTTRCD("AH",S_" ",P,0))
DO RSLT(E_" : RANGE EXISTS => "_L)
QUIT
+8 IF '$DATA(^AUTTRCD(P,11))
SET ^(11,0)="^9999999.81101^^"
+9 SET DIC="^AUTTRCD("_P_",11,"
SET X=O
SET DA(1)=P
DO FILE
+10 IF Y<0
DO RSLT(E(0)_E_" : ADD RANGE FAILED => "_L)
QUIT
+11 SET DIE="^AUTTRCD("_P_",11,"
SET DA(1)=P
SET DA=+Y
SET P(1)=DA
SET DR=".02///"_S
DO DIE
+12 IF $DATA(Y)
DO RSLT(E(0)_E_" : ADD RANGE FAILED => "_L)
SET DA(1)=P
SET DA=P(1)
SET DIK="^AUTTRCD("_DA(1)_",11,"
DO DIK
QUIT
+13 DO RSLT(E_" : Added => "_L)
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
RCDDEL ;
+1 SET E="Recode ICD/APC, delete range"
+2 FOR T=1:1
SET L=$TEXT(RCDDEL+T^AUM9403D)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
Begin DoDot:1
+3 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET R=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
SET O=$PIECE(L,U,4)
SET S=$PIECE(L,U,5)
SET L=C_" "_R_" "_N_" "_O_" "_S
+4 SET P=$ORDER(^AUTTRCD("B",C,0))
+5 IF 'P
DO RSLT(E_" : Code does not exist => "_L)
QUIT
+6 IF '$ORDER(^AUTTRCD(P,11,"B",$EXTRACT(O,1,30),0))
DO RSLT(E_" : Range does not exist => "_L)
QUIT
+7 IF $ORDER(^AUTTRCD(P,11,"B",$EXTRACT(O,1,30),0))'=$ORDER(^AUTTRCD("AH",S_" ",P,0))
DO RSLT(E_" : Range does not exist => "_L)
QUIT
+8 SET DA(1)=P
SET DA=$ORDER(^AUTTRCD(P,11,"B",$EXTRACT(O,1,30),0))
SET DIK="^AUTTRCD("_DA(1)_",11,"
DO DIK
+9 DO RSLT(E_" : Deleted => "_L)
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
ICD0ACT ;
+1 SET E="ICD0, Activate"
+2 FOR T=1:1
SET L=$TEXT(ICD0ACT+T^AUM9403D)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
Begin DoDot:1
+3 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET L=C
+4 SET P=$ORDER(^ICD0("B",C,0))
+5 IF 'P
SET P=$ORDER(^ICD0("AB",C,0))
+6 IF 'P
SET P=$ORDER(^ICD0("BA",C_" ",0))
+7 IF 'P
IF +C[$PIECE(C,".",1)
SET P=$ORDER(^ICD0("BA",+C,0))
+8 IF 'P
DO RSLT(E_" : Code does not exist => "_L)
QUIT
+9 SET DIE="^ICD0("
SET DA=P
SET DR="100///@;102///@"
DO DIE
+10 IF $DATA(Y)
DO RSLT(E(0)_E_" : EDIT ICD0 FAILED => "_L)
QUIT
+11 DO RSLT(E_" : Activated => "_L)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
ICD0INAC ;
+1 SET E="ICD0, IN-Activate"
+2 FOR T=1:1
SET L=$TEXT(ICD0INAC+T^AUM9403D)
IF $PIECE(L,";",3)="END"
QUIT
IF $PIECE(L,U,$LENGTH(L,U))="Y"
Begin DoDot:1
+3 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET L=C_" "_O
+4 SET P=$ORDER(^ICD0("B",C,0))
+5 IF 'P
SET P=$ORDER(^ICD0("AB",C,0))
+6 IF 'P
SET P=$ORDER(^ICD0("BA",C_" ",0))
+7 IF 'P
IF +C[$PIECE(C,".",1)
SET P=$ORDER(^ICD0("BA",+C,0))
+8 IF 'P
DO RSLT(E_" : Code does not exist => "_L)
QUIT
+9 SET DIE="^ICD0("
SET DA=P
SET DR="100///1;102///"_O
DO DIE
+10 IF $DATA(Y)
DO RSLT(E(0)_E_" : EDIT ICD0 FAILED => "_L)
QUIT
+11 DO RSLT(E_" : IN-Activated => "_L)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
