- ICDDRGXM ;ALB/MRY/KUM - GROUPER PROCESS ;26 Mar 2013 12:33 PM
- ;;18.0;DRG Grouper;**31,50,62,64**;Oct 20, 2000;Build 103
- CKHIV ;MDC25 grouping; MS-DRG
- ;Q:ICDP25=""
- I ICDPD'["h"&(ICDSD'["h") Q
- S ICDRG=$S(ICDOR["x":970,ICDPD["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: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
- .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&(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
- ;
- CKNMDC ;non MDC drg's ;MS-DRG
- ;S:(ICDRG>5)&(ICDRG<14) ICDRG=999
- ; ICD*18*1 - reorder drg 103 higher than all Pre-MDCs 480-83 & 495
- I ICDRG=2 S ICDRTC=0 Q
- S ICDCDSY=$S(ICDDATE'<$$IMPDATE^LEXU("10D"):30,1:1)
- ;use FY logic to resolve DRG if no FY defined user current FY
- N ICDDXFY S ICDDXFY=""
- I ICDDATE>3040930.9 D I ICDRG=3!(ICDRG=4) S ICDRTC=0 Q ;Use DRG FY 05 logic
- .I $D(ICDOP(" 39.65")) S ICDRG=3 Q
- .I $D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!($D(ICDOP(" 31.29"))) I $TR($P($$ICDDX^ICDEX(ICDDX(1),ICDDATE,ICDCDSY,"I"),"^",3),";","")'["Y"!(($D(ICDOP(" 96.72")))) S ICDRG=4
- .I $D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!($D(ICDOP(" 31.29"))) I $TR($P($$ICDDX^ICDEX(ICDDX(1),ICDDATE,ICDCDSY,"I"),"^",3),";","")'["Y"!(($D(ICDOP(" 96.72")))) I ICDOR["O"&(ICDOR'["z")&(ICDOR'["y") S ICDRG=3
- ;S ICDRG=$S((ICDOR["l")&($D(ICDOP(" 46.97"))):5,ICDOR["l":6,1:ICDRG) I ICDRG=5!(ICDRG=6) S ICDRTC=0 Q
- S ICDRG=$S(ICDOR["l":6,1:ICDRG) I ICDRG=6 S ICDRTC=0 Q
- I ICDRG=8!(ICDRG=10) S ICDRTC=0 Q
- S ICDRG=$S(ICDOR["r":7,1:ICDRG) I ICDRG=7 S ICDRTC=0 Q ;check for lung tx
- S ICDRG=$S(ICDOR["q":2,1:ICDRG) I ICDRG=2 S ICDRTC=0 Q ;check for heart tx
- S ICDRG=$S((ICDOR["B")&(ICDDATE<3101001):9,(ICDOR["B")&(ICDDATE>3100930.9):14,1:ICDRG) S ICDRTC=0,ICDMDC=""
- S ICDRG=$S($D(ICDOP(" 30.3"))!$D(ICDOP(" 30.4")):13,1:ICDRG) I ICDRG=13 S ICDRTC=0 Q
- S ICDRG=$S(ICDOR["t"&($TR($P($$ICDDX^ICDEX(ICDDX(1),ICDDATE,ICDCDSY,"I"),"^",3),";","")["Y"):13,1:ICDRG) I ICDRG=13 S ICDRTC=0 Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDDRGXM 3120 printed Jan 18, 2025@02:51:39 Page 2
- ICDDRGXM ;ALB/MRY/KUM - GROUPER PROCESS ;26 Mar 2013 12:33 PM
- +1 ;;18.0;DRG Grouper;**31,50,62,64**;Oct 20, 2000;Build 103
- CKHIV ;MDC25 grouping; MS-DRG
- +1 ;Q:ICDP25=""
- +2 IF ICDPD'["h"&(ICDSD'["h")
- QUIT
- +3 SET ICDRG=$SELECT(ICDOR["x":970,ICDPD["i"&($DATA(ICDS25(1))):977,1:ICDRG)
- +4 SET ICDGH=$SELECT("969^976^977"[ICDRG:1,1:0)
- SET ICDORNI=$SELECT(ICDOCNT>0:ICDORNI,1:0)
- SET ICDORNA=$FIND(ICDORNI,"O",$FIND(ICDORNI,"O"))
- +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 FOR I=1:1:$LENGTH(ICDORNI)
- if $EXTRACT(ICDORNI,I,I)="z"
- SET K1=K1+1
- if $EXTRACT(ICDORNI,I,I)="O"
- SET K2=K2+1
- +13 IF ICDP25=1!(ICDP25>1&($DATA(ICDS25)>0))
- Begin DoDot:2
- +14 IF K1<K2&(K1<ICDOPCT)
- Begin DoDot:3
- +15 SET ICDRG=970
- QUIT
- End DoDot:3
- +16 IF ICDOPCT=1&(ICDORNI'["z")
- Begin DoDot:3
- +17 SET ICDRG=970
- QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- IF ICDRG=970
- DO CKMS
- QUIT
- +18 SET ICDRG=$SELECT(ICDP25=1&('$DATA(ICDS25))&('$$EXIST^ICDEX(ICDDX(1),30)):977,1:ICDRG)
- IF 'ICDGH&(ICDRG=977)
- DO CKMS
- QUIT
- +19 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
- +20 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
- +21 SET ICDRG=$SELECT((ICDP25&(ICDOCNT=0)&('$DATA(ICDS25))):977,1:ICDRG)
- IF 'ICDGH&(ICDRG=977)
- DO CKMS
- QUIT
- +22 IF "969^970^974^975^976^977"[ICDRG
- SET ICDRTC=0
- +23 KILL ICDGH,ICDP25,ICDS25,ICDORNA
- QUIT
- +24 ;
- 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 ;
- CKNMDC ;non MDC drg's ;MS-DRG
- +1 ;S:(ICDRG>5)&(ICDRG<14) ICDRG=999
- +2 ; ICD*18*1 - reorder drg 103 higher than all Pre-MDCs 480-83 & 495
- +3 IF ICDRG=2
- SET ICDRTC=0
- QUIT
- +4 SET ICDCDSY=$SELECT(ICDDATE'<$$IMPDATE^LEXU("10D"):30,1:1)
- +5 ;use FY logic to resolve DRG if no FY defined user current FY
- +6 NEW ICDDXFY
- SET ICDDXFY=""
- +7 ;Use DRG FY 05 logic
- IF ICDDATE>3040930.9
- Begin DoDot:1
- +8 IF $DATA(ICDOP(" 39.65"))
- SET ICDRG=3
- QUIT
- +9 IF $DATA(ICDOP(" 31.1"))!($DATA(ICDOP(" 31.21")))!($DATA(ICDOP(" 31.29")))
- IF $TRANSLATE($PIECE($$ICDDX^ICDEX(ICDDX(1),ICDDATE,ICDCDSY,"I"),"^",3),";","")'["Y"!(($DATA(ICDOP(" 96.72"))))
- SET ICDRG=4
- +10 IF $DATA(ICDOP(" 31.1"))!($DATA(ICDOP(" 31.21")))!($DATA(ICDOP(" 31.29")))
- IF $TRANSLATE($PIECE($$ICDDX^ICDEX(ICDDX(1),ICDDATE,ICDCDSY,"I"),"^",3),";","")'["Y"!(($DATA(ICDOP(" 96.72"))))
- IF ICDOR["O"&(ICDOR'["z")&(ICDOR'["y")
- SET ICDRG=3
- End DoDot:1
- IF ICDRG=3!(ICDRG=4)
- SET ICDRTC=0
- QUIT
- +11 ;S ICDRG=$S((ICDOR["l")&($D(ICDOP(" 46.97"))):5,ICDOR["l":6,1:ICDRG) I ICDRG=5!(ICDRG=6) S ICDRTC=0 Q
- +12 SET ICDRG=$SELECT(ICDOR["l":6,1:ICDRG)
- IF ICDRG=6
- SET ICDRTC=0
- QUIT
- +13 IF ICDRG=8!(ICDRG=10)
- SET ICDRTC=0
- QUIT
- +14 ;check for lung tx
- SET ICDRG=$SELECT(ICDOR["r":7,1:ICDRG)
- IF ICDRG=7
- SET ICDRTC=0
- QUIT
- +15 ;check for heart tx
- SET ICDRG=$SELECT(ICDOR["q":2,1:ICDRG)
- IF ICDRG=2
- SET ICDRTC=0
- QUIT
- +16 SET ICDRG=$SELECT((ICDOR["B")&(ICDDATE<3101001):9,(ICDOR["B")&(ICDDATE>3100930.9):14,1:ICDRG)
- SET ICDRTC=0
- SET ICDMDC=""
- +17 SET ICDRG=$SELECT($DATA(ICDOP(" 30.3"))!$DATA(ICDOP(" 30.4")):13,1:ICDRG)
- IF ICDRG=13
- SET ICDRTC=0
- QUIT
- +18 SET ICDRG=$SELECT(ICDOR["t"&($TRANSLATE($PIECE($$ICDDX^ICDEX(ICDDX(1),ICDDATE,ICDCDSY,"I"),"^",3),";","")["Y"):13,1:ICDRG)
- IF ICDRG=13
- SET ICDRTC=0
- QUIT
- +19 QUIT