ICDDRGX1 ;KUM - GROUPER PROCESS ;05/10/12 3:44pm
;;18.0;DRG Grouper;**64**;Oct 20, 2000;Build 103
;
CKMST ;MDC24 Grouping
N ICDI
S ICDAJ=0 F ICDS24K=1:1 S ICDAJ=$O(ICDS24(ICDAJ)) Q:ICDAJ=""
S ICDS24K=ICDS24K-1,ICDS24L=0 F ICDI=1:1:8 S:$D(ICDS24(ICDI))&(ICDI'=ICDP24) ICDS24L=$S($D(ICDS24(ICDI)):1,1:0)
I $D(ICD10OR(112)) S ICDS24K=ICDS24K+1 ;112=Other O.R. Procedues for MST
G:((ICDP24=0)&(ICDS24K<2))!((ICDP24>0)&('ICDS24L)) CKMSTE
S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):955,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):955,1:ICDRG) I ICDRG=955 D CKMSTE Q
S:ICDRG'=955 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):956,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):956,1:ICDRG) I ICDRG=956 D CKMSTE Q
S:ICDRG'=956 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):959,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):959,1:ICDRG) I ICDRG=959 D CKMSTE Q
S ICDRG=$S(ICDP24=0&(ICDS24K>1):965,ICDP24>0&ICDS24L:965,1:ICDRG)
S:(ICDRG>954)&(ICDRG<966) ICDRTC=0
CKMSTE K ICDAJ,ICDP24,ICDS24,ICDO24,ICDS24K,ICDO24,ICDS24L
Q
CKHIV ;MDC25 grouping; MS-DRG
I '$D(ICD10PD("h"))&'$D(ICD10SD("h")) Q
S ICDRG=$S($D(ICD10OR("x")):970,$D(ICD10PD("i"))&($D(ICDS25(1))):977,1:ICDRG)
;S ICDGH=$S("969^976^977"[ICDRG:1,1:0),ICDORNI=$S(ICDOCNT>0:ICDORNI,1:0),ICDORNA=$F(ICDORNI,"O",$F(ICDORNI,"O"))
S ICDGH=$S("969^976^977"[ICDRG:1,1:0),ICDORNI=$S(ICDOCNT>0:ICDORNI,1:0),ICDORNA=$G(ICD10ORNI("O"))-1
S:ICDORNI="" ICDORNI=ICDOR
S ICDRG=$S(ICDP25=1&(ICDORNA>0):970,1:ICDRG) I 'ICDGH&(ICDRG=970) D CKMS Q
S:(ICDOCNT>0) ICDRG=$S(ICDP25>1&(ICDORNA>0)&($D(ICDS25(1))):970,1:ICDRG) I 'ICDGH&(ICDRG=970) D CKMS Q
I ICDOPCT>0 D I ICDRG=970 D CKMS Q
.;count the non-extensive "z" vs the "O"
.N K1,K2,I
.S (K1,K2)=0
.S K1=ICD10ORNI("z")
.S K2=ICD10ORNI("O")
.;F I=1:1:$L(ICDORNI) S:$E(ICDORNI,I,I)="z" K1=K1+1 S:$E(ICDORNI,I,I)="O" K2=K2+1
.I ICDP25=1!(ICDP25>1&($D(ICDS25)>0)) D
..I K1<K2&(K1<ICDOPCT) D
...S ICDRG=970 Q
..I ICDOPCT=1&('$D(ICDORNI("z"))) D
...S ICDRG=970 Q
S ICDRG=$S(ICDP25=1&('$D(ICDS25))&('$$EXIST^ICDEX(ICDDX(1),30)):977,1:ICDRG) I 'ICDGH&(ICDRG=977) D CKMS Q
S ICDRG=$S(ICDP25=1&($D(ICDS25(2))):976,ICDP25=1&($D(ICDS25(3))):976,1:ICDRG) I 'ICDGH&((ICDRG=976)!(ICDRG=977)) D CKMS Q
S ICDRG=$S(ICDP25=2&($D(ICDS25(1))):976,ICDP25=3&($D(ICDS25(1))):977,1:ICDRG) I 'ICDGH&((ICDRG=976)!(ICDRG=977)) D CKMS Q
S ICDRG=$S((ICDP25&(ICDOCNT=0)&('$D(ICDS25))):977,1:ICDRG) I 'ICDGH&(ICDRG=977) D CKMS Q
I "969^970^974^975^976^977"[ICDRG S ICDRTC=0
K ICDGH,ICDP25,ICDS25,ICDORNA Q
;
CKMS ;determine severity
I ICDRG=970 S ICDRG=$S(ICDMCC=2:969,1:970) Q
I ICDRG=976 S ICDRG=$S(ICDMCC=2:974,ICDMCC=1:975,1:976) Q
;MS-DRG 977 has no severity
Q
;
CHKMDC4 ;MDC 4 drg's
I (ICDMDC=4!(ICDMDC=98)),($D(ICD10OR("f"))) S ICDRG=168
I ICDDRG=983,$G(ICDMDC)=5 S ICDRG=264
I ICDDRG=983,$G(ICDMDC)=5,ICDNOR=1 S ICDRG=264
Q
CKNMDC ;non MDC drg's ;
I ICDRG=2 S ICDRTC=0 Q
S ICDRG=$S($D(ICD10OR("l")):6,1:ICDRG) I ICDRG=6 S ICDRTC=0 Q
I ICDRG=8!(ICDRG=10) S ICDRTC=0 Q
S ICDRG=$S($D(ICD10OR("r")):7,1:ICDRG) I ICDRG=7 S ICDRTC=0 Q ;check for lung tx
S ICDRG=$S($D(ICD10OR("q")):2,1:ICDRG) I ICDRG=2 S ICDRTC=0 Q ;check for heart tx
S ICDRG=$S($D(ICD10OR("B")):14,1:ICDRG) S ICDRTC=0,ICDMDC="" Q
S ICDRG=$S($D(ICD10OR("t"))&$D(ICD10PD("Y")):13,1:ICDRG) I ICDRG=13 S ICDRTC=0 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDDRGX1 3329 printed Apr 09, 2024@20:57:17 Page 2
ICDDRGX1 ;KUM - GROUPER PROCESS ;05/10/12 3:44pm
+1 ;;18.0;DRG Grouper;**64**;Oct 20, 2000;Build 103
+2 ;
CKMST ;MDC24 Grouping
+1 NEW ICDI
+2 SET ICDAJ=0
FOR ICDS24K=1:1
SET ICDAJ=$ORDER(ICDS24(ICDAJ))
if ICDAJ=""
QUIT
+3 SET ICDS24K=ICDS24K-1
SET ICDS24L=0
FOR ICDI=1:1:8
if $DATA(ICDS24(ICDI))&(ICDI'=ICDP24)
SET ICDS24L=$SELECT($DATA(ICDS24(ICDI)):1,1:0)
+4 ;112=Other O.R. Procedues for MST
IF $DATA(ICD10OR(112))
SET ICDS24K=ICDS24K+1
+5 if ((ICDP24=0)&(ICDS24K<2))!((ICDP24>0)&('ICDS24L))
GOTO CKMSTE
+6 SET ICDRG=$SELECT(ICDP24=0&(ICDS24K>1)&($DATA(ICDO24(1))):955,ICDP24>0&($DATA(ICDO24(1)))&(ICDS24L):955,1:ICDRG)
IF ICDRG=955
DO CKMSTE
QUIT
+7 if ICDRG'=955
SET ICDRG=$SELECT(ICDP24=0&(ICDS24K>1)&($DATA(ICDO24(2))):956,ICDP24>0&($DATA(ICDO24(2)))&(ICDS24L):956,1:ICDRG)
IF ICDRG=956
DO CKMSTE
QUIT
+8 if ICDRG'=956
SET ICDRG=$SELECT(ICDP24=0&(ICDS24K>1)&($DATA(ICDO24(3))):959,ICDP24>0&($DATA(ICDO24(3)))&(ICDS24L):959,1:ICDRG)
IF ICDRG=959
DO CKMSTE
QUIT
+9 SET ICDRG=$SELECT(ICDP24=0&(ICDS24K>1):965,ICDP24>0&ICDS24L:965,1:ICDRG)
+10 if (ICDRG>954)&(ICDRG<966)
SET ICDRTC=0
CKMSTE KILL ICDAJ,ICDP24,ICDS24,ICDO24,ICDS24K,ICDO24,ICDS24L
+1 QUIT
CKHIV ;MDC25 grouping; MS-DRG
+1 IF '$DATA(ICD10PD("h"))&'$DATA(ICD10SD("h"))
QUIT
+2 SET ICDRG=$SELECT($DATA(ICD10OR("x")):970,$DATA(ICD10PD("i"))&($DATA(ICDS25(1))):977,1:ICDRG)
+3 ;S ICDGH=$S("969^976^977"[ICDRG:1,1:0),ICDORNI=$S(ICDOCNT>0:ICDORNI,1:0),ICDORNA=$F(ICDORNI,"O",$F(ICDORNI,"O"))
+4 SET ICDGH=$SELECT("969^976^977"[ICDRG:1,1:0)
SET ICDORNI=$SELECT(ICDOCNT>0:ICDORNI,1:0)
SET ICDORNA=$GET(ICD10ORNI("O"))-1
+5 if ICDORNI=""
SET ICDORNI=ICDOR
+6 SET ICDRG=$SELECT(ICDP25=1&(ICDORNA>0):970,1:ICDRG)
IF 'ICDGH&(ICDRG=970)
DO CKMS
QUIT
+7 if (ICDOCNT>0)
SET ICDRG=$SELECT(ICDP25>1&(ICDORNA>0)&($DATA(ICDS25(1))):970,1:ICDRG)
IF 'ICDGH&(ICDRG=970)
DO CKMS
QUIT
+8 IF ICDOPCT>0
Begin DoDot:1
+9 ;count the non-extensive "z" vs the "O"
+10 NEW K1,K2,I
+11 SET (K1,K2)=0
+12 SET K1=ICD10ORNI("z")
+13 SET K2=ICD10ORNI("O")
+14 ;F I=1:1:$L(ICDORNI) S:$E(ICDORNI,I,I)="z" K1=K1+1 S:$E(ICDORNI,I,I)="O" K2=K2+1
+15 IF ICDP25=1!(ICDP25>1&($DATA(ICDS25)>0))
Begin DoDot:2
+16 IF K1<K2&(K1<ICDOPCT)
Begin DoDot:3
+17 SET ICDRG=970
QUIT
End DoDot:3
+18 IF ICDOPCT=1&('$DATA(ICDORNI("z")))
Begin DoDot:3
+19 SET ICDRG=970
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
IF ICDRG=970
DO CKMS
QUIT
+20 SET ICDRG=$SELECT(ICDP25=1&('$DATA(ICDS25))&('$$EXIST^ICDEX(ICDDX(1),30)):977,1:ICDRG)
IF 'ICDGH&(ICDRG=977)
DO CKMS
QUIT
+21 SET ICDRG=$SELECT(ICDP25=1&($DATA(ICDS25(2))):976,ICDP25=1&($DATA(ICDS25(3))):976,1:ICDRG)
IF 'ICDGH&((ICDRG=976)!(ICDRG=977))
DO CKMS
QUIT
+22 SET ICDRG=$SELECT(ICDP25=2&($DATA(ICDS25(1))):976,ICDP25=3&($DATA(ICDS25(1))):977,1:ICDRG)
IF 'ICDGH&((ICDRG=976)!(ICDRG=977))
DO CKMS
QUIT
+23 SET ICDRG=$SELECT((ICDP25&(ICDOCNT=0)&('$DATA(ICDS25))):977,1:ICDRG)
IF 'ICDGH&(ICDRG=977)
DO CKMS
QUIT
+24 IF "969^970^974^975^976^977"[ICDRG
SET ICDRTC=0
+25 KILL ICDGH,ICDP25,ICDS25,ICDORNA
QUIT
+26 ;
CKMS ;determine severity
+1 IF ICDRG=970
SET ICDRG=$SELECT(ICDMCC=2:969,1:970)
QUIT
+2 IF ICDRG=976
SET ICDRG=$SELECT(ICDMCC=2:974,ICDMCC=1:975,1:976)
QUIT
+3 ;MS-DRG 977 has no severity
+4 QUIT
+5 ;
CHKMDC4 ;MDC 4 drg's
+1 IF (ICDMDC=4!(ICDMDC=98))
IF ($DATA(ICD10OR("f")))
SET ICDRG=168
+2 IF ICDDRG=983
IF $GET(ICDMDC)=5
SET ICDRG=264
+3 IF ICDDRG=983
IF $GET(ICDMDC)=5
IF ICDNOR=1
SET ICDRG=264
+4 QUIT
CKNMDC ;non MDC drg's ;
+1 IF ICDRG=2
SET ICDRTC=0
QUIT
+2 SET ICDRG=$SELECT($DATA(ICD10OR("l")):6,1:ICDRG)
IF ICDRG=6
SET ICDRTC=0
QUIT
+3 IF ICDRG=8!(ICDRG=10)
SET ICDRTC=0
QUIT
+4 ;check for lung tx
SET ICDRG=$SELECT($DATA(ICD10OR("r")):7,1:ICDRG)
IF ICDRG=7
SET ICDRTC=0
QUIT
+5 ;check for heart tx
SET ICDRG=$SELECT($DATA(ICD10OR("q")):2,1:ICDRG)
IF ICDRG=2
SET ICDRTC=0
QUIT
+6 SET ICDRG=$SELECT($DATA(ICD10OR("B")):14,1:ICDRG)
SET ICDRTC=0
SET ICDMDC=""
QUIT
+7 SET ICDRG=$SELECT($DATA(ICD10OR("t"))&$DATA(ICD10PD("Y")):13,1:ICDRG)
IF ICDRG=13
SET ICDRTC=0
QUIT
+8 QUIT
