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
