ICDDRGXM ;ALB/MRY - GROUPER PROCESS ; 10/1/07 1:38pm
;;18.0;DRG Grouper;**31,50,62**;Oct 20, 2000;Build 7
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))&('$O(^ICD9(ICDDX(1),"R",0))):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
;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 $P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)'["Y"!(($D(ICDOP(" 96.72")))) S ICDRG=4
.I $D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!($D(ICDOP(" 31.29"))) I $P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",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"&($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)["Y"):13,1:ICDRG) I ICDRG=13 S ICDRTC=0 Q
Q
ICDDRGXM ;ALB/MRY - GROUPER PROCESS ; 10/1/07 1:38pm
+1 ;;18.0;DRG Grouper;**31,50,62**;Oct 20, 2000;Build 7
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))&('$ORDER(^ICD9(ICDDX(1),"R",0))):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 ;use FY logic to resolve DRG if no FY defined user current FY
+5 NEW ICDDXFY
SET ICDDXFY=""
+6 ;Use DRG FY 05 logic
IF ICDDATE>3040930.9
Begin DoDot:1
+7 IF $DATA(ICDOP(" 39.65"))
SET ICDRG=3
QUIT
+8 IF $DATA(ICDOP(" 31.1"))!($DATA(ICDOP(" 31.21")))!($DATA(ICDOP(" 31.29")))
IF $PIECE($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)'["Y"!(($DATA(ICDOP(" 96.72"))))
SET ICDRG=4
+9 IF $DATA(ICDOP(" 31.1"))!($DATA(ICDOP(" 31.21")))!($DATA(ICDOP(" 31.29")))
IF $PIECE($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",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
+10 ;S ICDRG=$S((ICDOR["l")&($D(ICDOP(" 46.97"))):5,ICDOR["l":6,1:ICDRG) I ICDRG=5!(ICDRG=6) S ICDRTC=0 Q
+11 SET ICDRG=$SELECT(ICDOR["l":6,1:ICDRG)
IF ICDRG=6
SET ICDRTC=0
QUIT
+12 IF ICDRG=8!(ICDRG=10)
SET ICDRTC=0
QUIT
+13 ;check for lung tx
SET ICDRG=$SELECT(ICDOR["r":7,1:ICDRG)
IF ICDRG=7
SET ICDRTC=0
QUIT
+14 ;check for heart tx
SET ICDRG=$SELECT(ICDOR["q":2,1:ICDRG)
IF ICDRG=2
SET ICDRTC=0
QUIT
+15 SET ICDRG=$SELECT((ICDOR["B")&(ICDDATE<3101001):9,(ICDOR["B")&(ICDDATE>3100930.9):14,1:ICDRG)
SET ICDRTC=0
SET ICDMDC=""
+16 SET ICDRG=$SELECT($DATA(ICDOP(" 30.3"))!$DATA(ICDOP(" 30.4")):13,1:ICDRG)
IF ICDRG=13
SET ICDRTC=0
QUIT
+17 SET ICDRG=$SELECT(ICDOR["t"&($PIECE($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)["Y"):13,1:ICDRG)
IF ICDRG=13
SET ICDRTC=0
QUIT
+18 QUIT
