- ACHSGRP ; IHS/ITSC/PMF - CHS DRG GROUPER MODIFIED FROM AICDGRP & AICDGRP1 ; [ 10/16/2001 8:16 AM ]
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- ARR ;EP
- S Y=ACHSICDX(ACHSICDJ),Y(0)=ACHSICDX(ACHSICDJ,0),ACHSMDC=$P(Y(0),U,5) I ACHSMDC=469 Q
- CD K RG
- S ACHSPD=$P(Y(0),U,2),RG=0 I ACHSMDC=12 S ACHSMDC=$S(ACHSSEX="F":13,1:12)
- F ACHSNDR=1:1 S RG=$O(^ICD9(+Y,"DR",RG)) Q:RG'>0 S RG(RG)=""
- MORE I ACHSMDC=5,'ACHSNOR!(ACHSOR'["O") D MI,WRT:RG>0 Q
- I ACHSMDC=18,ACHSOR["O" S RG=415 D WRT Q
- I ACHSMDC=19,ACHSOR["O" S RG=424 D WRT Q
- I ACHSMDC=23,ACHSOR["O" S RG=461 D WRT Q
- I ACHSMDC=14 D DGDRG14,WRT Q
- I ACHSMDC=20,ACHSDAM S RG=433 D WRT Q
- I ACHSMDC=22 S:'$D(ACHSTAC) ACHSTAC=0 S RG=$S(ACHSTAC:456,ACHSPD["*"!(ACHSSD["*"):457,ACHSOR'["O":460,1:0) I RG D WRT Q
- I '$D(ACHSTRS) S ACHSTRS=""
- I '$D(ACHSEXP) S ACHSEXP=""
- I ACHSMDC=15,ACHSTRS!ACHSEXP S RG=385 D WRT Q
- I ACHSMDC=15,ACHSSD1 S RG=391 D WRT Q
- I 'ACHSNOR,ACHSNDR<3 S RG=$O(RG(0)) D:RG'>0 469 D WRT Q
- I 'ACHSNOR S RG=$O(RG(0)) X:$D(^ICD(RG,"MC")) ^ICD(RG,"MC") D WRT Q
- ;
- D DGDRG6:ACHSMDC=6,DGDRG8:ACHSMDC=8,DGDRG2:ACHSMDC=2,DGDRG3:ACHSMDC=3 S RG=$O(ACHSORG(ACHSMDC,0)) G:RG'>0 NOP X:$D(^ICD(RG,"MC")) ^ICD(RG,"MC") D WRT Q
- ;
- NOP I ACHSOR["O",ACHSMDC'=20 D 468 Q
- D S RG=$O(RG(0)) X:$D(^ICD(RG,"MC")) ^ICD(RG,"MC") D:RG'>0 469 D WRT Q
- WRT D:'$D(RG) 469 Q:RG<0 S ACHSGCAL=$G(^ICD(RG,0)),ACHSICDN=$P(ACHSGCAL,U,7) I ACHSICDN'="" D SETDRG
- Q
- SETDRG I '$D(ACHSICDE(9-ACHSICDN)) S ACHSICDE(9-ACHSICDN)=ACHSGCAL,ACHSICDE(9-ACHSICDN,1)=Y(0) Q
- I ACHSGCAL'=ACHSICDE(9-ACHSICDN) S ACHSICDN=ACHSICDN+.000001 G SETDRG
- F I=1:1 I '$D(ACHSICDE(9-ACHSICDN,I)) S ACHSICDE(9-ACHSICDN,I)=Y(0) Q
- Q
- ;
- 469 S RG=469 W *7,!!,"DRG= 469 PDX INVALID AS DISCHARGE DIAGNOSIS" Q
- 468 ;
- S ACHSOR="",ACHSNOR=0
- D CD
- Q
- MI I ACHSPD["I"!(ACHSSD["I") S RG=$S($S($D(ACHSEXP):ACHSEXP,1:0):123,ACHSPD["V"!(ACHSSD["V"):121,1:122) Q
- KILLS ;EP
- K ACHSICDX,ACHSICDE,ACHSICDI,ACHSICDJ,ACHSICDK,ACHSICDL,ACHSICDN,ACHSICDT
- K ACHSDGFL,ACHSDAM,ACHSPT,Q,RG,ACHSSD,ACHSSD1,T,ACHSTAC,Y,DIC,ACHSGCAL,I,L,ACHSMDC,ACHSNDR,ACHSNOR,ACHSOR,ACHSPD,%,%DT,ACHSSEX,ACHSEXP,ACHSORG,ACHSTRS,ACHSNSD,C,ACHSWD2,W,S,AGE
- Q
- DGDRG2 ;
- Q:$O(ACHSORG(ACHSMDC,0))'>0 K JJ F JJ=0:0 S JJ=$O(ACHSORG(ACHSMDC,JJ)) Q:JJ'>0 D F
- G END
- ;
- F ;
- I JJ=36 S JJ(1)=JJ Q
- I JJ=37 S JJ(2)=JJ Q
- I JJ=38 S JJ(5)=JJ Q
- I JJ=39 S JJ(4)=JJ Q
- I JJ=40 S JJ(6)=JJ Q
- I JJ=42 S JJ(3)=JJ
- Q
- DGDRG3 ;
- Q:$O(ACHSORG(ACHSMDC,0))'>0 K JJ F JJ=0:0 S JJ=$O(ACHSORG(ACHSMDC,JJ)) Q:JJ'>0 D F3
- G END
- F3 ;
- I JJ=49 S JJ(1)=JJ Q
- I JJ=50 S JJ(2)=JJ Q
- I JJ=51 S JJ(3)=JJ Q
- I JJ=52 S JJ(4)=JJ Q
- I JJ=53 S JJ(5)=JJ Q
- I JJ=55 S JJ(6)=JJ Q
- I JJ=56 S JJ(7)=JJ Q
- I JJ=57 S JJ(9)=JJ Q
- I JJ=59 S JJ(8)=JJ Q
- I JJ=61 S JJ(10)=JJ Q
- I JJ=63 S JJ(11)=JJ
- Q
- DGDRG6 ;
- Q:$O(ACHSORG(ACHSMDC,0))'>0 K JJ F JJ=0:0 S JJ=$O(ACHSORG(ACHSMDC,JJ)) Q:JJ'>0 D F6
- G END
- F6 ;
- I JJ=146 S JJ(2)=JJ Q
- I JJ=148 S JJ(3)=JJ Q
- I JJ=150 S JJ(7)=JJ Q
- I JJ=152 S JJ(4)=JJ Q
- I JJ=154 S JJ(1)=JJ Q
- I JJ=157 S JJ(8)=JJ Q
- I JJ=159 S JJ(6)=JJ Q
- I JJ=161 S JJ(6.1)=JJ Q
- I JJ=164 S JJ(5)=JJ Q
- I JJ=166 S JJ(5.5)=JJ Q
- I JJ=168 S JJ(9)=JJ Q
- I JJ=170 S JJ(10)=JJ
- Q
- DGDRG8 ;
- Q:$O(ACHSORG(ACHSMDC,0))'>0 K JJ F JJ=0:0 S JJ=$O(ACHSORG(ACHSMDC,JJ)) Q:JJ'>0 D F8
- G END
- F8 ;
- I JJ=209 S JJ(1)=JJ Q
- I JJ=210 S JJ(2)=JJ Q
- I JJ=213 S JJ(3)=JJ Q
- I JJ=214 S JJ(4)=JJ Q
- I JJ=216 S JJ(5)=JJ Q
- I JJ=217 S JJ(6)=JJ Q
- I JJ=218 S JJ(7)=JJ Q
- I JJ=221 S JJ(8)=JJ Q
- I JJ=223 S JJ(10)=JJ Q
- I JJ=225 S JJ(11)=JJ Q
- I JJ=226 S JJ(12)=JJ Q
- I JJ=228 S JJ(13)=JJ Q
- I JJ=229 S JJ(13.5)=JJ Q
- I JJ=230 S JJ(9)=JJ Q
- I JJ=231 S JJ(9.5)=JJ Q
- I JJ=232 S JJ(14)=JJ Q
- I JJ=233 S JJ(15)=JJ
- Q
- END ;
- S JJ=$O(JJ(0)) Q:JJ'>0 S JJ=JJ(JJ) K ACHSORG S ACHSORG(ACHSMDC,JJ)="" K JJ Q
- ;
- DGDRG14 ;
- G POST:ACHSPD'["D" I ACHSOR["c" S RG=$S(ACHSSD["C":370,1:371) Q
- NOV I ACHSOR["s"!(ACHSOR["g") S RG=$S(ACHSOR["s":374,1:375) Q
- S RG=$S(ACHSSD["n"!(ACHSPD["n"):372,1:373) Q
- ;
- POST I ACHSPD["d" S RG=$S(ACHSOR["O":377,1:376) Q
- S RG=$O(RG(0)) I RG'>0 S RG=469 Q
- X ^ICD(RG,"MC") Q
- ACHSGRP ; IHS/ITSC/PMF - CHS DRG GROUPER MODIFIED FROM AICDGRP & AICDGRP1 ; [ 10/16/2001 8:16 AM ]
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- ARR ;EP
- +1 SET Y=ACHSICDX(ACHSICDJ)
- SET Y(0)=ACHSICDX(ACHSICDJ,0)
- SET ACHSMDC=$PIECE(Y(0),U,5)
- IF ACHSMDC=469
- QUIT
- CD KILL RG
- +1 SET ACHSPD=$PIECE(Y(0),U,2)
- SET RG=0
- IF ACHSMDC=12
- SET ACHSMDC=$SELECT(ACHSSEX="F":13,1:12)
- +2 FOR ACHSNDR=1:1
- SET RG=$ORDER(^ICD9(+Y,"DR",RG))
- IF RG'>0
- QUIT
- SET RG(RG)=""
- MORE IF ACHSMDC=5
- IF 'ACHSNOR!(ACHSOR'["O")
- DO MI
- IF RG>0
- DO WRT
- QUIT
- +1 IF ACHSMDC=18
- IF ACHSOR["O"
- SET RG=415
- DO WRT
- QUIT
- +2 IF ACHSMDC=19
- IF ACHSOR["O"
- SET RG=424
- DO WRT
- QUIT
- +3 IF ACHSMDC=23
- IF ACHSOR["O"
- SET RG=461
- DO WRT
- QUIT
- +4 IF ACHSMDC=14
- DO DGDRG14
- DO WRT
- QUIT
- +5 IF ACHSMDC=20
- IF ACHSDAM
- SET RG=433
- DO WRT
- QUIT
- +6 IF ACHSMDC=22
- IF '$DATA(ACHSTAC)
- SET ACHSTAC=0
- SET RG=$SELECT(ACHSTAC:456,ACHSPD["*"!(ACHSSD["*"):457,ACHSOR'["O":460,1:0)
- IF RG
- DO WRT
- QUIT
- +7 IF '$DATA(ACHSTRS)
- SET ACHSTRS=""
- +8 IF '$DATA(ACHSEXP)
- SET ACHSEXP=""
- +9 IF ACHSMDC=15
- IF ACHSTRS!ACHSEXP
- SET RG=385
- DO WRT
- QUIT
- +10 IF ACHSMDC=15
- IF ACHSSD1
- SET RG=391
- DO WRT
- QUIT
- +11 IF 'ACHSNOR
- IF ACHSNDR<3
- SET RG=$ORDER(RG(0))
- IF RG'>0
- DO 469
- DO WRT
- QUIT
- +12 IF 'ACHSNOR
- SET RG=$ORDER(RG(0))
- IF $DATA(^ICD(RG,"MC"))
- XECUTE ^ICD(RG,"MC")
- DO WRT
- QUIT
- +13 ;
- +14 IF ACHSMDC=6
- DO DGDRG6
- IF ACHSMDC=8
- DO DGDRG8
- IF ACHSMDC=2
- DO DGDRG2
- IF ACHSMDC=3
- DO DGDRG3
- SET RG=$ORDER(ACHSORG(ACHSMDC,0))
- IF RG'>0
- GOTO NOP
- IF $DATA(^ICD(RG,"MC"))
- XECUTE ^ICD(RG,"MC")
- DO WRT
- QUIT
- +15 ;
- NOP IF ACHSOR["O"
- IF ACHSMDC'=20
- DO 468
- QUIT
- D SET RG=$ORDER(RG(0))
- IF $DATA(^ICD(RG,"MC"))
- XECUTE ^ICD(RG,"MC")
- IF RG'>0
- DO 469
- DO WRT
- QUIT
- WRT IF '$DATA(RG)
- DO 469
- IF RG<0
- QUIT
- SET ACHSGCAL=$GET(^ICD(RG,0))
- SET ACHSICDN=$PIECE(ACHSGCAL,U,7)
- IF ACHSICDN'=""
- DO SETDRG
- +1 QUIT
- SETDRG IF '$DATA(ACHSICDE(9-ACHSICDN))
- SET ACHSICDE(9-ACHSICDN)=ACHSGCAL
- SET ACHSICDE(9-ACHSICDN,1)=Y(0)
- QUIT
- +1 IF ACHSGCAL'=ACHSICDE(9-ACHSICDN)
- SET ACHSICDN=ACHSICDN+.000001
- GOTO SETDRG
- +2 FOR I=1:1
- IF '$DATA(ACHSICDE(9-ACHSICDN,I))
- SET ACHSICDE(9-ACHSICDN,I)=Y(0)
- QUIT
- +3 QUIT
- +4 ;
- 469 SET RG=469
- WRITE *7,!!,"DRG= 469 PDX INVALID AS DISCHARGE DIAGNOSIS"
- QUIT
- 468 ;
- +1 SET ACHSOR=""
- SET ACHSNOR=0
- +2 DO CD
- +3 QUIT
- MI IF ACHSPD["I"!(ACHSSD["I")
- SET RG=$SELECT($SELECT($DATA(ACHSEXP):ACHSEXP,1:0):123,ACHSPD["V"!(ACHSSD["V"):121,1:122)
- QUIT
- KILLS ;EP
- +1 KILL ACHSICDX,ACHSICDE,ACHSICDI,ACHSICDJ,ACHSICDK,ACHSICDL,ACHSICDN,ACHSICDT
- +2 KILL ACHSDGFL,ACHSDAM,ACHSPT,Q,RG,ACHSSD,ACHSSD1,T,ACHSTAC,Y,DIC,ACHSGCAL,I,L,ACHSMDC,ACHSNDR,ACHSNOR,ACHSOR,ACHSPD,%,%DT,ACHSSEX,ACHSEXP,ACHSORG,ACHSTRS,ACHSNSD,C,ACHSWD2,W,S,AGE
- +3 QUIT
- DGDRG2 ;
- +1 IF $ORDER(ACHSORG(ACHSMDC,0))'>0
- QUIT
- KILL JJ
- FOR JJ=0:0
- SET JJ=$ORDER(ACHSORG(ACHSMDC,JJ))
- IF JJ'>0
- QUIT
- DO F
- +2 GOTO END
- +3 ;
- F ;
- +1 IF JJ=36
- SET JJ(1)=JJ
- QUIT
- +2 IF JJ=37
- SET JJ(2)=JJ
- QUIT
- +3 IF JJ=38
- SET JJ(5)=JJ
- QUIT
- +4 IF JJ=39
- SET JJ(4)=JJ
- QUIT
- +5 IF JJ=40
- SET JJ(6)=JJ
- QUIT
- +6 IF JJ=42
- SET JJ(3)=JJ
- +7 QUIT
- DGDRG3 ;
- +1 IF $ORDER(ACHSORG(ACHSMDC,0))'>0
- QUIT
- KILL JJ
- FOR JJ=0:0
- SET JJ=$ORDER(ACHSORG(ACHSMDC,JJ))
- IF JJ'>0
- QUIT
- DO F3
- +2 GOTO END
- F3 ;
- +1 IF JJ=49
- SET JJ(1)=JJ
- QUIT
- +2 IF JJ=50
- SET JJ(2)=JJ
- QUIT
- +3 IF JJ=51
- SET JJ(3)=JJ
- QUIT
- +4 IF JJ=52
- SET JJ(4)=JJ
- QUIT
- +5 IF JJ=53
- SET JJ(5)=JJ
- QUIT
- +6 IF JJ=55
- SET JJ(6)=JJ
- QUIT
- +7 IF JJ=56
- SET JJ(7)=JJ
- QUIT
- +8 IF JJ=57
- SET JJ(9)=JJ
- QUIT
- +9 IF JJ=59
- SET JJ(8)=JJ
- QUIT
- +10 IF JJ=61
- SET JJ(10)=JJ
- QUIT
- +11 IF JJ=63
- SET JJ(11)=JJ
- +12 QUIT
- DGDRG6 ;
- +1 IF $ORDER(ACHSORG(ACHSMDC,0))'>0
- QUIT
- KILL JJ
- FOR JJ=0:0
- SET JJ=$ORDER(ACHSORG(ACHSMDC,JJ))
- IF JJ'>0
- QUIT
- DO F6
- +2 GOTO END
- F6 ;
- +1 IF JJ=146
- SET JJ(2)=JJ
- QUIT
- +2 IF JJ=148
- SET JJ(3)=JJ
- QUIT
- +3 IF JJ=150
- SET JJ(7)=JJ
- QUIT
- +4 IF JJ=152
- SET JJ(4)=JJ
- QUIT
- +5 IF JJ=154
- SET JJ(1)=JJ
- QUIT
- +6 IF JJ=157
- SET JJ(8)=JJ
- QUIT
- +7 IF JJ=159
- SET JJ(6)=JJ
- QUIT
- +8 IF JJ=161
- SET JJ(6.1)=JJ
- QUIT
- +9 IF JJ=164
- SET JJ(5)=JJ
- QUIT
- +10 IF JJ=166
- SET JJ(5.5)=JJ
- QUIT
- +11 IF JJ=168
- SET JJ(9)=JJ
- QUIT
- +12 IF JJ=170
- SET JJ(10)=JJ
- +13 QUIT
- DGDRG8 ;
- +1 IF $ORDER(ACHSORG(ACHSMDC,0))'>0
- QUIT
- KILL JJ
- FOR JJ=0:0
- SET JJ=$ORDER(ACHSORG(ACHSMDC,JJ))
- IF JJ'>0
- QUIT
- DO F8
- +2 GOTO END
- F8 ;
- +1 IF JJ=209
- SET JJ(1)=JJ
- QUIT
- +2 IF JJ=210
- SET JJ(2)=JJ
- QUIT
- +3 IF JJ=213
- SET JJ(3)=JJ
- QUIT
- +4 IF JJ=214
- SET JJ(4)=JJ
- QUIT
- +5 IF JJ=216
- SET JJ(5)=JJ
- QUIT
- +6 IF JJ=217
- SET JJ(6)=JJ
- QUIT
- +7 IF JJ=218
- SET JJ(7)=JJ
- QUIT
- +8 IF JJ=221
- SET JJ(8)=JJ
- QUIT
- +9 IF JJ=223
- SET JJ(10)=JJ
- QUIT
- +10 IF JJ=225
- SET JJ(11)=JJ
- QUIT
- +11 IF JJ=226
- SET JJ(12)=JJ
- QUIT
- +12 IF JJ=228
- SET JJ(13)=JJ
- QUIT
- +13 IF JJ=229
- SET JJ(13.5)=JJ
- QUIT
- +14 IF JJ=230
- SET JJ(9)=JJ
- QUIT
- +15 IF JJ=231
- SET JJ(9.5)=JJ
- QUIT
- +16 IF JJ=232
- SET JJ(14)=JJ
- QUIT
- +17 IF JJ=233
- SET JJ(15)=JJ
- +18 QUIT
- END ;
- +1 SET JJ=$ORDER(JJ(0))
- IF JJ'>0
- QUIT
- SET JJ=JJ(JJ)
- KILL ACHSORG
- SET ACHSORG(ACHSMDC,JJ)=""
- KILL JJ
- QUIT
- +2 ;
- DGDRG14 ;
- +1 IF ACHSPD'["D"
- GOTO POST
- IF ACHSOR["c"
- SET RG=$SELECT(ACHSSD["C":370,1:371)
- QUIT
- NOV IF ACHSOR["s"!(ACHSOR["g")
- SET RG=$SELECT(ACHSOR["s":374,1:375)
- QUIT
- +1 SET RG=$SELECT(ACHSSD["n"!(ACHSPD["n"):372,1:373)
- QUIT
- +2 ;
- POST IF ACHSPD["d"
- SET RG=$SELECT(ACHSOR["O":377,1:376)
- QUIT
- +1 SET RG=$ORDER(RG(0))
- IF RG'>0
- SET RG=469
- QUIT
- +2 XECUTE ^ICD(RG,"MC")
- QUIT
