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

Last change on this file since 1801 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 2.8 KB
Line 
1ICDDRGXM ;ALB/MRY - GROUPER PROCESS ; 10/1/07 1:38pm
2 ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7
3CKHIV ;MDC25 grouping; MS-DRG
4 ;Q:ICDP25=""
5 I ICDPD'["h"&(ICDSD'["h") Q
6 S ICDRG=$S(ICDOR["x":970,ICDPD["i"&($D(ICDS25(1))):977,1:ICDRG)
7 S ICDGH=$S("969^976^977"[ICDRG:1,1:0),ICDORNI=$S(ICDOCNT>0:ICDORNI,1:0),ICDORNA=$F(ICDORNI,"O",$F(ICDORNI,"O"))
8 S:ICDORNI="" ICDORNI=ICDOR
9 S ICDRG=$S(ICDP25=1&(ICDORNA>0):970,1:ICDRG) I 'ICDGH&(ICDRG=970) D CKMS Q
10 S:(ICDOCNT>0) ICDRG=$S(ICDP25>1&(ICDORNA>0)&($D(ICDS25(1))):970,1:ICDRG) I 'ICDGH&(ICDRG=970) D CKMS Q
11 I ICDOPCT>0 D I ICDRG=970 D CKMS Q
12 .;count the non-extensive "z" vs the "O"
13 .N K1,K2,I
14 .S (K1,K2)=0
15 .F I=1:1:$L(ICDORNI) S:$E(ICDORNI,I,I)="z" K1=K1+1 S:$E(ICDORNI,I,I)="O" K2=K2+1
16 .I ICDP25=1!(ICDP25>1&($D(ICDS25)>0)) D
17 ..I K1<K2&(K1<ICDOPCT) D
18 ...S ICDRG=970 Q
19 ..I ICDOPCT=1&(ICDORNI'["z") D
20 ...S ICDRG=970 Q
21 S ICDRG=$S(ICDP25=1&('$D(ICDS25))&('$O(^ICD9(ICDDX(1),"R",0))):977,1:ICDRG) I 'ICDGH&(ICDRG=977) D CKMS Q
22 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
23 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
24 S ICDRG=$S((ICDP25&(ICDOCNT=0)&('$D(ICDS25))):977,1:ICDRG) I 'ICDGH&(ICDRG=977) D CKMS Q
25 I "969^970^974^975^976^977"[ICDRG S ICDRTC=0
26 K ICDGH,ICDP25,ICDS25,ICDORNA Q
27 ;
28CKMS ;determine severity
29 I ICDRG=970 S ICDRG=$S(ICDMCC=2:969,1:970) Q
30 I ICDRG=976 S ICDRG=$S(ICDMCC=2:974,ICDMCC=1:975,1:976) Q
31 ;MS-DRG 977 has no severity
32 Q
33 ;
34CKNMDC ;non MDC drg's ;MS-DRG
35 ;S:(ICDRG>5)&(ICDRG<14) ICDRG=999
36 ; ICD*18*1 - reorder drg 103 higher than all Pre-MDCs 480-83 & 495
37 I ICDRG=2 S ICDRTC=0 Q
38 ;use FY logic to resolve DRG if no FY defined user current FY
39 N ICDDXFY S ICDDXFY=""
40 I ICDDATE>3040930.9 D I ICDRG=3!(ICDRG=4) S ICDRTC=0 Q ;Use DRG FY 05 logic
41 .I $D(ICDOP(" 39.65")) S ICDRG=3 Q
42 .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
43 .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
44 ;S ICDRG=$S((ICDOR["l")&($D(ICDOP(" 46.97"))):5,ICDOR["l":6,1:ICDRG) I ICDRG=5!(ICDRG=6) S ICDRTC=0 Q
45 S ICDRG=$S(ICDOR["l":6,1:ICDRG) I ICDRG=6 S ICDRTC=0 Q
46 I ICDRG=8!(ICDRG=10) S ICDRTC=0 Q
47 S ICDRG=$S(ICDOR["r":7,1:ICDRG) I ICDRG=7 S ICDRTC=0 Q ;check for lung tx
48 S ICDRG=$S(ICDOR["q":2,1:ICDRG) I ICDRG=2 S ICDRTC=0 Q ;check for heart tx
49 S ICDRG=$S(ICDOR["B":9,1:ICDRG) I ICDRG=9 S ICDRTC=0 Q
50 S ICDRG=$S($D(ICDOP(" 30.3"))!$D(ICDOP(" 30.4")):13,1:ICDRG) I ICDRG=13 S ICDRTC=0 Q
51 S ICDRG=$S(ICDOR["t"&($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)["Y"):13,1:ICDRG) I ICDRG=13 S ICDRTC=0 Q
52 Q
Note: See TracBrowser for help on using the repository browser.