ICD14PST ;SSI/ALA-POST INSTALL FOR DRG GROUPER ;[ 05/28/97 6:43 PM ]
;;14.0;DRG Grouper;;Apr 03, 1997
;
EN ; Entry Point for DRG Post Init
D DRG,DXN,PRC
D DELETE
K I,T1
F DIK="^ICM(","^ICD(" D IXALL^DIK
F I=80,80.1 F J="DD","DEL","LAYGO","WR" S ^DIC(I,0,J)="@"
F I=80,80.1 S ^DIC(I,0,"RD")="d"
K CT,I,J,DA,DIK,%X,%Y,FL
Q
DRG ; Update DRG information from file #80.9
S (I,CT)=0
F S I=$O(^ICDYZ(80.9,I)) Q:'I D S CT=CT+1 W:CT#25=0 "."
. S $P(^ICD(I,0),U)=$P(^ICDYZ(80.9,I,0),U)
. S $P(^ICD(I,0),U,5)=$P(^ICDYZ(80.9,I,0),U,5)
. S $P(^ICD(I,0),U,6)=$P(^ICDYZ(80.9,I,0),U,6)
. I '$D(^ICD(I,1,0)) S ^ICD(I,1,0)="^80.21A^^"
. S T1=0
. F S T1=$O(^ICDYZ(80.9,I,1,T1)) Q:'T1 S ^ICD(I,1,T1,0)=^ICDYZ(80.9,I,1,T1,0),$P(^ICD(I,1,0),"^",3,4)=T1_"^"_T1
. S:$D(^ICDYZ(80.9,I,"MC1")) ^ICD(I,"MC1")=^ICDYZ(80.9,I,"MC1")
. S DA=I,DIK="^ICD(" D IX1^DIK
Q
DXN ; Update Diagnosis File #80
S (DA,CT)=0,DIK="^ICD9("
F S DA=$O(^ICDYZ(80.7,DA)) Q:'DA D S CT=CT+1 W:CT#25=0 "."
. D ^DIK
. S %X="^ICDYZ(80.7,"_DA_",",%Y="^ICD9("_DA_","
. D %XY^%RCR
. I $D(^ICD9(DA,"N")) S $P(^ICD9(DA,"N",0),U,2)="80.01P"
. I $D(^ICD9(DA,"R")) S $P(^ICD9(DA,"R",0),U,2)="80.02P"
. I $D(^ICD9(DA,2)) S $P(^ICD9(DA,2,0),U,2)="80.03P"
. D IX1^DIK
Q
PRC ; Update Procedure File #80.1
S (DA,CT)=0,DIK="^ICD0("
F S DA=$O(^ICDYZ(80.8,DA)) Q:'DA D S CT=CT+1 W:CT#25=0 "."
. D ^DIK
. S %X="^ICDYZ(80.8,"_DA_",",%Y="^ICD0("_DA_","
. D %XY^%RCR
. I $D(^ICD0(DA,"MDC")) S $P(^ICD0(DA,"MDC",0),U,2)="80.12PA"
. D IX1^DIK
Q
DELETE ; Delete Temporary Files #80.7,#80.8,#80.9
F FL=80.7,80.8,80.9 S I=0 D
. F S I=$O(^ICDYZ(FL,I)) Q:I="" K ^ICDYZ(FL,I)
. S $P(^ICDYZ(FL,0),U,3,4)="0^0"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD14PST 1734 printed Apr 09, 2024@20:55:05 Page 2
ICD14PST ;SSI/ALA-POST INSTALL FOR DRG GROUPER ;[ 05/28/97 6:43 PM ]
+1 ;;14.0;DRG Grouper;;Apr 03, 1997
+2 ;
EN ; Entry Point for DRG Post Init
+1 DO DRG
DO DXN
DO PRC
+2 DO DELETE
+3 KILL I,T1
+4 FOR DIK="^ICM(","^ICD("
DO IXALL^DIK
+5 FOR I=80,80.1
FOR J="DD","DEL","LAYGO","WR"
SET ^DIC(I,0,J)="@"
+6 FOR I=80,80.1
SET ^DIC(I,0,"RD")="d"
+7 KILL CT,I,J,DA,DIK,%X,%Y,FL
+8 QUIT
DRG ; Update DRG information from file #80.9
+1 SET (I,CT)=0
+2 FOR
SET I=$ORDER(^ICDYZ(80.9,I))
if 'I
QUIT
Begin DoDot:1
+3 SET $PIECE(^ICD(I,0),U)=$PIECE(^ICDYZ(80.9,I,0),U)
+4 SET $PIECE(^ICD(I,0),U,5)=$PIECE(^ICDYZ(80.9,I,0),U,5)
+5 SET $PIECE(^ICD(I,0),U,6)=$PIECE(^ICDYZ(80.9,I,0),U,6)
+6 IF '$DATA(^ICD(I,1,0))
SET ^ICD(I,1,0)="^80.21A^^"
+7 SET T1=0
+8 FOR
SET T1=$ORDER(^ICDYZ(80.9,I,1,T1))
if 'T1
QUIT
SET ^ICD(I,1,T1,0)=^ICDYZ(80.9,I,1,T1,0)
SET $PIECE(^ICD(I,1,0),"^",3,4)=T1_"^"_T1
+9 if $DATA(^ICDYZ(80.9,I,"MC1"))
SET ^ICD(I,"MC1")=^ICDYZ(80.9,I,"MC1")
+10 SET DA=I
SET DIK="^ICD("
DO IX1^DIK
End DoDot:1
SET CT=CT+1
if CT#25=0
WRITE "."
+11 QUIT
DXN ; Update Diagnosis File #80
+1 SET (DA,CT)=0
SET DIK="^ICD9("
+2 FOR
SET DA=$ORDER(^ICDYZ(80.7,DA))
if 'DA
QUIT
Begin DoDot:1
+3 DO ^DIK
+4 SET %X="^ICDYZ(80.7,"_DA_","
SET %Y="^ICD9("_DA_","
+5 DO %XY^%RCR
+6 IF $DATA(^ICD9(DA,"N"))
SET $PIECE(^ICD9(DA,"N",0),U,2)="80.01P"
+7 IF $DATA(^ICD9(DA,"R"))
SET $PIECE(^ICD9(DA,"R",0),U,2)="80.02P"
+8 IF $DATA(^ICD9(DA,2))
SET $PIECE(^ICD9(DA,2,0),U,2)="80.03P"
+9 DO IX1^DIK
End DoDot:1
SET CT=CT+1
if CT#25=0
WRITE "."
+10 QUIT
PRC ; Update Procedure File #80.1
+1 SET (DA,CT)=0
SET DIK="^ICD0("
+2 FOR
SET DA=$ORDER(^ICDYZ(80.8,DA))
if 'DA
QUIT
Begin DoDot:1
+3 DO ^DIK
+4 SET %X="^ICDYZ(80.8,"_DA_","
SET %Y="^ICD0("_DA_","
+5 DO %XY^%RCR
+6 IF $DATA(^ICD0(DA,"MDC"))
SET $PIECE(^ICD0(DA,"MDC",0),U,2)="80.12PA"
+7 DO IX1^DIK
End DoDot:1
SET CT=CT+1
if CT#25=0
WRITE "."
+8 QUIT
DELETE ; Delete Temporary Files #80.7,#80.8,#80.9
+1 FOR FL=80.7,80.8,80.9
SET I=0
Begin DoDot:1
+2 FOR
SET I=$ORDER(^ICDYZ(FL,I))
if I=""
QUIT
KILL ^ICDYZ(FL,I)
+3 SET $PIECE(^ICDYZ(FL,0),U,3,4)="0^0"
End DoDot:1
+4 QUIT
