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 Apr 09, 2024@20:52:36 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
