source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPS36.m@ 868

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1RMPRPS36 ;HIN CIO/RVD - HCPCS Update Utilities ; 3/25/04 12:29pm
2 ;;3.0;PROSTHETICS;**76,77,84**,FEB 09,1996
3 Q
4 ;
5 ; RVD 2/12/03 patch #76 - replace a list of deactivated 2003 HCPCS
6 ; for sites with patch #61 installed.
7 ; RVD patch #77 - added list of old HCPCS in PIP for conversion.
8 ; - added HCPCS G0290, G0291, TM100, TM101, TM101,
9 ; TM102, TM103, TM104 and TM105.
10 ;
11 ; AAC 3/26/04 - Patch 84: Convert old HCPCS to new/replacement HCPCS in PIP.
12 ; Replace all CPT Codes with pointer 104840 - code A9900 begin with 1/1/04
13 ; Update all Modifier codes with null
14 ;
15 Q
16 ;
17F6111 ; Update PIP files 661.11
18 K RMI
19 F RMI=0:0 S RMI=$O(^RMPR(661.11,"B",RMHOLD,RMI)) Q:RMI'>0 D
20 .S RMIT=""
21 .Q:'$D(^RMPR(661.11,RMI,0))
22 .S RMIT=$P(^RMPR(661.11,RMI,0),U,2)
23 .K RMPRFDA,RMPRFME
24 .S RMPRIEN=RMI_","
25 .S RMPRFDA(661.11,RMPRIEN,.01)=RMHNEW
26 .S RMPRFDA(661.11,RMPRIEN,6)=RMHNEW_"-"_RMIT
27 .D FILE^DIE("","RMPRFDA","RMPRFME")
28 Q
29 ;
30F614 ; Update PIP files 661.4
31 K RMI
32 F RMI=0:0 S RMI=$O(^RMPR(661.4,"B",RMHOLD,RMI)) Q:RMI'>0 D
33 .Q:'$D(^RMPR(661.4,RMI,0))
34 .K RMPRFDA,RMPRFME
35 .S RMPRIEN=RMI_","
36 .S RMPRFDA(661.4,RMPRIEN,.01)=RMHNEW
37 .D FILE^DIE("","RMPRFDA","RMPRFME")
38 Q
39 ;
40F6141 ; Update PIP files 661.41
41 K RMI
42 F RMI=0:0 S RMI=$O(^RMPR(661.41,"B",RMHOLD,RMI)) Q:RMI'>0 D
43 .Q:'$D(^RMPR(661.41,RMI,0))
44 .K RMPRFDA,RMPRFME
45 .S RMPRIEN=RMI_","
46 .S RMPRFDA(661.41,RMPRIEN,5)=RMHNEW
47 .D FILE^DIE("","RMPRFDA","RMPRFME")
48 Q
49 ;
50F616 ; Update PIP files 661.6
51 K RMI
52 F RMI=0:0 S RMI=$O(^RMPR(661.6,"B",RMHOLD,RMI)) Q:RMI'>0 D
53 .Q:'$D(^RMPR(661.6,RMI,0))
54 .K RMPRFDA,RMPRFME
55 .S RMPRIEN=RMI_","
56 .S RMPRFDA(661.6,RMPRIEN,.01)=RMHNEW
57 .D FILE^DIE("","RMPRFDA","RMPRFME")
58 Q
59 ;
60F6163 ; Update PIP files 661.63
61 K RMI
62 F RMI=0:0 S RMI=$O(^RMPR(661.63,RMI)) Q:RMI'>0 D
63 .S RM63DAT=^RMPR(661.63,RMI,0)
64 .S RM63HCP=$P(RM63DAT,U,4)
65 .Q:RM63HCP'=RMHOLD
66 .K RMPRFDA,RMPRFME
67 .S RMPRIEN=RMI_","
68 .S RMPRFDA(661.63,RMPRIEN,4)=RMHNEW
69 .D FILE^DIE("","RMPRFDA","RMPRFME")
70 Q
71 ;
72F617 ; Update PIP files 661.7
73 K RMI
74 F RMI=0:0 S RMI=$O(^RMPR(661.7,"B",RMHOLD,RMI)) Q:RMI'>0 D
75 .Q:'$D(^RMPR(661.7,RMI,0))
76 .K RMPRFDA,RMPRFME
77 .S RMPRIEN=RMI_","
78 .S RMPRFDA(661.7,RMPRIEN,.01)=RMHNEW
79 .D FILE^DIE("","RMPRFDA","RMPRFME")
80 Q
81 ;
82F619 ; Update PIP files 661.9
83 K RMI
84 F RMI=0:0 S RMI=$O(^RMPR(661.9,RMI)) Q:RMI'>0 D
85 .S RM9DAT=^RMPR(661.9,RMI,0)
86 .S RM9HCP=$P(RM9DAT,U,2)
87 .Q:RM9HCP'=RMHOLD
88 .K RMPRFDA,RMPRFME
89 .S RMPRIEN=RMI_","
90 .S RMPRFDA(661.9,RMPRIEN,1)=RMHNEW
91 .D FILE^DIE("","RMPRFDA","RMPRFME")
92 Q
93 ;
94 ;for next update, change RMPRA() local array to the HCPCS that need
95 ;to be replaced.
96PAT76 ; Set up array and replace HCPCS
97 S U="^"
98 I '$D(IO("Q")) D
99 . W !!,"Replacing the following HCPCS...",!
100 . Q
101 ;list of replacement HCPCS.
102 ;K RMPRA
103 ;S RMPRA(1)="K0182^A7018"
104 ;S RMPRA(2)="K0269^E0572"
105 S I=""
106 ;patch #76 - replacement code
107 F RMIJ=0:0 S RMIJ=$O(^RMPR(661.1,"RMPR",RMIJ)) Q:RMIJ'>0 D
108 .S RMHDA=^RMPR(661.1,"RMPR",RMIJ)
109 .S RMHOLD=$P(RMHDA,"^",1),RMHNEW=$P(RMHDA,U,2)
110 .I '$D(IO("Q")) D
111 .. W !,RMHOLD," with ",RMHNEW
112 .;convert 661.11
113 .D F6111
114 .;convert 661.4
115 .D F614
116 .;convert 661.41
117 .D F6141
118 .;convert 661.6
119 .D F616
120 .;convert 661.7
121 .D F617
122 .;convert 661.9
123 .D F619
124 I '$D(IO("Q")) D
125 . W !!,"HCPCS replacement complete.",!
126 . Q
127 Q
128 ;
129PAT77 ;Convert old HCPCS and set consult service requestor in file 660.
130 ;this label is called by patch 77 post-init.
131 ;add new HCPCS to file #661.1
132 S U="^"
133 W !!,"Adding new PSAS HCPCS to file #661.1.....",!
134 S DIK="^RMPR(661.1,"
135 F RMI=1:1 S RMDAT=$P($T(ADDHCPC+RMI),";",3) Q:RMDAT="END" D
136 .S RIEN=$P(RMDAT,":",1)
137 .S RNOD=$P(RMDAT,":",2)
138 .S RDAT=$P(RMDAT,":",3)
139 .S RARR(RIEN)=""
140 .I RNOD=2 S ^RMPR(661.1,RIEN,RNOD,1,0)=RDAT
141 .E S ^RMPR(661.1,RIEN,RNOD)=RDAT
142 F RMI=0:0 S RMI=$O(RARR(RMI)) Q:RMI'>0 D
143 .S ^RMPR(661.1,RMI,2,0)="^661.18^1^1"
144 .S DA=RMI D IX1^DIK
145 S $P(^RMPR(661.1,0),U,3)=3915
146 S $P(^RMPR(661.1,0),U,4)=3035
147 W !!,"Done adding new PSAS HCPCS!!!",!
148 ; D CONV
149 ; D SCRS^RMPRPCE1
150 ; D CFLG^RMPRPS35
151 Q
152ADDHCPC ;list of HCPCS added in #77
153 ;;3906:0:G0290^STENT, DRUG ELUTING W/DEL SYS^^106939^1^^960 E
154 ;;3906:2:STENT, DRUG ELUTING WITH DELIVERY SYSTEM
155 ;;3906:4:GY,NU
156 ;;3907:0:G0291^STENT, DRUG ELUTING W/O DEL^^106940^1^^960 E
157 ;;3907:2:STENT, DRUG ELUTING WITH OUT DELIVERY SYSTEM
158 ;;3907:4:GY,NU
159 ;;3908:0:TM100^TELEMED HOME COMPUTER/EQUIPMT^^100201^1^R80 C^900 K
160 ;;3908:2:TELEMEDICINE HOME COMPUTER EQUIPMENT
161 ;;3908:4:NU,RP
162 ;;3910:0:TM102^TELEMED HOME EQUIPMENT^^100201^1^R80 C^900 K
163 ;;3910:2:TELEMEDICINE HOME EQUIPMENT
164 ;;3910:4:NU,RP
165 ;;3912:0:TM104^TELEMED AUDIO/VIDEO^^100201^1^R80 C^900 K
166 ;;3912:2:TELEMEDICINE VIDEOPHONE/AUDIO VIDEO
167 ;;3912:4:NU,RP
168 ;;3913:0:TM105^TELEMED WOUND CARE^^100201^1^R80 C^900 K
169 ;;3913:2:TELEMEDICINE WOUND CARE EQUIPMENT
170 ;;3913:4:NU,RP
171 ;;3914:0:TM101^TELEMED VIDEO MONITOR^^100201^1^R80 C^900 K
172 ;;3914:2:TELEMEDICINE VIDEO MONITOR
173 ;;3914:4:NU,RP
174 ;;3915:0:TM103^TELEMED MESSAGE/MONITORING^^100201^1^R80 C^900 K
175 ;;3915:2:TELEMEDICINE IN HOME MESSAGE MONITORING
176 ;;3915:4:NU,RP
177 ;;END
178CONV ;convert old HCPCS in PIP to new HCPCS
179 W !!,"Replacing old/INACTIVE HCPCS to new/ACTIVE HCPCS in PIP.....",!
180 S RMFLG61=""
181 I $D(^RMPR(661.6)),$D(^RMPR(661.7)),$D(^RMPR(661.9)) S RMFLG61=1
182CONV35 F RMPRII=1:1 S RMHCDA=$P($T(HLST+RMPRII),";",3) Q:RMHCDA="" D
183 .S RMHOLD=$P(RMHCDA,U,1),RMHNEW=$P(RMHCDA,U,2)
184 .Q:'$D(^RMPR(661.1,"B",RMHOLD))!'$D(^RMPR(661.1,"B",RMHNEW))
185 .S RMHNEWI=$O(^RMPR(661.1,"B",RMHNEW,0)) Q:'$G(RMHNEWI)
186 .;quit if the new HCPCS has been used in stock issue.
187 .S RMFLG=""
188 .F R6I=0:0 S R6I=$O(^RMPR(660,"H",RMHNEWI,R6I)) Q:R6I'>0!$G(RMFLG) D
189 ..I $D(^RMPR(660,R6I,0)),$P(^RMPR(660,R6I,0),U,13)=11 S RMFLG=1 Q
190 .Q:$G(RMFLG)
191 .I $G(RMFLG61) D
192 ..;convert 661.11
193 ..D F6111
194 ..;convert 661.4
195 ..D F614
196 ..;convert 661.41
197 ..D F6141
198 ..;convert 661.6
199 ..D F616
200 ..;convert 661.7
201 ..D F617
202 ..;convert 661.9
203 ..D F619
204 . E D ITEM^RMPRPS35(RMHOLD,RMHNEW)
205 I '$D(IO("Q")) W !!,"HCPCS replacement complete!!!",!
206 Q
207 ;
208HLST ;List of old^new HCPCS
209 ;;E0165^E0166
210 ;;E0943^DL191
211 ;;E0975^E0981
212 ;;E0979^E0978
213 ;;E0991^E0981
214 ;;E0993^E0982
215 ;;E1066^E2367
216 ;;E1069^E2366
217 ;;K0002^E1084
218 ;;K0003^E1240
219 ;;K0004^E1088
220 ;;K0006^E1290
221 ;;K0010^E1213
222 ;;K0016^E0973
223 ;;K0022^E0982
224 ;;K0025^E0966
225 ;;K0026^E0982
226 ;;K0027^E0982
227 ;;K0028^E1226
228 ;;K0029^E0981
229 ;;K0030^E0992
230 ;;K0031^E0978
231 ;;K0032^E0981
232 ;;K0033^E0981
233 ;;K0035^E0951
234 ;;K0036^E0952
235 ;;K0048^E0990
236 ;;K0049^E0995
237 ;;K0062^E0967
238 ;;K0063^E0967
239 ;;K0079^E0961
240 ;;K0080^E0974
241 ;;K0082^E2360
242 ;;K0083^E2361
243 ;;K0084^E2362
244 ;;K0085^E2363
245 ;;K0086^E2361
246 ;;K0087^E2365
247 ;;K0088^E2366
248 ;;K0089^E2367
249 ;;K0100^E0959
250 ;;K0103^E0972
251 ;;K0107^E0950
252 ;;K0112^E0980
253 ;;K0113^E0980
254 ;;K0268^E0561
255 ;;K0460^E0983
256 ;;K0461^E0984
257 ;;K0531^E0562
258 ;;K0538^E2402
259 ;;K0540^A6551
260 ;;K0541^E2500
261 ;;K0542^E2502
262 ;;K0543^E2508
263 ;;K0544^E2510
264 ;;K0545^E2511
265 ;;K0546^E2512
266 ;;K0547^E2599
267 ;;K0549^E0301
268 ;;K0550^E0302
269 ;;K0556^L5673
270 ;;K0557^L5679
271 ;;K0558^L5681
272 ;;K0559^L5683
273 ;;L1885^L1831
274 ;;L2102^L2106
275 ;;L2104^L2108
276 ;;L2122^L2126
277 ;;L2124^L2128
278 ;;S8180^A7523
279 ;;S8181^A7526
280 ;;V2116^V2199
281 ;;V2117^V2199
282 ;;V2216^V2299
283 ;;V2217^V2299
284 ;;V2316^V2399
285 ;;V2317^V2399
286 ;;VA123^E0470
Note: See TracBrowser for help on using the repository browser.