- 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 Feb 18, 2025@23:16:45 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