source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPS35.m@ 1505

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1RMPRPS35 ;HINCIO/ODJ - HCPCS Update Utilities ; 3/25/04 12:27pm
2 ;;3.0;PROSTHETICS;**58,69,76,77,84**,FEB 09,1996
3 Q
4 ;
5 ; RVD 2/12/02 patch #76 - replace a list of deactivated for 2003 HCPCS
6 ;
7 ; RVD 4/25/02 patch #69 - replace a list of deactivated HCPCS.
8 ; files (661.1 and 661.3)
9 ; RVD patch #77 - Convert old HCPCS to new/replacement HCPCS in PIP.
10 ; - old HCPCS not included in patch #76
11 ; - Remove inactive flag.
12 ;
13 ; AAC 3/26/04 - Patch 84: Convert old HCPCS to new/replacement HCPCS in PIP.
14 ; Replace all CPT Codes with pointer 104840 - code A9900 begin with 1/1/04
15 ; Update all Modifier codes with null
16 ;
17 ; HCPCD - Change HCPCS code in files 660, 664, 664.1, 665, 665.72
18 ; 661.2 and 661.3
19 ; Only to be run if users off the system
20 ; Used where the same HCPCS code has duplicate records.
21 ; Inputs:
22 ; RMPRHPF - IEN of HCPCS to delete
23 ; RMPRHPT - IEN of HCPCS to copy deleted HCPCS to
24 ;
25HCPCD(RMPRHPF,RMPRHPT) ;
26 N RMPRI,RMPRFDA,RMPRFME,RMPRIEN,RMPRS,RMPR65P,RMPRJ,RMPRPTP
27 N RMPRO1,RMPRO2,RMPRO3,RMPRO4,RMPR641P,RMPR64P,X,Y,DA
28 ;
29 ; Start with file 660 using the H x-ref.
30 S RMPRI=""
31 F S RMPRI=$O(^RMPR(660,"H",RMPRHPF,RMPRI)) Q:RMPRI="" D
32 . ;
33 . ; Get pointer to 665 and update HCPCS multiples
34 . S RMPR65P=$P($G(^RMPR(660,RMPRI,0)),"^",2)
35 . S RMHCIT=$P($G(^RMPR(660,RMPRI,2)),"^",1)
36 . I RMPR65P'="" D
37 .. ;
38 .. ; Update 665.194 multiple
39 .. Q:'$D(^RMPR(665,RMPR65P,0))
40 .. S RMPRPTP=$P(^RMPR(665,RMPR65P,0),"^",1)
41 .. S RMPRJ=0
42 .. F S RMPRJ=$O(^RMPR(665,RMPR65P,"RMPOC",RMPRJ)) Q:'RMPRJ D
43 ... Q:$P($G(^RMPR(665,RMPR65P,"RMPOC",RMPRJ,0)),"^",7)'=RMPRHPF
44 ... S RMPRIEN=RMPRJ_","_RMPR65P_","
45 ... K RMPRFDA,RMPRFME
46 ... S RMPRFDA(665.194,RMPRIEN,6)=RMPRHPT
47 ... D FILE^DIE("","RMPRFDA","RMPRFME")
48 ... Q
49 .. ;
50 .. ; Update 665.723191 multiple
51 .. S RMPRO1=0
52 .. F S RMPRO1=$O(^RMPO(665.72,RMPRO1)) Q:'+RMPRO1 D
53 ... S RMPRO2=0
54 ... F S RMPRO2=$O(^RMPO(665.72,RMPRO1,1,RMPRO2)) Q:'+RMPRO2 D
55 .... S RMPRO3=0
56 .... F S RMPRO3=$O(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3)) Q:'+RMPRO3 D
57 ..... I $D(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP)) D
58 ...... S RMPRO4=0
59 ...... F S RMPRO4=$O(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP,1,RMPRO4)) Q:'+RMPRO4 D
60 ....... Q:$P($G(^RMPO(665.72,RMPRO1,1,RMPRO2,1,RMPRO3,"V",RMPRPTP,1,RMPRO4,0)),"^",2)'=RMPRHPF
61 ....... S RMPRIEN=RMPRO4_","_RMPRPTP_","_RMPRO3_","_RMPRO2_","_RMPRO1_","
62 ....... K RMPRFME,RMPRFDA
63 ....... S RMPRFDA(665.723191,RMPRIEN,2)=RMPRHPT
64 ....... D FILE^DIE("","RMPRFDA","RMPRFME")
65 ....... Q
66 ...... Q
67 ..... Q
68 .... Q
69 ... Q
70 .. Q
71 . ;
72 . ; Update to 664.1 and 664 HCPCS multiples
73 . S RMPRPTP=RMPR65P ;patient pointer
74 . I RMPRPTP'="" D
75 .. ;
76 .. ; Update 664.16 multiple
77 .. S RMPR641P=""
78 .. F S RMPR641P=$O(^RMPR(664.1,"D",RMPRPTP,RMPR641P)) Q:RMPR641P="" D
79 ... S RMPRJ=0
80 ... F S RMPRJ=$O(^RMPR(664.1,RMPR641P,2,RMPRJ)) Q:'+RMPRJ D
81 .... Q:$P($G(^RMPR(664.1,RMPR641P,2,RMPRJ,2)),"^",1)'=RMPRHPF
82 .... S RMPRIEN=RMPRJ_","_RMPR641P_","
83 .... K RMPRFDA,RMPRFME
84 .... S RMPRFDA(664.16,RMPRIEN,13)=RMPRHPT
85 .... D FILE^DIE("","RMPRFDA","RMPRFME")
86 .... Q
87 ... Q
88 .. Q
89 . S RMPRPTP=RMPR65P ;patient pointer same as 665 pointer
90 . I RMPRPTP'="" D
91 .. ;
92 .. ; Update 664.02 multiple
93 .. S RMPR64P=""
94 .. F S RMPR64P=$O(^RMPR(664,"C",RMPRPTP,RMPR64P)) Q:RMPR64P="" D
95 ... S RMPRJ=0
96 ... F S RMPRJ=$O(^RMPR(664,RMPR64P,1,RMPRJ)) Q:'+RMPRJ D
97 .... Q:$P($G(^RMPR(664,RMPR64P,1,RMPRJ,0)),"^",16)'=RMPRHPF
98 .... K RMPRFDA,RMPRFME
99 .... S RMPRIEN=RMPRJ_","_RMPR64P_","
100 .... S RMPRFDA(664.02,RMPRIEN,16)=RMPRHPT
101 .... D FILE^DIE("","RMPRFDA","RMPRFME")
102 .... Q
103 ... Q
104 .. Q
105 . ;
106 . ; finally update the 660 file
107 . K RMPRFDA,RMPRFME
108 . S RMPRIEN=RMPRI_","
109 . S RMPRFDA(660,RMPRIEN,4.5)=RMPRHPT
110 . S RMPRFDA(660,RMPRIEN,37)=RMPRHPT_"-"_$P(RMHCIT,"-",2)
111 . D FILE^DIE("","RMPRFDA","RMPRFME")
112 . Q
113 ;
114 ; Update PIP files 661.2 and 661.3
115HCPCDP S RMPRI=""
116 F S RMPRI=$O(^RMPR(661.2,"D",RMPRHPF,RMPRI)) Q:RMPRI="" D
117 . K RMPRFDA,RMPRFME
118 . S RMPRIEN=RMPRI_","
119 . S RMPRFDA(661.2,RMPRIEN,3)=RMPRHPT
120 . D FILE^DIE("","RMPRFDA","RMPRFME")
121 . Q
122 S RMPRI=0
123 F S RMPRI=$O(^RMPR(661.3,RMPRI)) Q:'+RMPRI D
124 . S RMPRJ=0
125 . F S RMPRJ=$O(^RMPR(661.3,RMPRI,1,RMPRJ)) Q:'+RMPRJ D
126 .. Q:$P($G(^RMPR(661.3,RMPRI,1,RMPRJ,0)),"^",1)'=RMPRHPF
127 .. K RMPRFDA,RMPRFME
128 .. S RMPRIEN=RMPRJ_","_RMPRI_","
129 .. S RMPRFDA(661.31,RMPRIEN,.01)=RMPRHPT
130 .. D FILE^DIE("","RMPRFDA","RMPRFME")
131 .. Q
132 . Q
133 K RMPRFDA,RMPRFME
134 S RMPRIEN=RMPRHPF_","
135 S RMPRFDA(661.1,RMPRIEN,.01)="@"
136 D FILE^DIE("","RMPRFDA","RMPRFME")
137HCPCDX Q
138 ;
139 ; ITEM - move Item records from 661.1 from old to new HCPCS
140 ;
141 ; Inputs:
142 ; RMPRHPO - Old HCPCS code being replaced
143 ; RMPRHPN - New HCPCS code
144 ;
145ITEM(RMPRHPO,RMPRHPN) ;
146 N RMPRHPOI,RMPRHPNI,RMPRJ,RMPRFDA,RMPRFME,RMPRIEN,X,Y,DA,RMPRIENA,RMPRK
147 N RMPRL,RMPRS,RMPRITEM,RMPRIFLG,RML,RMPRIN,RMPRIO
148 K ^TMP($J,"RM")
149 S RMPRHPOI=$O(^RMPR(661.1,"B",RMPRHPO,"")) ;old HCPCS ien
150 S RMPRHPNI=$O(^RMPR(661.1,"B",RMPRHPN,"")) ;new HCPCS ien
151 Q:'$G(RMPRHPNI)!'$G(RMPRHPOI)
152 G:$D(^RMPR(661.2,"D",RMPRHPNI)) ITEMX ;quit if Items already on new HCPCS and PIP.
153 S RMPRIFLG=0
154 I $P($G(^RMPR(661.1,RMPRHPOI,0)),"^",9)'="" S RMPRIFLG=1
155 ;
156 ; Loop on items and copy to new HCPCS
157 S RML=0
158 ;S RMPRIEN="+1,"_RMPRHPNI_","
159 S (RMPRJ,RMPRN)=0
160 I $D(^RMPR(661.1,RMPRHPNI,3,0)) S RMPRN=$P(^RMPR(661.1,RMPRHPNI,3,0),U,3)
161 S RMPRIENA=RMPRN
162 F S RMPRJ=$O(^RMPR(661.1,RMPRHPOI,3,RMPRJ)) Q:'+RMPRJ D
163 . K RMPRFDA,RMPRFME,DIE
164 . I RMPRN=0 S RMPRIENA=RMPRJ
165 . I RMPRN>0 S RMPRIENA=RMPRIENA+1
166 . S RML=RML+1
167 . S RMPRIEN="+"_RML_","_RMPRHPNI_","
168 . S RMPRFDA(661.12,RMPRIEN,.01)=$P(^RMPR(661.1,RMPRHPOI,3,RMPRJ,0),"^",1)
169 . I $L(RMPRFDA(661.12,RMPRIEN,.01))>30 S RMPRFDA(661.12,RMPRIEN,.01)=$E(RMPRFDA(661.12,RMPRIEN,.01),1,30)
170 .;don't create an entry if it's already been created.
171 . Q:$D(^RMPR(661.1,RMPRHPNI,3,"B",RMPRFDA(661.12,RMPRIEN,.01)))
172 . S ^TMP($J,"RM",RMPRJ)=RMPRIENA
173 . D UPDATE^DIE("","RMPRFDA","RMPRIENA","RMPRFME")
174 . Q
175 ;
176 ; Update 661.3 file
177 S RMPRJ=""
178 F S RMPRJ=$O(^RMPR(661.3,"C",RMPRHPOI,RMPRJ)) Q:RMPRJ="" D
179 . S RMPRK=""
180 . F S RMPRK=$O(^RMPR(661.3,"C",RMPRHPOI,RMPRJ,RMPRK)) Q:RMPRK="" D
181 .. S RMPRL=0
182 .. F S RMPRL=$O(^RMPR(661.3,RMPRJ,1,RMPRK,1,RMPRL)) Q:'+RMPRL D
183 ... S RMPRS=^RMPR(661.3,RMPRJ,1,RMPRK,1,RMPRL,0)
184 ... S RMPRITEM=$P(RMPRS,"^",1)
185 ... S RMPRIO=$P(RMPRITEM,"-",2)
186 ... Q:'$D(^TMP($J,"RM",RMPRIO))
187 ... S RMPRIN=^TMP($J,"RM",RMPRIO)
188 ... Q:'$G(RMPRIN)
189 ... S $P(RMPRITEM,"-",1)=RMPRHPN
190 ... S $P(RMPRITEM,"-",2)=RMPRIN
191 ... S RMPRIEN=RMPRL_","_RMPRK_","_RMPRJ_","
192 ... K RMPRFDA,RMPRFME
193 ... S RMPRFDA(661.312,RMPRIEN,.01)=RMPRITEM
194 ... D FILE^DIE("","RMPRFDA","RMPRFME")
195 ... Q
196 .. S RMPRIEN=RMPRK_","_RMPRJ_","
197 .. K RMPRFDA,RMPRFME
198 .. S RMPRFDA(661.31,RMPRIEN,.01)=RMPRHPNI
199 .. D FILE^DIE("","RMPRFDA","RMPRFME")
200 .. S RMPRIFLG=1
201 .. Q
202 . Q
203 I RMPRIFLG D
204 . K RMPRFDA,RMPRFME
205 . S RMPRIEN=RMPRHPNI_","
206 . S RMPRFDA(661.1,RMPRIEN,10)=1
207 . D FILE^DIE("","RMPRFDA","RMPRFME")
208 . Q
209 ;
210 ; Update PIP files 661.2
211 S RMPRI=""
212 F S RMPRI=$O(^RMPR(661.2,"D",RMPRHPOI,RMPRI)) Q:RMPRI="" D
213 . Q:'$D(^RMPR(661.2,RMPRI,0))
214 . S RMHCIT=$P(^RMPR(661.2,RMPRI,0),U,9)
215 . K RMPRFDA,RMPRFME
216 . S RMPRIEN=RMPRI_","
217 . S RMPRFDA(661.2,RMPRIEN,3)=RMPRHPNI
218 . S RMPRFDA(661.2,RMPRIEN,9)=RMPRHPN_"-"_$P(RMHCIT,"-",2)
219 . D FILE^DIE("","RMPRFDA","RMPRFME")
220 . Q
221 ;
222ITEMX Q
223 ;
224 ; PATCH58 -
225 ; 1 - Repoint duplicate HCPCS
226 ; 2 - Copy item and current inventory to new HCPCS for specified list
227 ; (patch 58 only)
228PATCH58 N RMPRA,RMPRI
229 I '$D(IO("Q")) D
230 . W !!,"Repointing specified duplicate HCPCS...",!
231 . Q
232 D HCPCD(170,133) ;E0277
233 I '$D(IO("Q")) D
234 . W !!,"Repointing complete.",!
235 . Q
236 ;
237 ;for next update, change RMPRA() local array to the HCPCS that need
238 ;to be replaced.
239PAT76 ; Set up array and replace HCPCS
240 S U="^"
241 I '$D(IO("Q")) D
242 . W !!,"Replacing the following HCPCS...",!
243 . Q
244 ;patch #58 - replacement code
245 ;K RMPRA
246 ;S RMPRA(1)="K0182^A7018"
247 ;S RMPRA(2)="K0269^E0572"
248 S RMFLG61=""
249 I '$D(^RMPR(661.6)),'$D(^RMPR(661.7)),'$D(^RMPR(661.9)) S RMFLG61=1 D CONV35^RMPRPS36
250 ;F RMI=0:0 S RMI=$O(^RMPR(661.1,"RMPR",RMI)) Q:RMI'>0 D
251 ;.S RMHCDA=^RMPR(661.1,"RMPR",RMI)
252 ;.S RMHOLD=$P(RMHCDA,U,1),RMHNEW=$P(RMHCDA,U,2)
253 ;.I '$D(IO("Q")) D
254 ;..W !,RMHOLD," with ",RMHNEW
255 ;.D ITEM(RMHOLD,RMHNEW)
256 ;.Q
257 I '$D(IO("Q")) D
258 . W !!,"HCPCS replacement complete.",!
259 . Q
260 Q
261CFLG ;remove calculation flag.
262 W !!,"Removing the Calculation flag.....",!
263 F RMPRI=1:1:66 S RMPRY=$P($T(FLG+RMPRI),";",4) Q:RMPRY'>0 D
264 .S $P(^RMPR(661.1,RMPRY,0),U,8)=""
265 W !!,"Done Removing Calculation flag!!!",!
266 Q
267FLG ;REMOVE calculation flag of the ff HCPCS:
268 ;;E1038;3884
269 ;;E1050;264
270 ;;E1060;265
271 ;;E1070;269
272 ;;E1083;271
273 ;;E1084;270
274 ;;E1085;272
275 ;;E1086;273
276 ;;E1087;274
277 ;;E1088;275
278 ;;E1089;276
279 ;;E1090;277
280 ;;E1092;278
281 ;;E1093;279
282 ;;E1100;280
283 ;;E1110;281
284 ;;E1130;282
285 ;;E1140;283
286 ;;E1150;284
287 ;;E1160;285
288 ;;E1161;3885
289 ;;E1170;286
290 ;;E1171;287
291 ;;E1172;288
292 ;;E1180;289
293 ;;E1190;290
294 ;;E1195;291
295 ;;E1200;292
296 ;;E1210;293
297 ;;E1211;294
298 ;;E1212;295
299 ;;E1213;296
300 ;;E1220;297
301 ;;E1221;298
302 ;;E1222;299
303 ;;E1223;300
304 ;;E1224;301
305 ;;E1225;302
306 ;;E1226;303
307 ;;E1227;304
308 ;;E1228;305
309 ;;E1230;306
310 ;;E1240;307
311 ;;E1250;308
312 ;;E1260;309
313 ;;E1270;310
314 ;;E1280;311
315 ;;E1285;312
316 ;;E1290;313
317 ;;E1295;314
318 ;;E1296;315
319 ;;E1297;316
320 ;;E1298;317
321 ;;K0001;339
322 ;;K0002;340
323 ;;K0003;341
324 ;;K0004;342
325 ;;K0005;343
326 ;;K0006;344
327 ;;K0007;345
328 ;;K0009;347
329 ;;K0010;348
330 ;;K0011;349
331 ;;K0012;350
332 ;;K0014;352
333 ;;END
Note: See TracBrowser for help on using the repository browser.