3. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 8/4/2017 8:56:44 AM Eastern Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

3.1 Files compared

#	Location	File	Last Modified
1	IB_2.0_577.zip	IB_2_577_TEST_V11.kid	Tue Aug 1 17:54:26 2017 UTC
2	IB_2.0_577.zip	IB_2_577_TEST_V11.kid	Thu Aug 3 19:37:11 2017 UTC

3.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	4	18138
Changed	3	6
Inserted	1	12
Removed	0	0

3.3 Comparison options

Whitespace
Character case	Differences in character case are significant
Line endings	Differences in line endings (`CR` and `LF` characters) are ignored
CR/LF characters	Not shown in the comparison detail

3.4 Active regular expressions

No regular expressions were active.

3.5 Comparison detail

1	IB2577 T EST v11
2	Extracted from mail message
3	KIDS:I B2.0577^
4
5	INSTALL NAME
6	IB2.0577
7	"BLD",1050 9,0)
8	IB2.0577 ^INTEGRATE D BILLING^ 0^3170627^ y
9	"BLD",1050 9,4,0)
10	^9.64PA^36 ^7
11	"BLD",1050 9,4,36,0)
12	36
13	"BLD",1050 9,4,36,2,0 )
14	^9.641^36. 017^1
15	"BLD",1050 9,4,36,2,3 6.017,0)
16	277EDI ID NUMBER (s ub-file)
17	"BLD",1050 9,4,36,2,3 6.017,1,0)
18	^9.6411^^
19	"BLD",1050 9,4,36,222 )
20	y^y^p^^^^n ^^n
21	"BLD",1050 9,4,36,224 )
22
23	"BLD",1050 9,4,350.8, 0)
24	350.8
25	"BLD",1050 9,4,350.8, 222)
26	n^n^f^^n^^ y^o^n
27	"BLD",1050 9,4,350.8, 224)
28	I $$INC350 8^IBY577PR (Y)
29	"BLD",1050 9,4,350.9, 0)
30	350.9
31	"BLD",1050 9,4,350.9, 2,0)
32	^9.641^350 .9004^1
33	"BLD",1050 9,4,350.9, 2,350.9004 ,0)
34	PAY-TO PRO VIDERS (s ub-file)
35	"BLD",1050 9,4,350.9, 2,350.9004 ,1,0)
36	^9.6411^1. 02^2
37	"BLD",1050 9,4,350.9, 2,350.9004 ,1,1.01,0)
38	STREET ADD RESS 1
39	"BLD",1050 9,4,350.9, 2,350.9004 ,1,1.02,0)
40	STREET ADD RESS 2
41	"BLD",1050 9,4,350.9, 222)
42	y^y^p^^^^n ^^n
43	"BLD",1050 9,4,350.9, 224)
44
45	"BLD",1050 9,4,355.93 ,0)
46	355.93
47	"BLD",1050 9,4,355.93 ,2,0)
48	^9.641^355 .93^1
49	"BLD",1050 9,4,355.93 ,2,355.93, 0)
50	IB NON/OTH ER VA BILL ING PROVID ER (File- top level)
51	"BLD",1050 9,4,355.93 ,2,355.93, 1,0)
52	^9.6411^.0 5^2
53	"BLD",1050 9,4,355.93 ,2,355.93, 1,.01,0)
54	NAME
55	"BLD",1050 9,4,355.93 ,2,355.93, 1,.05,0)
56	STREET ADD RESS
57	"BLD",1050 9,4,355.93 ,222)
58	y^y^p^^^^n ^^n
59	"BLD",1050 9,4,355.93 ,224)
60
61	"BLD",1050 9,4,364.6, 0)
62	364.6
63	"BLD",1050 9,4,364.6, 222)
64	n^n^f^^y^^ y^o^n
65	"BLD",1050 9,4,364.6, 223)
66
67	"BLD",1050 9,4,364.6, 224)
68	I $$INCLUD E^IBY577PR (6,Y)
69	"BLD",1050 9,4,364.7, 0)
70	364.7
71	"BLD",1050 9,4,364.7, 222)
72	n^n^f^^y^^ y^o^n
73	"BLD",1050 9,4,364.7, 223)
74
75	"BLD",1050 9,4,364.7, 224)
76	I $$INCLUD E^IBY577PR (7,Y)
77	"BLD",1050 9,4,399,0)
78	399
79	"BLD",1050 9,4,399,2, 0)
80	^9.641^399 .0304^2
81	"BLD",1050 9,4,399,2, 399,0)
82	BILL/CLAIM S (File-t op level)
83	"BLD",1050 9,4,399,2, 399,1,0)
84	^9.6411^27 8^13
85	"BLD",1050 9,4,399,2, 399,1,.21, 0)
86	CURRENT BI LL PAYER S EQUENCE
87	"BLD",1050 9,4,399,2, 399,1,163, 0)
88	TREATMENT AUTHORIZAT ION CODE
89	"BLD",1050 9,4,399,2, 399,1,202, 0)
90	OFFSET AMO UNT
91	"BLD",1050 9,4,399,2, 399,1,230, 0)
92	SECONDARY AUTHORIZAT ION CODE
93	"BLD",1050 9,4,399,2, 399,1,231, 0)
94	TERTIARY A UTHORIZATI ON CODE
95	"BLD",1050 9,4,399,2, 399,1,253, 0)
96	PRIMARY RE FERRAL NUM BER
97	"BLD",1050 9,4,399,2, 399,1,254, 0)
98	SECONDARY REFERRAL N UMBER
99	"BLD",1050 9,4,399,2, 399,1,255, 0)
100	TERTIARY R EFERRAL NU MBER
101	"BLD",1050 9,4,399,2, 399,1,261, 0)
102	PROPERTY/C ASUALTY CL AIM NUMBER
103	"BLD",1050 9,4,399,2, 399,1,271, 0)
104	AMBULANCE P/U ADDRES S 1
105	"BLD",1050 9,4,399,2, 399,1,272, 0)
106	AMBULANCE P/U ADDRES S 2
107	"BLD",1050 9,4,399,2, 399,1,277, 0)
108	AMBULANCE D/O ADDRES S 1
109	"BLD",1050 9,4,399,2, 399,1,278, 0)
110	AMBULANCE D/O ADDRES S 2
111	"BLD",1050 9,4,399,2, 399.0304,0 )
112	PROCEDURES (sub-fil e)
113	"BLD",1050 9,4,399,2, 399.0304,1 ,0)
114	^9.6411^53 ^3
115	"BLD",1050 9,4,399,2, 399.0304,1 ,52,0)
116	UNITS/BASI S OF MEASU REMENT
117	"BLD",1050 9,4,399,2, 399.0304,1 ,53,0)
118	NDC
119	"BLD",1050 9,4,399,2, 399.0304,1 ,54,0)
120	UNITS
121	"BLD",1050 9,4,399,22 2)
122	y^y^p^^^^n ^^n
123	"BLD",1050 9,4,399,22 4)
124
125	"BLD",1050 9,4,"APDD" ,36,36.017 )
126
127	"BLD",1050 9,4,"APDD" ,350.9,350 .9004)
128
129	"BLD",1050 9,4,"APDD" ,350.9,350 .9004,1.01 )
130
131	"BLD",1050 9,4,"APDD" ,350.9,350 .9004,1.02 )
132
133	"BLD",1050 9,4,"APDD" ,355.93,35 5.93)
134
135	"BLD",1050 9,4,"APDD" ,355.93,35 5.93,.01)
136
137	"BLD",1050 9,4,"APDD" ,355.93,35 5.93,.05)
138
139	"BLD",1050 9,4,"APDD" ,399,399)
140
141	"BLD",1050 9,4,"APDD" ,399,399,. 21)
142
143	"BLD",1050 9,4,"APDD" ,399,399,1 63)
144
145	"BLD",1050 9,4,"APDD" ,399,399,2 02)
146
147	"BLD",1050 9,4,"APDD" ,399,399,2 30)
148
149	"BLD",1050 9,4,"APDD" ,399,399,2 31)
150
151	"BLD",1050 9,4,"APDD" ,399,399,2 53)
152
153	"BLD",1050 9,4,"APDD" ,399,399,2 54)
154
155	"BLD",1050 9,4,"APDD" ,399,399,2 55)
156
157	"BLD",1050 9,4,"APDD" ,399,399,2 61)
158
159	"BLD",1050 9,4,"APDD" ,399,399,2 71)
160
161	"BLD",1050 9,4,"APDD" ,399,399,2 72)
162
163	"BLD",1050 9,4,"APDD" ,399,399,2 77)
164
165	"BLD",1050 9,4,"APDD" ,399,399,2 78)
166
167	"BLD",1050 9,4,"APDD" ,399,399.0 304)
168
169	"BLD",1050 9,4,"APDD" ,399,399.0 304,52)
170
171	"BLD",1050 9,4,"APDD" ,399,399.0 304,53)
172
173	"BLD",1050 9,4,"APDD" ,399,399.0 304,54)
174
175	"BLD",1050 9,4,"B",36 ,36)
176
177	"BLD",1050 9,4,"B",35 0.8,350.8)
178
179	"BLD",1050 9,4,"B",35 0.9,350.9)
180
181	"BLD",1050 9,4,"B",35 5.93,355.9 3)
182
183	"BLD",1050 9,4,"B",36 4.6,364.6)
184
185	"BLD",1050 9,4,"B",36 4.7,364.7)
186
187	"BLD",1050 9,4,"B",39 9,399)
188
189	"BLD",1050 9,6)
190	2^
191	"BLD",1050 9,6.3)
192	34
193	"BLD",1050 9,"ABPKG")
194	n
195	"BLD",1050 9,"INI")
196	IBY577PR
197	"BLD",1050 9,"INIT")
198	IBY577PO
199	"BLD",1050 9,"KRN",0)
200	^9.67PA^77 9.2^20
201	"BLD",1050 9,"KRN",.4 ,0)
202	.4
203	"BLD",1050 9,"KRN",.4 01,0)
204	.401
205	"BLD",1050 9,"KRN",.4 02,0)
206	.402
207	"BLD",1050 9,"KRN",.4 03,0)
208	.403
209	"BLD",1050 9,"KRN",.5 ,0)
210	.5
211	"BLD",1050 9,"KRN",.8 4,0)
212	.84
213	"BLD",1050 9,"KRN",3. 6,0)
214	3.6
215	"BLD",1050 9,"KRN",3. 8,0)
216	3.8
217	"BLD",1050 9,"KRN",9. 2,0)
218	9.2
219	"BLD",1050 9,"KRN",9. 8,0)
220	9.8
221	"BLD",1050 9,"KRN",9. 8,"NM",0)
222	^9.68A^13^ 13
223	"BLD",1050 9,"KRN",9. 8,"NM",1,0 )
224	IBCU7^^0^B 116407276
225	"BLD",1050 9,"KRN",9. 8,"NM",2,0 )
226	IBCBB1^^0^ B125744740
227	"BLD",1050 9,"KRN",9. 8,"NM",3,0 )
228	IBCBB11^^0 ^B11205232 7
229	"BLD",1050 9,"KRN",9. 8,"NM",4,0 )
230	IBCEF11^^0 ^B86419290
231	"BLD",1050 9,"KRN",9. 8,"NM",5,0 )
232	IBCF23A^^0 ^B39049121
233	"BLD",1050 9,"KRN",9. 8,"NM",6,0 )
234	IBCEF22^^0 ^B97383500
235	"BLD",1050 9,"KRN",9. 8,"NM",7,0 )
236	IBCF33^^0^ B35272389
237	"BLD",1050 9,"KRN",9. 8,"NM",8,0 )
238	IBCEF77^^0 ^B27726430
239	"BLD",1050 9,"KRN",9. 8,"NM",9,0 )
240	IBJPS3^^0^ B122000376
241	"BLD",1050 9,"KRN",9. 8,"NM",10, 0)
242	IBCSC9^^0^ B9127578
243	"BLD",1050 9,"KRN",9. 8,"NM",11, 0)
244	IBCSC8^^0^ B9982208
245	"BLD",1050 9,"KRN",9. 8,"NM",12, 0)
246	IBCEST^^0^ B96695131
247	"BLD",1050 9,"KRN",9. 8,"NM",13, 0)
248	IBCERP7^^0 ^B32855168
249	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCBB1", 2)
250
251	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCBB11" ,3)
252
253	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCEF11" ,4)
254
255	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCEF22" ,6)
256
257	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCEF77" ,8)
258
259	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCERP7" ,13)
260
261	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCEST", 12)
262
263	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCF23A" ,5)
264
265	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCF33", 7)
266
267	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCSC8", 11)
268
269	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCSC9", 10)
270
271	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBCU7",1 )
272
273	"BLD",1050 9,"KRN",9. 8,"NM","B" ,"IBJPS3", 9)
274
275	"BLD",1050 9,"KRN",19 ,0)
276	19
277	"BLD",1050 9,"KRN",19 ,"NM",0)
278	^9.68A^2^2
279	"BLD",1050 9,"KRN",19 ,"NM",1,0)
280	IB HCCH PA YER ID REP ORT^^0
281	"BLD",1050 9,"KRN",19 ,"NM",2,0)
282	IB SYSTEM DEFINITION MENU^^2
283	"BLD",1050 9,"KRN",19 ,"NM","B", "IB HCCH P AYER ID RE PORT",1)
284
285	"BLD",1050 9,"KRN",19 ,"NM","B", "IB SYSTEM DEFINITIO N MENU",2)
286
287	"BLD",1050 9,"KRN",19 .1,0)
288	19.1
289	"BLD",1050 9,"KRN",19 .1,"NM",0)
290	^9.68A^^
291	"BLD",1050 9,"KRN",10 1,0)
292	101
293	"BLD",1050 9,"KRN",10 1,"NM",0)
294	^9.68A^7^7
295	"BLD",1050 9,"KRN",10 1,"NM",1,0 )
296	IBJP IB PA Y-TO ASSOC IATIONS ME NU^^0
297	"BLD",1050 9,"KRN",10 1,"NM",2,0 )
298	IBJP IB PA Y-TO DIVIS ION ADD^^0
299	"BLD",1050 9,"KRN",10 1,"NM",3,0 )
300	IBJP IB PA Y-TO PROVI DER ADD^^0
301	"BLD",1050 9,"KRN",10 1,"NM",4,0 )
302	IBJP IB PA Y-TO PROVI DER DEL^^0
303	"BLD",1050 9,"KRN",10 1,"NM",5,0 )
304	IBJP IB PA Y-TO PROVI DER DIVISI ONS^^0
305	"BLD",1050 9,"KRN",10 1,"NM",6,0 )
306	IBJP IB PA Y-TO PROVI DER EDIT^^ 0
307	"BLD",1050 9,"KRN",10 1,"NM",7,0 )
308	IBJP IB PA Y-TO PROVI DERS MENU^ ^0
309	"BLD",1050 9,"KRN",10 1,"NM","B" ,"IBJP IB PAY-TO ASS OCIATIONS MENU",1)
310
311	"BLD",1050 9,"KRN",10 1,"NM","B" ,"IBJP IB PAY-TO DIV ISION ADD" ,2)
312
313	"BLD",1050 9,"KRN",10 1,"NM","B" ,"IBJP IB PAY-TO PRO VIDER ADD" ,3)
314
315	"BLD",1050 9,"KRN",10 1,"NM","B" ,"IBJP IB PAY-TO PRO VIDER DEL" ,4)
316
317	"BLD",1050 9,"KRN",10 1,"NM","B" ,"IBJP IB PAY-TO PRO VIDER DIVI SIONS",5)
318
319	"BLD",1050 9,"KRN",10 1,"NM","B" ,"IBJP IB PAY-TO PRO VIDER EDIT ",6)
320
321	"BLD",1050 9,"KRN",10 1,"NM","B" ,"IBJP IB PAY-TO PRO VIDERS MEN U",7)
322
323	"BLD",1050 9,"KRN",40 9.61,0)
324	409.61
325	"BLD",1050 9,"KRN",77 1,0)
326	771
327	"BLD",1050 9,"KRN",77 9.2,0)
328	779.2
329	"BLD",1050 9,"KRN",87 0,0)
330	870
331	"BLD",1050 9,"KRN",89 89.51,0)
332	8989.51
333	"BLD",1050 9,"KRN",89 89.52,0)
334	8989.52
335	"BLD",1050 9,"KRN",89 94,0)
336	8994
337	"BLD",1050 9,"KRN","B ",.4,.4)
338
339	"BLD",1050 9,"KRN","B ",.401,.40 1)
340
341	"BLD",1050 9,"KRN","B ",.402,.40 2)
342
343	"BLD",1050 9,"KRN","B ",.403,.40 3)
344
345	"BLD",1050 9,"KRN","B ",.5,.5)
346
347	"BLD",1050 9,"KRN","B ",.84,.84)
348
349	"BLD",1050 9,"KRN","B ",3.6,3.6)
350
351	"BLD",1050 9,"KRN","B ",3.8,3.8)
352
353	"BLD",1050 9,"KRN","B ",9.2,9.2)
354
355	"BLD",1050 9,"KRN","B ",9.8,9.8)
356
357	"BLD",1050 9,"KRN","B ",19,19)
358
359	"BLD",1050 9,"KRN","B ",19.1,19. 1)
360
361	"BLD",1050 9,"KRN","B ",101,101)
362
363	"BLD",1050 9,"KRN","B ",409.61,4 09.61)
364
365	"BLD",1050 9,"KRN","B ",771,771)
366
367	"BLD",1050 9,"KRN","B ",779.2,77 9.2)
368
369	"BLD",1050 9,"KRN","B ",870,870)
370
371	"BLD",1050 9,"KRN","B ",8989.51, 8989.51)
372
373	"BLD",1050 9,"KRN","B ",8989.52, 8989.52)
374
375	"BLD",1050 9,"KRN","B ",8994,899 4)
376
377	"BLD",1050 9,"QDEF")
378	^^^^NO^^^^ NO^^NO
379	"BLD",1050 9,"QUES",0 )
380	^9.62^^
381	"BLD",1050 9,"REQB",0 )
382	^9.611^6^6
383	"BLD",1050 9,"REQB",1 ,0)
384	IB2.0522 ^1
385	"BLD",1050 9,"REQB",2 ,0)
386	IB2.0547 ^1
387	"BLD",1050 9,"REQB",3 ,0)
388	IB2.0550 ^1
389	"BLD",1050 9,"REQB",4 ,0)
390	IB2.0554 ^1
391	"BLD",1050 9,"REQB",5 ,0)
392	IB2.0407 ^1
393	"BLD",1050 9,"REQB",6 ,0)
394	IB2.0576 ^1
395	"BLD",1050 9,"REQB"," B","IB2.0 407",5)
396
397	"BLD",1050 9,"REQB"," B","IB2.0 522",1)
398
399	"BLD",1050 9,"REQB"," B","IB2.0 547",2)
400
401	"BLD",1050 9,"REQB"," B","IB2.0 550",3)
402
403	"BLD",1050 9,"REQB"," B","IB2.0 554",4)
404
405	"BLD",1050 9,"REQB"," B","IB2.0 576",6)
406
407	"DATA",350 .8,283,0)
408	IB360^Unit s & Units/ Basis of M easurement are Requi red if NDC exists.^I B360^1^3
409	"DATA",350 .8,295,0)
410	INCORRECT NON-VA RAT E^Non-VA r ate type u sed for bi ll that is not Non-V A^IB360^1^ 1
411	"DATA",364 .6,170,0)
412	8^N^^55^1^ ^0^2^60^La b/Facility Name^^1
413	"DATA",364 .6,171,0)
414	8^N^^55^1^ ^0^3^55^La b/Facility Address 1 ^^1
415	"DATA",364 .6,956,0)
416	8^N^^107^1 ^^0^9^50^O ther Payer Prior Aut h/Referral #^^1
417	"DATA",364 .6,957,0)
418	8^N^^36^1^ ^0^4^50^Pr ior Author ization #^ ^1
419	"DATA",364 .6,970,0)
420	8^N^^57^1^ ^0^13^10^C LIA #^0^1
421	"DATA",364 .6,1930,0)
422	8^N^^16^1^ ^0^7^55^Pa y-To Provi der Addres s 1^^1
423	"DATA",364 .6,1931,0)
424	8^N^^16^1^ ^0^8^55^Pa y-To Provi der Addres s 2^^1
425	"DATA",364 .6,1940,0)
426	8^N^^104.8 ^1^^0^3^55 ^Ambulance Address 1 ^0^1^0
427	"DATA",364 .6,1941,0)
428	8^N^^104.8 ^1^^0^4^55 ^Ambulance Address 2 ^0^1^0
429	"DATA",364 .6,1968,0)
430	8^N^^36^1^ ^0^9^50^Re ferral Num ber^^1
431	"DATA",364 .6,1975,0)
432	8^N^^45^1^ ^0^6^50^Pr op/Cas Cla im Number^ ^1
433	"DATA",364 .6,2025,0)
434	8^N^^112^1 ^^^12^50^O ther Payer Referral Number^0
435	"DATA",364 .6,2371,0)
436	8^N^^55^1^ ^0^8^1^BLA NK^^1
437	"DATA",364 .7,804,0)
438	808^N^5^^^ ^N
439	"DATA",364 .7,804,1)
440	N Z,IBZ K IBXDATA S (Z,IBZ)=0 F S IBZ=$ O(IBXSAVE( "CCOB",IBZ )) Q:'IBZ I IBZ<$$C OBN^IBCEF( IBXIEN) S Z=Z+1,IBXD ATA(Z)=$E( "PST",IBZ) I Z>1 D I D^IBCEF2(Z ,"COB1")
441	"DATA",364 .7,804,3,0 )
442	^364.73^5^ 5^3170417^ ^^^
443	"DATA",364 .7,804,3,1 ,0)
444	This is a group data element s o more tha n 1 occurr ence of a value is
445	"DATA",364 .7,804,3,2 ,0)
446	possible f or the dat a element in the IBX DATA array . It reli es on the
447	"DATA",364 .7,804,3,3 ,0)
448	existence of the IBX SAVE("CCOB ",COBSEQ) array that was previ ously extr acted.
449	"DATA",364 .7,804,3,4 ,0)
450	For other than the f irst occur rence, the RECORD ID 'COB1' mu st be outp ut.
451	"DATA",364 .7,804,3,5 ,0)
452	Only outpu t 1 record per COB s equence.
453	"DATA",364 .7,939,0)
454	977^N^5^^^ ^N
455	"DATA",364 .7,939,1)
456	K IBXDATA N Z S Z=0 F S Z=$O( IBXSAVE("O UTPT",Z)) Q:'Z I $P (IBXSAVE(" OUTPT",Z), U,16)'="" S IBXDATA( Z)=+$TR($J ($P(IBXSAV E("OUTPT", Z),U,16),1 1,3)," .")
457	"DATA",364 .7,939,3,0 )
458	^364.73^1^ 1^3170508^ ^^^
459	"DATA",364 .7,939,3,1 ,0)
460	This eleme nt is blan k.
461	"DATA",364 .7,941,0)
462	979^N^5^^^ ^N
463	"DATA",364 .7,941,1)
464	K IBXDATA N Z S Z=0 F S Z=$O( IBXSAVE("O UTPT",Z)) Q:'Z I $P (IBXSAVE(" OUTPT",Z), U,16)'="" S IBXDATA( Z)=$P(IBXS AVE("OUTPT ",Z),U,17) I IBXDATA (Z)="" S I BXDATA(Z)= "UN"
465	"DATA",364 .7,941,3,0 )
466	^364.73^1^ 1^3170413^ ^^^
467	"DATA",364 .7,941,3,1 ,0)
468	This eleme nt is blan k.
469	"DATA",364 .7,1015,0)
470	1014^N^5^^ ^^N
471	"DATA",364 .7,1015,1)
472	S IBXDATA= "577.0" I '$$PROD^XU PROD(1) S $E(IBXDATA ,11)="D"
473	"DATA",364 .7,1015,3, 0)
474	^364.73^7^ 7^3170417^ ^^^
475	"DATA",364 .7,1015,3, 1,0)
476	This field contains the VistA IB patch# that perta ins to the
477	"DATA",364 .7,1015,3, 2,0)
478	applicable changes i n the clai m map. Au stin uses this field to determ ine
479	"DATA",364 .7,1015,3, 3,0)
480	which set of EDI cla im maps to use when processing the EDI c laims.
481	"DATA",364 .7,1015,3, 4,0)
482
483	"DATA",364 .7,1015,3, 5,0)
484	If the EDI claims ar e being tr ansmitted from a non -productio n account,
485	"DATA",364 .7,1015,3, 6,0)
486	then the " D" in the 11th posit ion indica tes to Aus tin that i t is test
487	"DATA",364 .7,1015,3, 7,0)
488	data.
489	"DATA",364 .7,1406,0)
490	1706^N^5^^ ^^N
491	"DATA",364 .7,1406,1)
492	N Z,A,B,C F Z=1:1 Q: '$D(^TMP($ J,"IBC-RC" ,Z)) S B= ^(Z),C=$$B 43^IBCEF77 (B),A=$S(+ B=1:$S(C]" ":C,1:$E($ P(B,U,3),1 ,24)),+B=2 :$S(C]"":C ,1:$E($P(B ,U,2),6,30 )),1:$S(C] "":C,1:$E( $P(B,U,2), 1,25))) S: Z'>22 IBXD ATA(Z)=A D :Z>22 CKRE V^IBCEF3(Z ,A)
493	"DATA",364 .7,1406,3, 0)
494	^364.73^12 ^12^317050 4^^^
495	"DATA",364 .7,1406,3, 1,0)
496	This data element is a group d ata elemen t where mo re than on e occurren ce
497	"DATA",364 .7,1406,3, 2,0)
498	might be e xpected. It relies on the pre sence of d ata in arr ay
499	"DATA",364 .7,1406,3, 3,0)
500	IBXSAVE("R EV",n) ext racted pre viously. The first '^' piece of the arr ay
501	"DATA",364 .7,1406,3, 4,0)
502	indicates whether th is is a 'n ormal' ser vice data line (=1) or a text line
503	"DATA",364 .7,1406,3, 5,0)
504	(=2 or =3) . For a n ormal serv ice line, the data i s found in the third '^'
505	"DATA",364 .7,1406,3, 6,0)
506	piece of t he array. For text line where the first piece = 2 , the text is
507	"DATA",364 .7,1406,3, 7,0)
508	assumed TO start in column 1, so the dat a is extra cted from positions
509	"DATA",364 .7,1406,3, 8,0)
510	6-30. For text line where the first piec e = 3, the text is a ssumed to
511	"DATA",364 .7,1406,3, 9,0)
512	start in c olumn 6, s o the data for this field is e xtracted f rom positi ons
513	"DATA",364 .7,1406,3, 10,0)
514	1-25. Sinc e only 22 lines of s ervice lin e can appe ar on one form, if t here
515	"DATA",364 .7,1406,3, 11,0)
516	are more t han 22 lin es, subseq uent pages are force d for the remaining data
517	"DATA",364 .7,1406,3, 12,0)
518	lines afte r 22.
519	"DATA",364 .7,1537,0)
520	1837^N^5^^ ^^N
521	"DATA",364 .7,1537,1)
522	N Z K IBXD ATA F Z=1, 2 S IBXDAT A(Z)=$P($G (IBXSAVE(" OI_PSIDS", Z)),U,3)
523	"DATA",364 .7,1538,0)
524	1838^N^5^^ ^^N
525	"DATA",364 .7,1538,1)
526	N Z K IBXD ATA F Z=1, 2 S IBXDAT A(Z)=$P($G (IBXSAVE(" OI_PSIDS", Z)),U,4)
527	"DATA",364 .7,1551,0)
528	1851^N^5^^ ^^N
529	"DATA",364 .7,1551,1)
530	D CLEANUP^ IBCEF78(.I BXSAVE)
531	"DATA",364 .7,1927,0)
532	2227^N^56^ ^^^N
533	"DATA",364 .7,1927,1)
534	N Z,Z1,IBZ M IBZ=IBX DATA K IBX DATA Q:$$C OBN^IBCEF( IBXIEN)=1 F Z=1,2 Q :Z=2&($$CO BN^IBCEF(I BXIEN)=2) I $D(^DGC R(399,IBXI EN,"I"_(Z+ 1))),$G(IB Z(Z))'="" S IBXDATA( Z)=IBZ(Z)
535	"DATA",364 .7,1927,3, 0)
536	^364.73^10 ^10^317041 7^^^^
537	"DATA",364 .7,1927,3, 1,0)
538	This is a group data element s o more tha n 1 occurr ence of a value is
539	"DATA",364 .7,1927,3, 2,0)
540	possible f or the dat a element in the IBX DATA array . If any o ther insur ance
541	"DATA",364 .7,1927,3, 3,0)
542	form locat or 64 data is found, the data is output.
543	"DATA",364 .7,1927,3, 4,0)
544
545	"DATA",364 .7,1927,3, 5,0)
546	This is O I1A-03 als o known as the ICN/D CN for the MRA secon dary claim s.
547	"DATA",364 .7,1927,3, 6,0)
548	If there i s data her e in OI1A- 03, then w e cannot t ransmit th e Other Pa yer
549	"DATA",364 .7,1927,3, 7,0)
550	secondary ID and qua lifier #2. This is in the OI6 segment, pieces 7 a nd
551	"DATA",364 .7,1927,3, 8,0)
552	8. For thi s calculat ion, OI6-6 .9 is set- up very si milar to t his OI1A-0 3
553	"DATA",364 .7,1927,3, 9,0)
554	piece to s ee if ther e is an IC N/DCN pres ent. So any change s here sho uld
555	"DATA",364 .7,1927,3, 10,0)
556	also be ma de to OI6- 6.9 as a c alculate o nly field.
557	"DATA",364 .7,1949,0)
558	2236^N^5^^ ^^N^0
559	"DATA",364 .7,1949,1)
560	K IBXDATA N Z S Z=0 F S Z=$O( IBXSAVE("I NPT",Z)) Q :'Z I $P( IBXSAVE("I NPT",Z),U, 12)'="" S IBXDATA(Z) =+$TR($J($ P(IBXSAVE( "INPT",Z), U,12),11,3 )," .")
561	"DATA",364 .7,1949,3, 0)
562	^364.73^2^ 2^3170508^ ^^
563	"DATA",364 .7,1949,3, 1,0)
564	If the use r added an NDC to th is line of the claim , they are then allo wed
565	"DATA",364 .7,1949,3, 2,0)
566	to enter a unit. MRD ;IB2.051 6
567	"DATA",364 .7,1950,0)
568	2237^N^5^^ ^^N^0
569	"DATA",364 .7,1950,1)
570	K IBXDATA N Z S Z=0 F S Z=$O( IBXSAVE("I NPT",Z)) Q :'Z I $P( IBXSAVE("I NPT",Z),U, 12)'="" S IBXDATA(Z) =$P(IBXSAV E("INPT",Z ),U,13) I IBXDATA(Z) ="" S IBXD ATA(Z)="UN "
571	"DATA",364 .7,1950,3, 0)
572	^364.73^3^ 3^3170413^ ^^
573	"DATA",364 .7,1950,3, 1,0)
574	If the use r added an NDC to th is line of the claim , there sh ould also be
575	"DATA",364 .7,1950,3, 2,0)
576	a value in the unit field ($P( IBXSAVE("I NPT",Z),U, 12), and i f there is ,
577	"DATA",364 .7,1950,3, 3,0)
578	then this field shou ld be 'UN' . MRD;IB2 .0516
579	"DATA",364 .7,1955,0)
580	2257^N^101 ^^^^N
581	"DATA",364 .7,1955,1)
582	N IBZ,IBW, Z,Z0 D F^I BCEF("N-AL L AUTH COD ES","IBW") M IBZ=IBX DATA K IBX DATA I $O( IBXSAVE(1, 0)) S (Z,Z 0)=0 F S Z=$O(IBXSA VE(1,Z)),Z 0=Z0+1 Q:' Z I Z<($F ("PST",IBX SAVE(1))-1 )!($G(IBW( Z))]"") S IBXDATA(Z0 )=IBXSAVE( 1,Z) I Z0> 1 D ID^IBC EF2(Z0,"OI 1A")
583	"DATA",364 .7,1955,3, 0)
584	^364.73^8^ 8^3170417^ ^^^
585	"DATA",364 .7,1955,3, 1,0)
586	This is a group data element s o more tha n 1 occurr ence of a value is
587	"DATA",364 .7,1955,3, 2,0)
588	possible f or the dat a element in the IBX DATA array . The IBX SAVE(1)
589	"DATA",364 .7,1955,3, 3,0)
590	variable h olds the i ndicator o f which in surance
591	"DATA",364 .7,1955,3, 4,0)
592	[(P)rimary /(S)econda ry/(T)erti ary] is cu rrently re sponsible for the
593	"DATA",364 .7,1955,3, 5,0)
594	bill. U sing this data as a guide, the next insu rance for the primar y is
595	"DATA",364 .7,1955,3, 6,0)
596	secondary, then tert iary. For secondary , it's pri mary then tertiary, and
597	"DATA",364 .7,1955,3, 7,0)
598	for tertia ry, it's p rimary, th en seconda ry. For ot her than t he first
599	"DATA",364 .7,1955,3, 8,0)
600	occurrence , the RECO RD ID 'OI1 A' must be output.
601	"DATA",364 .7,1956,0)
602	2371^N^5^^ ^^N
603	"DATA",364 .7,1956,1)
604	S IBXDATA= ""
605	"DATA",364 .7,1956,3, 0)
606	^364.73^2^ 2^3170510^ ^
607	"DATA",364 .7,1956,3, 1,0)
608	JRA IB2.0 577 Creat ed to repl ace SUB (S eq 55), fi eld 8 (CLI A #) which was
609	"DATA",364 .7,1956,3, 2,0)
610	moved to S UB2 (Seq 5 7), field 13.
611	"FIA",36)
612	INSURANCE COMPANY
613	"FIA",36,0 )
614	^DIC(36,
615	"FIA",36,0 ,0)
616	36I
617	"FIA",36,0 ,1)
618	y^y^p^^^^n ^^n
619	"FIA",36,0 ,10)
620
621	"FIA",36,0 ,11)
622
623	"FIA",36,0 ,"RLRO")
624
625	"FIA",36,0 ,"VR")
626	2.0^IB
627	"FIA",36,3 6)
628	1
629	"FIA",36,3 6,17)
630
631	"FIA",36,3 6.017)
632	0
633	"FIA",350. 8)
634	IB ERROR
635	"FIA",350. 8,0)
636	^IBE(350.8 ,
637	"FIA",350. 8,0,0)
638	350.8I
639	"FIA",350. 8,0,1)
640	n^n^f^^n^^ y^o^n
641	"FIA",350. 8,0,10)
642
643	"FIA",350. 8,0,11)
644	I $$INC350 8^IBY577PR (Y)
645	"FIA",350. 8,0,"RLRO" )
646
647	"FIA",350. 8,0,"VR")
648	2.0^IB
649	"FIA",350. 8,350.8)
650	0
651	"FIA",350. 9)
652	IB SITE PA RAMETERS
653	"FIA",350. 9,0)
654	^IBE(350.9 ,
655	"FIA",350. 9,0,0)
656	350.9I
657	"FIA",350. 9,0,1)
658	y^y^p^^^^n ^^n
659	"FIA",350. 9,0,10)
660
661	"FIA",350. 9,0,11)
662
663	"FIA",350. 9,0,"RLRO" )
664
665	"FIA",350. 9,0,"VR")
666	2.0^IB
667	"FIA",350. 9,350.9)
668	1
669	"FIA",350. 9,350.9004 )
670	1
671	"FIA",350. 9,350.9004 ,1.01)
672
673	"FIA",350. 9,350.9004 ,1.02)
674
675	"FIA",355. 93)
676	IB NON/OTH ER VA BILL ING PROVID ER
677	"FIA",355. 93,0)
678	^IBA(355.9 3,
679	"FIA",355. 93,0,0)
680	355.93I
681	"FIA",355. 93,0,1)
682	y^y^p^^^^n ^^n
683	"FIA",355. 93,0,10)
684
685	"FIA",355. 93,0,11)
686
687	"FIA",355. 93,0,"RLRO ")
688
689	"FIA",355. 93,0,"VR")
690	2.0^IB
691	"FIA",355. 93,355.93)
692	1
693	"FIA",355. 93,355.93, .01)
694
695	"FIA",355. 93,355.93, .05)
696
697	"FIA",364. 6)
698	IB FORM SK ELETON DEF INITION
699	"FIA",364. 6,0)
700	^IBA(364.6 ,
701	"FIA",364. 6,0,0)
702	364.6IP
703	"FIA",364. 6,0,1)
704	n^n^f^^y^^ y^o^n
705	"FIA",364. 6,0,10)
706
707	"FIA",364. 6,0,11)
708	I $$INCLUD E^IBY577PR (6,Y)
709	"FIA",364. 6,0,"RLRO" )
710
711	"FIA",364. 6,0,"VR")
712	2.0^IB
713	"FIA",364. 6,364.6)
714	0
715	"FIA",364. 7)
716	IB FORM FI ELD CONTEN T
717	"FIA",364. 7,0)
718	^IBA(364.7 ,
719	"FIA",364. 7,0,0)
720	364.7IP
721	"FIA",364. 7,0,1)
722	n^n^f^^y^^ y^o^n
723	"FIA",364. 7,0,10)
724
725	"FIA",364. 7,0,11)
726	I $$INCLUD E^IBY577PR (7,Y)
727	"FIA",364. 7,0,"RLRO" )
728
729	"FIA",364. 7,0,"VR")
730	2.0^IB
731	"FIA",364. 7,364.7)
732	0
733	"FIA",364. 7,364.73)
734	0
735	"FIA",399)
736	BILL/CLAIM S
737	"FIA",399, 0)
738	^DGCR(399,
739	"FIA",399, 0,0)
740	399I
741	"FIA",399, 0,1)
742	y^y^p^^^^n ^^n
743	"FIA",399, 0,10)
744
745	"FIA",399, 0,11)
746
747	"FIA",399, 0,"RLRO")
748
749	"FIA",399, 0,"VR")
750	2.0^IB
751	"FIA",399, 399)
752	1
753	"FIA",399, 399,.21)
754
755	"FIA",399, 399,163)
756
757	"FIA",399, 399,202)
758
759	"FIA",399, 399,230)
760
761	"FIA",399, 399,231)
762
763	"FIA",399, 399,253)
764
765	"FIA",399, 399,254)
766
767	"FIA",399, 399,255)
768
769	"FIA",399, 399,261)
770
771	"FIA",399, 399,271)
772
773	"FIA",399, 399,272)
774
775	"FIA",399, 399,277)
776
777	"FIA",399, 399,278)
778
779	"FIA",399, 399.0304)
780	1
781	"FIA",399, 399.0304,5 2)
782
783	"FIA",399, 399.0304,5 3)
784
785	"FIA",399, 399.0304,5 4)
786
787	"INI")
788	IBY577PR
789	"INIT")
790	IBY577PO
791	"IX",36,36 ,"AEDIX",0 )
792	36^AEDIX^2 77STAT TRA NSACTION P AYER STORA GE US129^M U^^R^IR^W^ 36.017^^^^ ^S
793	"IX",36,36 ,"AEDIX",. 1,0)
794	^^2^2^3170 508^
795	"IX",36,36 ,"AEDIX",. 1,1,0)
796	This cross reference allows fo r reportin g of 277ST AT updates to the ED I
797	"IX",36,36 ,"AEDIX",. 1,2,0)
798	number to determine the correc t Payer ID .
799	"IX",36,36 ,"AEDIX",1 )
800	S ^DIC(36, "AEDIX",X( 1),DA(1),X (2),X(3))= X(4)
801	"IX",36,36 ,"AEDIX",1 .4)
802	S X=(X(1)] ""&(X(2)]" ")&(X(3)]" "))
803	"IX",36,36 ,"AEDIX",2 )
804	Q
805	"IX",36,36 ,"AEDIX",1 1.1,0)
806	^.114IA^4^ 4
807	"IX",36,36 ,"AEDIX",1 1.1,1,0)
808	1^F^36.017 ^.02^10^^F
809	"IX",36,36 ,"AEDIX",1 1.1,2,0)
810	2^F^36.017 ^.01^30^^F
811	"IX",36,36 ,"AEDIX",1 1.1,3,0)
812	3^F^36.017 ^.03^1^^F
813	"IX",36,36 ,"AEDIX",1 1.1,4,0)
814	4^F^36.017 ^.04^30^^F
815	"IX",364.6 ,364.6,"AL L",0)
816	364.6^ALL^ Allows for identific ation of l ocal overr ide fields that appl y to ALL^M U^^F^IR^I^ 364.6^^^^^ S
817	"IX",364.6 ,364.6,"AL L",1)
818	S ^IBA(364 .7,"ALL",D A,X2(5))=" "
819	"IX",364.6 ,364.6,"AL L",1.4)
820	I X2(4)'=" L"!'X2(5)! (X2(2)'="" )!(X2(3)'= "")!'X2(1) S X=0
821	"IX",364.6 ,364.6,"AL L",2)
822	K ^IBA(364 .7,"ALL",D A,X1(5))
823	"IX",364.6 ,364.6,"AL L",2.4)
824	I X1(4)'=" L"!'X1(5)! (X1(2)'="" )!(X1(3)'= "")!'X1(1) S X=0
825	"IX",364.6 ,364.6,"AL L",2.5)
826	K ^IBA(364 .7,"ALL")
827	"IX",364.6 ,364.6,"AL L",11.1,0)
828	^.114IA^5^ 5
829	"IX",364.6 ,364.6,"AL L",11.1,1, 0)
830	1^F^364.6^ .03^^1^F
831	"IX",364.6 ,364.6,"AL L",11.1,1, 1)
832
833	"IX",364.6 ,364.6,"AL L",11.1,2, 0)
834	2^C
835	"IX",364.6 ,364.6,"AL L",11.1,2, 1.5)
836	N Z S Z=+$ O(^IBA(364 .7,"B",DA, 0)) I Z S X=$P($G(^I BA(364.7,Z ,0)),U,5)
837	"IX",364.6 ,364.6,"AL L",11.1,3, 0)
838	3^C
839	"IX",364.6 ,364.6,"AL L",11.1,3, 1.5)
840	N Z S Z=+$ O(^IBA(364 .7,"B",DA, 0)) I Z S X=$P($G(^I BA(364.7,Z ,0)),U,6)
841	"IX",364.6 ,364.6,"AL L",11.1,4, 0)
842	4^C
843	"IX",364.6 ,364.6,"AL L",11.1,4, 1.5)
844	N Z S Z=+$ O(^IBA(364 .7,"B",DA, 0)) I Z S X=$P($G(^I BA(364.7,Z ,0)),U,2)
845	"IX",364.6 ,364.6,"AL L",11.1,5, 0)
846	5^C
847	"IX",364.6 ,364.6,"AL L",11.1,5, 1.5)
848	S X=+$O(^I BA(364.7," B",DA,0))
849	"IX",364.6 ,364.6,"C" ,0)
850	364.6^C^Fi eld name l ookup^R^^F ^IR^I^364. 6^^^^^LS
851	"IX",364.6 ,364.6,"C" ,1)
852	S ^IBA(364 .6,"C",$E( X,1,40),DA )=""
853	"IX",364.6 ,364.6,"C" ,2)
854	K ^IBA(364 .6,"C",$E( X,1,40),DA )
855	"IX",364.6 ,364.6,"C" ,2.5)
856	K ^IBA(364 .6,"C")
857	"IX",364.6 ,364.6,"C" ,11.1,0)
858	^.114IA^1^ 1
859	"IX",364.6 ,364.6,"C" ,11.1,1,0)
860	1^F^364.6^ .1^40^1^F
861	"IX",364.6 ,364.6,"C" ,11.1,1,2)
862	S X=$$UP^X LFSTR(X)
863	"IX",364.6 ,364.6,"D" ,0)
864	364.6^D^XR EF BY FORM ,PAGE,LINE ,COL TO SI MPLIFY DEV ELOPMENT^M U^^R^IR^I^ 364.6^^^^^ LS
865	"IX",364.6 ,364.6,"D" ,1)
866	S ^IBA(364 .6,"D",X2( 1)_","_X2( 2)_","_X2( 3)_","_X2( 4),DA)=""
867	"IX",364.6 ,364.6,"D" ,1.4)
868	I X2(1)="" !(X2(2)="" )!(X2(3)=" ")!(X2(4)= "") S X=0
869	"IX",364.6 ,364.6,"D" ,2)
870	K ^IBA(364 .6,"D",X1( 1)_","_X1( 2)_","_X1( 3)_","_X1( 4),DA)
871	"IX",364.6 ,364.6,"D" ,2.4)
872	I X1(1)="" !(X1(2)="" )!(X1(3)=" ")!(X1(4)= "") S X=0
873	"IX",364.6 ,364.6,"D" ,2.5)
874	K ^IBA(364 .6,"D")
875	"IX",364.6 ,364.6,"D" ,11.1,0)
876	^.114IA^4^ 4
877	"IX",364.6 ,364.6,"D" ,11.1,1,0)
878	1^F^364.6^ .01^^1^F
879	"IX",364.6 ,364.6,"D" ,11.1,2,0)
880	2^F^364.6^ .04^^^F
881	"IX",364.6 ,364.6,"D" ,11.1,3,0)
882	3^F^364.6^ .05^^^F
883	"IX",364.6 ,364.6,"D" ,11.1,4,0)
884	4^F^364.6^ .08^^^F
885	"IX",364.7 ,364.7,"AL L",0)
886	364.7^ALL^ Xref conta ins all lo cal overri des define d for all insurance and type^M U^^F^IR^I^ 364.7^^^^^ S
887	"IX",364.7 ,364.7,"AL L",1)
888	S ^IBA(364 .7,"ALL",X 2(2),DA)=" "
889	"IX",364.7 ,364.7,"AL L",1.4)
890	I 'X2(2)!( X2(4)'="") !(X2(5)'=" ")!(X2(3)' ="L") S X= 0
891	"IX",364.7 ,364.7,"AL L",2)
892	K ^IBA(364 .7,"ALL",X 1(2),DA)
893	"IX",364.7 ,364.7,"AL L",2.4)
894	I 'X1(2)!( X1(4)'="") !(X1(5)'=" ")!(X1(3)' ="L") S X= 0
895	"IX",364.7 ,364.7,"AL L",2.5)
896	K ^IBA(364 .7,"ALL")
897	"IX",364.7 ,364.7,"AL L",11.1,0)
898	^.114IA^5^ 5
899	"IX",364.7 ,364.7,"AL L",11.1,1, 0)
900	1^F^364.7^ .01^15^^F
901	"IX",364.7 ,364.7,"AL L",11.1,1, 3)
902
903	"IX",364.7 ,364.7,"AL L",11.1,2, 0)
904	2^C^^^10^1
905	"IX",364.7 ,364.7,"AL L",11.1,2, 1.5)
906	S X=$P($G( ^IBA(364.6 ,+X(1),0)) ,U,3)
907	"IX",364.7 ,364.7,"AL L",11.1,3, 0)
908	3^F^364.7^ .02^10^^F
909	"IX",364.7 ,364.7,"AL L",11.1,3, 3)
910
911	"IX",364.7 ,364.7,"AL L",11.1,4, 0)
912	4^F^364.7^ .05^20^^F
913	"IX",364.7 ,364.7,"AL L",11.1,4, 3)
914
915	"IX",364.7 ,364.7,"AL L",11.1,5, 0)
916	5^F^364.7^ .06^20^^F
917	"IX",364.7 ,364.7,"AL L",11.1,5, 3)
918
919	"KRN",19,3 102,-1)
920	2^2
921	"KRN",19,3 102,0)
922	IB SYSTEM DEFINITION MENU^MCCR System De finition M enu^^M^568 ^IB SUPERV ISOR^^^^^y ^230
923	"KRN",19,3 102,10,0)
924	^19.01IP^2 2^22
925	"KRN",19,3 102,10,22, 0)
926	2922455^HI D
927	"KRN",19,3 102,10,22, "^")
928	IB HCCH PA YER ID REP ORT
929	"KRN",19,3 102,"U")
930	MCCR SYSTE M DEFINITI ON MENU
931	"KRN",19,2 922455,-1)
932	0^1
933	"KRN",19,2 922455,0)
934	IB HCCH PA YER ID REP ORT^HCCH P ayer ID Re port^^R^^^ ^^^^^INTEG RATED BILL ING^^
935	"KRN",19,2 922455,1,0 )
936	^19.06^3^3 ^3170509^^
937	"KRN",19,2 922455,1,1 ,0)
938	This is a report bas ed on the 277STAT tr ansactions
939	"KRN",19,2 922455,1,2 ,0)
940	from Healt h Care Cle aring Hous e to deter mine if it updated o r
941	"KRN",19,2 922455,1,3 ,0)
942	attempted to update the Payer Id.
943	"KRN",19,2 922455,10. 1)
944
945	"KRN",19,2 922455,20)
946
947	"KRN",19,2 922455,25)
948	ENT^IBCERP 7
949	"KRN",19,2 922455,99)
950	64412,6800 0
951	"KRN",19,2 922455,"U" )
952	HCCH PAYER ID REPORT
953	"KRN",101, 7457,-1)
954	0^5
955	"KRN",101, 7457,0)
956	IBJP IB PA Y-TO PROVI DER DIVISI ONS^Associ ate Divisi ons^^A^^^^ ^^^^INTEGR ATED BILLI NG
957	"KRN",101, 7457,4)
958	^^^AD
959	"KRN",101, 7457,20)
960	D EN^IBJPS 4(0)
961	"KRN",101, 7457,99)
962	61599,2010 7
963	"KRN",101, 7458,-1)
964	0^6
965	"KRN",101, 7458,0)
966	IBJP IB PA Y-TO PROVI DER EDIT^E dit Provid er^^A^^^^^ ^^^INTEGRA TED BILLIN G
967	"KRN",101, 7458,4)
968	^^^EP
969	"KRN",101, 7458,20)
970	D PRVEDIT^ IBJPS3(0)
971	"KRN",101, 7458,99)
972	63699,4912 1
973	"KRN",101, 7459,-1)
974	0^4
975	"KRN",101, 7459,0)
976	IBJP IB PA Y-TO PROVI DER DEL^De lete Provi der^^A^^^^ ^^^^INTEGR ATED BILLI NG
977	"KRN",101, 7459,4)
978	^^^DP
979	"KRN",101, 7459,20)
980	D PRVDEL^I BJPS3(0)
981	"KRN",101, 7459,99)
982	63699,4912 1
983	"KRN",101, 7460,-1)
984	0^3
985	"KRN",101, 7460,0)
986	IBJP IB PA Y-TO PROVI DER ADD^Ad d Provider ^^A^^^^^^^ ^INTEGRATE D BILLING
987	"KRN",101, 7460,4)
988	^^^AP
989	"KRN",101, 7460,20)
990	D PRVADD^I BJPS3(0)
991	"KRN",101, 7460,99)
992	63699,4912 1
993	"KRN",101, 7461,-1)
994	0^7
995	"KRN",101, 7461,0)
996	IBJP IB PA Y-TO PROVI DERS MENU^ Pay-To Pro viders Men u^^M^^^^^^ ^^INTEGRAT ED BILLING
997	"KRN",101, 7461,4)
998	26^4
999	"KRN",101, 7461,10,0)
1000	^101.01PA^ 4^4
1001	"KRN",101, 7461,10,1, 0)
1002	7460^AP^2^
1003	"KRN",101, 7461,10,1, "^")
1004	IBJP IB PA Y-TO PROVI DER ADD
1005	"KRN",101, 7461,10,2, 0)
1006	7459^DP^7^
1007	"KRN",101, 7461,10,2, "^")
1008	IBJP IB PA Y-TO PROVI DER DEL
1009	"KRN",101, 7461,10,3, 0)
1010	7458^EP^5^
1011	"KRN",101, 7461,10,3, "^")
1012	IBJP IB PA Y-TO PROVI DER EDIT
1013	"KRN",101, 7461,10,4, 0)
1014	7457^AS^8^
1015	"KRN",101, 7461,10,4, "^")
1016	IBJP IB PA Y-TO PROVI DER DIVISI ONS
1017	"KRN",101, 7461,24)
1018	I $D(^XUSE C("IB EDIT PAY-TO",D UZ))
1019	"KRN",101, 7461,26)
1020	D SHOW^VAL M
1021	"KRN",101, 7461,99)
1022	64408,4771 5
1023	"KRN",101, 7462,-1)
1024	0^2
1025	"KRN",101, 7462,0)
1026	IBJP IB PA Y-TO DIVIS ION ADD^As sociate Di vision^^A^ ^^^^^^^INT EGRATED BI LLING
1027	"KRN",101, 7462,4)
1028	^^^AD
1029	"KRN",101, 7462,20)
1030	D DIVADD^I BJPS4(0)
1031	"KRN",101, 7462,99)
1032	63699,4912 1
1033	"KRN",101, 7463,-1)
1034	0^1
1035	"KRN",101, 7463,0)
1036	IBJP IB PA Y-TO ASSOC IATIONS ME NU^Pay-To Associatio ns Menu^^M ^^^^^^^^IN TEGRATED B ILLING
1037	"KRN",101, 7463,4)
1038	40^4
1039	"KRN",101, 7463,10,0)
1040	^101.01PA^ 3^2
1041	"KRN",101, 7463,10,1, 0)
1042	7462^AS^3^
1043	"KRN",101, 7463,10,1, "^")
1044	IBJP IB PA Y-TO DIVIS ION ADD
1045	"KRN",101, 7463,26)
1046	D SHOW^VAL M
1047	"KRN",101, 7463,99)
1048	64408,4802 5
1049	"MBREQ")
1050	0
1051	"ORD",15,1 01)
1052	101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
1053	"ORD",15,1 01,0)
1054	PROTOCOL
1055	"ORD",18,1 9)
1056	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
1057	"ORD",18,1 9,0)
1058	OPTION
1059	"PGL",364. 6,0,3,.03)
1060	ASSOCIATED FORM DEFI NITION^P36 4.6'^IBA(3 64.6,^0;3^ Q
1061	"PGL",364. 7,0,5,.05)
1062	INSURANCE COMPANY^P3 6'^DIC(36, ^0;5^Q
1063	"PKG",230, -1)
1064	1^1
1065	"PKG",230, 0)
1066	INTEGRATED BILLING^I B^INTEGRAT ED BILLING
1067	"PKG",230, 20,0)
1068	^9.402P^1^ 1
1069	"PKG",230, 20,1,0)
1070	2^^IBAXDR
1071	"PKG",230, 20,1,1)
1072
1073	"PKG",230, 20,"B",2,1 )
1074
1075	"PKG",230, 22,0)
1076	^9.49I^1^1
1077	"PKG",230, 22,1,0)
1078	2.0^294032 1^2940525
1079	"PKG",230, 22,1,"PAH" ,1,0)
1080	577^317062 7^52082463 5
1081	"QUES","XP F1",0)
1082	Y
1083	"QUES","XP F1","??")
1084	^D REP^XPD H
1085	"QUES","XP F1","A")
1086	Shall I wr ite over y our \|FLAG\| File
1087	"QUES","XP F1","B")
1088	YES
1089	"QUES","XP F1","M")
1090	D XPF1^XPD IQ
1091	"QUES","XP F2",0)
1092	Y
1093	"QUES","XP F2","??")
1094	^D DTA^XPD H
1095	"QUES","XP F2","A")
1096	Want my da ta \|FLAG\| yours
1097	"QUES","XP F2","B")
1098	YES
1099	"QUES","XP F2","M")
1100	D XPF2^XPD IQ
1101	"QUES","XP I1",0)
1102	YO
1103	"QUES","XP I1","??")
1104	^D INHIBIT ^XPDH
1105	"QUES","XP I1","A")
1106	Want KIDS to INHIBIT LOGONs du ring the i nstall
1107	"QUES","XP I1","B")
1108	NO
1109	"QUES","XP I1","M")
1110	D XPI1^XPD IQ
1111	"QUES","XP M1",0)
1112	PO^VA(200, :EM
1113	"QUES","XP M1","??")
1114	^D MG^XPDH
1115	"QUES","XP M1","A")
1116	Enter the Coordinato r for Mail Group '\|F LAG\|'
1117	"QUES","XP M1","B")
1118
1119	"QUES","XP M1","M")
1120	D XPM1^XPD IQ
1121	"QUES","XP O1",0)
1122	Y
1123	"QUES","XP O1","??")
1124	^D MENU^XP DH
1125	"QUES","XP O1","A")
1126	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
1127	"QUES","XP O1","B")
1128	NO
1129	"QUES","XP O1","M")
1130	D XPO1^XPD IQ
1131	"QUES","XP Z1",0)
1132	Y
1133	"QUES","XP Z1","??")
1134	^D OPT^XPD H
1135	"QUES","XP Z1","A")
1136	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
1137	"QUES","XP Z1","B")
1138	NO
1139	"QUES","XP Z1","M")
1140	D XPZ1^XPD IQ
1141	"QUES","XP Z2",0)
1142	Y
1143	"QUES","XP Z2","??")
1144	^D RTN^XPD H
1145	"QUES","XP Z2","A")
1146	Want to MO VE routine s to other CPUs
1147	"QUES","XP Z2","B")
1148	NO
1149	"QUES","XP Z2","M")
1150	D XPZ2^XPD IQ
1151	"RTN")
1152	15
1153	"RTN","IBC BB1")
1154	0^2^B12574 4740^B1240 97608
1155	"RTN","IBC BB1",1,0)
1156	IBCBB1 ;AL B/AAS - CO NTINUATION OF EDIT C HECK ROUTI NE ;2-NOV- 89
1157	"RTN","IBC BB1",2,0)
1158	;;2.0;INT EGRATED BI LLING;27 ,52,80,93, 106,51,151 ,148,153,1 37,232,280 ,155,320,3 43,349,363 ,371,395,3 84,432,447 ,488,554,5 77;21-MA R-94;Build 34
1159	"RTN","IBC BB1",3,0)
1160	;Per VA D irective 6 402, this routine sh ould not b e modified .
1161	"RTN","IBC BB1",4,0)
1162	;
1163	"RTN","IBC BB1",5,0)
1164	; *** Beg in IB2.0 488 VD (I ssue 46 RB N)
1165	"RTN","IBC BB1",6,0)
1166	N I
1167	"RTN","IBC BB1",7,0)
1168	S I=""
1169	"RTN","IBC BB1",8,0)
1170	S X=+$G(^ DGCR(399,I BIFN,"MP") )
1171	"RTN","IBC BB1",9,0)
1172	I 'X,$$MC RWNR^IBEFU NC(+$$CURR ^IBCEF2(IB IFN)) S X= +$$CURR^IB CEF2(IBIFN )
1173	"RTN","IBC BB1",10,0)
1174	I X,+$G(^ DIC(36,X,3 )) S I=$P( ^(3),U,$S( $$FT^IBCEF (IBIFN)=2: 2,1:4))
1175	"RTN","IBC BB1",11,0)
1176	S I=$$UP^ XLFSTR(I)
1177	"RTN","IBC BB1",12,0)
1178	I (I'=""& (I["PRNT") &($G(IBER) '["IB488") ) D
1179	"RTN","IBC BB1",13,0)
1180	. S IBER= $G(IBER)_" IB488;"
1181	"RTN","IBC BB1",14,0)
1182	;
1183	"RTN","IBC BB1",15,0)
1184	; Cause a n error if FORCED TO PRINT TO CLEARINGHO USE
1185	"RTN","IBC BB1",16,0)
1186	I $P($G(^ DGCR(399,I BIFN,"TX") ),U,8)=2 D
1187	"RTN","IBC BB1",17,0)
1188	. S IBER= $G(IBER)_" IB489;"
1189	"RTN","IBC BB1",18,0)
1190	;
1191	"RTN","IBC BB1",19,0)
1192	; Cause a fatal err or if the claim has no procedu res & is N OT a UB-04 Inpatient claim.
1193	"RTN","IBC BB1",20,0)
1194	I +$O(^DG CR(399,IBI FN,"CP",0) )=0 D
1195	"RTN","IBC BB1",21,0)
1196	.I $$INPA T^IBCEF(IB IFN,1),$$I NSPRF^IBCE F(IBIFN) Q ; inpat ient UB-04 check
1197	"RTN","IBC BB1",22,0)
1198	.I '$$INP AT^IBCEF(I BIFN,1),$$ INSPRF^IBC EF(IBIFN) D Q ; Outpatie nt Institu tional Cla im.
1199	"RTN","IBC BB1",23,0)
1200	..I IBER[ "IB352" Q
1201	"RTN","IBC BB1",24,0)
1202	..S IBER= IBER_"IB35 2;"
1203	"RTN","IBC BB1",25,0)
1204	.;
1205	"RTN","IBC BB1",26,0)
1206	.; Profes sional cla im
1207	"RTN","IBC BB1",27,0)
1208	.I IBER[" IB353" Q
1209	"RTN","IBC BB1",28,0)
1210	.S IBER=I BER_"IB353 ;"
1211	"RTN","IBC BB1",29,0)
1212	.Q
1213	"RTN","IBC BB1",30,0)
1214	; *** End IB2.048 8 -- VD
1215	"RTN","IBC BB1",31,0)
1216	;
1217	"RTN","IBC BB1",32,0)
1218	;MAP TO D GCRBB1
1219	"RTN","IBC BB1",33,0)
1220	;
1221	"RTN","IBC BB1",34,0)
1222	% ;Bill St atus
1223	"RTN","IBC BB1",35,0)
1224	N Z,Z0,Z1 ,IBFT
1225	"RTN","IBC BB1",36,0)
1226	I $S(+IBS T=0:1,1:"^ 1^2^3^4^7^ "'[(U_IBST _U)) S IBE R=IBER_"IB 045;"
1227	"RTN","IBC BB1",37,0)
1228	;
1229	"RTN","IBC BB1",38,0)
1230	;Statemen t Covers F rom
1231	"RTN","IBC BB1",39,0)
1232	I IBFDT=" " S IBER=I BER_"IB061 ;"
1233	"RTN","IBC BB1",40,0)
1234	I IBFDT]" ",IBFDT'?7 N&(IBFDT'? 7N1".".N) S IBER=IBE R_"IB061;"
1235	"RTN","IBC BB1",41,0)
1236	I IBFDT>I BTDT S IBE R=IBER_"IB 061;" ; fr om must be on or bef ore the to date
1237	"RTN","IBC BB1",42,0)
1238	S IBFFY=$ $FY^IBOUTL (IBFDT)
1239	"RTN","IBC BB1",43,0)
1240	; if inpa t - from d ate must n ot be prio r to admit date.
1241	"RTN","IBC BB1",44,0)
1242	I $$INPAT ^IBCEF(IBI FN,1),(IBF DT<($P($G( ^DGPT(+$P( IBND0,U,8) ,0)),U,2)\ 1)) S IBE R=IBER_"IB 061;"
1243	"RTN","IBC BB1",45,0)
1244	;
1245	"RTN","IBC BB1",46,0)
1246	;Statemen t Covers T o
1247	"RTN","IBC BB1",47,0)
1248	I IBTDT=" " S IBER=I BER_"IB062 ;"
1249	"RTN","IBC BB1",48,0)
1250	I IBTDT]" ",IBTDT'?7 N&(IBTDT'? 7N1".".N) S IBER=IBE R_"IB062;"
1251	"RTN","IBC BB1",49,0)
1252	I IBTDT>D T!(IBTDT<I BFDT) S IB ER=IBER_"I B062;" ; to date mu st not be >than toda y's date
1253	"RTN","IBC BB1",50,0)
1254	S IBTFY=$ $FY^IBOUTL (IBTDT)
1255	"RTN","IBC BB1",51,0)
1256	;
1257	"RTN","IBC BB1",52,0)
1258	;Total Ch arges
1259	"RTN","IBC BB1",53,0)
1260	; IB2.0 447/TAZ Re moved this error so that zero dollar rev enue codes can proce ss on the 837
1261	"RTN","IBC BB1",54,0)
1262	;I +IBTC' >0!(+IBTC' =IBTC) S I BER=IBER_" IB064;"
1263	"RTN","IBC BB1",55,0)
1264	;
1265	"RTN","IBC BB1",56,0)
1266	;Billable charges f or seconda ry claim
1267	"RTN","IBC BB1",57,0)
1268	I $$MCRON BIL^IBEFUN C(IBIFN)&( ($P(IBNDU1 ,U,1)-$P(I BNDU1,U,2) )'>0) S IB ER=IBER_"I B094;"
1269	"RTN","IBC BB1",58,0)
1270	;Fiscal Y ear 1
1271	"RTN","IBC BB1",59,0)
1272	S IBFFY=$ $FY^IBOUTL (IBFDT)
1273	"RTN","IBC BB1",60,0)
1274	;
1275	"RTN","IBC BB1",61,0)
1276	;Check pr ovider lin k for curr ent user, enterer, r eviewer an d Authoriz or
1277	"RTN","IBC BB1",62,0)
1278	I '$D(^VA (200,DUZ,0 )) S IBER= IBER_"IB04 8;"
1279	"RTN","IBC BB1",63,0)
1280	I IBEU]"" ,'$D(^VA(2 00,IBEU,0) ) S IBER=I BER_"IB048 ;"
1281	"RTN","IBC BB1",64,0)
1282	I IBRU]"" ,'$D(^VA(2 00,IBRU,0) ) S IBER=I BER_"IB060 ;"
1283	"RTN","IBC BB1",65,0)
1284	I IBAU]"" ,'$D(^VA(2 00,IBAU,0) ) S IBER=I BER_"IB041 ;"
1285	"RTN","IBC BB1",66,0)
1286	;
1287	"RTN","IBC BB1",67,0)
1288	I IBER="" ,+$$STA^PR CAFN(IBIFN )=104 S IB ER=IBER_"I B040;"
1289	"RTN","IBC BB1",68,0)
1290	; If ins bill, must have vali d COB sequ ence
1291	"RTN","IBC BB1",69,0)
1292	I $P(IBND 0,U,11)="i ",$S($P(IB ND0,U,21)= "":1,1:"PS T"'[$P(IBN D0,U,21)) S IBER=IBE R_"IB324;"
1293	"RTN","IBC BB1",70,0)
1294	;
1295	"RTN","IBC BB1",71,0)
1296	; Check f or valid s ec provide r id for c urrent ins
1297	"RTN","IBC BB1",72,0)
1298	S Z=0 F S Z=$O(^DG CR(399,IBI FN,"PRV",Z )) Q:'Z S Z0=$G(^(Z ,0)),Z1=+$ $COBN^IBCE F(IBIFN) I $P(Z0,U,4 +Z1)'="",$ P(Z0,U,11+ Z1)'="" D
1299	"RTN","IBC BB1",73,0)
1300	. I '$$SE CIDCK^IBCE F74(IBIFN, Z1,$P(Z0,U ,11+Z1),Z) D WARN^IB CBB11("Pro v secondar y id type for the "_ $P("PRIMAR Y^SECONDAR Y^TERTIARY ",U,Z1)_" "_$$EXTERN AL^DILFD(3 99.0222,.0 1,,+Z0)_" is invalid /won't tra nsmit")
1301	"RTN","IBC BB1",74,0)
1302	; Check N PIs
1303	"RTN","IBC BB1",75,0)
1304	D NPICHK^ IBCBB11
1305	"RTN","IBC BB1",76,0)
1306	;
1307	"RTN","IBC BB1",77,0)
1308	; Check m ultiple rx NPIs
1309	"RTN","IBC BB1",78,0)
1310	D RXNPI^I BCBB11(IBI FN)
1311	"RTN","IBC BB1",79,0)
1312	;
1313	"RTN","IBC BB1",80,0)
1314	; Check t axonomies
1315	"RTN","IBC BB1",81,0)
1316	D TAXCHK^ IBCBB11
1317	"RTN","IBC BB1",82,0)
1318	;
1319	"RTN","IBC BB1",83,0)
1320	; Check f or Physici an Name
1321	"RTN","IBC BB1",84,0)
1322	K IBXDATA D F^IBCEF ("N-ATT/RE ND PHYSICI AN NAME",, ,IBIFN)
1323	"RTN","IBC BB1",85,0)
1324	; IB2.0 432 - CMS1 500 no lon ger needs a claim le vel render ing
1325	"RTN","IBC BB1",86,0)
1326	S IBFT=$$ FT^IBCEF(I BIFN)
1327	"RTN","IBC BB1",87,0)
1328	I IBFT'=2 ,$P($G(IBX DATA),U)=" " S IBER=I BER_"IB303 ;"
1329	"RTN","IBC BB1",88,0)
1330	;
1331	"RTN","IBC BB1",89,0)
1332	N FUNCTIO N,IBINS
1333	"RTN","IBC BB1",90,0)
1334	; IB2.0 432 - CMS1 500 no lon ger needs a claim le vel render ing
1335	"RTN","IBC BB1",91,0)
1336	;S FUNCTI ON=$S($$FT ^IBCEF(IBI FN)=3:4,1: 3)
1337	"RTN","IBC BB1",92,0)
1338	S FUNCTIO N=$S(IBFT= 3:4,1:3)
1339	"RTN","IBC BB1",93,0)
1340	I IBFT'=2 ,IBER'["IB 303;" D
1341	"RTN","IBC BB1",94,0)
1342	. F IBINS =1:1:3 D
1343	"RTN","IBC BB1",95,0)
1344	.. S Z=$$ GETTYP^IBC EP2A(IBIFN ,IBINS)
1345	"RTN","IBC BB1",96,0)
1346	.. I Z,$P (Z,U,2) D ; Renderi ng/attendi ng prov se condary id required
1347	"RTN","IBC BB1",97,0)
1348	... N IBI D,IBOK,Q0
1349	"RTN","IBC BB1",98,0)
1350	... D PRO VINF^IBCEF 74(IBIFN,I BINS,.IBID ,1,"C") ; check all as though they were current
1351	"RTN","IBC BB1",99,0)
1352	... S IBO K=0
1353	"RTN","IBC BB1",100,0 )
1354	... S Q0= 0 F S Q0= $O(IBID(1, FUNCTION,Q 0)) Q:'Q0 I $P(IBID (1,FUNCTIO N,Q0),U,9) =+Z S IBOK =1 Q
1355	"RTN","IBC BB1",101,0 )
1356	... I 'IB OK S IBER= IBER_$S(IB INS=1:"IB2 36;",IBINS =2:"IB237; ",IBINS=3: "IB238;",1 :"")
1357	"RTN","IBC BB1",102,0 )
1358	;
1359	"RTN","IBC BB1",103,0 )
1360	; Patch 4 32 enh5:Th e IB syste m shall no longer pr event user s from aut horizing(f atal error message)a claim bec ause the s ystem cann ot find th e provider sSSNorEIN
1361	"RTN","IBC BB1",104,0 )
1362	; D PRIID CHK^IBCBB1 1
1363	"RTN","IBC BB1",105,0 )
1364	;
1365	"RTN","IBC BB1",106,0 )
1366	N IBM,IBM 1
1367	"RTN","IBC BB1",107,0 )
1368	S IBM=$G( ^DGCR(399, IBIFN,"M") )
1369	"RTN","IBC BB1",108,0 )
1370	S IBM1=$G (^DGCR(399 ,IBIFN,"M1 "))
1371	"RTN","IBC BB1",109,0 )
1372	I $P(IBM, U),$P($G(^ DIC(36,$P( IBM,U),4)) ,U,6),$P(I BM1,U,2)=" " S IBER=I BER_"IB244 ;"
1373	"RTN","IBC BB1",110,0 )
1374	I $P(IBM, U,2),$P($G (^DIC(36,$ P(IBM,U,2) ,4)),U,6), $P(IBM1,U, 3)="" S IB ER=IBER_"I B245;"
1375	"RTN","IBC BB1",111,0 )
1376	I $P(IBM, U,3),$P($G (^DIC(36,$ P(IBM,U,3) ,4)),U,6), $P(IBM1,U, 4)="" S IB ER=IBER_"I B246;"
1377	"RTN","IBC BB1",112,0 )
1378	;
1379	"RTN","IBC BB1",113,0 )
1380	; If outs ide facili ty, check for ID and qualifier in 355.93
1381	"RTN","IBC BB1",114,0 )
1382	; 5/15/06 - esg - h ard error IB243 turn ed into wa rning mess age instea d
1383	"RTN","IBC BB1",115,0 )
1384	S Z=$P($G (^DGCR(399 ,IBIFN,"U2 ")),U,10)
1385	"RTN","IBC BB1",116,0 )
1386	I Z D
1387	"RTN","IBC BB1",117,0 )
1388	. I $P($G (^IBA(355. 93,Z,0)),U ,9)=""!($P ($G(^IBA(3 55.93,Z,0) ),U,13)="" ) D
1389	"RTN","IBC BB1",118,0 )
1390	.. N Z1,Z 2
1391	"RTN","IBC BB1",119,0 )
1392	.. S Z1=" Missing La b or Facil ity Primar y ID for n on-VA faci lity, "
1393	"RTN","IBC BB1",120,0 )
1394	.. S Z2=$ $EXTERNAL^ DILFD(399, 232,,Z)
1395	"RTN","IBC BB1",121,0 )
1396	.. I $L(Z 2)'>19 D W ARN^IBCBB1 1(Z1_Z2) Q
1397	"RTN","IBC BB1",122,0 )
1398	.. D WARN ^IBCBB11(Z 1),WARN^IB CBB11(" "_Z2)
1399	"RTN","IBC BB1",123,0 )
1400	.. Q
1401	"RTN","IBC BB1",124,0 )
1402	. Q
1403	"RTN","IBC BB1",125,0 )
1404	;
1405	"RTN","IBC BB1",126,0 )
1406	; Must be one and o nly one di vision on bill
1407	"RTN","IBC BB1",127,0 )
1408	S IBZ=$$M ULTDIV^IBC BB11(IBIFN ,IBND0)
1409	"RTN","IBC BB1",128,0 )
1410	; I IBZ S IBER=IBER _$S(IBZ=1: "IB095;",I BZ=2:"IB10 4;",1:"IB1 05;")
1411	"RTN","IBC BB1",129,0 )
1412	; Allow m ulti-divis ional for OP instuti onal claim s
1413	"RTN","IBC BB1",130,0 )
1414	I IBZ,$$I NPAT^IBCEF (IBIFN)!'( $$INSPRF^I BCEF(IBIFN )) S IBER= IBER_$S(IB Z=1:"IB095 ;",IBZ=2:" IB104;",1: "IB105;")
1415	"RTN","IBC BB1",131,0 )
1416	; Still n eed error msg on OP Institutio nal if No Default di vision
1417	"RTN","IBC BB1",132,0 )
1418	I IBZ=3,' $$INPAT^IB CEF(IBIFN) ,$$INSPRF^ IBCEF(IBIF N) S IBER= IBER_"IB10 5;"
1419	"RTN","IBC BB1",133,0 )
1420	; Divisio n address must be de fined in i nstitution file
1421	"RTN","IBC BB1",134,0 )
1422	I $P(IBND 0,U,22) D
1423	"RTN","IBC BB1",135,0 )
1424	. N Z,Z0, Z1
1425	"RTN","IBC BB1",136,0 )
1426	. S Z0=$G (^DIC(4,+$ P($G(^DG(4 0.8,+$P(IB ND0,U,22), 0)),U,7),0 ))
1427	"RTN","IBC BB1",137,0 )
1428	. S Z1=$G (^DIC(4,+$ P($G(^DG(4 0.8,+$P(IB ND0,U,22), 0)),U,7),1 ))
1429	"RTN","IBC BB1",138,0 )
1430	. I $P(Z0 ,U,2)="" S IBER=IBER _"IB097;" Q
1431	"RTN","IBC BB1",139,0 )
1432	. F Z=1,3 ,4 I $P(Z1 ,U,Z)="" S IBER=IBER _"IB097;" Q
1433	"RTN","IBC BB1",140,0 )
1434	;
1435	"RTN","IBC BB1",141,0 )
1436	; IB2.0 432 Check ambulance addresses, COB Non-c overed amt . & Attach ment Contr ol
1437	"RTN","IBC BB1",142,0 )
1438	I $$AMBCK ^IBCBB11(I BIFN)=1 S IBER=IBER_ "IB329;"
1439	"RTN","IBC BB1",143,0 )
1440	I $$COBAM T^IBCBB11( IBIFN)=1 S IBER=IBER _"IB330;"
1441	"RTN","IBC BB1",144,0 )
1442	I $$TMCK^ IBCBB11(IB IFN)=1 S I BER=IBER_" IB331;"
1443	"RTN","IBC BB1",145,0 )
1444	I $$ACCK^ IBCBB11(IB IFN)=1 S I BER=IBER_" IB332;"
1445	"RTN","IBC BB1",146,0 )
1446	I $$COBMR A^IBCBB11( IBIFN)=1 S IBER=IBER _"IB342;"
1447	"RTN","IBC BB1",147,0 )
1448	I $$COBSE C^IBCBB11( IBIFN)=1 S IBER=IBER _"IB343;"
1449	"RTN","IBC BB1",148,0 )
1450	;
1451	"RTN","IBC BB1",149,0 )
1452	;CHAMPVA Rate Type and Primar y Insuranc e Carriers Type of C overage mu st match
1453	"RTN","IBC BB1",150,0 )
1454	S (IBRTCH V,IBPICHV) =0
1455	"RTN","IBC BB1",151,0 )
1456	I $P($G(^ DGCR(399.3 ,+IBAT,0)) ,U,1)="CHA MPVA" S IB RTCHV=1
1457	"RTN","IBC BB1",152,0 )
1458	I $P($G(^ IBE(355.2, +$P($G(^DI C(36,+IBND MP,0)),U,1 3),0)),U,1 )="CHAMPVA " S IBPICH V=1
1459	"RTN","IBC BB1",153,0 )
1460	I (+IBRTC HV!+IBPICH V)&('IBRTC HV!'IBPICH V) S IBER= IBER_"IB08 5;"
1461	"RTN","IBC BB1",154,0 )
1462	;
1463	"RTN","IBC BB1",155,0 )
1464	;Non-VA b ill must u se FEE REI MB INS rat e type; FE E REIMB IN S rate typ e can only be used f or Non-VA bill
1465	"RTN","IBC BB1",156,0 )
1466	;IB2.05 54/DRF 10/ 9/2015
1467	"RTN","IBC BB1",157,0 )
1468	;N IBNVAR T,IBNVAST
1469	"RTN","IBC BB1",158,0 )
1470	;S (IBNVA RT,IBNVAST )=0
1471	"RTN","IBC BB1",159,0 )
1472	;I $P($G( ^DGCR(399. 3,+IBAT,0) ),U,1)="FE E REIMB IN S" S IBNVA RT=1
1473	"RTN","IBC BB1",160,0 )
1474	;S IBNVAS T=$$NONVAF LG(IBIFN)
1475	"RTN","IBC BB1",161,0 )
1476	;I IBNVAR T,'IBNVAST S IBER=IB ER_"IB360; " ;Non-VA rate type used for bill that is not Non -VA
1477	"RTN","IBC BB1",162,0 )
1478	;I 'IBNVA RT,IBNVAST S IBER=IB ER_"IB361; " ;Non-VA rate type not used for bill t hat is Non -VA
1479	"RTN","IBC BB1",163,0 )
1480	;
1481	"RTN","IBC BB1",164,0 )
1482	N IBZPRC, IBZPRCUB
1483	"RTN","IBC BB1",165,0 )
1484	D F^IBCEF ("N-ALL PR OCEDURES", "IBZPRC",, IBIFN)
1485	"RTN","IBC BB1",166,0 )
1486	; Procedu re Clinic is require d for Surg ical Proce dures Outp t Facility Charges
1487	"RTN","IBC BB1",167,0 )
1488	I +$P(IBN D0,U,27)'= 2,$$BILLRA TE^IBCRU3( IBAT,IBCL, IBEVDT,"RC OUTPATIEN T") D
1489	"RTN","IBC BB1",168,0 )
1490	. N Z,Z0, Z1,ZE S (Z E,Z)=0 F S Z=$O(^DG CR(399,IBI FN,"CP",Z) ) Q:'Z D I +ZE S I BER=IBER_" IB320;" Q
1491	"RTN","IBC BB1",169,0 )
1492	.. S Z0=$ G(^DGCR(39 9,IBIFN,"C P",Z,0)),Z 1=+Z0 I Z0 '[";ICPT(" Q
1493	"RTN","IBC BB1",170,0 )
1494	.. I '((Z 1'<10000)& (Z1'>69999 ))&'((Z1'< 93501)&(Z1 '>93533)) Q
1495	"RTN","IBC BB1",171,0 )
1496	.. I '$P( Z0,U,7) S ZE=1
1497	"RTN","IBC BB1",172,0 )
1498	;
1499	"RTN","IBC BB1",173,0 )
1500	; Extract procedure s for UB-0 4
1501	"RTN","IBC BB1",174,0 )
1502	D F^IBCEF ("N-UB-04 PROCEDURES ","IBZPRCU B",,IBIFN)
1503	"RTN","IBC BB1",175,0 )
1504	; Does th is bill ha ve ANY pre scriptions associate d with it?
1505	"RTN","IBC BB1",176,0 )
1506	; Must bi ll prescri ptions sep arately fr om other c harges
1507	"RTN","IBC BB1",177,0 )
1508	;
1509	"RTN","IBC BB1",178,0 )
1510	; DEM;432 - Call li ne level p rovider ed it checks.
1511	"RTN","IBC BB1",179,0 )
1512	D LNPROV^ IBCBB12(IB IFN) ; DE M;432 - If there are line prov ider edits , then rou tine LNPRO V^IBCBB12( IBIFN) upd ates IBER string.
1513	"RTN","IBC BB1",180,0 )
1514	; DEM;432 - Call to Other Ope rating/Ope rating Pro vider edit checks.
1515	"RTN","IBC BB1",181,0 )
1516	I $$OPPRO VCK^IBCBB1 2(IBIFN)=1 S IBER=IB ER_"IB337; " ; DEM;4 32
1517	"RTN","IBC BB1",182,0 )
1518	; DEM;432 - Line le vel Attach ment Contr ol edits.
1519	"RTN","IBC BB1",183,0 )
1520	I $$LNTMC K^IBCBB11( IBIFN)=1 S IBER=IBER _"IB331;" ; DEM;432
1521	"RTN","IBC BB1",184,0 )
1522	I $$LNACC K^IBCBB11( IBIFN)=1 S IBER=IBER _"IB332;" ; DEM;432
1523	"RTN","IBC BB1",185,0 )
1524	;
1525	"RTN","IBC BB1",186,0 )
1526	; vd/Begi nning of I B2577 - Validate L ine Level NDC edits.
1527	"RTN","IBC BB1",187,0 )
1528	I $$LNNDC CK^IBCBB11 (IBIFN)=1 S IBER=IBE R_"IB360;" ;IB257 7
1529	"RTN","IBC BB1",188,0 )
1530	; vd/End of IB257 7
1531	"RTN","IBC BB1",189,0 )
1532	I $$ISRX^ IBCEF1(IBI FN) D
1533	"RTN","IBC BB1",190,0 )
1534	. N IBZ,I BRXDEF
1535	"RTN","IBC BB1",191,0 )
1536	. S IBRXD EF=$P($G(^ IBE(350.9, 1,1)),U,30 ),IBZ=0
1537	"RTN","IBC BB1",192,0 )
1538	. F S IB Z=$O(IBZPR CUB(IBZ)) Q:'IBZ I IBZPRCUB(I BZ),+$P(IB ZPRCUB(IBZ ),U)'=IBRX DEF S IBER =IBER_"IB1 02;" Q
1539	"RTN","IBC BB1",193,0 )
1540	. K IBZ
1541	"RTN","IBC BB1",194,0 )
1542	;
1543	"RTN","IBC BB1",195,0 )
1544	; Check t hat COB se quences ar e not skip ped
1545	"RTN","IBC BB1",196,0 )
1546	K Z
1547	"RTN","IBC BB1",197,0 )
1548	F Z=1:1:3 S:+$G(^DG CR(399,IBI FN,"I"_Z)) Z(Z)=""
1549	"RTN","IBC BB1",198,0 )
1550	F Z=0:1:2 S Z0=$O(Z (Z)) Q:'Z0 I Z0'=(Z +1) S IBER =IBER_"IB3 22;" Q
1551	"RTN","IBC BB1",199,0 )
1552	K Z
1553	"RTN","IBC BB1",200,0 )
1554	; HD64676 IB2371 - OK for payer sequ ence to be blank whe n the Rate
1555	"RTN","IBC BB1",201,0 )
1556	; Type is either Interagen cy or Shar ing Agreem ent
1557	"RTN","IBC BB1",202,0 )
1558	I $P($G(^ DGCR(399,I BIFN,0)),U ,21)="",$P ($G(^DGCR( 399,IBIFN, 0)),U,7)'= 4,$P($G(^D GCR(399,IB IFN,0)),U, 7)'=9 S IB ER=IBER_"I B323;"
1559	"RTN","IBC BB1",203,0 )
1560	K IBXDATA D F^IBCEF ("N-PROCED URE CODING METHD",,, IBIFN)
1561	"RTN","IBC BB1",204,0 )
1562	; Coding method sho uld agree with types of proced ure codes
1563	"RTN","IBC BB1",205,0 )
1564	S IBOK=$S ('$O(IBZPR C(0))!(IBX DATA=""):1 ,1:0)
1565	"RTN","IBC BB1",206,0 )
1566	I 'IBOK S IBOK=1,IB Z=0 F S I BZ=$O(IBZP RC(IBZ)) Q :'IBZ I I BZPRC(IBZ) ,$P(IBZPRC (IBZ),U)'[ $S(IBXDATA =9:"ICD",1 :"ICP") S IBOK=0 Q
1567	"RTN","IBC BB1",207,0 )
1568	I 'IBOK D WARN^IBCB B11("Codin g Method d oes not ag ree with a ll procedu re codes f ound on bi ll")
1569	"RTN","IBC BB1",208,0 )
1570	D EDITMRA ^IBCBB3(.I BQUIT,.IBE R,IBIFN,IB FT)
1571	"RTN","IBC BB1",209,0 )
1572	Q:$G(IBQU IT)
1573	"RTN","IBC BB1",210,0 )
1574	;
1575	"RTN","IBC BB1",211,0 )
1576	;Other th ings that could be a dded: Rev Code - ca lculating charges
1577	"RTN","IBC BB1",212,0 )
1578	; Diagnosis Coding, if MT copay - check fo r other co -payments
1579	"RTN","IBC BB1",213,0 )
1580	;
1581	"RTN","IBC BB1",214,0 )
1582	I $P(IBND TX,U,8),$$ REQMRA^IBE FUNC(IBIFN ) S IBER=I BER_"IB121 ;" ; can 't force M RAs to pri nt
1583	"RTN","IBC BB1",215,0 )
1584	I $P(IBND TX,U,8)!$P (IBNDTX,U, 9) D
1585	"RTN","IBC BB1",216,0 )
1586	. Q:$P(IB NDTX,U,8)= 2 ; Don 't want to do this f or option 2 any more .
1587	"RTN","IBC BB1",217,0 )
1588	. D WARN^ IBCBB11($S ($$REQMRA^ IBEFUNC(IB IFN)&($P(I BNDTX,U,9) ):"MRA Sec ondary ",1 :"")_"Bill has been forced to print "_$S ($P(IBNDTX ,U,8)=1!($ P(IBNDTX,U ,9)=1):"lo cally",1:" at clearin ghouse"))
1589	"RTN","IBC BB1",218,0 )
1590	N IBXZ,IB IZ F IBIZ= 12,13,14 S IBXZ=$P(I BNDM,U,IBI Z) I +IBXZ S IBXZ=$P ($G(^DPT(D FN,.312,IB XZ,0)),U,1 8) I +IBXZ S IBXZ=$G (^IBA(355. 3,+IBXZ,0) ) I +$P(IB XZ,U,12) D
1591	"RTN","IBC BB1",219,0 )
1592	. D WARN^ IBCBB11($P ($G(^DIC(3 6,+IBXZ,0) ),U,1)_" r equires Am b Care Cer tification ")
1593	"RTN","IBC BB1",220,0 )
1594	;
1595	"RTN","IBC BB1",221,0 )
1596	D VALNDC^ IBCBB11(IB IFN,DFN) ;validate NDC#
1597	"RTN","IBC BB1",222,0 )
1598	;
1599	"RTN","IBC BB1",223,0 )
1600	;Build AR array if no errors and MRA no t needed o r already rec'd
1601	"RTN","IBC BB1",224,0 )
1602	I IBER="" ,$S($$NEED MRA^IBEFUN C(IBIFN)!( $$REQMRA^I BEFUNC(IBI FN)):0,1:1 ) D ARRAY
1603	"RTN","IBC BB1",225,0 )
1604	;
1605	"RTN","IBC BB1",226,0 )
1606	;Check RO I
1607	"RTN","IBC BB1",227,0 )
1608	N ROIERR
1609	"RTN","IBC BB1",228,0 )
1610	S ROIERR= 0 I $P($G( ^DGCR(399, IBIFN,"U") ),U,5)=1,+ $P($G(^DGC R(399,IBIF N,"U")),U, 7)=0 S ROI ERR=1 ; sc reen 7 sen sitive rec ord and no ROI
1611	"RTN","IBC BB1",229,0 )
1612	I $$ROICH K^IBCBB11( IBIFN,DFN, +IBNDMP) S ROIERR=1 ; check fi le for sen sitive Rx and missin g ROI
1613	"RTN","IBC BB1",230,0 )
1614	I ROIERR S IBER=IBE R_"IB328;"
1615	"RTN","IBC BB1",231,0 )
1616	;
1617	"RTN","IBC BB1",232,0 )
1618	;Verify L ine Charge s Match Cl aim Total Charge. IB 2.0447 B I
1619	"RTN","IBC BB1",233,0 )
1620	I +$$GET1 ^DIQ(399,I BIFN_",",2 01)'=+$$IB LNTOT^IBCB B13(IBIFN) S IBER=IB ER_"IB344; "
1621	"RTN","IBC BB1",234,0 )
1622	;
1623	"RTN","IBC BB1",235,0 )
1624	;Test for valid EIN /SY ID Val ues. IB2. 0447 BI
1625	"RTN","IBC BB1",236,0 )
1626	I $$IBSYE I^IBCBB13( IBIFN) S I BER=IBER_" IB345;"
1627	"RTN","IBC BB1",237,0 )
1628	;
1629	"RTN","IBC BB1",238,0 )
1630	;Test for a missing ICN. IB2 .0447 BI
1631	"RTN","IBC BB1",239,0 )
1632	I $$IBMIC N^IBCBB13( IBIFN) S I BER=IBER_" IB346;"
1633	"RTN","IBC BB1",240,0 )
1634	;
1635	"RTN","IBC BB1",241,0 )
1636	;Test for a ZERO ch arge amoun ts. IB2.0 447 BI
1637	"RTN","IBC BB1",242,0 )
1638	I $$IBRCC HK^IBCBB13 (IBIFN) D WARN^IBCBB 11("Claim contains r evenue cod es with no associate d charges. ")
1639	"RTN","IBC BB1",243,0 )
1640	;
1641	"RTN","IBC BB1",244,0 )
1642	;Test for missing " Patient re ason for v isit". IB* 2.0*447 BI
1643	"RTN","IBC BB1",245,0 )
1644	I $$FT^IB CEF(IBIFN) =3,'$$INPA T^IBCEF(IB IFN),$$IBP RV3^IBCBB1 3(IBIFN) S IBER=IBER _"IB347;"
1645	"RTN","IBC BB1",246,0 )
1646	;
1647	"RTN","IBC BB1",247,0 )
1648	;Test for missing P ayer ID. I B2.0447 BI
1649	"RTN","IBC BB1",248,0 )
1650	;I $$IBMP ID^IBCBB13 (IBIFN) S IBER=IBER_ "IB348;"
1651	"RTN","IBC BB1",249,0 )
1652	;Changed Error to W arning. IB 2.0447 T AZ
1653	"RTN","IBC BB1",250,0 )
1654	I $$IBMPI D^IBCBB13( IBIFN) D W ARN^IBCBB1 1("Not all payers ha ve Payer I Ds.")
1655	"RTN","IBC BB1",251,0 )
1656	;
1657	"RTN","IBC BB1",252,0 )
1658	;Test for missing " Priority ( Type) of A dmission" for UB-04. IB2.044 7 BI
1659	"RTN","IBC BB1",253,0 )
1660	I $$FT^IB CEF(IBIFN) =3,$$GET1^ DIQ(399,IB IFN_",",15 8)="" S IB ER=IBER_"I B349;"
1661	"RTN","IBC BB1",254,0 )
1662	;
1663	"RTN","IBC BB1",255,0 )
1664	END ;Don't kill IBIF N, IBER, D FN
1665	"RTN","IBC BB1",256,0 )
1666	I $O(^TMP ($J,"BILL- WARN",0)), $G(IBER)=" " S IBER=" WARN" ;War nings only
1667	"RTN","IBC BB1",257,0 )
1668	K IBBNO,I BEVDT,IBLO C,IBCL,IBT F,IBAT,IBW HO,IBST,IB FDT,IBTDT, IBTC,IBFY, IBFY1,IBAU ,IBRU,IBEU ,IBARTP,IB FYC,IBMRA, IBTOB,IBTO B12,IBNDU2 ,IBNDUF3,I BNDUF31,IB NDTX
1669	"RTN","IBC BB1",258,0 )
1670	K IBNDS,I BND0,IBNDU ,IBNDM,IBN DMP,IBNDU1 ,IBFFY,IBT FY,IBFT,IB RTCHV,IBPI CHV,IBXDAT A,IBOK
1671	"RTN","IBC BB1",259,0 )
1672	I $D(IBER ),IBER="" W !,"No Er rors found for Natio nal edits"
1673	"RTN","IBC BB1",260,0 )
1674	Q
1675	"RTN","IBC BB1",261,0 )
1676	;
1677	"RTN","IBC BB1",262,0 )
1678	ARRAY ;Bui ld PRCASV( array)
1679	"RTN","IBC BB1",263,0 )
1680	N IBCOBN, X
1681	"RTN","IBC BB1",264,0 )
1682	K PRCASV
1683	"RTN","IBC BB1",265,0 )
1684	Q:$$MCRWN R^IBEFUNC( +$$CURR^IB CEF2(IBIFN ))
1685	"RTN","IBC BB1",266,0 )
1686	S IBCOBN= $$COBN^IBC EF(IBIFN)
1687	"RTN","IBC BB1",267,0 )
1688	S X=IBIFN
1689	"RTN","IBC BB1",268,0 )
1690	S PRCASV( "BDT")=DT, PRCASV("AR REC")=IBIF N
1691	"RTN","IBC BB1",269,0 )
1692	S PRCASV( "APR")=DUZ
1693	"RTN","IBC BB1",270,0 )
1694	S PRCASV( "PAT")=DFN ,PRCASV("C AT")=$P(^D GCR(399.3, IBAT,0),"^ ",6)
1695	"RTN","IBC BB1",271,0 )
1696	I IBWHO=" i" S PRCAS V("DEBTOR" )=+IBNDMP_ ";DIC(36,"
1697	"RTN","IBC BB1",272,0 )
1698	S PRCASV( "DEBTOR")= $S(IBWHO=" p":DFN_";D PT(",IBWHO ="o":$P(IB NDM,"^",11 )_";DIC(4, ",IBWHO="i ":PRCASV(" DEBTOR"),1 :"")
1699	"RTN","IBC BB1",273,0 )
1700	S PRCASV( "CARE")=$E ($$TOB^IBC EF1(IBIFN) ,1,2)
1701	"RTN","IBC BB1",274,0 )
1702	S PRCASV( "FY")=$$FY ^IBOUTL(DT )_U_($P(IB NDU1,U)-$P (IBNDU1,U, 2))
1703	"RTN","IBC BB1",275,0 )
1704	;S PRCASV ("FY")=$P( IBNDU1,U,9 )_U_$S($P( IBNDU1,U,2 )]"":($P(I BNDU1,U,10 )-$P(IBNDU 1,U,2)),1: $P(IBNDU1, U,10))_$S( $P(IBNDU1, U,11)]"":U _$P(IBNDU1 ,U,11)_U_$ P(IBNDU1,U ,12),1:"")
1705	"RTN","IBC BB1",276,0 )
1706	PLUS I IBW HO="i",$P( IBNDM,"^", 2),$D(^DIC (36,$P(IBN DM,"^",2), 0)) S PRCA SV("2NDINS ")=$P(IBND M,"^",2)
1707	"RTN","IBC BB1",277,0 )
1708	I IBWHO=" i",$P(IBND M,"^",3),$ D(^DIC(36, $P(IBNDM," ^",3),0)) S PRCASV(" 3RDINS")=$ P(IBNDM,"^ ",3)
1709	"RTN","IBC BB1",278,0 )
1710	;
1711	"RTN","IBC BB1",279,0 )
1712	N IBX S I BX=$P(IBND 0,U,21),IB X=$S(IBX=" P":"I1",IB X="S":"I2" ,IBX="T":" I3",1:"") Q:IBX=""
1713	"RTN","IBC BB1",280,0 )
1714	N IBNDI1
1715	"RTN","IBC BB1",281,0 )
1716	Q:'$D(^DG CR(399,IBI FN,IBX)) S IBNDI1=^ (IBX)
1717	"RTN","IBC BB1",282,0 )
1718	S:$P(IBND I1,"^",3)] "" PRCASV( "GPNO")=$P (IBNDI1,"^ ",3)
1719	"RTN","IBC BB1",283,0 )
1720	S:$P(IBND I1,"^",15) ]"" PRCASV ("GPNM")=$ P(IBNDI1," ^",15)
1721	"RTN","IBC BB1",284,0 )
1722	S:$P(IBND I1,"^",17) ]"" PRCASV ("INPA")=$ P(IBNDI1," ^",17)
1723	"RTN","IBC BB1",285,0 )
1724	S:$P(IBND I1,"^",2)] "" PRCASV( "IDNO")=$P (IBNDI1,"^ ",2),PRCAS V("INID")= PRCASV("ID NO")
1725	"RTN","IBC BB1",286,0 )
1726	; Check t hat this i s a second ary or ter tiary bill and insur ance for p revious
1727	"RTN","IBC BB1",287,0 )
1728	; COB seq uence is M edicare WN R and MRA is active --> send d ata elemen ts to AR
1729	"RTN","IBC BB1",288,0 )
1730	I IBCOBN> 1,$$WNRBIL L^IBEFUNC( IBIFN,IBCO BN-1),$$ED IACTV^IBCE F4(2) D MR A
1731	"RTN","IBC BB1",289,0 )
1732	Q
1733	"RTN","IBC BB1",290,0 )
1734	;
1735	"RTN","IBC BB1",291,0 )
1736	MRA N IBEO B S IBEOB= 0
1737	"RTN","IBC BB1",292,0 )
1738	;
1739	"RTN","IBC BB1",293,0 )
1740	K PRCASV( "MEDURE"), PRCASV("ME DCA")
1741	"RTN","IBC BB1",294,0 )
1742	; Get EOB data
1743	"RTN","IBC BB1",295,0 )
1744	F S IBEO B=$O(^IBM( 361.1,"B", IBIFN,IBEO B)) Q:'IBE OB D
1745	"RTN","IBC BB1",296,0 )
1746	. D MRACA LC^IBCEMU2 (IBEOB,IBI FN,1,.PRCA SV)
1747	"RTN","IBC BB1",297,0 )
1748	Q ;MRA
1749	"RTN","IBC BB1",298,0 )
1750	;
1751	"RTN","IBC BB1",299,0 )
1752	;; PREGNA NCY DX COD ES: V22- V24, V27 -V28, 630*-677 *
1753	"RTN","IBC BB1",300,0 )
1754	;; FLU SH OTS PROCED URE CODES: 90724, G0 008, 90732 , G0009
1755	"RTN","IBC BB1",301,0 )
1756	;
1757	"RTN","IBC BB1",302,0 )
1758	NONVAFLG(I BIFN) ; Ch eck if Non -VA bill
1759	"RTN","IBC BB1",303,0 )
1760	; Functio n returns 1 if Non-V A bill
1761	"RTN","IBC BB1",304,0 )
1762	; IB2.0 554/DRF 10 /9/2015
1763	"RTN","IBC BB1",305,0 )
1764	N FLAG,PT F
1765	"RTN","IBC BB1",306,0 )
1766	S FLAG=0
1767	"RTN","IBC BB1",307,0 )
1768	I $P($G(^ DGCR(399,I BIFN,"U2") ),U,10)]"" S FLAG=1 ;Non-VA pr ovider def ined
1769	"RTN","IBC BB1",308,0 )
1770	S PTF=$P( $G(^DGCR(3 99,IBIFN,0 )),U,8)
1771	"RTN","IBC BB1",309,0 )
1772	I PTF,$P( $G(^DGPT(P TF,0)),U,4 )=1 S FLAG =1 ;PTF en try indica tes Non-VA
1773	"RTN","IBC BB1",310,0 )
1774	Q FLAG
1775	"RTN","IBC BB11")
1776	0^3^B11205 2327^B9646 4375
1777	"RTN","IBC BB11",1,0)
1778	IBCBB11 ;A LB/AAS/OIF O-BP/PIJ - CONTINUAT ION OF EDI T CHECK RO UTINE ;12 Jun 2006 3:45 PM
1779	"RTN","IBC BB11",2,0)
1780	;;2.0;INT EGRATED BI LLING;51 ,343,363,3 71,395,392 ,401,384,4 00,436,432 ,516,550,5 77;21-MA R-94;Build 34
1781	"RTN","IBC BB11",3,0)
1782	;;Per VA Directive 6402, this routine s hould not be modifie d.
1783	"RTN","IBC BB11",4,0)
1784	;
1785	"RTN","IBC BB11",5,0)
1786	WARN(IBDIS P) ; Set w arning in global
1787	"RTN","IBC BB11",6,0)
1788	; DISP = warning te xt to disp lay
1789	"RTN","IBC BB11",7,0)
1790	;
1791	"RTN","IBC BB11",8,0)
1792	N Z
1793	"RTN","IBC BB11",9,0)
1794	S Z=+$O(^ TMP($J,"BI LL-WARN"," "),-1)
1795	"RTN","IBC BB11",10,0 )
1796	I Z=0 S ^ TMP($J,"BI LL-WARN",1 )=$J("",5) _"Warnin gs:",Z=1
1797	"RTN","IBC BB11",11,0 )
1798	S Z=Z+1,^ TMP($J,"BI LL-WARN",Z )=$J("",5) _IBDISP
1799	"RTN","IBC BB11",12,0 )
1800	Q
1801	"RTN","IBC BB11",13,0 )
1802	;
1803	"RTN","IBC BB11",14,0 )
1804	MULTDIV(IB IFN,IBND0) ; Check f or multipl e division s on a bil l ien IBIF N
1805	"RTN","IBC BB11",15,0 )
1806	; IBND0 = 0-node of bill
1807	"RTN","IBC BB11",16,0 )
1808	;
1809	"RTN","IBC BB11",17,0 )
1810	; Functi on returns 1 if more than 1 di vision fou nd on bill
1811	"RTN","IBC BB11",18,0 )
1812	N Z,Z0,Z1 ,MULT
1813	"RTN","IBC BB11",19,0 )
1814	S MULT=0, Z1=$P(IBND 0,U,22)
1815	"RTN","IBC BB11",20,0 )
1816	I Z1 D
1817	"RTN","IBC BB11",21,0 )
1818	. S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"RC", Z)) Q:'Z S Z0=$P(^( Z,0),U,7) I Z0,Z0'=Z 1 S MULT=1 Q
1819	"RTN","IBC BB11",22,0 )
1820	. S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"CP", Z)) Q:'Z S Z0=$P(^( Z,0),U,6) I Z0,Z0'=Z 1 S MULT=2 Q
1821	"RTN","IBC BB11",23,0 )
1822	I 'Z1 S M ULT=3
1823	"RTN","IBC BB11",24,0 )
1824	Q MULT
1825	"RTN","IBC BB11",25,0 )
1826	;
1827	"RTN","IBC BB11",26,0 )
1828	;; PREGNA NCY DX COD ES: V22- V24, V27 -V28, 630*-677 *
1829	"RTN","IBC BB11",27,0 )
1830	;; FLU SH OTS PROCED URE CODES: 90724, G0 008, 90732 , G0009
1831	"RTN","IBC BB11",28,0 )
1832	;
1833	"RTN","IBC BB11",29,0 )
1834	NPICHK ; C heck for r equired NP Is
1835	"RTN","IBC BB11",30,0 )
1836	N IBNPIS, IBNONPI,IB NPIREQ,Z,I BNFI,IBTF, IBWC,IBXSA VE,IBPRV,I BLINE
1837	"RTN","IBC BB11",31,0 )
1838	;*** pij start IB2 0436 ***
1839	"RTN","IBC BB11",32,0 )
1840	N IBRATYP E,IBLEGAL
1841	"RTN","IBC BB11",33,0 )
1842	S (IBRATY PE,IBLEGAL )=""
1843	"RTN","IBC BB11",34,0 )
1844	S IBRATYP E=$P($G(^D GCR(399,IB IFN,0)),U, 7)
1845	"RTN","IBC BB11",35,0 )
1846	; Legal t ypes for t his use.
1847	"RTN","IBC BB11",36,0 )
1848	; 7=NO F AULT INS.
1849	"RTN","IBC BB11",37,0 )
1850	; 10=TORT FEASOR
1851	"RTN","IBC BB11",38,0 )
1852	; 11=WORK ERS' COMP.
1853	"RTN","IBC BB11",39,0 )
1854	S IBNFI=$ O(^DGCR(39 9.3,"B","N O FAULT IN S.",0)) S: 'IBNFI IBN FI=7
1855	"RTN","IBC BB11",40,0 )
1856	S IBTF=$O (^DGCR(399 .3,"B","TO RT FEASOR" ,0)) S:'IB TF IBTF=10
1857	"RTN","IBC BB11",41,0 )
1858	S IBWC=$O (^DGCR(399 .3,"B","WO RKERS' COM P.",0)) S: 'IBWC IBWC =11
1859	"RTN","IBC BB11",42,0 )
1860	;
1861	"RTN","IBC BB11",43,0 )
1862	I IBRATYP E=IBNFI!(I BRATYPE=IB TF)!(IBRAT YPE=IBWC) D
1863	"RTN","IBC BB11",44,0 )
1864	. ; One o f the lega l types - force loca l print
1865	"RTN","IBC BB11",45,0 )
1866	. S IBLEG AL=1
1867	"RTN","IBC BB11",46,0 )
1868	;* pij end *
1869	"RTN","IBC BB11",47,0 )
1870	S IBNPIRE Q=$$NPIREQ ^IBCEP81(D T) ; Chec k if NPI i s required
1871	"RTN","IBC BB11",48,0 )
1872	; Check p roviders
1873	"RTN","IBC BB11",49,0 )
1874	; IB2.0 432 change d the NPI check to t he new Pro vider Arra y
1875	"RTN","IBC BB11",50,0 )
1876	;S IBNPIS =$$PROVNPI ^IBCEF73A( IBIFN,.IBN ONPI)
1877	"RTN","IBC BB11",51,0 )
1878	D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1)
1879	"RTN","IBC BB11",52,0 )
1880	S IBPRV=" "
1881	"RTN","IBC BB11",53,0 )
1882	F S IBPR V=$O(IBXSA VE("PROVIN F",IBIFN," C",1,IBPRV )) Q:'IBPR V D
1883	"RTN","IBC BB11",54,0 )
1884	. I $P($G (IBXSAVE(" PROVINF",I BIFN,"C",1 ,IBPRV,0)) ,U,4)="" S IBNONPI(I BPRV)=""
1885	"RTN","IBC BB11",55,0 )
1886	S IBLINE= ""
1887	"RTN","IBC BB11",56,0 )
1888	F S IBLI NE=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE)) Q: 'IBLINE D
1889	"RTN","IBC BB11",57,0 )
1890	. S IBPRV =""
1891	"RTN","IBC BB11",58,0 )
1892	. F S IB PRV=$O(IBX SAVE("L-PR OV",IBIFN, IBLINE,"C" ,1,IBPRV)) Q:IBPRV=" " D
1893	"RTN","IBC BB11",59,0 )
1894	.. I $P($ G(IBXSAVE( "L-PROV",I BIFN,IBLIN E,"C",1,IB PRV,0)),U, 4)="" S IB NONPI(IBPR V)=""
1895	"RTN","IBC BB11",60,0 )
1896	I $D(IBNO NPI) S IBP RV="" F S IBPRV=$O( IBNONPI(IB PRV)) Q:'I BPRV D
1897	"RTN","IBC BB11",61,0 )
1898	. S IBER= IBER_"IB"_ (140+IBPRV )_";" Q ; If requir ed, set er ror IB25 16
1899	"RTN","IBC BB11",62,0 )
1900	; Check o rganizatio ns
1901	"RTN","IBC BB11",63,0 )
1902	S IBNONPI =""
1903	"RTN","IBC BB11",64,0 )
1904	S IBNPIS= $$ORGNPI^I BCEF73A(IB IFN,.IBNON PI)
1905	"RTN","IBC BB11",65,0 )
1906	I $L(IBNO NPI) F Z=1 :1:$L(IBNO NPI,U) D
1907	"RTN","IBC BB11",66,0 )
1908	. S IBER= IBER_$P("I B339;^IB34 0;^IB341;" ,U,$P(IBNO NPI,U,Z)) ; DEM;432 Added NPI errors.
1909	"RTN","IBC BB11",67,0 )
1910	Q
1911	"RTN","IBC BB11",68,0 )
1912	;
1913	"RTN","IBC BB11",69,0 )
1914	TAXCHK ; C heck for r equired ta xonomies
1915	"RTN","IBC BB11",70,0 )
1916	N IBDT,IB LINE,IBNOT AX,IBPRV,I BTAXS,IBXS AVE,Z
1917	"RTN","IBC BB11",71,0 )
1918	;
1919	"RTN","IBC BB11",72,0 )
1920	; MRD;IB* 2.0*516 - This check is now mo ot; 'today ' is alway s on or
1921	"RTN","IBC BB11",73,0 )
1922	; after M ay 23, 200 8, so taxo nomy codes are alway s required
1923	"RTN","IBC BB11",74,0 )
1924	; for cer tain provi ders.
1925	"RTN","IBC BB11",75,0 )
1926	;S IBTAXR EQ=$$TAXRE Q^IBCEP81( DT) ; Che ck if taxo nomy is re quired
1927	"RTN","IBC BB11",76,0 )
1928	;
1929	"RTN","IBC BB11",77,0 )
1930	; Check p roviders
1931	"RTN","IBC BB11",78,0 )
1932	; IB2.0 432 change d the Taxo nomy check to the ne w Provider Array
1933	"RTN","IBC BB11",79,0 )
1934	;S IBTAXS =$$PROVTAX ^IBCEF73A( IBIFN,.IBN OTAX)
1935	"RTN","IBC BB11",80,0 )
1936	D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1)
1937	"RTN","IBC BB11",81,0 )
1938	S IBPRV=" "
1939	"RTN","IBC BB11",82,0 )
1940	F S IBPR V=$O(IBXSA VE("PROVIN F",IBIFN," C",1,IBPRV )) Q:'IBPR V D
1941	"RTN","IBC BB11",83,0 )
1942	. I $G(IB XSAVE("PRO VINF",IBIF N,"C",1,IB PRV,"TAXON OMY"))="" S IBNOTAX( IBPRV)=""
1943	"RTN","IBC BB11",84,0 )
1944	. Q
1945	"RTN","IBC BB11",85,0 )
1946	;
1947	"RTN","IBC BB11",86,0 )
1948	S IBLINE= ""
1949	"RTN","IBC BB11",87,0 )
1950	F S IBLI NE=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE)) Q: 'IBLINE D
1951	"RTN","IBC BB11",88,0 )
1952	. S IBPRV =""
1953	"RTN","IBC BB11",89,0 )
1954	. F S IB PRV=$O(IBX SAVE("L-PR OV",IBIFN, IBLINE,"C" ,1,IBPRV)) Q:IBPRV=" " D
1955	"RTN","IBC BB11",90,0 )
1956	. . I $G( IBXSAVE("L -PROV",IBI FN,IBLINE, "C",1,IBPR V,"TAXONOM Y"))="" S IBNOTAX(IB PRV)=""
1957	"RTN","IBC BB11",91,0 )
1958	. . Q
1959	"RTN","IBC BB11",92,0 )
1960	. Q
1961	"RTN","IBC BB11",93,0 )
1962	;
1963	"RTN","IBC BB11",94,0 )
1964	; IB251 = Referring provider taxonomy m issing.
1965	"RTN","IBC BB11",95,0 )
1966	; IB253 = Rendering provider taxonomy m issing.
1967	"RTN","IBC BB11",96,0 )
1968	; IB254 = Attending provider taxonomy m issing.
1969	"RTN","IBC BB11",97,0 )
1970	;
1971	"RTN","IBC BB11",98,0 )
1972	I $D(IBNO TAX) S IBP RV="" F S IBPRV=$O( IBNOTAX(IB PRV)) Q:'I BPRV D
1973	"RTN","IBC BB11",99,0 )
1974	. ; Only Referring, Rendering and Atten ding are c urrently s ent to the payer
1975	"RTN","IBC BB11",100, 0)
1976	. ;I IBTA XREQ,"134" [IBPRV S I BER=IBER_" IB"_(250+I BPRV)_";" Q ; MRD;I B2.0516 - Always r equired.
1977	"RTN","IBC BB11",101, 0)
1978	. I "134" [IBPRV S I BER=IBER_" IB"_(250+I BPRV)_";" Q ; If re quired, se t error an d quit
1979	"RTN","IBC BB11",102, 0)
1980	. D WARN( "Taxonomy for the "_ $P("referr ing^operat ing^render ing^attend ing^superv ising^^^^o ther",U,IB PRV)_" pro vider has no value") ; Else, set warnin g
1981	"RTN","IBC BB11",103, 0)
1982	. Q
1983	"RTN","IBC BB11",104, 0)
1984	;
1985	"RTN","IBC BB11",105, 0)
1986	; Check o rganizatio ns. The f unction OR GTAX will set IBNOTA X to be a
1987	"RTN","IBC BB11",106, 0)
1988	; list of entities missing ta xonomy cod es, if any (n, n^m, n^m^p,
1989	"RTN","IBC BB11",107, 0)
1990	; where e ach 1 is s ervice fac ility, 2 i s non-VA s ervice fac ility and
1991	"RTN","IBC BB11",108, 0)
1992	; 3 is bi lling prov ider.
1993	"RTN","IBC BB11",109, 0)
1994	;
1995	"RTN","IBC BB11",110, 0)
1996	S IBNOTAX =""
1997	"RTN","IBC BB11",111, 0)
1998	S IBTAXS= $$ORGTAX^I BCEF73A(IB IFN,.IBNOT AX)
1999	"RTN","IBC BB11",112, 0)
2000	I $L(IBNO TAX) F Z=1 :1:$L(IBNO TAX,U) D
2001	"RTN","IBC BB11",113, 0)
2002	. ; IB167 = Billing Provider taxonomy m issing.
2003	"RTN","IBC BB11",114, 0)
2004	. ;I IBTA XREQ,$P(IB NOTAX,U,Z) =3 S IBER= IBER_"IB16 7;" Q ; M RD;IB2.0 516 - Alwa ys require d.
2005	"RTN","IBC BB11",115, 0)
2006	. I $P(IB NOTAX,U,Z) =3 S IBER= IBER_"IB16 7;" Q
2007	"RTN","IBC BB11",116, 0)
2008	. ; MRD;I B2.0516 - Remove w arning mes sage for m issing tax onomy code for lab o r facility .
2009	"RTN","IBC BB11",117, 0)
2010	. ; D WAR N("Taxonom y for the "_$P("Serv ice Facili ty^Non-VA Service Fa cility^Bil ling Provi der",U,$P( IBNOTAX,U, Z))_" has no value") ; Else, set warnin g
2011	"RTN","IBC BB11",118, 0)
2012	. Q
2013	"RTN","IBC BB11",119, 0)
2014	;
2015	"RTN","IBC BB11",120, 0)
2016	Q
2017	"RTN","IBC BB11",121, 0)
2018	;
2019	"RTN","IBC BB11",122, 0)
2020	VALNDC(IBI FN,IBDFN) ; IB2363 - validat e NDC# bet ween PRESC RIPTION fi le (#52)
2021	"RTN","IBC BB11",123, 0)
2022	; and IB BILL/CLAIM S PRESCRIP TION REFIL L file (#3 62.4)
2023	"RTN","IBC BB11",124, 0)
2024	; input - IBIFN = i nternal en try number of the bi lling reco rd in the BILL/CLAIM S file (#3 99)
2025	"RTN","IBC BB11",125, 0)
2026	; IBDFN = i nternal en try number of patien t record i n the PATI ENT file ( #2)
2027	"RTN","IBC BB11",126, 0)
2028	N IBX,IBR XCOL
2029	"RTN","IBC BB11",127, 0)
2030	; call pr ogram that determine s if NDC d ifferences exist
2031	"RTN","IBC BB11",128, 0)
2032	D VALNDC^ IBEFUNC3(I BIFN,IBDFN ,.IBRXCOL)
2033	"RTN","IBC BB11",129, 0)
2034	Q:'$D(IBR XCOL)
2035	"RTN","IBC BB11",130, 0)
2036	; at leas t one RX o n the IB r ecord has an NDC dis crepancy
2037	"RTN","IBC BB11",131, 0)
2038	S IBX=0 F S IBX=$O (IBRXCOL(I BX)) Q:'IB X D WARN( "NDC# on B ill does n ot equal t he NDC# on Rx "_IBRX COL(IBX))
2039	"RTN","IBC BB11",132, 0)
2040	Q
2041	"RTN","IBC BB11",133, 0)
2042	;
2043	"RTN","IBC BB11",134, 0)
2044	PRIIDCHK ; Check for required Pimarary I D (SSN/EIN )
2045	"RTN","IBC BB11",135, 0)
2046	; If the provider i s on the c laim, he m ust have o ne
2047	"RTN","IBC BB11",136, 0)
2048	;
2049	"RTN","IBC BB11",137, 0)
2050	N IBI,IBZ
2051	"RTN","IBC BB11",138, 0)
2052	I $$TXMT^ IBCEF4(IBI FN) D
2053	"RTN","IBC BB11",139, 0)
2054	. D F^IBC EF("N-ALL ATT/REND P ROV SSN/EI ","IBZ",,I BIFN)
2055	"RTN","IBC BB11",140, 0)
2056	. S IBI=" " F S IBI =$O(^DGCR( 399,IBIFN, "PRV","B", IBI)) Q:IB I="" D
2057	"RTN","IBC BB11",141, 0)
2058	.. I $P(I BZ,U,IBI)= "" S IBER= IBER_$S(IB I=1:"IB151 ;",IBI=2:" IB152;",IB I=3!(IBI=4 ):"IB321;" ,IBI=5:"IB 153;",IBI= 9:"IB154;" ,1:"")
2059	"RTN","IBC BB11",142, 0)
2060	Q
2061	"RTN","IBC BB11",143, 0)
2062	;
2063	"RTN","IBC BB11",144, 0)
2064	RXNPI(IBIF N) ; check for multi ple pharma cy npi's o n the same bill
2065	"RTN","IBC BB11",145, 0)
2066	N IBORG,I BRXNPI,IBX ,IBY
2067	"RTN","IBC BB11",146, 0)
2068	S IBORG=$ $RXSITE^IB CEF73A(IBI FN,.IBORG)
2069	"RTN","IBC BB11",147, 0)
2070	S IBX=0 F S IBX=$O (IBORG(IBX )) Q:'IBX S IBY=0 F S IBY=$O (IBORG(IBX ,IBY)) Q:' IBY S IBR XNPI(+IBOR G(IBX,IBY) )=""
2071	"RTN","IBC BB11",148, 0)
2072	S (IBX,IB Y)=0 F S IBX=$O(IBR XNPI(IBX)) Q:'IBX S IBY=IBY+1
2073	"RTN","IBC BB11",149, 0)
2074	I IBY>1 D WARN("Bil l has pres criptions resulting from "_IBY _" differe nt NPI loc ations")
2075	"RTN","IBC BB11",150, 0)
2076	Q
2077	"RTN","IBC BB11",151, 0)
2078	;
2079	"RTN","IBC BB11",152, 0)
2080	ROICHK(IBI FN,IBDFN,I BINS) ; IB 2.0384 - check pre scriptions that cont ain the
2081	"RTN","IBC BB11",153, 0)
2082	; SENSITI VE DIAGNOS IS DRUG fi eld #87 in the DRUG File #50 s et to 1 ag ainst
2083	"RTN","IBC BB11",154, 0)
2084	; the Cla ims Tracki ng ROI fil e (#356.25 ) to see i f an ROI i s on file
2085	"RTN","IBC BB11",155, 0)
2086	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
2087	"RTN","IBC BB11",156, 0)
2088	; IBDFN = I EN of the patient
2089	"RTN","IBC BB11",157, 0)
2090	; IBINS = I EN of the payer insu rance comp any (#36)
2091	"RTN","IBC BB11",158, 0)
2092	; OUTPUT - 0 = no e rror
2093	"RTN","IBC BB11",159, 0)
2094	; 1 = a pr escription is sensit ive and th ere is no ROI on fil e
2095	"RTN","IBC BB11",160, 0)
2096	;
2097	"RTN","IBC BB11",161, 0)
2098	N IBX,IBY 0,IBRXIEN, IBDT,IBDRU G,ROIQ
2099	"RTN","IBC BB11",162, 0)
2100	S ROIQ=0
2101	"RTN","IBC BB11",163, 0)
2102	S IBX=0 F S IBX=$O (^IBA(362. 4,"C",IBIF N,IBX)) Q: 'IBX D
2103	"RTN","IBC BB11",164, 0)
2104	.S IBY0=^ IBA(362.4, IBX,0),IBR XIEN=$P(IB Y0,U,5) I 'IBRXIEN Q
2105	"RTN","IBC BB11",165, 0)
2106	.S IBDT=$ P(IBY0,U,3 ),IBDRUG=$ P(IBY0,U,4 )
2107	"RTN","IBC BB11",166, 0)
2108	.D ZERO^I BRXUTL(IBD RUG)
2109	"RTN","IBC BB11",167, 0)
2110	.I $$SENS ^IBNCPDR(I BDRUG) D ; Sensitiv e Diagnosi s Drug - c heck for R OI
2111	"RTN","IBC BB11",168, 0)
2112	.. I $$RO I^IBNCPDR4 (IBDFN,IBD RUG,IBINS, IBDT) Q ; ROI is on file
2113	"RTN","IBC BB11",169, 0)
2114	.. D WARN ("ROI not on file fo r prescrip tion "_$$R XAPI1^IBNC PUT1(IBRXI EN,.01,"E" ))
2115	"RTN","IBC BB11",170, 0)
2116	.. S ROIQ =1
2117	"RTN","IBC BB11",171, 0)
2118	ROICHKQ ;
2119	"RTN","IBC BB11",172, 0)
2120	K ^TMP($J ,"IBDRUG")
2121	"RTN","IBC BB11",173, 0)
2122	Q ROIQ
2123	"RTN","IBC BB11",174, 0)
2124	;
2125	"RTN","IBC BB11",175, 0)
2126	AMBCK(IBIF N) ; IB 2.0432 - if ambula nce locati on defined , address must be de fined
2127	"RTN","IBC BB11",176, 0)
2128	; if ther e is anyth ing entere d in any o f the addr ess fields (either p /up or dro p/off fiel ds), than there need s to be:
2129	"RTN","IBC BB11",177, 0)
2130	; Address 1, State and ZIP un less the S tate is no t a US sta te or poss ession, th en zip cod e is not n eeded (CMS 1500 only)
2131	"RTN","IBC BB11",178, 0)
2132	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
2133	"RTN","IBC BB11",179, 0)
2134	; OUTPUT - 0 = no e rror
2135	"RTN","IBC BB11",180, 0)
2136	; 1 = Erro r
2137	"RTN","IBC BB11",181, 0)
2138	;
2139	"RTN","IBC BB11",182, 0)
2140	N IBPAMB, IBDAMB,IBA MBR,IBCK
2141	"RTN","IBC BB11",183, 0)
2142	S IBAMBR= 0
2143	"RTN","IBC BB11",184, 0)
2144	Q:$$INSPR F^IBCEF(IB IFN)'=0 IB AMBR
2145	"RTN","IBC BB11",185, 0)
2146	S IBPAMB= $G(^DGCR(3 99,IBIFN," U5")),IBDA MB=$G(^DGC R(399,IBIF N,"U6"))
2147	"RTN","IBC BB11",186, 0)
2148	S IBCK(5) =$$NOPUNCT ^IBCEF($P( IBPAMB,U,2 ,6),1),IBC K(6)=$$NOP UNCT^IBCEF ($P(IBDAMB ,U,1,6),1)
2149	"RTN","IBC BB11",187, 0)
2150	I IBCK(5) ="",IBCK(6 )="" Q IBA MBR
2151	"RTN","IBC BB11",188, 0)
2152	; at this point we know that at least o ne ambulan ce field h as data, s o check to see if al l have dat a
2153	"RTN","IBC BB11",189, 0)
2154	I IBCK(5) '="" F I=2 ,4,5 I $P( IBPAMB,U,I )="" S IBA MBR=1
2155	"RTN","IBC BB11",190, 0)
2156	I IBCK(6) '="" F I=1 ,2,4,5 I $ P(IBDAMB,U ,I)="" S I BAMBR=1
2157	"RTN","IBC BB11",191, 0)
2158	Q:IBAMBR= 1 IBAMBR
2159	"RTN","IBC BB11",192, 0)
2160	; now che ck zip cod e. OK to be null if state is not a US P osession
2161	"RTN","IBC BB11",193, 0)
2162	F I="IBPA MB","IBDAM B" I $P(I, U,5)'="",$ P($G(^DIC( 5,$P(I,U,5 ),0)),U,6) =1,$P(I,U, 6)="" S IB AMBR=1
2163	"RTN","IBC BB11",194, 0)
2164	Q IBAMBR
2165	"RTN","IBC BB11",195, 0)
2166	;
2167	"RTN","IBC BB11",196, 0)
2168	COBAMT(IBI FN) ; IB 2.0432 - IF there is a COB a mt. it mus t equal th e Total Cl aim Charge Amount
2169	"RTN","IBC BB11",197, 0)
2170	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
2171	"RTN","IBC BB11",198, 0)
2172	; OUTPUT - 0 = no e rror
2173	"RTN","IBC BB11",199, 0)
2174	; 1 = Erro r
2175	"RTN","IBC BB11",200, 0)
2176	;
2177	"RTN","IBC BB11",201, 0)
2178	Q:IBIFN=" " 0
2179	"RTN","IBC BB11",202, 0)
2180	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)="" 0
2181	"RTN","IBC BB11",203, 0)
2182	Q:+$P($G( ^DGCR(399, IBIFN,"U1" )),U)'=+$P ($G(^DGCR( 399,IBIFN, "U4")),U) 1
2183	"RTN","IBC BB11",204, 0)
2184	Q 0
2185	"RTN","IBC BB11",205, 0)
2186	;
2187	"RTN","IBC BB11",206, 0)
2188	COBMRA(IBI FN) ; IB 2.0432 - If there is a 'COB total non- covered am ount' (Fil e#399, Fie ld#260),
2189	"RTN","IBC BB11",207, 0)
2190	; Primary Insurance must be M edicare th at never w ent to Med icare, and this must be a 2nda ry or tert iary claim
2191	"RTN","IBC BB11",208, 0)
2192	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
2193	"RTN","IBC BB11",209, 0)
2194	; OUTPUT - 0 = no e rror
2195	"RTN","IBC BB11",210, 0)
2196	; 1 = Erro r
2197	"RTN","IBC BB11",211, 0)
2198	;
2199	"RTN","IBC BB11",212, 0)
2200	N IBP
2201	"RTN","IBC BB11",213, 0)
2202	Q:IBIFN=" " 0
2203	"RTN","IBC BB11",214, 0)
2204	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)="" 0
2205	"RTN","IBC BB11",215, 0)
2206	S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN
2207	"RTN","IBC BB11",216, 0)
2208	I $$WNRBI LL^IBEFUNC (IBIFN,1), $P($G(^DGC R(399,IBP, "S")),U,7) ="",$$COBN ^IBCEF(IBI FN)>1 Q 0
2209	"RTN","IBC BB11",217, 0)
2210	Q 1
2211	"RTN","IBC BB11",218, 0)
2212	;
2213	"RTN","IBC BB11",219, 0)
2214	COBSEC(IBI FN) ; IB 2.0432 - If there is NOT a ' COB total non-covere d amount' (File#399, Field#260 ),
2215	"RTN","IBC BB11",220, 0)
2216	; and Pri mary Insur ance is Me dicare tha t never we nt to Medi care, 2nda ry or tert iary claim cannot be set to tr ansmit
2217	"RTN","IBC BB11",221, 0)
2218	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
2219	"RTN","IBC BB11",222, 0)
2220	; OUTPUT - 0 = no e rror
2221	"RTN","IBC BB11",223, 0)
2222	; 1 = Erro r
2223	"RTN","IBC BB11",224, 0)
2224	;
2225	"RTN","IBC BB11",225, 0)
2226	N IBP
2227	"RTN","IBC BB11",226, 0)
2228	Q:IBIFN=" " 0
2229	"RTN","IBC BB11",227, 0)
2230	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)'="" 0
2231	"RTN","IBC BB11",228, 0)
2232	Q:$$COBN^ IBCEF(IBIF N)<2 0
2233	"RTN","IBC BB11",229, 0)
2234	S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN
2235	"RTN","IBC BB11",230, 0)
2236	I $$WNRBI LL^IBEFUNC (IBIFN,1), $P($G(^DGC R(399,IBP, "S")),U,7) ="",$P($G( ^DGCR(399, IBIFN,"TX" )),U,8)'=1 Q 1
2237	"RTN","IBC BB11",231, 0)
2238	Q 0
2239	"RTN","IBC BB11",232, 0)
2240	;
2241	"RTN","IBC BB11",233, 0)
2242	TMCK(IBIFN ) ; IB2. 0432 - At tachment C ontrol Num ber - REQU IRED when Transmissi on Method = BM, EL, EM, or FT
2243	"RTN","IBC BB11",234, 0)
2244	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
2245	"RTN","IBC BB11",235, 0)
2246	; OUTPUT - 0 = no e rror
2247	"RTN","IBC BB11",236, 0)
2248	; 1 = Erro r
2249	"RTN","IBC BB11",237, 0)
2250	;
2251	"RTN","IBC BB11",238, 0)
2252	N IBAC
2253	"RTN","IBC BB11",239, 0)
2254	Q:IBIFN=" " 0
2255	"RTN","IBC BB11",240, 0)
2256	F I=1,3 S IBAC(I)=$ P($G(^DGCR (399,IBIFN ,"U8")),U, I)
2257	"RTN","IBC BB11",241, 0)
2258	Q:IBAC(3) ="" 0
2259	"RTN","IBC BB11",242, 0)
2260	Q:IBAC(1) '="" 0
2261	"RTN","IBC BB11",243, 0)
2262	Q:IBAC(3) ="AA" 0
2263	"RTN","IBC BB11",244, 0)
2264	Q 1
2265	"RTN","IBC BB11",245, 0)
2266	;
2267	"RTN","IBC BB11",246, 0)
2268	ACCK(IBIFN ) ; IB2.0 432 If an y of the l oop info i s present, then Repo rt Type & Transmissi on Method req'd
2269	"RTN","IBC BB11",247, 0)
2270	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
2271	"RTN","IBC BB11",248, 0)
2272	; OUTPUT - 0 = no e rror
2273	"RTN","IBC BB11",249, 0)
2274	; 1 = Erro r
2275	"RTN","IBC BB11",250, 0)
2276	;
2277	"RTN","IBC BB11",251, 0)
2278	N IBAC
2279	"RTN","IBC BB11",252, 0)
2280	Q:IBIFN=" " 0
2281	"RTN","IBC BB11",253, 0)
2282	F I=1:1:3 S IBAC(I) =$P($G(^DG CR(399,IBI FN,"U8")), U,I)
2283	"RTN","IBC BB11",254, 0)
2284	; All fie lds null, no error
2285	"RTN","IBC BB11",255, 0)
2286	I IBAC(1) ="",IBAC(2 )="",IBAC( 3)="" Q 0
2287	"RTN","IBC BB11",256, 0)
2288	; Both re quired fie lds comple te, no err or
2289	"RTN","IBC BB11",257, 0)
2290	I IBAC(2) '="",IBAC( 3)'="" Q 0
2291	"RTN","IBC BB11",258, 0)
2292	; At this point, on e of the 2 required fields has data and one does n ot, so err or
2293	"RTN","IBC BB11",259, 0)
2294	Q 1
2295	"RTN","IBC BB11",260, 0)
2296	;
2297	"RTN","IBC BB11",261, 0)
2298	LNTMCK(IBI FN) ; DEM ;IB2.043 2 - (Line Level) Att achment Co ntrol Numb er - REQUI RED when T ransmissio n Method = BM, EL, E M, or FT
2299	"RTN","IBC BB11",262, 0)
2300	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
2301	"RTN","IBC BB11",263, 0)
2302	; OUTPUT - IBLNERR = 0 = no e rror
2303	"RTN","IBC BB11",264, 0)
2304	; IBLNERR = 1 = Erro r
2305	"RTN","IBC BB11",265, 0)
2306	;
2307	"RTN","IBC BB11",266, 0)
2308	N IBAC,IB PROCP,I,IB LNERR
2309	"RTN","IBC BB11",267, 0)
2310	S IBLNERR =0 ; DEM; 432 - Init ialize err or flag IB LNERR to ' 0' for no errors.
2311	"RTN","IBC BB11",268, 0)
2312	Q:IBIFN=" " IBLNERR
2313	"RTN","IBC BB11",269, 0)
2314	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR
2315	"RTN","IBC BB11",270, 0)
2316	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,0 ))#10) ; DEM;432 - Node '0' i s procedur e node.
2317	"RTN","IBC BB11",271, 0)
2318	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; DEM;432 - Node '1' i s line lev el Attachm ent Contro l fields.
2319	"RTN","IBC BB11",272, 0)
2320	. F I=1,3 S IBAC(I) =$P(^DGCR( 399,IBIFN, "CP",IBPRO CP,1),U,I)
2321	"RTN","IBC BB11",273, 0)
2322	. I IBAC( 3)="" S IB LNERR=0 Q
2323	"RTN","IBC BB11",274, 0)
2324	. I IBAC( 1)'="" S I BLNERR=0 Q
2325	"RTN","IBC BB11",275, 0)
2326	. I (IBAC (3)="AA") S IBLNERR= 0 Q
2327	"RTN","IBC BB11",276, 0)
2328	. S IBLNE RR=1
2329	"RTN","IBC BB11",277, 0)
2330	. Q
2331	"RTN","IBC BB11",278, 0)
2332	;
2333	"RTN","IBC BB11",279, 0)
2334	Q IBLNERR
2335	"RTN","IBC BB11",280, 0)
2336	;
2337	"RTN","IBC BB11",281, 0)
2338	LNACCK(IBI FN) ; DEM; IB2.0432 (Line Lev el) If any of the lo op info is present, then Repor t Type & T ransmissio n Method r eq'd
2339	"RTN","IBC BB11",282, 0)
2340	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
2341	"RTN","IBC BB11",283, 0)
2342	; OUTPUT - IBLNERR = 0 = no e rror
2343	"RTN","IBC BB11",284, 0)
2344	; IBLNERR = 1 = Erro r
2345	"RTN","IBC BB11",285, 0)
2346	;
2347	"RTN","IBC BB11",286, 0)
2348	N IBAC,IB PROCP,I,IB LNERR
2349	"RTN","IBC BB11",287, 0)
2350	S IBLNERR =0 ; DEM; 432 - Init ialize err or flag IB LNERR to ' 0' for no errors.
2351	"RTN","IBC BB11",288, 0)
2352	Q:IBIFN=" " IBLNERR
2353	"RTN","IBC BB11",289, 0)
2354	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR
2355	"RTN","IBC BB11",290, 0)
2356	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,0 ))#10) ; DEM;432 - Node '0' i s procedur e node.
2357	"RTN","IBC BB11",291, 0)
2358	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; DEM;432 - Node '1' i s line lev el Attachm ent Contro l fields.
2359	"RTN","IBC BB11",292, 0)
2360	. F I=1:1 :3 S IBAC( I)=$P(^DGC R(399,IBIF N,"CP",IBP ROCP,1),U, I)
2361	"RTN","IBC BB11",293, 0)
2362	. ; All f ields null , no error
2363	"RTN","IBC BB11",294, 0)
2364	. I IBAC( 1)="",IBAC (2)="",IBA C(3)="" S IBLNERR=0 Q
2365	"RTN","IBC BB11",295, 0)
2366	. ; Both required f ields comp lete, no e rror
2367	"RTN","IBC BB11",296, 0)
2368	. I IBAC( 2)'="",IBA C(3)'="" S IBLNERR=0 Q
2369	"RTN","IBC BB11",297, 0)
2370	. ; At th is point, one of the 2 require d fields h as data an d one does not, so e rror
2371	"RTN","IBC BB11",298, 0)
2372	. S IBLNE RR=1
2373	"RTN","IBC BB11",299, 0)
2374	. Q
2375	"RTN","IBC BB11",300, 0)
2376	;
2377	"RTN","IBC BB11",301, 0)
2378	Q IBLNERR
2379	"RTN","IBC BB11",302, 0)
2380	;
2381	"RTN","IBC BB11",303, 0)
2382	;vd/Begin ning of IB 2577 - V alidate Li ne Level f or NDC
2383	"RTN","IBC BB11",304, 0)
2384	LNNDCCK(IB IFN) ;IB2 577 (Line Level) Th e Units an d Units/Ba sis of Mea surement f ields are required i f the NDC field is p opulated.
2385	"RTN","IBC BB11",305, 0)
2386	; INPUT - IBIFN = IEN of the Bill/Clai ms file (# 399)
2387	"RTN","IBC BB11",306, 0)
2388	; OUTPUT - IBLNERR = 0 = no e rror
2389	"RTN","IBC BB11",307, 0)
2390	; IBLNERR = 1 = Erro r
2391	"RTN","IBC BB11",308, 0)
2392	;
2393	"RTN","IBC BB11",309, 0)
2394	N IBAC,IB PROCP,I,IB LNERR
2395	"RTN","IBC BB11",310, 0)
2396	S IBLNERR =0 ; IB2 577 - Ini tialize er ror flag I BLNERR to '0' for no errors.
2397	"RTN","IBC BB11",311, 0)
2398	Q:IBIFN=" " IBLNERR
2399	"RTN","IBC BB11",312, 0)
2400	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR
2401	"RTN","IBC BB11",313, 0)
2402	. Q:($$GE T1^DIQ(399 .0304,IBPR OCP_","_IB IFN_",","N DC","I")=" ") ; IB* 2*577 - No NDC Code
2403	"RTN","IBC BB11",314, 0)
2404	. ; If th ere is an NDC Code, then the U NITS and U NITS/BASIS OF MEASUR EMENT are Required.
2405	"RTN","IBC BB11",315, 0)
2406	. I $$GET 1^DIQ(399. 0304,IBPRO CP_","_IBI FN_",","UN ITS/BASIS OF MEASURE MENT","I") ="" S IBLN ERR=1 Q
2407	"RTN","IBC BB11",316, 0)
2408	. I $$GET 1^DIQ(399. 0304,IBPRO CP_","_IBI FN_",","UN ITS","I")= "" S IBLNE RR=1 Q ;U nits (Quan tity) is r equired if there is an NDC Cod e.
2409	"RTN","IBC BB11",317, 0)
2410	. Q
2411	"RTN","IBC BB11",318, 0)
2412	;
2413	"RTN","IBC BB11",319, 0)
2414	Q IBLNERR
2415	"RTN","IBC BB11",320, 0)
2416	;vd/End o f IB2577
2417	"RTN","IBC EF11")
2418	0^4^B86419 290^B80990 662
2419	"RTN","IBC EF11",1,0)
2420	IBCEF11 ;A LB/TMP - F ORMATTER S PECIFIC BI LL FUNCTIO NS - CONT ;30-JAN-96
2421	"RTN","IBC EF11",2,0)
2422	;;2.0;INT EGRATED BI LLING;51 ,137,155,3 09,335,348 ,349,371,4 32,447,473 ,516,577 ;21-MAR-94 ;Build 34
2423	"RTN","IBC EF11",3,0)
2424	;;Per VA Directive 6402, this routine s hould not be modifie d.
2425	"RTN","IBC EF11",4,0)
2426	;
2427	"RTN","IBC EF11",5,0)
2428	BOX24D(A,I B) ; Retur ns the lin es for box es 19-24 o f the CMS- 1500 displ ay
2429	"RTN","IBC EF11",6,0)
2430	; IB = fl ag is 1 if only box 24 is need ed
2431	"RTN","IBC EF11",7,0)
2432	Q $S('$G( IB):"36",1 :"44")_"^5 5"
2433	"RTN","IBC EF11",8,0)
2434	;
2435	"RTN","IBC EF11",9,0)
2436	RCBOX() ; Returns th e lines fo r revenue code boxes of the UB -04 displa y
2437	"RTN","IBC EF11",10,0 )
2438	Q "19^41"
2439	"RTN","IBC EF11",11,0 )
2440	;
2441	"RTN","IBC EF11",12,0 )
2442	OUTPT(IBIF N,IBPRINT) ; Returns an array of service line data from
2443	"RTN","IBC EF11",13,0 )
2444	; C MS-1500 bo x 24. Out put is in IBXDATA(n)
2445	"RTN","IBC EF11",14,0 )
2446	; IBPRINT = print f lag 1: re turn print fields
2447	"RTN","IBC EF11",15,0 )
2448	; 0: re turn EDI f ields
2449	"RTN","IBC EF11",16,0 )
2450	; Uses di agnosis ar ray ^TMP(" IBXSAVE",$ J,"DX",IBI FN,DIAG CO DE)=SEQ #
2451	"RTN","IBC EF11",17,0 )
2452	; if it already e xists. If not, it bu ilds it fr om N-DIAGN OSES eleme nt
2453	"RTN","IBC EF11",18,0 )
2454	;
2455	"RTN","IBC EF11",19,0 )
2456	; For EDI call: Ret urns IBXDA TA(n)=
2457	"RTN","IBC EF11",20,0 )
2458	; begin date(YYYY MMDD) ^ en d date(YYY YMMDD) ^ p os ^ tos ^
2459	"RTN","IBC EF11",21,0 )
2460	; proc code/reven ue code - if no proc edure (not the point ers) ^
2461	"RTN","IBC EF11",22,0 )
2462	; type of code ^ dx pointer (s ) ^ uni t charge ^ units ^ m odifiers s eparated b y ;
2463	"RTN","IBC EF11",23,0 )
2464	; ^ pur chased cha rge amount ^ anesthe sia minute s ^ emerge ncy indica tor ^
2465	"RTN","IBC EF11",24,0 )
2466	; lab-t ype servic e flag ^ N DC ^ Units /Quantity ^ Unit/Bas is of Meas urement (v d/IB2577 )
2467	"RTN","IBC EF11",25,0 )
2468	;
2469	"RTN","IBC EF11",26,0 )
2470	; Also Returns IB XDATA(IBI, "COB",COB, m) with CO B data for each line
2471	"RTN","IBC EF11",27,0 )
2472	; it em found i n an accep ted EOB fo r the bill and = the reference
2473	"RTN","IBC EF11",28,0 )
2474	; li ne in the first '^' piece foll owed by th e '0' node data of f ile
2475	"RTN","IBC EF11",29,0 )
2476	; 36 1.115 (LIN E LEVEL AD JUSTMENTS)
2477	"RTN","IBC EF11",30,0 )
2478	; C OB = COB s equence # of adjustm ent's ins co, m = se q #
2479	"RTN","IBC EF11",31,0 )
2480	; -- AND --
2481	"RTN","IBC EF11",32,0 )
2482	; IBXD ATA(IBI,"C OB",COB,m, z,p)=
2483	"RTN","IBC EF11",33,0 )
2484	; the dat a on the ' 0' node fo r each sub ordinate e ntry of fi le
2485	"RTN","IBC EF11",34,0 )
2486	; 361.115 11 (REASON S) (Only f irst 3 pie ces for 83 7 output)
2487	"RTN","IBC EF11",35,0 )
2488	; z = group c ode, somet imes prece eded by a space p = seq #
2489	"RTN","IBC EF11",36,0 )
2490	;
2491	"RTN","IBC EF11",37,0 )
2492	; For Pri nt call: R eturns beg in date(DD MMYYYY)^en d date(DDM MYYYY) or
2493	"RTN","IBC EF11",38,0 )
2494	; null if equal t o begin da te^pos^tos ^bedsectio n name(if no procedu re)
2495	"RTN","IBC EF11",39,0 )
2496	; or pr ocedure co de(not the pointer)^ ... refer to EDI ca ll results
2497	"RTN","IBC EF11",40,0 )
2498	; Also, IBXDATA(n ,"TEXT")=t he text to print on first line of box 24 ,
2499	"RTN","IBC EF11",41,0 )
2500	; If no procedure code, ret urns IBXDA TA(n,"A")= rev code a bbrev
2501	"RTN","IBC EF11",42,0 )
2502	;
2503	"RTN","IBC EF11",43,0 )
2504	; For bo th calls, returns IB XDATA(n,it em type,it em ptr)=""
2505	"RTN","IBC EF11",44,0 )
2506	; -- AND --
2507	"RTN","IBC EF11",45,0 )
2508	; IBXDA TA(n,"RX") =RX#^drug name^NDC^r efill #^(r e)fill dat e^qty^days
2509	"RTN","IBC EF11",46,0 )
2510	; ^chrge^ie n of file 362.4^NDC format
2511	"RTN","IBC EF11",47,0 )
2512	; If line reference s a prescr iption
2513	"RTN","IBC EF11",48,0 )
2514	; -- AND --
2515	"RTN","IBC EF11",49,0 )
2516	; If no revenue c ode for a prescripti on, return s IBXDATA( n,"ARX")=" "
2517	"RTN","IBC EF11",50,0 )
2518	; -- AND --
2519	"RTN","IBC EF11",51,0 )
2520	; IBXDA TA(n,"AUX" )='AUX' no de of the procedure entry
2521	"RTN","IBC EF11",52,0 )
2522	;
2523	"RTN","IBC EF11",53,0 )
2524	; Also re turns IBXD ATA(n,"CPL NK") = sof t link to correspond ing entry in PROCEDU RES multip le of file 399
2525	"RTN","IBC EF11",54,0 )
2526	;
2527	"RTN","IBC EF11",55,0 )
2528	N IB,IBI, IBJ,IBFLD, IBDXI,IBXI EN,Z,IBXTR A,IBRX,IBR X0,IBRX1,Z 0,Z1
2529	"RTN","IBC EF11",56,0 )
2530	;
2531	"RTN","IBC EF11",57,0 )
2532	K ^TMP($J ,"IBITEM")
2533	"RTN","IBC EF11",58,0 )
2534	S ^TMP($J ,"IBITEM") =""
2535	"RTN","IBC EF11",59,0 )
2536	; Build d iagnosis a rray if no t already built
2537	"RTN","IBC EF11",60,0 )
2538	I $O(^TMP ("IBXSAVE" ,$J,"DX",I BIFN,""))= "",$O(^IBA (362.3,"AI FN"_IBIFN, "")) D
2539	"RTN","IBC EF11",61,0 )
2540	.N Z,IBXD ATA D F^IB CEF("N-DIA GNOSES",,, IBIFN)
2541	"RTN","IBC EF11",62,0 )
2542	.S Z="" F S Z=$O(I BXDATA(Z)) K:$O(IBXD ATA(0))="" &(Z="") IB XDATA Q:Z= "" S:$P(I BXDATA(Z), U,2) ^TMP( "IBXSAVE", $J,"DX",IB IFN,$P(IBX DATA(Z),U, 2))=Z
2543	"RTN","IBC EF11",63,0 )
2544	;
2545	"RTN","IBC EF11",64,0 )
2546	S IB(0)=$ G(^DGCR(39 9,IBIFN,0) ),IB("U")= $G(^("U")) ,IB("U1")= $G(^("U1") )
2547	"RTN","IBC EF11",65,0 )
2548	S IBI="" F S IBI=$ O(^TMP("IB XSAVE",$J, "DX",IBIFN ,IBI)) Q:I BI="" S I BDXI(IBI)= ^(IBI)
2549	"RTN","IBC EF11",66,0 )
2550	I '$G(IBP RINT) D RV CE^IBCF23( IBIFN,IBIF N)
2551	"RTN","IBC EF11",67,0 )
2552	I $G(IBPR INT) D RVC E^IBCF23(, IBIFN)
2553	"RTN","IBC EF11",68,0 )
2554	; Returns IBFLD(24) = begin d ate ^ end date ^ pos ^ tos ^
2555	"RTN","IBC EF11",69,0 )
2556	; pro c/bedsecti on/revenue code ^ dx pointer ^ unit char ge ^
2557	"RTN","IBC EF11",70,0 )
2558	; uni ts ^ modif iers ^ pur chased cha rge amount ^ anesthe sia minute s ^
2559	"RTN","IBC EF11",71,0 )
2560	; eme rgency ind icator ^ s oft pointe r to PROCE DURES mult iple in fi le 399 ^
2561	"RTN","IBC EF11",72,0 )
2562	; NDC ^ Units
2563	"RTN","IBC EF11",73,0 )
2564	; IBFLD(24, n,type,ite m)=""
2565	"RTN","IBC EF11",74,0 )
2566	; IBFLD(24, n_"A") = r evenue cod e abbrevia tion if no procedure
2567	"RTN","IBC EF11",75,0 )
2568	; IBFLD(24, n,"AUX") = 'AUX' nod e of line item
2569	"RTN","IBC EF11",76,0 )
2570	; IBFLD(24, n,"RX") = soft point er to file 362.4 fro m 'item' f ld
2571	"RTN","IBC EF11",77,0 )
2572	; (can be nu ll)
2573	"RTN","IBC EF11",78,0 )
2574	;
2575	"RTN","IBC EF11",79,0 )
2576	D SET^IBC SC5A(IBIFN ,.IBRX) ;p rescriptio ns
2577	"RTN","IBC EF11",80,0 )
2578	; IBRX1(i en 362.4)= RX#^drug i en^NDC^ref il #^(re)f il date^qt y^days^chr ge
2579	"RTN","IBC EF11",81,0 )
2580	I IBRX S IBRX="" F S IBRX=$O (IBRX(IBRX )) Q:IBRX= "" S IBRX 0=0 F S I BRX0=$O(IB RX(IBRX,IB RX0)) Q:'I BRX0 D
2581	"RTN","IBC EF11",82,0 )
2582	. N IBRXH
2583	"RTN","IBC EF11",83,0 )
2584	. S IBRXH =IBRX(IBRX ,IBRX0)
2585	"RTN","IBC EF11",84,0 )
2586	. ; *IB 2.0432* added _U_$ P(IBRXH,U, 9) (Rx Dat e) to Outp ut Formatt er
2587	"RTN","IBC EF11",85,0 )
2588	. S IBRX1 (+IBRXH)=I BRX_U_$P(I BRXH,U,2)_ U_$P(IBRXH ,U,5)_U_$P (IBRXH,U,7 )_U_IBRX0_ U_$P(IBRXH ,U,4)_U_$P (IBRXH,U,3 )_U_$P(IBR XH,U,6)_U_ +IBRXH_U_$ P(IBRXH,U, 8)_U_$P(IB RXH,U,9)
2589	"RTN","IBC EF11",86,0 )
2590	K IBRX
2591	"RTN","IBC EF11",87,0 )
2592	;
2593	"RTN","IBC EF11",88,0 )
2594	; for EDI , remove a ny $0 line items fro m the IBFL D array be fore
2595	"RTN","IBC EF11",89,0 )
2596	; droppin g down int o the next loop (IB* 2*371)
2597	"RTN","IBC EF11",90,0 )
2598	; Start I B2.0447 BI - Code removed to allow 0 d ollars to print.
2599	"RTN","IBC EF11",91,0 )
2600	;I '$G(IB PRINT) D
2601	"RTN","IBC EF11",92,0 )
2602	;. NEW IB Z,IBI,Z
2603	"RTN","IBC EF11",93,0 )
2604	;. M IBZ= IBFLD K IB FLD
2605	"RTN","IBC EF11",94,0 )
2606	;. S (IBI ,Z)=0
2607	"RTN","IBC EF11",95,0 )
2608	;. F S I BI=$O(IBZ( 24,IBI)) Q :IBI'=+IBI D
2609	"RTN","IBC EF11",96,0 )
2610	;.. I $P( IBZ(24,IBI ),U,7)*$P( IBZ(24,IBI ),U,8)'>0 Q
2611	"RTN","IBC EF11",97,0 )
2612	;.. S Z=Z +1
2613	"RTN","IBC EF11",98,0 )
2614	;.. M IBF LD(24,Z)=I BZ(24,IBI)
2615	"RTN","IBC EF11",99,0 )
2616	;.. S IBF LD(24)=Z
2617	"RTN","IBC EF11",100, 0)
2618	;.. Q
2619	"RTN","IBC EF11",101, 0)
2620	;. Q
2621	"RTN","IBC EF11",102, 0)
2622	; End IB* 2.0*447 BI
2623	"RTN","IBC EF11",103, 0)
2624	;
2625	"RTN","IBC EF11",104, 0)
2626	S IBI=0
2627	"RTN","IBC EF11",105, 0)
2628	F S IBI= $O(IBFLD(2 4,IBI)) Q: IBI'=+IBI D
2629	"RTN","IBC EF11",106, 0)
2630	. S IBRX1 =0
2631	"RTN","IBC EF11",107, 0)
2632	. S IBXDA TA(IBI)=$P (IBFLD(24, IBI),U)_U_ $P(IBFLD(2 4,IBI),U,$ S($P(IBFLD (24,IBI),U ,2)=""&'$G (IBPRINT): 1,1:2))
2633	"RTN","IBC EF11",108, 0)
2634	. S $P(IB XDATA(IBI) ,U,3,5)=$P (IBFLD(24, IBI),U,3,5 )
2635	"RTN","IBC EF11",109, 0)
2636	. S $P(IB XDATA(IBI) ,U,6)=$S($ D(IBFLD(24 ,IBI_"X")) :"CJ",1:"H C")
2637	"RTN","IBC EF11",110, 0)
2638	. S $P(IB XDATA(IBI) ,U,7,13)=$ P(IBFLD(24 ,IBI),U,6, 12)
2639	"RTN","IBC EF11",111, 0)
2640	. S $P(IB XDATA(IBI) ,U,14)=+$$ ISLAB(IBXD ATA(IBI))
2641	"RTN","IBC EF11",112, 0)
2642	. ; MRD;I B2.0516 - Added ND C and Unit s to line level of c laim,
2643	"RTN","IBC EF11",113, 0)
2644	. ; piece s 14 & 15 of IBFLD, pieces 15 & 16 of IB XDATA. Pri nt
2645	"RTN","IBC EF11",114, 0)
2646	. ; in Bo x 24 by se tting in I BXDATA(IBI ,"TEXT").
2647	"RTN","IBC EF11",115, 0)
2648	. ;S $P(I BXDATA(IBI ),U,15,16) =$P(IBFLD( 24,IBI),U, 14,15)
2649	"RTN","IBC EF11",116, 0)
2650	. ;I $P(I BFLD(24,IB I),U,14)'= "" S IBXDA TA(IBI,"TE XT")="N4"_ $P(IBFLD(2 4,IBI),U,1 4)_" UN"_$ P(IBFLD(24 ,IBI),U,15 )
2651	"RTN","IBC EF11",117, 0)
2652	. ; vd/IB 2577 - A dded Unit/ Basis of M easurement to line l evel of cl aim,
2653	"RTN","IBC EF11",118, 0)
2654	. ; piece 16 of IBF LD, piece 17 of IBXD ATA.
2655	"RTN","IBC EF11",119, 0)
2656	. ; Print in Box 24 by settin g in IBXDA TA(IBI,"TE XT").
2657	"RTN","IBC EF11",120, 0)
2658	. S $P(IB XDATA(IBI) ,U,15,17)= $P(IBFLD(2 4,IBI),U,1 4,16)
2659	"RTN","IBC EF11",121, 0)
2660	. I $P(IB FLD(24,IBI ),U,14)'=" " S IBXDAT A(IBI,"TEX T")="N4"_$ P(IBFLD(24 ,IBI),U,14 )_" "_$P(I BFLD(24,IB I),U,16)_$ P(IBFLD(24 ,IBI),U,15 )
2661	"RTN","IBC EF11",122, 0)
2662	. ;
2663	"RTN","IBC EF11",123, 0)
2664	. I $D(IB FLD(24,IBI ,"RX")) D ;Rx
2665	"RTN","IBC EF11",124, 0)
2666	.. S IBRX 1=1
2667	"RTN","IBC EF11",125, 0)
2668	.. I $P($ G(IBFLD(24 ,IBI,"AUX" )),U,8)'=" " S $P(IBF LD(24,IBI, "AUX"),U,8 )="",$P(IB FLD(24,IBI ,"AUX"),U, 9)="" ;No free text allowed f or rx's
2669	"RTN","IBC EF11",126, 0)
2670	.. I $D(I BRX1(+IBFL D(24,IBI," RX"))) D Q ;Soft l ink exists
2671	"RTN","IBC EF11",127, 0)
2672	...D ZERO ^IBRXUTL(+ $P(IBRX1(+ IBFLD(24,I BI,"RX")), U,2))
2673	"RTN","IBC EF11",128, 0)
2674	... S IBX DATA(IBI," RX")=IBRX1 (+IBFLD(24 ,IBI,"RX") ),$P(IBXDA TA(IBI,"RX "),U,2)=$E ($G(^TMP($ J,"IBDRUG" ,+$P(IBRX1 (+IBFLD(24 ,IBI,"RX") ),U,2),.01 )),1,30)
2675	"RTN","IBC EF11",129, 0)
2676	... K IBR X1(+IBFLD( 24,IBI,"RX "))
2677	"RTN","IBC EF11",130, 0)
2678	... ; No soft link - must fin d the firs t Rx with the same c harge
2679	"RTN","IBC EF11",131, 0)
2680	.. S IBRX ="" F S I BRX=$O(IBR X1(IBRX)) Q:'IBRX I +$P(IBRX1 (IBRX),U,8 )=+$P(IBXD ATA(IBI),U ,8) D Q
2681	"RTN","IBC EF11",132, 0)
2682	... D ZER O^IBRXUTL( +$P(IBRX1( IBRX),U,2) )
2683	"RTN","IBC EF11",133, 0)
2684	... S IBX DATA(IBI," RX")=IBRX1 (IBRX),$P( IBXDATA(IB I,"RX"),U, 2)=$E($G(^ TMP($J,"IB DRUG",+$P( IBRX1(IBRX ),U,2),.01 )),1,30) K IBRX1(IBR X) Q
2685	"RTN","IBC EF11",134, 0)
2686	... Q
2687	"RTN","IBC EF11",135, 0)
2688	.. Q
2689	"RTN","IBC EF11",136, 0)
2690	. ;
2691	"RTN","IBC EF11",137, 0)
2692	. ; MRD;I B2.0516 - If addit ional serv ice line c omments to appear in
2693	"RTN","IBC EF11",138, 0)
2694	. ; Box 2 4, concate nate to fr ont if som ething (ND C) is alre ady there.
2695	"RTN","IBC EF11",139, 0)
2696	. I $G(IB FLD(24,IBI ,"AUX"))'= "" D
2697	"RTN","IBC EF11",140, 0)
2698	.. I $G(I BPRINT),$P (IBFLD(24, IBI,"AUX") ,U,8)'="" D
2699	"RTN","IBC EF11",141, 0)
2700	... I $G( IBXDATA(IB I,"TEXT")) '="" S IBX DATA(IBI," TEXT")=$E( $P(IBFLD(2 4,IBI,"AUX "),U,8)_" "_IBXDATA( IBI,"TEXT" ),1,59)
2701	"RTN","IBC EF11",142, 0)
2702	... E S IBXDATA(IB I,"TEXT")= $P(IBFLD(2 4,IBI,"AUX "),U,8)
2703	"RTN","IBC EF11",143, 0)
2704	... S $P( IBFLD(24,I BI,"AUX"), U,8)=""
2705	"RTN","IBC EF11",144, 0)
2706	... Q
2707	"RTN","IBC EF11",145, 0)
2708	.. S IBXD ATA(IBI,"A UX")=IBFLD (24,IBI,"A UX")
2709	"RTN","IBC EF11",146, 0)
2710	.. Q
2711	"RTN","IBC EF11",147, 0)
2712	. ;
2713	"RTN","IBC EF11",148, 0)
2714	. I $G(IB PRINT) D
2715	"RTN","IBC EF11",149, 0)
2716	.. ; STAR T IB2.04 47 BI ZERO DOLLAR CH ANGES
2717	"RTN","IBC EF11",150, 0)
2718	.. ; I '$ P(IBXDATA( IBI),U,8), '$G(IBXDAT A(IBI,"RX" )) D Q
2719	"RTN","IBC EF11",151, 0)
2720	.. I $P(I BXDATA(IBI ),U,8)="", '$G(IBXDAT A(IBI,"RX" )) D Q
2721	"RTN","IBC EF11",152, 0)
2722	... ; END IB2.044 7 BI ZERO DOLLAR CHA NGES
2723	"RTN","IBC EF11",153, 0)
2724	... I $G( IBNOSHOW) Q ; don 't show er rors/warni ngs
2725	"RTN","IBC EF11",154, 0)
2726	... S IBX DATA(IBI," TEXT")="Wa rning:** R EV CODE UN ITS < #PRO CEDURES, T HEY MUST B E ="
2727	"RTN","IBC EF11",155, 0)
2728	... I $D( IBXDATA(IB I,"AUX")) S $P(IBXDA TA(IBI,"AU X"),U,9)=" "
2729	"RTN","IBC EF11",156, 0)
2730	... Q
2731	"RTN","IBC EF11",157, 0)
2732	.. ;
2733	"RTN","IBC EF11",158, 0)
2734	.. I $G(I BFLD(24,IB I_"A"))'=" " D Q
2735	"RTN","IBC EF11",159, 0)
2736	... S IBX DATA(IBI," A")=IBFLD( 24,IBI_"A" )
2737	"RTN","IBC EF11",160, 0)
2738	... I $G( IBNOSHOW) Q ; don 't show er rors/warni ngs
2739	"RTN","IBC EF11",161, 0)
2740	... S IBX DATA(IBI," TEXT")="Wa rning:** R EV CODE UN ITS > #PRO CEDURES, T HEY MUST B E=: "_IBFL D(24,IBI_" A")
2741	"RTN","IBC EF11",162, 0)
2742	... I $D( IBXDATA(IB I,"AUX")) S $P(IBXDA TA(IBI,"AU X"),U,9)=" "
2743	"RTN","IBC EF11",163, 0)
2744	... Q
2745	"RTN","IBC EF11",164, 0)
2746	.. ;
2747	"RTN","IBC EF11",165, 0)
2748	.. S IBRX =$G(IBXDAT A(IBI,"RX" ))
2749	"RTN","IBC EF11",166, 0)
2750	.. I IBRX '="" D ;F ormat Rx d etail
2751	"RTN","IBC EF11",167, 0)
2752	... N Z
2753	"RTN","IBC EF11",168, 0)
2754	... S Z=$ P(IBRX,U)
2755	"RTN","IBC EF11",169, 0)
2756	... S Z=$ S(Z'="":"R x#"_Z_" ", 1:"RX: ")
2757	"RTN","IBC EF11",170, 0)
2758	... S IBX DATA(IBI," TEXT")=Z_$ S($P(IBRX, U,3)'="":" NDC: "_$P( IBRX,U,3), 1:"NOC: "_ $P(IBRX,U, 2))_" Qty: "_$P(IBRX ,U,6)_" Da ys: "_$P(I BRX,U,7)
2759	"RTN","IBC EF11",171, 0)
2760	... S $P( IBXDATA(IB I,"AUX"),U ,9)="N4" ; service line comm ent qualif ier for RX 's
2761	"RTN","IBC EF11",172, 0)
2762	... Q
2763	"RTN","IBC EF11",173, 0)
2764	.. Q
2765	"RTN","IBC EF11",174, 0)
2766	. S IBXDA TA(IBI,"CP LNK")=$P(I BFLD(24,IB I),U,13)
2767	"RTN","IBC EF11",175, 0)
2768	. I '$G(I BPRINT) D COBLINE^IB CEU6(IBIFN ,IBI,.IBXD ATA,,.IBXT RA)
2769	"RTN","IBC EF11",176, 0)
2770	. Q
2771	"RTN","IBC EF11",177, 0)
2772	;
2773	"RTN","IBC EF11",178, 0)
2774	I $G(IBPR INT) D
2775	"RTN","IBC EF11",179, 0)
2776	. S IBRX= 0 F S IBR X=$O(IBRX1 (IBRX)) Q: 'IBRX D
2777	"RTN","IBC EF11",180, 0)
2778	.. S IBI= +$O(IBXDAT A(""),-1)+ 1
2779	"RTN","IBC EF11",181, 0)
2780	.. S IBXD ATA(IBI)=$ $DATE($P(I BRX1(IBRX) ,U,5))
2781	"RTN","IBC EF11",182, 0)
2782	.. S IBXD ATA(IBI,"T EXT")="*** * ERROR - NO PROC LI NK TO REV CODE FOR D RUG: RX#: "_$P(IBRX1 (IBRX),U)_ " NDC #: "_$P(IBRX1 (IBRX),U,3 )
2783	"RTN","IBC EF11",183, 0)
2784	.. I $D(I BXDATA(IBI ,"AUX")) S $P(IBXDAT A(IBI,"AUX "),U,9)=""
2785	"RTN","IBC EF11",184, 0)
2786	.. S IBXD ATA(IBI,"A RX")=""
2787	"RTN","IBC EF11",185, 0)
2788	.. D ZERO ^IBRXUTL(+ $P(IBRX1(I BRX),U,2))
2789	"RTN","IBC EF11",186, 0)
2790	.. S IBXD ATA(IBI,"R X")=IBRX1( IBRX),$P(I BXDATA(IBI ,"RX"),U,2 )=$E($G(^T MP($J,"IBD RUG",+$P(I BRX1(IBRX) ,U,2),.01) ),1,30) K IBRX1(IBRX )
2791	"RTN","IBC EF11",187, 0)
2792	.. Q
2793	"RTN","IBC EF11",188, 0)
2794	. Q
2795	"RTN","IBC EF11",189, 0)
2796	;
2797	"RTN","IBC EF11",190, 0)
2798	I '$G(IBP RINT),$D(I BXTRA) D C OMBO^IBCEU 2(.IBXDATA ,.IBXTRA,0 ) ;Handle bundled/un bundled li nes
2799	"RTN","IBC EF11",191, 0)
2800	K ^TMP($J ,"IBDRUG")
2801	"RTN","IBC EF11",192, 0)
2802	Q
2803	"RTN","IBC EF11",193, 0)
2804	;
2805	"RTN","IBC EF11",194, 0)
2806	ISLAB(LDAT A) ; Retur ns 0/1 if line item data indic ates the i tem is a l ab (1)
2807	"RTN","IBC EF11",195, 0)
2808	; 'LAB' i s defined here as ty pe of serv ice = 5
2809	"RTN","IBC EF11",196, 0)
2810	Q $E($P(L DATA,U,4)) ="5"
2811	"RTN","IBC EF11",197, 0)
2812	;
2813	"RTN","IBC EF11",198, 0)
2814	FMT(DATA,D LEN,FLEN) ; Returns a string i n DATA wit h a max le ngth of DL EN
2815	"RTN","IBC EF11",199, 0)
2816	; and a field leng th of FLEN
2817	"RTN","IBC EF11",200, 0)
2818	Q $E($E(D ATA,1,DLEN )_$J("",FL EN),1,FLEN )
2819	"RTN","IBC EF11",201, 0)
2820	;
2821	"RTN","IBC EF11",202, 0)
2822	DATE(X,DEL ) ; Retur ns FM date in X as M MxDDxYYYY where x=D EL
2823	"RTN","IBC EF11",203, 0)
2824	S DEL=$G( DEL)
2825	"RTN","IBC EF11",204, 0)
2826	S X=$$DAT E^IBCF2(X, 1,1)
2827	"RTN","IBC EF11",205, 0)
2828	I X'="" S X=$E(X,1, 2)_DEL_$E( X,3,4)_DEL _$E(X,5,8)
2829	"RTN","IBC EF11",206, 0)
2830	Q X
2831	"RTN","IBC EF11",207, 0)
2832	;
2833	"RTN","IBC EF11",208, 0)
2834	BATCH() ; Sets up re cord for a nd stores/ returns th e next bat ch number
2835	"RTN","IBC EF11",209, 0)
2836	N NUM,FAC ,DO,DD,DLA YGO,DIC,X, Y
2837	"RTN","IBC EF11",210, 0)
2838	;Keep lat est batch number for view/prin t edi bill extract d ata option
2839	"RTN","IBC EF11",211, 0)
2840	I $D(IBVN UM) S NUM= IBVNUM G B ATCHQ
2841	"RTN","IBC EF11",212, 0)
2842	;Check fo r batch re submit - i f yes, use same numb er as orig inal batch
2843	"RTN","IBC EF11",213, 0)
2844	I $P($G(^ TMP("IBRES UBMIT",$J) ),U,3)=1 S NUM=$P(^( $J),U) G B ATCHQ
2845	"RTN","IBC EF11",214, 0)
2846	L +^IBA(3 64.1,0):5 I '$T Q 0
2847	"RTN","IBC EF11",215, 0)
2848	S FAC=+$P ($$SITE^VA SITE(),U,3 ),NUM=$O(^ IBA(364.1, "B",""),-1 )
2849	"RTN","IBC EF11",216, 0)
2850	I $D(^IBA (364.1,+NU M,0)),$P(^ (0),U,2)=" " F D Q: 'NUM!($P($ G(^IBA(364 .1,+NUM,0) ),U,2)'="" )
2851	"RTN","IBC EF11",217, 0)
2852	. I $D(^I BA(364.1,N UM,0)) S D A=NUM,DIK= "^IBA(364. 1," D ^DIK
2853	"RTN","IBC EF11",218, 0)
2854	. S NUM=$ O(^IBA(364 .1,"B","") ,-1)
2855	"RTN","IBC EF11",219, 0)
2856	F S NUM= $S($P(NUM, FAC,2)'="" :NUM+1,1:F AC_"000000 1") Q:'$D( ^IBA(364.1 ,"B",NUM))
2857	"RTN","IBC EF11",220, 0)
2858	K DO,DD S DIC="^IBA (364.1,",D LAYGO=364. 1,DIC(0)=" L",X=NUM D FILE^DICN K DD,DO I Y'>0 S NU M=0
2859	"RTN","IBC EF11",221, 0)
2860	L -^IBA(3 64.1,0)
2861	"RTN","IBC EF11",222, 0)
2862	BATCHQ Q N UM
2863	"RTN","IBC EF11",223, 0)
2864	;
2865	"RTN","IBC EF11",224, 0)
2866	GETLDAT(IB XIEN) ; Ex tract data for 837 t ransmissio n LDAT rec ord
2867	"RTN","IBC EF11",225, 0)
2868	; IBXIEN - ien in f ile 399
2869	"RTN","IBC EF11",226, 0)
2870	; Sets up IBXSAVE(" LDAT",n) a rray:
2871	"RTN","IBC EF11",227, 0)
2872	; Attachm ent report type ^ At tachment r eport tran smission c ode ^ Atta chment con trol numbe r ^
2873	"RTN","IBC EF11",228, 0)
2874	; OB Anes thesia Add itional Un its ^ Purc hase Servi ce Provide r ID ^ Pur chase Serv ice Amount ^
2875	"RTN","IBC EF11",229, 0)
2876	N CPIEN,F TYPE,IBXDA TA,IDS,IBI DS,NODE1,P SAMNT,PSPI D,Z,PCE1,L INE
2877	"RTN","IBC EF11",230, 0)
2878	I '+$G(IB XIEN) Q
2879	"RTN","IBC EF11",231, 0)
2880	K IBXSAVE ("LDAT")
2881	"RTN","IBC EF11",232, 0)
2882	S FTYPE=$ $FT^IBCEF( IBXIEN)
2883	"RTN","IBC EF11",233, 0)
2884	I FTYPE=2 D OUTPT(I BXIEN,0)
2885	"RTN","IBC EF11",234, 0)
2886	I FTYPE=3 D HOS^IBC EF2(IBXIEN )
2887	"RTN","IBC EF11",235, 0)
2888	D ALLIDS^ IBCEFP(IBX IEN,.IDS,1 )
2889	"RTN","IBC EF11",236, 0)
2890	S (PSPID, PSAMNT)=""
2891	"RTN","IBC EF11",237, 0)
2892	; IB2.0 473/TAZ - Convert PR OVIDER cod e to funct ion call t o PSID^IBC EFP
2893	"RTN","IBC EF11",238, 0)
2894	I $$SUB1O K^IBCEP8A( IBXIEN),(F TYPE=2) D
2895	"RTN","IBC EF11",239, 0)
2896	. D PSID^ IBCEFP(IBX IEN,.IDS,. IBIDS)
2897	"RTN","IBC EF11",240, 0)
2898	. S PSPID =$G(IBIDS( 0)) I PSPI D="" S PSP ID=$P($G(I BIDS(1)),U ,1)
2899	"RTN","IBC EF11",241, 0)
2900	;IB2.04 73/TAZ - E ND
2901	"RTN","IBC EF11",242, 0)
2902	S Z=0 F S Z=$O(IBX DATA(Z)) Q :'Z D
2903	"RTN","IBC EF11",243, 0)
2904	. S CPIEN =+$G(IBXDA TA(Z,"CPLN K")) ;I 'C PIEN Q
2905	"RTN","IBC EF11",244, 0)
2906	. I FTYPE =2,$$SUB1O K^IBCEP8A( IBXIEN) S PSAMNT=$$D OLLAR^IBCE FG1($P($G( IBXDATA(Z) ),U,11))
2907	"RTN","IBC EF11",245, 0)
2908	. S (PCE1 ,NODE1)=""
2909	"RTN","IBC EF11",246, 0)
2910	. I CPIEN D
2911	"RTN","IBC EF11",247, 0)
2912	. . S NOD E1=$G(^DGC R(399,IBXI EN,"CP",CP IEN,1))
2913	"RTN","IBC EF11",248, 0)
2914	. . S PCE 1=$$GET1^D IQ(399.030 4,CPIEN_", "_IBXIEN_" ,",71)
2915	"RTN","IBC EF11",249, 0)
2916	. . Q
2917	"RTN","IBC EF11",250, 0)
2918	. ; MRD;I B2.0516 - Added ad dl. proced ure descri ption as p iece 7
2919	"RTN","IBC EF11",251, 0)
2920	. ; of IB XSAVE, whi ch will ex ist only i f the proc edure ends in '99'
2921	"RTN","IBC EF11",252, 0)
2922	. ; or is an 'NOC/N OS' proced ure.
2923	"RTN","IBC EF11",253, 0)
2924	. S IBXSA VE("LDAT", Z)=PCE1_U_ $P(NODE1,U ,3)_U_$P(N ODE1,U)_U_ $P(NODE1,U ,5)_U_$G(P SPID)_U_$G (PSAMNT)_U _$P(NODE1, U,4)
2925	"RTN","IBC EF11",254, 0)
2926	. Q
2927	"RTN","IBC EF11",255, 0)
2928	Q
2929	"RTN","IBC EF22")
2930	0^6^B97383 500^B90984 490
2931	"RTN","IBC EF22",1,0)
2932	IBCEF22 ;A LB/TMP - F ORMATTER S PECIFIC BI LL FUNCTIO NS ;06-FEB -96
2933	"RTN","IBC EF22",2,0)
2934	;;2.0;INT EGRATED BI LLING;51 ,137,135,1 55,309,349 ,389,432,4 88,516,577 ;21-MAR- 94;Build 3 4
2935	"RTN","IBC EF22",3,0)
2936	;;Per VA Directive 6402, this routine s hould not be modifie d.
2937	"RTN","IBC EF22",4,0)
2938	;
2939	"RTN","IBC EF22",5,0)
2940	; OVERFL OW FROM RO UTINE IBCE F2
2941	"RTN","IBC EF22",6,0)
2942	HOS(IBIFN) ; Extract rev codes for episo de billed on a UB-04 into IBXD ATA
2943	"RTN","IBC EF22",7,0)
2944	; IBIFN = bill ien
2945	"RTN","IBC EF22",8,0)
2946	; Format: IBXDATA(n ) =
2947	"RTN","IBC EF22",9,0)
2948	; rev cd ptr ^ CPT CODE ptr ^ unit chg ^ units ^ tot charg e
2949	"RTN","IBC EF22",10,0 )
2950	; ^ to t uncov ^ FL49 value
2951	"RTN","IBC EF22",11,0 )
2952	; ^ ie n of rev c ode multip le entry(s ) (separat ed by ";")
2953	"RTN","IBC EF22",12,0 )
2954	; ^ mo difiers sp ecific to rev code/p roc (separ ated by ", ")
2955	"RTN","IBC EF22",13,0 )
2956	; ^ re v code dat e, if it c an be dete rmined by a correspo nding proc
2957	"RTN","IBC EF22",14,0 )
2958	; ^ ND C from "CP " node of claim ^ Un its/Quanti ty from "C P" node - vd/IB25 77
2959	"RTN","IBC EF22",15,0 )
2960	; ^ Un its/Basis of Measure ment for D rugs - vd /IB2577
2961	"RTN","IBC EF22",16,0 )
2962	;
2963	"RTN","IBC EF22",17,0 )
2964	; Also Returns IB XDATA(IBI, "COB",COB, m) with CO B data for each line
2965	"RTN","IBC EF22",18,0 )
2966	; it em found i n an accep ted EOB fo r the bill and = the reference
2967	"RTN","IBC EF22",19,0 )
2968	; li ne in the first '^' piece foll owed by th e '0' node of file
2969	"RTN","IBC EF22",20,0 )
2970	; 36 1.115 (LIN E LEVEL AD JUSTMENTS)
2971	"RTN","IBC EF22",21,0 )
2972	; C OB = COB s eq # of ad justment's ins co, m = seq #
2973	"RTN","IBC EF22",22,0 )
2974	; -- AND --
2975	"RTN","IBC EF22",23,0 )
2976	; IBXD ATA(IBI,"C OB",COB,m, z,p)=
2977	"RTN","IBC EF22",24,0 )
2978	; the '0' node for each subor dinate ent ry of file
2979	"RTN","IBC EF22",25,0 )
2980	; 361.115 11 (REASON S) (Only f irst 3 pie ces for 83 7)
2981	"RTN","IBC EF22",26,0 )
2982	; z = group c ode, somet imes prece eded by a space p = seq #
2983	"RTN","IBC EF22",27,0 )
2984	;
2985	"RTN","IBC EF22",28,0 )
2986	; -- AND --
2987	"RTN","IBC EF22",29,0 )
2988	; IBXD ATA(n,"CPL NK") = sof t link to correspond ing entry in PROCEDU RES multip le of file 399
2989	"RTN","IBC EF22",30,0 )
2990	;
2991	"RTN","IBC EF22",31,0 )
2992	N IBDA,IB COMB,IBINP AT,IBLN,IB X,IBY,IBZ, IBS,IBSS,I BXTRA,IBX1 ,IBXS,IBP, IBPO,IBP1, IBDEF,Z,Z0 ,Z1,ZX,QQ, IBMOD,LST
2993	"RTN","IBC EF22",32,0 )
2994	S IBINPAT =$$INPAT^I BCEF(IBIFN ,1)
2995	"RTN","IBC EF22",33,0 )
2996	I 'IBINPA T D F^IBCE F("N-STATE MENT COVER S FROM DAT E","IBZ",, IBIFN)
2997	"RTN","IBC EF22",34,0 )
2998	S IBDEF=$ G(IBZ),LST =""
2999	"RTN","IBC EF22",35,0 )
3000	;
3001	"RTN","IBC EF22",36,0 )
3002	; Loop th rough line s of claim beneath ^ DGCR(399,I BIFN,"CP") and build
3003	"RTN","IBC EF22",37,0 )
3004	; the arr ay IBP to be used be low.
3005	"RTN","IBC EF22",38,0 )
3006	; IBP( Procedure ^ Modifier s, Print O rder, Line #) = Proce dure Date
3007	"RTN","IBC EF22",39,0 )
3008	;
3009	"RTN","IBC EF22",40,0 )
3010	S IBDA=0 F S IBDA= $O(^DGCR(3 99,IBIFN," CP",IBDA)) Q:'IBDA S IBZ=$G(^ (IBDA,0)) I IBZ D
3011	"RTN","IBC EF22",41,0 )
3012	. S IBP(+ $P(IBZ,U)_ U_$$GETMOD ^IBEFUNC(I BIFN,IBDA, 1),$S($P(I BZ,U,4):$P (IBZ,U,4), 1:999),IBD A)=$P(IBZ, U,2)
3013	"RTN","IBC EF22",42,0 )
3014	;
3015	"RTN","IBC EF22",43,0 )
3016	; Loop th rough the revenue co des beneat h ^DGCR(39 9,IBIFN,"R C") and
3017	"RTN","IBC EF22",44,0 )
3018	; build t he array I BX to be u sed below.
3019	"RTN","IBC EF22",45,0 )
3020	; IBX( " "_Revenu e Code, Pr int Order, Revenue L ine#) =
3021	"RTN","IBC EF22",46,0 )
3022	; ^DGCR(39 9.2, Reven ue Code IE N, 0)
3023	"RTN","IBC EF22",47,0 )
3024	; IBX( " "_Revenu e Code, Pr int Order, Revenue L ine#, "DT" ) = Proced ure Date
3025	"RTN","IBC EF22",48,0 )
3026	; IBX( " "_Revenu e Code, Pr int Order, Revenue L ine#, "MOD ") = Modif iers
3027	"RTN","IBC EF22",49,0 )
3028	;
3029	"RTN","IBC EF22",50,0 )
3030	S IBDA=0 F S IBDA= $O(^DGCR(3 99,IBIFN," RC",IBDA)) Q:'IBDA S IBZ=$G(^ (IBDA,0)) I IBZ S IB MOD="" D
3031	"RTN","IBC EF22",51,0 )
3032	. S IBX=$ G(^DGCR(39 9.2,+IBZ,0 )),IBX1="" ,IBPO=0
3033	"RTN","IBC EF22",52,0 )
3034	. ; Auto- added proc edure char ge
3035	"RTN","IBC EF22",53,0 )
3036	. I $P(IB Z,U,10)=4, $P(IBZ,U,1 1) D ; So ft link to proc
3037	"RTN","IBC EF22",54,0 )
3038	.. S Z=$G (^DGCR(399 ,IBIFN,"CP ",$P(IBZ,U ,11),0))
3039	"RTN","IBC EF22",55,0 )
3040	.. Q:Z=""
3041	"RTN","IBC EF22",56,0 )
3042	.. S ZX=+ Z_U_$$GETM OD^IBEFUNC (IBIFN,$P( IBZ,U,11), 1)
3043	"RTN","IBC EF22",57,0 )
3044	.. Q:'$O( IBP(ZX,0)) &'$O(IBP1( ZX,0))
3045	"RTN","IBC EF22",58,0 )
3046	.. I $P(I BZ,U,6) Q: $S($P(Z,U) '["ICPT":1 ,1:+$P(Z,U )'=$P(IBZ, U,6))
3047	"RTN","IBC EF22",59,0 )
3048	.. S Z0=$ S($D(IBP(Z X)):$O(IBP (ZX,0)),1: $O(IBP1(ZX ,0)))
3049	"RTN","IBC EF22",60,0 )
3050	.. S:'Z0 Z0=999
3051	"RTN","IBC EF22",61,0 )
3052	.. Q:'$D( IBP(ZX,+Z0 ,$P(IBZ,U, 11)))&'$D( IBP1(ZX,+Z 0,$P(IBZ,U ,11)))
3053	"RTN","IBC EF22",62,0 )
3054	.. I '$D( IBP1(ZX,+Z 0,$P(IBZ,U ,11))) S I BP1(ZX,+Z0 ,$P(IBZ,U, 11))=IBP(Z X,+Z0,$P(I BZ,U,11)) K IBP(ZX,+ Z0,$P(IBZ, U,11))
3055	"RTN","IBC EF22",63,0 )
3056	.. S IBX1 =$P(Z,U,2) ,IBPO=+Z0, IBMOD=$P(Z X,U,2)
3057	"RTN","IBC EF22",64,0 )
3058	. ; Manua lly added charge wit h a proced ure
3059	"RTN","IBC EF22",65,0 )
3060	. I $P(IB Z,U,6),$S( $P(IBZ,U,1 0)=4:'$P(I BZ,U,11),1 :1),+$O(IB P($P(IBZ,U ,6)))=$P(I BZ,U,6) D
3061	"RTN","IBC EF22",66,0 )
3062	.. ; No d irect link , but a pr oc exists on rev cod e and in p rocedure m ult withou t and then with modi fiers
3063	"RTN","IBC EF22",67,0 )
3064	.. S ZX=$ O(IBP($P(I BZ,U,6)))
3065	"RTN","IBC EF22",68,0 )
3066	.. F QQ=1 ,2 Q:IBPO S Z="" F S Z=$O(IB P(ZX,Z),-1 ) Q:'Z!(IB PO) S Z0= 0 F S Z0= $O(IBP(ZX, Z,Z0)) Q:' Z0 S Z1=$ G(^DGCR(39 9,IBIFN,"C P",Z0,0)) D Q:IBPO
3067	"RTN","IBC EF22",69,0 )
3068	... ; Ign ore if not a CPT or a modifier exists an d this is first pass
3069	"RTN","IBC EF22",70,0 )
3070	... S IBM OD=$$GETMO D^IBEFUNC( IBIFN,Z0,1 )
3071	"RTN","IBC EF22",71,0 )
3072	... Q:$S( $P(Z1,U)'[ "ICPT":1,Q Q=1:IBMOD' ="",1:0)
3073	"RTN","IBC EF22",72,0 )
3074	... S IBP O=+$P(Z1,U ,4),IBX1=$ P(Z1,U,2)
3075	"RTN","IBC EF22",73,0 )
3076	... K IBP (+Z1_U_IBM OD,Z,Z0)
3077	"RTN","IBC EF22",74,0 )
3078	. ;
3079	"RTN","IBC EF22",75,0 )
3080	. I IBX'= "" D ; re venue code is valid
3081	"RTN","IBC EF22",76,0 )
3082	.. S LST= $S(LST="": 900,1:LST+ 1)
3083	"RTN","IBC EF22",77,0 )
3084	.. F Z=LS T:1 S Z0=$ S(IBPO:IBP O,$D(IBX(" "_$P(IBX, U),Z)):0,1 :Z) I Z0 S (LST,IBPO )=Z0 Q
3085	"RTN","IBC EF22",78,0 )
3086	.. S IBX( " "_$P(IBX ,U),IBPO,I BDA)=IBX,I BX(" "_$P( IBX,U),IBP O,IBDA,"DT ")=$S(IBX1 :IBX1,1:IB DEF),IBX(" "_$P(IBX, U),IBPO,IB DA,"MOD")= IBMOD
3087	"RTN","IBC EF22",79,0 )
3088	;
3089	"RTN","IBC EF22",80,0 )
3090	; Loop th rough reve nue codes in IBX and build the array IBX 1.
3091	"RTN","IBC EF22",81,0 )
3092	;
3093	"RTN","IBC EF22",82,0 )
3094	S IBS="" F S IBS=$ O(IBX(IBS) ) Q:IBS="" S IBPO=0 F S IBPO =$O(IBX(IB S,IBPO)) Q :'IBPO D
3095	"RTN","IBC EF22",83,0 )
3096	. S IBDA= 0 F S IBD A=$O(IBX(I BS,IBPO,IB DA)) Q:'IB DA S IBX= $G(IBX(IBS ,IBPO,IBDA )),IBZ=$G( ^DGCR(399, IBIFN,"RC" ,IBDA,0)) I IBX'="" D
3097	"RTN","IBC EF22",84,0 )
3098	.. ;S IBX S=$P(IBZ,U ,2)_U_$P(I BZ,U,6)_U_ $G(IBX(IBS ,IBPO,IBDA ,"MOD"))
3099	"RTN","IBC EF22",85,0 )
3100	.. S IBXS =U_$P(IBZ, U,6)_U_$G( IBX(IBS,IB PO,IBDA,"M OD")) ;com bine same proc and m odifiers r egardless of rate
3101	"RTN","IBC EF22",86,0 )
3102	.. S:IBPO '<900&'$$A CCRV($P(IB S," ",2))& $S(IBINPAT :$P(IBZ,U, 6),1:1) IB COMB(IBS,I BXS,IBPO)= IBDA
3103	"RTN","IBC EF22",87,0 )
3104	.. S:'$D( IBX1(IBS,I BPO,IBXS,1 )) IBX1(IB S,IBPO,IBX S,1)=IBX,I BX1(IBS,IB PO,IBXS,2) =IBZ
3105	"RTN","IBC EF22",88,0 )
3106	.. S $P(I BX1(IBS,IB PO,IBXS),U )=$P($G(IB X1(IBS,IBP O,IBXS)),U )+$P(IBZ,U ,3)
3107	"RTN","IBC EF22",89,0 )
3108	.. S $P(I BX1(IBS,IB PO,IBXS),U ,2)=$P($G( IBX1(IBS,I BPO,IBXS)) ,U,2)+$P(I BZ,U,4)
3109	"RTN","IBC EF22",90,0 )
3110	.. S IBX1 (IBS,IBPO, IBXS,"DT") =$G(IBX(IB S,IBPO,IBD A,"DT")),I BX1(IBS,IB PO,IBXS,"I EN")=$G(IB X1(IBS,IBP O,IBXS,"IE N"))_$S($G (IBX1(IBS, IBPO,IBXS, "IEN")):"; ",1:"")_IB DA
3111	"RTN","IBC EF22",91,0 )
3112	;
3113	"RTN","IBC EF22",92,0 )
3114	S IBS="" F S IBS=$ O(IBX1(IBS )) Q:IBS=" " S IBPO= 899 F S I BPO=$O(IBX 1(IBS,IBPO )) Q:'IBPO D ; Che ck to comb ine like r ev codes w ithout pri nt order
3115	"RTN","IBC EF22",93,0 )
3116	. N Q,Q0, Q1,Z,Z0,Z1 ,Z2,IBZ1,I BZ2
3117	"RTN","IBC EF22",94,0 )
3118	. S Z=""
3119	"RTN","IBC EF22",95,0 )
3120	. N IBACC
3121	"RTN","IBC EF22",96,0 )
3122	. F S Z= $O(IBX1(IB S,IBPO,Z)) Q:Z="" S Q=IBPO F S Q=$O(IB COMB(IBS,Z ,Q)) Q:'Q I Q'=IBPO S IBZ1=$G (IBX1(IBS, IBPO,Z,1)) ,IBZ2=$G(I BX1(IBS,IB PO,Z,2)) D
3123	"RTN","IBC EF22",97,0 )
3124	.. Q:$G(I BX1(IBS,IB PO,Z,1))'= $G(IBX1(IB S,Q,Z,1))
3125	"RTN","IBC EF22",98,0 )
3126	.. S Q1=1 ,IBACC=$$A CCRV(+$P(I BS," ",2))
3127	"RTN","IBC EF22",99,0 )
3128	.. F Q0=1 ,5:1:7,10: 1:13,15 D Q:'Q1
3129	"RTN","IBC EF22",100, 0)
3130	... I IBA CC Q:Q0=5! (Q0>6)
3131	"RTN","IBC EF22",101, 0)
3132	... I (Q0 =11!(Q0=15 ))&($P($G( IBX1(IBS,Q ,Z,2)),U,1 0)=3) Q
3133	"RTN","IBC EF22",102, 0)
3134	... I Q0= 5,'IBINPAT Q
3135	"RTN","IBC EF22",103, 0)
3136	... I $P( $G(IBX1(IB S,IBPO,Z,2 )),U,Q0)'= $P($G(IBX1 (IBS,Q,Z,2 )),U,Q0) S Q1=0
3137	"RTN","IBC EF22",104, 0)
3138	.. Q:'Q1
3139	"RTN","IBC EF22",105, 0)
3140	.. S $P(I BX1(IBS,IB PO,Z,2),U, 3)=$P(IBX1 (IBS,IBPO, Z,2),U,3)+ $P(IBX1(IB S,Q,Z,2),U ,3)
3141	"RTN","IBC EF22",106, 0)
3142	.. S $P(I BX1(IBS,IB PO,Z,2),U, 4)=$P(IBX1 (IBS,IBPO, Z,2),U,4)+ $P(IBX1(IB S,Q,Z,2),U ,4)
3143	"RTN","IBC EF22",107, 0)
3144	.. S $P(I BX1(IBS,IB PO,Z,2),U, 9)=$P(IBX1 (IBS,IBPO, Z,2),U,9)+ $P(IBX1(IB S,Q,Z,2),U ,9)
3145	"RTN","IBC EF22",108, 0)
3146	.. S IBX1 (IBS,IBPO, Z)=$P(IBX1 (IBS,IBPO, Z,2),U,3)_ U_$P(IBX1( IBS,IBPO,Z ,2),U,4)
3147	"RTN","IBC EF22",109, 0)
3148	.. S IBX1 (IBS,IBPO, Z,"IEN")=I BX1(IBS,IB PO,Z,"IEN" )_";"_IBX1 (IBS,Q,Z," IEN")
3149	"RTN","IBC EF22",110, 0)
3150	.. K IBX1 (IBS,Q,Z)
3151	"RTN","IBC EF22",111, 0)
3152	;
3153	"RTN","IBC EF22",112, 0)
3154	D SPLIT ; 488 ; ba a
3155	"RTN","IBC EF22",113, 0)
3156	;
3157	"RTN","IBC EF22",114, 0)
3158	; Loop th rough IBX1 and build the array IBXDATA. Everything in the
3159	"RTN","IBC EF22",115, 0)
3160	; array I BXDATA com es from th e array IB X1.
3161	"RTN","IBC EF22",116, 0)
3162	;
3163	"RTN","IBC EF22",117, 0)
3164	S IBS="", IBLN=0
3165	"RTN","IBC EF22",118, 0)
3166	F S IBS= $O(IBX1(IB S)) Q:IBS= "" S IBPO =0 F S IB PO=$O(IBX1 (IBS,IBPO) ) Q:'IBPO S IBSS="" F S IBSS =$O(IBX1(I BS,IBPO,IB SS)) Q:IBS S="" D
3167	"RTN","IBC EF22",119, 0)
3168	. S IBX=$ G(IBX1(IBS ,IBPO,IBSS ,1)),IBZ=$ G(IBX1(IBS ,IBPO,IBSS ,2))
3169	"RTN","IBC EF22",120, 0)
3170	. S IBLN= $G(IBLN)+1 ,IBXDATA(I BLN)=$P(IB X,U)_U_$P( IBZ,U,6)_U _$P(IBZ,U, 2)_U_+IBX1 (IBS,IBPO, IBSS)_U_+$ P(IBX1(IBS ,IBPO,IBSS ),U,2),$P( IBXDATA(IB LN),U,10)= $G(IBX1(IB S,IBPO,IBS S,"DT"))
3171	"RTN","IBC EF22",121, 0)
3172	. S $P(IB XDATA(IBLN ),U,6)=$P( IBZ,U,9),$ P(IBXDATA( IBLN),U,7) =$P(IBZ,U, 13),$P(IBX DATA(IBLN) ,U,8)=$G(I BX1(IBS,IB PO,IBSS,"I EN")),$P(I BXDATA(IBL N),U,9)=$P ($P(IBSS,U ,3),",",1, 2)
3173	"RTN","IBC EF22",122, 0)
3174	. S IBXDA TA(IBLN,"C PLNK")=$$R C2CP(IBIFN ,$P($P(IBX DATA(IBLN) ,U,8),";") )
3175	"RTN","IBC EF22",123, 0)
3176	. ;
3177	"RTN","IBC EF22",124, 0)
3178	. ; MRD;I B2.0516 - Added ND C and Unit s to line level of c laim.
3179	"RTN","IBC EF22",125, 0)
3180	. ;I IBXD ATA(IBLN," CPLNK") S $P(IBXDATA (IBLN),U,1 1,12)=$TR( $P($G(^DGC R(399,IBIF N,"CP",IBX DATA(IBLN, "CPLNK"),1 )),U,7,8), "-")
3181	"RTN","IBC EF22",126, 0)
3182	. ; VAD;I B2.0577 - Added Un it/Basis o f Measurem ent to lin e level of claim.
3183	"RTN","IBC EF22",127, 0)
3184	. I IBXDA TA(IBLN,"C PLNK") D
3185	"RTN","IBC EF22",128, 0)
3186	. . S $P( IBXDATA(IB LN),U,11,1 3)=$TR($P( $G(^DGCR(3 99,IBIFN," CP",IBXDAT A(IBLN,"CP LNK"),1)), U,7,8),"-" )_U_$P($G( ^DGCR(399, IBIFN,"CP" ,IBXDATA(I BLN,"CPLNK "),2)),U)
3187	"RTN","IBC EF22",129, 0)
3188	. . I +$P (IBXDATA(I BLN),U,12) S $P(IBXD ATA(IBLN), U,12)=$S($ P(IBXDATA( IBLN),U,12 )#1:+$J($P (IBXDATA(I BLN),U,12) ,0,3),1:$P (IBXDATA(I BLN),U,12) )
3189	"RTN","IBC EF22",130, 0)
3190	. ;
3191	"RTN","IBC EF22",131, 0)
3192	. ; Extra ct line le v COB data for sec o r tert bil l
3193	"RTN","IBC EF22",132, 0)
3194	. I $$COB N^IBCEF(IB IFN)>1 D C OBLINE^IBC EU6(IBIFN, IBLN,.IBXD ATA,,.IBXT RA) I $D(I BXTRA) D C OMBO^IBCEU 2(.IBXDATA ,.IBXTRA,1 ) ;Handle bundled/un bundled
3195	"RTN","IBC EF22",133, 0)
3196	;
3197	"RTN","IBC EF22",134, 0)
3198	I $D(^IBA (362.4,"AI FN"_IBIFN) )!$D(^IBA( 362.5,"AIF N"_IBIFN)) D
3199	"RTN","IBC EF22",135, 0)
3200	. N IBARR AY,IBX,IBZ ,IBRX,IBLC NT
3201	"RTN","IBC EF22",136, 0)
3202	. S IBLCN T=0
3203	"RTN","IBC EF22",137, 0)
3204	. ; Print prescript ions, pros thetics on front of UB-04
3205	"RTN","IBC EF22",138, 0)
3206	. D SET^I BCSC5A(IBI FN,.IBARRA Y)
3207	"RTN","IBC EF22",139, 0)
3208	. I $P(IB ARRAY,U,2) D
3209	"RTN","IBC EF22",140, 0)
3210	.. S IBX= +$P(IBARRA Y,U,2)+2
3211	"RTN","IBC EF22",141, 0)
3212	.. S IBLC NT=IBLCNT+ 1,IBXSAVE( "RX-UB-04" ,IBLCNT)=" "
3213	"RTN","IBC EF22",142, 0)
3214	.. S IBLC NT=IBLCNT+ 1,IBXSAVE( "RX-UB-04" ,IBLCNT)=" PRESCRIPTI ON REFILLS :",IBLCNT= 2
3215	"RTN","IBC EF22",143, 0)
3216	.. S IBX= 0 F S IBX =$O(IBARRA Y(IBX)) Q: IBX="" S IBY=0 F S IBY=$O(IB ARRAY(IBX, IBY)) Q:'I BY S IBRX =IBARRAY(I BX,IBY) D
3217	"RTN","IBC EF22",144, 0)
3218	... D ZER O^IBRXUTL( +$P(IBRX,U ,2))
3219	"RTN","IBC EF22",145, 0)
3220	... S IBL CNT=IBLCNT +1,IBXSAVE ("RX-UB-04 ",IBLCNT)= IBX_$J(" " ,(11-$L(IB X)))_" "_$ J($S($P(IB RX,U,6):"$ "_$FN($P(I BRX,U,6)," ,",2),1:"" ),10)_" " _$J($$FMTE ^XLFDT(IBY ,2),8)_" "_$G(^TMP( $J,"IBDRUG ",+$P(IBRX ,U,2),.01) )
3221	"RTN","IBC EF22",146, 0)
3222	... S IBZ =$S(+$P(IB RX,U,4):"Q TY: "_$P(I BRX,U,4)_" ",1:"")_$ S(+$P(IBRX ,U,3):"for "_$P(IBRX ,U,3)_" da ys supply ",1:"") I IBZ'="" S IBLCNT=IBL CNT+1,IBXS AVE("RX-UB -04",IBLCN T)=$J(" ", 35)_IBZ
3223	"RTN","IBC EF22",147, 0)
3224	... S IBZ =$S($P(IBR X,U,5)'="" :"NDC #: " _$P(IBRX,U ,5),1:"") I IBZ'="" S IBLCNT=I BLCNT+1,IB XSAVE("RX- UB-04",IBL CNT)=$J(" ",35)_IBZ
3225	"RTN","IBC EF22",148, 0)
3226	... K ^TM P($J,"IBDR UG")
3227	"RTN","IBC EF22",149, 0)
3228	... Q
3229	"RTN","IBC EF22",150, 0)
3230	. ;
3231	"RTN","IBC EF22",151, 0)
3232	. D SET^I BCSC5B(IBI FN,.IBARRA Y)
3233	"RTN","IBC EF22",152, 0)
3234	. I $P(IB ARRAY,U,2) D
3235	"RTN","IBC EF22",153, 0)
3236	.. S IBLC NT=0
3237	"RTN","IBC EF22",154, 0)
3238	.. S IBX= +$P(IBARRA Y,U,2)+2
3239	"RTN","IBC EF22",155, 0)
3240	.. S IBLC NT=IBLCNT+ 1,IBXSAVE( "PROS-UB-0 4",IBLCNT) =""
3241	"RTN","IBC EF22",156, 0)
3242	.. S IBLC NT=IBLCNT+ 1,IBXSAVE( "PROS-UB-0 4",IBLCNT) ="PROSTHET IC REFILLS :",IBLCNT= 2
3243	"RTN","IBC EF22",157, 0)
3244	.. S IBX= 0 F S IBX =$O(IBARRA Y(IBX)) Q: IBX="" S IBY=0 F S IBY=$O(IB ARRAY(IBX, IBY)) Q:'I BY D
3245	"RTN","IBC EF22",158, 0)
3246	... S IBL CNT=IBLCNT +1,IBXSAVE ("PROS-UB- 04",IBLCNT )=$$FMTE^X LFDT(IBX,2 )_" "_$J($ S($P(IBARR AY(IBX,IBY ),U,2):"$" _$FN($P(IB ARRAY(IBX, IBY),U,2), ",",2),1:" "),10)_" "_$E($$PIN B^IBCSC5B( +IBARRAY(I BX,IBY)),1 ,54)
3247	"RTN","IBC EF22",159, 0)
3248	Q
3249	"RTN","IBC EF22",160, 0)
3250	;
3251	"RTN","IBC EF22",161, 0)
3252	ACCRV(X) ; Returns 1 if X is a n accomoda tion RC, 0 if not
3253	"RTN","IBC EF22",162, 0)
3254	Q ((X'<10 0&(X'>219) )!(X=224))
3255	"RTN","IBC EF22",163, 0)
3256	;
3257	"RTN","IBC EF22",164, 0)
3258	RC2CP(IBIF N,IBRCIEN) ; returns "CP" mult iple point er that co rresponds to a given "RC" mult iple point er in file 399
3259	"RTN","IBC EF22",165, 0)
3260	; IBIFN - ien in fi le 399, to p level
3261	"RTN","IBC EF22",166, 0)
3262	; IBRCIEN , ien in s ub-file 39 9.042 (REV ENUE CODE)
3263	"RTN","IBC EF22",167, 0)
3264	;
3265	"RTN","IBC EF22",168, 0)
3266	; returns pointer t o sub-file 399.0304 (PROCEDURE S) or 0 if no valid pointer ca n be found .
3267	"RTN","IBC EF22",169, 0)
3268	;
3269	"RTN","IBC EF22",170, 0)
3270	N IBRC0,I BCPIEN
3271	"RTN","IBC EF22",171, 0)
3272	I +IBIFN' >0 Q 0
3273	"RTN","IBC EF22",172, 0)
3274	I +IBRCIE N'>0 Q 0
3275	"RTN","IBC EF22",173, 0)
3276	S IBRC0=$ G(^DGCR(39 9,IBIFN,"R C",IBRCIEN ,0)),IBCPI EN=0
3277	"RTN","IBC EF22",174, 0)
3278	I $P(IBRC 0,U,10)=4 S IBCPIEN= +$P(IBRC0, U,11) ; ty pe = CPT
3279	"RTN","IBC EF22",175, 0)
3280	I $P(IBRC 0,U,10)=3 S IBCPIEN= +$P(IBRC0, U,15) ; ty pe = RX
3281	"RTN","IBC EF22",176, 0)
3282	I 'IBCPIE N D
3283	"RTN","IBC EF22",177, 0)
3284	. S IBRC= $P(IBRC0,U ,6)
3285	"RTN","IBC EF22",178, 0)
3286	. N IBCPT IEN S IBCP TIEN=IBRC
3287	"RTN","IBC EF22",179, 0)
3288	. F S IB CPTIEN=$O( ^DGCR(399, IBIFN,"CP" ,"B",IBCPT IEN)) Q:(+ IBCPTIEN'= IBRC)!IBCP IEN D
3289	"RTN","IBC EF22",180, 0)
3290	.. N OK,Z S OK="",Z =""
3291	"RTN","IBC EF22",181, 0)
3292	.. S Z=$O (^DGCR(399 ,IBIFN,"CP ","B",IBCP TIEN,Z)) Q :'Z!OK D
3293	"RTN","IBC EF22",182, 0)
3294	... N CNT R S CNTR=0
3295	"RTN","IBC EF22",183, 0)
3296	... F S CNTR=$O(IB XDATA(CNTR )) Q:'CNTR !'OK D
3297	"RTN","IBC EF22",184, 0)
3298	.... I $G (IBXDATA(C NTR,"CPLNK "))=Z S OK =0 Q
3299	"RTN","IBC EF22",185, 0)
3300	... I OK= "" S OK=1, IBCPIEN=Z
3301	"RTN","IBC EF22",186, 0)
3302	I IBCPIEN ,'$D(^DGCR (399,IBIFN ,"CP",IBCP IEN)) S IB CPIEN=0
3303	"RTN","IBC EF22",187, 0)
3304	Q IBCPIEN
3305	"RTN","IBC EF22",188, 0)
3306	;
3307	"RTN","IBC EF22",189, 0)
3308	SPLIT ; Split cod es into mu ltiple lin es as need ed => baa ; 488
3309	"RTN","IBC EF22",190, 0)
3310	; The max line $ am ount for a printed c laim is le ss than th e max line $ amount for an ele ctronicall y transmit ted claim.
3311	"RTN","IBC EF22",191, 0)
3312	; However , since th e clearing house can drop to pr int for a myriad of reasons at any time, the lines may need to be spli t
3313	"RTN","IBC EF22",192, 0)
3314	; so they can all f it on a pr inted clai m line jus t in case. In additi on, since some claim s are sent to primar y payers a s
3315	"RTN","IBC EF22",193, 0)
3316	; electro nic claims but print ed for sec ondary cla ims, the l ines numbe rs need to be the sa me going o ut to ensu re the
3317	"RTN","IBC EF22",194, 0)
3318	; COB dat a is corre ct applied (previous payments adj, etc a re applied to the co rrect line .)
3319	"RTN","IBC EF22",195, 0)
3320	N IBS,IBS S,DATA,CHR G,UNTS,TOT ,LNS,MOD,C PT,LNK,RLN K,IBSS1,LT OT,LUNT,RE C,LST,FST
3321	"RTN","IBC EF22",196, 0)
3322	S IBS="", IBLN=0
3323	"RTN","IBC EF22",197, 0)
3324	F S IBS= $O(IBX1(IB S)) Q:IBS= "" D
3325	"RTN","IBC EF22",198, 0)
3326	. S LST=$ O(IBX1(IBS ,""),-1) ;we have t o go throu gh each le vel so mus t reset fo r each
3327	"RTN","IBC EF22",199, 0)
3328	. S LNK=0
3329	"RTN","IBC EF22",200, 0)
3330	. F S LN K=$O(IBX1( IBS,LNK)) Q:('LNK!(L NK>LST)) S IBSS="" F S IBSS= $O(IBX1(IB S,LNK,IBSS )) Q:IBSS= "" D
3331	"RTN","IBC EF22",201, 0)
3332	.. S DATA =IBX1(IBS, LNK,IBSS,2 )
3333	"RTN","IBC EF22",202, 0)
3334	.. S CHRG =$P(DATA,U ,2)
3335	"RTN","IBC EF22",203, 0)
3336	.. S UNTS =$P(DATA,U ,3)
3337	"RTN","IBC EF22",204, 0)
3338	.. I UNTS =1 Q ; if only one unit can't split
3339	"RTN","IBC EF22",205, 0)
3340	.. S TOT= UNTS*CHRG
3341	"RTN","IBC EF22",206, 0)
3342	.. I TOT< =9999999.9 9 Q ; if the total is less th am max we don't need to split
3343	"RTN","IBC EF22",207, 0)
3344	.. S LNS= TOT\999999 9.99
3345	"RTN","IBC EF22",208, 0)
3346	.. S MOD= TOT#999999 9.99
3347	"RTN","IBC EF22",209, 0)
3348	.. I MOD S LNS=LNS+ 1
3349	"RTN","IBC EF22",210, 0)
3350	.. I CHRG >4999999.9 95 S LNS=U NTS ; if the charge is greate r than hal f the mas can't put more than one on a l ine.
3351	"RTN","IBC EF22",211, 0)
3352	.. S LUNT =UNTS\LNS
3353	"RTN","IBC EF22",212, 0)
3354	.. S MOD= UNTS#LNS
3355	"RTN","IBC EF22",213, 0)
3356	.. I MOD S LUNT=LUN T+1
3357	"RTN","IBC EF22",214, 0)
3358	.. F L=1: 1:LNS D
3359	"RTN","IBC EF22",215, 0)
3360	... N Q
3361	"RTN","IBC EF22",216, 0)
3362	... S Q=$ O(IBX1(IBS ,""),-1)+1
3363	"RTN","IBC EF22",217, 0)
3364	... I L=1 S Q=LNK
3365	"RTN","IBC EF22",218, 0)
3366	... M IBX 1(IBS,Q,IB SS)=IBX1(I BS,LNK,IBS S)
3367	"RTN","IBC EF22",219, 0)
3368	... S $P( IBX1(IBS,Q ,IBSS,2),U ,3)=LUNT,$ P(IBX1(IBS ,Q,IBSS,2) ,U,4)=LUNT *CHRG
3369	"RTN","IBC EF22",220, 0)
3370	... S $P( IBX1(IBS,Q ,IBSS),U,1 )=LUNT,$P( IBX1(IBS,Q ,IBSS),U,2 )=LUNT*CHR G
3371	"RTN","IBC EF22",221, 0)
3372	... I L>1 S $P(IBX1 (IBS,Q,IBS S,2),U,9)= ""
3373	"RTN","IBC EF22",222, 0)
3374	... S UNT S=UNTS-LUN T,LUNT=$S( UNTS>LUNT: LUNT,1:UNT S)
3375	"RTN","IBC EF22",223, 0)
3376	Q
3377	"RTN","IBC EF77")
3378	0^8^B27726 430^B27920 356
3379	"RTN","IBC EF77",1,0)
3380	IBCEF77 ;W OIFO/SS - FORMATTER/ EXTRACT BI LL FUNCTIO NS ;31-JUL -03
3381	"RTN","IBC EF77",2,0)
3382	;;2.0;INT EGRATED BI LLING;23 2,280,155, 290,291,32 0,348,349, 516,577; 21-MAR-94; Build 34
3383	"RTN","IBC EF77",3,0)
3384	;;Per VA Directive 6402, this routine s hould not be modifie d.
3385	"RTN","IBC EF77",4,0)
3386	;
3387	"RTN","IBC EF77",5,0)
3388	SORT(IBPRN UM,IBPRTYP ,IB399,IBS RC,IBDST,I BN,IBEXC,I BSEQ,IBLIM IT) ;
3389	"RTN","IBC EF77",6,0)
3390	N IBXIEN, IBXDATA,IB NET,IBTRI, IB1,IB2,IB ID,Z,IBZ,I BZ1,IBSVP
3391	"RTN","IBC EF77",7,0)
3392	S (IB1,IB 2,IBZ,IBZ1 ,IBTRI)=""
3393	"RTN","IBC EF77",8,0)
3394	D F^IBCEF ("N-ALL AT T/RENDERIN G PROV SSN ","IBZ",,I B399)
3395	"RTN","IBC EF77",9,0)
3396	S IBZ1=$$ ALLPTYP^IB CEF3(IB399 )
3397	"RTN","IBC EF77",10,0 )
3398	F Z=1:1:3 S $P(IBZ1 ,U,Z)=$S($ P(IBZ1,U,Z )="CH":1,1 :"") S:$P( IBZ1,U,Z) IBTRI=1
3399	"RTN","IBC EF77",11,0 )
3400	S IBNET=$ $NETID^IBC EP() ; net wrk id typ e
3401	"RTN","IBC EF77",12,0 )
3402	I $G(IBN) D
3403	"RTN","IBC EF77",13,0 )
3404	. S Z=0 F S Z=$O(I BDST(IBPRN UM,IBPRTYP ,Z)) Q:'Z S IBID(+$ P(IBDST(IB PRNUM,IBPR TYP,Z),U,9 ))=""
3405	"RTN","IBC EF77",14,0 )
3406	F S IB1= $O(IBSRC(I B1)) Q:IB1 ="" D Q: IBN=IBLIMI T
3407	"RTN","IBC EF77",15,0 )
3408	. N OK,IB STLIC
3409	"RTN","IBC EF77",16,0 )
3410	. S IBSTL IC=""
3411	"RTN","IBC EF77",17,0 )
3412	. F S IB 2=$O(IBSRC (IB1,IB2)) Q:IB2="" D Q:IBN= IBLIMIT
3413	"RTN","IBC EF77",18,0 )
3414	. . S IBS VP=$P(IBSR C(IB1,IB2) ,U)
3415	"RTN","IBC EF77",19,0 )
3416	. . ; If ID overrid den, outpu t no other s of this type
3417	"RTN","IBC EF77",20,0 )
3418	. . I $G( IBEXC),$P( $G(IBSRC(I B1,IB2)),U ,9)=IBEXC Q
3419	"RTN","IBC EF77",21,0 )
3420	. . ; Ck state of c are/lic ma tch if st lic#
3421	"RTN","IBC EF77",22,0 )
3422	. . I $P( $G(IBSRC(I B1,IB2)),U ,3)="0B" S OK=1 D Q :'OK
3423	"RTN","IBC EF77",23,0 )
3424	. . . I + $$CAREST^I BCEP2A(IB3 99)'=$P(IB SRC(IB1,IB 2),U,7) S IBSTLIC=1 Q
3425	"RTN","IBC EF77",24,0 )
3426	. . . I $ G(IBSTLIC( 0))'="" S OK=0 Q
3427	"RTN","IBC EF77",25,0 )
3428	. . . S I BSTLIC(0)= $G(IBSRC(I B1,IB2)),O K=0
3429	"RTN","IBC EF77",26,0 )
3430	. . ; Exc lude SSN f rom sec id s unless r equired
3431	"RTN","IBC EF77",27,0 )
3432	. . I $P( $G(IBSRC(I B1,IB2)),U ,3)="SY" Q
3433	"RTN","IBC EF77",28,0 )
3434	. . ; Onl y 1 of eac h prov id type
3435	"RTN","IBC EF77",29,0 )
3436	. . Q:$D( IBID(+$P($ G(IBSRC(IB 1,IB2)),U, 9)))
3437	"RTN","IBC EF77",30,0 )
3438	. . S IBN =IBN+1,IBI D(+$P($G(I BSRC(IB1,I B2)),U,9)) =""
3439	"RTN","IBC EF77",31,0 )
3440	. . S IBD ST(IBPRNUM ,IBPRTYP,I BN)=$G(IBS RC(IB1,IB2 ))
3441	"RTN","IBC EF77",32,0 )
3442	. I IBN'= IBLIMIT,'$ G(IBSTLIC) ,$G(IBSTLI C(0))'="" S IBN=IBN+ 1,IBDST(IB PRNUM,IBPR TYP,IBN)=I BSTLIC(0)
3443	"RTN","IBC EF77",33,0 )
3444	I $$FT^IB CEF(IB399) =2,$G(IBID (IBNET))=" ",IBTRI,$P (IBZ1,U,IB SEQ) D ; WCJ 02/1 3/2006
3445	"RTN","IBC EF77",34,0 )
3446	. Q:$P(IB Z,U,IBPRTY P)=""
3447	"RTN","IBC EF77",35,0 )
3448	. ; here, no networ k id & TRI CARE ins c o.
3449	"RTN","IBC EF77",36,0 )
3450	. N Z
3451	"RTN","IBC EF77",37,0 )
3452	. S Z=+$O (^DGCR(399 ,IB399,"PR V","B",IBP RTYP,0)),Z =$P($G(^DG CR(399,IB3 99,"PRV",Z ,0)),U,2)
3453	"RTN","IBC EF77",38,0 )
3454	. S IBN=I BN+1,IBDST (IBPRNUM,I BPRTYP,IBN )=Z_U_+$$P OLICY^IBCE F(IB399,1, IBSEQ)_U_$ P($G(^IBE( 355.97,IBN ET,0)),U,3 )_U_$P(IBZ ,U,IBPRTYP )_U_"0^0^^ ^"_IBNET
3455	"RTN","IBC EF77",39,0 )
3456	Q
3457	"RTN","IBC EF77",40,0 )
3458	;
3459	"RTN","IBC EF77",41,0 )
3460	; esg - 8 /25/06 - I B2348 - CFIDS func tion
3461	"RTN","IBC EF77",42,0 )
3462	;
3463	"RTN","IBC EF77",43,0 )
3464	CFIDS(IBIF N,PRVTYP,A LLOWIDS) ; Claim For m IDs for human prov iders
3465	"RTN","IBC EF77",44,0 )
3466	; Functio n returns a 3 piece string: [ 1] default secondary ID qual
3467	"RTN","IBC EF77",45,0 )
3468	; [ 2] default secondary ID
3469	"RTN","IBC EF77",46,0 )
3470	; [ 3] NPI
3471	"RTN","IBC EF77",47,0 )
3472	; Input: IBIFN - internal c laim#
3473	"RTN","IBC EF77",48,0 )
3474	; PRVTYP - internal p rovider ty pe ID numb er
3475	"RTN","IBC EF77",49,0 )
3476	; - 1:REFER;2: OPER;3:REN D;4:ATT;5: SUPER;9:OT HER
3477	"RTN","IBC EF77",50,0 )
3478	; - if blank, then defau lt Att/Ren d based on form type
3479	"RTN","IBC EF77",51,0 )
3480	; ALLOWIDS - List of allowable Secondary IDS ^ deli mited.
3481	"RTN","IBC EF77",52,0 )
3482	; ex "^1A^1B ^1C^1H^G2^ LU^N5^"
3483	"RTN","IBC EF77",53,0 )
3484	; UB-04 only wants IDs provided by the pay er, not th e provider s own IDS
3485	"RTN","IBC EF77",54,0 )
3486	; Also, they want the qualifier to be G2 ( Commercial )
3487	"RTN","IBC EF77",55,0 )
3488	; if it is a payer pro vided ID
3489	"RTN","IBC EF77",56,0 )
3490	NEW ID,FT ,IBZ,IBQ,I BSID,IBNPI ,I,OK
3491	"RTN","IBC EF77",57,0 )
3492	S ID=""
3493	"RTN","IBC EF77",58,0 )
3494	I '$G(IBI FN) G CFID SX
3495	"RTN","IBC EF77",59,0 )
3496	S FT=$$FT ^IBCEF(IBI FN)
3497	"RTN","IBC EF77",60,0 )
3498	I '$G(PRV TYP) S PRV TYP=3 I FT =3 S PRVTY P=4
3499	"RTN","IBC EF77",61,0 )
3500	D ALLIDS^ IBCEF75(IB IFN,.IBZ,1 )
3501	"RTN","IBC EF77",62,0 )
3502	S OK=0 I $G(ALLOWID S)="" S OK =1
3503	"RTN","IBC EF77",63,0 )
3504	F I=1:1 D Q:OK
3505	"RTN","IBC EF77",64,0 )
3506	. S IBQ=$ P($G(IBZ(" PROVINF",I BIFN,"C",1 ,PRVTYP,I) ),U,3) ; qualifie r
3507	"RTN","IBC EF77",65,0 )
3508	. S IBSID =$P($G(IBZ ("PROVINF" ,IBIFN,"C" ,1,PRVTYP, I)),U,4) ; ID#
3509	"RTN","IBC EF77",66,0 )
3510	. I IBQ=" ",IBSID="" S OK=1 Q
3511	"RTN","IBC EF77",67,0 )
3512	. Q:OK
3513	"RTN","IBC EF77",68,0 )
3514	. I $G(AL LOWIDS)[(U _IBQ_U) S OK=1,IBQ=" G2" Q
3515	"RTN","IBC EF77",69,0 )
3516	. S (IBQ, IBSID)=""
3517	"RTN","IBC EF77",70,0 )
3518	S IBNPI=" "
3519	"RTN","IBC EF77",71,0 )
3520	D F^IBCEF ("N-PROVID ER NPI COD ES","IBNPI ",,IBIFN)
3521	"RTN","IBC EF77",72,0 )
3522	S IBNPI=$ P(IBNPI,U, PRVTYP) ; NPI
3523	"RTN","IBC EF77",73,0 )
3524	;
3525	"RTN","IBC EF77",74,0 )
3526	; special check for the refer ring doc
3527	"RTN","IBC EF77",75,0 )
3528	I PRVTYP= 1,$D(IBZ(" PROVINF",I BIFN,"C",1 ,PRVTYP)), IBQ="",IBS ID="" S IB Q="1G",IBS ID="VAD000 "
3529	"RTN","IBC EF77",76,0 )
3530	;
3531	"RTN","IBC EF77",77,0 )
3532	; If UB-0 4 and no I Ds, use VA UPIN as d eafult
3533	"RTN","IBC EF77",78,0 )
3534	I $D(IBZ( "PROVINF", IBIFN,"C", 1,PRVTYP)) ,FT=3,IBQ= "",IBSID=" " S IBQ="1 G",IBSID=" VAD000"
3535	"RTN","IBC EF77",79,0 )
3536	;
3537	"RTN","IBC EF77",80,0 )
3538	; determi ne if lega cy ID's sh ould be di splayed
3539	"RTN","IBC EF77",81,0 )
3540	I '$$PRTL ID(IBIFN,I BNPI) S (I BQ,IBSID)= ""
3541	"RTN","IBC EF77",82,0 )
3542	;
3543	"RTN","IBC EF77",83,0 )
3544	S ID=IBQ_ U_IBSID_U_ IBNPI
3545	"RTN","IBC EF77",84,0 )
3546	CFIDSX ;
3547	"RTN","IBC EF77",85,0 )
3548	Q ID
3549	"RTN","IBC EF77",86,0 )
3550	;
3551	"RTN","IBC EF77",87,0 )
3552	DOL(AMT,LE N,DEC) ; f ormat doll ar amounts for print ed claim f orms
3553	"RTN","IBC EF77",88,0 )
3554	; AMT = a mount to b e formatte d
3555	"RTN","IBC EF77",89,0 )
3556	; LEN = l ength of f ield - rig ht justifi ed to this length
3557	"RTN","IBC EF77",90,0 )
3558	; DEC = f lag to inc lude the d ecimal poi nt or not
3559	"RTN","IBC EF77",91,0 )
3560	; D EFAULT val ue is to n ot include the decim al point
3561	"RTN","IBC EF77",92,0 )
3562	; i f DEC is n ot defined or 0, ass ume no dec imal point
3563	"RTN","IBC EF77",93,0 )
3564	; s o 15 will be returne d as 1500, 6.77 will be return ed as 677
3565	"RTN","IBC EF77",94,0 )
3566	; i f DEC is 1 , then the decimal p oint will be include d
3567	"RTN","IBC EF77",95,0 )
3568	;
3569	"RTN","IBC EF77",96,0 )
3570	S LEN=$G( LEN,10),DE C=$G(DEC,0 ) ; de faults
3571	"RTN","IBC EF77",97,0 )
3572	S AMT=$FN (+$G(AMT), "",2) ; fo rmat # wit h 2 decima ls
3573	"RTN","IBC EF77",98,0 )
3574	I 'DEC S AMT=$TR(AM T,".") ; st rip or lea ve decimal
3575	"RTN","IBC EF77",99,0 )
3576	S AMT=$J( AMT,LEN) ; ri ght justif y
3577	"RTN","IBC EF77",100, 0)
3578	Q AMT
3579	"RTN","IBC EF77",101, 0)
3580	;
3581	"RTN","IBC EF77",102, 0)
3582	PRTLID(IBI FN,NPI) ; YMG; Print Legacy ID s on the C MS-1500 or UB-04 for m
3583	"RTN","IBC EF77",103, 0)
3584	; Functio n fetches form type associated with give n claim nu mber
3585	"RTN","IBC EF77",104, 0)
3586	; (values : 2 - CMS- 1500 form, 3 - UB-04 form), th en looks a t
3587	"RTN","IBC EF77",105, 0)
3588	; "Print Legacy ID" site para meter for this parti cular form type.
3589	"RTN","IBC EF77",106, 0)
3590	;
3591	"RTN","IBC EF77",107, 0)
3592	; Possibl e site par ameter val ues are:
3593	"RTN","IBC EF77",108, 0)
3594	; "Y" - always pr int Legacy ID
3595	"RTN","IBC EF77",109, 0)
3596	; "N" - never pri nt Legacy ID
3597	"RTN","IBC EF77",110, 0)
3598	; "C" - only prin t Legacy I D if NPI i s not avai lable.
3599	"RTN","IBC EF77",111, 0)
3600	;
3601	"RTN","IBC EF77",112, 0)
3602	; This in formation is used to determine if Legacy ID should be printe d
3603	"RTN","IBC EF77",113, 0)
3604	; for cla im number in questio n.
3605	"RTN","IBC EF77",114, 0)
3606	;
3607	"RTN","IBC EF77",115, 0)
3608	; Note: S ituation w hen "Print Legacy ID " site par ameter is not set is treated
3609	"RTN","IBC EF77",116, 0)
3610	; a s if this parameter was set to "Y" - alw ays print Legacy ID.
3611	"RTN","IBC EF77",117, 0)
3612	;
3613	"RTN","IBC EF77",118, 0)
3614	; Input:
3615	"RTN","IBC EF77",119, 0)
3616	; IBIFN - interna l claim nu mber
3617	"RTN","IBC EF77",120, 0)
3618	; N PI - NPI number (o r "" if no NPI is av ailable)
3619	"RTN","IBC EF77",121, 0)
3620	;
3621	"RTN","IBC EF77",122, 0)
3622	; Returns :
3623	"RTN","IBC EF77",123, 0)
3624	; 0 - Legacy ID should not be pr inted
3625	"RTN","IBC EF77",124, 0)
3626	; 1 - Legacy ID should be printe d
3627	"RTN","IBC EF77",125, 0)
3628	;
3629	"RTN","IBC EF77",126, 0)
3630	Q $S(NPI= "":"YC",1: "Y")[$P($G (^IBE(350. 9,1,1)),U, $S($$FT^IB CEF(IBIFN) =2:32,1:33 ))
3631	"RTN","IBC EF77",127, 0)
3632	;
3633	"RTN","IBC EF77",128, 0)
3634	REMARK(IBI FN,IBXDATA ,OFLG) ; p rocedure t o return a rray of UB -04 remark text
3635	"RTN","IBC EF77",129, 0)
3636	; for cla im IBIFN. Data pull ed from fi eld# 402 o f file 399 and
3637	"RTN","IBC EF77",130, 0)
3638	; formatt ed into an array IBX DATA(n) wh ere each l ine is not greater
3639	"RTN","IBC EF77",131, 0)
3640	; than 24 character s long. T his will f it into UB -04 FL-80.
3641	"RTN","IBC EF77",132, 0)
3642	;
3643	"RTN","IBC EF77",133, 0)
3644	; OFLG=1 only when called in the output formatter . In this case, onl y
3645	"RTN","IBC EF77",134, 0)
3646	; 4 lines in IBXDAT A will be returned.
3647	"RTN","IBC EF77",135, 0)
3648	;
3649	"RTN","IBC EF77",136, 0)
3650	NEW TEXT, LEN,IBZ,J, PCE,CHS,NE WCHS,IBK,J ,TX,IBCP1
3651	"RTN","IBC EF77",137, 0)
3652	K IBXDATA
3653	"RTN","IBC EF77",138, 0)
3654	;
3655	"RTN","IBC EF77",139, 0)
3656	; MRD;IB* 2.0*516 - Pull the B ill Remark s for the claim. If this was
3657	"RTN","IBC EF77",140, 0)
3658	; called from the O utput Form atter, the n look at lines of c laim for
3659	"RTN","IBC EF77",141, 0)
3660	; NDC's. If any ar e found, t hey should be added to the end of TEXT.
3661	"RTN","IBC EF77",142, 0)
3662	;
3663	"RTN","IBC EF77",143, 0)
3664	S TEXT=$P ($G(^DGCR( 399,+$G(IB IFN),"UF2" )),U,3)
3665	"RTN","IBC EF77",144, 0)
3666	; VAD/ Be gin of IB* 2*577 chan ges
3667	"RTN","IBC EF77",145, 0)
3668	; NDC, Qu antity, an d Unit of Measure no w printed in FL-43
3669	"RTN","IBC EF77",146, 0)
3670	; instead of here i n FL-80
3671	"RTN","IBC EF77",147, 0)
3672	;I $G(OFL G) D
3673	"RTN","IBC EF77",148, 0)
3674	;. S J=0
3675	"RTN","IBC EF77",149, 0)
3676	;. F S J =$O(^DGCR( 399,+$G(IB IFN),"CP", J)) Q:'J S IBCP1=$G (^(J,1)) I $P(IBCP1, U,7)'="" D
3677	"RTN","IBC EF77",150, 0)
3678	;. . I TE XT'="" S T EXT=TEXT_" "
3679	"RTN","IBC EF77",151, 0)
3680	;. . S TE XT=TEXT_"N 4"_$TR($P( IBCP1,U,7) ,"-")_" UN "_$P(IBCP1 ,U,8)
3681	"RTN","IBC EF77",152, 0)
3682	;. . Q
3683	"RTN","IBC EF77",153, 0)
3684	;. Q
3685	"RTN","IBC EF77",154, 0)
3686	; VAD/ En d of IB2 577 change s
3687	"RTN","IBC EF77",155, 0)
3688	;
3689	"RTN","IBC EF77",156, 0)
3690	; If ther e's nothin g in TEXT, then Quit .
3691	"RTN","IBC EF77",157, 0)
3692	;
3693	"RTN","IBC EF77",158, 0)
3694	I TEXT="" Q
3695	"RTN","IBC EF77",159, 0)
3696	;
3697	"RTN","IBC EF77",160, 0)
3698	; need to break up large word s for word wrapping purposes t o get
3699	"RTN","IBC EF77",161, 0)
3700	; as many character s as possi ble in the box.
3701	"RTN","IBC EF77",162, 0)
3702	S LEN=17
3703	"RTN","IBC EF77",163, 0)
3704	F PCE=1:1 Q:PCE>$L( TEXT," ") S CHS=$P( TEXT," ",P CE) I $L(C HS)>LEN D
3705	"RTN","IBC EF77",164, 0)
3706	. S NEWCH S=$E(CHS,1 ,LEN)_" "_ $E(CHS,LEN +1,999)
3707	"RTN","IBC EF77",165, 0)
3708	. S $P(TE XT," ",PCE )=NEWCHS
3709	"RTN","IBC EF77",166, 0)
3710	. Q
3711	"RTN","IBC EF77",167, 0)
3712	;
3713	"RTN","IBC EF77",168, 0)
3714	; When ca lling FSTR NG^IBJU1 w hich calls ^DIWP, Fi leMan buil ds the
3715	"RTN","IBC EF77",169, 0)
3716	; array w ith string s of max l ength=1 le ss than wh at you tel l it.
3717	"RTN","IBC EF77",170, 0)
3718	;
3719	"RTN","IBC EF77",171, 0)
3720	S LEN=20 ; line 1 is 19 chars
3721	"RTN","IBC EF77",172, 0)
3722	D FSTRNG^ IBJU1(TEXT ,LEN,.IBZ) ; build IBZ array
3723	"RTN","IBC EF77",173, 0)
3724	S IBK=$$T RIM^XLFSTR ($G(IBZ(1) )) ; save off t he first l ine
3725	"RTN","IBC EF77",174, 0)
3726	S TEXT=$P (TEXT,IBK, 2,99) ; restore th e rest of the text
3727	"RTN","IBC EF77",175, 0)
3728	S TEXT=$$ TRIM^XLFST R(TEXT) ; trim space s
3729	"RTN","IBC EF77",176, 0)
3730	;
3731	"RTN","IBC EF77",177, 0)
3732	S LEN=25 ; the rest i s 24 chars
3733	"RTN","IBC EF77",178, 0)
3734	D FSTRNG^ IBJU1(TEXT ,LEN,.IBZ) ; build IBZ array
3735	"RTN","IBC EF77",179, 0)
3736	S IBXDATA (1)=" "_IBK ; line 1
3737	"RTN","IBC EF77",180, 0)
3738	S J=0 F S J=$O(IBZ (J)) Q:'J D ; lines 2-n
3739	"RTN","IBC EF77",181, 0)
3740	. I J>3,$ G(OFLG) Q ; only 4 lin es for out put format ter
3741	"RTN","IBC EF77",182, 0)
3742	. S TX=$$ TRIM^XLFST R($G(IBZ(J )))
3743	"RTN","IBC EF77",183, 0)
3744	. I TX'=" " S IBXDAT A(J+1)=TX
3745	"RTN","IBC EF77",184, 0)
3746	. Q
3747	"RTN","IBC EF77",185, 0)
3748	Q
3749	"RTN","IBC EF77",186, 0)
3750	;
3751	"RTN","IBC EF77",187, 0)
3752	B43(NDCDAT A) ; This is passed a string a nd properl y formats if there i s NDC drug informati on.
3753	"RTN","IBC EF77",188, 0)
3754	; The dru g informat ion is in pieces 21- 23 of that string.
3755	"RTN","IBC EF77",189, 0)
3756	; It was part of th e output f ormatter e ntry 364.7 [1406] use d for FL43 but that got too bi g for a Fi leMan Mump s data ele ment
3757	"RTN","IBC EF77",190, 0)
3758	; It retu rns a stri ng with N4 - the NDC Drug qual ifier
3759	"RTN","IBC EF77",191, 0)
3760	; NDC Code witho ut the hyp hens
3761	"RTN","IBC EF77",192, 0)
3762	; a sp ace
3763	"RTN","IBC EF77",193, 0)
3764	; Unit s qualifie r
3765	"RTN","IBC EF77",194, 0)
3766	; Unit s
3767	"RTN","IBC EF77",195, 0)
3768	; Ex "N41 2345678901 ML1.5"
3769	"RTN","IBC EF77",196, 0)
3770	I NDCDATA ="" Q ""
3771	"RTN","IBC EF77",197, 0)
3772	S NDCDATA =$P(NDCDAT A,U,21,23)
3773	"RTN","IBC EF77",198, 0)
3774	Q:$P(NDCD ATA,U)="" ""
3775	"RTN","IBC EF77",199, 0)
3776	Q "N4"_$T R($P(NDCDA TA,U),"-") _" "_$TR($ P(NDCDATA, U,2,3),U)
3777	"RTN","IBC EF77",200, 0)
3778	;
3779	"RTN","IBC ERP7")
3780	0^13^B3285 5168^n/a
3781	"RTN","IBC ERP7",1,0)
3782	IBCERP7 ;A ITC/KDM - HID HCCH Payer ID Report ;5/ 4/2017
3783	"RTN","IBC ERP7",2,0)
3784	;;2.0;INT EGRATED BI LLING;57 7;21-MAR -94;Build 34
3785	"RTN","IBC ERP7",3,0)
3786	;;Per VA Directive 6402, this routine s hould not be modifie d.
3787	"RTN","IBC ERP7",4,0)
3788	; This re port is a PAYER ID r eport base d on the 2 77stat msg responses from the clearing h ouse
3789	"RTN","IBC ERP7",5,0)
3790	; This re port will give a sna p shot vie w of what is on file at the ti me of runn ing.
3791	"RTN","IBC ERP7",6,0)
3792	; The res ults may v ary each r unning dep ending on the timing of transa ctions pos ted to the file
3793	"RTN","IBC ERP7",7,0)
3794	; Refer t o US976
3795	"RTN","IBC ERP7",8,0)
3796	; Called by IB BILL ING SUPERV ISOR MENU, Opt:SYST, Opt:HID
3797	"RTN","IBC ERP7",9,0)
3798	;
3799	"RTN","IBC ERP7",10,0 )
3800	ENT ; Menu Option En try Point
3801	"RTN","IBC ERP7",11,0 )
3802	N BEGDT,B EGIN,DT,EN D,ENDDT,HD R1,HDR2,HD R3,IBABEG, IBAEND,IBE OB,IBIFN,I BQUIT,LNTO T,MAX,PAGE S,PGC,RNAM E,U,Y
3803	"RTN","IBC ERP7",12,0 )
3804	N CNT,DAS H,EORMSG,N ONEMSG,POP
3805	"RTN","IBC ERP7",13,0 )
3806	S IBQUIT= 0,RNAME="I BCERP7"
3807	"RTN","IBC ERP7",14,0 )
3808	D DATES Q :IBQUIT Q :'Y
3809	"RTN","IBC ERP7",15,0 )
3810	D DEVICE Q:POP Q:I BQUIT
3811	"RTN","IBC ERP7",16,0 )
3812	QUE ; Queu ed Entry P oint
3813	"RTN","IBC ERP7",17,0 )
3814	K ^TMP(RN AME,$J)
3815	"RTN","IBC ERP7",18,0 )
3816	D GATHER
3817	"RTN","IBC ERP7",19,0 )
3818	D HDRINIT
3819	"RTN","IBC ERP7",20,0 )
3820	D HEADER Q:IBQUIT
3821	"RTN","IBC ERP7",21,0 )
3822	D PRINT
3823	"RTN","IBC ERP7",22,0 )
3824	D EXIT
3825	"RTN","IBC ERP7",23,0 )
3826	Q
3827	"RTN","IBC ERP7",24,0 )
3828	DATES ; E nter the f rom and to dates for this repo rt
3829	"RTN","IBC ERP7",25,0 )
3830	;
3831	"RTN","IBC ERP7",26,0 )
3832	N DIR
3833	"RTN","IBC ERP7",27,0 )
3834	W ! S DIR (0)="DA^:D T:EX",DIR( "A")="Ente r Earliest Date: ",D IR("B")=$$ HTE^XLFDT( $H-30),DIR ("?")="Ent er the ear liest tran saction da te for the transacti on report. "
3835	"RTN","IBC ERP7",28,0 )
3836	D ^DIR K DIR Q:'Y S IBABEG=+ Y,BEGIN=Y( 0),BEGDT=$ $FMTE^XLFD T(IBABEG,2 )
3837	"RTN","IBC ERP7",29,0 )
3838	;
3839	"RTN","IBC ERP7",30,0 )
3840	W ! S DIR (0)="DA^"_ +Y_":DT:EX ",DIR("A") ="Enter La test Date: ",DIR("B" )=$$FMTE^X LFDT(DT,1)
3841	"RTN","IBC ERP7",31,0 )
3842	; DIR("?" )="Enter t he latest date for t he transac tion repor t."
3843	"RTN","IBC ERP7",32,0 )
3844	D ^DIR K DIR Q:'Y S IBAEND=+ Y,END=Y(0) ,ENDDT=$$F MTE^XLFDT( IBAEND,2)
3845	"RTN","IBC ERP7",33,0 )
3846	;
3847	"RTN","IBC ERP7",34,0 )
3848	Q
3849	"RTN","IBC ERP7",35,0 )
3850	;
3851	"RTN","IBC ERP7",36,0 )
3852	DEVICE ; - Ask devic e
3853	"RTN","IBC ERP7",37,0 )
3854	;
3855	"RTN","IBC ERP7",38,0 )
3856	N %ZIS,ZT DESC,ZTIO, ZTQUEUED,Z TRTN,ZTSAV E
3857	"RTN","IBC ERP7",39,0 )
3858	W !!!,"Yo u will nee d a 132 co lumn print er for thi s report", !
3859	"RTN","IBC ERP7",40,0 )
3860	S %ZIS="Q M" D ^%ZIS S:POP IBQ UIT=1 Q:PO P
3861	"RTN","IBC ERP7",41,0 )
3862	I $D(IO(" Q")) D S IBQUIT=1 Q
3863	"RTN","IBC ERP7",42,0 )
3864	. S ZTRTN ="QUE^IBCE RP7",ZTDES C="HCCH Pa yer ID Rep ort"
3865	"RTN","IBC ERP7",43,0 )
3866	. S ZTSAV E("BEGIN") =""
3867	"RTN","IBC ERP7",44,0 )
3868	. S ZTSAV E("END")=" "
3869	"RTN","IBC ERP7",45,0 )
3870	. S ZTSAV E("IBABEG" )=""
3871	"RTN","IBC ERP7",46,0 )
3872	. S ZTSAV E("IBAEND" )=""
3873	"RTN","IBC ERP7",47,0 )
3874	. S ZTSAV E("BEGDT") =""
3875	"RTN","IBC ERP7",48,0 )
3876	. S ZTSAV E("ENDDT") =""
3877	"RTN","IBC ERP7",49,0 )
3878	. S ZTSAV E("RNAME") =""
3879	"RTN","IBC ERP7",50,0 )
3880	. S ZTSAV E("IBQUIT" )=""
3881	"RTN","IBC ERP7",51,0 )
3882	. D ^%ZTL OAD
3883	"RTN","IBC ERP7",52,0 )
3884	. W !!,$S ($D(ZTSK): "Your task number "_ ZTSK_" has been queu ed.",1:"Un able to qu eue this j ob.")
3885	"RTN","IBC ERP7",53,0 )
3886	. K ZTSK D HOME^%ZI S
3887	"RTN","IBC ERP7",54,0 )
3888	. W !!! I $E(IOST,1 ,2)["C-" K DIR S DIR (0)="E" D ^DIR K DIR ;pause to see ta sk no.
3889	"RTN","IBC ERP7",55,0 )
3890	U IO
3891	"RTN","IBC ERP7",56,0 )
3892	Q
3893	"RTN","IBC ERP7",57,0 )
3894	;
3895	"RTN","IBC ERP7",58,0 )
3896	GATHER ;GO GET THE I NFO BASED ON THE DAT ES ENTERED
3897	"RTN","IBC ERP7",59,0 )
3898	; uses ^D IC(36,"AED IX",DATE,I NSURANCE I EN,) to ge t data wit hin date r ange.
3899	"RTN","IBC ERP7",60,0 )
3900	; If data is within date rang e sets up ^TMP($J fi le with al l data nee ded for th e report.
3901	"RTN","IBC ERP7",61,0 )
3902	; ^DIC(36 ,"AEDIX",D ATE,INSURA NCE IEN ,E DI ID NUMB ER,TYPE "P " OR "I")= EDI ID NUM BER ON FIL E ;
3903	"RTN","IBC ERP7",62,0 )
3904	;
3905	"RTN","IBC ERP7",63,0 )
3906	;(If EDI NUMBER ON FILE is n ull- it is considere d updated , not atte mpted)
3907	"RTN","IBC ERP7",64,0 )
3908	;
3909	"RTN","IBC ERP7",65,0 )
3910	; Uses t he insuran ce ien fro m Cross re f to extra ct the nam e, address , city, an d state fr om the ^DI C(36,IEN)
3911	"RTN","IBC ERP7",66,0 )
3912	; Uses t he Type fr om cross r ef as the EDI PayerI D for the report. Fo r printing the I="In st";P="Pro f"
3913	"RTN","IBC ERP7",67,0 )
3914	; Uses t he EDI ID NUMBER fro m Cross re f to be th e NewValue on report .
3915	"RTN","IBC ERP7",68,0 )
3916	; Uses t he EDI ID NUMBER ON FILE from cross ref to be the OldValue o n report
3917	"RTN","IBC ERP7",69,0 )
3918	; If the EDI ID NU MBER ON FI LE from cr oss ref is null- set the "upda ted" value for repor t to be "Y es", other wise "No"
3919	"RTN","IBC ERP7",70,0 )
3920	;
3921	"RTN","IBC ERP7",71,0 )
3922	;
3923	"RTN","IBC ERP7",72,0 )
3924	N DATE,ED IONFILE,ED INO,IBADDR ESS,IBCITY ,IBNAME,IB STATE,IBPI EN,LNCNT,T YPE
3925	"RTN","IBC ERP7",73,0 )
3926	S $P(DASH ,"_",132)= ""
3927	"RTN","IBC ERP7",74,0 )
3928	S U="^",L NTOT=0,PGC =1,MAX=IOS L
3929	"RTN","IBC ERP7",75,0 )
3930	S DATE=IB ABEG-1
3931	"RTN","IBC ERP7",76,0 )
3932	F S DATE =$O(^DIC(3 6,"AEDIX", DATE)) Q:D ATE="" Q: DATE>IBAEN D D
3933	"RTN","IBC ERP7",77,0 )
3934	. S IBPIE N="" F S IBPIEN=$O( ^DIC(36,"A EDIX",DATE ,IBPIEN)) Q:IBPIEN=" " D
3935	"RTN","IBC ERP7",78,0 )
3936	.. S EDIN O="" F S EDINO=$O(^ DIC(36,"AE DIX",DATE, IBPIEN,EDI NO)) Q:EDI NO="" D
3937	"RTN","IBC ERP7",79,0 )
3938	... S TYP E="" F S TYPE=$O(^D IC(36,"AED IX",DATE,I BPIEN,EDIN O,TYPE)) Q :TYPE="" D
3939	"RTN","IBC ERP7",80,0 )
3940	.... S ED IONFILE=$G (^DIC(36," AEDIX",DAT E,IBPIEN,E DINO,TYPE) )
3941	"RTN","IBC ERP7",81,0 )
3942	.... S IB NAME=$$GET 1^DIQ(36,I BPIEN,.01)
3943	"RTN","IBC ERP7",82,0 )
3944	.... S IB ADDRESS=$$ GET1^DIQ(3 6,IBPIEN,. 111)
3945	"RTN","IBC ERP7",83,0 )
3946	.... S IB CITY=$$GET 1^DIQ(36,I BPIEN,.114 )
3947	"RTN","IBC ERP7",84,0 )
3948	.... S IB STATE=$$GE T1^DIQ(36, IBPIEN,.11 5,"I")
3949	"RTN","IBC ERP7",85,0 )
3950	.... S ^T MP(RNAME,$ J,IBNAME,D ATE,EDINO, TYPE)=IBPI EN_U_IBADD RESS_U_IBC ITY_U_IBST ATE_U_EDIO NFILE
3951	"RTN","IBC ERP7",86,0 )
3952	.... S LN TOT=LNTOT+ 1
3953	"RTN","IBC ERP7",87,0 )
3954	Q
3955	"RTN","IBC ERP7",88,0 )
3956	;
3957	"RTN","IBC ERP7",89,0 )
3958	PRINT ; P rint data
3959	"RTN","IBC ERP7",90,0 )
3960	; PGC=pa ge ct,LNTO T=no of li nes to be printed,LN CNT=when t o page bre ak
3961	"RTN","IBC ERP7",91,0 )
3962	; MAX=IO SL (device length)
3963	"RTN","IBC ERP7",92,0 )
3964	;
3965	"RTN","IBC ERP7",93,0 )
3966	N ADDRESS ,CITY,DATE ,EDINO,EDI ONFILE,IEN ,NAME,PID, STATE,TYPE ,UPDATE
3967	"RTN","IBC ERP7",94,0 )
3968	S EORMSG= "*** END O F REPORT * **"
3969	"RTN","IBC ERP7",95,0 )
3970	S NONEMSG ="* * * N O D A T A T O P R I N T * * *"
3971	"RTN","IBC ERP7",96,0 )
3972	;
3973	"RTN","IBC ERP7",97,0 )
3974	I '$D(^TM P(RNAME,$J )) W !!!,N ONEMSG D E ND Q
3975	"RTN","IBC ERP7",98,0 )
3976	S NAME="" F S NAME =$O(^TMP(R NAME,$J,NA ME)) Q:NAM E="" D
3977	"RTN","IBC ERP7",99,0 )
3978	. S DATE= "" F S DA TE=$O(^TMP (RNAME,$J, NAME,DATE) ) Q:DATE=" " D
3979	"RTN","IBC ERP7",100, 0)
3980	.. S EDIN O="" F S EDINO=$O(^ TMP(RNAME, $J,NAME,DA TE,EDINO)) Q:EDINO=" " D
3981	"RTN","IBC ERP7",101, 0)
3982	... S TYP E="" F S TYPE=$O(^T MP(RNAME,$ J,NAME,DAT E,EDINO,TY PE)) Q:TYP E="" Q:IB QUIT D
3983	"RTN","IBC ERP7",102, 0)
3984	.... S PI D=$S(TYPE= "I":"Inst" ,1:"Prof")
3985	"RTN","IBC ERP7",103, 0)
3986	.... ;S N AME=$P(^TM P(RNAME,$J ,DATE,IEN, EDINO,TYPE ),U,1)
3987	"RTN","IBC ERP7",104, 0)
3988	.... S AD DRESS=$P(^ TMP(RNAME, $J,NAME,DA TE,EDINO,T YPE),U,2)
3989	"RTN","IBC ERP7",105, 0)
3990	.... S CI TY=$P(^TMP (RNAME,$J, NAME,DATE, EDINO,TYPE ),U,3)
3991	"RTN","IBC ERP7",106, 0)
3992	.... S ST ATE=$P(^DI C(5,$P(^TM P(RNAME,$J ,NAME,DATE ,EDINO,TYP E),U,4),0) ,U,2)
3993	"RTN","IBC ERP7",107, 0)
3994	.... S ED IONFILE=$P (^TMP(RNAM E,$J,NAME, DATE,EDINO ,TYPE),U,5 )
3995	"RTN","IBC ERP7",108, 0)
3996	.... S UP DATE=$S(ED IONFILE="" :"Yes",1:" No")
3997	"RTN","IBC ERP7",109, 0)
3998	.... I LN CNT>MAX D HEADER Q:I BQUIT
3999	"RTN","IBC ERP7",110, 0)
4000	.... W !, $E(NAME,1, 30),?33,$E (ADDRESS,1 ,35)," ",C ITY,", ",S TATE,?73,$ $FMTE^XLFD T(DATE,2), ?84,PID,?9 7,EDIONFIL E,?109,EDI NO,?121,UP DATE
4001	"RTN","IBC ERP7",111, 0)
4002	.... S LN CNT=LNCNT+ 1
4003	"RTN","IBC ERP7",112, 0)
4004	I LNCNT>M AX D HEADE R
4005	"RTN","IBC ERP7",113, 0)
4006	Q:IBQUIT
4007	"RTN","IBC ERP7",114, 0)
4008	END W !!!, ?49,EORMSG ,!!!
4009	"RTN","IBC ERP7",115, 0)
4010	I $E(IOST ,1,2)["C-" K DIR S D IR(0)="E" D ^DIR K D IR ;pau se at end of report
4011	"RTN","IBC ERP7",116, 0)
4012	Q
4013	"RTN","IBC ERP7",117, 0)
4014	;
4015	"RTN","IBC ERP7",118, 0)
4016	HDRINIT ; Initial se tting
4017	"RTN","IBC ERP7",119, 0)
4018	;
4019	"RTN","IBC ERP7",120, 0)
4020	S LNCNT=0
4021	"RTN","IBC ERP7",121, 0)
4022	I PGC=1,$ E(IOST,1,2 )["C-" W @ IOF ; ref resh termi nal screen on 1st hd r
4023	"RTN","IBC ERP7",122, 0)
4024	I 'LNTOT S PAGES=1
4025	"RTN","IBC ERP7",123, 0)
4026	I LNTOT,P GC=1 D
4027	"RTN","IBC ERP7",124, 0)
4028	. S LNCNT =0
4029	"RTN","IBC ERP7",125, 0)
4030	. S PAGES =LNTOT/(MA X-10) I PA GES<1 S PA GES=1
4031	"RTN","IBC ERP7",126, 0)
4032	. I PAGES ["." S PAG ES=$P(PAGE S+1,".") ; if mor e than one page set whole numb er
4033	"RTN","IBC ERP7",127, 0)
4034	S HDR1="C learinghou se Payer I D Report"
4035	"RTN","IBC ERP7",128, 0)
4036	S HDR2=$$ FMTE^XLFDT ($$NOW^XLF DT,1)
4037	"RTN","IBC ERP7",129, 0)
4038	Q
4039	"RTN","IBC ERP7",130, 0)
4040	;
4041	"RTN","IBC ERP7",131, 0)
4042	HEADER ; P rint Heade r info
4043	"RTN","IBC ERP7",132, 0)
4044	;
4045	"RTN","IBC ERP7",133, 0)
4046	N DIR,DUO UT
4047	"RTN","IBC ERP7",134, 0)
4048	S LNCNT=0
4049	"RTN","IBC ERP7",135, 0)
4050	I PGC'=1 D Q:IBQUI T
4051	"RTN","IBC ERP7",136, 0)
4052	. W !
4053	"RTN","IBC ERP7",137, 0)
4054	. I $E(IO ST,1,2)["C -" K DIR S DIR(0)="E " D ^DIR K DIR I $D( DUOUT) S I BQUIT=1 Q: IBQUIT
4055	"RTN","IBC ERP7",138, 0)
4056	. W @IOF ; refres h terminal screen on hdr
4057	"RTN","IBC ERP7",139, 0)
4058	W !,HDR1, ?43,HDR2,? 98," Page : "_PGC_" of "_PAGES
4059	"RTN","IBC ERP7",140, 0)
4060	W !,"Time frame: "_B EGDT_" thr u "_ENDDT
4061	"RTN","IBC ERP7",141, 0)
4062	W !!
4063	"RTN","IBC ERP7",142, 0)
4064	W !,"Insu rance Co", ?33,"Addre ss",?73,"D ate",?84," EDI-PayerI D",?97,"Ol dValue",?1 09,"NewVal ue",?121," Updated"
4065	"RTN","IBC ERP7",143, 0)
4066	W !,DASH
4067	"RTN","IBC ERP7",144, 0)
4068	S LNCNT=L NCNT+10,PG C=PGC+1
4069	"RTN","IBC ERP7",145, 0)
4070	Q
4071	"RTN","IBC ERP7",146, 0)
4072	EXIT() ;cl ean up and quit
4073	"RTN","IBC ERP7",147, 0)
4074	N ZTREQ
4075	"RTN","IBC ERP7",148, 0)
4076	; Force a form feed at end of a printer report
4077	"RTN","IBC ERP7",149, 0)
4078	I $E(IOST ,1,2)'["C- " W @IOF
4079	"RTN","IBC ERP7",150, 0)
4080	; handle device clo sing befor e exiting
4081	"RTN","IBC ERP7",151, 0)
4082	I $D(ZTQU EUED) S ZT REQ="@"
4083	"RTN","IBC ERP7",152, 0)
4084	I '$D(ZTQ UEUED) D ^ %ZISC
4085	"RTN","IBC ERP7",153, 0)
4086	K ^TMP(RN AME,$J)
4087	"RTN","IBC ERP7",154, 0)
4088	K BEGIN,B EGDT,ENDDT ,IBABEG,IB AEND,IBQUI T,IEN,LNCN T,Y
4089	"RTN","IBC ERP7",155, 0)
4090	Q
4091	"RTN","IBC EST")
4092	0^12^B9669 5131^B7602 7306
4093	"RTN","IBC EST",1,0)
4094	IBCEST ;AL B/TMP - 83 7 EDI STAT US MESSAGE PROCESSIN G ;17-APR- 96
4095	"RTN","IBC EST",2,0)
4096	;;2.0;INT EGRATED BI LLING;13 7,189,197, 135,283,32 0,368,397, 407,577; 21-MAR-94; Build 34
4097	"RTN","IBC EST",3,0)
4098	;;Per VA Directive 6402, this routine s hould not be modifie d.
4099	"RTN","IBC EST",4,0)
4100	; IA 4043 for call to AUDITX^ PRCAUDT
4101	"RTN","IBC EST",5,0)
4102	Q
4103	"RTN","IBC EST",6,0)
4104	;
4105	"RTN","IBC EST",7,0)
4106	UPD361(IBT DA) ; Upda te IB BILL STATUS ME SSAGES fil e
4107	"RTN","IBC EST",8,0)
4108	; IBTDA = ien of re turn messa ge in file 364.2
4109	"RTN","IBC EST",9,0)
4110	;
4111	"RTN","IBC EST",10,0)
4112	N IB,IB0, IBSEQ,IB00 ,IBBILL,IB BTCH,IBMNU M,IBDATE,I BTYP
4113	"RTN","IBC EST",11,0)
4114	;
4115	"RTN","IBC EST",12,0)
4116	I '$$LOCK ^IBCEM(IBT DA) G UPDQ ;Lock mes sage in fi le 364.2
4117	"RTN","IBC EST",13,0)
4118	;
4119	"RTN","IBC EST",14,0)
4120	S IB0=$G( ^IBA(364.2 ,IBTDA,0))
4121	"RTN","IBC EST",15,0)
4122	S IBMNUM= $P(IB0,U) ; Message number
4123	"RTN","IBC EST",16,0)
4124	S IB00=$G (^IBA(364, +$P(IB0,U, 5),0)) ; T ransmit bi ll entry
4125	"RTN","IBC EST",17,0)
4126	S IBBILL= +IB00 ; Ac tual bill ien in fil e 399
4127	"RTN","IBC EST",18,0)
4128	S IBBTCH= $P(IB0,U,4 ) ; Batch #
4129	"RTN","IBC EST",19,0)
4130	;
4131	"RTN","IBC EST",20,0)
4132	; Auto-au dit bills based on s tatus code on '10' r ecord of s tatus msg
4133	"RTN","IBC EST",21,0)
4134	; flat fi le
4135	"RTN","IBC EST",22,0)
4136	I IBBILL, $P($T(PRCA UDT+1^PRCA UDT),"**", 2)[",173" D
4137	"RTN","IBC EST",23,0)
4138	. N Z,Z0, Z1,OK
4139	"RTN","IBC EST",24,0)
4140	. Q:+$$ST A^PRCAFN(I BBILL)'=10 4
4141	"RTN","IBC EST",25,0)
4142	. S (Z,OK )=0
4143	"RTN","IBC EST",26,0)
4144	. F S Z= $O(^IBA(36 4.2,IBTDA, 2,Z)) Q:'Z S Z0=$P( $G(^(Z,0)) ,"##RAW DA TA: ",2) I +Z0=10 S Z0=$P(Z0,U ,5) D Q:O K
4145	"RTN","IBC EST",27,0)
4146	.. ; Stri p leading spaces
4147	"RTN","IBC EST",28,0)
4148	.. S Z0=$ $TRIM^XLFS TR(Z0)
4149	"RTN","IBC EST",29,0)
4150	.. Q:Z0=" "
4151	"RTN","IBC EST",30,0)
4152	.. I $$SC ODE^IBCEST 1(Z0),$P($ G(^DGCR(39 9.3,+$P($G (^DGCR(399 ,IBBILL,0) ),U,7),0)) ,U,11) D A UDITX^PRCA UDT(IBBILL ) S OK=1 ; IA 4043
4153	"RTN","IBC EST",31,0)
4154	;
4155	"RTN","IBC EST",32,0)
4156	I $S(IBMN UM="":1,1: 'IBBILL&(I BBTCH="")) D DELMSG^ IBCESRV2(I BTDA) G UP DQ
4157	"RTN","IBC EST",33,0)
4158	;
4159	"RTN","IBC EST",34,0)
4160	; Individ ual bill ; KDM US1 29 IB257 7 rework I ndividual vs. Batch to Correct Storage o f Payer ID
4161	"RTN","IBC EST",35,0)
4162	I IBBILL D UPDTBILL () G UPDQ
4163	"RTN","IBC EST",36,0)
4164	;
4165	"RTN","IBC EST",37,0)
4166	; Batch - update ea ch bill se parately
4167	"RTN","IBC EST",38,0)
4168	S IBBILL= ""
4169	"RTN","IBC EST",39,0)
4170	F S IBBI LL=$O(^IBA (364,"ABAB I",+IBBTCH ,IBBILL)) Q:'IBBILL D
4171	"RTN","IBC EST",40,0)
4172	. Q:$D(^T MP("IBCONF ",$J,IBBIL L)) ;Bill was rejec ted
4173	"RTN","IBC EST",41,0)
4174	. S IB=$O (^IBA(364, "ABABI",+I BBTCH,IBBI LL,0))
4175	"RTN","IBC EST",42,0)
4176	. Q:'IB
4177	"RTN","IBC EST",43,0)
4178	. D UPDTB ILL() ;KDM US129 IB2577 Correct St orage of P AYER ID
4179	"RTN","IBC EST",44,0)
4180	;
4181	"RTN","IBC EST",45,0)
4182	Q
4183	"RTN","IBC EST",46,0)
4184	;
4185	"RTN","IBC EST",47,0)
4186	UPDTBILL() ;KDM US129 IB2 577 New s ection to Correct St orage of P AYER ID
4187	"RTN","IBC EST",48,0)
4188	N IBA1,IB MSG0,IBPID
4189	"RTN","IBC EST",49,0)
4190	S IBPID=" ",IBA1=0
4191	"RTN","IBC EST",50,0)
4192	;
4193	"RTN","IBC EST",51,0)
4194	F S IBA1 =$O(^IBA(3 64.2,IBTDA ,2,IBA1)) Q:'IBA1 D Q:IBPID] ""
4195	"RTN","IBC EST",52,0)
4196	. S IBMSG 0=$P($G(^( IBA1,0))," ##RAW DATA : ",2)
4197	"RTN","IBC EST",53,0)
4198	. I +IBMS G0=277,$P( IBMSG0,U,5 )="N" S IB PID=$P(IBM SG0,U,11)
4199	"RTN","IBC EST",54,0)
4200	;
4201	"RTN","IBC EST",55,0)
4202	S IBSEQ=$ P(IB00,U,8 ) S:IBSEQ= "" IBSEQ=" P"
4203	"RTN","IBC EST",56,0)
4204	D STORE(I B0,IBBTCH, IBMNUM,IBT DA,IBBILL, IBSEQ,IBPI D,1)
4205	"RTN","IBC EST",57,0)
4206	Q
4207	"RTN","IBC EST",58,0)
4208	;
4209	"RTN","IBC EST",59,0)
4210	STORE(IB0, IBBTCH,IBM NUM,IBTDA, IBBILL,IBS EQ,IBPID,I B1) ;
4211	"RTN","IBC EST",60,0)
4212	;
4213	"RTN","IBC EST",61,0)
4214	; IB0 = 0 -node of m essage in file 364.2
4215	"RTN","IBC EST",62,0)
4216	; IBBTCH = ien of b atch in fi le 364.1
4217	"RTN","IBC EST",63,0)
4218	; IBMNUM = actual m essage num ber
4219	"RTN","IBC EST",64,0)
4220	; IBTDA = ien of me ssage in f ile 364.2
4221	"RTN","IBC EST",65,0)
4222	; IBBILL = ien of b ill in 399
4223	"RTN","IBC EST",66,0)
4224	; IBSEQ = P/S/T/ fo r COB sequ ence relat ed to mess age
4225	"RTN","IBC EST",67,0)
4226	; IBPID = the payer id return ed from cl earinghous e for the claim
4227	"RTN","IBC EST",68,0)
4228	; IB1 = f lag that s ays if the message w as for a s ingle bill or a batc h.
4229	"RTN","IBC EST",69,0)
4230	; B atch statu ses have a n addition al standar d text ent ry.
4231	"RTN","IBC EST",70,0)
4232	; 1 = single bill 0 = b atch
4233	"RTN","IBC EST",71,0)
4234	;
4235	"RTN","IBC EST",72,0)
4236	N DA,DIK, DIE,DIC,X, Y,DR,DO,DD ,DLAYGO,Z, Z0,Z1,Z2,Z 3,IBT,IBDU P,IBFLDS,I BY,IBAUTO, IBLN
4237	"RTN","IBC EST",73,0)
4238	;
4239	"RTN","IBC EST",74,0)
4240	S X=IBBIL L,IBDUP=0
4241	"RTN","IBC EST",75,0)
4242	;
4243	"RTN","IBC EST",76,0)
4244	S IBFLDS= ".02////"_ $P(IB0,U,3 )
4245	"RTN","IBC EST",77,0)
4246	S IBFLDS= IBFLDS_";. 03////"_$S ($$EXTERNA L^DILFD(36 4.2,.02,"U ",$P(IB0,U ,2))["REJ" :"R",1:"I" )_";.05/// /"_IBBTCH_ ";.06////" _IBMNUM_"; .04////"_+ $P(IB0,U,8 )_";.07/// /"_IBSEQ_$ S($P(IB0,U ,5):";.11/ ///"_$P(IB 0,U,5),1:" ")
4247	"RTN","IBC EST",78,0)
4248	S IBFLDS= IBFLDS_";. 12////"_$P (IB0,U,10) _";.09//// 0"
4249	"RTN","IBC EST",79,0)
4250	S IBFLDS= IBFLDS_";. 15////"_$$ CHKSUM^IBC EST1("^IBA (364.2,"_I BTDA_",2)" )
4251	"RTN","IBC EST",80,0)
4252	I IBPID'= "" D
4253	"RTN","IBC EST",81,0)
4254	. S IBPID ("TYPE")=$ S($$FT^IBC EF(IBBILL) =2:"P",1:" I")
4255	"RTN","IBC EST",82,0)
4256	. D UPDIN S(.IBPID,$ $POLICY^IB CEF(IBBILL ,1,$TR(IBS EQ,"PST"," 123")),IBB ILL,IBTDA) ;KDM US129 IB* 2*577
4257	"RTN","IBC EST",83,0)
4258	;
4259	"RTN","IBC EST",84,0)
4260	I IBDUP D I $D(Y) G UPDQ
4261	"RTN","IBC EST",85,0)
4262	. ; Stuff fields in to existin g entry
4263	"RTN","IBC EST",86,0)
4264	. ; (may be needed for reproc essing of aborted up dates)
4265	"RTN","IBC EST",87,0)
4266	. S DIE=" ^IBM(361," ,DA=IBDUP, DR=IBFLDS_ ";1///@"
4267	"RTN","IBC EST",88,0)
4268	. D ^DIE
4269	"RTN","IBC EST",89,0)
4270	. I $D(Y) S IBY=-1 Q ;Update not succe ssful
4271	"RTN","IBC EST",90,0)
4272	. S IBY=I BDUP
4273	"RTN","IBC EST",91,0)
4274	;
4275	"RTN","IBC EST",92,0)
4276	K IBT
4277	"RTN","IBC EST",93,0)
4278	I 'IBDUP D ; Creat e new entr y and stuf f fields
4279	"RTN","IBC EST",94,0)
4280	. S DIC(0 )="L",DIC= "^IBM(361, ",DLAYGO=3 61
4281	"RTN","IBC EST",95,0)
4282	. S DIC(" DR")=IBFLD S
4283	"RTN","IBC EST",96,0)
4284	. D FILE^ DICN
4285	"RTN","IBC EST",97,0)
4286	. K DO,DD ,DLAYGO,DI C
4287	"RTN","IBC EST",98,0)
4288	. S IBY=+ Y
4289	"RTN","IBC EST",99,0)
4290	. Q:IBY'> 0
4291	"RTN","IBC EST",100,0 )
4292	. ;
4293	"RTN","IBC EST",101,0 )
4294	. ; IB2 320 - Chec k for dupl icate stat us message
4295	"RTN","IBC EST",102,0 )
4296	. NEW IBN EW,IBOLD,P CE,Z,DIK,D A
4297	"RTN","IBC EST",103,0 )
4298	. S IBNEW =""
4299	"RTN","IBC EST",104,0 )
4300	. F PCE=3 ,4,5,7,8,1 1,15 S IBN EW=IBNEW_$ P($G(^IBM( 361,IBY,0) ),U,PCE)_U
4301	"RTN","IBC EST",105,0 )
4302	. S Z=0
4303	"RTN","IBC EST",106,0 )
4304	. F S Z= $O(^IBM(36 1,"B",IBBI LL,Z)) Q:' Z I Z'=IB Y D Q:IBY '>0
4305	"RTN","IBC EST",107,0 )
4306	.. S IBOL D=""
4307	"RTN","IBC EST",108,0 )
4308	.. F PCE= 3,4,5,7,8, 11,15 S IB OLD=IBOLD_ $P($G(^IBM (361,Z,0)) ,U,PCE)_U
4309	"RTN","IBC EST",109,0 )
4310	.. I IBNE W'=IBOLD Q ; no du plicate so get the n ext one
4311	"RTN","IBC EST",110,0 )
4312	.. S DIK= "^IBM(361, ",DA=IBY,I BY=-1 D ^D IK D DELMS G^IBCESRV2 (IBTDA)
4313	"RTN","IBC EST",111,0 )
4314	.. Q
4315	"RTN","IBC EST",112,0 )
4316	. Q
4317	"RTN","IBC EST",113,0 )
4318	;
4319	"RTN","IBC EST",114,0 )
4320	I IBY>0 D ;Move te xt over
4321	"RTN","IBC EST",115,0 )
4322	. K IBT
4323	"RTN","IBC EST",116,0 )
4324	. ;
4325	"RTN","IBC EST",117,0 )
4326	. D BLDMS G(IB1,IBTD A,.IBT,.IB AUTO)
4327	"RTN","IBC EST",118,0 )
4328	. ;
4329	"RTN","IBC EST",119,0 )
4330	. ; IB2 368 - ymg - 2Q,RE,RP messages will be fi led as inf ormational
4331	"RTN","IBC EST",120,0 )
4332	. ; Z0 is the flag for 2Q cod e
4333	"RTN","IBC EST",121,0 )
4334	. ; Z1 is the flag for RE cod e
4335	"RTN","IBC EST",122,0 )
4336	. ; Z2 is the flag for RP cod e
4337	"RTN","IBC EST",123,0 )
4338	. ; Z3 is the flag for autofi ling the m essage
4339	"RTN","IBC EST",124,0 )
4340	. I $P($G (^IBM(361, +IBY,0)),U ,3)="R" D
4341	"RTN","IBC EST",125,0 )
4342	.. S Z="" ,(Z0,Z1,Z2 ,Z3)=0 F S Z=$O(IBT (Z)) Q:Z=" "!(Z3=1) D
4343	"RTN","IBC EST",126,0 )
4344	... S IBL N=$$UP^XLF STR($G(IBT (Z)))
4345	"RTN","IBC EST",127,0 )
4346	... I (Z0 !Z1!Z2)=0 D
4347	"RTN","IBC EST",128,0 )
4348	.... S:IB LN?.E1"COD E:".P1"2Q" .E Z0=1
4349	"RTN","IBC EST",129,0 )
4350	.... S:IB LN?.E1"COD E:".P1"RE" .E Z1=1
4351	"RTN","IBC EST",130,0 )
4352	.... S:IB LN?.E1"COD E:".P1"RP" .E Z2=1
4353	"RTN","IBC EST",131,0 )
4354	... I Z0= 1 S:IBLN?. P1"CLAIM". P1"REJECTE D".P1"BY". P1"CLEARIN GHOUSE".E Z3=1
4355	"RTN","IBC EST",132,0 )
4356	... I Z1= 1 S:IBLN?. P1"ELECTRO NIC".P1"CL AIM".P1"RE JECTED".P1 "BY".P1"EM DEON".E Z3 =1
4357	"RTN","IBC EST",133,0 )
4358	... I Z2= 1 S:IBLN?. P1"PAPER". P1"CLAIM". P1"REJECTE D".P1"BY". P1"EMDEON" .E Z3=1
4359	"RTN","IBC EST",134,0 )
4360	.. I Z3=1 S IBAUTO= 1,DIE=361, DA=+IBY,DR =".03////I " D ^DIE
4361	"RTN","IBC EST",135,0 )
4362	.. Q
4363	"RTN","IBC EST",136,0 )
4364	. ;
4365	"RTN","IBC EST",137,0 )
4366	. ; if in fo msg, ck for no re view neede d based on first lin e of text
4367	"RTN","IBC EST",138,0 )
4368	. I $G(IB AUTO),$P($ G(^IBM(361 ,+IBY,0)), U,3)="I" D
4369	"RTN","IBC EST",139,0 )
4370	.. S DIE= "^IBM(361, ",DR=".09/ ///2;.14// //1;.1//// F",DA=+IBY D ^DIE
4371	"RTN","IBC EST",140,0 )
4372	.. I IB1, $P($G(^IBM (361,+IBY, 0)),U,11) S Z="",Z0= 0 F S Z=$ O(IBT(Z)) Q:Z=""!(Z0 =1) D
4373	"RTN","IBC EST",141,0 )
4374	... S Z0= $$PRINTUPD ^IBCEU0($$ UP^XLFSTR( $G(IBT(Z)) ),$P($G(^I BM(361,+IB Y,0)),U,11 ))
4375	"RTN","IBC EST",142,0 )
4376	. ;
4377	"RTN","IBC EST",143,0 )
4378	. D MSGLN SZ(.IBT) ; Convert M essage Lin es in IBT to be no l onger than 70 chars
4379	"RTN","IBC EST",144,0 )
4380	. D WP^DI E(361,+IBY _",",1,"A" ,"IBT") ; file me ssage text
4381	"RTN","IBC EST",145,0 )
4382	. ;
4383	"RTN","IBC EST",146,0 )
4384	. ; Delet e message after it s uccessfull y updates the databa se.
4385	"RTN","IBC EST",147,0 )
4386	. D DELMS G^IBCESRV2 (IBTDA)
4387	"RTN","IBC EST",148,0 )
4388	. Q
4389	"RTN","IBC EST",149,0 )
4390	;
4391	"RTN","IBC EST",150,0 )
4392	UPDQ L -^I BA(364.2,I BTDA,0)
4393	"RTN","IBC EST",151,0 )
4394	Q
4395	"RTN","IBC EST",152,0 )
4396	;
4397	"RTN","IBC EST",153,0 )
4398	BLDMSG(IB1 ,IBTDA,IBT ,IBAUTO) ; Builds me ssage text
4399	"RTN","IBC EST",154,0 )
4400	; IB1 = f lag for ba tch messag e
4401	"RTN","IBC EST",155,0 )
4402	; IBTDA = ien of en try in fil e 364.2
4403	"RTN","IBC EST",156,0 )
4404	; IBT = a rray retur ned with m essage tex t
4405	"RTN","IBC EST",157,0 )
4406	; IBAUTO = if passe d by refer ence, retu rns 1 if t ext indica tes review
4407	"RTN","IBC EST",158,0 )
4408	; not need ed
4409	"RTN","IBC EST",159,0 )
4410	N IBDATA, IBCK,IBZ,I BZ0,IBZ1,Z
4411	"RTN","IBC EST",160,0 )
4412	S (IBZ,IB Z0,IBDATA, IBAUTO,IBC K)=0
4413	"RTN","IBC EST",161,0 )
4414	I 'IB1 S IBT(1)="St atus messa ge receive d for batc h "_$P($G( ^IBA(364.1 ,IBBTCH,0) ),U)_" dat ed "_$$FMT E^XLFDT($P ($G(^IBA(3 64.2,IBTDA ,0)),U,10) ,2),IBZ0=1
4415	"RTN","IBC EST",162,0 )
4416	; Don't m ove the ra w data ove r, just mo ve the tex t of the m essage
4417	"RTN","IBC EST",163,0 )
4418	F S IBZ= $O(^IBA(36 4.2,IBTDA, 2,IBZ)) Q: 'IBZ S IB Z1=$G(^(IB Z,0)) S IB DATA=($E(I BZ1,1,2)=" ##") Q:IBD ATA S IBZ 0=IBZ0+1,I BT(IBZ0)=I BZ1 I 'IBC K S Z=$$CK REVU^IBCEM 4(IBZ1,,,. IBCK),IBAU TO=$S(IBCK :0,Z:1,1:I BAUTO)
4419	"RTN","IBC EST",164,0 )
4420	Q
4421	"RTN","IBC EST",165,0 )
4422	;
4423	"RTN","IBC EST",166,0 )
4424	UPDINS(IBP ID,IBINS,I BIFN,IBTDA ) ;KDM US129 IB* 2*577
4425	"RTN","IBC EST",167,0 )
4426	; Update the insura nce id or the bill p rinted at
4427	"RTN","IBC EST",168,0 )
4428	; the EDI contra ctor's pri nt shop an d mailed t o the ins co.
4429	"RTN","IBC EST",169,0 )
4430	; IBPID = the id re turned fro m the EDI contractor for the i ns co
4431	"RTN","IBC EST",170,0 )
4432	; (" TYPE") = P if profes sional id or I if in stitutiona l id
4433	"RTN","IBC EST",171,0 )
4434	; IBINS = the ien o f the insu rance co i t was sent to (file 36)
4435	"RTN","IBC EST",172,0 )
4436	; IBIFN = the ien o f the clai m (file 39 9)
4437	"RTN","IBC EST",173,0 )
4438	; IBTDA = ien of en try in fil e 364.2 ;KDM US1 29 IB257 7
4439	"RTN","IBC EST",174,0 )
4440	;
4441	"RTN","IBC EST",175,0 )
4442	N IBID,IB IDFLD,IBPR T,IBLOOK,D A,DR,DIE,X ,Y,Z,UPD ;KDM US 129 IB25 77
4443	"RTN","IBC EST",176,0 )
4444	;
4445	"RTN","IBC EST",177,0 )
4446	Q:'$G(IBI NS)!($G(IB PID)="")
4447	"RTN","IBC EST",178,0 )
4448	;
4449	"RTN","IBC EST",179,0 )
4450	; Strip s paces off the end of data
4451	"RTN","IBC EST",180,0 )
4452	S IBLOOK= ""
4453	"RTN","IBC EST",181,0 )
4454	I $L(IBPI D) F Z=$L( IBPID):-1: 1 I $E(IBP ID,Z)'=" " S IBLOOK= $E(IBPID,1 ,Z) Q
4455	"RTN","IBC EST",182,0 )
4456	;
4457	"RTN","IBC EST",183,0 )
4458	S IBPRT=( $E(IBLOOK, 2,5)="PRNT ")
4459	"RTN","IBC EST",184,0 )
4460	I IBPRT D ; Set pr inted via EDI field on bill
4461	"RTN","IBC EST",185,0 )
4462	. S DA=IB IFN,DIE="^ DGCR(399," ,DR="26/// /1" D ^DIE
4463	"RTN","IBC EST",186,0 )
4464	;
4465	"RTN","IBC EST",187,0 )
4466	; KDM US1 29 IB257 7 correct payer ID storage
4467	"RTN","IBC EST",188,0 )
4468	;S IBLOOK =$E($S('IB PRT:$P(IBL OOK,"PAYID =",2),1:"" ),1,5)
4469	"RTN","IBC EST",189,0 )
4470	;Q:IBLOOK =""!($E(IB LOOK,2,5)= "PRNT")
4471	"RTN","IBC EST",190,0 )
4472	I IBPRT Q
4473	"RTN","IBC EST",191,0 )
4474	I IBLOOK' ["PAYID=", IBLOOK'["C OBID=" Q ;KDM US 129 IB25 77
4475	"RTN","IBC EST",192,0 )
4476	S IBLOOK= $E($P(IBLO OK,"ID=",2 ),1,5)
4477	"RTN","IBC EST",193,0 )
4478	Q:IBLOOK= ""
4479	"RTN","IBC EST",194,0 )
4480	;
4481	"RTN","IBC EST",195,0 )
4482	S IBIDFLD ="3.0"_$S( $G(IBPID(" TYPE"))="I ":4,1:2)
4483	"RTN","IBC EST",196,0 )
4484	S IBID=$P ($G(^DIC(3 6,+IBINS,3 )),U,IBIDF LD*100#100 )
4485	"RTN","IBC EST",197,0 )
4486	Q:IBID=IB LOOK
4487	"RTN","IBC EST",198,0 )
4488	S IBDATE= DT,IBTYP=$ G(IBPID("T YPE")) ;KDM US1 29 IB257 7
4489	"RTN","IBC EST",199,0 )
4490	I IBID="" D G UPDI NSQ ; Upda te insuran ce co elec tronic id # if blank
4491	"RTN","IBC EST",200,0 )
4492	. S DIE=" ^DIC(36,", DR=IBIDFLD _"////"_IB LOOK,DA=IB INS D ^DIE
4493	"RTN","IBC EST",201,0 )
4494	. D UPDLO G(1,IBDATE ,IBINS,IBL OOK,IBTYP, IBID) ;KDM US129 IB2577
4495	"RTN","IBC EST",202,0 )
4496	I IBID'=" ",IBLOOK'= "" D ; Bu lletin tha t the id o n file and id return ed
4497	"RTN","IBC EST",203,0 )
4498	. ; are d ifferent
4499	"RTN","IBC EST",204,0 )
4500	. N XMTO, XMDUZ,XMBO DY,IBXM,XM SUBJ,XMZ
4501	"RTN","IBC EST",205,0 )
4502	. S XMTO( "I:G.IB ED I")=""
4503	"RTN","IBC EST",206,0 )
4504	. S XMDUZ ="",XMBODY ="IBXM",XM SUBJ="PAYE R ID RETUR NED IS DIF FERENT THA N PAYER ID ON FILE"
4505	"RTN","IBC EST",207,0 )
4506	. S IBXM( 1)="BILL # : "_$ P($G(^DGCR (399,IBIFN ,0)),U)
4507	"RTN","IBC EST",208,0 )
4508	. S IBXM( 2)="PAYER : "_$ P($G(^DIC( 36,+IBINS, 0)),U)
4509	"RTN","IBC EST",209,0 )
4510	. S IBXM( 3)="BILL T YPE : "_$ S($G(IBPID ("TYPE"))= "I":"INSTI TUT",1:"PR OFESS")_"I ONAL"
4511	"RTN","IBC EST",210,0 )
4512	. S IBXM( 4)="ID ON FILE : "_I BID
4513	"RTN","IBC EST",211,0 )
4514	. S IBXM( 5)="ID RET URNED: "_I BLOOK
4515	"RTN","IBC EST",212,0 )
4516	. S IBXM( 6)=" ",IBX M(7)=" P lease dete rmine whic h id numbe r is corre ct and cor rect the i d in the", IBXM(8)="i nsurance f ile for th is payer, if needed"
4517	"RTN","IBC EST",213,0 )
4518	. D SENDM SG^XMXAPI( XMDUZ,XMSU BJ,XMBODY, .XMTO,,.XM Z)
4519	"RTN","IBC EST",214,0 )
4520	. D UPDLO G(0,IBDATE ,IBINS,IBL OOK,IBTYP, IBID) ;KDM US129 , US976 IB 2577
4521	"RTN","IBC EST",215,0 )
4522	;
4523	"RTN","IBC EST",216,0 )
4524	UPDINSQ Q
4525	"RTN","IBC EST",217,0 )
4526	;
4527	"RTN","IBC EST",218,0 )
4528	UPDLOG(UPD ,IBDATE,IB INS,IBLOOK ,IBTYP,IBI D) ;KDM US129, US 976 IB25 77 New sec tion for N ew Payer R eport
4529	"RTN","IBC EST",219,0 )
4530	; store f lds for re porting pu rposes whe n updating or attemp ting to up date Payer informati on (US129)
4531	"RTN","IBC EST",220,0 )
4532	; ^DIC(36 -17.0 277 EDI ID Num ber
4533	"RTN","IBC EST",221,0 )
4534	; 17.01 27 7EDI ID Nu mber
4535	"RTN","IBC EST",222,0 )
4536	; 17.02 27 7Date EDI ID Number
4537	"RTN","IBC EST",223,0 )
4538	; 17.03 27 7EDI Type (P)ROF or (I)nst
4539	"RTN","IBC EST",224,0 )
4540	; 17.04 27 7EDI ID NU MBER ON FI LE ;if bla nk it was an update otherwise it was an attempted update.
4541	"RTN","IBC EST",225,0 )
4542	;
4543	"RTN","IBC EST",226,0 )
4544	Q:(($D(^D IC(36,"AED IX",IBDATE ,IBINS,IBL OOK,IBTYP) ))&(UPD=0) ) ;sto re only on e attempt a day
4545	"RTN","IBC EST",227,0 )
4546	N ERROR,I BFDA,LEV
4547	"RTN","IBC EST",228,0 )
4548	S LEV="+2 ,"_IBINS_" ,"
4549	"RTN","IBC EST",229,0 )
4550	S IBFDA(3 6.017,LEV, .01)=IBLOO K ;New Value fro m 277STAT
4551	"RTN","IBC EST",230,0 )
4552	S IBFDA(3 6.017,LEV, .02)=IBDAT E ;Dat e transact ion is pro cessed
4553	"RTN","IBC EST",231,0 )
4554	S IBFDA(3 6.017,LEV, .03)=IBTYP ;"P" or "I"
4555	"RTN","IBC EST",232,0 )
4556	S IBFDA(3 6.017,LEV, .04)=$G(IB ID) ;Val ue already on file- if blank i t was an u pdate, oth erwise att empted upd ate
4557	"RTN","IBC EST",233,0 )
4558	D UPDATE^ DIE("","IB FDA","","E RROR")
4559	"RTN","IBC EST",234,0 )
4560	Q
4561	"RTN","IBC EST",235,0 )
4562	;
4563	"RTN","IBC EST",236,0 )
4564	MSGLNSZ(MS G) ; Chang e Input Me ssage Line s to be no more than 70 charac ters long each
4565	"RTN","IBC EST",237,0 )
4566	;
4567	"RTN","IBC EST",238,0 )
4568	; Input/O utput: M SG - arra y of Input Message L ines; this is also t he Output Message
4569	"RTN","IBC EST",239,0 )
4570	; which i s an array of Conver ted Messag e Lines (w ith lines no more th an 70 char s each)
4571	"RTN","IBC EST",240,0 )
4572	;
4573	"RTN","IBC EST",241,0 )
4574	N LN,XARY ,XARYLN,CN T,OUTMSG,T MPMSG,LDNG SP,LDNGSPN
4575	"RTN","IBC EST",242,0 )
4576	S LN="",C NT=0 F S LN=$O(MSG( LN)) Q:LN= "" D ;
4577	"RTN","IBC EST",243,0 )
4578	. ; Find any leadin g spaces i n original message l ine,
4579	"RTN","IBC EST",244,0 )
4580	. ; to be used if l ine got sp lit below
4581	"RTN","IBC EST",245,0 )
4582	. S TMPMS G=$$TRIM^X LFSTR(MSG( LN),"L"," ") ;Trim Leading Sp aces
4583	"RTN","IBC EST",246,0 )
4584	. S LDNGS P=$P(MSG(L N),TMPMSG, 1) ;get l eading spa ces if any
4585	"RTN","IBC EST",247,0 )
4586	. S LDNGS PN=$L(LDNG SP) S:LDNG SPN>30 LDN GSP=$E(LDN GSP,1,30) ;make sure there are no more t han 30 lea ding space s
4587	"RTN","IBC EST",248,0 )
4588	. ; Conve rts a sing le line to multiple lines with a maximum width of 70 each
4589	"RTN","IBC EST",249,0 )
4590	. ; If li ne is 70 c hars or le ss, this c all return s the exac t line
4591	"RTN","IBC EST",250,0 )
4592	. K XARY D FSTRNG^I BJU1(TMPMS G,70-LDNGS PN,.XARY)
4593	"RTN","IBC EST",251,0 )
4594	. ; Scan lines and merge them into the final outp ut array ( OUTMSG)
4595	"RTN","IBC EST",252,0 )
4596	. ; On li nes 2 and higher, ad d Leading Spaces fou nd above, if any.
4597	"RTN","IBC EST",253,0 )
4598	. S XARYL N="" F S XARYLN=$O( XARY(XARYL N)) Q:XARY LN="" S C NT=CNT+1,O UTMSG(CNT) =LDNGSP_XA RY(XARYLN)
4599	"RTN","IBC EST",254,0 )
4600	;
4601	"RTN","IBC EST",255,0 )
4602	; Move th e final Me ssage Line s (OUTMSG) into MSG array to b e returned
4603	"RTN","IBC EST",256,0 )
4604	K MSG M M SG=OUTMSG
4605	"RTN","IBC EST",257,0 )
4606	Q
4607	"RTN","IBC EST",258,0 )
4608	;
4609	"RTN","IBC F23A")
4610	0^5^B39049 121^B37854 610
4611	"RTN","IBC F23A",1,0)
4612	IBCF23A ;A LB/ARH - H CFA 1500 1 9-90 DATA - Split fr om IBCF23 ;12-JUN-93
4613	"RTN","IBC F23A",2,0)
4614	;;2.0;INT EGRATED BI LLING;51 ,432,516,5 47,577;2 1-MAR-94;B uild 34
4615	"RTN","IBC F23A",3,0)
4616	;;Per VA Directive 6402, this routine s hould not be modifie d.
4617	"RTN","IBC F23A",4,0)
4618	;
4619	"RTN","IBC F23A",5,0)
4620	; $$INSTA LDT^XPDUTL (IBPATCH,. IBARY) - I CR 10141
4621	"RTN","IBC F23A",6,0)
4622	;
4623	"RTN","IBC F23A",7,0)
4624	B24 ; set individual entries i n print ar ray, exter nal format
4625	"RTN","IBC F23A",8,0)
4626	; IBAUX = additiona l data for EDI outpu t
4627	"RTN","IBC F23A",9,0)
4628	; IBRXF = array of RX procedu res
4629	"RTN","IBC F23A",10,0 )
4630	N IBX,Z,I BD1,IBD2,I BCPLINK
4631	"RTN","IBC F23A",11,0 )
4632	S IBI=IBI +1,IBPROC= $P(IBSS,U, 2),IBD1=$$ DATE^IBCF2 3(IBDT1),I BD2=$S(IBD T1'=IBDT2: $$DATE^IBC F23(IBDT2) ,1:"")
4633	"RTN","IBC F23A",12,0 )
4634	I '$D(IBX IEN) S IBD 1=$E(IBD1, 5,8)_$E(IB D1,1,4),IB D2=$E(IBD2 ,5,8)_$E(I BD2,1,4)
4635	"RTN","IBC F23A",13,0 )
4636	S IBFLD(2 4,IBI)=IBD 1_U_IBD2_U _$P($G(^IB E(353.1,+$ P(IBSS,U,6 ),0)),U)_U _$P($G(^IB E(353.2,+$ P(IBSS,U,7 ),0)),U)
4637	"RTN","IBC F23A",14,0 )
4638	I +IBPROC D
4639	"RTN","IBC F23A",15,0 )
4640	. S IBFLD (24,IBI)=I BFLD(24,IB I)_U_$P($$ PRCD^IBCEF 1(IBPROC,1 ),U,2) S:$ P(IBPROC," ;",2)'["IC PT" IBFLD( 24,IBI_"X" )=""
4641	"RTN","IBC F23A",16,0 )
4642	I 'IBPROC S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_$S('$D( IBXIEN):IB PROC,1:+IB REV),IBFLD (24,IBI_"A ")=$P($G(^ DGCR(399.2 ,+IBREV,0) ),U,2)
4643	"RTN","IBC F23A",17,0 )
4644	I $D(IBRX F),IBCHARG ="" S IBFL D(24,IBI_" A")=$P($G( ^DGCR(399. 2,+IBREV,0 )),U,2)
4645	"RTN","IBC F23A",18,0 )
4646	S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_$P(IBSS ,U,5)_U_IB CHARG_U_IB UNIT_U_$P( IBSS,U,8)_ U_$G(IBPCH G)_U_$G(IB MIN)_U_$G( IBEMG)
4647	"RTN","IBC F23A",19,0 )
4648	I $D(IBSS ("L")) S Z =0 F S Z= $O(IBSS("L ",Z)) Q:'Z S IBFLD( 24,IBI,$P( IBSS("L",Z ),U),$P(IB SS("L",Z), U,2))=$G(I BFLD(24,IB I,$P(IBSS( "L",Z),U), $P(IBSS("L ",Z),U,2)) )+1
4649	"RTN","IBC F23A",20,0 )
4650	S:$TR($G( IBAUX),U)' ="" IBFLD( 24,IBI,"AU X")=$G(IBA UX)
4651	"RTN","IBC F23A",21,0 )
4652	S:$D(IBRX F) IBFLD(2 4,IBI,"RX" )=IBRXF
4653	"RTN","IBC F23A",22,0 )
4654	K IBPROC, IBSS("L")
4655	"RTN","IBC F23A",23,0 )
4656	S IBCPLIN K=$P(IBSS, U,$L(IBSS, U))
4657	"RTN","IBC F23A",24,0 )
4658	S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_IBCPLIN K
4659	"RTN","IBC F23A",25,0 )
4660	; MRD;IB* 2.0*516 - Added NDC and Units to line le vel of cla im.
4661	"RTN","IBC F23A",26,0 )
4662	;I IBCPLI NK'="" S $ P(IBFLD(24 ,IBI),U,14 ,15)=$TR($ P($G(^DGCR (399,IBIFN ,"CP",IBCP LINK,1)),U ,7,8),"-")
4663	"RTN","IBC F23A",27,0 )
4664	; vd/Begi nning of I B2577 - Added Unit /Basis of Measurment to line l evel of cl aim.
4665	"RTN","IBC F23A",28,0 )
4666	I IBCPLIN K'="" S $P (IBFLD(24, IBI),U,14, 16)=$TR($P ($G(^DGCR( 399,IBIFN, "CP",IBCPL INK,1)),U, 7,8),"-")_ U_$P($G(^D GCR(399,IB IFN,"CP",I BCPLINK,2) ),U)
4667	"RTN","IBC F23A",29,0 )
4668	; vd/End of IB257 7
4669	"RTN","IBC F23A",30,0 )
4670	Q
4671	"RTN","IBC F23A",31,0 )
4672	;
4673	"RTN","IBC F23A",32,0 )
4674	AUXOK(IBSS ,IBSS1) ; Check all other flds are the s ame to com bine procs
4675	"RTN","IBC F23A",33,0 )
4676	; IBSS = subscript of IBCP to check for dups to c ombine - p ass by ref
4677	"RTN","IBC F23A",34,0 )
4678	; IBSS(IB SS,"AUX-X" ,n) = all the previo usly extra cted line items for the
4679	"RTN","IBC F23A",35,0 )
4680	; same s et of basi c data, bu t having d ifferent " AUX" data
4681	"RTN","IBC F23A",36,0 )
4682	; IBSS1 = the "AUX" data of t he current IBCP entr y
4683	"RTN","IBC F23A",37,0 )
4684	;
4685	"RTN","IBC F23A",38,0 )
4686	; Returns entry # i n IBSS arr ay if matc h found, o r 0 if no match
4687	"RTN","IBC F23A",39,0 )
4688	; Set the IBSS "AUX -X" node f or no matc h
4689	"RTN","IBC F23A",40,0 )
4690	N Z,Z0
4691	"RTN","IBC F23A",41,0 )
4692	S Z=0 F S Z=$O(IBS S(IBSS,"AU X-X",Z)) Q :'Z I IBS S1=IBSS(IB SS,"AUX-X" ,Z) Q
4693	"RTN","IBC F23A",42,0 )
4694	I 'Z S Z0 =+$O(IBSS( IBSS,"AUX- X",""),-1) +1,IBSS(IB SS,"AUX-X" ,Z0)=IBSS1
4695	"RTN","IBC F23A",43,0 )
4696	Q +Z
4697	"RTN","IBC F23A",44,0 )
4698	;
4699	"RTN","IBC F23A",45,0 )
4700	PRC ; Extr act proced ure data f or HCFA 15 00
4701	"RTN","IBC F23A",46,0 )
4702	; IBRC(IB SS) = #rev codes wit h same bil ling crite ria (IBSS)
4703	"RTN","IBC F23A",47,0 )
4704	; IBLINK( 'CP' ien,' RC' ien) = IBSS incl uding modi fiers,rx s eq in pc 7 ,8
4705	"RTN","IBC F23A",48,0 )
4706	; IBLINK1 (IBSS, 'RC ' ien) = auto (1)^ 'CP' ien ( soft link)
4707	"RTN","IBC F23A",49,0 )
4708	;
4709	"RTN","IBC F23A",50,0 )
4710	; proc ar ray w/chrg
4711	"RTN","IBC F23A",51,0 )
4712	N IBPR,IB P
4713	"RTN","IBC F23A",52,0 )
4714	S IBI=0 F S IBI=$O (^DGCR(399 ,IBIFN,"CP ",IBI)) Q: 'IBI S IB LN=^(IBI,0 ),IBAUXLN= $G(^("AUX" )) D
4715	"RTN","IBC F23A",53,0 )
4716	. N Z,Z0, Z1,Q1
4717	"RTN","IBC F23A",54,0 )
4718	. S IBPDT =$P(IBLN,U ,2)
4719	"RTN","IBC F23A",55,0 )
4720	. S IBSS= $$IBSS(IBI ,.IBDXI,IB LN)
4721	"RTN","IBC F23A",56,0 )
4722	. S IBPO= $S($P(IBLN ,U,4):+$P( IBLN,U,4), 1:IBI+1000 ) ;Set pri nt order
4723	"RTN","IBC F23A",57,0 )
4724	. S IBCP( IBPO)=IBPD T_"^"_IBSS ,IBCP(IBPO ,"AUX")=IB AUXLN
4725	"RTN","IBC F23A",58,0 )
4726	. S IBCP( IBPO,"LNK" )=IBI
4727	"RTN","IBC F23A",59,0 )
4728	. ; Rx
4729	"RTN","IBC F23A",60,0 )
4730	. N IBZ,I BITEM
4731	"RTN","IBC F23A",61,0 )
4732	. S IBZ=$ S($P(IBSS, U):$P(IBSS ,U),1:"")
4733	"RTN","IBC F23A",62,0 )
4734	. I IBZ'= "",$D(IBLI NKRX(IBZ,I BI)) D Q: IBCHARG'=" "
4735	"RTN","IBC F23A",63,0 )
4736	.. S IBPO 1=IBPO
4737	"RTN","IBC F23A",64,0 )
4738	.. S IBIT EM=+$O(IBL INKRX(IBZ, IBI,0)),IB RV=$G(IBLI NKRX(IBZ,I BI,IBITEM) )
4739	"RTN","IBC F23A",65,0 )
4740	.. Q:$S(I BRV="":1,1 :'$G(IBRC( IBRV)))
4741	"RTN","IBC F23A",66,0 )
4742	.. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV)=IB RC(IBRV)-1
4743	"RTN","IBC F23A",67,0 )
4744	.. S $P(I BCP(IBPO1) ,U,9)=IBCH ARG,IBCP(I BPO1,"RX") =IBITEM K IBLINKRX(I BZ,IBI,IBI TEM)
4745	"RTN","IBC F23A",68,0 )
4746	. ; find chrgs dire ctly linke d to proc
4747	"RTN","IBC F23A",69,0 )
4748	. S IBK=0 F S IBK= $O(IBLINK( IBI,IBK)) Q:'IBK S IBRV1=IBLI NK(IBI,IBK ),IBRV=$P( IBRV1,U,1, 6) I +IBRC (IBRV1) D
4749	"RTN","IBC F23A",70,0 )
4750	.. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV1)=I BRC(IBRV1) -1
4751	"RTN","IBC F23A",71,0 )
4752	.. I IBCH ARG'="" S $P(IBSS,U, 8)=IBCHARG ,IBCP(IBPO )=IBPDT_"^ "_IBSS,IBP O=IBPO+.1
4753	"RTN","IBC F23A",72,0 )
4754	;
4755	"RTN","IBC F23A",73,0 )
4756	; add chr gs associa ted with a proc (not a direct link)
4757	"RTN","IBC F23A",74,0 )
4758	; find ch rg associa ted with p roc, if an y (match p roc,div,+/ -basc)
4759	"RTN","IBC F23A",75,0 )
4760	K IBP(0)
4761	"RTN","IBC F23A",76,0 )
4762	F IBP=3,2 Q:$D(IBP( 0)) S IBP O="" F S IBPO=$O(IB CP(IBPO)) Q:'IBPO I $P(IBCP(I BPO),U,9)= "" D
4763	"RTN","IBC F23A",77,0 )
4764	. S IBSS= $P(IBCP(IB PO),U,2,9)
4765	"RTN","IBC F23A",78,0 )
4766	. S IBCHA RG="",(IBR V,IBSS)=$P (IBSS,U,1, IBP) F S IBRV=$O(IB RC(IBRV)) Q:$P(IBRV, U,1,IBP)'= IBSS S IB P(0)=0 I + IBRC(IBRV) D Q
4767	"RTN","IBC F23A",79,0 )
4768	.. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV)=IB RC(IBRV)-1
4769	"RTN","IBC F23A",80,0 )
4770	.. I IBRC (IBRV) S Z =0 F S Z= $O(IBCP(IB PO,Z)) Q:' Z S IBRC( IBRV)=IBRC (IBRV)-1
4771	"RTN","IBC F23A",81,0 )
4772	. S $P(IB CP(IBPO),U ,9)=IBCHAR G
4773	"RTN","IBC F23A",82,0 )
4774	. I IBCHA RG'="" S Z =$O(IBLINK 1(IBRV,0)) I Z S IBC P(IBPO,"L" ,Z)=IBLINK 1(IBRV,Z) K IBLINK1( IBRV,Z)
4775	"RTN","IBC F23A",83,0 )
4776	;
4777	"RTN","IBC F23A",84,0 )
4778	; add chr gs not ass ociated wi th a proc to first p roc with n o chrg
4779	"RTN","IBC F23A",85,0 )
4780	; Aggggh! !! TP
4781	"RTN","IBC F23A",86,0 )
4782	S IBPO="" F S IBPO =$O(IBCP(I BPO)) Q:'I BPO I $P( IBCP(IBPO) ,U,9)="" D
4783	"RTN","IBC F23A",87,0 )
4784	. S IBCHA RG="",IBRV ="^" F S IBRV=$O(IB RC(IBRV)) Q:IBRV=""! +IBRV I + IBRC(IBRV) D Q
4785	"RTN","IBC F23A",88,0 )
4786	.. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV)=IB RC(IBRV)-1
4787	"RTN","IBC F23A",89,0 )
4788	.. S Z=$O (IBLINK1(I BRV,0)) I Z S IBCP(I BPO,"L",Z) =IBLINK1(I BRV,Z) K I BLINK1(IBR V,Z)
4789	"RTN","IBC F23A",90,0 )
4790	. S $P(IB CP(IBPO),U ,9)=IBCHAR G
4791	"RTN","IBC F23A",91,0 )
4792	;
4793	"RTN","IBC F23A",92,0 )
4794	Q
4795	"RTN","IBC F23A",93,0 )
4796	IBSS(IBI,I BDXI,IBLN) ; Creates index seq uence for procedure
4797	"RTN","IBC F23A",94,0 )
4798	N IBPC,IB J,IBSS,IBL PI,IBX,IBL PAR
4799	"RTN","IBC F23A",95,0 )
4800	S (IBPC,I BLPI)=0
4801	"RTN","IBC F23A",96,0 )
4802	F IBJ=1,6 ,5,0,9,10 S IBPC=IBP C+1 S:IBJ $P(IBSS,U, IBPC,IBPC+ 1)=($P(IBL N,U,IBJ)_U )
4803	"RTN","IBC F23A",97,0 )
4804	S $P(IBSS ,U,7)=($$G ETMOD^IBEF UNC(IBIFN, IBI)_U) ;M odifiers
4805	"RTN","IBC F23A",98,0 )
4806	;IB*547/T AZ - IBDXI not defin ed, use in ternal DX pointer
4807	"RTN","IBC F23A",99,0 )
4808	I '$G(IBN WPTCH) F I BJ=11:1:14 I $P(IBLN ,U,IBJ) S $P(IBSS,U, 4)=$P(IBSS ,U,4)_$S(I BJ>11:",", 1:"")_$G(I BDXI(+$P(I BLN,U,IBJ) )) ; dx
4809	"RTN","IBC F23A",100, 0)
4810	I $G(IBNW PTCH) F IB J=11:1:14 S IBX=$P(I BLN,U,IBJ) I IBX S $ P(IBSS,U,4 )=$P(IBSS, U,4)_$S(IB J>11:",",1 :"")_$G(IB DXI(IBX),I BX) ; dx
4811	"RTN","IBC F23A",101, 0)
4812	S $P(IBSS ,U,10)=$P( IBLN,U,16) ,$P(IBSS,U ,9)=$P(IBL N,U,19),$P (IBSS,U,11 )=+$P(IBLN ,U,17)
4813	"RTN","IBC F23A",102, 0)
4814	G:'$G(IBN WPTCH) IBS SX
4815	"RTN","IBC F23A",103, 0)
4816	;IB*547/T AZ - Add a dditional fields for roll-up c ompare
4817	"RTN","IBC F23A",104, 0)
4818	S $P(IBSS ,U,21)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","ASSO CIATED CLI NIC","I")
4819	"RTN","IBC F23A",105, 0)
4820	S $P(IBSS ,U,22)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","TYPE OF SERVIC E","I")
4821	"RTN","IBC F23A",106, 0)
4822	S $P(IBSS ,U,23)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","ATTA CHMENT CON TROL NUMBE R","I")
4823	"RTN","IBC F23A",107, 0)
4824	S $P(IBSS ,U,24)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","NDC" ,"I")
4825	"RTN","IBC F23A",108, 0)
4826	S $P(IBSS ,U,25)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","PROC EDURE DESC RIPTION"," I")
4827	"RTN","IBC F23A",109, 0)
4828	S $P(IBSS ,U,26)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","ADDI TIONAL OB MINUTES"," I")
4829	"RTN","IBC F23A",110, 0)
4830	;Add Prov ider info in pieces 41-49
4831	"RTN","IBC F23A",111, 0)
4832	M IBLPAR= ^DGCR(399, IBIFN,"CP" ,IBI,"LNPR V")
4833	"RTN","IBC F23A",112, 0)
4834	F S IBLP I=$O(IBLPA R(IBLPI)) Q:'IBLPI S IBX=IBLP AR(IBLPI,0 ),$P(IBSS, U,40+IBX)= $TR(IBX,"^ ","~")
4835	"RTN","IBC F23A",113, 0)
4836	K IBLPAR
4837	"RTN","IBC F23A",114, 0)
4838	IBSSX ;
4839	"RTN","IBC F23A",115, 0)
4840	Q IBSS
4841	"RTN","IBC F23A",116, 0)
4842	;
4843	"RTN","IBC F23A",117, 0)
4844	IBNWPTCH(I BIFN,IBPAT CH) ;
4845	"RTN","IBC F23A",118, 0)
4846	;Checks t he date th e primary claim was 1st transm itted and returns 1 if the tra nsmitted d ate is aft er the pat ch
4847	"RTN","IBC F23A",119, 0)
4848	;referenc ed in vari able IBPAT CH was rel eased. Thi s allows t he MRA/EOB s returnin g to roll up procedu res the sa me
4849	"RTN","IBC F23A",120, 0)
4850	;way as t hey went o ut. Other wise the o rder chang es and the MRA/EOB w on't match up.
4851	"RTN","IBC F23A",121, 0)
4852	;
4853	"RTN","IBC F23A",122, 0)
4854	N IBARY,I BIDT,IBPFN ,IBEFN,IBB N,IBX,IBBD T
4855	"RTN","IBC F23A",123, 0)
4856	S IBX=0
4857	"RTN","IBC F23A",124, 0)
4858	I $$INSTA LDT^XPDUTL (IBPATCH,. IBARY) D ;ICR 1014 1
4859	"RTN","IBC F23A",125, 0)
4860	. S IBX=1
4861	"RTN","IBC F23A",126, 0)
4862	. S IBIDT =$O(IBARY( ""))
4863	"RTN","IBC F23A",127, 0)
4864	. ; Get P rimary Bil l Number. This will insure COB data is c onsistent across all bills.
4865	"RTN","IBC F23A",128, 0)
4866	. S IBPFN =$$GET1^DI Q(399,IBIF N_",","PRI MARY BILL #","I") I 'IBPFN S I BPFN=IBIFN
4867	"RTN","IBC F23A",129, 0)
4868	. ; Find 1st Accept ed Entry ( A1, A2, or Z) of Pri mary Bill in EDI TRA NSMIT BILL FILE (364 ) to deter mine Batch Number
4869	"RTN","IBC F23A",130, 0)
4870	. S (IBEF N,IBBN)=0 F S IBEFN =$O(^IBA(3 64,"B",IBP FN,IBEFN)) Q:'IBEFN D I IBBN Q
4871	"RTN","IBC F23A",131, 0)
4872	.. I ",A1 ,A2,Z,"'[( ","_$$GET1 ^DIQ(364,I BEFN_","," TRANSMISSI ON STATUS" ,"I")_",") Q
4873	"RTN","IBC F23A",132, 0)
4874	.. S IBBN =$$GET1^DI Q(364,IBEF N_",","BAT CH NUMBER" ,"I")
4875	"RTN","IBC F23A",133, 0)
4876	. ;Retrie ve the dat e the batc h was 1st sent. If IBBN="" IB BDT will b e null
4877	"RTN","IBC F23A",134, 0)
4878	. S IBBDT =$$GET1^DI Q(364.1,$$ GET1^DIQ(3 64,IBBN_", ","BATCH N UMBER","I" )_",","DAT E FIRST SE NT","I")
4879	"RTN","IBC F23A",135, 0)
4880	. I IBBDT ,(IBBDT<IB IDT) S IBX =0
4881	"RTN","IBC F23A",136, 0)
4882	Q IBX
4883	"RTN","IBC F33")
4884	0^7^B35272 389^B31973 795
4885	"RTN","IBC F33",1,0)
4886	IBCF33 ;AL B/ARH - UB -04 CMS-14 50 (GATHER CODES) ;2 5-AUG-1993
4887	"RTN","IBC F33",2,0)
4888	;;2.0;INT EGRATED BI LLING;52 ,80,109,51 ,230,349,5 77;21-MA R-94;Build 34
4889	"RTN","IBC F33",3,0)
4890	;;Per VA Directive 6402, this routine s hould not be modifie d
4891	"RTN","IBC F33",4,0)
4892	;
4893	"RTN","IBC F33",5,0)
4894	;IBIFN re quired
4895	"RTN","IBC F33",6,0)
4896	;
4897	"RTN","IBC F33",7,0)
4898	; Not all free text prints in these blo cks as of MRA/EDI - only print
4899	"RTN","IBC F33",8,0)
4900	; REVEN UE CODES a nd associa ted data, Rx's and p rosthetics
4901	"RTN","IBC F33",9,0)
4902	; and l ast line t o indicate multiple pages
4903	"RTN","IBC F33",10,0)
4904	N IBI,IBJ ,IBCU2,IBC OL,IBSTATE ,IBCBILL,I BINPAT,IBX ,IBY,Z,IBZ ,IBLPG
4905	"RTN","IBC F33",11,0)
4906	S IBLINES =22,IBCU2= $G(^DGCR(3 99,IBIFN," U2")),IBCO L=1,IBNOCO M=0
4907	"RTN","IBC F33",12,0)
4908	K IBXSAVE ("RX-UB-04 "),IBXSAVE ("PROS-UB- 04")
4909	"RTN","IBC F33",13,0)
4910	D HOS^IBC EF22(IBIFN )
4911	"RTN","IBC F33",14,0)
4912	;
4913	"RTN","IBC F33",15,0)
4914	I $$TXMT^ IBCEF4(IBI FN) S IBNO COM=1
4915	"RTN","IBC F33",16,0)
4916	S Z="",IB NOCHG=0
4917	"RTN","IBC F33",17,0)
4918	; Add tot al line as last entr y, if not already th ere
4919	"RTN","IBC F33",18,0)
4920	;S IBLCT= $O(IBXDATA (""),-1)
4921	"RTN","IBC F33",19,0)
4922	;I IBLCT, $P(IBXDATA (IBLCT),U) '="001" S IBXDATA(IB LCT+1)="00 1"
4923	"RTN","IBC F33",20,0)
4924	;S IBLCT= 0
4925	"RTN","IBC F33",21,0)
4926	S IBLPG=( $O(IBXDATA (""),-1)+$ O(IBXSAVE( "RX-UB-04" ,""),-1)+$ O(IBXSAVE( "PROS-UB-0 4",""),-1) )/22,IBLPG =IBLPG\1+$ S($P(IBLPG ,".",2):1, 1:0)
4927	"RTN","IBC F33",22,0)
4928	F S Z=$O (IBXDATA(Z )) Q:'Z D
4929	"RTN","IBC F33",23,0)
4930	. N IBZ1
4931	"RTN","IBC F33",24,0)
4932	. ;I $P(I BXDATA(Z), U)="001",' $O(IBXDATA (Z)) S IBZ ="001",$P( IBZ,U,4)=$ P(IBCBCOMM ,U,1),IBDA =0 S:IBNOC HG $P(IBZ, U,9)=$G(IB NOCHG) S I BXDATA(Z)= IBZ D SET1 Q
4933	"RTN","IBC F33",25,0)
4934	. ;Get mo difiers
4935	"RTN","IBC F33",26,0)
4936	. S IBZ1= $G(^DGCR(3 99,IBIFN," RC",+$P(IB XDATA(Z),U ,8),0)),IB MOD=""
4937	"RTN","IBC F33",27,0)
4938	. I $P(IB Z1,U,6),$S ($P(IBZ1,U ,10)=4:$P( IBZ1,U,11) ,1:'$P(IBZ 1,U,10)) S $P(IBXDAT A(Z),U,9)= $$MOD(IBZ1 ,IBIFN)
4939	"RTN","IBC F33",28,0)
4940	. S IBZ=$ P(IBXDATA( Z),U)_U_$P (IBXDATA(Z ),U,3,5)_" ^^"_$P(IBX DATA(Z),U, 2),$P(IBZ, U,9)=$P(IB XDATA(Z),U ,6),$P(IBZ ,U,13)=$P( IBXDATA(Z) ,U,7),$P(I BZ,U,10)=$ P(IBXDATA( Z),U,9),$P (IBZ,U,14) =$P(IBXDAT A(Z),U,10)
4941	"RTN","IBC F33",29,0)
4942	. ; VAD-I B2577 - Add "NDC#" , "Unit/Ba sis of Mea sure", and "Units/Qt y" to piec es 20,21,2 2 of IBZ, respective ly
4943	"RTN","IBC F33",30,0)
4944	. S $P(IB Z,U,20)=$P (IBXDATA(Z ),U,11),$P (IBZ,U,21) =$P(IBXDAT A(Z),U,13) ,$P(IBZ,U, 22)=$P(IBX DATA(Z),U, 12)
4945	"RTN","IBC F33",31,0)
4946	. I IBZ S IBNOCHG=I BNOCHG+$P( IBXDATA(Z) ,U,6),IBDA =$P(IBXDAT A(Z),U,8) D SET1
4947	"RTN","IBC F33",32,0)
4948	. ;S IBLC T=IBLCT+1
4949	"RTN","IBC F33",33,0)
4950	I $D(IBXS AVE("RX-UB -04"))!$D( IBXSAVE("P ROS-UB-04" )) D
4951	"RTN","IBC F33",34,0)
4952	. N Z
4953	"RTN","IBC F33",35,0)
4954	. S Z=0 F S Z=$O(I BXSAVE("RX -UB-04",Z) ) Q:'Z S IBZ=IBXSAV E("RX-UB-0 4",Z) D SE T2
4955	"RTN","IBC F33",36,0)
4956	. S Z=0 F S Z=$O(I BXSAVE("PR OS-UB-04", Z)) Q:'Z S IBZ=IBXS AVE("PROS- UB-04",Z) D SET2
4957	"RTN","IBC F33",37,0)
4958	D END
4959	"RTN","IBC F33",38,0)
4960	Q
4961	"RTN","IBC F33",39,0)
4962	;
4963	"RTN","IBC F33",40,0)
4964	RV ;rev co des sorted by bedsec tion - no longer use d as of pa tch IB25 1
4965	"RTN","IBC F33",41,0)
4966	S (IBBSN, IBBS,IBNOC HG)=0 F S IBBS=$O(^ DGCR(399,I BIFN,"RC", "ABS",IBBS )) Q:'IBBS D
4967	"RTN","IBC F33",42,0)
4968	. S IBRV= 0 F S IBR V=$O(^DGCR (399,IBIFN ,"RC","ABS ",IBBS,IBR V)) Q:'IBR V D
4969	"RTN","IBC F33",43,0)
4970	.. S IBDA =0 F S IB DA=$O(^DGC R(399,IBIF N,"RC","AB S",IBBS,IB RV,IBDA)) Q:'IBDA D
4971	"RTN","IBC F33",44,0)
4972	... S IBX =$G(^DGCR( 399,IBIFN, "RC",IBDA, 0))
4973	"RTN","IBC F33",45,0)
4974	... S IBZ =$P($G(^DG CR(399.1,+ $P(IBX,U,5 ),0)),U,1) S IBBSN=I BZ,IBZ=IBX ,IBNOCHG=I BNOCHG+$P( IBZ,U,9) D SET1
4975	"RTN","IBC F33",46,0)
4976	;
4977	"RTN","IBC F33",47,0)
4978	;loop thr ough all r ev codes, print thos e with no bedsection
4979	"RTN","IBC F33",48,0)
4980	S IBDA=0 F S IBDA= $O(^DGCR(3 99,IBIFN," RC",IBDA)) Q:'IBDA S IBZ=$G(^ (IBDA,0)) I +IBZ,$P( IBZ,U,5)=" " S IBNOCH G=IBNOCHG+ $P(IBZ,U,9 ) D SET1
4981	"RTN","IBC F33",49,0)
4982	;
4983	"RTN","IBC F33",50,0)
4984	TOTAL ;add total
4985	"RTN","IBC F33",51,0)
4986	;I +$P(IB CBCOMM,U,2 ) S IBZ="" ,$P(IBZ,U, 2)="SUBTOT AL",$P(IBZ ,U,4)=+$P( IBCBCOMM,U ,1) D SET1
4987	"RTN","IBC F33",52,0)
4988	;
4989	"RTN","IBC F33",53,0)
4990	;S IBX=$S (+$P(IBCBC OMM,U,2):4 ,1:2) D SP ACE
4991	"RTN","IBC F33",54,0)
4992	S IBX=2 D SPACE
4993	"RTN","IBC F33",55,0)
4994	;S IBZ="" D SET2
4995	"RTN","IBC F33",56,0)
4996	;S IBJ=0 F IBI=4,5, 6 S IBJ=IB J+$P(IBCU2 ,U,IBI)
4997	"RTN","IBC F33",57,0)
4998	;I +$P(IB CBCOMM,U,2 ),+$P(IBCB COMM,U,2)' =IBJ S (IB I,IBZ)="", $P(IBZ,U,2 )="LESS "_ $P(IBCBCOM M,U,3),$P( IBZ,U,4)=+ $P(IBCBCOM M,U,2) D S ET1 S IBZ= "" D SET2
4999	"RTN","IBC F33",58,0)
5000	;
5001	"RTN","IBC F33",59,0)
5002	;S IBZ="0 01",$P(IBZ ,U,2)="TOT AL",$P(IBZ ,U,4)=IBCB COMM-$S(IB I="":$P(IB CBCOMM,U,2 ),1:0) S:I BNOCHG $P( IBZ,U,9)=$ G(IBNOCHG) D SET1
5003	"RTN","IBC F33",60,0)
5004	;
5005	"RTN","IBC F33",61,0)
5006	;
5007	"RTN","IBC F33",62,0)
5008	CPT ;add a dditional procedures
5009	"RTN","IBC F33",63,0)
5010	;G:$G(IBF L(80))'>6 OPV S IBX= +IBFL(80)- 4 D SPACE
5011	"RTN","IBC F33",64,0)
5012	;S IBZ="" D SET2
5013	"RTN","IBC F33",65,0)
5014	;S IBZ="A DDITIONAL PROCEDURE CODES:" D SET2
5015	"RTN","IBC F33",66,0)
5016	;S IBI=6 F S IBI=$ O(IBFL(80, IBI)) Q:'I BI D
5017	"RTN","IBC F33",67,0)
5018	;. S IBX= $P(IBFL(80 ,IBI),U,2) ,IBZ=$E(IB X,1,2)_"/" _$E(IBX,3, 4)_"/"_$E( IBX,5,6)_$ J(" ",5)_$ P(IBFL(80, IBI),U,1) D SET2
5019	"RTN","IBC F33",68,0)
5020	;
5021	"RTN","IBC F33",69,0)
5022	OPV ;add o utpatient visit date s
5023	"RTN","IBC F33",70,0)
5024	;G:'$O(^D GCR(399,IB IFN,"OP",0 )) CONT S (IBX,IBY)= 0 F S IBX =$O(^DGCR( 399,IBIFN, "OP",IBX)) Q:'IBX S IBY=IBY+1
5025	"RTN","IBC F33",71,0)
5026	;S IBX=IB Y/3,IBX=IB X\1+$S(+$P (IBX,".",2 ):1,1:0)+1 D SPACE
5027	"RTN","IBC F33",72,0)
5028	;S IBZ="" D SET2 S IBZ="OP VI SIT DATE(S ) BILLED:" _$J(" ",34 -24)
5029	"RTN","IBC F33",73,0)
5030	;S (IBI,I BJ)=0 F S IBI=$O(^D GCR(399,IB IFN,"OP",I BI)) Q:'IB I D
5031	"RTN","IBC F33",74,0)
5032	;. S Y=$G (^DGCR(399 ,IBIFN,"OP ",IBI,0)), IBZ=IBZ_$$ FMTE^XLFDT (Y,2)_$S($ O(^DGCR(39 9,IBIFN,"O P",IBI)):" , ",1:"")
5033	"RTN","IBC F33",75,0)
5034	;. S IBJ= IBJ+1 I IB J>2 D SET2 S IBZ=$J( " ",34),IB J=0
5035	"RTN","IBC F33",76,0)
5036	;I $L(IBZ )>34 D SET 2
5037	"RTN","IBC F33",77,0)
5038	;
5039	"RTN","IBC F33",78,0)
5040	CONT ;D ^I BCF331 ;Mo re free te xt - can n o longer p rint on UB -04
5041	"RTN","IBC F33",79,0)
5042	;
5043	"RTN","IBC F33",80,0)
5044	; fill in rest of p age
5045	"RTN","IBC F33",81,0)
5046	END D:'$G( IBNOCOM) F ILLPG S $P (^TMP($J," IBC-RC"),U ,2)=0 S IB PG=+$G(^TM P($J,"IBC- RC")),IBX= IBPG/22,IB PG=IBX\1+$ S(+$P(IBX, ".",2):1,1 :0)
5047	"RTN","IBC F33",82,0)
5048	K IBZ,IBB SN,IBBS,IB RV,IBDA,IB LN,IBCOL,I BLINES,IBA RRAY,IBNOC HG,IBNOCOM ,IBXSAVE(" RX-UB-04") ,IBXSAVE(" PROS-UB-04 ")
5049	"RTN","IBC F33",83,0)
5050	Q
5051	"RTN","IBC F33",84,0)
5052	;
5053	"RTN","IBC F33",85,0)
5054	SPACE ;che cks to see if IBX ca n fit on p age, if no t starts n ew page
5055	"RTN","IBC F33",86,0)
5056	Q:'IBX N IBLN,IBY S IBLN=+$G (^TMP($J," IBC-RC")), IBY=IBLN#2 2 S:IBY=0& (IBLN'=0) IBY=22 I I BX>(IBLINE S-IBY) D F ILLPG
5057	"RTN","IBC F33",87,0)
5058	Q
5059	"RTN","IBC F33",88,0)
5060	;
5061	"RTN","IBC F33",89,0)
5062	FILLPG ;fi ll rest of page with blank lin es
5063	"RTN","IBC F33",90,0)
5064	N IBI,IBL N,IBZ S IB FILL=1 F I BI=1:1:22 S IBLN=+$G (^TMP($J," IBC-RC")) Q:'(IBLN#2 2) S IBZ= "" D FILLU P Q:IBFILL =2
5065	"RTN","IBC F33",91,0)
5066	K IBFILL Q
5067	"RTN","IBC F33",92,0)
5068	;
5069	"RTN","IBC F33",93,0)
5070	SET1 ; add rev codes to array: rev cd ^ rev cd st abbrev. ^ CPT CODE ^ unit char ge ^ units ^ total ^ non-cov c harge ^ fo rm locator 49 ^ rev code mult ien ^ cpt modifiers attached t o revenue code/proce dure (unli nked)^ out pt serv da te
5071	"RTN","IBC F33",94,0)
5072	;formats for output into spec ific colum n blocks 4 2-48
5073	"RTN","IBC F33",95,0)
5074	;
5075	"RTN","IBC F33",96,0)
5076	;JRA;IB2 .0577 Add Unit/Basi s of Measu re to arra y - added after 'un its' so th e string a bove will be changed to:
5077	"RTN","IBC F33",97,0)
5078	;rev cd ^ rev cd st abbrev. ^ CPT CODE ^ unit cha rge ^ unit s (Qty) ^ unit/basis of measur e ^ total ^ non-cov charge ^ f orm locato r 49 ^ rev code mult ien ^ cpt modifiers attached to revenue code/proc edure (unl inked)^ ou tpt serv d ate
5079	"RTN","IBC F33",98,0)
5080	;
5081	"RTN","IBC F33",99,0)
5082	N IBX,IBY ,IBLN,IBN, IBMOD
5083	"RTN","IBC F33",100,0 )
5084	D NEXTLN S IBY=""
5085	"RTN","IBC F33",101,0 )
5086	;set up r ev cd item with appr opriate ou tput value s, non-rev cd entrie s for old bills shou ld already be in ext ernal form
5087	"RTN","IBC F33",102,0 )
5088	S IBN=$P( IBZ,U,9) ; non-covere d charges
5089	"RTN","IBC F33",103,0 )
5090	S IBMOD=$ P(IBZ,U,10 ) I IBMOD' ="" S IBMO D=$E($TR(I BMOD,",;") ,1,4) ; cp t modifier s
5091	"RTN","IBC F33",104,0 )
5092	I +IBZ S IBX=$G(^DG CR(399.2,+ IBZ,0)) Q: IBX="" D
5093	"RTN","IBC F33",105,0 )
5094	. S IBY=$ P(IBX,U,1) _U_$P(IBX, U,2)_U_$$P RCD^IBCEF1 ($P(IBZ,U, 6)_";ICPT( ")_IBMOD
5095	"RTN","IBC F33",106,0 )
5096	. S IBY=I BY_U_$P(IB Z,U,2)_U_$ P(IBZ,U,3) _U_$P(IBZ, U,4)_U_IBN _U_$P(IBZ, U,13)_U_$G (IBDA)_U_U _$$DATE^IB CF2($P(IBZ ,U,14),"", 1)
5097	"RTN","IBC F33",107,0 )
5098	I IBY="" S IBY=$P(I BZ,U,1)_U_ $P(IBZ,U,2 )_U_U_U_$P (IBZ,U,3)_ U_$P(IBZ,U ,4)_U_IBN_ U_$P(IBZ,U ,13)_U_$G( IBDA)_U_U_ $$DATE^IBC F2($P(IBZ, U,14),"",1 )
5099	"RTN","IBC F33",108,0 )
5100	S $P(IBY, U,20,22)=$ P(IBZ,U,20 ,22) ;VA D Add "NDC #", "Unit/ Basis of M easure", a nd "Units/ Qty" to IB Y
5101	"RTN","IBC F33",109,0 )
5102	S IBLN=+$ G(^TMP($J, "IBC-RC")) +1,^TMP($J ,"IBC-RC", IBLN)=1_U_ IBY,^TMP($ J,"IBC-RC" )=IBLN I ' (IBLN#22) S IBLINES= 22
5103	"RTN","IBC F33",110,0 )
5104	Q
5105	"RTN","IBC F33",111,0 )
5106	;
5107	"RTN","IBC F33",112,0 )
5108	SET2 ;set free text into block 42 array
5109	"RTN","IBC F33",113,0 )
5110	Q:$G(IBNO COM) ;No comments w anted
5111	"RTN","IBC F33",114,0 )
5112	N IBLN D NEXTLN S I BCOL=$S('I BCOL:2,1:3 )
5113	"RTN","IBC F33",115,0 )
5114	S IBLN=+$ G(^TMP($J, "IBC-RC")) +1 I IBLN# 22=1,$G(IB FILL) S IB FILL=2 Q
5115	"RTN","IBC F33",116,0 )
5116	S ^TMP($J ,"IBC-RC", IBLN)=IBCO L_U_IBZ,^T MP($J,"IBC -RC")=IBLN I '(IBLN# 22) S IBLI NES=22
5117	"RTN","IBC F33",117,0 )
5118	Q
5119	"RTN","IBC F33",118,0 )
5120	;
5121	"RTN","IBC F33",119,0 )
5122	FILLUP ; F ill block 42 with bl ank lines
5123	"RTN","IBC F33",120,0 )
5124	N IBLN D NEXTLN S I BCOL=$S('I BCOL:2,1:3 )
5125	"RTN","IBC F33",121,0 )
5126	S IBLN=+$ G(^TMP($J, "IBC-RC")) +1 I IBLN# 22=1,$G(IB FILL) S IB FILL=2 Q
5127	"RTN","IBC F33",122,0 )
5128	S ^TMP($J ,"IBC-RC", IBLN)=IBCO L_U_IBZ,^T MP($J,"IBC -RC")=IBLN I '(IBLN# 22) S IBLI NES=22
5129	"RTN","IBC F33",123,0 )
5130	Q
5131	"RTN","IBC F33",124,0 )
5132	;
5133	"RTN","IBC F33",125,0 )
5134	NEXTLN ;ch ecks count er for nex t line, re sets if ne cessary,
5135	"RTN","IBC F33",126,0 )
5136	;ie. if t he line # indicated by the nex t line # v ar. has al ready been used then this incr ements the next line # var.
5137	"RTN","IBC F33",127,0 )
5138	S IBLN=+$ G(^TMP($J, "IBC-RC")) +1 I $D(^T MP($J,"IBC -RC",IBLN) ) S ^TMP($ J,"IBC-RC" )=IBLN S:' (IBLN#22) IBLINES=22 G NEXTLN
5139	"RTN","IBC F33",128,0 )
5140	Q
5141	"RTN","IBC F33",129,0 )
5142	;
5143	"RTN","IBC F33",130,0 )
5144	MOD(RCLN,I BIFN) ; re turn modif ier(s) for a directl y linked C PT charge or for an indirectly linked on e
5145	"RTN","IBC F33",131,0 )
5146	N IBCPTN, IBMOD
5147	"RTN","IBC F33",132,0 )
5148	S IBMOD=" "
5149	"RTN","IBC F33",133,0 )
5150	I $P($G(R CLN),U,10) =4 S IBCPT N=+$P(RCLN ,U,11) I + IBCPTN S I BMOD=$$GET MOD^IBEFUN C(IBIFN,IB CPTN,1) ;L inked
5151	"RTN","IBC F33",134,0 )
5152	I IBMOD=" ",$P(RCLN, U,14)'="" S IBMOD=$T R($P(RCLN, U,14),";", ",") ; Not linked or linked, b ut manuall y entered modifiers only
5153	"RTN","IBC F33",135,0 )
5154	MODQ Q IBM OD
5155	"RTN","IBC F33",136,0 )
5156	;
5157	"RTN","IBC F33",137,0 )
5158	DATE45(IBI FN,IBXDATA ,IBDATE) ; What prin ts in the service da te box of UB-04
5159	"RTN","IBC F33",138,0 )
5160	; INPUT:
5161	"RTN","IBC F33",139,0 )
5162	; IBIFN = ien of bill
5163	"RTN","IBC F33",140,0 )
5164	; IBDAT E = the de fault outp t service date
5165	"RTN","IBC F33",141,0 )
5166	; OUTPUT:
5167	"RTN","IBC F33",142,0 )
5168	; IBXDA TA = the o utput form atter arra y with the service d ates
5169	"RTN","IBC F33",143,0 )
5170	; (pass by refere nce)
5171	"RTN","IBC F33",144,0 )
5172	N Z,Z0,IB R,IBIN
5173	"RTN","IBC F33",145,0 )
5174	S IBIN=$$ INPAT^IBCE F(IBXIEN,1 )
5175	"RTN","IBC F33",146,0 )
5176	F Z=1:1 Q :'$D(^TMP( $J,"IBC-RC ",Z)) S I BR=^(Z) D
5177	"RTN","IBC F33",147,0 )
5178	. S Z0=$S (+IBR=1&'I BIN&(+$P(I BR,U,2)'=1 ):$S($P(IB R,U,12):$P (IBR,U,12) ,1:$G(IBDA TE)),+IBR= 2:$E($P(IB R,U,2),46, 52),1:$E($ P(IBR,U,2) ,41,47))
5179	"RTN","IBC F33",148,0 )
5180	. S:Z'>22 IBXDATA(Z )=Z0 D:Z>2 2 CKREV^IB CEF3(Z,Z0)
5181	"RTN","IBC F33",149,0 )
5182	Q
5183	"RTN","IBC F33",150,0 )
5184	;
5185	"RTN","IBC SC8")
5186	0^11^B9982 208^B97753 51
5187	"RTN","IBC SC8",1,0)
5188	IBCSC8 ;AL B/MJB/AAS - MCCR SCR EEN 8 (BIL LING - CLA IM INFORMA TION SCREE N) ;27 MAY 88 10:15
5189	"RTN","IBC SC8",2,0)
5190	;;2.0;INT EGRATED BI LLING;43 2,447,488, 577;21-M AR-94;Buil d 34
5191	"RTN","IBC SC8",3,0)
5192	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
5193	"RTN","IBC SC8",4,0)
5194	;
5195	"RTN","IBC SC8",5,0)
5196	;
5197	"RTN","IBC SC8",6,0)
5198	EN D ^IBCS CU S IBSR= 8,IBSR1="" S IB("U2" )=$G(^DGCR (399,IBIFN ,"U2")),IB ("U4")=$G( ^DGCR(399, IBIFN,"U4" )),IB("U5" )=$G(^DGCR (399,IBIFN ,"U5")),IB ("U6")=$G( ^DGCR(399, IBIFN,"U6" )),IB("U8" )=$G(^DGCR (399,IBIFN ,"U8"))
5199	"RTN","IBC SC8",7,0)
5200	D H^IBCSC U
5201	"RTN","IBC SC8",8,0)
5202	; DEM - I BV is set in EDI^IBC B => S IBA C=1,IBV=0 D EN G Q:' IBAC1,EDI
5203	"RTN","IBC SC8",9,0)
5204	; I BV=0, or I BV=1 as a flag if fi eld on scr een is req uired
5205	"RTN","IBC SC8",10,0)
5206	; o r not. <Fi eld #> ind icates fie ld is not required.
5207	"RTN","IBC SC8",11,0)
5208	; [ Field #]
5209	"RTN","IBC SC8",12,0)
5210	; Make so me section s NOT avai lable for UB04 form
5211	"RTN","IBC SC8",13,0)
5212	S IBT=$P( $G(^DGCR(3 99,IBIFN,0 )),U,19)
5213	"RTN","IBC SC8",14,0)
5214	;S IBV1=$ S(IBT=3:"0 01011",IBV :"111111", 1:"000000" )
5215	"RTN","IBC SC8",15,0)
5216	S IBV1=$S (IBT=3:"00 1011111",I BV:"111111 111",1:"00 0000000") ; IB2.0 488 (vd)
5217	"RTN","IBC SC8",16,0)
5218	;
5219	"RTN","IBC SC8",17,0)
5220	S Z=1,IBW =1 X IBWW W " COB No n-Covered Charge Amt : " S X=$P (IB("U4"), U),X2="2$" I X'="" D COMMA^%DT C W X
5221	"RTN","IBC SC8",18,0)
5222	S Z=2 X I BWW W " Pr operty Cas ualty Info rmation"
5223	"RTN","IBC SC8",19,0)
5224	;W !,?4," Claim Numb er: ",$P( IB("U4"),U ,2),?41,"C ontact Nam e: ",$P(I B("U4"),U, 9) ;JRA I B2.0577 ';'
5225	"RTN","IBC SC8",20,0)
5226	W !,?4,"C laim Numbe r: ",$P(I B("U4"),U, 2) ;JRA I B2.0577
5227	"RTN","IBC SC8",21,0)
5228	W !,?4,"C ontact Nam e: ",$P(I B("U4"),U, 9) ;JRA I B2.0577
5229	"RTN","IBC SC8",22,0)
5230	W !,?4,"D ate of 1st Contact: ",$$FMTE^ XLFDT($P(I B("U4"),U, 3)),?41,"C ontact Pho ne: ",$P( IB("U4"),U ,10)," ", $P(IB("U4" ),U,11)
5231	"RTN","IBC SC8",23,0)
5232	; Start I B2.0447 BI
5233	"RTN","IBC SC8",24,0)
5234	;S Z=3 X IBWW W " A mbulance I nformation "
5235	"RTN","IBC SC8",25,0)
5236	;W !,?41, "D/O Locat ion: ",$P( IB("U6"),U )
5237	"RTN","IBC SC8",26,0)
5238	;W !,?4," P/U Addres s1: ",$P( IB("U5"),U ,2),?41,"D /O Address 1: ",$P(I B("U6"),U, 2)
5239	"RTN","IBC SC8",27,0)
5240	;W !,?4," P/U Addres s2: ",$P( IB("U5"),U ,3),?41,"D /O Address 2: ",$P(I B("U6"),U, 3)
5241	"RTN","IBC SC8",28,0)
5242	;W !,?4," P/U City: ",$P(IB(" U5"),U,4), ?41,"D/O C ity: ",$P (IB("U6"), U,4)
5243	"RTN","IBC SC8",29,0)
5244	;W !,?4," P/U State/ Zip: " W: $P(IB("U5" ),U,5)'="" $P($G(^DI C(5,$P(IB( "U5"),U,5) ,0)),U,2)
5245	"RTN","IBC SC8",30,0)
5246	;W:$P(IB( "U5"),U,6) ]"" "/"_$P (IB("U5"), U,6)
5247	"RTN","IBC SC8",31,0)
5248	;W ?41,"D /O State/Z ip: " W:$ P(IB("U6") ,U,5)'="" $P($G(^DIC (5,$P(IB(" U6"),U,5), 0)),U,2)
5249	"RTN","IBC SC8",32,0)
5250	;W:$P(IB( "U6"),U,6) ]"" "/"_$P (IB("U6"), U,6)
5251	"RTN","IBC SC8",33,0)
5252	;;W !,?4, "P/U Count ry/SubDiv: ",$P(IB( "U5"),U),? 41,"D/O Co untry/SubD iv: "
5253	"RTN","IBC SC8",34,0)
5254	S Z=3 X I BWW W " Su rgical Cod es for Ane sthesia Cl aims"
5255	"RTN","IBC SC8",35,0)
5256	W !,?4,"P rimary Cod e: " W:$P (IB("U4"), U,7)'="" $ P($G(^ICPT ($P(IB("U4 "),U,7),0) ),U)
5257	"RTN","IBC SC8",36,0)
5258	W ?41,"Se condary Co de: " W:$ P(IB("U4") ,U,8)'="" $P($G(^ICP T($P(IB("U 4"),U,8),0 )),U)
5259	"RTN","IBC SC8",37,0)
5260	S Z=4 X I BWW W " Pa perwork At tachment I nformation "
5261	"RTN","IBC SC8",38,0)
5262	W !,?4,"R eport Type : " W:$P( IB("U8"),U ,2)'="" $P ($G(^IBE(3 53.3,$P(IB ("U8"),U,2 ),0)),U)
5263	"RTN","IBC SC8",39,0)
5264	W ?41,"Tr ansmission Method: ",$P(IB("U 8"),U,3)
5265	"RTN","IBC SC8",40,0)
5266	W !,?4,"A ttachment Control #: ",$P(IB( "U8"),U)
5267	"RTN","IBC SC8",41,0)
5268	S Z=5 X I BWW W " Di sability S tart Date: ",$$FMTE ^XLFDT($P( IB("U4"),U ,4)),?41," Disability End Date: ",$$FMTE ^XLFDT($P( IB("U4"),U ,5))
5269	"RTN","IBC SC8",42,0)
5270	S Z=6 X I BWW W " As sumed Care Date: ", $$FMTE^XLF DT($P(IB(" U4"),U,13) ),?41,"Rel inquished Care Date: ",$$FMTE ^XLFDT($P( IB("U4"),U ,14))
5271	"RTN","IBC SC8",43,0)
5272	; End IB* 2.0*447 BI
5273	"RTN","IBC SC8",44,0)
5274	;
5275	"RTN","IBC SC8",45,0)
5276	;/ Beginn ing of IB* 2.0*488 - code moved from IBCS C10H (vd)
5277	"RTN","IBC SC8",46,0)
5278	S Z=7 X I BWW W " Sp ecial Prog ram: " I $P(IB("U2" ),U,16)'=" " S IBZ=$$ EXPAND^IBT RE(399,238 ,$P(IB("U2 "),U,16)) W $S(IBZ'= "":IBZ,$$W NRBILL^IBE FUNC(IBIFN ):"31",1:" ")
5279	"RTN","IBC SC8",47,0)
5280	S Z=8 X I BWW W " Ho mebound: ",$$EXPAND ^IBTRE(399 ,236,$P(IB ("U2"),U,1 4))
5281	"RTN","IBC SC8",48,0)
5282	S Z=9 X I BWW W " Da te Last Se en: ",$$E XPAND^IBTR E(399,237, $P(IB("U2" ),U,15))
5283	"RTN","IBC SC8",49,0)
5284	;/ End of IB2.048 8 (vd)
5285	"RTN","IBC SC8",50,0)
5286	REV G ^IBC SCP
5287	"RTN","IBC SC8",51,0)
5288	;IBCSC8
5289	"RTN","IBC SC9")
5290	0^10^B9127 578^B75360 45
5291	"RTN","IBC SC9",1,0)
5292	IBCSC9 ;AL B/BI - MCC R SCREEN 9 (AMBULANC E INFO) ; 11 MAY 201 1 10:20
5293	"RTN","IBC SC9",2,0)
5294	;;2.0;INT EGRATED BI LLING;52 ,51,447,47 3,577;11 -MAY-2011; Build 34
5295	"RTN","IBC SC9",3,0)
5296	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
5297	"RTN","IBC SC9",4,0)
5298	;
5299	"RTN","IBC SC9",5,0)
5300	EN ; Main Entry Poin t
5301	"RTN","IBC SC9",6,0)
5302	N IBACI,I BACIX,IB,I BT
5303	"RTN","IBC SC9",7,0)
5304	D ^IBCSCU
5305	"RTN","IBC SC9",8,0)
5306	S IBT=$P( $G(^DGCR(3 99,IBIFN,0 )),U,19)
5307	"RTN","IBC SC9",9,0)
5308	S IBSR=9, IBSR1="",I BV1=$S(IBT =3:"11",IB V:"11",1:" 00")
5309	"RTN","IBC SC9",10,0)
5310	S IB("U") =$G(^DGCR( 399,IBIFN, "U"))
5311	"RTN","IBC SC9",11,0)
5312	S IB("U1" )=$G(^DGCR (399,IBIFN ,"U1"))
5313	"RTN","IBC SC9",12,0)
5314	S IB("U4" )=$G(^DGCR (399,IBIFN ,"U4"))
5315	"RTN","IBC SC9",13,0)
5316	S IB("U5" )=$G(^DGCR (399,IBIFN ,"U5"))
5317	"RTN","IBC SC9",14,0)
5318	S IB("U6" )=$G(^DGCR (399,IBIFN ,"U6"))
5319	"RTN","IBC SC9",15,0)
5320	S IB("U7" )=$G(^DGCR (399,IBIFN ,"U7"))
5321	"RTN","IBC SC9",16,0)
5322	S IB("U8" )=$G(^DGCR (399,IBIFN ,"U8"))
5323	"RTN","IBC SC9",17,0)
5324	M IB("U9" )=^DGCR(39 9,IBIFN,"U 9")
5325	"RTN","IBC SC9",18,0)
5326	D H^IBCSC U
5327	"RTN","IBC SC9",19,0)
5328	S Z=1,IBW =1 X IBWW W " Ambula nce Transp ort Data"
5329	"RTN","IBC SC9",20,0)
5330	;JRA IB2 .0577 Rea rrange Fie ld order s o that exp anded 55 c har PU/DO Address1 & PU/DO Add ress2 can be display ed
5331	"RTN","IBC SC9",21,0)
5332	;W !,?41, "D/O Locat ion: ",$P( IB("U6"),U ) ;JRA '; ' IB2.05 77
5333	"RTN","IBC SC9",22,0)
5334	;W !,?4," P/U Addres s1: ",$P(I B("U5"),U, 2),?41,"D/ O Address1 : ",$P(IB( "U6"),U,2) ;JRA IB* 2.0*577 '; '
5335	"RTN","IBC SC9",23,0)
5336	;W !,?4," P/U Addres s2: ",$P(I B("U5"),U, 3),?41,"D/ O Address2 : ",$P(IB( "U6"),U,3) ;JRA IB* 2.0*577 '; '
5337	"RTN","IBC SC9",24,0)
5338	;W !,?4," P/U City: ",$P(IB("U 5"),U,4),? 41,"D/O Ci ty: ",$P(I B("U6"),U, 4) ;JRA I B2.0577 ';'
5339	"RTN","IBC SC9",25,0)
5340	;W !,?4," P/U State/ Zip: " W:$ P(IB("U5") ,U,5)'="" $P($G(^DIC (5,$P(IB(" U5"),U,5), 0)),U,2) ;JRA IB2. 0577 ';'
5341	"RTN","IBC SC9",26,0)
5342	;W:$P(IB( "U5"),U,6) ]"" "/"_$P (IB("U5"), U,6) ;JRA IB2.057 7 ';'
5343	"RTN","IBC SC9",27,0)
5344	;W ?41,"D /O State/Z ip: " W:$P (IB("U6"), U,5)'="" $ P($G(^DIC( 5,$P(IB("U 6"),U,5),0 )),U,2) ; JRA IB2.0 577 ';'
5345	"RTN","IBC SC9",28,0)
5346	W !,?4,"P /U Address 1: ",$P(IB ("U5"),U,2 ) ;JRA IB 2.0577
5347	"RTN","IBC SC9",29,0)
5348	W !,?4,"P /U Address 2: ",$P(IB ("U5"),U,3 ) ;JRA IB 2.0577
5349	"RTN","IBC SC9",30,0)
5350	W !,?4,"P /U City: " ,$P(IB("U5 "),U,4) ; JRA IB2.0 577
5351	"RTN","IBC SC9",31,0)
5352	W ?41,"P/ U State/Zi p: " W:$P( IB("U5"),U ,5)'="" $P ($G(^DIC(5 ,$P(IB("U5 "),U,5),0) ),U,2) ;J RA IB2.0 577
5353	"RTN","IBC SC9",32,0)
5354	W:$P(IB(" U5"),U,6)] "" "/"_$P( IB("U5"),U ,6) ;JRA IB2.0577
5355	"RTN","IBC SC9",33,0)
5356	W !,?4,"D /O Locatio n: ",$P(IB ("U6"),U) ;JRA IB2 .0577
5357	"RTN","IBC SC9",34,0)
5358	W !,?4,"D /O Address 1: ",$P(IB ("U6"),U,2 ) ;JRA IB 2.0577
5359	"RTN","IBC SC9",35,0)
5360	W !,?4,"D /O Address 2: ",$P(IB ("U6"),U,3 ) ;JRA IB 2.0577
5361	"RTN","IBC SC9",36,0)
5362	W !,?4,"D /O City: " ,$P(IB("U6 "),U,4) ; JRA IB2.0 577
5363	"RTN","IBC SC9",37,0)
5364	W ?41,"D/ O State/Zi p: " W:$P( IB("U6"),U ,5)'="" $P ($G(^DIC(5 ,$P(IB("U6 "),U,5),0) ),U,2) ;J RA IB2.0 577
5365	"RTN","IBC SC9",38,0)
5366	W:$P(IB(" U6"),U,6)] "" "/"_$P( IB("U6"),U ,6)
5367	"RTN","IBC SC9",39,0)
5368	W !,?4,"P atient Wei ght: ",$P( IB("U7"),U ,1),?41,"T ransport D istance: " ,$P(IB("U7 "),U,3)
5369	"RTN","IBC SC9",40,0)
5370	W !,?4,"T ransport R eason: " I $P(IB("U7 "),U,2)'=" " D IBWP($ $GET1^DIQ( 353.4,$P(I B("U7"),U, 2)_",",.02 ),22,55)
5371	"RTN","IBC SC9",41,0)
5372	W !,?4,"R /T Purpose : " D IBWP ($P(IB("U7 "),U,4),17 ,60)
5373	"RTN","IBC SC9",42,0)
5374	W !,?4,"S tretcher P urpose: " D IBWP($P( IB("U7"),U ,5),23,54)
5375	"RTN","IBC SC9",43,0)
5376	S Z=2,IBW =2 X IBWW W " Ambula nce Certif ication Da ta"
5377	"RTN","IBC SC9",44,0)
5378	W !,?4,"C ondition I ndicator:"
5379	"RTN","IBC SC9",45,0)
5380	S IBACIX= 0
5381	"RTN","IBC SC9",46,0)
5382	F S IBAC IX=$O(IB(" U9",IBACIX )) Q:+IBAC IX=0 D
5383	"RTN","IBC SC9",47,0)
5384	. S IBACI =IB("U9",I BACIX,0)
5385	"RTN","IBC SC9",48,0)
5386	. W ?25,$ $GET1^DIQ( 353.5,IBAC I_",",.01) ," - ",$$G ET1^DIQ(35 3.5,IBACI_ ",",.02),!
5387	"RTN","IBC SC9",49,0)
5388	K IB("U9" )
5389	"RTN","IBC SC9",50,0)
5390	W !
5391	"RTN","IBC SC9",51,0)
5392	G ^IBCSCP
5393	"RTN","IBC SC9",52,0)
5394	Q
5395	"RTN","IBC SC9",53,0)
5396	;
5397	"RTN","IBC SC9",54,0)
5398	IBWP(IBX,I BLM,IBRM) ;
5399	"RTN","IBC SC9",55,0)
5400	K ^UTILIT Y($J,"W")
5401	"RTN","IBC SC9",56,0)
5402	N X,Y,DIW F,DIWL,DIW R S X=IBX
5403	"RTN","IBC SC9",57,0)
5404	S DIWL=1, DIWR=IBRM, DIWF="" D ^DIWP
5405	"RTN","IBC SC9",58,0)
5406	I $D(^UTI LITY($J,"W ")) S Y=0 F S Y=$O( ^UTILITY($ J,"W",1,Y) ) Q:'Y W: Y>1 !,?(IB LM) W $G(^ UTILITY($J ,"W",1,Y,0 ))
5407	"RTN","IBC SC9",59,0)
5408	K ^UTILIT Y($J,"W")
5409	"RTN","IBC SC9",60,0)
5410	Q
5411	"RTN","IBC SC9",61,0)
5412	;
5413	"RTN","IBC SC9",62,0)
5414	SCREEN1(DA 1) ;
5415	"RTN","IBC SC9",63,0)
5416	N A,RESPO NSE S RESP ONSE=0
5417	"RTN","IBC SC9",64,0)
5418	I +$P($G( ^DGCR(399, DA1,"U9",0 )),U,4)<5 S RESPONSE =1 Q RESPO NSE
5419	"RTN","IBC SC9",65,0)
5420	S A(1,"F" )="!?35",A (1)="Maxim um of 5 Co ndition In dicators a llowed"
5421	"RTN","IBC SC9",66,0)
5422	D EN^DDIO L(.A)
5423	"RTN","IBC SC9",67,0)
5424	Q RESPONS E
5425	"RTN","IBC SC9",68,0)
5426	;IBCSC9
5427	"RTN","IBC U7")
5428	0^1^B11640 7276^B1132 07672
5429	"RTN","IBC U7",1,0)
5430	IBCU7 ;ALB /AAS - INT ERCEPT SCR EEN INPUT OF PROCEDU RE CODES ; 29-OCT-91
5431	"RTN","IBC U7",2,0)
5432	;;2.0;INT EGRATED BI LLING;62 ,52,106,12 5,51,137,2 10,245,228 ,260,348,3 71,432,447 ,488,461,5 16,522,577 ;21-MAR- 94;Build 3 4
5433	"RTN","IBC U7",3,0)
5434	;;Per VA Directive 6402, this routine s hould not be modifie d.
5435	"RTN","IBC U7",4,0)
5436	;
5437	"RTN","IBC U7",5,0)
5438	;MAP TO D GCRU7
5439	"RTN","IBC U7",6,0)
5440	;
5441	"RTN","IBC U7",7,0)
5442	CHKX ; -i nterceptio n of input x from Ad ditional P rocedure i nput
5443	"RTN","IBC U7",8,0)
5444	G:X=" " C HKXQ
5445	"RTN","IBC U7",9,0)
5446	I $$INPAT ^IBCEF(DA( 1)),'$P($G (^IBE(350. 9,1,1)),"^ ",15),X'?1 A1.2N D G CHKXQ
5447	"RTN","IBC U7",10,0)
5448	. K X
5449	"RTN","IBC U7",11,0)
5450	. D EN^DD IOL("Site param does not allow entry of non-PTF pr ocedures") ;Fileman error here will be: The previo us error o ccurred wh en perform ing an act ion specif ied in a P re-lookup transform (7.5 node) .
5451	"RTN","IBC U7",12,0)
5452	G:'$D(^UT ILITY($J," IB")) CHKX Q
5453	"RTN","IBC U7",13,0)
5454	;S M=($A( $E(X,1))-6 4),S=+$E(X ,2) Q:'$G( ^UTILITY($ J,"IB",M,S )) S X="` "_+^(S)
5455	"RTN","IBC U7",14,0)
5456	S M=0 I X ?1A1.2N S N=$G(^UTIL ITY($J,"IB ","B",X)) S M=+N,S=+ $P(N,U,2), P=X S S=$G (^UTILITY( $J,"IB",M, S)) I +S S X="`"_+S I $P(N,U,3 )="N" S X= """"_X_""" " S $P(^UT ILITY($J," IB","B",P) ,U,3)="Y"
5457	"RTN","IBC U7",15,0)
5458	I +M,$D(D GPROCDT),D GPROCDT'=$ P($G(^UTIL ITY($J,"IB ",M,1)),"^ ",2) S DGP ROCDT=$P(^ (1),"^",2) W !!,"Pro cedure Dat e: " S Y=D GPROCDT X ^DD("DD") W Y,!
5459	"RTN","IBC U7",16,0)
5460	CHKXQ Q
5461	"RTN","IBC U7",17,0)
5462	;
5463	"RTN","IBC U7",18,0)
5464	CODMUL ;Da te oriente d entry of procedure
5465	"RTN","IBC U7",19,0)
5466	DELASK I $ D(IBZ20),I BZ20,IBZ20 '=$P(^DGCR (399,IBIFN ,0),U,9) S %=2 W !," SINCE THE PROCEDURE CODING MET HOD HAS BE EN CHANGED , DO YOU W ANT TO DEL ETE ALL",! ,"PROCEDUR E CODES IN THIS BILL "
5467	"RTN","IBC U7",20,0)
5468	I D YN^D ICN Q:%=-1 D:%=1 DE LADD I %Y? 1."?" W !! ,"If you a nswer 'Yes ', all pro cedure cod es will be DELETED f rom this b ill.",! G DELASK
5469	"RTN","IBC U7",21,0)
5470	K %,%Y,DA ,IBZ20,DIK ;W !,"Pro cedure Ent ry:"
5471	"RTN","IBC U7",22,0)
5472	;
5473	"RTN","IBC U7",23,0)
5474	CODDT I $D (IBIFN),$D (^DGCR(399 ,IBIFN,0)) ,$P(^(0),U ,9) S DIC( "V")=$S($P (^(0),U,9) =9:"I +Y(0 )=80.1",$P (^(0),U,9) =4!($P(^(0 ),U,9)=5): "I +Y(0)=8 1",1:"")
5475	"RTN","IBC U7",24,0)
5476	I $P($G(^ DGCR(399,I BIFN,0))," ^",5)<3 S IBZTYPE=1 I $P($G(^U TILITY($J, "IB",1,1)) ,"^",2) S DGPROCDT=$ P(^(1),"^" ,2) D ASKC OD
5477	"RTN","IBC U7",25,0)
5478	S X=$$PRC DIV^IBCU71 (IBIFN) I +X W !!,$P (X,U,2),!
5479	"RTN","IBC U7",26,0)
5480	N Z,Z0 S Z=$G(^DGCR (399,IBIFN ,"U")),Z0= $$FMTE^XLF DT($P(Z,U) ,"2D")_"-" _$$FMTE^XL FDT($P(Z,U ,2),"2D")
5481	"RTN","IBC U7",27,0)
5482	W !,"Sele ct PROCEDU RE DATE"_$ S($TR(Z0," -")'="":" ("_Z0_")", 1:"")_": " R X:DTIME G:'$T!("^ "[X) CODQ D:X["?" CO DHLP
5483	"RTN","IBC U7",28,0)
5484	S IBEX=0 D ; Get p rocedure d ate
5485	"RTN","IBC U7",29,0)
5486	. I X=" " ,$D(DGPROC DT),DGPROC DT?7N S Y= DGPROCDT D D^DIQ W " (",Y,") " Q
5487	"RTN","IBC U7",30,0)
5488	. I X=" " ,+$P($G(^D GCR(399,IB IFN,"OP",0 )),"^",4) S (DGPROCD T,Y)=$O(^D GCR(399,IB IFN,"OP",0 )) D D^DIQ W " (", Y,")" Q
5489	"RTN","IBC U7",31,0)
5490	. S %DT=" EXP",%DT(0 )=-DT D ^% DT K %DT I Y<1 S IBE X=1 Q
5491	"RTN","IBC U7",32,0)
5492	. I '$$OP V2^IBCU41( Y,IBIFN,1) S IBEX=1 Q
5493	"RTN","IBC U7",33,0)
5494	. S:'$G(I BZTYPE) X= $$OPV^IBCU 41(Y,IBIFN ) S DGPROC DT=Y
5495	"RTN","IBC U7",34,0)
5496	I 'IBEX D ASKCOD,AD DCPT^IBCU7 1:$D(DGCPT )
5497	"RTN","IBC U7",35,0)
5498	K IBEX
5499	"RTN","IBC U7",36,0)
5500	G CODDT
5501	"RTN","IBC U7",37,0)
5502	;
5503	"RTN","IBC U7",38,0)
5504	ASKCOD N Z ,Z0,DA,IBA CT,IBQUIT, IBLNPRV ; WCJ;2.0*43 2
5505	"RTN","IBC U7",39,0)
5506	N IBPOPOU T S IBPOP OUT=0 ; I B2.0447 BI
5507	"RTN","IBC U7",40,0)
5508	K DGCPT
5509	"RTN","IBC U7",41,0)
5510	S DGCPT=0 ,DGCPTUP=$ P($G(^IBE( 350.9,1,1) ),"^",19), DGADDVST=0 ,IBFT=$P($ G(^DGCR(39 9,IBIFN,0) ),"^",19)
5511	"RTN","IBC U7",42,0)
5512	I '$D(^DG CR(399,IBI FN,"CP",0) ) S ^DGCR( 399,IBIFN, "CP",0)=U_ $$GETSPEC^ IBEFUNC(39 9,304)
5513	"RTN","IBC U7",43,0)
5514	;
5515	"RTN","IBC U7",44,0)
5516	F S IBQU IT=0 D Q: IBQUIT
5517	"RTN","IBC U7",45,0)
5518	. S IBPOP OUT=0
5519	"RTN","IBC U7",46,0)
5520	. D DICV ; restrict code type to PCM
5521	"RTN","IBC U7",47,0)
5522	. S DIC(" A")=" Se lect PROCE DURE: "
5523	"RTN","IBC U7",48,0)
5524	. S DIC=" ^DGCR(399, "_IBIFN_", ""CP"","
5525	"RTN","IBC U7",49,0)
5526	. S DIC(0 )="AEQMNL"
5527	"RTN","IBC U7",50,0)
5528	. S DIC(" S")="I '$D (DIV(""S"" ))&($P(^(0 ),U,2)=DGP ROCDT)"
5529	"RTN","IBC U7",51,0)
5530	. S DIC(" DR")="1/// ^S X=DGPRO CDT"
5531	"RTN","IBC U7",52,0)
5532	. S DA(1) =IBIFN,DLA YGO=399
5533	"RTN","IBC U7",53,0)
5534	. W ! D ^ DIC I Y<1 S IBQUIT=1 Q
5535	"RTN","IBC U7",54,0)
5536	. S IBPRO CP=+Y
5537	"RTN","IBC U7",55,0)
5538	. ; If we just adde d inactive code - it must be d eleted.
5539	"RTN","IBC U7",56,0)
5540	. S IBACT =0 ; Activ e flag
5541	"RTN","IBC U7",57,0)
5542	. I Y["IC D0" S IBAC T=$$ICD0AC T^IBACSV(+ $P(Y,U,2), $$BDATE^IB ACSV(IBIFN ))
5543	"RTN","IBC U7",58,0)
5544	. I Y["IC PT" S IBAC T=$$CPTACT ^IBACSV(+$ P(Y,U,2),D GPROCDT)
5545	"RTN","IBC U7",59,0)
5546	. S DGCPT NEW=$P(Y," ^",3) ;Was the proce dure just added?
5547	"RTN","IBC U7",60,0)
5548	. I DGCPT NEW,'IBACT D DELPROC Q
5549	"RTN","IBC U7",61,0)
5550	. I 'IBAC T W !,*7," Warning: Procedure code is in active on this date" ,!
5551	"RTN","IBC U7",62,0)
5552	. I DGCPT NEW,$D(^UT ILITY($J," IB")),$$IN PAT^IBCEF( IBIFN),Y[" ICPT(" D D ATA^IBCU74 (Y,.IBLNPR V)
5553	"RTN","IBC U7",63,0)
5554	. S DGADD VST=$S(DGC PTNEW:1,$D (DGADDVST) :DGADDVST, 1:0)
5555	"RTN","IBC U7",64,0)
5556	. N IBPRV ,IBPRVO,IB PRVN
5557	"RTN","IBC U7",65,0)
5558	. ;
5559	"RTN","IBC U7",66,0)
5560	. ; Line level prov ider funct ion by for m type.
5561	"RTN","IBC U7",67,0)
5562	. ; C MS-1500 (F ORM TYPE=2 )
5563	"RTN","IBC U7",68,0)
5564	. ; RE NDERING PR OVIDER, RE FERRING PR OVIDER,
5565	"RTN","IBC U7",69,0)
5566	. ; an d SUPERVIS ING PROVID ER.
5567	"RTN","IBC U7",70,0)
5568	. ; U B-04 (FORM TYPE=3)
5569	"RTN","IBC U7",71,0)
5570	. ; RE NDERING PR OVIDER, RE FERRING PR OVIDER,
5571	"RTN","IBC U7",72,0)
5572	. ; OP ERATING PR OVIDER, an d OTHER OP ERATING
5573	"RTN","IBC U7",73,0)
5574	. ; PR OVIDER.
5575	"RTN","IBC U7",74,0)
5576	. ;
5577	"RTN","IBC U7",75,0)
5578	. ; Remov ed: Call t o $$MAINPR V^IBCEU(IB IFN) is fo r claim
5579	"RTN","IBC U7",76,0)
5580	. ; level provider d efaults.
5581	"RTN","IBC U7",77,0)
5582	. ; 1 . For new line level providers we don't need
5583	"RTN","IBC U7",78,0)
5584	. ; or want default cl aim level provider
5585	"RTN","IBC U7",79,0)
5586	. ; (require ment).
5587	"RTN","IBC U7",80,0)
5588	. ; 2 . We don't want to d efault cla im level t o
5589	"RTN","IBC U7",81,0)
5590	. ; line lev el provide r (require ment).
5591	"RTN","IBC U7",82,0)
5592	. ;
5593	"RTN","IBC U7",83,0)
5594	. K DIC(" V") ; DEM ;432 - KIL L DIC("V") because t his was fo r previous variable pointer us e.
5595	"RTN","IBC U7",84,0)
5596	. ;
5597	"RTN","IBC U7",85,0)
5598	. N IBPRO CSV ; DEM ;432 - Var iable IBPR OCSV is va riable to preserve v alue of 'Y ', which i s procedur e code inf o returned by call t o ^DIC.
5599	"RTN","IBC U7",86,0)
5600	. S IBPRO CSV=Y ; D EM;432 - P reserve va lue of Y f or after c alls to Fi leMan (Y = procedure code info returned by call to ^DIC).
5601	"RTN","IBC U7",87,0)
5602	. K DR ;WCJ;IB2. 0432
5603	"RTN","IBC U7",88,0)
5604	. ;
5605	"RTN","IBC U7",89,0)
5606	. I IBPRO CSV["ICD0" S DR=".01 ",DIE=DIC, (IBPROCP,D A)=+Y D ^D IE Q:'$D(D A)!($D(Y)) K DR ; I B2.0461
5607	"RTN","IBC U7",90,0)
5608	. I IBPRO CSV["ICPT" S DR=".01 ;16",DIE=D IC,(IBPROC P,DA)=+Y D ^DIE Q:'$ D(DA)!($D( Y)) K DR ; IB2.04 47 BI
5609	"RTN","IBC U7",91,0)
5610	. ;
5611	"RTN","IBC U7",92,0)
5612	. S DR=""
5613	"RTN","IBC U7",93,0)
5614	. ;
5615	"RTN","IBC U7",94,0)
5616	. ; MRD;I B2.0516 - Added li ne level P ROCEDURE D ESCRIPTION field,
5617	"RTN","IBC U7",95,0)
5618	. ; asked only if t he procedu re is an " NOC".
5619	"RTN","IBC U7",96,0)
5620	. I IBPRO CSV["ICPT" ,$$NOCPROC (IBPROCSV) D
5621	"RTN","IBC U7",97,0)
5622	. . S DA= $P(IBPROCS V,"^") ; The line# on the bil l/claim.
5623	"RTN","IBC U7",98,0)
5624	. . S DR= 51 ; Field# for PROCEDURE DESCRIPTI ON
5625	"RTN","IBC U7",99,0)
5626	. . D ^DI E
5627	"RTN","IBC U7",100,0)
5628	. . Q
5629	"RTN","IBC U7",101,0)
5630	. ;
5631	"RTN","IBC U7",102,0)
5632	. D EN^IB CU7B ; DEM ;432 - Cal l to line level prov ider user input.
5633	"RTN","IBC U7",103,0)
5634	. S Y=IBP ROCSV ; D EM;432 - R estore val ue of Y af ter calls to FileMan
5635	"RTN","IBC U7",104,0)
5636	. K IBPRO CSV
5637	"RTN","IBC U7",105,0)
5638	. K DR ;WCJ;IB2. 0432
5639	"RTN","IBC U7",106,0)
5640	. I IBPOP OUT Q ; IB2.0447 BI
5641	"RTN","IBC U7",107,0)
5642	. S DR="" I Y["ICPT " S DR="6; 5//"_$$DEF DIV(IBIFN) _";"
5643	"RTN","IBC U7",108,0)
5644	. S DR=DR _$S(IBFT=2 :"8;9;17// NO;",1:"") _3,DIE=DIC ,(IBPROCP, DA)=+Y D ^ DIE Q:'$D( DA)!($E($G (Y))=U)
5645	"RTN","IBC U7",109,0)
5646	. K DR ;WCJ;IB2. 0432
5647	"RTN","IBC U7",110,0)
5648	. ;
5649	"RTN","IBC U7",111,0)
5650	. ; MRD;I B2.0516 - Allow us er to add an NDC and Units. A sk only if
5651	"RTN","IBC U7",112,0)
5652	. ; codin g system i s not ICD and this i s not a pr escription claim. If
5653	"RTN","IBC U7",113,0)
5654	. ; an ND C is enter ed, prompt for Units .
5655	"RTN","IBC U7",114,0)
5656	. I $P($G (^DGCR(399 ,IBIFN,0)) ,U,9)'=9,' $$RXLINK^I BCSC5C(IBI FN,IBPROCP ) D
5657	"RTN","IBC U7",115,0)
5658	. . K DA
5659	"RTN","IBC U7",116,0)
5660	. . S DA= IBPROCP,DA (1)=IBIFN, DIE="^DGCR (399,"_IBI FN_",""CP" ","
5661	"RTN","IBC U7",117,0)
5662	. . ; vd/ Beginning IB2577 - Added the prompt fo r Unit/Bas is of Meas urement.
5663	"RTN","IBC U7",118,0)
5664	. . ; S D R="53NDC N UMBER;I X= """" S Y=" """;54//1"
5665	"RTN","IBC U7",119,0)
5666	. . S DR= "53NDC NUM BER;I X="" "" S Y=""" ";52//UN;5 4QUANTITY/ /1" ;Prom pt for NDC , UN & amt .
5667	"RTN","IBC U7",120,0)
5668	. . ; vd/ Ending IB* 2*577
5669	"RTN","IBC U7",121,0)
5670	. . D ^DI E
5671	"RTN","IBC U7",122,0)
5672	. . Q
5673	"RTN","IBC U7",123,0)
5674	. ;
5675	"RTN","IBC U7",124,0)
5676	. I IBFT= 3 D:'$$INP AT^IBCEF(I BIFN) ATTA CH ; DEM; 432 - Prom pt for Att achment Co ntrol Numb er.
5677	"RTN","IBC U7",125,0)
5678	. ; DEM;4 32 - Add A dditional OB Minutes to DR str ing for ca ll to DIE.
5679	"RTN","IBC U7",126,0)
5680	. S DR=$$ SPCUNIT(IB IFN,IBPROC P) S:DR["1 5;" DR=DR_ "74Additio nal OB Min utes" D ^D IE ; miles /minutes/h ours
5681	"RTN","IBC U7",127,0)
5682	. ;
5683	"RTN","IBC U7",128,0)
5684	. I IBFT= 2 D
5685	"RTN","IBC U7",129,0)
5686	.. D DX^I BCU72(IBIF N,IBPROCP)
5687	"RTN","IBC U7",130,0)
5688	.. S X=$$ ADDTNL(IBI FN,.DA)
5689	"RTN","IBC U7",131,0)
5690	. Q:$$INP AT^IBCEF(I BIFN) ;on ly outpati ent bills
5691	"RTN","IBC U7",132,0)
5692	. ;add pr ocedures t o array fo r download to PCE: d gcpt(assoc clinic,cp t,'provide r^first dx ^modifiers ',cnt)=""
5693	"RTN","IBC U7",133,0)
5694	. S DGPRO C=$G(^DGCR (399,IBIFN ,"CP",+DA, 0))
5695	"RTN","IBC U7",134,0)
5696	. S X=$P( DGPROC,U,1 8)_U_+$G(^ IBA(362.3, +$P(DGPROC ,U,11),0)) _U_$P(DGPR OC,U,15)
5697	"RTN","IBC U7",135,0)
5698	. I 'DGCP TNEW,$P(DG PROC,"^",7 )="" S DGC PTNEW=2
5699	"RTN","IBC U7",136,0)
5700	. I DGCPT UP,DGCPTNE W S DGCPT= DGCPT+1 I $P(DGPROC, "^",7) S D GCPT($P(DG PROC,"^",7 ),+DGPROC, X,DGCPT)=" "
5701	"RTN","IBC U7",137,0)
5702	. ; add v isit date to bill
5703	"RTN","IBC U7",138,0)
5704	. I DGADD VST S (X,D INUM)=DGPR OCDT D VFI LE1^IBCOPV 1 K DINUM, X,DGNOADD, DGADDVST
5705	"RTN","IBC U7",139,0)
5706	; Delete modifiers with only a sequence #, no cod e
5707	"RTN","IBC U7",140,0)
5708	S Z=0 F S Z=$O(^DG CR(399,IBI FN,"CP",Z) ) Q:'Z S Z0=0 F S Z0=$O(^DGC R(399,IBIF N,"CP",Z," MOD",Z0)) Q:'Z0 I $ P($G(^(Z0, 0)),U,2)=" " S DA(2)= IBIFN,DA(1 )=Z,DA=Z0, DIK="^DGCR (399,"_DA( 2)_",""CP" ","_DA(1)_ ",""MOD"", " D ^DIK
5709	"RTN","IBC U7",141,0)
5710	Q
5711	"RTN","IBC U7",142,0)
5712	CODQ K %DT ,DGPROC,DI C,DIE,DR,D GPROCDT,IB PROCP,DLAY GO
5713	"RTN","IBC U7",143,0)
5714	K IBFT,DG NOADD,DGAD DVST,DGCPT ,DGCPTUP,I BZTYPE,DGC PTNEW
5715	"RTN","IBC U7",144,0)
5716	Q
5717	"RTN","IBC U7",145,0)
5718	;
5719	"RTN","IBC U7",146,0)
5720	DELPROC ; Remove the selected procedure, because o f inactive status (c ancel sele ction)
5721	"RTN","IBC U7",147,0)
5722	W !!,*7," The Proced ure code i s inactive on ",$$DA T1^IBOUTL( DGPROCDT), "."
5723	"RTN","IBC U7",148,0)
5724	W !,"Plea se select another Pr ocedure."
5725	"RTN","IBC U7",149,0)
5726	S DA(1)=I BIFN,DA=+Y ,DIK="^DGC R(399,"_IB IFN_",""CP "","
5727	"RTN","IBC U7",150,0)
5728	D ^DIK
5729	"RTN","IBC U7",151,0)
5730	Q
5731	"RTN","IBC U7",152,0)
5732	;
5733	"RTN","IBC U7",153,0)
5734	DELADD N Z ,Z0,DA,DIK ,X,Y
5735	"RTN","IBC U7",154,0)
5736	S DA(1)=I BIFN
5737	"RTN","IBC U7",155,0)
5738	;Delete r eferences to proc on rev codes
5739	"RTN","IBC U7",156,0)
5740	S Z=0 F S Z=$O(^DG CR(399,IBI FN,"RC",Z) ) Q:'Z S Z0=$G(^(Z, 0)) I Z0'= "",$P(Z0,U ,15)!$S($P (Z0,U,10)= 3:$P(Z0,U, 11),1:0) S DIE="^DGC R(399,"_DA (1)_",""RC "",",DA=Z, DR=".11/// @;.15///@" _$S($P(Z0, U,8):"",1: ";.08////1 ") D ^DIE
5741	"RTN","IBC U7",157,0)
5742	S DIK="^D GCR(399,"_ DA(1)_","" CP""," F D A=0:0 S DA =$O(^DGCR( 399,DA(1), "CP",DA)) Q:'DA D ^ DIK
5743	"RTN","IBC U7",158,0)
5744	S DGRVRCA L=1
5745	"RTN","IBC U7",159,0)
5746	Q
5747	"RTN","IBC U7",160,0)
5748	;
5749	"RTN","IBC U7",161,0)
5750	DTMES ;Mes sage if pr ocedure da te not in date range
5751	"RTN","IBC U7",162,0)
5752	Q:'$D(IBI FN) Q:'$D (^DGCR(399 ,IBIFN,"U" )) S DGNO DUU=^("U")
5753	"RTN","IBC U7",163,0)
5754	G:X'<$P(D GNODUU,"^" )&(X'>$P(D GNODUU,"^" ,2)) DTMES Q
5755	"RTN","IBC U7",164,0)
5756	W *7,!!?3 ,"Date mus t be withi n STATEMEN T COVERS F ROM and ST ATEMENT CO VERS TO pe riod."
5757	"RTN","IBC U7",165,0)
5758	S Y=$P(DG NODUU,"^") X ^DD("DD ")
5759	"RTN","IBC U7",166,0)
5760	W !?3,"En ter a date between " ,Y," and " S Y=$P(DG NODUU,"^", 2) X ^DD(" DD") W Y,!
5761	"RTN","IBC U7",167,0)
5762	K X,Y
5763	"RTN","IBC U7",168,0)
5764	DTMESQ K D GNODUU Q
5765	"RTN","IBC U7",169,0)
5766	;
5767	"RTN","IBC U7",170,0)
5768	CODHLP ;Di splay Addi tional Pro cedure cod es
5769	"RTN","IBC U7",171,0)
5770	N I,J,Y,I BMOD
5771	"RTN","IBC U7",172,0)
5772	I '$O(^DG CR(399,IBI FN,"CP",0) ) W !!?5," No Codes E ntered!",! Q
5773	"RTN","IBC U7",173,0)
5774	W ! F I=0 :0 S I=$O( ^DGCR(399, IBIFN,"CP" ,I)) Q:'I S Y=$G(^( I,0)) S Z= $$PRCNM^IB CSCH1($P(Y ,"^",1),$P (Y,"^",2)) W !?5,$E( $P(Z,"^",2 ),1,33),?4 0,"- ",$P( Z,"^") D
5775	"RTN","IBC U7",174,0)
5776	. N IBY
5777	"RTN","IBC U7",175,0)
5778	. S IBY=$ P(Y,U,2)
5779	"RTN","IBC U7",176,0)
5780	. S IBMOD =$$GETMOD^ IBEFUNC(IB IFN,I,1)
5781	"RTN","IBC U7",177,0)
5782	. I IBMOD '="" S IBM OD="/"_IBM OD W IBMOD
5783	"RTN","IBC U7",178,0)
5784	. W ?60," Date: " S Y=IBY D DT ^DIQ
5785	"RTN","IBC U7",179,0)
5786	W !
5787	"RTN","IBC U7",180,0)
5788	;
5789	"RTN","IBC U7",181,0)
5790	K Z Q
5791	"RTN","IBC U7",182,0)
5792	;
5793	"RTN","IBC U7",183,0)
5794	DICV I $D( IBIFN),$D( ^DGCR(399, IBIFN,0)), $P(^(0),U, 9) S DIC(" V")=$S($P( ^(0),U,9)= 9:"I +Y(0) =80.1",$P( ^(0),U,9)= 4!($P(^(0) ,U,9)=5):" I +Y(0)=81 ",1:"")
5795	"RTN","IBC U7",184,0)
5796	Q
5797	"RTN","IBC U7",185,0)
5798	;
5799	"RTN","IBC U7",186,0)
5800	DEFDIV(IBI FN) ; Find default d ivision fo r bill IBI FN
5801	"RTN","IBC U7",187,0)
5802	Q $P($G(^ DG(40.8,+$ P($G(^DGCR (399,IBIFN ,0)),U,22) ,0)),U)
5803	"RTN","IBC U7",188,0)
5804	;
5805	"RTN","IBC U7",189,0)
5806	ADDTNL(IBI FN,DA) ;
5807	"RTN","IBC U7",190,0)
5808	N DR,IBOK ,X,Y,DIR
5809	"RTN","IBC U7",191,0)
5810	S IBOK=1
5811	"RTN","IBC U7",192,0)
5812	S DR="19T ;50.09T;50 .08T" D ^D IE ; WCJ; IB2.0488 Added Ts
5813	"RTN","IBC U7",193,0)
5814	;I '($$FT ^IBCEF(IBI FN)'=3&($$ INPAT^IBCE F(IBIFN))) D ATTACH ; DEM;432 - Prompt for Attach ment Contr ol Number.
5815	"RTN","IBC U7",194,0)
5816	I '($$FT^ IBCEF(IBIF N)=3&($$IN PAT^IBCEF( IBIFN))) D ATTACH ; DEM;432 - Prompt fo r Attachme nt Control Number.
5817	"RTN","IBC U7",195,0)
5818	I $D(Y) S IBOK=0 G ADDTNLQ
5819	"RTN","IBC U7",196,0)
5820	;/Beginni ng of IB2 .0488 (vd )
5821	"RTN","IBC U7",197,0)
5822	;S DIR("B ")="NO",DI R("A")="ED IT CMS-150 0 SPECIAL PROGRAM FI ELDS and B OX 19?: ", DIR("A",1) =" ",DIR(0 )="YA"
5823	"RTN","IBC U7",198,0)
5824	;S DIR("? ",1)="Resp ond YES on ly if you need to ad d/edit dat a for chir opractic v isits,"
5825	"RTN","IBC U7",199,0)
5826	;S DIR("? ")="EPSDT care, or i f billing for HOSPIC E and atte nding is n ot a hospi ce employe e."
5827	"RTN","IBC U7",200,0)
5828	;D ^DIR K DIR
5829	"RTN","IBC U7",201,0)
5830	;I Y'=1 S IBOK=0 G ADDTNLQ
5831	"RTN","IBC U7",202,0)
5832	;S DR="W !,"" <<EP SDT>>"";50 .07;W !!," " <<HOSPI CE>>"";50. 03"
5833	"RTN","IBC U7",203,0)
5834	S DR="50. 07T;50.03T " ;WCJ;I B2.0488 added Ts
5835	"RTN","IBC U7",204,0)
5836	;/End of IB2.0488 (vd)
5837	"RTN","IBC U7",205,0)
5838	D ^DIE
5839	"RTN","IBC U7",206,0)
5840	W !
5841	"RTN","IBC U7",207,0)
5842	ADDTNLQ Q IBOK
5843	"RTN","IBC U7",208,0)
5844	;
5845	"RTN","IBC U7",209,0)
5846	XTRA1(Y) ;
5847	"RTN","IBC U7",210,0)
5848	K Y
5849	"RTN","IBC U7",211,0)
5850	Q
5851	"RTN","IBC U7",212,0)
5852	;
5853	"RTN","IBC U7",213,0)
5854	SPCUNIT(IB IFN,DA) ; return fie lds for sp ecial unit s if appli cable, in DR form
5855	"RTN","IBC U7",214,0)
5856	N IB0,IBC PT,IBDR,IB CT,IBFT,DF N S IBDR=" "
5857	"RTN","IBC U7",215,0)
5858	S IB0=$G( ^DGCR(399, +$G(IBIFN) ,0)),IBCT= $P(IB0,U,2 7),IBFT=$P (IB0,U,19) ,DFN=$P(IB 0,U,2)
5859	"RTN","IBC U7",216,0)
5860	S IBCPT=$ G(^DGCR(39 9,+$G(IBIF N),"CP",+$ G(DA),0)) I IBCPT'[" ICPT" G SP CUNTQ
5861	"RTN","IBC U7",217,0)
5862	I +$$ITMU NIT^IBCRU4 (+IBCPT,5, IBCT) S IB DR="15;" D SROMIN^IB CU74(IBIFN ,DA) G SPC UNTQ ; min utes
5863	"RTN","IBC U7",218,0)
5864	I +$$ITMU NIT^IBCRU4 (+IBCPT,4, IBCT) S IB DR="21;" G SPCUNTQ ; miles
5865	"RTN","IBC U7",219,0)
5866	I +$$ITMU NIT^IBCRU4 (+IBCPT,6, IBCT) S IB DR="22//"_ $$OBSHOUR^ IBCU74(DFN ,$P(IBCPT, U,2))_";" G SPCUNTQ ; hours
5867	"RTN","IBC U7",220,0)
5868	I +IBFT=2 ,$P($G(^IB E(353.2,+$ P(IBCPT,U, 10),0)),U, 2)="ANESTH ESIA" S IB DR="15;" ; minutes
5869	"RTN","IBC U7",221,0)
5870	SPCUNTQ Q IBDR
5871	"RTN","IBC U7",222,0)
5872	;
5873	"RTN","IBC U7",223,0)
5874	ATTACH ; D EM;432 - A ttachment control nu mber.
5875	"RTN","IBC U7",224,0)
5876	; Ask if user wants to enter Attachment Control N umber.
5877	"RTN","IBC U7",225,0)
5878	N DIR,X,Y ,DA,DIE,DR
5879	"RTN","IBC U7",226,0)
5880	S DIR("A" )="Enter A ttachment Control Nu mber"
5881	"RTN","IBC U7",227,0)
5882	S DIR(0)= "Y",DIR("B ")="NO"
5883	"RTN","IBC U7",228,0)
5884	D ^DIR
5885	"RTN","IBC U7",229,0)
5886	Q:'Y
5887	"RTN","IBC U7",230,0)
5888	; User ch ose to ent er Attachm ent Contro l Number.
5889	"RTN","IBC U7",231,0)
5890	; User en ters Attac hment Cont rol fields .
5891	"RTN","IBC U7",232,0)
5892	S DA(1)=I BIFN,DA=IB PROCP
5893	"RTN","IBC U7",233,0)
5894	S DIE="^D GCR(399,"_ DA(1)_","" CP"","
5895	"RTN","IBC U7",234,0)
5896	S DR="71R eport Type ;72Report Transmissi on Method; 70Attachme nt Control Number"
5897	"RTN","IBC U7",235,0)
5898	D ^DIE
5899	"RTN","IBC U7",236,0)
5900	Q
5901	"RTN","IBC U7",237,0)
5902	;
5903	"RTN","IBC U7",238,0)
5904	NOCPROC(IB PROCSV) ; MRD;IB2.0 516 - Fun ction to d etermine i f procedur e is an
5905	"RTN","IBC U7",239,0)
5906	; "NOC". Returns ' 1' if "NOC " procedur e, otherwi se '0'.
5907	"RTN","IBC U7",240,0)
5908	;
5909	"RTN","IBC U7",241,0)
5910	N IBNOC,I BPROCEX,IB PROCIN,IBP ROCNM,IBX
5911	"RTN","IBC U7",242,0)
5912	S IBNOC=0
5913	"RTN","IBC U7",243,0)
5914	I $G(IBPR OCSV)="" G NOCPROCQ
5915	"RTN","IBC U7",244,0)
5916	S IBPROCI N=$P($P(IB PROCSV,U,2 ),";")
5917	"RTN","IBC U7",245,0)
5918	I IBPROCI N="" G NOC PROCQ
5919	"RTN","IBC U7",246,0)
5920	;
5921	"RTN","IBC U7",247,0)
5922	; If proc edure code ends in ' 99', quit with a '1' .
5923	"RTN","IBC U7",248,0)
5924	;
5925	"RTN","IBC U7",249,0)
5926	S IBPROCE X=$P($G(^I CPT(IBPROC IN,0)),U,1 )
5927	"RTN","IBC U7",250,0)
5928	I $E(IBPR OCEX,$L(IB PROCEX)-1, $L(IBPROCE X))=99 S I BNOC=1 G N OCPROCQ
5929	"RTN","IBC U7",251,0)
5930	;
5931	"RTN","IBC U7",252,0)
5932	; Pull pr ocedure na me, then c heck to se e if it co ntains one of the
5933	"RTN","IBC U7",253,0)
5934	; specifi ed strings .
5935	"RTN","IBC U7",254,0)
5936	;
5937	"RTN","IBC U7",255,0)
5938	S IBPROCN M=$P($G(^I CPT(IBPROC IN,0)),U,2 )
5939	"RTN","IBC U7",256,0)
5940	I IBPROCN M'="",$$NO C(IBPROCNM ) S IBNOC= 1 G NOCPRO CQ
5941	"RTN","IBC U7",257,0)
5942	;
5943	"RTN","IBC U7",258,0)
5944	S IBX=0
5945	"RTN","IBC U7",259,0)
5946	F S IBX= $O(^ICPT(I BPROCIN,"D ",IBX)) Q: 'IBX D I IBNOC=1 Q
5947	"RTN","IBC U7",260,0)
5948	. S IBTEX T=$G(^ICPT (IBPROCIN, "D",IBX,0) )
5949	"RTN","IBC U7",261,0)
5950	. I $G(^I CPT(IBPROC IN,"D",IBX +1,0))'="" S IBTEXT= IBTEXT_" " _$G(^ICPT( IBPROCIN," D",IBX+1,0 ))
5951	"RTN","IBC U7",262,0)
5952	. S IBNOC =$$NOC(IBT EXT)
5953	"RTN","IBC U7",263,0)
5954	. Q
5955	"RTN","IBC U7",264,0)
5956	;
5957	"RTN","IBC U7",265,0)
5958	NOCPROCQ ; Quit out.
5959	"RTN","IBC U7",266,0)
5960	Q IBNOC
5961	"RTN","IBC U7",267,0)
5962	;
5963	"RTN","IBC U7",268,0)
5964	NOC(IBTEXT ) ; Quit w ith '1' if IBTEXT co ntains one of the sp ecified st rings.
5965	"RTN","IBC U7",269,0)
5966	;
5967	"RTN","IBC U7",270,0)
5968	S IBTEXT= $TR(IBTEXT ,"abcdefgh ijklmnopqr stuvwxyz", "ABCDEFGHI JKLMNOPQRS TUVWXYZ")
5969	"RTN","IBC U7",271,0)
5970	;
5971	"RTN","IBC U7",272,0)
5972	I IBTEXT[ "NOT OTHER WISE" Q 1
5973	"RTN","IBC U7",273,0)
5974	I IBTEXT[ "NOT ELSEW HERE" Q 1
5975	"RTN","IBC U7",274,0)
5976	I IBTEXT[ "NOT LISTE D" Q 1
5977	"RTN","IBC U7",275,0)
5978	I IBTEXT[ "UNLISTED" Q 1
5979	"RTN","IBC U7",276,0)
5980	I IBTEXT[ "UNSPECIFI ED" Q 1
5981	"RTN","IBC U7",277,0)
5982	I IBTEXT[ "UNCLASSIF IED" Q 1
5983	"RTN","IBC U7",278,0)
5984	I IBTEXT[ "NON-SPECI FIED" Q 1
5985	"RTN","IBC U7",279,0)
5986	I IBTEXT[ "NOS " Q 1
5987	"RTN","IBC U7",280,0)
5988	I IBTEXT[ "NOS;" Q 1
5989	"RTN","IBC U7",281,0)
5990	I IBTEXT[ "NOS." Q 1
5991	"RTN","IBC U7",282,0)
5992	I IBTEXT[ "NOS," Q 1
5993	"RTN","IBC U7",283,0)
5994	I IBTEXT[ "NOS/" Q 1
5995	"RTN","IBC U7",284,0)
5996	I IBTEXT[ "(NOS)" Q 1
5997	"RTN","IBC U7",285,0)
5998	I IBTEXT[ "NOC " Q 1
5999	"RTN","IBC U7",286,0)
6000	I IBTEXT[ "NOC;" Q 1
6001	"RTN","IBC U7",287,0)
6002	I IBTEXT[ "NOC." Q 1
6003	"RTN","IBC U7",288,0)
6004	I IBTEXT[ "NOC," Q 1
6005	"RTN","IBC U7",289,0)
6006	I IBTEXT[ "NOC/" Q 1
6007	"RTN","IBC U7",290,0)
6008	I IBTEXT[ "(NOC)" Q 1
6009	"RTN","IBC U7",291,0)
6010	;
6011	"RTN","IBC U7",292,0)
6012	; Check i f last thr ee charcte rs are 'NO C' or 'NOS '.
6013	"RTN","IBC U7",293,0)
6014	;
6015	"RTN","IBC U7",294,0)
6016	S IBTEXT= $E(IBTEXT, $L(IBTEXT) -2,$L(IBTE XT))
6017	"RTN","IBC U7",295,0)
6018	I IBTEXT= "NOC" Q 1
6019	"RTN","IBC U7",296,0)
6020	I IBTEXT= "NOS" Q 1
6021	"RTN","IBC U7",297,0)
6022	;
6023	"RTN","IBC U7",298,0)
6024	Q 0
6025	"RTN","IBJ PS3")
6026	0^9^B12200 0376^B1117 22417
6027	"RTN","IBJ PS3",1,0)
6028	IBJPS3 ;BP /YMG - IB Site Param eters, Pay -To Provid er ;20-Oct -2008
6029	"RTN","IBJ PS3",2,0)
6030	;;2.0;INT EGRATED BI LLING;40 0,432,516, 577;21-M AR-94;Buil d 34
6031	"RTN","IBJ PS3",3,0)
6032	;;Per VA Directive 6402, this routine s hould not be modifie d.
6033	"RTN","IBJ PS3",4,0)
6034	;
6035	"RTN","IBJ PS3",5,0)
6036	; MRD;IB* 2.0*516 - Added logi c pertaini ng to TRIC ARE-Specif ic Pay-To
6037	"RTN","IBJ PS3",6,0)
6038	; Provide rs, which entailed a dding the parameter IBTCFLAG t o many
6039	"RTN","IBJ PS3",7,0)
6040	; procedu res here a nd in ^IBJ PS4.
6041	"RTN","IBJ PS3",8,0)
6042	;
6043	"RTN","IBJ PS3",9,0)
6044	EN(IBTCFLA G) ; -- ma in entry p oint for I BJP IB PAY -TO PROVID ERS
6045	"RTN","IBJ PS3",10,0)
6046	D EN^VALM ("IBJP IB "_$S(IBTCF LAG:"TRICA RE PAY-TO PROVS",1:" PAY-TO PRO VIDERS"))
6047	"RTN","IBJ PS3",11,0)
6048	Q
6049	"RTN","IBJ PS3",12,0)
6050	;
6051	"RTN","IBJ PS3",13,0)
6052	HDR(IBTCFL AG) ; -- h eader code
6053	"RTN","IBJ PS3",14,0)
6054	; Not set ting VALMH DR causes this tag t o be calle d upon ret urn from e very actio n,
6055	"RTN","IBJ PS3",15,0)
6056	; this is done to k eep VALMSG displayed at all ti mes, inste ad of the default me ssage on t he lower b ar.
6057	"RTN","IBJ PS3",16,0)
6058	S VALMSG= "* = Defau lt "_$S(IB TCFLAG:"TR ICARE ",1: "")_"Pay-t o provider "
6059	"RTN","IBJ PS3",17,0)
6060	Q
6061	"RTN","IBJ PS3",18,0)
6062	;
6063	"RTN","IBJ PS3",19,0)
6064	INIT(IBTCF LAG) ; -- init varia bles and l ist array
6065	"RTN","IBJ PS3",20,0)
6066	N IBCNT,I BLN,IBSTR, PIEN,PDATA ,IBNODE
6067	"RTN","IBJ PS3",21,0)
6068	S IBNODE= $$NODE^IBJ PS4(IBTCFL AG)
6069	"RTN","IBJ PS3",22,0)
6070	;
6071	"RTN","IBJ PS3",23,0)
6072	S (VALMCN T,IBCNT,IB LN)=0
6073	"RTN","IBJ PS3",24,0)
6074	S PIEN=0 F S PIEN= $O(^IBE(35 0.9,1,IBNO DE,PIEN)) Q:'PIEN D
6075	"RTN","IBJ PS3",25,0)
6076	.I $P($G( ^IBE(350.9 ,1,IBNODE, PIEN,0)),U ,5)'="" Q
6077	"RTN","IBJ PS3",26,0)
6078	.S PDATA= $$PTG(PIEN ,IBTCFLAG) ,IBCNT=IBC NT+1
6079	"RTN","IBJ PS3",27,0)
6080	.S IBSTR= $$SETSTR^V ALM1(IBCNT _".","",2, 4)
6081	"RTN","IBJ PS3",28,0)
6082	.I $$ISDF LT(PIEN,IB TCFLAG) S IBSTR=$$SE TSTR^VALM1 ("*",IBSTR ,7,1)
6083	"RTN","IBJ PS3",29,0)
6084	.S IBSTR= $$SETSTR^V ALM1("Name : "_$ P(PDATA,U) ,IBSTR,8,4 5)
6085	"RTN","IBJ PS3",30,0)
6086	.;S IBSTR =$$SETSTR^ VALM1("Sta te : "_$ P(PDATA,U, 8),IBSTR,5 4,25) ;JR A IB2.05 77 ';'
6087	"RTN","IBJ PS3",31,0)
6088	.S IBLN=$ $SET(IBLN, IBSTR)
6089	"RTN","IBJ PS3",32,0)
6090	.;S IBSTR =$$SETSTR^ VALM1("Add ress 1: "_ $P(PDATA,U ,5),"",8,4 5) ;JRA I B2.0577 ';'
6091	"RTN","IBJ PS3",33,0)
6092	.S IBSTR= $$SETSTR^V ALM1("Addr ess 1: "_$ P(PDATA,U, 5),"",8,66 ) ;JRA IB 2.0577 e xpand to 5 5 chars
6093	"RTN","IBJ PS3",34,0)
6094	.;S IBSTR =$$SETSTR^ VALM1("Zip Code: "_$ P(PDATA,U, 9),IBSTR,5 4,25) ;JR A IB2.05 77 ';'
6095	"RTN","IBJ PS3",35,0)
6096	.S IBLN=$ $SET(IBLN, IBSTR)
6097	"RTN","IBJ PS3",36,0)
6098	.;S IBSTR =$$SETSTR^ VALM1("Add ress 2: "_ $P(PDATA,U ,6),"",8,4 5) ;JRA I B2.0577 ';'
6099	"RTN","IBJ PS3",37,0)
6100	.S IBSTR= $$SETSTR^V ALM1("Addr ess 2: "_$ P(PDATA,U, 6),"",8,66 ) ;JRA IB 2.0577 e xpand to 5 5 chars
6101	"RTN","IBJ PS3",38,0)
6102	.;S IBSTR =$$SETSTR^ VALM1("Pho ne : "_$ P(PDATA,U, 4),IBSTR,5 4,25) ;JR A IB2.05 77 ';'
6103	"RTN","IBJ PS3",39,0)
6104	.S IBLN=$ $SET(IBLN, IBSTR)
6105	"RTN","IBJ PS3",40,0)
6106	.S IBSTR= $$SETSTR^V ALM1("City : "_$ P(PDATA,U, 7),"",8,45 )
6107	"RTN","IBJ PS3",41,0)
6108	.S IBLN=$ $SET(IBLN, IBSTR)
6109	"RTN","IBJ PS3",42,0)
6110	.;S IBSTR =$$SETSTR^ VALM1("Tax ID : "_$ P(PDATA,U, 3),IBSTR,5 4,25) ;JR A IB2.05 77 ';'
6111	"RTN","IBJ PS3",43,0)
6112	.;JRA Mov e State, Z ip Code, P hone and T ax ID unde r City to allow for longer add ress lines
6113	"RTN","IBJ PS3",44,0)
6114	.S IBSTR= $$SETSTR^V ALM1("Stat e : "_$ P(PDATA,U, 8),IBSTR,8 ,25) ;JRA IB2.057 7
6115	"RTN","IBJ PS3",45,0)
6116	.S IBLN=$ $SET(IBLN, IBSTR) ;J RA IB2.0 577
6117	"RTN","IBJ PS3",46,0)
6118	.S IBSTR= $$SETSTR^V ALM1("Zip Code : "_$ P(PDATA,U, 9),IBSTR,8 ,25) ;JRA IB2.057 7
6119	"RTN","IBJ PS3",47,0)
6120	.S IBLN=$ $SET(IBLN, IBSTR) ;J RA IB2.0 577
6121	"RTN","IBJ PS3",48,0)
6122	.S IBSTR= $$SETSTR^V ALM1("Phon e : "_$ P(PDATA,U, 4),IBSTR,8 ,25) ;JRA IB2.057 7
6123	"RTN","IBJ PS3",49,0)
6124	.S IBLN=$ $SET(IBLN, IBSTR) ;J RA IB2.0 577
6125	"RTN","IBJ PS3",50,0)
6126	.S IBSTR= $$SETSTR^V ALM1("Tax ID : "_$ P(PDATA,U, 3),IBSTR,8 ,25) ;JRA IB2.057 7
6127	"RTN","IBJ PS3",51,0)
6128	.S IBLN=$ $SET(IBLN, IBSTR),IBL N=$$SET(IB LN,"")
6129	"RTN","IBJ PS3",52,0)
6130	.S @VALMA R@("ZIDX", IBCNT,PIEN )=""
6131	"RTN","IBJ PS3",53,0)
6132	.Q
6133	"RTN","IBJ PS3",54,0)
6134	;
6135	"RTN","IBJ PS3",55,0)
6136	I 'IBLN S IBLN=$$SE T(IBLN,$$S ETSTR^VALM 1("No "_$S (IBTCFLAG: "TRICARE " ,1:"")_"Pa y-To Provi ders defin ed.","",13 ,40))
6137	"RTN","IBJ PS3",56,0)
6138	;
6139	"RTN","IBJ PS3",57,0)
6140	S VALMCNT =IBLN,VALM BG=1
6141	"RTN","IBJ PS3",58,0)
6142	Q
6143	"RTN","IBJ PS3",59,0)
6144	;
6145	"RTN","IBJ PS3",60,0)
6146	HELP ; -- help code
6147	"RTN","IBJ PS3",61,0)
6148	S X="?" D DISP^XQOR M1 W !!
6149	"RTN","IBJ PS3",62,0)
6150	Q
6151	"RTN","IBJ PS3",63,0)
6152	;
6153	"RTN","IBJ PS3",64,0)
6154	EXIT ; -- exit code
6155	"RTN","IBJ PS3",65,0)
6156	D CLEAR^V ALM1,CLEAN ^VALM10
6157	"RTN","IBJ PS3",66,0)
6158	Q
6159	"RTN","IBJ PS3",67,0)
6160	;
6161	"RTN","IBJ PS3",68,0)
6162	PRVADD(IBT CFLAG) ; a dd new pay -to provid er
6163	"RTN","IBJ PS3",69,0)
6164	N X,Y,DIC ,DA,DLAYGO ,DIE,DR,DI R,DIRUT,DU OUT,DTOUT, IEN,IBNODE
6165	"RTN","IBJ PS3",70,0)
6166	S IBNODE= $$NODE^IBJ PS4(IBTCFL AG)
6167	"RTN","IBJ PS3",71,0)
6168	D FULL^VA LM1
6169	"RTN","IBJ PS3",72,0)
6170	S VALMBCK ="R"
6171	"RTN","IBJ PS3",73,0)
6172	S DIC="^I BE(350.9,1 ,"_IBNODE_ ",",DIC(0) ="AELMQ",D A(1)=1,DLA YGO=350.9
6173	"RTN","IBJ PS3",74,0)
6174	S DIC("A" )="Enter " _$S(IBTCFL AG:"TRICAR E ",1:"")_ "Pay-to Pr ovider: "
6175	"RTN","IBJ PS3",75,0)
6176	D ^DIC S IEN=+Y
6177	"RTN","IBJ PS3",76,0)
6178	I IEN'>0 Q
6179	"RTN","IBJ PS3",77,0)
6180	D PRVEDIT 1
6181	"RTN","IBJ PS3",78,0)
6182	I $P($G(^ IBE(350.9, 1,IBNODE,I EN,0)),U,2 )="" D PRV DEL1
6183	"RTN","IBJ PS3",79,0)
6184	Q
6185	"RTN","IBJ PS3",80,0)
6186	;
6187	"RTN","IBJ PS3",81,0)
6188	PRVDEL(IBT CFLAG) ; d elete a pa y-to provi der
6189	"RTN","IBJ PS3",82,0)
6190	N DA,DR,D IE,X,Y,DIR ,DIRUT,DUO UT,DTOUT,I ,IEN,DIVS, DFLT,IBNOD E,IBDISP
6191	"RTN","IBJ PS3",83,0)
6192	S IBNODE= $$NODE^IBJ PS4(IBTCFL AG)
6193	"RTN","IBJ PS3",84,0)
6194	S IBDISP= $S(IBTCFLA G:"TRICARE ",1:"")_" Pay-To Pro vider"
6195	"RTN","IBJ PS3",85,0)
6196	S VALMBCK ="R"
6197	"RTN","IBJ PS3",86,0)
6198	D FULL^VA LM1
6199	"RTN","IBJ PS3",87,0)
6200	S IEN=$$S EL(IBTCFLA G) Q:'IEN
6201	"RTN","IBJ PS3",88,0)
6202	S DFLT=$$ ISDFLT(IEN ,IBTCFLAG)
6203	"RTN","IBJ PS3",89,0)
6204	I DFLT W !!,"WARNIN G: This is the defau lt "_IBDIS P_"."
6205	"RTN","IBJ PS3",90,0)
6206	D GETDIVS ^IBJPS4(IE N,.DIVS,IB TCFLAG)
6207	"RTN","IBJ PS3",91,0)
6208	I 'DFLT D
6209	"RTN","IBJ PS3",92,0)
6210	.W !!,"Th e followin g division s are curr ently asso ciated wit h this "_I BDISP_": "
6211	"RTN","IBJ PS3",93,0)
6212	.S I="" F S I=$O(D IVS(I)) Q: I="" W !, ?5,DIVS(I)
6213	"RTN","IBJ PS3",94,0)
6214	.W:'$D(DI VS) "None" ,! W !
6215	"RTN","IBJ PS3",95,0)
6216	.Q
6217	"RTN","IBJ PS3",96,0)
6218	S DIR("?" )="Enter Y es to dele te this "_ IBDISP_"."
6219	"RTN","IBJ PS3",97,0)
6220	S DIR("A" )="Delete "_IBDISP_" "_$P($G(^ IBE(350.9, 1,IBNODE,I EN,0)),U,2 )
6221	"RTN","IBJ PS3",98,0)
6222	S DIR(0)= "YO",DIR(" B")="NO" D ^DIR Q:'Y
6223	"RTN","IBJ PS3",99,0)
6224	I DFLT S DIE="^IBE( 350.9,",DA =1,DR=$S(I BTCFLAG:"1 1.04",1:"1 1.03")_"// //@" D ^DI E
6225	"RTN","IBJ PS3",100,0 )
6226	I $D(DIVS ) K DIK S DIK="^IBE( 350.9,1,"_ IBNODE_"," ,DA(1)=1,I ="" F S I =$O(DIVS(I )) Q:I="" S DA=I D ^DIK
6227	"RTN","IBJ PS3",101,0 )
6228	K DIK
6229	"RTN","IBJ PS3",102,0 )
6230	PRVDEL1 ;
6231	"RTN","IBJ PS3",103,0 )
6232	N DIK
6233	"RTN","IBJ PS3",104,0 )
6234	K DA
6235	"RTN","IBJ PS3",105,0 )
6236	S DIK="^I BE(350.9,1 ,"_IBNODE_ ","
6237	"RTN","IBJ PS3",106,0 )
6238	S DA(1)=1 ,DA=IEN
6239	"RTN","IBJ PS3",107,0 )
6240	D ^DIK
6241	"RTN","IBJ PS3",108,0 )
6242	D CLEAN^V ALM10,INIT (IBTCFLAG)
6243	"RTN","IBJ PS3",109,0 )
6244	Q
6245	"RTN","IBJ PS3",110,0 )
6246	;
6247	"RTN","IBJ PS3",111,0 )
6248	PRVEDIT(IB TCFLAG) ; edit exist ing pay-to provider
6249	"RTN","IBJ PS3",112,0 )
6250	N IEN,IBN ODE
6251	"RTN","IBJ PS3",113,0 )
6252	S IBNODE= $$NODE^IBJ PS4(IBTCFL AG)
6253	"RTN","IBJ PS3",114,0 )
6254	S VALMBCK ="R"
6255	"RTN","IBJ PS3",115,0 )
6256	D FULL^VA LM1
6257	"RTN","IBJ PS3",116,0 )
6258	S IEN=$$S EL(IBTCFLA G) Q:'IEN
6259	"RTN","IBJ PS3",117,0 )
6260	PRVEDIT1 ;
6261	"RTN","IBJ PS3",118,0 )
6262	N DIE,DA, DR,DIR,DIR UT,DUOUT,D TOUT,X,Y
6263	"RTN","IBJ PS3",119,0 )
6264	S DIE="^I BE(350.9,1 ,"_IBNODE_ ","
6265	"RTN","IBJ PS3",120,0 )
6266	S DA=IEN, DA(1)=1
6267	"RTN","IBJ PS3",121,0 )
6268	S DR=".02 T;1.01T;1. 02T;1.03T; 1.04T;1.05 T;.04T;.03 T;.05///@"
6269	"RTN","IBJ PS3",122,0 )
6270	D ^DIE
6271	"RTN","IBJ PS3",123,0 )
6272	S DIR("?" )="Enter Y es to make this entr y the defa ult "_$S(I BTCFLAG:"T RICARE ",1 :"")_"Pay- to Provide r."
6273	"RTN","IBJ PS3",124,0 )
6274	S DIR("A" )="Is this the defau lt "_$S(IB TCFLAG:"TR ICARE ",1: "")_"Pay-T o Provider "
6275	"RTN","IBJ PS3",125,0 )
6276	S DIR(0)= "YO"
6277	"RTN","IBJ PS3",126,0 )
6278	S DIR("B" )="YES" I $$GETDFLT( IBTCFLAG), '$$ISDFLT( IEN,IBTCFL AG) S DIR( "B")="NO"
6279	"RTN","IBJ PS3",127,0 )
6280	D ^DIR I Y K DA S D IE="^IBE(3 50.9,",DA= 1,DR=$S(IB TCFLAG:"11 .04",1:"11 .03")_"/// /"_IEN D ^ DIE
6281	"RTN","IBJ PS3",128,0 )
6282	D CLEAN^V ALM10,INIT (IBTCFLAG)
6283	"RTN","IBJ PS3",129,0 )
6284	Q
6285	"RTN","IBJ PS3",130,0 )
6286	;
6287	"RTN","IBJ PS3",131,0 )
6288	SET(IBLN,I BSTR) ; ad d a line t o display list
6289	"RTN","IBJ PS3",132,0 )
6290	; returns line numb er added
6291	"RTN","IBJ PS3",133,0 )
6292	S IBLN=IB LN+1 D SET ^VALM10(IB LN,IBSTR)
6293	"RTN","IBJ PS3",134,0 )
6294	Q IBLN
6295	"RTN","IBJ PS3",135,0 )
6296	;
6297	"RTN","IBJ PS3",136,0 )
6298	ISDFLT(PIE N,IBTCFLAG ) ; return s 1 if pro vider with ien PIEN is the def ault pay-t o provider , 0 otherw ise
6299	"RTN","IBJ PS3",137,0 )
6300	Q:PIEN="" 0
6301	"RTN","IBJ PS3",138,0 )
6302	Q $$GETDF LT(IBTCFLA G)=PIEN
6303	"RTN","IBJ PS3",139,0 )
6304	;
6305	"RTN","IBJ PS3",140,0 )
6306	GETDFLT(IB TCFLAG) ; returns ie n of defau lt pay-to provider
6307	"RTN","IBJ PS3",141,0 )
6308	Q $P($G(^ IBE(350.9, 1,11)),U,$ S(IBTCFLAG :4,1:3))
6309	"RTN","IBJ PS3",142,0 )
6310	;
6311	"RTN","IBJ PS3",143,0 )
6312	SEL(IBTCFL AG) ; sele ct pay-to provider
6313	"RTN","IBJ PS3",144,0 )
6314	; returns ien of se lected pay -to provid er, or 0 i f nothing is selecte d
6315	"RTN","IBJ PS3",145,0 )
6316	N DIR,IEN ,MAX,X,Y
6317	"RTN","IBJ PS3",146,0 )
6318	S IEN=0
6319	"RTN","IBJ PS3",147,0 )
6320	I VALMLST >4 D
6321	"RTN","IBJ PS3",148,0 )
6322	. ; there is at lea st one ent ry
6323	"RTN","IBJ PS3",149,0 )
6324	. S MAX=$ O(@VALMAR@ ("ZIDX","" ),-1) S:MA X=1 Y=1
6325	"RTN","IBJ PS3",150,0 )
6326	. I MAX>1 D
6327	"RTN","IBJ PS3",151,0 )
6328	. . S DIR ("A")="Sel ect "_$S(I BTCFLAG:"T RICARE ",1 :"")_"Pay- To Provide r (1-"_MAX _"): "
6329	"RTN","IBJ PS3",152,0 )
6330	. . S DIR (0)="NA^"_ 1_":"_MAX_ ":0"
6331	"RTN","IBJ PS3",153,0 )
6332	. . D ^DI R
6333	"RTN","IBJ PS3",154,0 )
6334	. . Q
6335	"RTN","IBJ PS3",155,0 )
6336	. S:+Y>0 IEN=$O(@VA LMAR@("ZID X",Y,""))
6337	"RTN","IBJ PS3",156,0 )
6338	. Q
6339	"RTN","IBJ PS3",157,0 )
6340	Q +IEN
6341	"RTN","IBJ PS3",158,0 )
6342	;
6343	"RTN","IBJ PS3",159,0 )
6344	PRVDATA(IB IFN) ; Ret urn a stri ng of Pay- To provide r informat ion in the following format
6345	"RTN","IBJ PS3",160,0 )
6346	; [1] na me
6347	"RTN","IBJ PS3",161,0 )
6348	; [2] np i
6349	"RTN","IBJ PS3",162,0 )
6350	; [3] ta x id#
6351	"RTN","IBJ PS3",163,0 )
6352	; [4] ph one#
6353	"RTN","IBJ PS3",164,0 )
6354	; [5] st reet 1
6355	"RTN","IBJ PS3",165,0 )
6356	; [6] st reet 2
6357	"RTN","IBJ PS3",166,0 )
6358	; [7] ci ty
6359	"RTN","IBJ PS3",167,0 )
6360	; [8] st ate abbrev iation
6361	"RTN","IBJ PS3",168,0 )
6362	; [9] zi p
6363	"RTN","IBJ PS3",169,0 )
6364	; [10] li st of IB e rror messa ges if any of this d ata is mis sing in IB XX1;IBXX2; IBXX3;IBXX 4; format
6365	"RTN","IBJ PS3",170,0 )
6366	; [11] In stitution (File 4) i en
6367	"RTN","IBJ PS3",171,0 )
6368	;
6369	"RTN","IBJ PS3",172,0 )
6370	; **NOTE: pieces 1 2,13,14 ar e added to this stri ng in outp ut formatt er data el ement #162 4 for PRV1 -1.5 for P RV1
6371	"RTN","IBJ PS3",173,0 )
6372	; pieces 2,3,5. If pieces ar e added he re to this string, t hen adjust the code in PRV1-1. 5,2,3,5 ac cordingly.
6373	"RTN","IBJ PS3",174,0 )
6374	;
6375	"RTN","IBJ PS3",175,0 )
6376	N DATA,IB 0,EVDT,IBD IV,INST,PI EN,IBER,IB TCFLAG
6377	"RTN","IBJ PS3",176,0 )
6378	S DATA="" ,IBER=""
6379	"RTN","IBJ PS3",177,0 )
6380	;
6381	"RTN","IBJ PS3",178,0 )
6382	S IBTCFLA G=$$TRICAR E^IBJPS4(I BIFN) ; Se t IBTCFLAG to '1' if TRICARE c laim, othe rwise '0'.
6383	"RTN","IBJ PS3",179,0 )
6384	;
6385	"RTN","IBJ PS3",180,0 )
6386	S IB0=$G( ^DGCR(399, IBIFN,0))
6387	"RTN","IBJ PS3",181,0 )
6388	S EVDT=$P (IB0,U,3) ; event date on claim
6389	"RTN","IBJ PS3",182,0 )
6390	I 'EVDT S EVDT=DT
6391	"RTN","IBJ PS3",183,0 )
6392	S IBDIV=+ $P(IB0,U,2 2) ; division o n claim
6393	"RTN","IBJ PS3",184,0 )
6394	I 'IBDIV S IBDIV=$$ PRIM^VASIT E(EVDT)
6395	"RTN","IBJ PS3",185,0 )
6396	I IBDIV'> 0 S IBDIV= $$PRIM^VAS ITE()
6397	"RTN","IBJ PS3",186,0 )
6398	I IBDIV'> 0 G PRVDAT X ; get out if no divisi on
6399	"RTN","IBJ PS3",187,0 )
6400	S INST=+$ $SITE^VASI TE(EVDT,IB DIV) ; inst file 4 pointer
6401	"RTN","IBJ PS3",188,0 )
6402	I INST'>0 S INST=+$ $SITE^VASI TE(DT,IBDI V)
6403	"RTN","IBJ PS3",189,0 )
6404	I INST'>0 S INST=+$ $SITE^VASI TE()
6405	"RTN","IBJ PS3",190,0 )
6406	I INST'>0 G PRVDATX ; get out if no instit ution
6407	"RTN","IBJ PS3",191,0 )
6408	;
6409	"RTN","IBJ PS3",192,0 )
6410	; check t o see if t his instit ution exis ts as a se parate Pay -To Provid er subfile entry
6411	"RTN","IBJ PS3",193,0 )
6412	S PIEN=+$ O(^IBE(350 .9,1,$S(IB TCFLAG:29, 1:19),"B", INST,""))
6413	"RTN","IBJ PS3",194,0 )
6414	;
6415	"RTN","IBJ PS3",195,0 )
6416	I 'PIEN D G PRVDAT X ; t his instit ution does not exist in 350.90 04/350.929 .
6417	"RTN","IBJ PS3",196,0 )
6418	. ; check to see if the defau lt Pay-To provider i nformation is define d (350.9;1 1.03/11.04 )
6419	"RTN","IBJ PS3",197,0 )
6420	. S PIEN= +$P($G(^IB E(350.9,1, 11)),U,$S( IBTCFLAG:4 ,1:3)) Q:' PIEN
6421	"RTN","IBJ PS3",198,0 )
6422	. S DATA= $$PTG(PIEN ,IBTCFLAG)
6423	"RTN","IBJ PS3",199,0 )
6424	. Q
6425	"RTN","IBJ PS3",200,0 )
6426	;
6427	"RTN","IBJ PS3",201,0 )
6428	; here PI EN exists and the in stitution pointer wa s found in the 350.9 004 subfil e
6429	"RTN","IBJ PS3",202,0 )
6430	; find pa rent pay-t o provider
6431	"RTN","IBJ PS3",203,0 )
6432	S PIEN=$$ GETPROV^IB JPS4(PIEN, IBTCFLAG) S:PIEN DAT A=$$PTG(PI EN,IBTCFLA G)
6433	"RTN","IBJ PS3",204,0 )
6434	;
6435	"RTN","IBJ PS3",205,0 )
6436	PRVDATX ;
6437	"RTN","IBJ PS3",206,0 )
6438	I DATA="" S IBER=IB ER_"IB177; ",$P(DATA, U,10)=IBER
6439	"RTN","IBJ PS3",207,0 )
6440	Q DATA
6441	"RTN","IBJ PS3",208,0 )
6442	;
6443	"RTN","IBJ PS3",209,0 )
6444	PTG(PIEN,I BTCFLAG) ; gather pa y-to provi der info
6445	"RTN","IBJ PS3",210,0 )
6446	N N0,N1,I BORG,NPI,S TIEN,STATE ,Z,IBER,IB NODE
6447	"RTN","IBJ PS3",211,0 )
6448	;
6449	"RTN","IBJ PS3",212,0 )
6450	S IBNODE= $$NODE^IBJ PS4(+$G(IB TCFLAG))
6451	"RTN","IBJ PS3",213,0 )
6452	;
6453	"RTN","IBJ PS3",214,0 )
6454	S Z="",IB ER="",PIEN =+$G(PIEN)
6455	"RTN","IBJ PS3",215,0 )
6456	;
6457	"RTN","IBJ PS3",216,0 )
6458	I '$D(^IB E(350.9,1, IBNODE,PIE N)) S IBER =IBER_"IB1 77;",$P(Z, U,10)=IBER G PTGX
6459	"RTN","IBJ PS3",217,0 )
6460	S N0=$G(^ IBE(350.9, 1,IBNODE,P IEN,0))
6461	"RTN","IBJ PS3",218,0 )
6462	S N1=$G(^ IBE(350.9, 1,IBNODE,P IEN,1))
6463	"RTN","IBJ PS3",219,0 )
6464	;
6465	"RTN","IBJ PS3",220,0 )
6466	; get the NPI# from the Insti tution fil e
6467	"RTN","IBJ PS3",221,0 )
6468	S IBORG=+ $P(N0,U,1) ,NPI=""
6469	"RTN","IBJ PS3",222,0 )
6470	I IBORG S NPI=$P($$ NPI^XUSNPI ("Organiza tion_ID",I BORG),U,1)
6471	"RTN","IBJ PS3",223,0 )
6472	;
6473	"RTN","IBJ PS3",224,0 )
6474	; get the state abb reviation
6475	"RTN","IBJ PS3",225,0 )
6476	S STIEN=+ $P(N1,U,4) ,STATE=""
6477	"RTN","IBJ PS3",226,0 )
6478	I STIEN S STATE=$$G ET1^DIQ(5, STIEN_",", 1)
6479	"RTN","IBJ PS3",227,0 )
6480	;
6481	"RTN","IBJ PS3",228,0 )
6482	; check f or missing data
6483	"RTN","IBJ PS3",229,0 )
6484	I '$L($P( N0,U,2)) S IBER=IBER _"IB178;" ; miss ing name
6485	"RTN","IBJ PS3",230,0 )
6486	I NPI'>0 S IBER=IBE R_"IB179;" ; miss ing npi
6487	"RTN","IBJ PS3",231,0 )
6488	; Patch 4 32 enh5: The IB sys tem shall no longer prevent us ers from a uthorizing (fatal er ror messag e) a claim because t he system can not fi nd the hum an provide rs SSN or EIN
6489	"RTN","IBJ PS3",232,0 )
6490	;I '$L($P (N0,U,3)) S IBER=IBE R_"IB180;" ; mis sing tax I D
6491	"RTN","IBJ PS3",233,0 )
6492	I '$L($P( N1,U,1))!' $L($P(N1,U ,3))!'$L(S TATE)!'$L( $P(N1,U,5) ) S IBER=I BER_"IB181 ;" ; m issing add ress part( s)
6493	"RTN","IBJ PS3",234,0 )
6494	;
6495	"RTN","IBJ PS3",235,0 )
6496	S Z=$P(N0 ,U,2)_U_NP I_U_$P(N0, U,3)_U_$P( N0,U,4)_U_ $P(N1,U,1) _U_$P(N1,U ,2)_U_$P(N 1,U,3)_U_S TATE_U_$P( N1,U,5)_U_ IBER_U_IBO RG
6497	"RTN","IBJ PS3",236,0 )
6498	PTGX ;
6499	"RTN","IBJ PS3",237,0 )
6500	Q Z
6501	"RTN","IBJ PS3",238,0 )
6502	;
6503	"RTN","IBJ PS3",239,0 )
6504	PRVPHONE(I BIFN) ; Re turn Pay-t o provider phone# fo r a given claim
6505	"RTN","IBJ PS3",240,0 )
6506	; IBIFN - internal claim# (op tional par ameter)
6507	"RTN","IBJ PS3",241,0 )
6508	; If IBIF N is not p assed in, then the p hone# from the defau lt pay-to provider e ntry will be returne d.
6509	"RTN","IBJ PS3",242,0 )
6510	; For exa mple, AR o ption 'EDI Lockbox 3 rd Party E xceptions' needs the phone# fo r the proc ess of tra nsfering a n
6511	"RTN","IBJ PS3",243,0 )
6512	; EEOB to another s ite, but t he claim# is not ava ilable to this proce ss.
6513	"RTN","IBJ PS3",244,0 )
6514	N PTPP,PI EN
6515	"RTN","IBJ PS3",245,0 )
6516	S PTPP=""
6517	"RTN","IBJ PS3",246,0 )
6518	I +$G(IBI FN) S PTPP =$P($$PRVD ATA(IBIFN) ,U,4) G PR VPHNX
6519	"RTN","IBJ PS3",247,0 )
6520	;
6521	"RTN","IBJ PS3",248,0 )
6522	S PIEN=+$ P($G(^IBE( 350.9,1,11 )),U,3) I 'PIEN G PR VPHNX ; no claim#, default p ay-to prov ider
6523	"RTN","IBJ PS3",249,0 )
6524	S PTPP=$P ($$PTG(PIE N),U,4) ; phone#
6525	"RTN","IBJ PS3",250,0 )
6526	;
6527	"RTN","IBJ PS3",251,0 )
6528	PRVPHNX ;
6529	"RTN","IBJ PS3",252,0 )
6530	Q PTPP
6531	"RTN","IBJ PS3",253,0 )
6532	;
6533	"RTN","IBJ PS3",254,0 )
6534	DEF(INST,D A,IBTCFLAG ) ; This p rocedure i s called b y new styl e x-ref in
6535	"RTN","IBJ PS3",255,0 )
6536	; order t o default name and a ddress fie lds.
6537	"RTN","IBJ PS3",256,0 )
6538	; INST - IEN to fil e #4, Inst itution. This is th e value in the .01
6539	"RTN","IBJ PS3",257,0 )
6540	; fi eld of the Pay-to or TRICARE P ay-to Prov iders sub- fil.
6541	"RTN","IBJ PS3",258,0 )
6542	; DA - DA array as passed in from FileM an. DA(1) should eq ual 1 sinc e
6543	"RTN","IBJ PS3",259,0 )
6544	; th is is the IB site pa rams and t here is on ly 1 entry . DA shou ld
6545	"RTN","IBJ PS3",260,0 )
6546	; eq ual the IE N to the p ay-to prov ider multi ple entry
6547	"RTN","IBJ PS3",261,0 )
6548	; This pr ocedure is called on ly if a ne w institut ion is bei ng added t o
6549	"RTN","IBJ PS3",262,0 )
6550	; the sub -file or a n entry in the sub-f ile is bei ng changed from one
6551	"RTN","IBJ PS3",263,0 )
6552	; institu tion to an other.
6553	"RTN","IBJ PS3",264,0 )
6554	;
6555	"RTN","IBJ PS3",265,0 )
6556	NEW NAD,I ENS,ST,STI EN,IBTAXID ,IBFILE
6557	"RTN","IBJ PS3",266,0 )
6558	;
6559	"RTN","IBJ PS3",267,0 )
6560	I '$G(INS T) G DEFX
6561	"RTN","IBJ PS3",268,0 )
6562	;
6563	"RTN","IBJ PS3",269,0 )
6564	I IBTCFLA G S IBFILE =350.929
6565	"RTN","IBJ PS3",270,0 )
6566	E S IBFI LE=350.900 4
6567	"RTN","IBJ PS3",271,0 )
6568	;
6569	"RTN","IBJ PS3",272,0 )
6570	S ST=$$WH AT^XUAF4(I NST,.02) ; full st ate name
6571	"RTN","IBJ PS3",273,0 )
6572	S STIEN=$ $FIND1^DIC (5,,"BX",S T,"B") ; state i en
6573	"RTN","IBJ PS3",274,0 )
6574	;
6575	"RTN","IBJ PS3",275,0 )
6576	; if the selected p ay-to prov ider insti tution is the same a s the main
6577	"RTN","IBJ PS3",276,0 )
6578	; facilit y name fie ld from th e IB site parameters , then als o default
6579	"RTN","IBJ PS3",277,0 )
6580	; the fed eral tax I D# from th e IB site parameters into the pay-to
6581	"RTN","IBJ PS3",278,0 )
6582	; provide r tax ID# field.
6583	"RTN","IBJ PS3",279,0 )
6584	S IBTAXID =""
6585	"RTN","IBJ PS3",280,0 )
6586	I INST=$P ($G(^IBE(3 50.9,1,0)) ,U,2) S IB TAXID=$P($ G(^IBE(350 .9,1,1)),U ,5)
6587	"RTN","IBJ PS3",281,0 )
6588	;
6589	"RTN","IBJ PS3",282,0 )
6590	S IENS=DA _",1,"
6591	"RTN","IBJ PS3",283,0 )
6592	S NAD(IBF ILE,IENS,. 02)=$$WHAT ^XUAF4(INS T,100) ; officia l VA name
6593	"RTN","IBJ PS3",284,0 )
6594	S NAD(IBF ILE,IENS,. 03)=IBTAXI D ; tax#
6595	"RTN","IBJ PS3",285,0 )
6596	S NAD(IBF ILE,IENS,. 04)="" ; phone# - blank it out
6597	"RTN","IBJ PS3",286,0 )
6598	S NAD(IBF ILE,IENS,. 05)="" ; parent - blank it out
6599	"RTN","IBJ PS3",287,0 )
6600	S NAD(IBF ILE,IENS,1 .01)=$$WHA T^XUAF4(IN ST,1.01) ; address line 1
6601	"RTN","IBJ PS3",288,0 )
6602	S NAD(IBF ILE,IENS,1 .02)=$$WHA T^XUAF4(IN ST,1.02) ; address line 2
6603	"RTN","IBJ PS3",289,0 )
6604	S NAD(IBF ILE,IENS,1 .03)=$$WHA T^XUAF4(IN ST,1.03) ; city
6605	"RTN","IBJ PS3",290,0 )
6606	I STIEN S NAD(IBFIL E,IENS,1.0 4)=STIEN ; state
6607	"RTN","IBJ PS3",291,0 )
6608	S NAD(IBF ILE,IENS,1 .05)=$$WHA T^XUAF4(IN ST,1.04) ; zip
6609	"RTN","IBJ PS3",292,0 )
6610	D FILE^DI E(,"NAD")
6611	"RTN","IBJ PS3",293,0 )
6612	DEFX ;
6613	"RTN","IBJ PS3",294,0 )
6614	Q
6615	"RTN","IBJ PS3",295,0 )
6616	;
6617	"RTN","IBJ PS3",296,0 )
6618	DIFF(IBIFN ,EDI) ; Th is functio n will det ermine if there are any differ ences betw een
6619	"RTN","IBJ PS3",297,0 )
6620	; the Bil ling Provi der name a nd address and the P ay-to Prov ider name and addres s.
6621	"RTN","IBJ PS3",298,0 )
6622	; When th ese two ar e the same , then the Pay-to Pr ovider inf ormation i s
6623	"RTN","IBJ PS3",299,0 )
6624	; suppres sed and is not print ed or tran smitted.
6625	"RTN","IBJ PS3",300,0 )
6626	; This fu nction ret urns a 1 i f differen ces are fo und, and 0 if they a re the sam e.
6627	"RTN","IBJ PS3",301,0 )
6628	;
6629	"RTN","IBJ PS3",302,0 )
6630	; EDI=1 i f this is being call ed for the electroni c claim tr ansmission
6631	"RTN","IBJ PS3",303,0 )
6632	; EDI=0 i f this is being call ed for the printed U B-04 claim form
6633	"RTN","IBJ PS3",304,0 )
6634	;
6635	"RTN","IBJ PS3",305,0 )
6636	N BPZ,PTP ,DIFF,BPNA ME,BPAD1,B PAD2,BPCIT Y,BPST,BPZ IP,IBZ
6637	"RTN","IBJ PS3",306,0 )
6638	S DIFF=0, EDI=+$G(ED I)
6639	"RTN","IBJ PS3",307,0 )
6640	S BPZ=+$$ B^IBCEF79( IBIFN) ; billing pr ovider ien to file 4
6641	"RTN","IBJ PS3",308,0 )
6642	S PTP=$$U P^XLFSTR($ $PRVDATA(I BIFN)) ; pay-to pro vider info rmation
6643	"RTN","IBJ PS3",309,0 )
6644	;
6645	"RTN","IBJ PS3",310,0 )
6646	; for EDI claims, u se the GET BP utility to get th e billing provider d ata
6647	"RTN","IBJ PS3",311,0 )
6648	I EDI D
6649	"RTN","IBJ PS3",312,0 )
6650	. D GETBP ^IBCEF79(I BIFN,"",BP Z,"DIFF",. IBZ)
6651	"RTN","IBJ PS3",313,0 )
6652	. S BPNAM E=$$UP^XLF STR($G(IBZ ("DIFF","N AME")))
6653	"RTN","IBJ PS3",314,0 )
6654	. S BPAD1 =$$UP^XLFS TR($G(IBZ( "DIFF","AD DR1")))
6655	"RTN","IBJ PS3",315,0 )
6656	. S BPAD2 =$$UP^XLFS TR($G(IBZ( "DIFF","AD DR2")))
6657	"RTN","IBJ PS3",316,0 )
6658	. S BPCIT Y=$$UP^XLF STR($G(IBZ ("DIFF","C ITY")))
6659	"RTN","IBJ PS3",317,0 )
6660	. S BPST= $$UP^XLFST R($G(IBZ(" DIFF","ST" )))
6661	"RTN","IBJ PS3",318,0 )
6662	. S BPZIP =$$NOPUNCT ^IBCEF($$U P^XLFSTR($ G(IBZ("DIF F","ZIP")) ))
6663	"RTN","IBJ PS3",319,0 )
6664	. Q
6665	"RTN","IBJ PS3",320,0 )
6666	;
6667	"RTN","IBJ PS3",321,0 )
6668	; for pri nted UB cl aims, use the Instit ution file for FL-1 data
6669	"RTN","IBJ PS3",322,0 )
6670	I 'EDI D
6671	"RTN","IBJ PS3",323,0 )
6672	. S BPNAM E=$$UP^XLF STR($$GETF AC^IBCEP8( BPZ,0,0))
6673	"RTN","IBJ PS3",324,0 )
6674	. S BPAD1 =$$UP^XLFS TR($$GETFA C^IBCEP8(B PZ,0,1))
6675	"RTN","IBJ PS3",325,0 )
6676	. S BPAD2 =$$UP^XLFS TR($$GETFA C^IBCEP8(B PZ,0,2))
6677	"RTN","IBJ PS3",326,0 )
6678	. S BPCIT Y=$$UP^XLF STR($$GETF AC^IBCEP8( BPZ,0,"3C" ))
6679	"RTN","IBJ PS3",327,0 )
6680	. S BPST= $$UP^XLFST R($$GETFAC ^IBCEP8(BP Z,0,"3S"))
6681	"RTN","IBJ PS3",328,0 )
6682	. S BPZIP =$$NOPUNCT ^IBCEF($$U P^XLFSTR($ $GETFAC^IB CEP8(BPZ,0 ,"3Z")))
6683	"RTN","IBJ PS3",329,0 )
6684	. Q
6685	"RTN","IBJ PS3",330,0 )
6686	;
6687	"RTN","IBJ PS3",331,0 )
6688	I BPNAME' =$P(PTP,U, 1) S DIFF= 1 G DIFFX
6689	"RTN","IBJ PS3",332,0 )
6690	I BPAD1'= $P(PTP,U,5 ) S DIFF=1 G DIFFX
6691	"RTN","IBJ PS3",333,0 )
6692	I BPAD2'= $P(PTP,U,6 ) S DIFF=1 G DIFFX
6693	"RTN","IBJ PS3",334,0 )
6694	I BPCITY' =$P(PTP,U, 7) S DIFF= 1 G DIFFX
6695	"RTN","IBJ PS3",335,0 )
6696	I BPST'=$ P(PTP,U,8) S DIFF=1 G DIFFX
6697	"RTN","IBJ PS3",336,0 )
6698	I BPZIP'= $$NOPUNCT^ IBCEF($P(P TP,U,9)) S DIFF=1 G DIFFX
6699	"RTN","IBJ PS3",337,0 )
6700	DIFFX ;
6701	"RTN","IBJ PS3",338,0 )
6702	Q DIFF
6703	"RTN","IBJ PS3",339,0 )
6704	;
6705	"RTN","IBJ PS3",340,0 )
6706	MAINPRV(IB TCFLAG) ; Return Pay -To provid er informa tion for m ain VAMC
6707	"RTN","IBJ PS3",341,0 )
6708	N DATA,IB ER,IEN4,PI EN,IBNODE
6709	"RTN","IBJ PS3",342,0 )
6710	S IBNODE= $$NODE^IBJ PS4(IBTCFL AG)
6711	"RTN","IBJ PS3",343,0 )
6712	S (DATA,I BER)="",IE N4=+$$SITE ^VASITE I 'IEN4 G MA INPRVX
6713	"RTN","IBJ PS3",344,0 )
6714	S PIEN=$O (^IBE(350. 9,1,IBNODE ,"B",IEN4, "")) I 'PI EN G MAINP RVX
6715	"RTN","IBJ PS3",345,0 )
6716	I $P($G(^ IBE(350.9, 1,IBNODE,P IEN,0)),U, 5)'="" G M AINPRVX ; if this sub-entry is not a p ay-to prov ider, then get out
6717	"RTN","IBJ PS3",346,0 )
6718	S DATA=$$ PTG(PIEN,I BTCFLAG)
6719	"RTN","IBJ PS3",347,0 )
6720	MAINPRVX ;
6721	"RTN","IBJ PS3",348,0 )
6722	I DATA="" S IBER=IB ER_"IB177; ",$P(DATA, U,10)=IBER
6723	"RTN","IBJ PS3",349,0 )
6724	Q DATA
6725	"RTN","IBJ PS3",350,0 )
6726	;
6727	"RTN","IBY 577PO")
6728	0^^B600205 9^n/a
6729	"RTN","IBY 577PO",1,0 )
6730	IBY577PO ; ALB/VD - P OST-INSTAL L FOR IB2 .0577 ;22 -FEB-2017
6731	"RTN","IBY 577PO",2,0 )
6732	;;2.0;INT EGRATED BI LLING;57 7;21-MAR -94;Build 34
6733	"RTN","IBY 577PO",3,0 )
6734	;;Per VA Directive 6402, this routine s hould not be modifie d.
6735	"RTN","IBY 577PO",4,0 )
6736	;
6737	"RTN","IBY 577PO",5,0 )
6738	;
6739	"RTN","IBY 577PO",6,0 )
6740	S IBA(2)= "IB2577 Post-Insta ll...",(IB A(1),IBA(3 ))=" " D M ES^XPDUTL( .IBA) K IB A
6741	"RTN","IBY 577PO",7,0 )
6742	D RIT
6743	"RTN","IBY 577PO",8,0 )
6744	D:$$PROD^ XUPROD(1) EMAIL
6745	"RTN","IBY 577PO",9,0 )
6746	S IBA(2)= "IB2577 Post-Insta ll Complet e.",(IBA(1 ),IBA(3))= " " D MES^ XPDUTL(.IB A) K IBA
6747	"RTN","IBY 577PO",10, 0)
6748	Q
6749	"RTN","IBY 577PO",11, 0)
6750	;
6751	"RTN","IBY 577PO",12, 0)
6752	RIT ; Reco mpile bill ing screen templates due to ch anges to F ield #399, .21 cross- references .
6753	"RTN","IBY 577PO",13, 0)
6754	N X,Y,DMA X,IBN
6755	"RTN","IBY 577PO",14, 0)
6756	D MES^XPD UTL(">> Re compiling Input Temp lates for Billing Sc reens ..." )
6757	"RTN","IBY 577PO",15, 0)
6758	F IBN=1:1 :10,"102", "10H" D
6759	"RTN","IBY 577PO",16, 0)
6760	.S X="IBX S"_$S(IBN= 10:"A",IBN ="102":"A2 ",IBN="10H ":"AH",1:I BN),Y=$$FI ND1^DIC(.4 02,,"X","I B SCREEN"_ IBN,"B"),D MAX=$$ROUS IZE^DILF
6761	"RTN","IBY 577PO",17, 0)
6762	.I Y D EN ^DIEZ
6763	"RTN","IBY 577PO",18, 0)
6764	D MES^XPD UTL(" Recompile Completed. ")
6765	"RTN","IBY 577PO",19, 0)
6766	Q
6767	"RTN","IBY 577PO",20, 0)
6768	;
6769	"RTN","IBY 577PO",21, 0)
6770	EMAIL ; Se nd an emai l message to MCCF De veloper Te am identif ying which forms [#3 53] are be ing used b y this sit e.
6771	"RTN","IBY 577PO",22, 0)
6772	N SITE,SU BJ,MSG,XMT O,LN,GLO,G LB
6773	"RTN","IBY 577PO",23, 0)
6774	D BMES^XP DUTL(">> C hecking to see which Forms are in Use at this Site ...")
6775	"RTN","IBY 577PO",24, 0)
6776	D MES^XPD UTL("----- --------")
6777	"RTN","IBY 577PO",25, 0)
6778	D MES^XPD UTL("Sendi ng email n otificatio n to MCCF Developers ... ")
6779	"RTN","IBY 577PO",26, 0)
6780	S SITE=$$ SITE^VASIT E
6781	"RTN","IBY 577PO",27, 0)
6782	S SUBJ="F orm #7 "_$ S($D(^IBE( 353,7)):"* IS*",1:" i s not")_" used at St ation# "_$ P(SITE,U,3 )_" - "_$P (SITE,U,2)
6783	"RTN","IBY 577PO",28, 0)
6784	S SUBJ=$E (SUBJ,1,65 )
6785	"RTN","IBY 577PO",29, 0)
6786	S MSG(1)= "The follo wing site: "
6787	"RTN","IBY 577PO",30, 0)
6788	S MSG(2)= ""
6789	"RTN","IBY 577PO",31, 0)
6790	S MSG(3)= " N ame: "_$P( SITE,U,2)
6791	"RTN","IBY 577PO",32, 0)
6792	S MSG(4)= " Stati on#: "_$P( SITE,U,3)
6793	"RTN","IBY 577PO",33, 0)
6794	S MSG(5)= " Dom ain: "_$G( ^XMB("NETN AME"))
6795	"RTN","IBY 577PO",34, 0)
6796	S MSG(6)= " Date/T ime: "_$$F MTE^XLFDT( $$NOW^XLFD T,"5ZPM")
6797	"RTN","IBY 577PO",35, 0)
6798	S MSG(7)= ""
6799	"RTN","IBY 577PO",36, 0)
6800	S MSG(8)= "uses the following Forms:"
6801	"RTN","IBY 577PO",37, 0)
6802	S MSG(9)= ""
6803	"RTN","IBY 577PO",38, 0)
6804	S LN=9,II =0
6805	"RTN","IBY 577PO",39, 0)
6806	F S II=$ O(^IBE(353 ,II)) Q:'+ II D
6807	"RTN","IBY 577PO",40, 0)
6808	. S LN=LN +1,MSG(LN) =" Form # "_II_" - for '"_$P( $G(^IBE(35 3,II,0))," ^",1)_"'"
6809	"RTN","IBY 577PO",41, 0)
6810	S LN=LN+1 ,MSG(LN)=" "
6811	"RTN","IBY 577PO",42, 0)
6812	S LN=LN+1 ,MSG(LN)=" ---------- -----"
6813	"RTN","IBY 577PO",43, 0)
6814	;
6815	"RTN","IBY 577PO",44, 0)
6816	S XMTO(" PII ")=""
6817	"RTN","IBY 577PO",45, 0)
6818	S XMTO(" PII ")=""
6819	"RTN","IBY 577PO",46, 0)
6820	S XMTO(" PII ")=""
6821	"RTN","IBY 577PO",47, 0)
6822	;
6823	"RTN","IBY 577PO",48, 0)
6824	D SENDMSG ^XMXAPI(DU Z,SUBJ,"MS G",.XMTO)
6825	"RTN","IBY 577PO",49, 0)
6826	;
6827	"RTN","IBY 577PO",50, 0)
6828	EMAILX ;
6829	"RTN","IBY 577PO",51, 0)
6830	D MES^XPD UTL(" Done .")
6831	"RTN","IBY 577PO",52, 0)
6832	D CLEAN^D ILF
6833	"RTN","IBY 577PO",53, 0)
6834	Q
6835	"RTN","IBY 577PO",54, 0)
6836	;
6837	"RTN","IBY 577PR")
6838	0^^B519634 7^n/a
6839	"RTN","IBY 577PR",1,0 )
6840	IBY577PR ; AITC/VD - Pre-Instal lation for IB patch 577 ; 4/06 /17 4:33pm
6841	"RTN","IBY 577PR",2,0 )
6842	;;2.0;INT EGRATED BI LLING;57 7;21-MAR -94;Build 34
6843	"RTN","IBY 577PR",3,0 )
6844	;;Per VA Directive 6402, this routine s hould not be modifie d.
6845	"RTN","IBY 577PR",4,0 )
6846	;
6847	"RTN","IBY 577PR",5,0 )
6848	; delete all output formatter (O.F.) da ta element s included in build
6849	"RTN","IBY 577PR",6,0 )
6850	D DELOF
6851	"RTN","IBY 577PR",7,0 )
6852	Q
6853	"RTN","IBY 577PR",8,0 )
6854	;
6855	"RTN","IBY 577PR",9,0 )
6856	INC3508(Y) ; functio n to deter mine if en try in IB ERROR file (350.8) s hould be i ncluded in the build
6857	"RTN","IBY 577PR",10, 0)
6858	; Y - ien to file
6859	"RTN","IBY 577PR",11, 0)
6860	N DATA,EN TRY,LN,OK, TAG
6861	"RTN","IBY 577PR",12, 0)
6862	S OK=0,EN TRY=U_$P($ G(^IBE(350 .8,Y,0)),U ,3)_U
6863	"RTN","IBY 577PR",13, 0)
6864	F LN=2:1 S TAG="ENT 3508+"_LN, DATA=$P($T (@TAG),";; ",2) Q:DAT A="" I $F (DATA,ENTR Y) S OK=1 Q
6865	"RTN","IBY 577PR",14, 0)
6866	Q OK
6867	"RTN","IBY 577PR",15, 0)
6868	;
6869	"RTN","IBY 577PR",16, 0)
6870	INCLUDE(FI LE,Y) ; fu nction to determine if O.F. en try should be includ ed in the build
6871	"RTN","IBY 577PR",17, 0)
6872	; FILE=5, 6,7 indica ting file 364.x
6873	"RTN","IBY 577PR",18, 0)
6874	; Y=ien t o file
6875	"RTN","IBY 577PR",19, 0)
6876	NEW OK,LN ,TAG,DATA
6877	"RTN","IBY 577PR",20, 0)
6878	S OK=0
6879	"RTN","IBY 577PR",21, 0)
6880	F LN=2:1 S TAG="ENT "_FILE_"+" _LN,DATA=$ P($T(@TAG) ,";;",2) Q :DATA="" I $F(DATA, U_Y_U) S O K=1 Q
6881	"RTN","IBY 577PR",22, 0)
6882	Q OK
6883	"RTN","IBY 577PR",23, 0)
6884	;
6885	"RTN","IBY 577PR",24, 0)
6886	;Delete e dited entr ies to ins ure clean install of new entri es
6887	"RTN","IBY 577PR",25, 0)
6888	;Delete o bsolete en tries.
6889	"RTN","IBY 577PR",26, 0)
6890	DELOF ; Delete inc luded OF e ntries
6891	"RTN","IBY 577PR",27, 0)
6892	NEW FILE, DIK,LN,TAG ,TAGLN,DAT A,PCE,DA,Y
6893	"RTN","IBY 577PR",28, 0)
6894	F FILE=5, 6,7 S DIK= "^IBA(364. "_FILE_"," D
6895	"RTN","IBY 577PR",29, 0)
6896	. F TAG=" ENT"_FILE, "DEL"_FILE D
6897	"RTN","IBY 577PR",30, 0)
6898	.. F LN=2 :1 S TAGLN =TAG_"+"_L N,DATA=$P( $T(@TAGLN) ,";;",2) Q :DATA="" D
6899	"RTN","IBY 577PR",31, 0)
6900	... F PCE =2:1 S DA= $P(DATA,U, PCE) Q:'DA I $D(^IB A("364."_F ILE,DA,0)) D ^DIK
6901	"RTN","IBY 577PR",32, 0)
6902	Q
6903	"RTN","IBY 577PR",33, 0)
6904	;
6905	"RTN","IBY 577PR",34, 0)
6906	; Example for ENT5, ENT6, ENT 7, DEL5, D EL6, and D EL7:
6907	"RTN","IBY 577PR",35, 0)
6908	;;^195^25 4^259^269^ 324^325^
6909	"RTN","IBY 577PR",36, 0)
6910	; Note: Must have beginning and ending up-carat
6911	"RTN","IBY 577PR",37, 0)
6912	;
6913	"RTN","IBY 577PR",38, 0)
6914	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
6915	"RTN","IBY 577PR",39, 0)
6916	; 364.5 e ntries mod ified:
6917	"RTN","IBY 577PR",40, 0)
6918	;
6919	"RTN","IBY 577PR",41, 0)
6920	ENT5 ; OF entries in file 364. 5 to be in cluded
6921	"RTN","IBY 577PR",42, 0)
6922	;
6923	"RTN","IBY 577PR",43, 0)
6924	;;
6925	"RTN","IBY 577PR",44, 0)
6926	;
6927	"RTN","IBY 577PR",45, 0)
6928	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
6929	"RTN","IBY 577PR",46, 0)
6930	; 364.6 e ntries mod ified:
6931	"RTN","IBY 577PR",47, 0)
6932	;
6933	"RTN","IBY 577PR",48, 0)
6934	; 170 - SUB-2
6935	"RTN","IBY 577PR",49, 0)
6936	; 171 - SUB-3
6937	"RTN","IBY 577PR",50, 0)
6938	; 956 - OI1A-9
6939	"RTN","IBY 577PR",51, 0)
6940	; 957 - CI3A-4
6941	"RTN","IBY 577PR",52, 0)
6942	; 970 - SUB2-13 ( was SUB-8)
6943	"RTN","IBY 577PR",53, 0)
6944	; 1930 - PRV1-7
6945	"RTN","IBY 577PR",54, 0)
6946	; 1931 - PRV1-8
6947	"RTN","IBY 577PR",55, 0)
6948	; 1940 - AMB-3
6949	"RTN","IBY 577PR",56, 0)
6950	; 1941 - AMB-4
6951	"RTN","IBY 577PR",57, 0)
6952	; 1968 - CI3A-9
6953	"RTN","IBY 577PR",58, 0)
6954	; 1975 - PT2-6
6955	"RTN","IBY 577PR",59, 0)
6956	; 2025 - OI4-12
6957	"RTN","IBY 577PR",60, 0)
6958	; 2371 - SUB-8
6959	"RTN","IBY 577PR",61, 0)
6960	;
6961	"RTN","IBY 577PR",62, 0)
6962	ENT6 ; O.F . entries in file 36 4.6 to be included
6963	"RTN","IBY 577PR",63, 0)
6964	;
6965	"RTN","IBY 577PR",64, 0)
6966	;;^170^17 1^956^957^ 970^1930^1 931^1940^1 941^1968^1 975^2025^2 371^
6967	"RTN","IBY 577PR",65, 0)
6968	;
6969	"RTN","IBY 577PR",66, 0)
6970	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
6971	"RTN","IBY 577PR",67, 0)
6972	; 364.7 e ntries mod ified:
6973	"RTN","IBY 577PR",68, 0)
6974	;
6975	"RTN","IBY 577PR",69, 0)
6976	; 804 - COB1-2
6977	"RTN","IBY 577PR",70, 0)
6978	; 939 - PRF-23
6979	"RTN","IBY 577PR",71, 0)
6980	; 941 - PRF-25
6981	"RTN","IBY 577PR",72, 0)
6982	; 1015 - GEN-7
6983	"RTN","IBY 577PR",73, 0)
6984	; 1406 - INS-15
6985	"RTN","IBY 577PR",74, 0)
6986	; 1537 - OI6-7
6987	"RTN","IBY 577PR",75, 0)
6988	; 1538 - OI6-8
6989	"RTN","IBY 577PR",76, 0)
6990	; 1551 - OI6-10.1
6991	"RTN","IBY 577PR",77, 0)
6992	; 1927 - COB1-7
6993	"RTN","IBY 577PR",78, 0)
6994	; 1949 - INS-16
6995	"RTN","IBY 577PR",79, 0)
6996	; 1950 - INS-17
6997	"RTN","IBY 577PR",80, 0)
6998	; 1955 - OI1A-2
6999	"RTN","IBY 577PR",81, 0)
7000	; 1956 - SUB-8
7001	"RTN","IBY 577PR",82, 0)
7002	;
7003	"RTN","IBY 577PR",83, 0)
7004	ENT7 ; O.F . entries in file 36 4.7 to be included
7005	"RTN","IBY 577PR",84, 0)
7006	;
7007	"RTN","IBY 577PR",85, 0)
7008	;;^804^93 9^941^1015 ^1406^1537 ^1538^1551 ^1927^1949 ^1950^1955 ^1956^
7009	"RTN","IBY 577PR",86, 0)
7010	;
7011	"RTN","IBY 577PR",87, 0)
7012	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
7013	"RTN","IBY 577PR",88, 0)
7014	; 364.5 e ntries del eted:
7015	"RTN","IBY 577PR",89, 0)
7016	;
7017	"RTN","IBY 577PR",90, 0)
7018	DEL5 ; remove O.F . entries in file 36 4.5 (not r e-added)
7019	"RTN","IBY 577PR",91, 0)
7020	;
7021	"RTN","IBY 577PR",92, 0)
7022	;;
7023	"RTN","IBY 577PR",93, 0)
7024	;
7025	"RTN","IBY 577PR",94, 0)
7026	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
7027	"RTN","IBY 577PR",95, 0)
7028	; 364.6 e ntries del eted:
7029	"RTN","IBY 577PR",96, 0)
7030	;
7031	"RTN","IBY 577PR",97, 0)
7032	; 1850 - OI6-6.9
7033	"RTN","IBY 577PR",98, 0)
7034	;
7035	"RTN","IBY 577PR",99, 0)
7036	DEL6 ; remove O.F . entries in file 36 4.6 (not r e-added)
7037	"RTN","IBY 577PR",100 ,0)
7038	;
7039	"RTN","IBY 577PR",101 ,0)
7040	;;^1850^
7041	"RTN","IBY 577PR",102 ,0)
7042	;
7043	"RTN","IBY 577PR",103 ,0)
7044	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
7045	"RTN","IBY 577PR",104 ,0)
7046	; 364.7 e ntries del eted:
7047	"RTN","IBY 577PR",105 ,0)
7048	;
7049	"RTN","IBY 577PR",106 ,0)
7050	; 1550 - OI6-6.9
7051	"RTN","IBY 577PR",107 ,0)
7052	;
7053	"RTN","IBY 577PR",108 ,0)
7054	DEL7 ; remove O.F . entries in file 36 4.7 (not r e-added)
7055	"RTN","IBY 577PR",109 ,0)
7056	;
7057	"RTN","IBY 577PR",110 ,0)
7058	;;^1550^
7059	"RTN","IBY 577PR",111 ,0)
7060	;
7061	"RTN","IBY 577PR",112 ,0)
7062	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
7063	"RTN","IBY 577PR",113 ,0)
7064	ENT3508 ; Add New IB Error Cod es to File 350.8
7065	"RTN","IBY 577PR",114 ,0)
7066	;
7067	"RTN","IBY 577PR",115 ,0)
7068	;;^IB360^
7069	"RTN","IBY 577PR",116 ,0)
7070	;
7071	"RTN","IBY 577PR",117 ,0)
7072	Q
7073	"RTN","IBY 577PR",118 ,0)
7074	;
7075	"UP",36,36 .017,-1)
7076	36^17
7077	"UP",36,36 .017,0)
7078	36.017
7079	"UP",350.9 ,350.9004, -1)
7080	350.9^19
7081	"UP",350.9 ,350.9004, 0)
7082	350.9004
7083	"UP",399,3 99.0304,-1 )
7084	399^CP
7085	"UP",399,3 99.0304,0)
7086	399.0304
7087	"VER")
7088	8.0^22.2
7089	"^DD",36,3 6,17,0)
7090	277EDI ID NUMBER^36. 017A^^17;0
7091	"^DD",36,3 6,17,21,0)
7092	^^2^2^3170 508^
7093	"^DD",36,3 6,17,21,1, 0)
7094	This is th e ID infor mation nee ded to cap ture data for report ing purpos es
7095	"^DD",36,3 6,17,21,2, 0)
7096	from proce ssing 277s tat transa ctions.
7097	"^DD",36,3 6.017,0)
7098	277EDI ID NUMBER SUB -FIELD^^.0 4^4
7099	"^DD",36,3 6.017,0,"D T")
7100	3170508
7101	"^DD",36,3 6.017,0,"I X","B",36. 017,.01)
7102
7103	"^DD",36,3 6.017,0,"N M","277EDI ID NUMBER ")
7104
7105	"^DD",36,3 6.017,0,"U P")
7106	36
7107	"^DD",36,3 6.017,.01, 0)
7108	277EDI ID NUMBER^FJ3 0^^0;1^K:$ L(X)>30!($ L(X)<1) X
7109	"^DD",36,3 6.017,.01, 1,0)
7110	^.1
7111	"^DD",36,3 6.017,.01, 1,1,0)
7112	36.017^B
7113	"^DD",36,3 6.017,.01, 1,1,1)
7114	S ^DIC(36, DA(1),17," B",$E(X,1, 30),DA)=""
7115	"^DD",36,3 6.017,.01, 1,1,2)
7116	K ^DIC(36, DA(1),17," B",$E(X,1, 30),DA)
7117	"^DD",36,3 6.017,.01, 3)
7118	Answer mus t be 1-30 characters in length .
7119	"^DD",36,3 6.017,.01, 21,0)
7120	^^2^2^3170 508^
7121	"^DD",36,3 6.017,.01, 21,1,0)
7122	This is th e ID numbe r used to identify t he payer o n a profes sional or an
7123	"^DD",36,3 6.017,.01, 21,2,0)
7124	institutio nal claim transmissi on. This i s for repo rting purp oses only.
7125	"^DD",36,3 6.017,.01, "DT")
7126	3170306
7127	"^DD",36,3 6.017,.02, 0)
7128	277DATE ED I ID NUMBE R^D^^0;2^S %DT="EX" D ^%DT S X =Y K:Y<1 X
7129	"^DD",36,3 6.017,.02, 3)
7130	Enter the date of th e 277STAT transactio n from the clearing house.
7131	"^DD",36,3 6.017,.02, 21,0)
7132	^^2^2^3170 508^
7133	"^DD",36,3 6.017,.02, 21,1,0)
7134	This is th e date fro m the 277s tat transm ission fro m the clea ring house .
7135	"^DD",36,3 6.017,.02, 21,2,0)
7136	This is fo r reportin g purposes only.
7137	"^DD",36,3 6.017,.02, "DT")
7138	3170508
7139	"^DD",36,3 6.017,.03, 0)
7140	277EDI TYP E^S^P:PROF ESSIONAL;I :INSTITUTI ONAL;^0;3^ Q
7141	"^DD",36,3 6.017,.03, 3)
7142	Enter the type of cl aim "P" fo r professi onal or "I " for inst itutional.
7143	"^DD",36,3 6.017,.03, 21,0)
7144	^^2^2^3170 508^
7145	"^DD",36,3 6.017,.03, 21,1,0)
7146	This deter mines the type of cl aim - eith er "P" for professio nal or "I"
7147	"^DD",36,3 6.017,.03, 21,2,0)
7148	for instit utional. F or reporti ng purpose s only.
7149	"^DD",36,3 6.017,.03, "DT")
7150	3170508
7151	"^DD",36,3 6.017,.04, 0)
7152	277EDI ID NUMBER ON FILE^FJ30^ ^0;4^K:$L( X)>30!($L( X)<1) X
7153	"^DD",36,3 6.017,.04, 3)
7154	Answer mus t be 1-30 characters in length .
7155	"^DD",36,3 6.017,.04, 21,0)
7156	^.001^3^3^ 3170508^^
7157	"^DD",36,3 6.017,.04, 21,1,0)
7158	This is th e ID numbe r that was stored on file to d etermine t he payer o n
7159	"^DD",36,3 6.017,.04, 21,2,0)
7160	a claim pr ior to the 277stat t ransaction update. If there i s no numbe r
7161	"^DD",36,3 6.017,.04, 21,3,0)
7162	that means there wil l be an up date. Thi s is for r eporting p urposes on ly.
7163	"^DD",36,3 6.017,.04, "DT")
7164	3170306
7165	"^DD",350. 8,350.8,0)
7166	FIELD^^10^ 7
7167	"^DD",350. 8,350.8,0, "DDA")
7168	N
7169	"^DD",350. 8,350.8,0, "DT")
7170	2930322
7171	"^DD",350. 8,350.8,0, "ID",.03)
7172	W " ",$P (^(0),U,3)
7173	"^DD",350. 8,350.8,0, "IX","AC", 350.8,.03)
7174
7175	"^DD",350. 8,350.8,0, "IX","B",3 50.8,.01)
7176
7177	"^DD",350. 8,350.8,0, "IX","C",3 50.8,.03)
7178
7179	"^DD",350. 8,350.8,0, "NM","IB E RROR")
7180
7181	"^DD",350. 8,350.8,0, "PT",399,3 6)
7182
7183	"^DD",350. 8,350.8,0, "VRPK")
7184	IB
7185	"^DD",350. 8,350.8,.0 1,0)
7186	NAME^RF^^0 ;1^K:$L(X) >30!(X?.N) !($L(X)<3) !'(X'?1P.E ) X
7187	"^DD",350. 8,350.8,.0 1,1,0)
7188	^.1
7189	"^DD",350. 8,350.8,.0 1,1,1,0)
7190	350.8^B
7191	"^DD",350. 8,350.8,.0 1,1,1,1)
7192	S ^IBE(350 .8,"B",$E( X,1,30),DA )=""
7193	"^DD",350. 8,350.8,.0 1,1,1,2)
7194	K ^IBE(350 .8,"B",$E( X,1,30),DA )
7195	"^DD",350. 8,350.8,.0 1,3)
7196	NAME MUST BE 3-30 CH ARACTERS, NOT NUMERI C OR START ING WITH P UNCTUATION
7197	"^DD",350. 8,350.8,.0 1,21,0)
7198	^^2^2^2910 305^^
7199	"^DD",350. 8,350.8,.0 1,21,1,0)
7200	This is a free text name of th e entry. It should be namespa ced with
7201	"^DD",350. 8,350.8,.0 1,21,2,0)
7202	the namesp ace of the package r eporting t he error.
7203	"^DD",350. 8,350.8,.0 2,0)
7204	ERROR MESS AGE^F^^0;2 ^K:$L(X)>8 0!($L(X)<3 ) X
7205	"^DD",350. 8,350.8,.0 2,3)
7206	Answer mus t be 3-80 characters in length .
7207	"^DD",350. 8,350.8,.0 2,21,0)
7208	^^3^3^2940 209^^^^
7209	"^DD",350. 8,350.8,.0 2,21,1,0)
7210	This is th e text of the messag e as it wi ll be disp layed to a user or
7211	"^DD",350. 8,350.8,.0 2,21,2,0)
7212	posted in a bulletin . It shou ld be as m eaningful as possibl e to the
7213	"^DD",350. 8,350.8,.0 2,21,3,0)
7214	person see ing the me ssage.
7215	"^DD",350. 8,350.8,.0 3,0)
7216	ERROR CODE ^F^^0;3^K: X[""""!($A (X)=45) X I $D(X) K: $L(X)>9!($ L(X)<1) X
7217	"^DD",350. 8,350.8,.0 3,1,0)
7218	^.1
7219	"^DD",350. 8,350.8,.0 3,1,1,0)
7220	350.8^AC
7221	"^DD",350. 8,350.8,.0 3,1,1,1)
7222	S ^IBE(350 .8,"AC",$E (X,1,30),D A)=""
7223	"^DD",350. 8,350.8,.0 3,1,1,2)
7224	K ^IBE(350 .8,"AC",$E (X,1,30),D A)
7225	"^DD",350. 8,350.8,.0 3,1,2,0)
7226	350.8^C
7227	"^DD",350. 8,350.8,.0 3,1,2,1)
7228	S ^IBE(350 .8,"C",$E( X,1,30),DA )=""
7229	"^DD",350. 8,350.8,.0 3,1,2,2)
7230	K ^IBE(350 .8,"C",$E( X,1,30),DA )
7231	"^DD",350. 8,350.8,.0 3,3)
7232	Answer mus t be 1-9 c haracters in length.
7233	"^DD",350. 8,350.8,.0 3,21,0)
7234	^^9^9^2920 219^^^^
7235	"^DD",350. 8,350.8,.0 3,21,1,0)
7236	This is th e error co de that wi ll be pass ed to or d etermined by
7237	"^DD",350. 8,350.8,.0 3,21,2,0)
7238	Integrated Billing. The forma t for the Error Code should be
7239	"^DD",350. 8,350.8,.0 3,21,3,0)
7240	nnxxx, whe re nn is t he reporti ng package namespace and xxx a re numeric
7241	"^DD",350. 8,350.8,.0 3,21,4,0)
7242	values.
7243	"^DD",350. 8,350.8,.0 3,21,5,0)
7244
7245	"^DD",350. 8,350.8,.0 3,21,6,0)
7246	This is th e error co de that wi ll be pass ed as the second pie ce of
7247	"^DD",350. 8,350.8,.0 3,21,7,0)
7248	the variab le Y to IB when +Y=- 1. More t han one er ror code c an be
7249	"^DD",350. 8,350.8,.0 3,21,8,0)
7250	placed in the second ^ piece o f Y delimi ted by sem i-colons. Applicati ons
7251	"^DD",350. 8,350.8,.0 3,21,9,0)
7252	may call ^ IBAERR to display th e error me ssage(s).
7253	"^DD",350. 8,350.8,.0 3,"DT")
7254	2920219
7255	"^DD",350. 8,350.8,.0 4,0)
7256	PACKAGE RE PORTING ER ROR^S^1:IN TEGRATED B ILLING;2:A CCOUNTS RE CEIVABLE;3 :PHARMACY; ^0;4^Q
7257	"^DD",350. 8,350.8,.0 4,21,0)
7258	^.001^2^2^ 3170217^^^ ^
7259	"^DD",350. 8,350.8,.0 4,21,1,0)
7260	This is th e package that reque sted this entry in t his file a nd will
7261	"^DD",350. 8,350.8,.0 4,21,2,0)
7262	report it to IB as a n error if the condi tions are detected.
7263	"^DD",350. 8,350.8,.0 5,0)
7264	ERROR ACTI ON^S^1:DIS PLAY MESSA GE;2:SEND BULLETIN;3 :EDIT FILE ;^0;5^Q
7265	"^DD",350. 8,350.8,.0 5,21,0)
7266	^^6^6^2910 227^
7267	"^DD",350. 8,350.8,.0 5,21,1,0)
7268	This is th e type of action tha t should b e taken wh en this er ror is
7269	"^DD",350. 8,350.8,.0 5,21,2,0)
7270	reported t o IB. If action oth er than di splaying a message i s indicate d
7271	"^DD",350. 8,350.8,.0 5,21,3,0)
7272	then the M UMPS code in the ERR OR ACTION field will be execut ed.
7273	"^DD",350. 8,350.8,.0 5,21,4,0)
7274
7275	"^DD",350. 8,350.8,.0 5,21,5,0)
7276	Currently only displ ay actions are imple mented. P lease cont act the
7277	"^DD",350. 8,350.8,.0 5,21,6,0)
7278	developing ISC if ot her action types are desired.
7279	"^DD",350. 8,350.8,.0 6,0)
7280	CORRESPOND ING ALERT^ P354.5'^IB E(354.5,^0 ;6^Q
7281	"^DD",350. 8,350.8,.0 6,21,0)
7282	^^1^1^2940 209^
7283	"^DD",350. 8,350.8,.0 6,21,1,0)
7284	This is th e type of alert that should be sent when this erro r occurs.
7285	"^DD",350. 8,350.8,.0 6,"DT")
7286	2930322
7287	"^DD",350. 8,350.8,10 ,0)
7288	EXECUTABLE LOGIC^K^^ 10;E1,245^ K:$L(X)>24 5 X D:$D(X ) ^DIM
7289	"^DD",350. 8,350.8,10 ,3)
7290	This is St andard MUM PS code.
7291	"^DD",350. 8,350.8,10 ,21,0)
7292	^^2^2^2910 227^
7293	"^DD",350. 8,350.8,10 ,21,1,0)
7294	This is th e MUMPS co de that wi ll be exec uted if an error is reported
7295	"^DD",350. 8,350.8,10 ,21,2,0)
7296	with an ER ROR ACTION of other than to di splay a me ssage.
7297	"^DD",350. 9,350.9004 ,1.01,0)
7298	STREET ADD RESS 1^FJ5 5^^1;1^K:$ L(X)>55!($ L(X)<1) X
7299	"^DD",350. 9,350.9004 ,1.01,.1)
7300	Pay-to Pro vider Addr ess Line 1
7301	"^DD",350. 9,350.9004 ,1.01,3)
7302	Answer mus t be 1-55 characters in length .
7303	"^DD",350. 9,350.9004 ,1.01,21,0 )
7304	^.001^2^2^ 3170330^^
7305	"^DD",350. 9,350.9004 ,1.01,21,1 ,0)
7306	You may mo dify the P ay-to Prov ider Addre ss for use on electr onic or
7307	"^DD",350. 9,350.9004 ,1.01,21,2 ,0)
7308	printed cl aims. You may enter a P.O. Bo x.
7309	"^DD",350. 9,350.9004 ,1.01,23,0 )
7310	^.001^1^1^ 3170330^^
7311	"^DD",350. 9,350.9004 ,1.01,23,1 ,0)
7312	This field is initia lly set by the "AC" x-ref of t he .01 fie ld.
7313	"^DD",350. 9,350.9004 ,1.01,"DT" )
7314	3170427
7315	"^DD",350. 9,350.9004 ,1.02,0)
7316	STREET ADD RESS 2^FJ5 5^^1;2^K:$ L(X)>55!($ L(X)<1) X
7317	"^DD",350. 9,350.9004 ,1.02,.1)
7318	Pay-to Pro vider Addr ess Line 2
7319	"^DD",350. 9,350.9004 ,1.02,3)
7320	Answer mus t be 1-55 characters in length .
7321	"^DD",350. 9,350.9004 ,1.02,21,0 )
7322	^^1^1^3081 114^
7323	"^DD",350. 9,350.9004 ,1.02,21,1 ,0)
7324	Enter addi tional Add ress infor mation if needed.
7325	"^DD",350. 9,350.9004 ,1.02,23,0 )
7326	^^1^1^3081 114^
7327	"^DD",350. 9,350.9004 ,1.02,23,1 ,0)
7328	This field is initia lly set by the "AC" x-ref of t he .01 fie ld.
7329	"^DD",350. 9,350.9004 ,1.02,"DT" )
7330	3170427
7331	"^DD",355. 93,355.93, .01,0)
7332	NAME^RFXJ6 0^^0;1^K:( $L(X)>60)! ($L(X)<3) X I $D(X) D PRVFMT^I BCEP8
7333	"^DD",355. 93,355.93, .01,1,0)
7334	^.1
7335	"^DD",355. 93,355.93, .01,1,1,0)
7336	355.93^B
7337	"^DD",355. 93,355.93, .01,1,1,1)
7338	S ^IBA(355 .93,"B",$E (X,1,30),D A)=""
7339	"^DD",355. 93,355.93, .01,1,1,2)
7340	K ^IBA(355 .93,"B",$E (X,1,30),D A)
7341	"^DD",355. 93,355.93, .01,1,2,0)
7342	^^TRIGGER^ 355.93^.02
7343	"^DD",355. 93,355.93, .01,1,2,1)
7344	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=IBFLPFL P I X S X= DIV S Y(1) =$S($D(^IB A(355.93,D 0,0)):^(0) ,1:"") S X =$P(Y(1),U ,2),X=X S DIU=X K Y S X=DIV S X=IBFLPFLP X ^DD(355 .93,.01,1, 2,1.4)
7345	"^DD",355. 93,355.93, .01,1,2,1. 4)
7346	S DIH=$G(^ IBA(355.93 ,DIV(0),0) ),DIV=X S $P(^(0),U, 2)=DIV,DIH =355.93,DI G=.02 D ^D ICR
7347	"^DD",355. 93,355.93, .01,1,2,2)
7348	Q
7349	"^DD",355. 93,355.93, .01,1,2,3)
7350	Do not del ete
7351	"^DD",355. 93,355.93, .01,1,2,"% D",0)
7352	^^3^3^3100 720^
7353	"^DD",355. 93,355.93, .01,1,2,"% D",1,0)
7354	Trigger to change pr ovider typ e based on user inpu t during a dd/edit of the
7355	"^DD",355. 93,355.93, .01,1,2,"% D",2,0)
7356	NAME field (#.01). Population of this f ield is ba sed on the value of the
7357	"^DD",355. 93,355.93, .01,1,2,"% D",3,0)
7358	IBFLPFLP v ariable re turned by the NAME f ield input transform .
7359	"^DD",355. 93,355.93, .01,1,2,"C REATE COND ITION")
7360	S X=IBFLPF LP
7361	"^DD",355. 93,355.93, .01,1,2,"C REATE VALU E")
7362	S X=IBFLPF LP
7363	"^DD",355. 93,355.93, .01,1,2,"D ELETE VALU E")
7364	NO EFFECT
7365	"^DD",355. 93,355.93, .01,1,2,"D T")
7366	3100707
7367	"^DD",355. 93,355.93, .01,1,2,"F IELD")
7368	PROVIDER T YPE
7369	"^DD",355. 93,355.93, .01,3)
7370	Enter the name of a NON-VA pro vider/faci lity or ot her VA. N ame must s tart with a letter a nd can hav e letters, numbers,co mma,space, dash only. Names ar en't valid if they e xist in th e NEW PERS ON file.
7371	"^DD",355. 93,355.93, .01,21,0)
7372	^.001^26^2 6^3170330^ ^^^
7373	"^DD",355. 93,355.93, .01,21,1,0 )
7374	This is th e name of either an individual NON-VA
7375	"^DD",355. 93,355.93, .01,21,2,0 )
7376	provider o r a NON-VA or anothe r VA facil ity
7377	"^DD",355. 93,355.93, .01,21,3,0 )
7378	that provi des servic es to the V.A. for w hich
7379	"^DD",355. 93,355.93, .01,21,4,0 )
7380	the V.A. c an in turn bill an i nsurance c ompany
7381	"^DD",355. 93,355.93, .01,21,5,0 )
7382	for reimbu rsement.
7383	"^DD",355. 93,355.93, .01,21,6,0 )
7384
7385	"^DD",355. 93,355.93, .01,21,7,0 )
7386	For indivi dual type entries:
7387	"^DD",355. 93,355.93, .01,21,8,0 )
7388	The name s hould be e ntered in LAST,FIRST MIDDLE
7389	"^DD",355. 93,355.93, .01,21,9,0 )
7390	format. E nter only data that is actuall y part
7391	"^DD",355. 93,355.93, .01,21,10, 0)
7392	of the pro vider's na me. Do not include e xtra
7393	"^DD",355. 93,355.93, .01,21,11, 0)
7394	titles, id entificati on, flags, local inf ormation,
7395	"^DD",355. 93,355.93, .01,21,12, 0)
7396	etc. All individual provider names will be
7397	"^DD",355. 93,355.93, .01,21,13, 0)
7398	converted to the 'st andardized ' format.
7399	"^DD",355. 93,355.93, .01,21,14, 0)
7400	'Standardi zed' for i ndividuals means all
7401	"^DD",355. 93,355.93, .01,21,15, 0)
7402	punctuatio n except ' -' and spa ce are rem oved,
7403	"^DD",355. 93,355.93, .01,21,16, 0)
7404	the name i s changed to all upp ercase, 2 or more
7405	"^DD",355. 93,355.93, .01,21,17, 0)
7406	successive '-' or sp aces are c onverted t o a
7407	"^DD",355. 93,355.93, .01,21,18, 0)
7408	single '-' or space and any wo rds for bi rth
7409	"^DD",355. 93,355.93, .01,21,19, 0)
7410	position ( 1ST-10TH) are change d to their Roman
7411	"^DD",355. 93,355.93, .01,21,20, 0)
7412	numeral eq uivalents.
7413	"^DD",355. 93,355.93, .01,21,21, 0)
7414
7415	"^DD",355. 93,355.93, .01,21,22, 0)
7416	For facili ty type en tries:
7417	"^DD",355. 93,355.93, .01,21,23, 0)
7418	The name M UST start with an Al pha charac ter. The
7419	"^DD",355. 93,355.93, .01,21,24, 0)
7420	name may c ontain num erals, spa ces, comma s,
7421	"^DD",355. 93,355.93, .01,21,25, 0)
7422	periods, a nd a hyphe n or dash. No other
7423	"^DD",355. 93,355.93, .01,21,26, 0)
7424	punctuatio n characte rs are all owed in th e name.
7425	"^DD",355. 93,355.93, .01,"DT")
7426	3170427
7427	"^DD",355. 93,355.93, .05,0)
7428	STREET ADD RESS^RFXJ5 5^^0;5^S X =$$UP^XLFS TR(X) K:$L (X)>55!($L (X)<1)!$$B ADADD^IBCE P8B(X) X I $D(X),$P( $G(^IBA(35 5.93,DA,0) ),U,2)'=1 K X
7429	"^DD",355. 93,355.93, .05,3)
7430	Answer mus t be 1-55 characters in length . Cannot b e a post o ffice box.
7431	"^DD",355. 93,355.93, .05,5,1,0)
7432	355.93^.02 ^3
7433	"^DD",355. 93,355.93, .05,21,0)
7434	^.001^3^3^ 3170330^^^ ^
7435	"^DD",355. 93,355.93, .05,21,1,0 )
7436	This is th e street a ddress of the non-VA facility that rende red
7437	"^DD",355. 93,355.93, .05,21,2,0 )
7438	the care t hat is bei ng billed by the VA. It is on ly valid f or FACILIT Y
7439	"^DD",355. 93,355.93, .05,21,3,0 )
7440	providers. It cannot be a post office bo x.
7441	"^DD",355. 93,355.93, .05,"DT")
7442	3170427
7443	"^DD",364. 6,364.6,0)
7444	FIELD^^.13 ^13
7445	"^DD",364. 6,364.6,0, "DDA")
7446	N
7447	"^DD",364. 6,364.6,0, "DT")
7448	3170509
7449	"^DD",364. 6,364.6,0, "ID",.04)
7450	W " ",$P (^(0),U,4)
7451	"^DD",364. 6,364.6,0, "ID",.05)
7452	W " ",$P (^(0),U,5)
7453	"^DD",364. 6,364.6,0, "ID",.08)
7454	W " ",$P (^(0),U,8)
7455	"^DD",364. 6,364.6,0, "ID",.1)
7456	W " ",$P (^(0),U,10 )
7457	"^DD",364. 6,364.6,0, "IX","APAR ",364.6,.0 1)
7458
7459	"^DD",364. 6,364.6,0, "IX","APAR 1",364.6,. 03)
7460
7461	"^DD",364. 6,364.6,0, "IX","ASEQ ",364.6,.0 1)
7462
7463	"^DD",364. 6,364.6,0, "IX","ASEQ 1",364.6,. 04)
7464
7465	"^DD",364. 6,364.6,0, "IX","ASEQ 2",364.6,. 05)
7466
7467	"^DD",364. 6,364.6,0, "IX","ASEQ 3",364.6,. 08)
7468
7469	"^DD",364. 6,364.6,0, "IX","B",3 64.6,.01)
7470
7471	"^DD",364. 6,364.6,0, "NM","IB F ORM SKELET ON DEFINIT ION")
7472
7473	"^DD",364. 6,364.6,0, "PT",364.6 ,.03)
7474
7475	"^DD",364. 6,364.6,0, "PT",364.7 ,.01)
7476
7477	"^DD",364. 6,364.6,0, "VRPK")
7478	IB
7479	"^DD",364. 6,364.6,.0 1,0)
7480	BILL FORM^ RP353'X^IB E(353,^0;1 ^I $$DUP^I BCEFG0($G( DA),X,1) K X
7481	"^DD",364. 6,364.6,.0 1,1,0)
7482	^.1
7483	"^DD",364. 6,364.6,.0 1,1,1,0)
7484	364.6^B
7485	"^DD",364. 6,364.6,.0 1,1,1,1)
7486	S ^IBA(364 .6,"B",$E( X,1,30),DA )=""
7487	"^DD",364. 6,364.6,.0 1,1,1,2)
7488	K ^IBA(364 .6,"B",$E( X,1,30),DA )
7489	"^DD",364. 6,364.6,.0 1,1,2,0)
7490	364.6^ASEQ ^MUMPS
7491	"^DD",364. 6,364.6,.0 1,1,2,1)
7492	N Z0,Z1,Z2 ,Z3 S Z0=$ G(^IBA(364 .6,DA,0)), Z1=$P(Z0,U ,4),Z2=$P( Z0,U,5),Z3 =$P(Z0,U,8 ) I Z1,Z2, Z3 S ^IBA( 364.6,"ASE Q",+X,Z1,Z 2,Z3,DA)=" "
7493	"^DD",364. 6,364.6,.0 1,1,2,2)
7494	N Z0,Z1,Z2 ,Z3 S Z0=$ G(^IBA(364 .6,DA,0)), Z1=$P(Z0,U ,4),Z2=$P( Z0,U,5),Z3 =$P(Z0,U,8 ) I Z1,Z2, Z3 K ^IBA( 364.6,"ASE Q",+X,Z1,Z 2,Z3,DA)
7495	"^DD",364. 6,364.6,.0 1,1,2,3)
7496	DO NOT DEL ETE
7497	"^DD",364. 6,364.6,.0 1,1,2,"%D" ,0)
7498	^^1^1^2960 117^^
7499	"^DD",364. 6,364.6,.0 1,1,2,"%D" ,1,0)
7500	This xref contains t he sequenc e to use t o extract or print t he form fi elds.
7501	"^DD",364. 6,364.6,.0 1,1,2,"DT" )
7502	2960116
7503	"^DD",364. 6,364.6,.0 1,1,3,0)
7504	364.6^APAR ^MUMPS
7505	"^DD",364. 6,364.6,.0 1,1,3,1)
7506	N Z0 S Z0= $P($G(^IBA (364.6,DA, 0)),U,3) I Z0,Z0'=X S ^IBA(364 .6,"APAR", $E(X,1,30) ,Z0,DA)=""
7507	"^DD",364. 6,364.6,.0 1,1,3,2)
7508	N Z0 S Z0= $P($G(^IBA (364.6,DA, 0)),U,3) I Z0,Z0'=X K ^IBA(364 .6,"APAR", $E(X,1,30) ,Z0,DA)
7509	"^DD",364. 6,364.6,.0 1,1,3,3)
7510	DO NOT DEL ETE
7511	"^DD",364. 6,364.6,.0 1,1,3,"%D" ,0)
7512	^^1^1^2960 117^
7513	"^DD",364. 6,364.6,.0 1,1,3,"%D" ,1,0)
7514	Xref by bi ll form an d associat ed form fi eld defini tion.
7515	"^DD",364. 6,364.6,.0 1,1,3,"DT" )
7516	2960117
7517	"^DD",364. 6,364.6,.0 1,1,4,0)
7518	^^TRIGGER^ 364.6^.03
7519	"^DD",364. 6,364.6,.0 1,1,4,1)
7520	X ^DD(364. 6,.01,1,4, 1.3) I X S X=DIV S Y (1)=$S($D( ^IBA(364.6 ,D0,0)):^( 0),1:"") S X=$P(Y(1) ,U,3),X=X S DIU=X K Y S X=DIV S X=$S('$D (D0):"",D0 <0:"",1:D0 ) X ^DD(36 4.6,.01,1, 4,1.4)
7521	"^DD",364. 6,364.6,.0 1,1,4,1.3)
7522	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X X ^DD(364.6 ,.01,1,4,6 9.2) S X=$ P($P(Y(102 ),$C(59)_$ P(Y(101),U ,2)_":",2) ,$C(59),1) ="BILLING SCREEN" S D0=I(0,0)
7523	"^DD",364. 6,364.6,.0 1,1,4,1.4)
7524	S DIH=$G(^ IBA(364.6, DIV(0),0)) ,DIV=X S $ P(^(0),U,3 )=DIV,DIH= 364.6,DIG= .03 D ^DIC R
7525	"^DD",364. 6,364.6,.0 1,1,4,2)
7526	X ^DD(364. 6,.01,1,4, 2.3) I X S X=DIV S Y (1)=$S($D( ^IBA(364.6 ,D0,0)):^( 0),1:"") S X=$P(Y(1) ,U,3),X=X S DIU=X K Y S X="" S DIH=$G(^I BA(364.6,D IV(0),0)), DIV=X S $P (^(0),U,3) =DIV,DIH=3 64.6,DIG=. 03 D ^DICR
7527	"^DD",364. 6,364.6,.0 1,1,4,2.3)
7528	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X X ^DD(364.6 ,.01,1,4,7 9.2) S Y(1 01)=$S($D( ^IBE(353,D 0,2)):^(2) ,1:"") S X =$P($P(Y(1 02),$C(59) _$P(Y(101) ,U,2)_":", 2),$C(59), 1)="BILLIN G SCREEN" S D0=I(0,0 )
7529	"^DD",364. 6,364.6,.0 1,1,4,3)
7530	DO NOT DEL ETE
7531	"^DD",364. 6,364.6,.0 1,1,4,69.2 )
7532	S I(0,0)=$ G(D0),D0=Y (0) S:'D0! '$D(^IBE(3 53,+D0,0)) D0=-1 S Y (102)=$C(5 9)_$P($G(^ DD(353,2.0 2,0)),U,3) ,Y(101)=$S ($D(^IBE(3 53,D0,2)): ^(2),1:"")
7533	"^DD",364. 6,364.6,.0 1,1,4,79.2 )
7534	S I(0,0)=$ G(D0),Y(1) =$S($D(^IB A(364.6,D0 ,0)):^(0), 1:""),D0=$ P(Y(1),U,1 ) S:'D0!'$ D(^IBE(353 ,+D0,0)) D 0=-1 S Y(1 02)=$C(59) _$P($G(^DD (353,2.02, 0)),U,3)
7535	"^DD",364. 6,364.6,.0 1,1,4,"%D" ,0)
7536	^^1^1^3000 613^
7537	"^DD",364. 6,364.6,.0 1,1,4,"%D" ,1,0)
7538	This trigg er is need ed for the local scr een 9 logi c to work correctly.
7539	"^DD",364. 6,364.6,.0 1,1,4,"CRE ATE CONDIT ION")
7540	BILL FORM: FORMAT TYP E="BILLING SCREEN"
7541	"^DD",364. 6,364.6,.0 1,1,4,"CRE ATE VALUE" )
7542	NUMBER
7543	"^DD",364. 6,364.6,.0 1,1,4,"DEL ETE CONDIT ION")
7544	BILL FORM: FORMAT TYP E="BILLING SCREEN"
7545	"^DD",364. 6,364.6,.0 1,1,4,"DEL ETE VALUE" )
7546	@
7547	"^DD",364. 6,364.6,.0 1,1,4,"DT" )
7548	3000613
7549	"^DD",364. 6,364.6,.0 1,1,4,"FIE LD")
7550	ASSOCIATED FORM DEFI NITION
7551	"^DD",364. 6,364.6,.0 1,3)
7552	Enter a BI LLING FORM that the data eleme nt will ap pear on.
7553	"^DD",364. 6,364.6,.0 1,21,0)
7554	^.001^2^2^ 3170510^^^ ^
7555	"^DD",364. 6,364.6,.0 1,21,1,0)
7556	Identifies a billing 'form' or 'screen' where the data eleme nt is used .
7557	"^DD",364. 6,364.6,.0 1,21,2,0)
7558	The combin ation of f orm/page/l ine/column must be u nique.
7559	"^DD",364. 6,364.6,.0 1,"DT")
7560	3170510
7561	"^DD",364. 6,364.6,.0 2,0)
7562	SECURITY L EVEL^SX^N: NATIONAL,N O EDIT;L:L OCAL;^0;2^ I X="N",$P ($G(^IBA(3 64.6,DA,0) ),U,3) K X
7563	"^DD",364. 6,364.6,.0 2,3)
7564	Enter an N if no edi ting is al lowed, L i f editing is OK beca use this e ntry is as sociated w ith a loca lly define d form.
7565	"^DD",364. 6,364.6,.0 2,5,1,0)
7566	364.6^.03^ 7
7567	"^DD",364. 6,364.6,.0 2,21,0)
7568	^.001^4^4^ 3001030^^
7569	"^DD",364. 6,364.6,.0 2,21,1,0)
7570	This field determine s whether or not edi ting of th e entry is allowed. If
7571	"^DD",364. 6,364.6,.0 2,21,2,0)
7572	the securi ty level o f the entr y is NATIO NAL (N), n o local ed iting is
7573	"^DD",364. 6,364.6,.0 2,21,3,0)
7574	allowed. If the sec urity leve l of the e ntry is LO CAL (L), i t may be
7575	"^DD",364. 6,364.6,.0 2,21,4,0)
7576	edited.
7577	"^DD",364. 6,364.6,.0 2,"DT")
7578	2960117
7579	"^DD",364. 6,364.6,.0 3,0)
7580	ASSOCIATED FORM DEFI NITION^P36 4.6'^IBA(3 64.6,^0;3^ Q
7581	"^DD",364. 6,364.6,.0 3,1,0)
7582	^.1
7583	"^DD",364. 6,364.6,.0 3,1,1,0)
7584	364.6^APAR 1^MUMPS
7585	"^DD",364. 6,364.6,.0 3,1,1,1)
7586	N Z0 S Z0= +$G(^IBA(3 64.6,DA,0) ) I Z0,Z0' =X S ^IBA( 364.6,"APA R",Z0,$E(X ,1,30),DA) =""
7587	"^DD",364. 6,364.6,.0 3,1,1,2)
7588	N Z0 S Z0= +$G(^IBA(3 64.6,DA,0) ) I Z0,Z0' =X K ^IBA( 364.6,"APA R",Z0,$E(X ,1,30),DA)
7589	"^DD",364. 6,364.6,.0 3,1,1,3)
7590	DO NOT DEL ETE
7591	"^DD",364. 6,364.6,.0 3,1,1,"%D" ,0)
7592	^^1^1^2960 117^^
7593	"^DD",364. 6,364.6,.0 3,1,1,"%D" ,1,0)
7594	Xref by bi ll form an d associat ed form fi eld defini tion.
7595	"^DD",364. 6,364.6,.0 3,1,1,"DT" )
7596	2960117
7597	"^DD",364. 6,364.6,.0 3,1,2,0)
7598	^^TRIGGER^ 364.6^.04
7599	"^DD",364. 6,364.6,.0 3,1,2,1)
7600	X ^DD(364. 6,.03,1,2, 1.3) I X S X=DIV S Y (1)=$S($D( ^IBA(364.6 ,D0,0)):^( 0),1:"") S X=$P(Y(1) ,U,4),X=X S DIU=X K Y S X="" X ^DD(364.6 ,.03,1,2,1 .4)
7601	"^DD",364. 6,364.6,.0 3,1,2,1.3)
7602	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X X ^DD(364.6 ,.03,1,2,6 9.2) S Y(1 01)=$S($D( ^IBE(353,D 0,2)):^(2) ,1:"") S X =$P($P(Y(1 02),$C(59) _$P(Y(101) ,U,2)_":", 2),$C(59), 1)'="BILLI NG SCREEN" S D0=I(0, 0)
7603	"^DD",364. 6,364.6,.0 3,1,2,1.4)
7604	S DIH=$S($ D(^IBA(364 .6,DIV(0), 0)):^(0),1 :""),DIV=X S $P(^(0) ,U,4)=DIV, DIH=364.6, DIG=.04 D ^DICR
7605	"^DD",364. 6,364.6,.0 3,1,2,2)
7606	Q
7607	"^DD",364. 6,364.6,.0 3,1,2,3)
7608	DO NOT DEL ETE
7609	"^DD",364. 6,364.6,.0 3,1,2,69.2 )
7610	S I(0,0)=$ S($D(D0):D 0,1:""),Y( 1)=$S($D(^ IBA(364.6, D0,0)):^(0 ),1:""),D0 =$P(Y(1),U ,1) S:'$D( ^IBE(353,+ D0,0)) D0= -1 S Y(102 )=$C(59)_$ S($D(^DD(3 53,2.02,0) ):$P(^(0), U,3),1:"")
7611	"^DD",364. 6,364.6,.0 3,1,2,"%D" ,0)
7612	^.101^2^2^ 3000424^^
7613	"^DD",364. 6,364.6,.0 3,1,2,"%D" ,1,0)
7614	If an asso ciated for m that is not a scre en form, p age is tak en from th e
7615	"^DD",364. 6,364.6,.0 3,1,2,"%D" ,2,0)
7616	associated with fiel d definiti on.
7617	"^DD",364. 6,364.6,.0 3,1,2,"CRE ATE CONDIT ION")
7618	BILL FORM: FORMAT TYP E'="BILLIN G SCREEN"
7619	"^DD",364. 6,364.6,.0 3,1,2,"CRE ATE VALUE" )
7620	@
7621	"^DD",364. 6,364.6,.0 3,1,2,"DEL ETE VALUE" )
7622	NO EFFECT
7623	"^DD",364. 6,364.6,.0 3,1,2,"DT" )
7624	3000405
7625	"^DD",364. 6,364.6,.0 3,1,2,"FIE LD")
7626	PAGE OR SE QUENCE
7627	"^DD",364. 6,364.6,.0 3,1,3,0)
7628	^^TRIGGER^ 364.6^.05
7629	"^DD",364. 6,364.6,.0 3,1,3,1)
7630	X ^DD(364. 6,.03,1,3, 1.3) I X S X=DIV S Y (1)=$S($D( ^IBA(364.6 ,D0,0)):^( 0),1:"") S X=$P(Y(1) ,U,5),X=X S DIU=X K Y S X="" X ^DD(364.6 ,.03,1,3,1 .4)
7631	"^DD",364. 6,364.6,.0 3,1,3,1.3)
7632	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X X ^DD(364.6 ,.03,1,3,6 9.2) S Y(1 01)=$S($D( ^IBE(353,D 0,2)):^(2) ,1:"") S X =$P($P(Y(1 02),$C(59) _$P(Y(101) ,U,2)_":", 2),$C(59), 1)'="BILLI NG SCREEN" S D0=I(0, 0)
7633	"^DD",364. 6,364.6,.0 3,1,3,1.4)
7634	S DIH=$S($ D(^IBA(364 .6,DIV(0), 0)):^(0),1 :""),DIV=X S $P(^(0) ,U,5)=DIV, DIH=364.6, DIG=.05 D ^DICR
7635	"^DD",364. 6,364.6,.0 3,1,3,2)
7636	Q
7637	"^DD",364. 6,364.6,.0 3,1,3,3)
7638	DO NOT DEL ETE
7639	"^DD",364. 6,364.6,.0 3,1,3,69.2 )
7640	S I(0,0)=$ S($D(D0):D 0,1:""),Y( 1)=$S($D(^ IBA(364.6, D0,0)):^(0 ),1:""),D0 =$P(Y(1),U ,1) S:'$D( ^IBE(353,+ D0,0)) D0= -1 S Y(102 )=$C(59)_$ S($D(^DD(3 53,2.02,0) ):$P(^(0), U,3),1:"")
7641	"^DD",364. 6,364.6,.0 3,1,3,"%D" ,0)
7642	^^2^2^3000 405^
7643	"^DD",364. 6,364.6,.0 3,1,3,"%D" ,1,0)
7644	If an asso ciated for m that is not a scre en form, l ine is tak en from th e
7645	"^DD",364. 6,364.6,.0 3,1,3,"%D" ,2,0)
7646	associated with fiel d definiti on.
7647	"^DD",364. 6,364.6,.0 3,1,3,"CRE ATE CONDIT ION")
7648	BILL FORM: FORMAT TYP E'="BILLIN G SCREEN"
7649	"^DD",364. 6,364.6,.0 3,1,3,"CRE ATE VALUE" )
7650	@
7651	"^DD",364. 6,364.6,.0 3,1,3,"DEL ETE VALUE" )
7652	NO EFFECT
7653	"^DD",364. 6,364.6,.0 3,1,3,"DT" )
7654	3000405
7655	"^DD",364. 6,364.6,.0 3,1,3,"FIE LD")
7656	FIRST LINE NUMBER
7657	"^DD",364. 6,364.6,.0 3,1,4,0)
7658	^^TRIGGER^ 364.6^.08
7659	"^DD",364. 6,364.6,.0 3,1,4,1)
7660	X ^DD(364. 6,.03,1,4, 1.3) I X S X=DIV S Y (1)=$S($D( ^IBA(364.6 ,D0,0)):^( 0),1:"") S X=$P(Y(1) ,U,8),X=X S DIU=X K Y S X="" X ^DD(364.6 ,.03,1,4,1 .4)
7661	"^DD",364. 6,364.6,.0 3,1,4,1.3)
7662	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X X ^DD(364.6 ,.03,1,4,6 9.2) S Y(1 01)=$S($D( ^IBE(353,D 0,2)):^(2) ,1:"") S X =$P($P(Y(1 02),$C(59) _$P(Y(101) ,U,2)_":", 2),$C(59), 1)'="BILLI NG SCREEN" S D0=I(0, 0)
7663	"^DD",364. 6,364.6,.0 3,1,4,1.4)
7664	S DIH=$S($ D(^IBA(364 .6,DIV(0), 0)):^(0),1 :""),DIV=X S $P(^(0) ,U,8)=DIV, DIH=364.6, DIG=.08 D ^DICR
7665	"^DD",364. 6,364.6,.0 3,1,4,2)
7666	Q
7667	"^DD",364. 6,364.6,.0 3,1,4,3)
7668	DO NOT DEL ETE
7669	"^DD",364. 6,364.6,.0 3,1,4,69.2 )
7670	S I(0,0)=$ S($D(D0):D 0,1:""),Y( 1)=$S($D(^ IBA(364.6, D0,0)):^(0 ),1:""),D0 =$P(Y(1),U ,1) S:'$D( ^IBE(353,+ D0,0)) D0= -1 S Y(102 )=$C(59)_$ S($D(^DD(3 53,2.02,0) ):$P(^(0), U,3),1:"")
7671	"^DD",364. 6,364.6,.0 3,1,4,"%D" ,0)
7672	^^2^2^3000 405^
7673	"^DD",364. 6,364.6,.0 3,1,4,"%D" ,1,0)
7674	If an asso ciated for m that is not a scre en form, c olumn is t aken from the
7675	"^DD",364. 6,364.6,.0 3,1,4,"%D" ,2,0)
7676	associated with fiel d definiti on.
7677	"^DD",364. 6,364.6,.0 3,1,4,"CRE ATE CONDIT ION")
7678	BILL FORM: FORMAT TYP E'="BILLIN G SCREEN"
7679	"^DD",364. 6,364.6,.0 3,1,4,"CRE ATE VALUE" )
7680	@
7681	"^DD",364. 6,364.6,.0 3,1,4,"DEL ETE VALUE" )
7682	NO EFFECT
7683	"^DD",364. 6,364.6,.0 3,1,4,"DT" )
7684	3000405
7685	"^DD",364. 6,364.6,.0 3,1,4,"FIE LD")
7686	STARTING C OLUMN
7687	"^DD",364. 6,364.6,.0 3,1,5,0)
7688	^^TRIGGER^ 364.6^.09
7689	"^DD",364. 6,364.6,.0 3,1,5,1)
7690	X ^DD(364. 6,.03,1,5, 1.3) I X S X=DIV S Y (1)=$S($D( ^IBA(364.6 ,D0,0)):^( 0),1:"") S X=$P(Y(1) ,U,9),X=X S DIU=X K Y S X="" X ^DD(364.6 ,.03,1,5,1 .4)
7691	"^DD",364. 6,364.6,.0 3,1,5,1.3)
7692	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X X ^DD(364.6 ,.03,1,5,6 9.2) S Y(1 01)=$S($D( ^IBE(353,D 0,2)):^(2) ,1:"") S X =$P($P(Y(1 02),$C(59) _$P(Y(101) ,U,2)_":", 2),$C(59), 1)'="BILLI NG SCREEN" S D0=I(0, 0)
7693	"^DD",364. 6,364.6,.0 3,1,5,1.4)
7694	S DIH=$S($ D(^IBA(364 .6,DIV(0), 0)):^(0),1 :""),DIV=X S $P(^(0) ,U,9)=DIV, DIH=364.6, DIG=.09 D ^DICR:$O(^ DD(DIH,DIG ,1,0))>0
7695	"^DD",364. 6,364.6,.0 3,1,5,2)
7696	Q
7697	"^DD",364. 6,364.6,.0 3,1,5,3)
7698	DO NOT DEL ETE
7699	"^DD",364. 6,364.6,.0 3,1,5,69.2 )
7700	S I(0,0)=$ S($D(D0):D 0,1:""),Y( 1)=$S($D(^ IBA(364.6, D0,0)):^(0 ),1:""),D0 =$P(Y(1),U ,1) S:'$D( ^IBE(353,+ D0,0)) D0= -1 S Y(102 )=$C(59)_$ S($D(^DD(3 53,2.02,0) ):$P(^(0), U,3),1:"")
7701	"^DD",364. 6,364.6,.0 3,1,5,"%D" ,0)
7702	^^2^2^3000 405^
7703	"^DD",364. 6,364.6,.0 3,1,5,"%D" ,1,0)
7704	If an asso ciated for m that is not a scre en form, l ength is t aken from the
7705	"^DD",364. 6,364.6,.0 3,1,5,"%D" ,2,0)
7706	associated with fiel d definiti on.
7707	"^DD",364. 6,364.6,.0 3,1,5,"CRE ATE CONDIT ION")
7708	BILL FORM: FORMAT TYP E'="BILLIN G SCREEN"
7709	"^DD",364. 6,364.6,.0 3,1,5,"CRE ATE VALUE" )
7710	@
7711	"^DD",364. 6,364.6,.0 3,1,5,"DEL ETE VALUE" )
7712	NO EFFECT
7713	"^DD",364. 6,364.6,.0 3,1,5,"DT" )
7714	3000405
7715	"^DD",364. 6,364.6,.0 3,1,5,"FIE LD")
7716	LENGTH
7717	"^DD",364. 6,364.6,.0 3,1,6,0)
7718	^^TRIGGER^ 364.6^.06
7719	"^DD",364. 6,364.6,.0 3,1,6,1)
7720	X ^DD(364. 6,.03,1,6, 1.3) I X S X=DIV S Y (1)=$S($D( ^IBA(364.6 ,D0,0)):^( 0),1:"") S X=$P(Y(1) ,U,6),X=X S DIU=X K Y S X="" X ^DD(364.6 ,.03,1,6,1 .4)
7721	"^DD",364. 6,364.6,.0 3,1,6,1.3)
7722	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X X ^DD(364.6 ,.03,1,6,6 9.2) S Y(1 01)=$S($D( ^IBE(353,D 0,2)):^(2) ,1:"") S X =$P($P(Y(1 02),$C(59) _$P(Y(101) ,U,2)_":", 2),$C(59), 1)'="BILLI NG SCREEN" S D0=I(0, 0)
7723	"^DD",364. 6,364.6,.0 3,1,6,1.4)
7724	S DIH=$S($ D(^IBA(364 .6,DIV(0), 0)):^(0),1 :""),DIV=X S $P(^(0) ,U,6)=DIV, DIH=364.6, DIG=.06 D ^DICR:$O(^ DD(DIH,DIG ,1,0))>0
7725	"^DD",364. 6,364.6,.0 3,1,6,2)
7726	Q
7727	"^DD",364. 6,364.6,.0 3,1,6,3)
7728	DO NOT DEL ETE
7729	"^DD",364. 6,364.6,.0 3,1,6,69.2 )
7730	S I(0,0)=$ S($D(D0):D 0,1:""),Y( 1)=$S($D(^ IBA(364.6, D0,0)):^(0 ),1:""),D0 =$P(Y(1),U ,1) S:'$D( ^IBE(353,+ D0,0)) D0= -1 S Y(102 )=$C(59)_$ S($D(^DD(3 53,2.02,0) ):$P(^(0), U,3),1:"")
7731	"^DD",364. 6,364.6,.0 3,1,6,"%D" ,0)
7732	^^2^2^3000 405^
7733	"^DD",364. 6,364.6,.0 3,1,6,"%D" ,1,0)
7734	If associa ted form t hat is not a screen form, the max number lines is taken
7735	"^DD",364. 6,364.6,.0 3,1,6,"%D" ,2,0)
7736	from the a ssociated with field definitio n.
7737	"^DD",364. 6,364.6,.0 3,1,6,"CRE ATE CONDIT ION")
7738	BILL FORM: FORMAT TYP E'="BILLIN G SCREEN"
7739	"^DD",364. 6,364.6,.0 3,1,6,"CRE ATE VALUE" )
7740	@
7741	"^DD",364. 6,364.6,.0 3,1,6,"DEL ETE VALUE" )
7742	NO EFFECT
7743	"^DD",364. 6,364.6,.0 3,1,6,"DT" )
7744	3000405
7745	"^DD",364. 6,364.6,.0 3,1,6,"FIE LD")
7746	MAX NUMBER LINES
7747	"^DD",364. 6,364.6,.0 3,1,7,0)
7748	^^TRIGGER^ 364.6^.02
7749	"^DD",364. 6,364.6,.0 3,1,7,1)
7750	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(1)=$S( $D(^IBA(36 4.6,D0,0)) :^(0),1:"" ) S X=$P(Y (1),U,2),X =X S DIU=X K Y S X=D IV S X="L" X ^DD(364 .6,.03,1,7 ,1.4)
7751	"^DD",364. 6,364.6,.0 3,1,7,1.4)
7752	S DIH=$S($ D(^IBA(364 .6,DIV(0), 0)):^(0),1 :""),DIV=X S $P(^(0) ,U,2)=DIV, DIH=364.6, DIG=.02 D ^DICR:$O(^ DD(DIH,DIG ,1,0))>0
7753	"^DD",364. 6,364.6,.0 3,1,7,2)
7754	Q
7755	"^DD",364. 6,364.6,.0 3,1,7,3)
7756	DO NOT DEL ETE
7757	"^DD",364. 6,364.6,.0 3,1,7,"%D" ,0)
7758	^^1^1^2960 117^
7759	"^DD",364. 6,364.6,.0 3,1,7,"%D" ,1,0)
7760	Only local entries c an be asso ciated.
7761	"^DD",364. 6,364.6,.0 3,1,7,"CRE ATE VALUE" )
7762	"L"
7763	"^DD",364. 6,364.6,.0 3,1,7,"DEL ETE VALUE" )
7764	NO EFFECT
7765	"^DD",364. 6,364.6,.0 3,1,7,"DT" )
7766	2960117
7767	"^DD",364. 6,364.6,.0 3,1,7,"FIE LD")
7768	SECURITY L EVEL
7769	"^DD",364. 6,364.6,.0 3,3)
7770	Enter the form defin ition reco rd this de finition w ill overri de.
7771	"^DD",364. 6,364.6,.0 3,5,1,0)
7772	364.6^.01^ 4
7773	"^DD",364. 6,364.6,.0 3,21,0)
7774	^^1^1^2960 117^^
7775	"^DD",364. 6,364.6,.0 3,21,1,0)
7776	The form d efinition record thi s definiti on will ov erride.
7777	"^DD",364. 6,364.6,.0 3,"DT")
7778	3000414
7779	"^DD",364. 6,364.6,.0 4,0)
7780	PAGE OR SE QUENCE^FXJ 20^^0;4^K: $L(X)>20!( $L(X)<1) X I $D(X),$ S($P($G(^I BE(353,+$G (^IBA(364. 6,+DA,0)), 2)),U,2)=" S":0,1:$P( $G(^IBA(36 4.6,DA,0)) ,U,3))!$$D UP^IBCEFG0 (DA,X,2) K X
7781	"^DD",364. 6,364.6,.0 4,1,0)
7782	^.1^^-1
7783	"^DD",364. 6,364.6,.0 4,1,1,0)
7784	364.6^ASEQ 1^MUMPS
7785	"^DD",364. 6,364.6,.0 4,1,1,1)
7786	N Z0,Z1,Z2 ,Z3 S Z0=$ G(^IBA(364 .6,DA,0)), Z1=+Z0,Z2= $P(Z0,U,5) ,Z3=$P(Z0, U,8) I Z1, Z2,Z3 S ^I BA(364.6," ASEQ",Z1,$ E(X,1,30), Z2,Z3,DA)= ""
7787	"^DD",364. 6,364.6,.0 4,1,1,2)
7788	N Z0,Z1,Z2 ,Z3 S Z0=$ G(^IBA(364 .6,DA,0)), Z1=+Z0,Z2= $P(Z0,U,5) ,Z3=$P(Z0, U,8) I Z1, Z2,Z3 K ^I BA(364.6," ASEQ",Z1,$ E(X,1,30), Z2,Z3,DA)
7789	"^DD",364. 6,364.6,.0 4,1,1,3)
7790	DO NOT DEL ETE
7791	"^DD",364. 6,364.6,.0 4,1,1,"%D" ,0)
7792	^^1^1^2960 117^
7793	"^DD",364. 6,364.6,.0 4,1,1,"%D" ,1,0)
7794	This xref contains t he sequenc e to use t o extract or print t he form fi elds.
7795	"^DD",364. 6,364.6,.0 4,1,1,"DT" )
7796	2960117
7797	"^DD",364. 6,364.6,.0 4,3)
7798	This data must be 1- 20 char lo ng, can't be an asso c form, an d must be a unique f orm/page/l ine/column .
7799	"^DD",364. 6,364.6,.0 4,5,1,0)
7800	364.6^.03^ 2
7801	"^DD",364. 6,364.6,.0 4,21,0)
7802	^^4^4^2960 318^^^^
7803	"^DD",364. 6,364.6,.0 4,21,1,0)
7804	This field is used t o specify the page, section, t ransaction segment, etc.
7805	"^DD",364. 6,364.6,.0 4,21,2,0)
7806	that the d ata elemen t is to be associate d with. T his field will be us ed as
7807	"^DD",364. 6,364.6,.0 4,21,3,0)
7808	the second -level sor t field wh en extract ing data f ields for this form.
7809	"^DD",364. 6,364.6,.0 4,21,4,0)
7810	The combin ation of f orm/page/l ine/column must be u nique.
7811	"^DD",364. 6,364.6,.0 4,"DT")
7812	3170509
7813	"^DD",364. 6,364.6,.0 5,0)
7814	FIRST LINE NUMBER^NJ 4,0X^^0;5^ K:+X'=X!(X >9999)!(X< 0)!(X?.E1" ."1N.N) X I $D(X),$S ($P($G(^IB E(353,+$G( ^IBA(364.6 ,+DA,0)),2 )),U,2)="S ":0,1:$P($ G(^IBA(364 .6,DA,0)), U,3))!$$DU P^IBCEFG0( DA,X,3) K X
7815	"^DD",364. 6,364.6,.0 5,.1)
7816	LINE
7817	"^DD",364. 6,364.6,.0 5,1,0)
7818	^.1
7819	"^DD",364. 6,364.6,.0 5,1,1,0)
7820	364.6^ASEQ 2^MUMPS
7821	"^DD",364. 6,364.6,.0 5,1,1,1)
7822	N Z0,Z1,Z2 ,Z3 S Z0=$ G(^IBA(364 .6,DA,0)), Z1=+Z0,Z2= $P(Z0,U,4) ,Z3=$P(Z0, U,8) I Z1, Z2'="",Z3 S ^IBA(364 .6,"ASEQ", Z1,Z2,$E(X ,1,30),Z3, DA)=""
7823	"^DD",364. 6,364.6,.0 5,1,1,2)
7824	N Z0,Z1,Z2 ,Z3 S Z0=$ G(^IBA(364 .6,DA,0)), Z1=+Z0,Z2= $P(Z0,U,4) ,Z3=$P(Z0, U,8) I Z1, Z2'="",Z3 K ^IBA(364 .6,"ASEQ", Z1,Z2,$E(X ,1,30),Z3, DA)
7825	"^DD",364. 6,364.6,.0 5,1,1,3)
7826	DO NOT DEL ETE
7827	"^DD",364. 6,364.6,.0 5,1,1,"%D" ,0)
7828	^^1^1^2960 117^^^^
7829	"^DD",364. 6,364.6,.0 5,1,1,"%D" ,1,0)
7830	This xref contains t he sequenc e to use t o extract or print t he form fi elds.
7831	"^DD",364. 6,364.6,.0 5,1,1,"DT" )
7832	2960117
7833	"^DD",364. 6,364.6,.0 5,3)
7834	Type a # 0 -9999, 0 D ecimals, c an't be as soc form, need uniqu e form/pg/ line/col.
7835	"^DD",364. 6,364.6,.0 5,5,1,0)
7836	364.6^.03^ 3
7837	"^DD",364. 6,364.6,.0 5,21,0)
7838	^^5^5^2960 318^^^
7839	"^DD",364. 6,364.6,.0 5,21,1,0)
7840	If this is a printed form, thi s is the f irst line number tha t this dat a
7841	"^DD",364. 6,364.6,.0 5,21,2,0)
7842	element wi ll appear on. For t ransmitted forms, th is is assu med to alw ays
7843	"^DD",364. 6,364.6,.0 5,21,3,0)
7844	be a 1. T his will b e used as the third- level sort field whe n extracti ng
7845	"^DD",364. 6,364.6,.0 5,21,4,0)
7846	data field s for this form. Th e combinat ion of for m/page/lin e/column m ust
7847	"^DD",364. 6,364.6,.0 5,21,5,0)
7848	be unique.
7849	"^DD",364. 6,364.6,.0 5,"DT")
7850	3000428
7851	"^DD",364. 6,364.6,.0 6,0)
7852	MAX NUMBER LINES^NJ3 ,0X^^0;6^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 1N.N) X I $D(X),$P($ G(^IBA(364 .6,DA,0)), U,3) K X
7853	"^DD",364. 6,364.6,.0 6,3)
7854	Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits (can't be an associa ted form).
7855	"^DD",364. 6,364.6,.0 6,5,1,0)
7856	364.6^.03^ 6
7857	"^DD",364. 6,364.6,.0 6,21,0)
7858	^^2^2^2951 205^
7859	"^DD",364. 6,364.6,.0 6,21,1,0)
7860	If a print ed form, t his is the highest n umbered li ne number that this data
7861	"^DD",364. 6,364.6,.0 6,21,2,0)
7862	element is allowed t o print on .
7863	"^DD",364. 6,364.6,.0 6,"DT")
7864	2960117
7865	"^DD",364. 6,364.6,.0 7,0)
7866	LOCAL OVER RIDE ALLOW ED^S^0:NO; 1:YES;^0;7 ^Q
7867	"^DD",364. 6,364.6,.0 7,3)
7868	Enter 0 (N O) to prev ent local override, 1 to allow local ove rride.
7869	"^DD",364. 6,364.6,.0 7,21,0)
7870	^.001^2^2^ 3020822^^
7871	"^DD",364. 6,364.6,.0 7,21,1,0)
7872	This contr ols whethe r or not t he output forms gene rator will allow for a
7873	"^DD",364. 6,364.6,.0 7,21,2,0)
7874	redefiniti on of this record vi a a local override.
7875	"^DD",364. 6,364.6,.0 7,"DT")
7876	2960311
7877	"^DD",364. 6,364.6,.0 8,0)
7878	STARTING C OLUMN OR P IECE^NJ3,1 X^^0;8^K:+ X'=X!(X>99 9)!(X<0)!( $S(X[".":X '?.E1"."1. 2N,1:0)) X I $D(X),$ S($P($G(^I BE(353,+$G (^IBA(364. 6,+DA,0)), 2)),U,2)=" S":0,1:$P( $G(^IBA(36 4.6,DA,0)) ,U,3))!$$D UP^IBCEFG0 (DA,X,4) K X
7879	"^DD",364. 6,364.6,.0 8,.1)
7880	COLUMN
7881	"^DD",364. 6,364.6,.0 8,1,0)
7882	^.1
7883	"^DD",364. 6,364.6,.0 8,1,1,0)
7884	364.6^ASEQ 3^MUMPS
7885	"^DD",364. 6,364.6,.0 8,1,1,1)
7886	N Z0,Z1,Z2 ,Z3 S Z0=$ G(^IBA(364 .6,DA,0)), Z1=+Z0,Z2= $P(Z0,U,4) ,Z3=$P(Z0, U,5) I Z1, Z2'="",Z3 S ^IBA(364 .6,"ASEQ", Z1,Z2,Z3,$ E(X,1,30), DA)=""
7887	"^DD",364. 6,364.6,.0 8,1,1,2)
7888	N Z0,Z1,Z2 ,Z3 S Z0=$ G(^IBA(364 .6,DA,0)), Z1=+Z0,Z2= $P(Z0,U,4) ,Z3=$P(Z0, U,5) I Z1, Z2'="",Z3 K ^IBA(364 .6,"ASEQ", Z1,Z2,Z3,$ E(X,1,30), DA)
7889	"^DD",364. 6,364.6,.0 8,1,1,3)
7890	DO NOT DEL ETE
7891	"^DD",364. 6,364.6,.0 8,1,1,"%D" ,0)
7892	^^1^1^2960 117^
7893	"^DD",364. 6,364.6,.0 8,1,1,"%D" ,1,0)
7894	This xref contains t he sequenc e to use t o extract or print t he form fi elds.
7895	"^DD",364. 6,364.6,.0 8,1,1,"DT" )
7896	2960117
7897	"^DD",364. 6,364.6,.0 8,1,2,0)
7898	^^TRIGGER^ 364.6^.11
7899	"^DD",364. 6,364.6,.0 8,1,2,1)
7900	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=Y(0)[". " I X S X= DIV S Y(1) =$S($D(^IB A(364.6,D0 ,0)):^(0), 1:"") S X= $P(Y(1),U, 11),X=X S DIU=X K Y S X=DIV S X=1 X ^DD( 364.6,.08, 1,2,1.4)
7901	"^DD",364. 6,364.6,.0 8,1,2,1.4)
7902	S DIH=$S($ D(^IBA(364 .6,DIV(0), 0)):^(0),1 :""),DIV=X S $P(^(0) ,U,11)=DIV ,DIH=364.6 ,DIG=.11 D ^DICR:$O( ^DD(DIH,DI G,1,0))>0
7903	"^DD",364. 6,364.6,.0 8,1,2,2)
7904	Q
7905	"^DD",364. 6,364.6,.0 8,1,2,3)
7906	DO NOT DEL ETE
7907	"^DD",364. 6,364.6,.0 8,1,2,"%D" ,0)
7908	^^2^2^2960 126^^^
7909	"^DD",364. 6,364.6,.0 8,1,2,"%D" ,1,0)
7910	If the sta rting colu mn or piec e is not a whole num ber, this must be a
7911	"^DD",364. 6,364.6,.0 8,1,2,"%D" ,2,0)
7912	calculate only field - no outp ut.
7913	"^DD",364. 6,364.6,.0 8,1,2,"CRE ATE CONDIT ION")
7914	STARTING C OLUMN OR P IECE["."
7915	"^DD",364. 6,364.6,.0 8,1,2,"CRE ATE VALUE" )
7916	S X=1
7917	"^DD",364. 6,364.6,.0 8,1,2,"DEL ETE VALUE" )
7918	NO EFFECT
7919	"^DD",364. 6,364.6,.0 8,1,2,"DT" )
7920	2960126
7921	"^DD",364. 6,364.6,.0 8,1,2,"FIE LD")
7922	#.11
7923	"^DD",364. 6,364.6,.0 8,3)
7924	Type a # 0 -9999, 1-2 Decimals, can't be assoc form , need uni que form/p g/line/col .
7925	"^DD",364. 6,364.6,.0 8,5,1,0)
7926	364.6^.03^ 4
7927	"^DD",364. 6,364.6,.0 8,21,0)
7928	^^5^5^2960 318^^^^
7929	"^DD",364. 6,364.6,.0 8,21,1,0)
7930	This is th e column o n the form , position in the da ta string (for non-p rinted
7931	"^DD",364. 6,364.6,.0 8,21,2,0)
7932	forms) - starting a t position 1, or del imited pie ce that th is data el ement
7933	"^DD",364. 6,364.6,.0 8,21,3,0)
7934	is to be p rinted or stored in. This wil l be used as the fou rth-level sort
7935	"^DD",364. 6,364.6,.0 8,21,4,0)
7936	field when extractin g data fie lds for th is form. The combin ation of
7937	"^DD",364. 6,364.6,.0 8,21,5,0)
7938	form/page/ line/colum n must be unique.
7939	"^DD",364. 6,364.6,.0 8,"DT")
7940	3000428
7941	"^DD",364. 6,364.6,.0 9,0)
7942	LENGTH^NJ3 ,0X^^0;9^K :+X'=X!(X> 250)!(X<1) !(X?.E1"." 1N.N) X I $D(X),$P($ G(^IBA(364 .6,DA,0)), U,3),$P($G (^IBE(353, +^IBA(364. 6,DA,0),2) ),U,2)'="S " K X
7943	"^DD",364. 6,364.6,.0 9,3)
7944	Type a Num ber betwee n 1 and 25 0, 0 Decim al Digits (can't be an associa ted form).
7945	"^DD",364. 6,364.6,.0 9,5,1,0)
7946	364.6^.03^ 5
7947	"^DD",364. 6,364.6,.0 9,21,0)
7948	^^3^3^2951 205^
7949	"^DD",364. 6,364.6,.0 9,21,1,0)
7950	The length desired f or the dat a element. If prese nt, this f ield will be used
7951	"^DD",364. 6,364.6,.0 9,21,2,0)
7952	to truncat e or pad t he data el ement to t his length after the element h as been
7953	"^DD",364. 6,364.6,.0 9,21,3,0)
7954	passed thr ough the r outine ide ntified in the FORMA T ROUTINE field.
7955	"^DD",364. 6,364.6,.0 9,"DT")
7956	3000111
7957	"^DD",364. 6,364.6,.1 ,0)
7958	SHORT DESC RIPTION^F^ ^0;10^K:$L (X)>40!($L (X)<1) X
7959	"^DD",364. 6,364.6,.1 ,1,0)
7960	^.1^^0
7961	"^DD",364. 6,364.6,.1 ,3)
7962	Answer mus t be 1-40 characters in length
7963	"^DD",364. 6,364.6,.1 ,21,0)
7964	^^2^2^3071 126^
7965	"^DD",364. 6,364.6,.1 ,21,1,0)
7966	This is a short desc ription of the field that is u sed as an identifier to
7967	"^DD",364. 6,364.6,.1 ,21,2,0)
7968	make looku ps on this file mean ingful.
7969	"^DD",364. 6,364.6,.1 ,"DT")
7970	3080310
7971	"^DD",364. 6,364.6,.1 1,0)
7972	CALCULATE ONLY OR OU TPUT^S^1:C ALCULATE O NLY;0:OUTP UT;^0;11^Q
7973	"^DD",364. 6,364.6,.1 1,3)
7974	Enter 1 if this fiel d is used for calcul ation purp oses and i s not mean t to be ou tput
7975	"^DD",364. 6,364.6,.1 1,5,1,0)
7976	364.6^.08^ 2
7977	"^DD",364. 6,364.6,.1 1,21,0)
7978	^^4^4^2960 715^^^^
7979	"^DD",364. 6,364.6,.1 1,21,1,0)
7980	This field is set to 1 if ther e is a nee d to do a special ex tract or
7981	"^DD",364. 6,364.6,.1 1,21,2,0)
7982	calculatio n at some point in t he process ing, but n o output i s desired
7983	"^DD",364. 6,364.6,.1 1,21,3,0)
7984	from the f ield's cod e executio n. Used t o set up a rrays for group elem ents
7985	"^DD",364. 6,364.6,.1 1,21,4,0)
7986	then the i ndividual elements a re output separately .
7987	"^DD",364. 6,364.6,.1 1,"DT")
7988	2960715
7989	"^DD",364. 6,364.6,.1 2,0)
7990	TRANSMIT I GNORES IF NULL^S^0:F ALSE;1:TRU E;^0;12^Q
7991	"^DD",364. 6,364.6,.1 2,3)
7992	Enter 1 (T RUE) if th ere should be no ent ry made in the outpu t global i f the data value of the elemen t is null.
7993	"^DD",364. 6,364.6,.1 2,21,0)
7994	^.001^5^5^ 3001030^^^
7995	"^DD",364. 6,364.6,.1 2,21,1,0)
7996	This field can be us ed to supp ress outpu t of a fie ld if its value is n ull.
7997	"^DD",364. 6,364.6,.1 2,21,2,0)
7998	If not sup pressed, a n entry is made in t he output global use d by the
7999	"^DD",364. 6,364.6,.1 2,21,3,0)
8000	formatter, regardles s of the c ontents of the data for this f ield.
8001	"^DD",364. 6,364.6,.1 2,21,4,0)
8002	Supressing the value results i n no outpu t to the f ormatter's output
8003	"^DD",364. 6,364.6,.1 2,21,5,0)
8004	global if the value of the dat a for this field is determined to be nul l.
8005	"^DD",364. 6,364.6,.1 2,"DT")
8006	2991006
8007	"^DD",364. 6,364.6,.1 3,0)
8008	DATA REQUI RED FOR FI ELD^S^1:YE S;0:NO;^0; 13^Q
8009	"^DD",364. 6,364.6,.1 3,3)
8010	Enter yes if there s hould alwa ys be data in this f ield.
8011	"^DD",364. 6,364.6,.1 3,21,0)
8012	^^2^2^3000 216^
8013	"^DD",364. 6,364.6,.1 3,21,1,0)
8014	This field is a flag that will stop the output of a record i f this fie ld
8015	"^DD",364. 6,364.6,.1 3,21,2,0)
8016	indicates data is re quired and the data extracted is null.
8017	"^DD",364. 6,364.6,.1 3,"DT")
8018	3000216
8019	"^DD",364. 7,364.7,0)
8020	FIELD^^3^1 2
8021	"^DD",364. 7,364.7,0, "DDA")
8022	N
8023	"^DD",364. 7,364.7,0, "DT")
8024	2960710
8025	"^DD",364. 7,364.7,0, "ID",.03)
8026	S %I=Y,Y=$ S('$D(^(0) ):"",$D(^I BA(364.5,+ $P(^(0),U, 3),0))#2:$ P(^(0),U,1 ),1:""),C= $P(^DD(364 .5,.01,0), U,2) D Y^D IQ:Y]"" W " ",Y,@( "$E("_DIC_ "%I,0),0)" ) S Y=%I K %I
8027	"^DD",364. 7,364.7,0, "IX","AINS ",364.7,.0 1)
8028
8029	"^DD",364. 7,364.7,0, "IX","AINS 1",364.7,. 05)
8030
8031	"^DD",364. 7,364.7,0, "IX","AINT YP",364.7, .01)
8032
8033	"^DD",364. 7,364.7,0, "IX","AINT YP1",364.7 ,.05)
8034
8035	"^DD",364. 7,364.7,0, "IX","AINT YP2",364.7 ,.06)
8036
8037	"^DD",364. 7,364.7,0, "IX","ATYP E",364.7,. 01)
8038
8039	"^DD",364. 7,364.7,0, "IX","ATYP E1",364.7, .06)
8040
8041	"^DD",364. 7,364.7,0, "IX","B",3 64.7,.01)
8042
8043	"^DD",364. 7,364.7,0, "IX","C",3 64.7,.03)
8044
8045	"^DD",364. 7,364.7,0, "NM","IB F ORM FIELD CONTENT")
8046
8047	"^DD",364. 7,364.7,0, "VRPK")
8048	IB
8049	"^DD",364. 7,364.7,.0 1,0)
8050	FORM FIELD REFERENCE ^RP364.6'^ IBA(364.6, ^0;1^Q
8051	"^DD",364. 7,364.7,.0 1,1,0)
8052	^.1
8053	"^DD",364. 7,364.7,.0 1,1,1,0)
8054	364.7^B
8055	"^DD",364. 7,364.7,.0 1,1,1,1)
8056	S ^IBA(364 .7,"B",$E( X,1,30),DA )=""
8057	"^DD",364. 7,364.7,.0 1,1,1,2)
8058	K ^IBA(364 .7,"B",$E( X,1,30),DA )
8059	"^DD",364. 7,364.7,.0 1,1,2,0)
8060	364.7^ATYP E^MUMPS
8061	"^DD",364. 7,364.7,.0 1,1,2,1)
8062	N Z1,Z0 S Z0=$G(^IBA (364.7,DA, 0)),Z1=$P( Z0,U,6) I Z1'="",$P( $G(^IBA(36 4.6,+X,0)) ,U,3),'$P( Z0,U,5) S ^IBA(364.7 ,"ATYPE",$ P(^IBA(364 .6,+X,0),U ,3),Z1,DA) =""
8063	"^DD",364. 7,364.7,.0 1,1,2,2)
8064	N Z0,Z1 S Z0=$G(^IBA (364.7,DA, 0)),Z1=$P( Z0,U,6) I Z1'="",$P( $G(^IBA(36 4.6,+X,0)) ,U,3) K ^I BA(364.7," ATYPE",$P( ^IBA(364.6 ,+X,0),U,3 ),Z1,DA)
8065	"^DD",364. 7,364.7,.0 1,1,2,3)
8066	DO NOT DEL ETE
8067	"^DD",364. 7,364.7,.0 1,1,2,"%D" ,0)
8068	^^1^1^2980 104^^^^
8069	"^DD",364. 7,364.7,.0 1,1,2,"%D" ,1,0)
8070	Xref by fo rm and bil l type
8071	"^DD",364. 7,364.7,.0 1,1,2,"DT" )
8072	2960117
8073	"^DD",364. 7,364.7,.0 1,1,3,0)
8074	364.7^AINT YP^MUMPS
8075	"^DD",364. 7,364.7,.0 1,1,3,1)
8076	N Z0,Z1,Z2 S Z0=$G(^ IBA(364.7, DA,0)),Z1= $P(Z0,U,5) ,Z2=$P(Z0, U,6) I Z1, Z2'="",$P( $G(^IBA(36 4.6,+X,0)) ,U,3) S ^I BA(364.7," AINTYP",$P (^IBA(364. 6,+X,0),U, 3),Z1,Z2,D A)=""
8077	"^DD",364. 7,364.7,.0 1,1,3,2)
8078	N Z0,Z1,Z2 S Z0=$G(^ IBA(364.7, DA,0)),Z1= $P(Z0,U,5) ,Z2=$P(Z0, U,6) I Z1, Z2'="",$P( $G(^IBA(36 4.6,+X,0)) ,U,3) K ^I BA(364.7," AINTYP",$P (^IBA(364. 6,+X,0),U, 3),Z1,Z2,D A)
8079	"^DD",364. 7,364.7,.0 1,1,3,3)
8080	DO NOT DEL ETE
8081	"^DD",364. 7,364.7,.0 1,1,3,"%D" ,0)
8082	^^1^1^2971 231^^^
8083	"^DD",364. 7,364.7,.0 1,1,3,"%D" ,1,0)
8084	Xref by fo rm, insura nce compan y and bill type
8085	"^DD",364. 7,364.7,.0 1,1,3,"DT" )
8086	2960117
8087	"^DD",364. 7,364.7,.0 1,1,4,0)
8088	364.7^AINS ^MUMPS
8089	"^DD",364. 7,364.7,.0 1,1,4,1)
8090	N Z0,Z1 S Z0=$G(^IBA (364.7,DA, 0)),Z1=$P( Z0,U,5) I Z1,$P($G(^ IBA(364.6, +X,0)),U,3 ),$P(Z0,U, 6)="" S ^I BA(364.7," AINS",$P(^ IBA(364.6, +X,0),U,3) ,Z1,DA)=""
8091	"^DD",364. 7,364.7,.0 1,1,4,2)
8092	N Z0,Z1 S Z0=$G(^IBA (364.7,DA, 0)),Z1=$P( Z0,U,5) I Z1,$P($G(^ IBA(364.6, +X,0)),U,3 ) K ^IBA(3 64.7,"AINS ",$P(^IBA( 364.6,+X,0 ),U,3),Z1, DA)
8093	"^DD",364. 7,364.7,.0 1,1,4,3)
8094	DO NOT DEL ETE
8095	"^DD",364. 7,364.7,.0 1,1,4,"%D" ,0)
8096	^^1^1^2971 231^^
8097	"^DD",364. 7,364.7,.0 1,1,4,"%D" ,1,0)
8098	Xref by fo rm field a nd insuran ce company
8099	"^DD",364. 7,364.7,.0 1,1,4,"DT" )
8100	2960118
8101	"^DD",364. 7,364.7,.0 1,3)
8102	Enter the billing fo rm that th is field i s associat ed with
8103	"^DD",364. 7,364.7,.0 1,21,0)
8104	^^2^2^3170 510^^^^
8105	"^DD",364. 7,364.7,.0 1,21,1,0)
8106	This is a pointer to the billi ng form fi eld that t his field is associa ted
8107	"^DD",364. 7,364.7,.0 1,21,2,0)
8108	with.
8109	"^DD",364. 7,364.7,.0 1,"DT")
8110	3170510
8111	"^DD",364. 7,364.7,.0 2,0)
8112	SECURITY L EVEL^S^N:N ATIONAL,NO EDIT;L:LO CAL;^0;2^Q
8113	"^DD",364. 7,364.7,.0 2,3)
8114	Enter N fo r national ly release d fields ( no edit) o r L for lo cally adde d fields.
8115	"^DD",364. 7,364.7,.0 2,21,0)
8116	^^3^3^2951 219^^^
8117	"^DD",364. 7,364.7,.0 2,21,1,0)
8118	This field determine s whether or not edi ting of th e entry is allowed. For
8119	"^DD",364. 7,364.7,.0 2,21,2,0)
8120	NATIONAL ( N) field, no local e diting is allowed. If LOCAL ( L) field i s
8121	"^DD",364. 7,364.7,.0 2,21,3,0)
8122	created, e diting is allowed.
8123	"^DD",364. 7,364.7,.0 2,"DT")
8124	3000428
8125	"^DD",364. 7,364.7,.0 3,0)
8126	DATA ELEME NT^P364.5' ^IBA(364.5 ,^0;3^Q
8127	"^DD",364. 7,364.7,.0 3,1,0)
8128	^.1
8129	"^DD",364. 7,364.7,.0 3,1,1,0)
8130	364.7^C
8131	"^DD",364. 7,364.7,.0 3,1,1,1)
8132	S ^IBA(364 .7,"C",$E( X,1,30),DA )=""
8133	"^DD",364. 7,364.7,.0 3,1,1,2)
8134	K ^IBA(364 .7,"C",$E( X,1,30),DA )
8135	"^DD",364. 7,364.7,.0 3,1,1,3)
8136	DO NOT DEL ETE
8137	"^DD",364. 7,364.7,.0 3,1,1,"%D" ,0)
8138	^^1^1^2960 702^
8139	"^DD",364. 7,364.7,.0 3,1,1,"%D" ,1,0)
8140	Xref by DA TA ELEMENT NAME
8141	"^DD",364. 7,364.7,.0 3,1,1,"DT" )
8142	2960702
8143	"^DD",364. 7,364.7,.0 3,3)
8144	Enter the data eleme nt that wi ll define this form field. If used on a screen, i t must be a fileman type.
8145	"^DD",364. 7,364.7,.0 3,21,0)
8146	^^1^1^2960 627^^^^
8147	"^DD",364. 7,364.7,.0 3,21,1,0)
8148	This ident ifies the data eleme nt that be extracted for this entry.
8149	"^DD",364. 7,364.7,.0 3,23,0)
8150	^^4^4^2960 627^^^^
8151	"^DD",364. 7,364.7,.0 3,23,1,0)
8152	This is th e data ele ment that will be al lowed to b e displaye d/edited o n a
8153	"^DD",364. 7,364.7,.0 3,23,2,0)
8154	screen, ex tracted fo r a transm it, or pri nted on a printed fo rm. If us ed on
8155	"^DD",364. 7,364.7,.0 3,23,3,0)
8156	a screen, the data e lement mus t be a fil eman type and a loca l field (> 10000
8157	"^DD",364. 7,364.7,.0 3,23,4,0)
8158	for ifn an d on a nod e >10000) to be edit able.
8159	"^DD",364. 7,364.7,.0 3,"DT")
8160	2960702
8161	"^DD",364. 7,364.7,.0 4,0)
8162	SCREEN PRO MPT^FX^^0; 4^K:$L(X)> 70!($L(X)< 1) X I $D( X),$P($G(^ IBE(353,+$ G(^IBA(364 .6,+$G(^IB A(364.7,DA ,0)),0)),2 )),U,2)'=" S" K X
8163	"^DD",364. 7,364.7,.0 4,.1)
8164
8165	"^DD",364. 7,364.7,.0 4,1,0)
8166	^.1^^0
8167	"^DD",364. 7,364.7,.0 4,3)
8168	Answer mus t be 1-70 characters in length .
8169	"^DD",364. 7,364.7,.0 4,21,0)
8170	3^^2^2^296 0321^^^^
8171	"^DD",364. 7,364.7,.0 4,21,1,0)
8172	This is us ed only by screen-ty pe forms t o place a prompt on the screen
8173	"^DD",364. 7,364.7,.0 4,21,2,0)
8174	for a part icular fie ld.
8175	"^DD",364. 7,364.7,.0 4,23,0)
8176	^^3^3^2960 321^^^^
8177	"^DD",364. 7,364.7,.0 4,23,1,0)
8178	This is th e prompt t hat will p receed the data elem ent define d for this
8179	"^DD",364. 7,364.7,.0 4,23,2,0)
8180	entry. If no data e lement, th is prompt will displ ay. This field is o nly
8181	"^DD",364. 7,364.7,.0 4,23,3,0)
8182	used for s creen-type forms.
8183	"^DD",364. 7,364.7,.0 4,"DT")
8184	2960321
8185	"^DD",364. 7,364.7,.0 5,0)
8186	INSURANCE COMPANY^P3 6'^DIC(36, ^0;5^Q
8187	"^DD",364. 7,364.7,.0 5,1,0)
8188	^.1
8189	"^DD",364. 7,364.7,.0 5,1,1,0)
8190	364.7^AINS 1^MUMPS
8191	"^DD",364. 7,364.7,.0 5,1,1,1)
8192	N Z0,Z1 S Z0=$G(^IBA (364.7,DA, 0)),Z1=$P( $G(^IBA(36 4.6,+Z0,0) ),U,3) I Z 1,$P(Z0,U, 6)="" S ^I BA(364.7," AINS",Z1,$ E(X,1,30), DA)=""
8193	"^DD",364. 7,364.7,.0 5,1,1,2)
8194	N Z0,Z1,Z2 S Z0=$G(^ IBA(364.7, DA,0)),Z1= $P($G(^IBA (364.6,+Z0 ,0)),U,3), Z2=$P(Z0,U ,6) K ^IBA (364.7,"AI NS",Z1,$E( X,1,30),DA ) I Z2'="" ,$D(^IBA(3 64.7,"AINT YP",Z1,X,Z 2,DA)) S ^ IBA(364.7, "ATYPE",Z1 ,Z2,DA)=""
8195	"^DD",364. 7,364.7,.0 5,1,1,3)
8196	DO NOT DEL ETE
8197	"^DD",364. 7,364.7,.0 5,1,1,"%D" ,0)
8198	^^1^1^2960 118^
8199	"^DD",364. 7,364.7,.0 5,1,1,"%D" ,1,0)
8200	Xref by fo rm field a nd insuran ce company .
8201	"^DD",364. 7,364.7,.0 5,1,1,"DT" )
8202	2960118
8203	"^DD",364. 7,364.7,.0 5,1,2,0)
8204	364.7^AINT YP1^MUMPS
8205	"^DD",364. 7,364.7,.0 5,1,2,1)
8206	N Z0,Z1,Z2 S Z0=$G(^ IBA(364.7, DA,0)),Z1= +$P($G(^IB A(364.6,+Z 0,0)),U,3) ,Z2=$P(Z0, U,6) I Z1, Z2'="" S ^ IBA(364.7, "AINTYP",Z 1,$E(X,1,3 0),Z2,DA)= "" K ^IBA( 364.7,"ATY PE",Z1,Z2, DA),^IBA(3 64.7,"AINS ",Z1,X,DA)
8207	"^DD",364. 7,364.7,.0 5,1,2,2)
8208	N Z0,Z1,Z2 S Z0=$G(^ IBA(364.7, DA,0)),Z1= +$P($G(^IB A(364.6,+Z 0,0)),U,3) ,Z2=$P(Z0, U,6) K:Z1& (Z2'="") ^ IBA(364.7, "AINTYP",Z 1,$E(X,1,3 0),Z2,DA)
8209	"^DD",364. 7,364.7,.0 5,1,2,3)
8210	DO NOT DEL ETE
8211	"^DD",364. 7,364.7,.0 5,1,2,"%D" ,0)
8212	^^1^1^2960 117^^^^
8213	"^DD",364. 7,364.7,.0 5,1,2,"%D" ,1,0)
8214	Xref by in surance co mpany and bill type
8215	"^DD",364. 7,364.7,.0 5,1,2,"DT" )
8216	2960117
8217	"^DD",364. 7,364.7,.0 5,3)
8218	Enter the name of th e insuranc e company that this field is a ssociated with.
8219	"^DD",364. 7,364.7,.0 5,21,0)
8220	^^2^2^2951 207^
8221	"^DD",364. 7,364.7,.0 5,21,1,0)
8222	This is th e insuranc e company who has a need for o ther than the standa rd
8223	"^DD",364. 7,364.7,.0 5,21,2,0)
8224	data in th is field.
8225	"^DD",364. 7,364.7,.0 5,"DT")
8226	3000428
8227	"^DD",364. 7,364.7,.0 6,0)
8228	BILL TYPE^ S^I:INPATI ENT;O:OUTP ATIENT;^0; 6^Q
8229	"^DD",364. 7,364.7,.0 6,1,0)
8230	^.1
8231	"^DD",364. 7,364.7,.0 6,1,1,0)
8232	364.7^ATYP E1^MUMPS
8233	"^DD",364. 7,364.7,.0 6,1,1,1)
8234	N Z0,Z1 S Z0=$G(^IBA (364.7,DA, 0)),Z1=$P( $G(^IBA(36 4.6,+Z0,0) ),U,3) I Z 1,'$P(Z0,U ,5) S ^IBA (364.7,"AT YPE",Z1,$E (X,1,30),D A)=""
8235	"^DD",364. 7,364.7,.0 6,1,1,2)
8236	N Z0,Z1,Z2 S Z0=$G(^ IBA(364.7, DA,0)),Z1= $P($G(^IBA (364.6,+Z0 ,0)),U,3), Z2=$P(Z0,U ,5) I Z1 K ^IBA(364. 7,"ATYPE", Z1,$E(X,1, 30),DA) I Z2,$D(^IBA (364.7,"AI NTYP",Z1,Z 2,X,DA)) S ^IBA(364. 7,"AINS",Z 1,Z2,DA)=" "
8237	"^DD",364. 7,364.7,.0 6,1,1,3)
8238	DO NOT DEL ETE
8239	"^DD",364. 7,364.7,.0 6,1,1,"%D" ,0)
8240	^^1^1^2960 117^^
8241	"^DD",364. 7,364.7,.0 6,1,1,"%D" ,1,0)
8242	Xref by fo rm and bil l type.
8243	"^DD",364. 7,364.7,.0 6,1,1,"DT" )
8244	2960117
8245	"^DD",364. 7,364.7,.0 6,1,2,0)
8246	364.7^AINT YP2^MUMPS
8247	"^DD",364. 7,364.7,.0 6,1,2,1)
8248	N Z0,Z1,Z2 S Z0=$G(^ IBA(364.7, DA,0)),Z1= +$P($G(^IB A(364.6,+Z 0,0)),U,3) ,Z2=$P(Z0, U,5) I Z1, Z2 K:'$D(^ IBA(364.7, "AINTYP",Z 1,Z2,X,DA) ) ^IBA(364 .7,"AINS", Z1,Z2,DA) S ^IBA(364 .7,"AINTYP ",Z1,Z2,$E (X,1,30),D A)=""
8249	"^DD",364. 7,364.7,.0 6,1,2,2)
8250	N Z0,Z1,Z2 S Z0=$G(^ IBA(364.7, DA,0)),Z1= +$P($G(^IB A(364.6,+Z 0,0)),U,3) ,Z2=$P(Z0, U,5) K:Z1& Z2 ^IBA(36 4.7,"AINTY P",Z1,Z2,$ E(X,1,30), DA)
8251	"^DD",364. 7,364.7,.0 6,1,2,3)
8252	DO NOT DEL ETE
8253	"^DD",364. 7,364.7,.0 6,1,2,"%D" ,0)
8254	^^1^1^2960 117^^^^
8255	"^DD",364. 7,364.7,.0 6,1,2,"%D" ,1,0)
8256	Xref by fo rm, insura nce compan y and bill type
8257	"^DD",364. 7,364.7,.0 6,1,2,"DT" )
8258	2960117
8259	"^DD",364. 7,364.7,.0 6,3)
8260	Enter the type of th e bill.
8261	"^DD",364. 7,364.7,.0 6,21,0)
8262	^^1^1^2960 117^^
8263	"^DD",364. 7,364.7,.0 6,21,1,0)
8264	This is th e type of bill that requires t his field.
8265	"^DD",364. 7,364.7,.0 6,"DT")
8266	3000428
8267	"^DD",364. 7,364.7,.0 7,0)
8268	PAD CHARAC TER^S^ZL:Z ERO PAD ON LEFT;ZR:Z ERO PAD ON RIGHT;SL: SPACE PAD ON LEFT;SR :SPACE PAD ON RIGHT; N:NO PAD R EQUIRED;^0 ;7^Q
8269	"^DD",364. 7,364.7,.0 7,3)
8270	Enter the code that correspond s to the f ormat and pad charac ter to use for the d ata output in this f ield.
8271	"^DD",364. 7,364.7,.0 7,21,0)
8272	^^3^3^2960 126^^
8273	"^DD",364. 7,364.7,.0 7,21,1,0)
8274	If present , this def ines the c haracter t o be used to pad the DATA
8275	"^DD",364. 7,364.7,.0 7,21,2,0)
8276	ELEMENT to its desir ed length and the or ientation of the pad ding chara cters
8277	"^DD",364. 7,364.7,.0 7,21,3,0)
8278	to the lef t or right of the da ta. The d efault is space pad to the rig ht.
8279	"^DD",364. 7,364.7,.0 7,"DT")
8280	2960126
8281	"^DD",364. 7,364.7,.0 8,0)
8282	REQUIRED^S ^0:NO;1:YE S;^0;8^Q
8283	"^DD",364. 7,364.7,.0 8,3)
8284	Enter 1 (Y ES) if thi s data ele ment is on a local s creen 9 fo rm and the data is r equired fo r the bill to be aut horized.
8285	"^DD",364. 7,364.7,.0 8,21,0)
8286	^.001^4^4^ 3001030^^
8287	"^DD",364. 7,364.7,.0 8,21,1,0)
8288	This field controls the requir ed/not req uired stat us of a da ta element
8289	"^DD",364. 7,364.7,.0 8,21,2,0)
8290	on a local screen 9 form. If this field is 1 (YES ), this da ta element
8291	"^DD",364. 7,364.7,.0 8,21,3,0)
8292	is always required t o have dat a (not nul l) in orde r for a bi ll to be
8293	"^DD",364. 7,364.7,.0 8,21,4,0)
8294	authorized .
8295	"^DD",364. 7,364.7,.0 8,"DT")
8296	2951207
8297	"^DD",364. 7,364.7,.0 9,0)
8298	EDIT STATU S^S^E:EDIT ABLE;D:DIS PLAY ONLY; ^0;9^Q
8299	"^DD",364. 7,364.7,.0 9,3)
8300	Enter 'E' to enable editing fo r this fie ld, 'D' fo r a displa y only fie ld.
8301	"^DD",364. 7,364.7,.0 9,21,0)
8302	^^2^2^2960 320^
8303	"^DD",364. 7,364.7,.0 9,21,1,0)
8304	This field is used t o control whether or not a dat a element on a scree n is
8305	"^DD",364. 7,364.7,.0 9,21,2,0)
8306	editable o r for disp lay-only p urposes.
8307	"^DD",364. 7,364.7,.0 9,"DT")
8308	2960320
8309	"^DD",364. 7,364.7,.1 ,0)
8310	EDIT GROUP NUMBER^NJ 2,0^^0;10^ K:+X'=X!(X >99)!(X<1) !(X?.E1"." 1N.N) X
8311	"^DD",364. 7,364.7,.1 ,3)
8312	Enter the edit grou p # that t his field will be in cluded in. Valid #' s are 1-99 .
8313	"^DD",364. 7,364.7,.1 ,21,0)
8314	^^6^6^2960 321^^
8315	"^DD",364. 7,364.7,.1 ,21,1,0)
8316	This field contains the # of t he edit gr oup that t he screen data eleme nt
8317	"^DD",364. 7,364.7,.1 ,21,2,0)
8318	will be in cluded wit h. When t his group # is selec ted on an edit scree n,
8319	"^DD",364. 7,364.7,.1 ,21,3,0)
8320	all data e lements as signed to this group # on this screen wi ll be pres ented
8321	"^DD",364. 7,364.7,.1 ,21,4,0)
8322	for editin g. If no # is enter ed here, t his field will not b e availabl e for
8323	"^DD",364. 7,364.7,.1 ,21,5,0)
8324	editing. This field will only apply to screen-typ e forms' e ditable da ta
8325	"^DD",364. 7,364.7,.1 ,21,6,0)
8326	element de scriptions .
8327	"^DD",364. 7,364.7,.1 ,"DT")
8328	2960321
8329	"^DD",364. 7,364.7,1, 0)
8330	FORMAT COD E^K^^1;E1, 245^K:$L(X )>245 X D: $D(X) ^DIM
8331	"^DD",364. 7,364.7,1, 3)
8332	This is St andard MUM PS code.
8333	"^DD",364. 7,364.7,1, 9)
8334	@
8335	"^DD",364. 7,364.7,1, 21,0)
8336	^.001^8^8^ 3170503^^
8337	"^DD",364. 7,364.7,1, 21,1,0)
8338	This is th e code tha t will be xecuted to format th e 'raw' da ta element
8339	"^DD",364. 7,364.7,1, 21,2,0)
8340	value that is return ed from th e executio n of the D ATA ELEMEN T's defini tion.
8341	"^DD",364. 7,364.7,1, 21,3,0)
8342	This code can assume the varia ble/array IBXDATA is available as input and
8343	"^DD",364. 7,364.7,1, 21,4,0)
8344	should set this vari able/array as its ou tput. Sta ndard call s for data
8345	"^DD",364. 7,364.7,1, 21,5,0)
8346	formatting have been provided. The vari ables IBXP G, IBXLN, IBXCOL are the
8347	"^DD",364. 7,364.7,1, 21,6,0)
8348	only IBX* variables that shoul d be chang ed in this routine. These rep resent
8349	"^DD",364. 7,364.7,1, 21,7,0)
8350	the page, line, colu mn as the first 3 le vels of su bscript fo r the outp ut
8351	"^DD",364. 7,364.7,1, 21,8,0)
8352	array.
8353	"^DD",364. 7,364.7,1, "DT")
8354	3170419
8355	"^DD",364. 7,364.7,3, 0)
8356	FORMAT COD E DESCRIPT ION^364.73 ^^3;0
8357	"^DD",364. 7,364.7,3, 21,0)
8358	^.001^1^1^ 3010102^^
8359	"^DD",364. 7,364.7,3, 21,1,0)
8360	This field describes the funct ion of the format co de entered .
8361	"^DD",364. 7,364.7,3, "DT")
8362	2960710
8363	"^DD",364. 7,364.73,0 )
8364	FORMAT COD E DESCRIPT ION SUB-FI ELD^^.01^1
8365	"^DD",364. 7,364.73,0 ,"DT")
8366	2960710
8367	"^DD",364. 7,364.73,0 ,"NM","FOR MAT CODE D ESCRIPTION ")
8368
8369	"^DD",364. 7,364.73,0 ,"UP")
8370	364.7
8371	"^DD",364. 7,364.73,. 01,0)
8372	FORMAT COD E DESCRIPT ION^W^^0;1 ^Q
8373	"^DD",364. 7,364.73,. 01,3)
8374	Enter a de scription of the pro cessing lo gic of the format co de.
8375	"^DD",364. 7,364.73,. 01,21,0)
8376	^.001^1^1^ 3010102^^^ ^
8377	"^DD",364. 7,364.73,. 01,21,1,0)
8378	This is a descriptio n of the p rocessing logic of t he format code.
8379	"^DD",364. 7,364.73,. 01,"DT")
8380	2960710
8381	"^DD",399, 399,.21,0)
8382	CURRENT BI LL PAYER S EQUENCE^*S ^P:PRIMARY INSURANCE ;S:SECONDA RY INSURAN CE;T:TERTI ARY INSURA NCE;A:PATI ENT;^0;21^ Q
8383	"^DD",399, 399,.21,1, 0)
8384	^.1
8385	"^DD",399, 399,.21,1, 1,0)
8386	^^TRIGGER^ 399^136
8387	"^DD",399, 399,.21,1, 1,1)
8388	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(1)=$S( $D(^DGCR(3 99,D0,"MP" )):^("MP") ,1:"") S X =$P(Y(1),U ,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IB CNS2(DA) X ^DD(399,. 21,1,1,1.4 )
8389	"^DD",399, 399,.21,1, 1,1.4)
8390	S DIH=$S($ D(^DGCR(39 9,DIV(0)," MP")):^("M P"),1:""), DIV=X S $P (^("MP"),U ,2)=DIV,DI H=399,DIG= 136 D ^DIC R
8391	"^DD",399, 399,.21,1, 1,2)
8392	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(1)=$S( $D(^DGCR(3 99,D0,"MP" )):^("MP") ,1:"") S X =$P(Y(1),U ,2),X=X S DIU=X K Y S X="" X ^ DD(399,.21 ,1,1,2.4)
8393	"^DD",399, 399,.21,1, 1,2.4)
8394	S DIH=$S($ D(^DGCR(39 9,DIV(0)," MP")):^("M P"),1:""), DIV=X S $P (^("MP"),U ,2)=DIV,DI H=399,DIG= 136 D ^DIC R
8395	"^DD",399, 399,.21,1, 1,"%D",0)
8396	^^2^2^2970 821^
8397	"^DD",399, 399,.21,1, 1,"%D",1,0 )
8398	Set the Bi ll Payer P olicy to t he Payer P olicy corr esponding to the Pay er
8399	"^DD",399, 399,.21,1, 1,"%D",2,0 )
8400	Sequence.
8401	"^DD",399, 399,.21,1, 1,"CREATE VALUE")
8402	S X=$$BPP^ IBCNS2(DA)
8403	"^DD",399, 399,.21,1, 1,"DELETE VALUE")
8404	@
8405	"^DD",399, 399,.21,1, 1,"DT")
8406	2970821
8407	"^DD",399, 399,.21,1, 1,"FIELD")
8408	BILL PAYER POLICY
8409	"^DD",399, 399,.21,1, 2,0)
8410	^^TRIGGER^ 399^24
8411	"^DD",399, 399,.21,1, 2,1)
8412	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=('$$REQ MRA^IBEFUN C(DA)&$$NE EDMRA^IBEF UNC(DA)) I X S X=DIV S Y(1)=$S ($D(^DGCR( 399,D0,"TX ")):^("TX" ),1:"") S X=$P(Y(1), U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD (399,.21,1 ,2,1.4)
8413	"^DD",399, 399,.21,1, 2,1.4)
8414	S DIH=$G(^ DGCR(399,D IV(0),"TX" )),DIV=X S $P(^("TX" ),U,5)=DIV ,DIH=399,D IG=24 D ^D ICR
8415	"^DD",399, 399,.21,1, 2,2)
8416	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=('$$REQ MRA^IBEFUN C(DA)&$$NE EDMRA^IBEF UNC(DA)) I X S X=DIV S Y(1)=$S ($D(^DGCR( 399,D0,"TX ")):^("TX" ),1:"") S X=$P(Y(1), U,5),X=X S DIU=X K Y S X="" X ^DD(399,.2 1,1,2,2.4)
8417	"^DD",399, 399,.21,1, 2,2.4)
8418	S DIH=$G(^ DGCR(399,D IV(0),"TX" )),DIV=X S $P(^("TX" ),U,5)=DIV ,DIH=399,D IG=24 D ^D ICR
8419	"^DD",399, 399,.21,1, 2,"%D",0)
8420	^^4^4^3041 108^
8421	"^DD",399, 399,.21,1, 2,"%D",1,0 )
8422	When the p ayer seque nce change s, this tr igger will detect if an MRA is no
8423	"^DD",399, 399,.21,1, 2,"%D",2,0 )
8424	longer nee ded, but t he CLAIM M RA STATUS field stil l indicate s than an MRA
8425	"^DD",399, 399,.21,1, 2,"%D",3,0 )
8426	is still n eeded. In this case , the CLAI M MRA STAT US is upda ted to be 0 -
8427	"^DD",399, 399,.21,1, 2,"%D",4,0 )
8428	NO MRA NEE DED.
8429	"^DD",399, 399,.21,1, 2,"CREATE CONDITION" )
8430	('$$REQMRA ^IBEFUNC(D A)&$$NEEDM RA^IBEFUNC (DA))
8431	"^DD",399, 399,.21,1, 2,"CREATE VALUE")
8432	S X=0
8433	"^DD",399, 399,.21,1, 2,"DELETE CONDITION" )
8434	('$$REQMRA ^IBEFUNC(D A)&$$NEEDM RA^IBEFUNC (DA))
8435	"^DD",399, 399,.21,1, 2,"DELETE VALUE")
8436	@
8437	"^DD",399, 399,.21,1, 2,"DT")
8438	3041108
8439	"^DD",399, 399,.21,1, 2,"FIELD")
8440	CLAIM MRA STATUS
8441	"^DD",399, 399,.21,1, 3,0)
8442	^^TRIGGER^ 399^27
8443	"^DD",399, 399,.21,1, 3,1)
8444	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=$S($$WN RBILL^IBEF UNC(DA,X): 1,1:0) I X S X=DIV S Y(1)=$S($ D(^DGCR(39 9,D0,"TX") ):^("TX"), 1:"") S X= $P(Y(1),U, 8),X=X S D IU=X K Y S X="" X ^D D(399,.21, 1,3,1.4)
8445	"^DD",399, 399,.21,1, 3,1.4)
8446	S DIH=$G(^ DGCR(399,D IV(0),"TX" )),DIV=X S $P(^("TX" ),U,8)=DIV ,DIH=399,D IG=27 D ^D ICR
8447	"^DD",399, 399,.21,1, 3,2)
8448	Q
8449	"^DD",399, 399,.21,1, 3,3)
8450	Do not del ete
8451	"^DD",399, 399,.21,1, 3,"%D",0)
8452	^.101^3^3^ 3101115^^
8453	"^DD",399, 399,.21,1, 3,"%D",1,0 )
8454	If the ins urance for the payer sequence is MEDICAR E WNR, the
8455	"^DD",399, 399,.21,1, 3,"%D",2,0 )
8456	data in fi eld FORCE CLAIM TO P RINT must be deleted as it is not valid
8457	"^DD",399, 399,.21,1, 3,"%D",3,0 )
8458	to print a n MRA requ est.
8459	"^DD",399, 399,.21,1, 3,"CREATE CONDITION" )
8460	S X=$S($$W NRBILL^IBE FUNC(DA,X) :1,1:0)
8461	"^DD",399, 399,.21,1, 3,"CREATE VALUE")
8462	@
8463	"^DD",399, 399,.21,1, 3,"DELETE VALUE")
8464	NO EFFECT
8465	"^DD",399, 399,.21,1, 3,"DT")
8466	3041119
8467	"^DD",399, 399,.21,1, 3,"FIELD")
8468	FORCE CLAI M TO PRINT
8469	"^DD",399, 399,.21,1, 4,0)
8470	^^TRIGGER^ 399^27
8471	"^DD",399, 399,.21,1, 4,1)
8472	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=$$CREAT E^IBCEF84( DA) I X S X=DIV S Y( 1)=$S($D(^ DGCR(399,D 0,"TX")):^ ("TX"),1:" ") S X=$P( Y(1),U,8), X=X S DIU= X K Y S X= DIV S X=1 X ^DD(399, .21,1,4,1. 4)
8473	"^DD",399, 399,.21,1, 4,1.4)
8474	S DIH=$G(^ DGCR(399,D IV(0),"TX" )),DIV=X S $P(^("TX" ),U,8)=DIV ,DIH=399,D IG=27 D ^D ICR
8475	"^DD",399, 399,.21,1, 4,2)
8476	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=$$DELET E^IBCEF84( DA) I X S X=DIV S Y( 1)=$S($D(^ DGCR(399,D 0,"TX")):^ ("TX"),1:" ") S X=$P( Y(1),U,8), X=X S DIU= X K Y S X= "" X ^DD(3 99,.21,1,4 ,2.4)
8477	"^DD",399, 399,.21,1, 4,2.4)
8478	S DIH=$G(^ DGCR(399,D IV(0),"TX" )),DIV=X S $P(^("TX" ),U,8)=DIV ,DIH=399,D IG=27 D ^D ICR
8479	"^DD",399, 399,.21,1, 4,"%D",0)
8480	^^6^6^3101 129^
8481	"^DD",399, 399,.21,1, 4,"%D",1,0 )
8482	This trigg er is desi gned to se t the FORC E CLAIM TO PRINT fie ld 27 equa l
8483	"^DD",399, 399,.21,1, 4,"%D",2,0 )
8484	to 1 for S ECONDARY M EDICARE WN R claims i f the carr ier field PRINT SEC MED
8485	"^DD",399, 399,.21,1, 4,"%D",3,0 )
8486	CLAIMS W/O MRA, 6.1 is set.
8487	"^DD",399, 399,.21,1, 4,"%D",4,0 )
8488	If the cur rent value of field 27, FORCE CLAIM TO P RINT is eq ual to 1, and
8489	"^DD",399, 399,.21,1, 4,"%D",5,0 )
8490	field .21, CURRENT B ILL PAYER SEQUENCE i s changed to somethi ng other t han
8491	"^DD",399, 399,.21,1, 4,"%D",6,0 )
8492	"S", then the value in field 2 7, FORCE C LAIM TO PR INT, is de leted.
8493	"^DD",399, 399,.21,1, 4,"CREATE CONDITION" )
8494	S X=$$CREA TE^IBCEF84 (DA)
8495	"^DD",399, 399,.21,1, 4,"CREATE VALUE")
8496	S X=1
8497	"^DD",399, 399,.21,1, 4,"DELETE CONDITION" )
8498	S X=$$DELE TE^IBCEF84 (DA)
8499	"^DD",399, 399,.21,1, 4,"DELETE VALUE")
8500	@
8501	"^DD",399, 399,.21,1, 4,"DT")
8502	3101128
8503	"^DD",399, 399,.21,1, 4,"FIELD")
8504	FORCE CLAI M TO PRINT
8505	"^DD",399, 399,.21,1, 5,0)
8506	^^TRIGGER^ 399^125
8507	"^DD",399, 399,.21,1, 5,1)
8508	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=Y(0),X= X S X=X="P " I X S X= DIV S Y(1) =$S($D(^DG CR(399,D0, "M1")):^(" M1"),1:"") S X=$P(Y( 1),U,5),X= X S DIU=X K Y S X="" X ^DD(399 ,.21,1,5,1 .4)
8509	"^DD",399, 399,.21,1, 5,1.4)
8510	S DIH=$G(^ DGCR(399,D IV(0),"M1" )),DIV=X S $P(^("M1" ),U,5)=DIV ,DIH=399,D IG=125 D ^ DICR
8511	"^DD",399, 399,.21,1, 5,2)
8512	Q
8513	"^DD",399, 399,.21,1, 5,"%D",0)
8514	^^3^3^3170 417^
8515	"^DD",399, 399,.21,1, 5,"%D",1,0 )
8516	This TRIGG ER removes the PRIMA RY BILL # when the C URRENT BIL L PAYER
8517	"^DD",399, 399,.21,1, 5,"%D",2,0 )
8518	SEQUENCE i s set to " P"rimary t o prevent COB inform ation from subsequen t
8519	"^DD",399, 399,.21,1, 5,"%D",3,0 )
8520	claims bei ng placed on the 837 claims tr ansmission .
8521	"^DD",399, 399,.21,1, 5,"CREATE CONDITION" )
8522	INTERNAL(C URRENT BIL L PAYER SE QUENCE)="P "
8523	"^DD",399, 399,.21,1, 5,"CREATE VALUE")
8524	@
8525	"^DD",399, 399,.21,1, 5,"DELETE VALUE")
8526	NO EFFECT
8527	"^DD",399, 399,.21,1, 5,"DT")
8528	3170417
8529	"^DD",399, 399,.21,1, 5,"FIELD")
8530	PRIMARY BI LL #
8531	"^DD",399, 399,.21,1, 6,0)
8532	^^TRIGGER^ 399^126
8533	"^DD",399, 399,.21,1, 6,1)
8534	X ^DD(399, .21,1,6,1. 3) I X S X =DIV S Y(1 )=$S($D(^D GCR(399,D0 ,"M1")):^( "M1"),1:"" ) S X=$P(Y (1),U,6),X =X S DIU=X K Y S X=" " S DIH=$G (^DGCR(399 ,DIV(0),"M 1")),DIV=X S $P(^("M 1"),U,6)=D IV,DIH=399 ,DIG=126 D ^DICR
8535	"^DD",399, 399,.21,1, 6,1.3)
8536	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=Y(0),X= X S X=X="P ",Y(1)=$G( X),Y(2)=$G (X) S X=Y( 0),X=X S X =X="S",Y=X ,X=Y(1),X= X!Y
8537	"^DD",399, 399,.21,1, 6,2)
8538	Q
8539	"^DD",399, 399,.21,1, 6,"%D",0)
8540	^^4^4^3170 417^
8541	"^DD",399, 399,.21,1, 6,"%D",1,0 )
8542	This TRIGG ER removes the SECON DARY BILL # when the CURRENT B ILL PAYER
8543	"^DD",399, 399,.21,1, 6,"%D",2,0 )
8544	SEQUENCE i s set to e ither "P"r imary or " S"econdary to preven t COB
8545	"^DD",399, 399,.21,1, 6,"%D",3,0 )
8546	informatio n from sub sequent cl aims being placed on the 837 c laims
8547	"^DD",399, 399,.21,1, 6,"%D",4,0 )
8548	transmissi on.
8549	"^DD",399, 399,.21,1, 6,"CREATE CONDITION" )
8550	INTERNAL(C URRENT BIL L PAYER SE QUENCE)="P "!(INTERNA L(CURRENT BILL PAYER SEQUENCE) ="S")
8551	"^DD",399, 399,.21,1, 6,"CREATE VALUE")
8552	@
8553	"^DD",399, 399,.21,1, 6,"DELETE VALUE")
8554	NO EFFECT
8555	"^DD",399, 399,.21,1, 6,"DT")
8556	3170417
8557	"^DD",399, 399,.21,1, 6,"FIELD")
8558	SECONDARY BILL #
8559	"^DD",399, 399,.21,1, 7,0)
8560	^^TRIGGER^ 399^127
8561	"^DD",399, 399,.21,1, 7,1)
8562	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(1)=$S( $D(^DGCR(3 99,D0,"M1" )):^("M1") ,1:"") S X =$P(Y(1),U ,7),X=X S DIU=X K Y S X="" S D IH=$G(^DGC R(399,DIV( 0),"M1")), DIV=X S $P (^("M1"),U ,7)=DIV,DI H=399,DIG= 127 D ^DIC R
8563	"^DD",399, 399,.21,1, 7,2)
8564	Q
8565	"^DD",399, 399,.21,1, 7,"%D",0)
8566	^^4^4^3170 417^
8567	"^DD",399, 399,.21,1, 7,"%D",1,0 )
8568	This TRIGG ER removes the TERTI ARY BILL # when the CURRENT BI LL PAYER
8569	"^DD",399, 399,.21,1, 7,"%D",2,0 )
8570	SEQUENCE i s set to e ither "P"r imary, "S" econdary o r "T"ertia ry to prev ent
8571	"^DD",399, 399,.21,1, 7,"%D",3,0 )
8572	COB inform ation from subsequen t claims b eing place d on the 8 37 claims
8573	"^DD",399, 399,.21,1, 7,"%D",4,0 )
8574	transmissi on.
8575	"^DD",399, 399,.21,1, 7,"CREATE VALUE")
8576	@
8577	"^DD",399, 399,.21,1, 7,"DELETE VALUE")
8578	NO EFFECT
8579	"^DD",399, 399,.21,1, 7,"DT")
8580	3170417
8581	"^DD",399, 399,.21,1, 7,"FIELD")
8582	TERTIARY B ILL #
8583	"^DD",399, 399,.21,1, 8,0)
8584	^^TRIGGER^ 399^218
8585	"^DD",399, 399,.21,1, 8,1)
8586	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=Y(0),X= X S X=X="P " I X S X= DIV S Y(1) =$S($D(^DG CR(399,D0, "U2")):^(" U2"),1:"") S X=$P(Y( 1),U,4),X= X S DIU=X K Y S X="" X ^DD(399 ,.21,1,8,1 .4)
8587	"^DD",399, 399,.21,1, 8,1.4)
8588	S DIH=$G(^ DGCR(399,D IV(0),"U2" )),DIV=X S $P(^("U2" ),U,4)=DIV ,DIH=399,D IG=218 D ^ DICR
8589	"^DD",399, 399,.21,1, 8,2)
8590	Q
8591	"^DD",399, 399,.21,1, 8,"%D",0)
8592	^^4^4^3170 418^
8593	"^DD",399, 399,.21,1, 8,"%D",1,0 )
8594	This TRIGG ER removes the PRIMA RY PRIOR P AYMENT whe n the CURR ENT BILL
8595	"^DD",399, 399,.21,1, 8,"%D",2,0 )
8596	PAYER SEQU ENCE is se t to "P"ri mary to pr operly adj ust the ca lculation of
8597	"^DD",399, 399,.21,1, 8,"%D",3,0 )
8598	the OFFSET AMOUNT fo r subseque nt claims being plac ed on the 837 claims
8599	"^DD",399, 399,.21,1, 8,"%D",4,0 )
8600	tranmissio n.
8601	"^DD",399, 399,.21,1, 8,"CREATE CONDITION" )
8602	INTERNAL(C URRENT BIL L PAYER SE QUENCE)="P "
8603	"^DD",399, 399,.21,1, 8,"CREATE VALUE")
8604	@
8605	"^DD",399, 399,.21,1, 8,"DELETE VALUE")
8606	NO EFFECT
8607	"^DD",399, 399,.21,1, 8,"DT")
8608	3170418
8609	"^DD",399, 399,.21,1, 8,"FIELD")
8610	PRIMARY PR IOR PAYMEN T
8611	"^DD",399, 399,.21,1, 9,0)
8612	^^TRIGGER^ 399^219
8613	"^DD",399, 399,.21,1, 9,1)
8614	X ^DD(399, .21,1,9,1. 3) I X S X =DIV S Y(1 )=$S($D(^D GCR(399,D0 ,"U2")):^( "U2"),1:"" ) S X=$P(Y (1),U,5),X =X S DIU=X K Y S X=" " S DIH=$G (^DGCR(399 ,DIV(0),"U 2")),DIV=X S $P(^("U 2"),U,5)=D IV,DIH=399 ,DIG=219 D ^DICR
8615	"^DD",399, 399,.21,1, 9,1.3)
8616	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S X=Y(0),X= X S X=X="P ",Y(1)=$G( X),Y(2)=$G (X) S X=Y( 0),X=X S X =X="S",Y=X ,X=Y(1),X= X!Y
8617	"^DD",399, 399,.21,1, 9,2)
8618	Q
8619	"^DD",399, 399,.21,1, 9,"%D",0)
8620	^.101^4^4^ 3170418^^
8621	"^DD",399, 399,.21,1, 9,"%D",1,0 )
8622	This TRIGG ER removes the SECON DARY PRIOR PAYMENT w hen the CU RRENT BILL
8623	"^DD",399, 399,.21,1, 9,"%D",2,0 )
8624	PAYER SEQU ENCE is se t to "P"ri mary or "S "econdary to properl y adjust t he
8625	"^DD",399, 399,.21,1, 9,"%D",3,0 )
8626	calculatio n of the O FFSET AMOU NT for sub sequent cl aims being placed on
8627	"^DD",399, 399,.21,1, 9,"%D",4,0 )
8628	the 837 cl aims trans mission.
8629	"^DD",399, 399,.21,1, 9,"CREATE CONDITION" )
8630	INTERNAL(C URRENT BIL L PAYER SE QUENCE)="P "!(INTERNA L(CURRENT BILL PAYER SEQUENCE) ="S")
8631	"^DD",399, 399,.21,1, 9,"CREATE VALUE")
8632	@
8633	"^DD",399, 399,.21,1, 9,"DELETE VALUE")
8634	NO EFFECT
8635	"^DD",399, 399,.21,1, 9,"DT")
8636	3170418
8637	"^DD",399, 399,.21,1, 9,"FIELD")
8638	SECONDARY PRIOR PAYM ENT
8639	"^DD",399, 399,.21,1, 10,0)
8640	^^TRIGGER^ 399^220
8641	"^DD",399, 399,.21,1, 10,1)
8642	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(1)=$S( $D(^DGCR(3 99,D0,"U2" )):^("U2") ,1:"") S X =$P(Y(1),U ,6),X=X S DIU=X K Y S X="" S D IH=$G(^DGC R(399,DIV( 0),"U2")), DIV=X S $P (^("U2"),U ,6)=DIV,DI H=399,DIG= 220 D ^DIC R
8643	"^DD",399, 399,.21,1, 10,2)
8644	Q
8645	"^DD",399, 399,.21,1, 10,"%D",0)
8646	^^4^4^3170 418^
8647	"^DD",399, 399,.21,1, 10,"%D",1, 0)
8648	This TRIGG ER removes the TERTI ARY PRIOR PAYMENT wh en the CUR RENT BILL
8649	"^DD",399, 399,.21,1, 10,"%D",2, 0)
8650	PAYER SEQU ENCE is se t to "P"ri mary, "S"e condary or "T"ertiar y to prope rly
8651	"^DD",399, 399,.21,1, 10,"%D",3, 0)
8652	adjust the calculati on of the OFFSET AMO UNT for su bsequent c laims bein g
8653	"^DD",399, 399,.21,1, 10,"%D",4, 0)
8654	placed on the 837 cl aims trans mission.
8655	"^DD",399, 399,.21,1, 10,"CREATE VALUE")
8656	@
8657	"^DD",399, 399,.21,1, 10,"DELETE VALUE")
8658	NO EFFECT
8659	"^DD",399, 399,.21,1, 10,"DT")
8660	3170418
8661	"^DD",399, 399,.21,1, 10,"FIELD" )
8662	TERTIARY P RIOR PAYME NT
8663	"^DD",399, 399,.21,3)
8664	Enter the entity cur rently res ponsible f or paying this bill.
8665	"^DD",399, 399,.21,5, 1,0)
8666	399^.11^4
8667	"^DD",399, 399,.21,12 )
8668	Primary/Se condary/Te rtiary mus t have cor responding insurance co on bil l.
8669	"^DD",399, 399,.21,12 .1)
8670	S DIC("S") ="I $S(X=" "P"":$D(^D GCR(399,DA ,""I1"")), X=""S"":$D (^DGCR(399 ,DA,""I2"" )),X=""T"" :$D(^DGCR( 399,DA,""I 3"")),1:1) "
8671	"^DD",399, 399,.21,21 ,0)
8672	^.001^1^1^ 3170302^^^ ^
8673	"^DD",399, 399,.21,21 ,1,0)
8674	This field determine s the enti ty current ly respons ible for p aying this bill.
8675	"^DD",399, 399,.21,"D T")
8676	3170418
8677	"^DD",399, 399,163,0)
8678	TREATMENT AUTHORIZAT ION CODE^F J50^^U;13^ K:$L(X)>50 !($L(X)<1) X
8679	"^DD",399, 399,163,3)
8680	Answer mus t be 1-50 characters in length .
8681	"^DD",399, 399,163,5, 1,0)
8682	399^112^4
8683	"^DD",399, 399,163,21 ,0)
8684	^.001^5^5^ 3170330^^
8685	"^DD",399, 399,163,21 ,1,0)
8686	This indic ates that the treatm ent covere d by this bill has b een
8687	"^DD",399, 399,163,21 ,2,0)
8688	authorized by the pr imary paye r.
8689	"^DD",399, 399,163,21 ,3,0)
8690
8691	"^DD",399, 399,163,21 ,4,0)
8692	On the CMS -1500 this is box 23 , PRIOR AU THORIZATIO N NUMBER.
8693	"^DD",399, 399,163,21 ,5,0)
8694	On the UB- 04, this i s reported in FL63.
8695	"^DD",399, 399,163,"D T")
8696	3170427
8697	"^DD",399, 399,202,0)
8698	OFFSET AMO UNT^NJ8,2^ ^U1;2^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 99)!(X<0) X
8699	"^DD",399, 399,202,1, 0)
8700	^.1
8701	"^DD",399, 399,202,1, 1,0)
8702	^^TRIGGER^ 399^203
8703	"^DD",399, 399,202,1, 1,1)
8704	Q
8705	"^DD",399, 399,202,1, 1,2)
8706	X ^DD(399, 202,1,1,2. 3) I X S X =DIV S Y(1 )=$S($D(^D GCR(399,D0 ,"U1")):^( "U1"),1:"" ) S X=$P(Y (1),U,3),X =X S DIU=X K Y S X=" " S DIH=$G (^DGCR(399 ,DIV(0),"U 1")),DIV=X S $P(^("U 1"),U,3)=D IV,DIH=399 ,DIG=203 D ^DICR
8707	"^DD",399, 399,202,1, 1,2.3)
8708	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S Y(1)=$S($ D(^DGCR(39 9,D0,"U1") ):^("U1"), 1:"") S X= $P(Y(1),U, 2)="",Y(2) =$G(X) S X =$P(Y(1),U ,2)=0,Y=X, X=Y(2),X=X !Y
8709	"^DD",399, 399,202,1, 1,"%D",0)
8710	^^2^2^3170 418^
8711	"^DD",399, 399,202,1, 1,"%D",1,0 )
8712	When the O FFSET AMOU NT is dele ted or is equal to Z ERO, remov e the OFFS ET
8713	"^DD",399, 399,202,1, 1,"%D",2,0 )
8714	DESCRIPTIO N.
8715	"^DD",399, 399,202,1, 1,"CREATE VALUE")
8716	NO EFFECT
8717	"^DD",399, 399,202,1, 1,"DELETE CONDITION" )
8718	OFFSET AMO UNT=""!(OF FSET AMOUN T=0)
8719	"^DD",399, 399,202,1, 1,"DELETE VALUE")
8720	@
8721	"^DD",399, 399,202,1, 1,"DT")
8722	3170418
8723	"^DD",399, 399,202,1, 1,"FIELD")
8724	#203
8725	"^DD",399, 399,202,3)
8726	Enter the dollar amo unt betwee n 0 and 99 999.99 tha t is to be subtracte d from the total cha rges on th is bill. Offset inc ludes, but is not li mited to, co-payment s and dedu ctibles.
8727	"^DD",399, 399,202,5, 1,0)
8728	399^218^1
8729	"^DD",399, 399,202,5, 2,0)
8730	399^219^1
8731	"^DD",399, 399,202,5, 3,0)
8732	399^220^1
8733	"^DD",399, 399,202,21 ,0)
8734	^.001^3^3^ 3021126^^
8735	"^DD",399, 399,202,21 ,1,0)
8736	This is th e dollar a mount whic h is to be subtracte d from the total cha rges
8737	"^DD",399, 399,202,21 ,2,0)
8738	on this bi ll. Offset includes, but is no t limited to, co-pay ments, cre dits,
8739	"^DD",399, 399,202,21 ,3,0)
8740	and deduct ibles.
8741	"^DD",399, 399,202,"D T")
8742	3170418
8743	"^DD",399, 399,230,0)
8744	SECONDARY AUTHORIZAT ION CODE^F XJ50^^U2;8 ^K:$L(X)>5 0!($L(X)<1 ) X
8745	"^DD",399, 399,230,3)
8746	Answer mus t be 1-50 characters in length .
8747	"^DD",399, 399,230,5, 1,0)
8748	399^113^4
8749	"^DD",399, 399,230,21 ,0)
8750	^.001^5^5^ 3170330^^
8751	"^DD",399, 399,230,21 ,1,0)
8752	This indic ates that the treatm ent covere d by this bill has b een
8753	"^DD",399, 399,230,21 ,2,0)
8754	authorized by the se condary pa yer.
8755	"^DD",399, 399,230,21 ,3,0)
8756
8757	"^DD",399, 399,230,21 ,4,0)
8758	On the CMS -1500 this is box 23 , PRIOR AU THORIZATIO N NUMBER.
8759	"^DD",399, 399,230,21 ,5,0)
8760	On the UB- 04, this i s reported in FL63.
8761	"^DD",399, 399,230,"D T")
8762	3170427
8763	"^DD",399, 399,231,0)
8764	TERTIARY A UTHORIZATI ON CODE^FJ 50^^U2;9^K :$L(X)>50! ($L(X)<1) X
8765	"^DD",399, 399,231,3)
8766	Answer mus t be 1-50 characters in length .
8767	"^DD",399, 399,231,5, 1,0)
8768	399^114^4
8769	"^DD",399, 399,231,21 ,0)
8770	^.001^5^5^ 3170330^^^
8771	"^DD",399, 399,231,21 ,1,0)
8772	This indic ates that the treatm ent covere d by this bill has b een
8773	"^DD",399, 399,231,21 ,2,0)
8774	authorized by the te rtiary pay er.
8775	"^DD",399, 399,231,21 ,3,0)
8776
8777	"^DD",399, 399,231,21 ,4,0)
8778	On the CMS -1500 this is box 23 , PRIOR AU THORIZATIO N NUMBER.
8779	"^DD",399, 399,231,21 ,5,0)
8780	On the UB- 04, this i s reported in FL63.
8781	"^DD",399, 399,231,"D T")
8782	3170427
8783	"^DD",399, 399,253,0)
8784	PRIMARY RE FERRAL NUM BER^FJ50^^ UF32;1^K:$ L(X)>50!($ L(X)<1) X
8785	"^DD",399, 399,253,3)
8786	Answer mus t be 1-50 characters in length .
8787	"^DD",399, 399,253,5, 1,0)
8788	399^112^5
8789	"^DD",399, 399,253,21 ,0)
8790	^.001^1^1^ 3170330^^^
8791	"^DD",399, 399,253,21 ,1,0)
8792	This is th e primary referral n umber assi gned to th e insuranc e.
8793	"^DD",399, 399,253,"D T")
8794	3170427
8795	"^DD",399, 399,254,0)
8796	SECONDARY REFERRAL N UMBER^FJ50 ^^UF32;2^K :$L(X)>50! ($L(X)<1) X
8797	"^DD",399, 399,254,3)
8798	Answer mus t be 1-50 characters in length .
8799	"^DD",399, 399,254,5, 1,0)
8800	399^113^5
8801	"^DD",399, 399,254,21 ,0)
8802	^.001^1^1^ 3170330^^
8803	"^DD",399, 399,254,21 ,1,0)
8804	This is th e secondar y referral number as signed to the insura nce.
8805	"^DD",399, 399,254,"D T")
8806	3170427
8807	"^DD",399, 399,255,0)
8808	TERTIARY R EFERRAL NU MBER^FJ50^ ^UF32;3^K: $L(X)>50!( $L(X)<1) X
8809	"^DD",399, 399,255,3)
8810	Answer mus t be 1-50 characters in length .
8811	"^DD",399, 399,255,5, 1,0)
8812	399^114^5
8813	"^DD",399, 399,255,21 ,0)
8814	^.001^1^1^ 3170330^^
8815	"^DD",399, 399,255,21 ,1,0)
8816	This is th e tertiary referral number ass igned to t he insuran ce.
8817	"^DD",399, 399,255,"D T")
8818	3170427
8819	"^DD",399, 399,261,0)
8820	PROPERTY/C ASUALTY CL AIM NUMBER ^FXJ50^^U4 ;2^K:$L(X) >50!($L(X) <1)!($TR(X ," ")="")! ($E(X)=" " ) X
8821	"^DD",399, 399,261,3)
8822	Answer mus t be 1-50 characters in length , not all spaces, no leading s paces.
8823	"^DD",399, 399,261,21 ,0)
8824	^.001^1^1^ 3170330^^^ ^
8825	"^DD",399, 399,261,21 ,1,0)
8826	This is a payer-assi gned claim number fo r a proper ty and cas ualty clai m.
8827	"^DD",399, 399,261,"D T")
8828	3170427
8829	"^DD",399, 399,271,0)
8830	AMBULANCE P/U ADDRES S 1^FJ55^^ U5;2^K:$L( X)>55!($L( X)<1) X
8831	"^DD",399, 399,271,3)
8832	Answer mus t be 1-55 characters in length .
8833	"^DD",399, 399,271,21 ,0)
8834	^.001^2^2^ 3170330^^^
8835	"^DD",399, 399,271,21 ,1,0)
8836	This is li ne one of the street address w here the p atient was picked up .
8837	"^DD",399, 399,271,21 ,2,0)
8838	Required f or ambulan ce transpo rtation.
8839	"^DD",399, 399,271,"D T")
8840	3170427
8841	"^DD",399, 399,272,0)
8842	AMBULANCE P/U ADDRES S 2^FJ55^^ U5;3^K:$L( X)>55!($L( X)<1) X
8843	"^DD",399, 399,272,3)
8844	Answer mus t be 1-55 characters in length .
8845	"^DD",399, 399,272,21 ,0)
8846	^.001^1^1^ 3170330^^^
8847	"^DD",399, 399,272,21 ,1,0)
8848	This is li ne two of the addres s where th e patient was picked up.
8849	"^DD",399, 399,272,"D T")
8850	3170427
8851	"^DD",399, 399,277,0)
8852	AMBULANCE D/O ADDRES S 1^FJ55^^ U6;2^K:$L( X)>55!($L( X)<1) X
8853	"^DD",399, 399,277,3)
8854	Answer mus t be 1-55 characters in length .
8855	"^DD",399, 399,277,21 ,0)
8856	^.001^2^2^ 3170330^^^
8857	"^DD",399, 399,277,21 ,1,0)
8858	This is li ne one of the street address w here the p atient was
8859	"^DD",399, 399,277,21 ,2,0)
8860	dropped of f. Requir ed for amb ulance tra nsportatio n.
8861	"^DD",399, 399,277,"D T")
8862	3170427
8863	"^DD",399, 399,278,0)
8864	AMBULANCE D/O ADDRES S 2^FJ55^^ U6;3^K:$L( X)>55!($L( X)<1) X
8865	"^DD",399, 399,278,3)
8866	Answer mus t be 1-55 characters in length .
8867	"^DD",399, 399,278,21 ,0)
8868	^.001^2^2^ 3170330^^^
8869	"^DD",399, 399,278,21 ,1,0)
8870	This is li ne two of the addres s where th e patient was
8871	"^DD",399, 399,278,21 ,2,0)
8872	dropped of f.
8873	"^DD",399, 399,278,"D T")
8874	3170427
8875	"^DD",399, 399.0304,5 2,0)
8876	UNITS/BASI S OF MEASU REMENT^SX^ F2:Interna tional Uni t;GR:Gram; ME:Milligr am;ML:Mill iliter;UN: Unit;^2;1^ Q
8877	"^DD",399, 399.0304,5 2,.1)
8878	Units/Basi s of Measu rement
8879	"^DD",399, 399.0304,5 2,3)
8880	Enter the units or b asis for m easurement associate d with the Medicatio n.
8881	"^DD",399, 399.0304,5 2,5,1,0)
8882	399.0304^5 3^1
8883	"^DD",399, 399.0304,5 2,21,0)
8884	^.001^2^2^ 3170419^^
8885	"^DD",399, 399.0304,5 2,21,1,0)
8886	This field is used t o associat e the corr ect unit o f measurem ent when
8887	"^DD",399, 399.0304,5 2,21,2,0)
8888	Medication is being specified.
8889	"^DD",399, 399.0304,5 2,23,0)
8890	^.001^1^1^ 3170419^^
8891	"^DD",399, 399.0304,5 2,23,1,0)
8892	This file is require d if there is an NDC Number.
8893	"^DD",399, 399.0304,5 2,"DT")
8894	3170613
8895	"^DD",399, 399.0304,5 3,0)
8896	NDC^FX^^1; 7^K:$L(X)> 13!($L(X)< 13)!'(X?5N 1"-"4N1"-" 2N) X
8897	"^DD",399, 399.0304,5 3,1,0)
8898	^.1
8899	"^DD",399, 399.0304,5 3,1,1,0)
8900	^^TRIGGER^ 399.0304^5 2
8901	"^DD",399, 399.0304,5 3,1,1,1)
8902	Q
8903	"^DD",399, 399.0304,5 3,1,1,2)
8904	X ^DD(399. 0304,53,1, 1,2.3) I X S X=DIV S Y(1)=$S($ D(^DGCR(39 9,D0,"CP", D1,1)):^(1 ),1:""),Y( 1)=$S($D(^ DGCR(399,D 0,"CP",D1, 2)):^(2),1 :"") S X=$ P(Y(1),U,1 ),X=X S DI U=X K Y S X="" X ^DD (399.0304, 53,1,1,2.4 )
8905	"^DD",399, 399.0304,5 3,1,1,2.3)
8906	K DIV S DI V=X,D0=DA( 1),DIV(0)= D0,D1=DA,D IV(1)=D1 S Y(0)=X S Y(1)=$S($D (^DGCR(399 ,D0,"CP",D 1,1)):^(1) ,1:"") S X =$P(Y(1),U ,7)=""
8907	"^DD",399, 399.0304,5 3,1,1,2.4)
8908	S DIH=$G(^ DGCR(399,D IV(0),"CP" ,DIV(1),2) ),DIV=X S $P(^(2),U, 1)=DIV,DIH =399.0304, DIG=52 D ^ DICR
8909	"^DD",399, 399.0304,5 3,1,1,"%D" ,0)
8910	^^2^2^3170 413^
8911	"^DD",399, 399.0304,5 3,1,1,"%D" ,1,0)
8912	When the N DC Code is removed, the UNITS/ BASIS OF M EASUREMENT field sho uld
8913	"^DD",399, 399.0304,5 3,1,1,"%D" ,2,0)
8914	be removed as well.
8915	"^DD",399, 399.0304,5 3,1,1,"CRE ATE VALUE" )
8916	NO EFFECT
8917	"^DD",399, 399.0304,5 3,1,1,"DEL ETE CONDIT ION")
8918	NDC=""
8919	"^DD",399, 399.0304,5 3,1,1,"DEL ETE VALUE" )
8920	@
8921	"^DD",399, 399.0304,5 3,1,1,"FIE LD")
8922	UNITS/BASI S OF MEASU REMENT
8923	"^DD",399, 399.0304,5 3,1,2,0)
8924	^^TRIGGER^ 399.0304^5 4
8925	"^DD",399, 399.0304,5 3,1,2,1)
8926	Q
8927	"^DD",399, 399.0304,5 3,1,2,2)
8928	X ^DD(399. 0304,53,1, 2,2.3) I X S X=DIV S Y(1)=$S($ D(^DGCR(39 9,D0,"CP", D1,1)):^(1 ),1:"") S X=$P(Y(1), U,8),X=X S DIU=X K Y S X="" S DIH=$G(^DG CR(399,DIV (0),"CP",D IV(1),1)), DIV=X S $P (^(1),U,8) =DIV,DIH=3 99.0304,DI G=54 D ^DI CR
8929	"^DD",399, 399.0304,5 3,1,2,2.3)
8930	K DIV S DI V=X,D0=DA( 1),DIV(0)= D0,D1=DA,D IV(1)=D1 S Y(0)=X S Y(1)=$S($D (^DGCR(399 ,D0,"CP",D 1,1)):^(1) ,1:"") S X =$P(Y(1),U ,7)=""
8931	"^DD",399, 399.0304,5 3,1,2,"%D" ,0)
8932	^^1^1^3170 413^
8933	"^DD",399, 399.0304,5 3,1,2,"%D" ,1,0)
8934	When the N DC Code is removed, the UNITS field shou ld be remo ved as wel l.
8935	"^DD",399, 399.0304,5 3,1,2,"CRE ATE VALUE" )
8936	NO EFFECT
8937	"^DD",399, 399.0304,5 3,1,2,"DEL ETE CONDIT ION")
8938	NDC=""
8939	"^DD",399, 399.0304,5 3,1,2,"DEL ETE VALUE" )
8940	@
8941	"^DD",399, 399.0304,5 3,1,2,"DT" )
8942	3170413
8943	"^DD",399, 399.0304,5 3,1,2,"FIE LD")
8944	UNITS
8945	"^DD",399, 399.0304,5 3,3)
8946	Enter a Na tional Dru g Code in a 5-4-2 fo rmat (nnnn n-nnnn-nn) if requir ed on a no n-prescrip tion claim .
8947	"^DD",399, 399.0304,5 3,21,0)
8948	^^2^2^3140 707^
8949	"^DD",399, 399.0304,5 3,21,1,0)
8950	Enter a Na tional Dru g Code in a 5-4-2 fo rmat (nnnn n-nnnn-nn) if
8951	"^DD",399, 399.0304,5 3,21,2,0)
8952	required o n a non-pr escription claim.
8953	"^DD",399, 399.0304,5 3,23,0)
8954	^.001^2^2^ 3140707^^
8955	"^DD",399, 399.0304,5 3,23,1,0)
8956	Enter a Na tional Dru g Code in a 5-4-2 fo rmat (nnnn n-nnnn-nn) if
8957	"^DD",399, 399.0304,5 3,23,2,0)
8958	required o n a non-pr escription claim.
8959	"^DD",399, 399.0304,5 3,"DT")
8960	3170613
8961	"^DD",399, 399.0304,5 4,0)
8962	UNITS^NJ15 ,3X^^1;8^K :+X'=X!(X> 9999999999 9)!(X<0)!( (X[".")&(X '?.11N1"." 1.3N)) X
8963	"^DD",399, 399.0304,5 4,3)
8964	Enter a nu mber betwe en 0 and 9 9999999999 with up t o 3 decima l digits.
8965	"^DD",399, 399.0304,5 4,5,1,0)
8966	399.0304^5 3^2
8967	"^DD",399, 399.0304,5 4,21,0)
8968	^^1^1^3170 421^
8969	"^DD",399, 399.0304,5 4,21,1,0)
8970	Enter the number of units of t he non-pre scription medication administe rd.
8971	"^DD",399, 399.0304,5 4,23,0)
8972	^^2^2^3170 421^^
8973	"^DD",399, 399.0304,5 4,23,1,0)
8974	The number entered m ust be gre ater than zero and h ave format of
8975	"^DD",399, 399.0304,5 4,23,2,0)
8976	9999999999 9 and up t o 3 decima l digits.
8977	"^DD",399, 399.0304,5 4,"DT")
8978	3170613
8979	"^DIC",350 .8,350.8,0 )
8980	IB ERROR
8981	"^DIC",350 .8,350.8,0 ,"GL")
8982	^IBE(350.8 ,
8983	"^DIC",350 .8,350.8," %D",0)
8984	^^11^11^29 40214^^^^
8985	"^DIC",350 .8,350.8," %D",1,0)
8986	This file contains e rrors for billing fu nctions. It may be used by
8987	"^DIC",350 .8,350.8," %D",2,0)
8988	applicatio ns, IB or AR. The n ormal form at for a r outine to return
8989	"^DIC",350 .8,350.8," %D",3,0)
8990	an error i s to retur n the vari able:
8991	"^DIC",350 .8,350.8," %D",4,0)
8992	Y=1^... a successf ul event o ccured
8993	"^DIC",350 .8,350.8," %D",5,0)
8994	Y=-1^err or code[;e rror code; error code ...]^addit ional text
8995	"^DIC",350 .8,350.8," %D",6,0)
8996	The error messages c an be disp layed by c alling rou tine ^IBAE RR. If
8997	"^DIC",350 .8,350.8," %D",7,0)
8998	the error occurs in a tasked j ob ($D(ZTQ UEUED)'=0) the routi ne will
8999	"^DIC",350 .8,350.8," %D",8,0)
9000	put the er ror messag e in a bul letin and post it to the group defined
9001	"^DIC",350 .8,350.8," %D",9,0)
9002	in the IB SITE PARAM ETER FILE.
9003	"^DIC",350 .8,350.8," %D",10,0)
9004
9005	"^DIC",350 .8,350.8," %D",11,0)
9006	Per VHA Di rective 10 -93-142, t his file d efinition should not be modifi ed.
9007	"^DIC",350 .8,"B","IB ERROR",35 0.8)
9008
9009	"^DIC",364 .6,364.6,0 )
9010	IB FORM SK ELETON DEF INITION^36 4.6P
9011	"^DIC",364 .6,364.6,0 ,"GL")
9012	^IBA(364.6 ,
9013	"^DIC",364 .6,364.6," %",0)
9014	^1.005^^
9015	"^DIC",364 .6,364.6," %D",0)
9016	^1.001^10^ 10^3170510 ^^^^
9017	"^DIC",364 .6,364.6," %D",1,0)
9018	DO NOT del ete entrie s or edit data in th is file wi th VA File Manager.
9019	"^DIC",364 .6,364.6," %D",2,0)
9020
9021	"^DIC",364 .6,364.6," %D",3,0)
9022	This file contains r ecords tha t define t he skeleto n makeup o f forms fo r
9023	"^DIC",364 .6,364.6," %D",4,0)
9024	the IB sys tem. This definitio n includes the absol ute positi on of ever y
9025	"^DIC",364 .6,364.6," %D",5,0)
9026	field that can be ou tput on th e form, th e length e ach field must be li mited
9027	"^DIC",364 .6,364.6," %D",6,0)
9028	to, and so me descrip tive infor mation. This inclu des printe d forms,
9029	"^DIC",364 .6,364.6," %D",7,0)
9030	transmitta ble output files, an d special local bill ing screen s.
9031	"^DIC",364 .6,364.6," %D",8,0)
9032
9033	"^DIC",364 .6,364.6," %D",9,0)
9034	Entries in this file that are designated as having a SECURIT Y LEVEL of
9035	"^DIC",364 .6,364.6," %D",10,0)
9036	NATIONAL s hould not be deleted or edited .
9037	"^DIC",364 .6,"B","IB FORM SKEL ETON DEFIN ITION",364 .6)
9038
9039	"^DIC",364 .7,364.7,0 )
9040	IB FORM FI ELD CONTEN T^364.7P
9041	"^DIC",364 .7,364.7,0 ,"GL")
9042	^IBA(364.7 ,
9043	"^DIC",364 .7,364.7," %",0)
9044	^1.005^^
9045	"^DIC",364 .7,364.7," %D",0)
9046	^1.001^9^9 ^3170510^^ ^^
9047	"^DIC",364 .7,364.7," %D",1,0)
9048	DO NOT del ete entrie s or edit data in th is file wi th VA File Manager.
9049	"^DIC",364 .7,364.7," %D",2,0)
9050
9051	"^DIC",364 .7,364.7," %D",3,0)
9052	This is th e file tha t contains the speci fic fields to be use d to produ ce
9053	"^DIC",364 .7,364.7," %D",4,0)
9054	the associ ated form or screen. If there is no ins urance com pany or bi ll
9055	"^DIC",364 .7,364.7," %D",5,0)
9056	type speci fied for a n entry, t his is ass umed to be the defau lt definit ion
9057	"^DIC",364 .7,364.7," %D",6,0)
9058	of the fie ld.
9059	"^DIC",364 .7,364.7," %D",7,0)
9060
9061	"^DIC",364 .7,364.7," %D",8,0)
9062	Entries in this file that are designated as having a SECURIT Y LEVEL of
9063	"^DIC",364 .7,364.7," %D",9,0)
9064	NATIONAL s hould not be deleted or edited .
9065	"^DIC",364 .7,"B","IB FORM FIEL D CONTENT" ,364.7)
9066
9067	"BLD",1050 9,6)
9068	11^
9069	END
9070	END
9071
9072
		9073
		9074
		9075
		9076
		9077
		9078
		9079
		9080
		9081
		9082
		9083
		9084