source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBYPSC1.m@ 1259

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

initial load of WorldVistAEHR

File size: 6.2 KB
Line 
1IBYPSC1 ;ALB/ARH - IB*2.0*287 POST INIT: UPDATE REVENUE CODE CPT LINKS ; 12/01/04
2 ;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
3 ;
4 Q
5 ;
6 ;
7RVD ; delete all Revenue Code - CPT links (363.33)
8 N IBA,IBSGFN,IBRVLN,IBCNT,DA,DIK,DIC,X,Y S IBCNT=0
9 ;
10 S IBSGFN=$O(^IBE(363.32,"B","STANDARD RVCD LINKS",0)) I 'IBSGFN D MSG(" ** STANDARD RVCD LINKS Special Group not found, no links deleted.")
11 ;
12 S IBRVLN=0 F S IBRVLN=$O(^IBE(363.33,IBRVLN)) Q:'IBRVLN D
13 . I +$P($G(^IBE(363.33,IBRVLN,0)),U,2)'=IBSGFN Q
14 . S DA=IBRVLN,DIK="^IBE(363.33," D ^DIK K DA,DIK S IBCNT=IBCNT+1
15 ;
16RVDQ S IBA(1)=" >> "_IBCNT_" Old Revenue Code - CPT Links deleted (363.33)..." D MSG(" ")
17 D MES^XPDUTL(.IBA)
18 Q
19 ;
20RVL ; add Revenue Codes - CPT links (363.33)
21 N IBA,IBLN,IBI,IBSGFN,IBRV,IBRVFN,IBRVLN,IBCPT1,IBCPT2,IBCPT1N,IBCPT2N,IBCNT,DD,DO,DIC,DIE,DA,DR,X,Y,DLAYGO S IBCNT=0
22 ;
23 S IBSGFN=$O(^IBE(363.32,"B","STANDARD RVCD LINKS",0)) I 'IBSGFN D MSG(" ** STANDARD RVCD LINKS Special Group not found, no links added.")
24 ;
25 I +IBSGFN F IBI=1:1 S IBLN=$P($T(FRVL+IBI),";;",2,999) Q:IBLN="" D
26 . ;
27 . S IBRV=$P(IBLN,U,1) Q:IBRV'?3N
28 . ;
29 . S IBRVFN=$O(^DGCR(399.2,"B",IBRV,0)) Q:'IBRVFN
30 . S IBRVLN=$G(^DGCR(399.2,+IBRVFN,0)) Q:IBRVLN=""
31 . I $P(IBRVLN,U,2)["*RESERVED" Q
32 . ;
33 . Q:$P(IBLN,U,2)=""
34 . S IBCPT1=$P(IBLN,U,2),IBCPT1N=+$$CPT^ICPTCOD(IBCPT1,DT) I IBCPT1N<1 Q
35 . S IBCPT2=$P(IBLN,U,3),IBCPT2N="" I IBCPT2'="" S IBCPT2N=+$$CPT^ICPTCOD(IBCPT2,DT) I IBCPT2N<1 Q
36 . ;
37 . I $O(^IBE(363.33,"AGP",IBSGFN,+IBCPT1N,0)) D MSG(" ** "_IBLN_" not added, a link already exists for "_IBCPT1) Q
38 . ;
39 . S DIC("DR")=".02////"_+IBSGFN_";.03////"_+IBCPT1N I +IBCPT2N S DIC("DR")=DIC("DR")_";.04////"_+IBCPT2N
40 . K DD,DO S DLAYGO=363.33,DIC="^IBE(363.33,",DIC(0)="L",X=+IBRVFN D FILE^DICN K DIC,X,Y,DD,DO S IBCNT=IBCNT+1
41 ;
42RVLQ S IBA(1)=" >> "_IBCNT_" New Revenue Code - CPT Links added (363.33)..." D MSG(" ")
43 D MES^XPDUTL(.IBA)
44 Q
45 ;
46 ;
47MSG(X) ;
48 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
49 S IBA(IBX)=$G(X)
50 Q
51 ;
52FRVL ; revenue code - CPT links
53 ;;301^80048^80440
54 ;;301^82000^84999
55 ;;302^86000^86999
56 ;;302^87449^87450
57 ;;305^85002^85999
58 ;;306^87001^87430
59 ;;306^87451^87999
60 ;;307^81000^81099
61 ;;309^89050^89399
62 ;;310^80500^80502
63 ;;311^88104^88299
64 ;;312^88300^88399
65 ;;320^70010^70330
66 ;;320^70333^
67 ;;320^70350^70390
68 ;;320^71010^
69 ;;320^71036^71130
70 ;;320^72010^72120
71 ;;320^72170^72190
72 ;;320^72200^73110
73 ;;320^73116^73140
74 ;;320^73500^73520
75 ;;320^73526^73565
76 ;;320^73581^73660
77 ;;320^74000^74022
78 ;;320^74175^
79 ;;320^74182^74183
80 ;;320^74190^74775
81 ;;320^75801^75897
82 ;;320^75900^75985
83 ;;320^75990^76066
84 ;;320^76075^76088
85 ;;320^76095^76125
86 ;;320^76150^76350
87 ;;322^70332^
88 ;;322^73115^
89 ;;322^73525^
90 ;;322^73580^
91 ;;322^76499^
92 ;;323^75600^75790
93 ;;323^75898^
94 ;;324^71015^71035
95 ;;333^77280^77799
96 ;;341^78000^78999
97 ;;342^79000^79999
98 ;;351^70450^70492
99 ;;351^76380^
100 ;;352^71250^71270
101 ;;352^72125^72133
102 ;;352^72192^72194
103 ;;352^73200^73202
104 ;;352^73700^73702
105 ;;352^74150^74170
106 ;;359^75989^
107 ;;359^76070^
108 ;;359^76355^76375
109 ;;360^19020^
110 ;;360^19100^19103
111 ;;360^19290^19291
112 ;;360^20220^20225
113 ;;360^28200^
114 ;;360^31656^
115 ;;360^31710^
116 ;;360^32400^
117 ;;360^32405^
118 ;;360^33010^33011
119 ;;360^35450^
120 ;;360^35458^
121 ;;360^35460^35476
122 ;;360^35483^
123 ;;360^35490^
124 ;;360^35492^35495
125 ;;360^36010^36217
126 ;;360^36245^36247
127 ;;360^36260^36262
128 ;;360^36460^
129 ;;360^36481^
130 ;;360^37200^37202
131 ;;360^37205^37207
132 ;;360^41105^
133 ;;360^43760^
134 ;;360^47000^47001
135 ;;360^47510^
136 ;;360^47525^47530
137 ;;360^47555^47556
138 ;;360^48102^
139 ;;360^49180^49200
140 ;;360^50200^
141 ;;360^50390^50393
142 ;;360^50395^50398
143 ;;360^50684^
144 ;;360^50688^50690
145 ;;360^51600^51605
146 ;;360^51710^
147 ;;360^52007^52010
148 ;;360^52320^52355
149 ;;360^53605^
150 ;;360^53850^53852
151 ;;360^55300^
152 ;;360^59012^
153 ;;360^60100^
154 ;;360^61055^
155 ;;360^61624^61626
156 ;;360^62280^
157 ;;360^62282^62284
158 ;;360^66983^66986
159 ;;362^65767^
160 ;;370^00103^
161 ;;370^00140^00147
162 ;;370^00170^00176
163 ;;401^76090^76091
164 ;;402^76506^76999
165 ;;403^76092^
166 ;;404^G0125^G0126
167 ;;410^94640^94668
168 ;;413^99183^
169 ;;420^64550^
170 ;;420^90901^90911
171 ;;420^95831^
172 ;;420^95833^95851
173 ;;420^97001^97002
174 ;;420^97010^97016
175 ;;420^97020^97033
176 ;;420^97035^97521
177 ;;420^97531^97533
178 ;;420^97540^97752
179 ;;420^97780^97799
180 ;;430^29126^
181 ;;430^29131^
182 ;;430^29260^29280
183 ;;430^95832^
184 ;;430^95852^
185 ;;430^97003^97004
186 ;;430^97018^
187 ;;430^97034^
188 ;;430^97530^
189 ;;430^97535^97537
190 ;;440^92506^92510
191 ;;440^92525^92526
192 ;;440^92597^92598
193 ;;440^96105^
194 ;;440^V5362^V5364
195 ;;441^92502^92504
196 ;;441^92511^92520
197 ;;450^24670^
198 ;;450^25630^
199 ;;450^25650^
200 ;;450^27760^
201 ;;450^28400^
202 ;;460^94010^
203 ;;460^94060^94620
204 ;;460^94680^94750
205 ;;460^94770^94772
206 ;;470^92551^
207 ;;470^92559^92560
208 ;;470^92590^92595
209 ;;470^V5299^
210 ;;471^92552^92557
211 ;;471^92561^92589
212 ;;471^92596^
213 ;;480^92950^92960
214 ;;480^93303^93315
215 ;;480^93317^93501
216 ;;480^93505^93508
217 ;;480^93514^93524
218 ;;480^93536^
219 ;;480^93571^93642
220 ;;480^93660^
221 ;;480^93724^
222 ;;481^93511^
223 ;;481^93528^93529
224 ;;482^93017^
225 ;;510^99201^
226 ;;510^99211^
227 ;;610^70336^
228 ;;610^70540^70549
229 ;;610^71550^71555
230 ;;610^72195^72198
231 ;;610^73218^73225
232 ;;610^73718^73725
233 ;;610^74181^
234 ;;610^74185^
235 ;;610^75552^75556
236 ;;610^76093^76094
237 ;;610^76390^76400
238 ;;611^70551^70553
239 ;;612^72141^72159
240 ;;636^90732^90748
241 ;;636^A4641^
242 ;;730^93000^93012
243 ;;730^93024^
244 ;;730^93278^
245 ;;731^93225^93226
246 ;;731^93231^93232
247 ;;731^93236^
248 ;;731^93799^
249 ;;740^95816^95829
250 ;;740^95920^
251 ;;740^95933^
252 ;;750^43200^43204
253 ;;750^43215^43272
254 ;;750^43450^43460
255 ;;750^44360^44373
256 ;;750^44380^44394
257 ;;750^45305^45321
258 ;;750^45331^45334
259 ;;750^45355^45385
260 ;;750^56300^56305
261 ;;750^91000^
262 ;;750^91020^91030
263 ;;750^91052^91122
264 ;;761^11040^11044
265 ;;762^99217^99220
266 ;;771^G0008^G0010
267 ;;820^90999^
268 ;;900^90801^90802
269 ;;900^90862^
270 ;;900^90875^
271 ;;900^97770^
272 ;;901^90870^90871
273 ;;904^Q0082^
274 ;;914^90804^90814
275 ;;914^90816^90845
276 ;;915^90853^90857
277 ;;916^90846^90847
278 ;;916^90887^
279 ;;918^96100^
280 ;;918^96110^96117
281 ;;920^51795^
282 ;;920^54250^
283 ;;920^59020^59025
284 ;;920^92060^92065
285 ;;920^92135^
286 ;;920^92235^92250
287 ;;920^92265^92275
288 ;;920^93990^
289 ;;920^95900^
290 ;;920^95930^
291 ;;920^95934^
292 ;;921^54240^
293 ;;921^93721^
294 ;;921^93740^
295 ;;921^93770^
296 ;;921^93875^93971
297 ;;922^95858^
298 ;;922^95870^95875
299 ;;924^95004^
300 ;;924^95015^95071
301 ;;924^95078^95199
302 ;;943^93737^93738
303 ;;943^93797^93798
304 ;;
305 ;
306 Q
Note: See TracBrowser for help on using the repository browser.