source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTBL2.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1ICDTBL2 ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS ; 11/13/07 4:13pm
2 ;;18.0;DRG Grouper;**31,32**;Oct 20, 2000;Build 9
3DRG200 ;
4DRG201 S ICDRG=$S(ICDMCC=2:199,ICDMCC=1:200,1:201) Q
5DRG202 ;
6DRG203 S ICDRG=$S(ICDMCC>0:202,1:203) Q
7DRG204 S ICDRG=204 Q
8DRG205 ;
9DRG206 S ICDRG=$S(ICDMCC=2:205,1:206) Q
10DRG207 S ICDRG=207 Q
11DRG208 S ICDRG=208 Q
12DRG215 S ICDRG=215 Q
13DRG216 ;valve procedures
14 N ICDE1,ICDE2
15 S ICDE1=$S($D(ICDOP(" 37.95"))&($D(ICDOP(" 37.96"))):1,1:0),ICDE2=$S($D(ICDOP(" 37.97"))&($D(ICDOP(" 37.98"))):1,1:0)
16 S:ICDOR["H" ICDRG=$S(ICDOR["N"&ICDE1:218,ICDOR["N"&ICDE2:218,ICDOR["O":218,1:ICDRG)
17 S:ICDOR'["H" ICDRG=$S(ICDOR["N"&ICDE1:221,ICDOR["N"&ICDE2:221,ICDOR["O":221,1:ICDRG)
18 I ICDOR["P"&(ICDE1+ICDE2=0) S ICDRG=$S(ICDOR["H":218,1:221)
19 S:ICDRG=218 ICDRG=$S(ICDMCC=2:216,ICDMCC=1:217,1:218)
20 S:ICDRG=221 ICDRG=$S(ICDMCC=2:219,ICDMCC=1:220,1:221)
21 Q
22DRG217 D DRG216 Q
23DRG218 D DRG216 Q
24DRG219 D DRG216 Q
25DRG220 D DRG216 Q
26DRG221 D DRG216 Q
27DRG222 N ICDE1,ICDE2,ICDE3,ICDE4
28 S ICDE1=$S($D(ICDOP(" 37.95"))&(($D(ICDOP(" 37.96")))!($D(ICDOP(" 00.54")))):1,1:0)
29 S ICDE2=$S($D(ICDOP(" 37.97"))&(($D(ICDOP(" 37.98")))!($D(ICDOP(" 00.54")))):1,1:0)
30 S ICDE3=$S($D(ICDOP(" 00.52"))&($D(ICDOP(" 00.54"))):1,1:0)
31 ;S ICDE4=$S($D(ICDOP(" 00.54"))&($D(ICDOP(" 37.95"))):1,1:0)
32 S ICDE4=$S($D(ICDOP(" 37.74"))&(($D(ICDOP(" 37.96")))!($D(ICDOP(" 37.98")))!($D(ICDOP(" 00.54")))):1,1:0)
33 S ICDRG=999
34 I $D(ICDOP(" 37.94"))!$D(ICDOP(" 00.51")) I ICDE1+ICDE2+ICDE3+ICDE4=0 D
35 . S ICDRG=$S(ICDMCC=2:226,1:227)
36 I '$D(ICDOP(" 37.94"))&('$D(ICDOP(" 00.51"))) I ICDE1!ICDE2!ICDE3!ICDE4
37 D
38 . S ICDRG=$S(ICDMCC=2:226,1:227)
39 ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
40 I (ICDRG=226)!(ICDRG=227) I ICDOR["HN" I '$D(ICDOP(" 37.26")) S ICDRG=$S((ICDPD["A")&(ICDMCC=2):222,ICDPD["A":223,ICDMCC=2:224,1:225)
41 I ICDRG=470 D CMS115
42 Q
43DRG223 D DRG222 Q
44DRG224 ;
45DRG225 D DRG222 Q
46DRG226 ;
47DRG227 D DRG222 Q
48DRG228 ;
49DRG229 ;
50DRG230 ;DRGs 228-230 note ICDOR["Oo" = operation and DRG CMS108/MS230 procedure
51 I ICDOR["Oo"!($D(ICDOP(" 38.44"))&($D(ICDOP(" 38.45")))) D Q
52 . S ICDRG=$S(ICDMCC=2:228,ICDMCC=1:229,1:230) Q
53 G DRG237
54DRG231 S ICDRG=999
55 I ICDOR["b" D DRG235
56 I ICDOR["b" I $D(ICDOP(" 35.96"))!($D(ICDOP(" 00.66"))) D Q
57 . S ICDRG=$S(ICDMCC=2:231,1:232)
58 I ICDOR["b" I $D(ICDOP(" 37.21"))!($D(ICDOP(" 37.22")))!($D(ICDOP(" 37.23"))) D DRG233 Q
59 I ICDOR["b" I $D(ICDOP(" 37.21"))!($D(ICDOP(" 37.22")))!($D(ICDOP(" 37.23"))) D DRG233 Q
60 I ICDRG'=231&(ICDRG'=232)&(ICDRG'=233)&(ICDRG'=234)&(ICDRG'=235)&(ICDRG'=236) S ICDRG=999 D DRG237
61 Q
62DRG232 D DRG231 Q
63DRG233 ; called from DRG231
64 D MCV
65 S ICDRG=$S(ICDMCV:233,ICDMCV1:233,1:234)
66 S ICDRG=$S(ICDMCC=2:233,1:234)
67 Q
68DRG234 D DRG233 Q
69DRG235 ;
70DRG236 S ICDRG=$S(ICDMCC=2:235,1:236) Q
71DRG237 I ICDOR["Oo" D DRG228
72 S ICDRG=$S((ICDMCC=2)&(ICDOR[7):237,ICDOR[7:238,1:ICDRG)
73 I $D(ICDOP(" 39.73")) S ICDRG=237
74 I "228^229^230^237^238"[ICDRG Q
75 ;I $D(ICDJJ(478))&('$D(ICDJJ(110))&'($D(ICDJJ(111)))) D DRG478^ICDTLB6C
76 D DRG239 I "239^240^241"[ICDRG Q
77 I ICDOR["p" D DRG260
78 I ICDOR["1" D CMS516
79 Q
80DRG238 S ICDRG=$S(ICDMCC=2:237,1:238) D Q
81 . I $D(ICDOP(" 39.73")) S ICDRG=237
82DRG239 ;239-241
83DRG240 ;
84DRG241 S ICDRG=$S($D(ICDJJ(241)):241,1:ICDRG)
85 I ICDRG=241 S ICDRG=$S(ICDMCC=2:239,ICDMCC=1:240,1:241)
86 Q
87DRG242 ; called from CMS115
88 D MCV
89 I ICDMCV!(ICDMCV1) D
90 . S ICDRG=$S(ICDMCC=2:242,ICDMCC=1:243,1:244)
91 Q
92DRG243 D CMS115 Q
93DRG244 D CMS115 Q
94DRG245 S ICDRG=245 Q
95DRG246 ;
96 D MCV
97 I ICDMCV!ICDMCV1 S ICDRG=246
98 E S ICDRG=247
99 S ICDRG=$S(ICDMCC=2:246,1:ICDRG) D Q
100 . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.43")) S ICDRG=246
101 . I $D(ICDOP(" 36.07")),$D(ICDOP(" 00.43")) S ICDRG=246
102 . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.48")) S ICDRG=246
103 . I $D(ICDOP(" 36.07")),$D(ICDOP(" 00.48")) S ICDRG=246
104 Q
105DRG247 D CMS516 Q
106DRG248 ;Called from CMS516
107 D MCV
108 I ICDMCV!(ICDMCV1) S ICDRG=248
109 S ICDRG=$S(ICDMCC=2:248,1:ICDRG) D Q
110 . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.43")) S ICDRG=248
111 . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.43")) S ICDRG=248
112 . I $D(ICDOP(" 36.06")),$D(ICDOP(" 00.48")) S ICDRG=248
113 . I $D(ICDOP(" 36.06")),$D(ICDOP(" 00.48")) S ICDRG=248
114 Q
115DRG249 ;Called from CMS516
116 D MCV
117 I 'ICDMCV&('ICDMCV1) S ICDRG=249
118 S ICDRG=$S(ICDMCC=2:248,1:ICDRG) D Q
119 . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.43")) S ICDRG=248
120 . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.43")) S ICDRG=248
121 . I $D(ICDOP(" 36.06")),$D(ICDOP(" 00.48")) S ICDRG=248
122 . I $D(ICDOP(" 36.06")),$D(ICDOP(" 00.48")) S ICDRG=248
123 Q
124DRG250 ;
125DRG251 D CMS516 Q ;S ICDRG=$S(ICDMCC=2:250,1:251) Q
126DRG252 ;
127DRG253 ;
128DRG254 S ICDRG=$S(ICDMCC=2:252,ICDMCC=1:253,1:254) Q
129DRG255 ;
130DRG256 ;
131DRG257 S ICDRG=$S(ICDMCC=2:255,ICDMCC=1:256,1:257) Q
132DRG258 ;
133DRG259 S ICDRG=$S(ICDMCC=2:258,1:259) Q
134DRG260 ;
135 D CMS115 I "242^243^244^291^292^293"[ICDRG Q
136 D DRG258 I $D(ICDOP(" 00.56")) S ICDRG=264
137 I ICDOR["p" S ICDRG=$S(ICDMCC=2:260,ICDMCC=1:261,1:262)
138 Q
139DRG261 D DRG260 Q
140DRG262 D DRG260 Q
141DRG263 S ICDRG=263 Q
142DRG264 S ICDRG=264 Q
143DRG280 ;
144DRG281 ;
145DRG282 S ICDRG=$S(ICDMCC=2:280,ICDMCC=1:281,1:282) Q
146DRG283 ;
147DRG284 ;
148DRG285 S ICDRG=$S(ICDMCC=2:283,ICDMCC=1:284,1:285) Q
149DRG286 ;
150DRG287 S ICDRG=$S(ICDMCC=2:286,1:287) Q
151DRG288 ;
152DRG289 ;
153DRG290 S ICDRG=$S(ICDMCC=2:288,ICDMCC=1:289,1:290) Q
154DRG291 ;
155DRG292 ;
156DRG293 I (ICDDX(1)=5458!$D(ICDDXT("785.51"))),'ICDEXP S ICDMCC=2
157 S ICDRG=$S(ICDMCC=2:291,ICDMCC=1:292,1:293) Q
158DRG294 ;
159DRG295 S ICDRG=$S(ICDMCC>0:294,1:295) Q
160DRG296 ;
161DRG297 ;
162DRG298 I (ICDDX(1)=2561!$D(ICDDXT(" 427.5"))),'ICDEXP S ICDMCC=2
163 S ICDRG=$S(ICDMCC=2:296,ICDMCC=1:297,1:298) Q
164DRG299 S ICDRG=$S(ICDMCC=2:299,ICDMCC=1:300,1:301) Q
165 Q
166CMS115 ;convert DRG115^ICDTLB2C code - no MS-DRG 115 existed
167 D EN1^ICDDRG5
168 I ICDPD'["I"&(ICDCC2=0)&(ICDCC3=0) D Q
169 . S ICDRG=$S(ICDMCC=2:291,ICDMCC=1:292,1:293)
170 I ICDCC2=1!(ICDCC3=1) D DRG242
171 I ((ICDRG>241)&(ICDRG<245)) Q
172 ; ICDCC2 identifies AICD LEAD OR GNRTR
173 I ICDCC2=1!(ICDCC3=1) D Q
174 . S ICDRG=$S(ICDMCC=2:242,ICDMCC=1:243,1:244)
175 Q
176CMS516 ;convert DRG516^ICDTLB6C code - no MS-DRG 516 exists
177 S ICDRG=$S(ICDMCC=2:250,1:251)
178 D DRG248
179 I $D(ICDOP(" 36.06"))!$D(ICDOP(" 92.27")) D DRG249
180 I $D(ICDOP(" 36.07")) D DRG246
181 Q
182MCV ; checks to see if case qualifies as an MCV (major cardiovascular complications or complex conditions)
183 S (ICDMCV,ICDMCV1,ICDMCV2)=0
184 ; ICDPD=identifier for prime dx ICDSD=identifier for any secondary dx
185 ; DGDX(1)=prime dx ICDDX(1)=ien of prime dx ICDDXT=any secondary dx
186 I ICDPD["c"!(ICDSD["c") S ICDMCV=1
187 I ICDSD["s" S ICDMCV=1
188 ;I DGDX(1)["426.0"!(DGDX(1)["426.53")!(DGDX(1)["426.54") S ICDMCV1=1
189 I $G(ICDDX(1))=9056!($G(ICDDX(1))=2548)!($G(ICDDX(1))=2549) S ICDMCV1=1
190 I $D(ICDDXT("426.0"))!($D(ICDDXT("426.53")))!($D(ICDDXT("426.54"))) S ICDMCV1=1
191 ;I DGDX(1)["411.1"!(DGDX(1)["411.81") S ICDMCV2=1
192 I $G(ICDDX(1))=2500!($G(ICDDX(1))=12477) S ICDMCV2=1
193 I $D(ICDDXT("411.1"))!($D(ICDDXT("411.81"))) S ICDMCV2=1
194 Q
Note: See TracBrowser for help on using the repository browser.