source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRGXM.m@ 808

ICDDRGXM ;ALB/MRY - GROUPER PROCESS ; 10/1/07 1:38pm
 ;;18.0;DRG Grouper;**31**;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":9,1:ICDRG) I ICDRG=9 S ICDRTC=0 Q
 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