source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB6C.m@ 1288

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1ICDTLB6C ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS FY 2007; 9/29/03 2:47pm ; 6/28/05 4:06pm
2 ;;18.0;DRG Grouper;**24,30**;Oct 20, 2000;Build 5
3DRG403 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
4DRG404 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
5DRG405 D DRG404 Q
6DRG406 ;
7 I ICDORNI["K" D
8 .S ICDRG=$S((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICDCC:406,1:407)
9 I ICDORNI'["K" D DRG408
10 Q
11DRG407 D DRG406 Q
12DRG408 I $D(ICDDX(1))&(ICDOPCT=0) D Q:ICDRG=409
13 .I ICDDX(1)=$O(^ICD9("AB","V58.0 ",0)) S ICDRG=409 Q
14 .I ICDDX(1)=$O(^ICD9("AB","V67.1 ",0)) S ICDRG=409 Q
15 .Q
16 I $D(ICDDX(1))&(ICDOPCT=0) D Q:"410^492"[ICDRG
17 .I ICDDX(1)=$O(^ICD9("AB","V58.11 ",0)) S ICDRG=$S(ICDSD["2":492,1:410) Q
18 .I ICDDX(1)=$O(^ICD9("AB","V58.12 ",0)) S ICDRG=$S(ICDSD["2":492,1:410) Q
19 .I ICDDX(1)=$O(^ICD9("AB","V67.2 ",0)) S ICDRG=$S(ICDSD["2":492,1:410) Q
20 I ICDOPCT>0 S ICDRG=$S(ICDPD'["L":408,ICDCC:401,1:402) Q
21 I ICDOPCT=0 D DRG412
22 Q
23DRG411 S ICDRG=$S(ICDOR["O"!(ICDORNI["O"):408,ICDOR["N":412,1:411) Q
24DRG412 ;S ICDRG=$S(ICDOR["O"!(ICDORNI["O"):408,ICDOR["N"&($D(ICDPDRG(412))):412,$D(ICDPDRG(411)):411,ICDCC:413,1:414)
25 I ICDOPCT>0 D DRG408 Q
26 D DRG412^ICDTLB61
27 Q
28DRG413 S ICDRG=$S(ICDCC:413,1:414) Q
29DRG414 S ICDRG=$S(ICDCC:413,1:414) Q
30DRG416 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE>17:576,1:417),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) I ICDRG=576&($D(ICDOP(" 96.72"))) S ICDRG=575
31 Q
32DRG417 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE>17:576,1:417),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
33DRG418 S ICDRG=$S(ICDOR["O":579,1:418) Q
34DRG419 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE<18:422,ICDCC:419,1:420),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
35DRG420 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE<18:422,ICDCC:419,1:420),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
36DRG421 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE>17:421,1:422),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
37DRG422 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE>17:421,1:422),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
38DRG423 S ICDRG=$S(ICDOR["O":578,1:423) I ICDRG=578&(ICDDX(1)=7615) S ICDRG=579
39 Q
40DRG424 S ICDRG=$S(ICDOR["O":424,1:425) Q
41DRG425 S ICDRG=$S(ICDOR["O":424,1:425) Q
42DRG426 S ICDRG=$S(ICDOR["O":424,1:426) Q
43DRG427 S ICDRG=$S(ICDOR["O":424,1:427) Q
44DRG428 S ICDRG=$S(ICDOR["O":424,1:428) Q
45DRG429 S ICDRG=$S(ICDOR["O":424,1:429) Q
46DRG430 S ICDRG=$S(ICDOR["O":424,1:430) Q
47DRG431 S ICDRG=$S(ICDOR["O":424,1:431) Q
48DRG432 S ICDRG=$S(ICDOR["O":424,1:432) Q
49DRG434 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
50DRG435 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
51DRG436 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
52DRG437 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
53DRG439 S ICDRG=$S($D(ICDODRG(440)):440,1:439) Q
54DRG442 S ICDRG=$S(ICDCC:442,1:443) Q
55DRG443 D EN1^ICDDRG5 S ICDRG=$S(ICDCC3:$S(ICDCC:442,1:443),1:"") Q
56DRG444 S ICDRG=$S(AGE<18:446,ICDCC:444,1:445) I AGE="" S ICDRG=470,ICDRTC=3
57 Q
58DRG445 S ICDRG=$S(AGE<18:446,ICDCC:444,1:445) I AGE="" S ICDRG=470,ICDRTC=3
59 Q
60DRG446 S ICDRG=$S(AGE<18:446,ICDCC:444,1:445) I AGE="" S ICDRG=470,ICDRTC=3
61 Q
62DRG447 S ICDRG=$S(AGE>17:447,1:448) I AGE="" S ICDRG=470,ICDRTC=3
63 Q
64DRG448 S ICDRG=$S(AGE>17:447,1:448) I AGE="" S ICDRG=470,ICDRTC=3
65 Q
66DRG449 S ICDRG=$S(AGE<18:451,ICDCC:449,1:450) I AGE="" S ICDRG=470,ICDRTC=3
67 Q
68DRG450 S ICDRG=$S(AGE<18:451,ICDCC:449,1:450) I AGE="" S ICDRG=470,ICDRTC=3
69 Q
70DRG451 S ICDRG=$S(AGE<18:451,ICDCC:449,1:450) I AGE="" S ICDRG=470,ICDRTC=3
71 Q
72DRG452 S ICDRG=$S(ICDCC:452,1:453) Q
73DRG453 S ICDRG=$S(ICDCC:452,1:453) Q
74DRG454 S ICDRG=$S(ICDCC:454,1:455) Q
75DRG455 S ICDRG=$S(ICDCC:454,1:455) Q
76DRG462 S ICDRG=$S(ICDOR["O":461,1:462) Q
77DRG463 S ICDRG=$S(ICDOR["O":461,ICDCC:463,1:464) Q
78DRG464 S ICDRG=$S(ICDOR["O":461,ICDCC:463,1:464) Q
79DRG465 S ICDRG=$S(ICDOR["O":461,ICDSD["m":465,1:466) Q
80DRG466 S ICDRG=$S(ICDOR["O":461,ICDSD["m":465,1:466) Q
81DRG467 S ICDRG=$S(ICDOR["O":461,1:467) Q
82DRG471 S ICDRG=$S($F($P(ICDOR,"M",2,99),"M"):471,1:"") Q
83DRG475 S ICDRG=$S(ICDOR["V":475,1:$S($D(ICDPDRG):$O(ICDPDRG(0)),1:468)) I ICDRG<468 D DODRG^ICDDRG0
84 Q
85DRG478 S ICDRG=$S(ICDOR["O"&ICDCC:478,1:479)
86 I ICDRG=478 D DRG553^ICDTLB6C
87 Q
88DRG479 G DRG478
89DRG493 ;I (ICDI-1)=1,'ICDCC S ICDCC=$S($D(^ICD9("ACC",ICDDX(1),ICDDX(1))):1,1:0)
90 S ICDRG=$S(ICDCC:493,1:494) Q
91DRG494 ;I (ICD-1),'ICDCC S ICDCC=$S($D(^ICD9("ACC",ICDDX(1),ICDDX(1))):1,1:0)
92 S ICDRG=$S(ICDCC:493,1:494) Q
93DRG495 Q
94DRG496 S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498)
95 I ICDRG=497!(ICDRG=498) I ICDPD["6" S ICDRG=546 Q
96 I ICDRG=497!(ICDRG=498) I $D(ICDDXT("737.40"))!($D(ICDDXT("737.41")))!($D(ICDDXT("737.42")))!($D(ICDDXT("737.43"))) S ICDRG=546
97 Q
98DRG497 G DRG496 ;S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498) Q
99DRG498 G DRG496 ;S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498) Q
100DRG499 S ICDRG=$S(ICDCC:499,1:500) Q
101DRG500 S ICDRG=$S(ICDCC:499,1:500) Q
102DRG501 D
103 . I (ICDPD["k") D
104 .. I ICDCC S ICDRG=501
105 .. I 'ICDCC S ICDRG=502
106 . E S ICDRG=503
107 Q
108DRG502 D DRG501 Q
109DRG503 D DRG501 Q
110DRG514 ; Replaced with DRG535
111 N ICDE1,ICDE2
112 S ICDE1=$S($D(ICDOP(" 37.95"))&($D(ICDOP(" 37.96"))):1,1:0)
113 S ICDE2=$S($D(ICDOP(" 37.97"))&($D(ICDOP(" 37.98"))):1,1:0)
114 S ICDRG=470
115 I $D(ICDOP(" 37.94")) I ICDE1+ICDE2=0 S ICDRG=515
116 I '$D(ICDOP(" 37.94")) I ICDE1!ICDE2 S ICDRG=515
117 ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
118 I ICDRG=515 I ICDOR["HN" S ICDRG=514
119 Q
120DRG515 D DRG535 Q
121DRG516 ; DRG 516,517,526 and 527 replaced by DRG 555-558 respectively
122 ; ICD*18*30 DRG551 is higher in surgical hierarchy
123 I ICDRG=551 Q
124 S ICDRG=518
125 D DRG555
126 I $D(ICDOP(" 36.06"))!$D(ICDOP(" 92.27")) D DRG556
127 I $D(ICDOP(" 36.07")) D DRG557
128 Q
129DRG517 D DRG516 Q
130DRG518 D DRG516 Q
131DRG519 S ICDRG=$S(ICDOR["F":496,ICDCC:519,1:520) Q
132DRG520 D DRG519 Q
133DRG521 S ICDRG=$S(ICDCC:521,ICDOR["D"!(ICDOR["R"):522,1:523) Q
134DRG522 D DRG521 Q
135DRG523 D DRG521 Q
136DRG526 D DRG516 Q
137DRG527 D DRG516 Q
138DRG531 S ICDRG=$S(ICDCC:531,1:532) Q
139DRG532 D DRG531 Q
140DRG533 S ICDRG=$S(ICDCC:533,1:534) I $D(ICDOP(" 00.61"))&($D(ICDOP(" 00.63"))) S ICDRG=577
141 Q
142DRG534 D DRG533 Q
143DRG535 N ICDE1,ICDE2,ICDE3,ICDE4
144 S ICDE1=$S($D(ICDOP(" 37.95"))&(($D(ICDOP(" 37.96")))!($D(ICDOP(" 00.54")))):1,1:0)
145 S ICDE2=$S($D(ICDOP(" 37.97"))&(($D(ICDOP(" 37.98")))!($D(ICDOP(" 00.54")))):1,1:0)
146 S ICDE3=$S($D(ICDOP(" 00.52"))&($D(ICDOP(" 00.54"))):1,1:0)
147 ;S ICDE4=$S($D(ICDOP(" 00.54"))&($D(ICDOP(" 37.95"))):1,1:0)
148 S ICDE4=$S($D(ICDOP(" 37.74"))&(($D(ICDOP(" 37.96")))!($D(ICDOP(" 37.98")))!($D(ICDOP(" 00.54")))):1,1:0)
149 S ICDRG=470
150 I $D(ICDOP(" 37.94"))!$D(ICDOP(" 00.51")) I ICDE1+ICDE2+ICDE3+ICDE4=0 S ICDRG=515
151 I '$D(ICDOP(" 37.94"))&('$D(ICDOP(" 00.51"))) I ICDE1!ICDE2!ICDE3!ICDE4 S ICDRG=515
152 ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
153 I ICDRG=515 I ICDOR["HN" I '$D(ICDOP(" 37.26")) S ICDRG=$S(ICDPD["A":535,1:536)
154 I ICDRG=470 D DRG115^ICDTLB2C
155 Q
156DRG536 D DRG535 Q
157DRG537 S ICDRG=$S(ICDCC:537,1:538) Q
158DRG538 D DRG537 Q
159DRG539 I ICDPD["L"&(ICDMAJ'[3) D DRG401^ICDTLB5C Q:"401^402^403^404^405^470^473"[ICDRG
160 S ICDRG=$S((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICDCC:406,1:407) Q
161DRG540 D DRG539 Q
162DRG543 S ICDRG=$S((ICDPD["Q")&(ICDOR["Q"):543,ICDOR["Q"&$D(ICDOP(" 00.10")):543,$D(ICDOP(" 02.93"))&($D(ICDOP(" 86.95"))):543,1:ICDRG) Q
163DRG544 Q
164DRG545 Q
165DRG546 Q
166DRG547 ; called from DRG106^ICDTLB2C
167 D MCV
168 S ICDRG=$S(ICDMCV:547,ICDMCV1:547,1:548) Q
169DRG548 G DRG547
170DRG549 ; called from DRG106^ICDTLB2C
171 D MCV
172 S ICDRG=$S(ICDMCV:549,ICDMCV1:549,1:550) Q
173DRG550 G DRG549
174DRG551 ; called from DRG115^ICDTLB2C
175 D MCV
176 I ICDMCV!(ICDMCV2) S ICDRG=551
177 Q
178DRG552 Q
179DRG553 ; called from DRG478
180 D MCV
181 S ICDRG=$S(ICDMCV:553,ICDMCV1:553,1:554) Q
182DRG554 G DRG553
183DRG555 ; called from DRG516
184 D MCV
185 I ICDMCV!(ICDMCV1) S ICDRG=555
186 Q
187DRG556 ; called from DRG516
188 D MCV
189 I 'ICDMCV&('ICDMCV1) S ICDRG=556
190 Q
191DRG557 ; called from DRG516
192 D MCV
193 I ICDMCV!ICDMCV1 S ICDRG=557
194 E S ICDRG=558
195 Q
196DRG558 G DRG516
197DRG559 ;I DGDX(1)["433.01"!(DGDX(1)["433.11")!(DGDX(1)["433.21")!(DGDX(1)["433.31")!(DGDX(1)["433.81")!(DGDX(1)["433.91")!(DGDX(1)["434.01")!(DGDX(1)["434.11")!(DGDX(1)["434.91") S ICDRG=559
198 I $G(ICDDX(1))=12856!($G(ICDDX(1))=12858)!($G(ICDDX(1))=12860)!($G(ICDDX(1))=12862)!($G(ICDDX(1))=12864)!($G(ICDDX(1))=12866)!($G(ICDDX(1))=12868)!($G(ICDDX(1))=12870)!($G(ICDDX(1))=12872) S ICDRG=559
199 Q
200DRG560 Q
201DRG561 Q
202DRG562 Q
203DRG563 Q
204DRG564 Q
205DRG565 Q
206DRG566 Q
207DRG567 Q
208DRG568 Q
209DRG569 Q
210DRG570 Q
211DRG571 Q
212DRG572 Q
213DRG573 Q
214DRG574 Q
215DRG575 Q
216DRG576 Q
217DRG577 Q
218DRG578 Q
219DRG579 Q
220MCV ; checks to see if case qualifies as an MCV (major cardiovascular complications or complex conditions)
221 S (ICDMCV,ICDMCV1,ICDMCV2)=0
222 ; ICDPD=identifier for prime dx ICDSD=identifier for any secondary dx
223 ; DGDX(1)=prime dx ICDDX(1)=ien of prime dx ICDDXT=any secondary dx
224 I ICDPD["c"!(ICDSD["c") S ICDMCV=1
225 I ICDSD["s" S ICDMCV=1
226 ;I DGDX(1)["426.0"!(DGDX(1)["426.53")!(DGDX(1)["426.54") S ICDMCV1=1
227 I $G(ICDDX(1))=9056!($G(ICDDX(1))=2548)!($G(ICDDX(1))=2549) S ICDMCV1=1
228 I $D(ICDDXT("426.0"))!($D(ICDDXT("426.53")))!($D(ICDDXT("426.54"))) S ICDMCV1=1
229 ;I DGDX(1)["411.1"!(DGDX(1)["411.81") S ICDMCV2=1
230 I $G(ICDDX(1))=2500!($G(ICDDX(1))=12477) S ICDMCV2=1
231 I $D(ICDDXT("411.1"))!($D(ICDDXT("411.81"))) S ICDMCV2=1
232 Q
Note: See TracBrowser for help on using the repository browser.