source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB3A.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: 4.4 KB
Line 
1ICDTLB3A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 10/23/00 11:48am ; 4/1/05 11:05am
2 ;;18.0;DRG Grouper;**14,16**;Oct 20, 2000
3DRG164 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
4DRG165 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
5DRG166 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
6DRG167 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
7DRG168 S ICDRG=$S(ICDCC:168,1:169) Q
8DRG169 S ICDRG=$S(ICDCC:168,1:169) Q
9DRG170 S ICDRG=$S(ICDCC:170,1:171) Q
10DRG171 S ICDRG=$S(ICDCC:170,1:171) Q
11DRG172 S ICDRG=$S(ICDCC:172,1:173) Q
12DRG173 S ICDRG=$S(ICDCC:172,1:173) Q
13DRG174 S ICDRG=$S(ICDCC:174,1:175) Q
14DRG175 S ICDRG=$S(ICDCC:174,1:175) Q
15DRG177 S ICDRG=$S(ICDCC:177,1:178) Q
16DRG178 S ICDRG=$S(ICDCC:177,1:178) Q
17DRG180 S ICDRG=$S(ICDCC:180,1:181) Q
18DRG181 S ICDRG=$S(ICDCC:180,1:181) Q
19DRG182 S ICDRG=$S(AGE<18:184,ICDCC:182,1:183) I AGE="" S ICDRG=470,ICDRTC=3
20 Q
21DRG183 S ICDRG=$S(AGE<18:184,ICDCC:182,1:183) I AGE="" S ICDRG=470,ICDRTC=3
22 Q
23DRG184 S ICDRG=$S(AGE<18:184,ICDCC:182,1:183) I AGE="" S ICDRG=470,ICDRTC=3
24 Q
25DRG185 S ICDRG=$S(ICDOR["e":187,AGE="":470,AGE<18:186,1:185),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
26DRG186 S ICDRG=$S(ICDOR["e":187,AGE="":470,AGE<18:186,1:185),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
27DRG187 S ICDRG=$S($D(ICDPDRG(187)):187,$D(ICDPDRG):ICDPDRG,1:"")
28 I ICDRG?.N&(+ICDRG>0) Q
29 I +ICDRG=0 S ICDRG=470 Q
30 S ICDREF=$$RTABLE^ICDREF(+ICDRG,+ICDDATE)
31 I ICDRG["^"&(ICDREF'="") X "D DRG"_+ICDRG_"^"_ICDREF Q
32 S ICDRG=+ICDPDRG
33 Q
34DRG188 S ICDRG=$S(AGE<18:190,ICDCC:188,1:189) I AGE="" S ICDRG=470,ICDRTC=3
35 Q
36DRG189 S ICDRG=$S(AGE<18:190,ICDCC:188,1:189) I AGE="" S ICDRG=470,ICDRTC=3
37 Q
38DRG190 S ICDRG=$S(AGE<18:190,ICDCC:188,1:189) I AGE="" S ICDRG=470,ICDRTC=3
39 Q
40DRG191 S ICDRG=$S(ICDCC:191,1:192) Q
41DRG192 S ICDRG=$S(ICDCC:191,1:192) Q
42DRG193 ;
43 I ICDOR["T"&(ICDOR'["3"!(ICDOR'["h")) D Q:"195^196^197^198"[ICDRG
44 .I ICDOR["E" S ICDRG=$S(ICDCC:195,1:196) Q
45 .I ICDOR'["E" S ICDRG=$S(ICDCC:197,1:198)
46 I ICDOR["3"!(ICDOR["E") S ICDRG=$S(ICDCC:193,1:194) Q
47 I ICDPD["M"&(ICDOR["h") S ICDRG=199 Q
48 I ICDPD'["M"&(ICDOR["h") S ICDRG=200 Q
49 I ICDPD["M"&(ICDOR'["h") S ICDRG=203 Q
50 S ICDRG=204
51 Q
52DRG194 D DRG193 Q
53DRG195 G:ICDOR["TT" DRG493^ICDTLB6A D DRG193 Q
54DRG196 D DRG193 Q
55DRG197 S ICDRG=$S(ICDCC:197,1:198) Q
56DRG198 S ICDRG=$S(ICDCC:197,1:198) Q
57DRG199 D DRG193 Q
58DRG200 D DRG193 Q
59DRG205 S ICDRG=$S(ICDCC:205,1:206) Q
60DRG206 S ICDRG=$S(ICDCC:205,1:206) Q
61DRG207 S ICDRG=$S(ICDCC:207,1:208) Q
62DRG208 S ICDRG=$S(ICDCC:207,1:208) Q
63DRG209 S ICDRG=$S($F($P(ICDOR,"M",2,99),"M"):471,1:209) Q
64DRG210 S ICDRG=$S(AGE<18:212,ICDCC:210,1:211) I AGE="" S ICDRG=470,ICDRTC=3
65 Q
66DRG211 S ICDRG=$S(AGE<18:212,ICDCC:210,1:211) I AGE="" S ICDRG=470,ICDRTC=3
67 Q
68DRG212 S ICDRG=$S(AGE<18:212,ICDCC:210,1:211) I AGE="" S ICDRG=470,ICDRTC=3
69 Q
70DRG214 Q
71DRG215 Q
72DRG218 S ICDRG=$S(AGE<18:220,ICDCC:218,1:219) I AGE="" S ICDRG=470,ICDRTC=3
73 Q
74DRG219 S ICDRG=$S(AGE<18:220,ICDCC:218,1:219) I AGE="" S ICDRG=470,ICDRTC=3
75 Q
76DRG220 S ICDRG=$S(AGE<18:220,ICDCC:218,1:219) I AGE="" S ICDRG=470,ICDRTC=3
77 Q
78DRG221 Q
79DRG222 Q
80DRG224 S ICDRG=$S(ICDCC:223,1:224) Q
81DRG226 S ICDRG=$S(ICDCC:226,1:227) Q
82DRG227 S ICDRG=$S(ICDCC:226,1:227) Q
83DRG228 S ICDRG=$S(ICDOR["O2":228,ICDCC:228,1:229) Q
84DRG229 S ICDRG=$S(ICDOR["O2":228,ICDCC:228,1:229) Q
85DRG232 S ICDRG=232 Q
86DRG233 S ICDRG=$S(ICDCC:233,1:234) Q
87DRG234 S ICDRG=$S(ICDCC:233,1:234) Q
88DRG240 S ICDRG=$S(ICDCC:240,1:241) Q
89DRG241 S ICDRG=$S(ICDCC:240,1:241) Q
90DRG244 S ICDRG=$S(ICDCC:244,1:245) Q
91DRG245 S ICDRG=$S(ICDCC:244,1:245) Q
92DRG250 S ICDRG=$S(AGE<18:252,ICDCC:250,1:251) I AGE="" S ICDRG=470,ICDRTC=3
93 Q
94DRG251 S ICDRG=$S(AGE<18:252,ICDCC:250,1:251) I AGE="" S ICDRG=470,ICDRTC=3
95 Q
96DRG252 S ICDRG=$S(AGE<18:252,ICDCC:250,1:251) I AGE="" S ICDRG=470,ICDRTC=3
97 Q
98DRG253 S ICDRG=$S(AGE<18:255,ICDCC:253,1:254) I AGE="" S ICDRG=470,ICDRTC=3
99 Q
100DRG254 S ICDRG=$S(AGE<18:255,ICDCC:253,1:254) I AGE="" S ICDRG=470,ICDRTC=3
101 Q
102DRG255 S ICDRG=$S(AGE<18:255,ICDCC:253,1:254) I AGE="" S ICDRG=470,ICDRTC=3
103 Q
104DRG256 S ICDRG=256 Q
105DRG257 I ICDOR'=""&(ICDOR["M") D
106 .S ICDRG=$S(ICDPD["r"&(ICDCC):257,ICDSD["r"&(ICDCC):257,ICDPD["r":258,ICDSD["r":258,1:"")
107 S:ICDRG="" ICDRG=261
108 Q
109DRG258 D DRG257 Q
110DRG259 I ICDOR'=""&(ICDOR["m") D
111 .S ICDRG=$S(ICDPD["r"&(ICDCC):259,ICDSD["r"&(ICDCC):259,ICDPD["r":260,ICDSD["r":260,ICDOR["L":262,1:"")
112 .I $D(ICDOP("85.12 "))!$D(ICDOP("85.20 "))!$D(ICDOP("85.21 ")) S ICDRG=262
113 S:ICDRG="" ICDRG=261
114 Q
115DRG260 D DRG259 Q
116DRG262 D DRG259 Q
Note: See TracBrowser for help on using the repository browser.