- 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 23, 2025@18:02:03 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
