source: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB3B.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1ICDTLB3B ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2006; 10/23/00 11:48am ; 6/28/05 4:03pm
2 ;;18.0;DRG Grouper;**20,27**;Oct 20, 2000;Build 2
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 ; ICD*18*27
44 ;I ICDOR["T"&(ICDOR'["3"&(ICDOR'["h")) D Q:"195^196^197^198"[ICDRG
45 ;.I ICDOR["E" S ICDRG=$S(ICDCC:195,1:196) Q
46 ;.I ICDOR'["E" S ICDRG=$S(ICDCC:197,1:198)
47 ;I ICDOR["3"!(ICDOR["E") S ICDRG=$S(ICDCC:193,1:194) Q
48 I ICDOR["3" S ICDRG=$S(ICDCC:193,1:194) Q
49 I ICDOR["E" I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22"))!$D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDCC:195,1:196) Q
50 I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22")) S ICDRG=$S(ICDCC:197,1:198) Q
51 I $D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDCC:493,1:494) Q
52 ; end of ICD*18*27
53 I ICDPD["M"&(ICDOR["h") S ICDRG=199 Q
54 I ICDPD'["M"&(ICDOR["h") S ICDRG=200 Q
55 I ICDPD["M"&(ICDOR'["h") S ICDRG=203 Q
56 S ICDRG=204
57 Q
58DRG194 D DRG193 Q
59DRG195 ;G:ICDOR["TT" DRG493^ICDTLB6B D DRG193 Q
60 D DRG193 Q
61DRG196 D DRG193 Q
62DRG197 ;S ICDRG=$S(ICDCC:197,1:198) Q
63 D DRG193 Q
64DRG198 ;S ICDRG=$S(ICDCC:197,1:198) Q
65 D DRG193 Q
66DRG199 D DRG193 Q
67DRG200 D DRG193 Q
68DRG205 S ICDRG=$S(ICDCC:205,1:206) Q
69DRG206 S ICDRG=$S(ICDCC:205,1:206) Q
70DRG207 S ICDRG=$S(ICDCC:207,1:208) Q
71DRG208 S ICDRG=$S(ICDCC:207,1:208) Q
72DRG209 S ICDRG=$S($F($P(ICDOR,"M",2,99),"M"):471,1:209) Q
73DRG210 S ICDRG=$S(AGE<18:212,ICDCC:210,1:211) I AGE="" S ICDRG=470,ICDRTC=3
74 Q
75DRG211 S ICDRG=$S(AGE<18:212,ICDCC:210,1:211) I AGE="" S ICDRG=470,ICDRTC=3
76 Q
77DRG212 S ICDRG=$S(AGE<18:212,ICDCC:210,1:211) I AGE="" S ICDRG=470,ICDRTC=3
78 Q
79DRG214 Q
80DRG215 Q
81DRG218 S ICDRG=$S(AGE<18:220,ICDCC:218,1:219) I AGE="" S ICDRG=470,ICDRTC=3
82 Q
83DRG219 S ICDRG=$S(AGE<18:220,ICDCC:218,1:219) I AGE="" S ICDRG=470,ICDRTC=3
84 Q
85DRG220 S ICDRG=$S(AGE<18:220,ICDCC:218,1:219) I AGE="" S ICDRG=470,ICDRTC=3
86 Q
87DRG221 Q
88DRG222 Q
89DRG224 S ICDRG=$S(ICDCC:223,1:224) Q
90DRG226 S ICDRG=$S(ICDCC:226,1:227) Q
91DRG227 S ICDRG=$S(ICDCC:226,1:227) Q
92DRG228 S ICDRG=$S(ICDOR["O2":228,ICDCC:228,1:229) Q
93DRG229 S ICDRG=$S(ICDOR["O2":228,ICDCC:228,1:229) Q
94DRG232 S ICDRG=232 Q
95DRG233 S ICDRG=$S(ICDCC:233,1:234) Q
96DRG234 S ICDRG=$S(ICDCC:233,1:234) Q
97DRG240 S ICDRG=$S(ICDCC:240,1:241) Q
98DRG241 S ICDRG=$S(ICDCC:240,1:241) Q
99DRG244 S ICDRG=$S(ICDCC:244,1:245) Q
100DRG245 S ICDRG=$S(ICDCC:244,1:245) Q
101DRG250 S ICDRG=$S(AGE<18:252,ICDCC:250,1:251) I AGE="" S ICDRG=470,ICDRTC=3
102 Q
103DRG251 S ICDRG=$S(AGE<18:252,ICDCC:250,1:251) I AGE="" S ICDRG=470,ICDRTC=3
104 Q
105DRG252 S ICDRG=$S(AGE<18:252,ICDCC:250,1:251) I AGE="" S ICDRG=470,ICDRTC=3
106 Q
107DRG253 S ICDRG=$S(AGE<18:255,ICDCC:253,1:254) I AGE="" S ICDRG=470,ICDRTC=3
108 Q
109DRG254 S ICDRG=$S(AGE<18:255,ICDCC:253,1:254) I AGE="" S ICDRG=470,ICDRTC=3
110 Q
111DRG255 S ICDRG=$S(AGE<18:255,ICDCC:253,1:254) I AGE="" S ICDRG=470,ICDRTC=3
112 Q
113DRG256 S ICDRG=256 Q
114DRG257 I ICDOR'=""&(ICDOR["M") D
115 .S ICDRG=$S(ICDPD["r"&(ICDCC):257,ICDSD["r"&(ICDCC):257,ICDPD["r":258,ICDSD["r":258,1:"")
116 S:ICDRG="" ICDRG=261
117 Q
118DRG258 D DRG257 Q
119DRG259 I ICDOR'=""&(ICDOR["m") D
120 .S ICDRG=$S(ICDPD["r"&(ICDCC):259,ICDSD["r"&(ICDCC):259,ICDPD["r":260,ICDSD["r":260,ICDOR["L":262,1:"")
121 .I $D(ICDOP("85.12 "))!$D(ICDOP("85.20 "))!$D(ICDOP("85.21 ")) S ICDRG=262
122 S:ICDRG="" ICDRG=261
123 Q
124DRG260 D DRG259 Q
125DRG262 D DRG259 Q
Note: See TracBrowser for help on using the repository browser.