source: WorldVistAEHR/trunk/r/DRG_GROUPER-ICD--ICPT/ICD1824A.m@ 701

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

initial load of WorldVistAEHR

File size: 6.4 KB
Line 
1ICD1824A ;;ALB/EG/JAT - FY 2007 UPDATE; 6/19/05 4:08pm ; 6/24/05 3:29pm
2 ;;18.0;DRG Grouper;**24**;Oct 13,2000;Build 5
3 ;
4 Q
5 ;
6ADDDRG ; add new DRGs
7 N DIC,X,Y,DINUM,LINE,ICDDRG,DA,DRGX,DRGY,MDC,SURG,ROUTINE,ICDIEN
8 D BMES^XPDUTL(">>> Adding New DRGs - Please verify that 20 were added")
9 ; create top-level record (relative weights & average length of stay (ALOS) will be added later)
10 F LINE=1:1 S X=$T(ADD+LINE) S ICDDRG=$P(X,";;",2) Q:ICDDRG="EXIT" D
11 .S DIC="^ICD(",DIC(0)="L"
12 .S MDC=$P(ICDDRG,U,2) I MDC="PRE" S MDC=98
13 .S SURG=$P(ICDDRG,U,3)
14 .S DIC("DR")="5///^S X=MDC;.06///^S X=SURG"
15 .S X="DRG",X=X_$P(ICDDRG,U)
16 .; check for duplicates in case install is being rerun
17 .I $D(^ICD($P(ICDDRG,U),0)) Q
18 .K DO D FILE^DICN
19 .K DIC,DA
20 .;create 80.21A subfile
21 .S DA(1)=$P(ICDDRG,U)
22 .S DIC="^ICD("_DA(1)_",1,"
23 .S DIC(0)="L"
24 .S X=$P(ICDDRG,U,4)
25 .K DO D FILE^DICN
26 .;create 80.266 subfile
27 .K DIC,DA
28 .S DA(1)=$P(ICDDRG,U)
29 .S DIC="^ICD("_DA(1)_",66,"
30 .S DIC(0)="L"
31 .I SURG="" S SURG=0
32 .S DIC("DR")=".03///1;.05///^S X=MDC;.06///^S X=SURG"
33 .S X=3061001
34 .K DO D FILE^DICN
35 .; create 80.271 subfile
36 .K DIC,DA
37 .S DA(1)=$P(ICDDRG,U)
38 .S DIC="^ICD("_DA(1)_",2,"
39 .S DIC(0)="L"
40 .S ROUTINE="ICDTLB6C"
41 .S DIC("DR")="1///^S X=ROUTINE"
42 .S X=3061001
43 .K DO D FILE^DICN
44 .; create 80.268 and 80.2681 subfiles
45 .K DIC,DA
46 .N FDA
47 .S ICDIEN=$P(ICDDRG,U)
48 .S FDA(1820,80.2,"?1,",.01)=ICDIEN
49 .S FDA(1820,80.268,"+2,?1,",.01)=3061001
50 .D UPDATE^DIE("","FDA(1820)") K FDA(1820)
51 .S FDA(1820,80.2,"?1,",.01)=ICDIEN
52 .S FDA(1820,80.268,"?2,?1,",.01)=3061001
53 .S FDA(1820,80.2681,"+3,?2,?1,",.01)=$P(ICDDRG,U,4)
54 .D UPDATE^DIE("","FDA(1820)")
55 .; displays listing
56 .S DRGX=$P(ICDDRG,U),DRGY=$P(ICDDRG,U,4)
57 .D MES^XPDUTL(" DRG"_DRGX_" "_DRGY)
58 .Q
59 ; now update entire file for weights & versioning
60 D UPDTDRG^ICD1824B
61 ; inactivate some DRGs
62 D INACTDRG^ICD1824B
63 ; modify some DRG titles
64 D DRGTITLE^ICD1824B
65 Q
66 ;
67ADD ;New DRGs
68 ;;560^1^^BACTERIAL & TUBERCULOUS INFECTIONS OF NERVOUS SYSTEM
69 ;;561^1^^NON-BACTERIAL INFECTIONS OF NERVOUS SYSTEM EXCEPT VIRAL MENINGITIS
70 ;;562^1^^SEIZURE AGE > 17 W CC
71 ;;563^1^^SEIZURE AGE > 17 W/O CC
72 ;;564^1^^HEADACHES AGE >17
73 ;;565^4^^RESPIRATORY SYSTEM DIAGNOSIS WITH VENTILATOR SUPPORT 96+ HOURS
74 ;;566^6^^RESPIRATORY SYSTEM DIAGNOSIS WITH VENTILATOR SUPPORT < 96 HOURS
75 ;;567^6^1^STOMACH, ESOPHAGEAL & DUODENAL PROC AGE > 17 W CC W MAJOR GI DX
76 ;;568^6^1^STOMACH, ESOPHAGEAL & DUODENAL PROCEDURES PROC AGE > 17 W CC W/O MAJOR GI DX
77 ;;569^6^1^MAJOR SMALL & LARGE BOWEL PROCEDURES W CC W MAJOR GI DX
78 ;;570^6^1^MAJOR SMALL & LARGE BOWEL PROCEDURES W CC W/O MAJOR GI DX
79 ;;571^6^1^MAJOR ESOPHAGEAL DISORDERS
80 ;;572^8^^MAJOR GASTROINTESTINAL DISORDERS AND PERITONEAL INFECTIONS
81 ;;573^11^1^MAJOR BLADDER PROCEDURES
82 ;;574^16^^MAJOR HEMATOLOGIC/IMMUNOLOGIC DIAG EXC SICKLE CELL CRISIS & COAGUL
83 ;;575^18^^SEPTICEMIA W MV96+ HOURS AGE >17
84 ;;576^18^^SEPTICEMIA W/O MV96+ HOURS AGE >17
85 ;;577^1^1^CAROTID ARTERY STENT PROCEDURE
86 ;;578^18^1^INFECTIOUS & PARASITIC DISEASES W OR PROCEDURE
87 ;;579^18^1^POSTOPERATIVE OR POST-TRAUMATIC INFECTIONS W OR PROCEDURE
88 ;;EXIT
89 ;
90PRO ;-update operation/procedure codes
91 ; from Table 6B in Fed Reg - assumes new codes already added by Lexicon
92 D BMES^XPDUTL(">>>Modifying new op/pro codes - file 80.1")
93 N LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,MDC24,SUBLINE,DATA,FDA
94 F LINE=1:1 S X=$T(REV+LINE) S ICDPROC=$P(X,";;",2) Q:ICDPROC="EXIT" D
95 .Q:ICDPROC["+"
96 .S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0))
97 .I ENTRY D
98 ..;check for possible inactive dupe
99 ..I $P($G(^ICD0(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",ENTRY)) I 'ENTRY Q
100 ..S DA=ENTRY,DIE="^ICD0("
101 ..;the "O" (not zero) is from the OR column in Table 6B (a "Y" there), rest is as needed
102 ..S IDENT=$P(ICDPROC,U,2)
103 ..S MDC24=$P(ICDPROC,U,3)
104 ..S DR="2///^S X=IDENT;5///^S X=MDC24"
105 ..I IDENT=""&(MDC24="") Q
106 ..D ^DIE
107 ..; check if already created in case patch being re-installed
108 ..Q:$D(^ICD0(ENTRY,2,"B",3061001))
109 ..;add 80.171, 80.1711 and 80.17111 records
110 ..F SUBLINE=1:1 S X=$T(REV+LINE+SUBLINE) S DATA=$P(X,";;",2) Q:DATA'["+" D
111 ...I SUBLINE=1 D
112 ....S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
113 ....S FDA(1820,80.171,"+2,?1,",.01)=3061001
114 ....D UPDATE^DIE("","FDA(1820)") K FDA(1820)
115 ...S DATA=$E(DATA,2,99)
116 ...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
117 ...S FDA(1820,80.171,"?2,?1,",.01)=3061001
118 ...S FDA(1820,80.1711,"+3,?2,?1,",.01)=$P(DATA,U)
119 ...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
120 ...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
121 ...S FDA(1820,80.171,"?2,?1,",.01)=3061001
122 ...S FDA(1820,80.1711,"?3,?2,?1,",.01)=$P(DATA,U)
123 ...S FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$P(DATA,U,2)
124 ...I $P(DATA,U,3) S FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$P(DATA,U,3)
125 ...I $P(DATA,U,4) S FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$P(DATA,U,4)
126 ...I $P(DATA,U,5) S FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$P(DATA,U,5)
127 ...I $P(DATA,U,6) S FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$P(DATA,U,6)
128 ...I $P(DATA,U,7) S FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$P(DATA,U,7)
129 ...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
130 Q
131 ;
132REV ;
133 ;;00.44^^
134 ;;00.56^Op^
135 ;;+5^117^120
136 ;;00.57^O^
137 ;;+5^118^120
138 ;;00.77^^
139 ;;00.85^OM^2
140 ;;+8^471^544
141 ;;+21^442^443
142 ;;+24^485
143 ;;00.86^OM^2
144 ;;+8^471^544
145 ;;+10^292^293
146 ;;+21^442^443
147 ;;+24^485
148 ;;00.87^OM^2
149 ;;+8^471^544
150 ;;+10^292^293
151 ;;+21^442^443
152 ;;+24^485
153 ;;01.28^OQ^1
154 ;;+1^1^2^3^543
155 ;;+17^406^407^539^540
156 ;;+21^442^443
157 ;;+24^484
158 ;;13.90^O^3
159 ;;+2^39
160 ;;+21^442^443
161 ;;+24^486
162 ;;13.91^O^3
163 ;;+2^39
164 ;;+21^442^443
165 ;;+24^486
166 ;;32.23^O^
167 ;;+4^75
168 ;;+17^406^407^539^540
169 ;;32.24^O^
170 ;;+4^76^7
171 ;;32.25^O^
172 ;;+4^75
173 ;;+17^406^407^539^540
174 ;;32.26^O^
175 ;;+4^75
176 ;;33.71^N^
177 ;;+17^412
178 ;;33.78^N^
179 ;;+17^412
180 ;;33.79^N^
181 ;;+17^412
182 ;;35.55^Oo^
183 ;;+5^108
184 ;;36.33^Oo^
185 ;;+5^108
186 ;;36.34^Oo^
187 ;;+5^108
188 ;;37.20^^
189 ;;39.74^OQ^3
190 ;;+1^1^2^3^543
191 ;;+21^442^443
192 ;;+24^486
193 ;;50.23^O^
194 ;;+6^170^171
195 ;;+7^191^192
196 ;;50.24^O^
197 ;;+6^170^171
198 ;;+7^191^192
199 ;;50.25^O^
200 ;;+6^170^171
201 ;;+7^191^192
202 ;;50.26^O^
203 ;;+6^170^171
204 ;;+7^191^192
205 ;;55.32^O^
206 ;;+11^303^304^305
207 ;;55.33^O^
208 ;;+11^303^304^305
209 ;;55.34^O^
210 ;;+11^303^304^305
211 ;;55.35^O^
212 ;;+11^303^304^305
213 ;;68.41^O^
214 ;;+13^354^355^357^358^359
215 ;;+14^375
216 ;;68.49^O^
217 ;;+13^354^355^357^358^359
218 ;;+14^375
219 ;;68.61^O^
220 ;;+13^353
221 ;;+14^375
222 ;;68.69^O^
223 ;;+13^353
224 ;;+14^375
225 ;;68.71^O^
226 ;;+13^353
227 ;;+14^375
228 ;;68.79^O^
229 ;;+13^353
230 ;;+14^375
231 ;;EXIT
Note: See TracBrowser for help on using the repository browser.