3. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 4/24/2017 10:01:11 PM 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	PSE Patch PRCA_4_5_313 v4 _Apr_2017.zip	PRCA_45_313v4.KID	Wed Apr 19 20:00:50 2017 UTC
2	PSE Patch PRCA_4_5_313 v4 _Apr_2017.zip	PRCA_45_313v4.KID	Tue Apr 25 00:24:06 2017 UTC

3.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	13	15930
Changed	12	25
Inserted	1	1
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	Packman Ma il Message :
2	========== ========== =
3
4	$END TXT
5	$KID PRCA* 4.5*313
6	INSTALL NAME
7	PRCA4.53 13
8	"BLD",1011 1,0)
9	PRCA4.53 13^ACCOUNT S RECEIVAB LE^0^31704 05^y
10	"BLD",1011 1,1,0)
11	^^1^1^3160 811^^^^
12	"BLD",1011 1,1,1,0)
13	Consolidat ed Patient Statement
14	"BLD",1011 1,4,0)
15	^9.64PA^34 9.5^6
16	"BLD",1011 1,4,340,0)
17	340
18	"BLD",1011 1,4,340,2, 0)
19	^9.641^340 ^1
20	"BLD",1011 1,4,340,2, 340,0)
21	AR DEBTOR (File-top level)
22	"BLD",1011 1,4,340,2, 340,1,0)
23	^9.6411^.0 3^3
24	"BLD",1011 1,4,340,2, 340,1,.01, 0)
25	DEBTOR
26	"BLD",1011 1,4,340,2, 340,1,.03, 0)
27	STATEMENT DAY
28	"BLD",1011 1,4,340,2, 340,1,7.06 ,0)
29	CURRENT CB S DEBT AMO UNT
30	"BLD",1011 1,4,340,22 2)
31	y^n^p^^^^n ^^n
32	"BLD",1011 1,4,340,22 4)
33
34	"BLD",1011 1,4,341,0)
35	341
36	"BLD",1011 1,4,341,2, 0)
37	^9.641^341 ^1
38	"BLD",1011 1,4,341,2, 341,0)
39	AR EVENT (File-top level)
40	"BLD",1011 1,4,341,2, 341,1,0)
41	^9.6411^6. 01^1
42	"BLD",1011 1,4,341,2, 341,1,6.01 ,0)
43	CCPC STATE MENT DATE
44	"BLD",1011 1,4,341,22 2)
45	y^n^p^^^^n ^^n
46	"BLD",1011 1,4,341,22 4)
47
48	"BLD",1011 1,4,349,0)
49	349
50	"BLD",1011 1,4,349,2, 0)
51	^9.641^349 ^1
52	"BLD",1011 1,4,349,2, 349,0)
53	AR TRANSMI SSION RECO RDS (File -top level )
54	"BLD",1011 1,4,349,2, 349,1,0)
55	^9.6411^.0 9^1
56	"BLD",1011 1,4,349,2, 349,1,.09, 0)
57	STATEMENT DATE
58	"BLD",1011 1,4,349,22 2)
59	y^n^p^^^^n ^^n
60	"BLD",1011 1,4,349,22 4)
61
62	"BLD",1011 1,4,349.1, 0)
63	349.1
64	"BLD",1011 1,4,349.1, 222)
65	y^n^f^^^^n ^^n
66	"BLD",1011 1,4,349.1, 224)
67
68	"BLD",1011 1,4,349.2, 0)
69	349.2
70	"BLD",1011 1,4,349.2, 2,0)
71	^9.641^349 .2^1
72	"BLD",1011 1,4,349.2, 2,349.2,0)
73	AR CBSS ST ATEMENTS (File-top level)
74	"BLD",1011 1,4,349.2, 2,349.2,1, 0)
75	^9.6411^61 ^12
76	"BLD",1011 1,4,349.2, 2,349.2,1, .01,0)
77	PATIENT
78	"BLD",1011 1,4,349.2, 2,349.2,1, .02,0)
79	SSN
80	"BLD",1011 1,4,349.2, 2,349.2,1, .03,0)
81	PATIENT NA ME
82	"BLD",1011 1,4,349.2, 2,349.2,1, .12,0)
83	INVALID ST ATEMENT ER ROR
84	"BLD",1011 1,4,349.2, 2,349.2,1, .18,0)
85	CBSS FILE BUILT
86	"BLD",1011 1,4,349.2, 2,349.2,1, .19,0)
87	PATIENT ST ATEMENT DA TE
88	"BLD",1011 1,4,349.2, 2,349.2,1, 51,0)
89	ERROR CODE (S)
90	"BLD",1011 1,4,349.2, 2,349.2,1, 61,0)
91	CBSS PRINT ED
92	"BLD",1011 1,4,349.2, 2,349.2,1, 81,0)
93	INTEGRATIO N CONTROL NUMBER
94	"BLD",1011 1,4,349.2, 2,349.2,1, 82,0)
95	ICN CHECKS UM
96	"BLD",1011 1,4,349.2, 2,349.2,1, 83,0)
97	AR FLAG
98	"BLD",1011 1,4,349.2, 2,349.2,1, 84,0)
99	DATE OF LA TEST BILL
100	"BLD",1011 1,4,349.2, 222)
101	y^n^p^^^^n ^^n
102	"BLD",1011 1,4,349.2, 224)
103
104	"BLD",1011 1,4,349.5, 0)
105	349.5
106	"BLD",1011 1,4,349.5, 222)
107	y^n^f^^^^n ^^n
108	"BLD",1011 1,4,349.5, 224)
109
110	"BLD",1011 1,4,"APDD" ,340,340)
111
112	"BLD",1011 1,4,"APDD" ,340,340,. 01)
113
114	"BLD",1011 1,4,"APDD" ,340,340,. 03)
115
116	"BLD",1011 1,4,"APDD" ,340,340,7 .06)
117
118	"BLD",1011 1,4,"APDD" ,341,341)
119
120	"BLD",1011 1,4,"APDD" ,341,341,6 .01)
121
122	"BLD",1011 1,4,"APDD" ,349,349)
123
124	"BLD",1011 1,4,"APDD" ,349,349,. 09)
125
126	"BLD",1011 1,4,"APDD" ,349.2,349 .2)
127
128	"BLD",1011 1,4,"APDD" ,349.2,349 .2,.01)
129
130	"BLD",1011 1,4,"APDD" ,349.2,349 .2,.02)
131
132	"BLD",1011 1,4,"APDD" ,349.2,349 .2,.03)
133
134	"BLD",1011 1,4,"APDD" ,349.2,349 .2,.12)
135
136	"BLD",1011 1,4,"APDD" ,349.2,349 .2,.18)
137
138	"BLD",1011 1,4,"APDD" ,349.2,349 .2,.19)
139
140	"BLD",1011 1,4,"APDD" ,349.2,349 .2,51)
141
142	"BLD",1011 1,4,"APDD" ,349.2,349 .2,61)
143
144	"BLD",1011 1,4,"APDD" ,349.2,349 .2,81)
145
146	"BLD",1011 1,4,"APDD" ,349.2,349 .2,82)
147
148	"BLD",1011 1,4,"APDD" ,349.2,349 .2,83)
149
150	"BLD",1011 1,4,"APDD" ,349.2,349 .2,84)
151
152	"BLD",1011 1,4,"B",34 0,340)
153
154	"BLD",1011 1,4,"B",34 1,341)
155
156	"BLD",1011 1,4,"B",34 9,349)
157
158	"BLD",1011 1,4,"B",34 9.1,349.1)
159
160	"BLD",1011 1,4,"B",34 9.2,349.2)
161
162	"BLD",1011 1,4,"B",34 9.5,349.5)
163
164	"BLD",1011 1,6)
165	2^
166	"BLD",1011 1,6.3)
167	113
168	"BLD",1011 1,"ABPKG")
169	n
170	"BLD",1011 1,"INI")
171	PRE^PRCA31 3P
172	"BLD",1011 1,"INID")
173	^y^y
174	"BLD",1011 1,"INIT")
175	EN^PRCA313 P
176	"BLD",1011 1,"KRN",0)
177	^9.67PA^77 9.2^20
178	"BLD",1011 1,"KRN",.4 ,0)
179	.4
180	"BLD",1011 1,"KRN",.4 ,"NM",0)
181	^9.68A^^0
182	"BLD",1011 1,"KRN",.4 01,0)
183	.401
184	"BLD",1011 1,"KRN",.4 02,0)
185	.402
186	"BLD",1011 1,"KRN",.4 02,"NM",0)
187	^9.68A^^0
188	"BLD",1011 1,"KRN",.4 03,0)
189	.403
190	"BLD",1011 1,"KRN",.5 ,0)
191	.5
192	"BLD",1011 1,"KRN",.8 4,0)
193	.84
194	"BLD",1011 1,"KRN",3. 6,0)
195	3.6
196	"BLD",1011 1,"KRN",3. 8,0)
197	3.8
198	"BLD",1011 1,"KRN",3. 8,"NM",0)
199	^9.68A^^0
200	"BLD",1011 1,"KRN",9. 2,0)
201	9.2
202	"BLD",1011 1,"KRN",9. 8,0)
203	9.8
204	"BLD",1011 1,"KRN",9. 8,"NM",0)
205	^9.68A^23^ 18
206	"BLD",1011 1,"KRN",9. 8,"NM",5,0 )
207	RCCPCBJ^^0 ^B9466054
208	"BLD",1011 1,"KRN",9. 8,"NM",6,0 )
209	PRCACPS1^^ 0^B1877125 1
210	"BLD",1011 1,"KRN",9. 8,"NM",7,0 )
211	RCCPCFN1^^ 0^B6869513
212	"BLD",1011 1,"KRN",9. 8,"NM",8,0 )
213	RCCPCML^^0 ^B65098323
214	"BLD",1011 1,"KRN",9. 8,"NM",9,0 )
215	RCCPCSV^^0 ^B11821725
216	"BLD",1011 1,"KRN",9. 8,"NM",10, 0)
217	RCCPCPS^^0 ^B12629290 4
218	"BLD",1011 1,"KRN",9. 8,"NM",11, 0)
219	RCCPCPS1^^ 0^B6483368 4
220	"BLD",1011 1,"KRN",9. 8,"NM",12, 0)
221	RCCPCSV1^^ 0^B4366325 5
222	"BLD",1011 1,"KRN",9. 8,"NM",13, 0)
223	RCCPCML1^^ 0^B8787618
224	"BLD",1011 1,"KRN",9. 8,"NM",14, 0)
225	RCCPCSE^^0 ^B13492869
226	"BLD",1011 1,"KRN",9. 8,"NM",15, 0)
227	RCCPCT^^0^ B23641825
228	"BLD",1011 1,"KRN",9. 8,"NM",17, 0)
229	PRCAG^^0^B 36104045
230	"BLD",1011 1,"KRN",9. 8,"NM",18, 0)
231	PRCA313P^^ 0^B1869746 0
232	"BLD",1011 1,"KRN",9. 8,"NM",19, 0)
233	PRCAACR^^0 ^B12495557 2
234	"BLD",1011 1,"KRN",9. 8,"NM",20, 0)
235	PRCAACR1^^ 0^B1512714 41
236	"BLD",1011 1,"KRN",9. 8,"NM",21, 0)
237	RCCPCAP^^0 ^B39742487
238	"BLD",1011 1,"KRN",9. 8,"NM",22, 0)
239	RCCPCAT^^0 ^B33146754
240	"BLD",1011 1,"KRN",9. 8,"NM",23, 0)
241	RCCPCAR^^0 ^B48587779
242	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"PRCA313P ",18)
243
244	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"PRCAACR" ,19)
245
246	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"PRCAACR1 ",20)
247
248	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"PRCACPS1 ",6)
249
250	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"PRCAG",1 7)
251
252	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCAP" ,21)
253
254	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCAR" ,23)
255
256	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCAT" ,22)
257
258	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCBJ" ,5)
259
260	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCFN1 ",7)
261
262	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCML" ,8)
263
264	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCML1 ",13)
265
266	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCPS" ,10)
267
268	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCPS1 ",11)
269
270	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCSE" ,14)
271
272	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCSV" ,9)
273
274	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCSV1 ",12)
275
276	"BLD",1011 1,"KRN",9. 8,"NM","B" ,"RCCPCT", 15)
277
278	"BLD",1011 1,"KRN",19 ,0)
279	19
280	"BLD",1011 1,"KRN",19 ,"NM",0)
281	^9.68A^8^5
282	"BLD",1011 1,"KRN",19 ,"NM",4,0)
283	PRCA CBS N IGHTLY UPD ATE^^0
284	"BLD",1011 1,"KRN",19 ,"NM",5,0)
285	PRCAE FOLL OW-UP^^2
286	"BLD",1011 1,"KRN",19 ,"NM",6,0)
287	RCCPC APPS BUILD AND TRANS^^0
288	"BLD",1011 1,"KRN",19 ,"NM",7,0)
289	RCCPC APPS RETRANS^^ 0
290	"BLD",1011 1,"KRN",19 ,"NM",8,0)
291	RCCPC APPS DATA CHEC K^^0
292	"BLD",1011 1,"KRN",19 ,"NM","B", "PRCA CBS NIGHTLY UP DATE",4)
293
294	"BLD",1011 1,"KRN",19 ,"NM","B", "PRCAE FOL LOW-UP",5)
295
296	"BLD",1011 1,"KRN",19 ,"NM","B", "RCCPC APP S BUILD AN D TRANS",6 )
297
298	"BLD",1011 1,"KRN",19 ,"NM","B", "RCCPC APP S DATA CHE CK",8)
299
300	"BLD",1011 1,"KRN",19 ,"NM","B", "RCCPC APP S RETRANS" ,7)
301
302	"BLD",1011 1,"KRN",19 .1,0)
303	19.1
304	"BLD",1011 1,"KRN",19 .1,"NM",0)
305	^9.68A^^0
306	"BLD",1011 1,"KRN",10 1,0)
307	101
308	"BLD",1011 1,"KRN",40 9.61,0)
309	409.61
310	"BLD",1011 1,"KRN",77 1,0)
311	771
312	"BLD",1011 1,"KRN",77 9.2,0)
313	779.2
314	"BLD",1011 1,"KRN",87 0,0)
315	870
316	"BLD",1011 1,"KRN",89 89.51,0)
317	8989.51
318	"BLD",1011 1,"KRN",89 89.52,0)
319	8989.52
320	"BLD",1011 1,"KRN",89 94,0)
321	8994
322	"BLD",1011 1,"KRN","B ",.4,.4)
323
324	"BLD",1011 1,"KRN","B ",.401,.40 1)
325
326	"BLD",1011 1,"KRN","B ",.402,.40 2)
327
328	"BLD",1011 1,"KRN","B ",.403,.40 3)
329
330	"BLD",1011 1,"KRN","B ",.5,.5)
331
332	"BLD",1011 1,"KRN","B ",.84,.84)
333
334	"BLD",1011 1,"KRN","B ",3.6,3.6)
335
336	"BLD",1011 1,"KRN","B ",3.8,3.8)
337
338	"BLD",1011 1,"KRN","B ",9.2,9.2)
339
340	"BLD",1011 1,"KRN","B ",9.8,9.8)
341
342	"BLD",1011 1,"KRN","B ",19,19)
343
344	"BLD",1011 1,"KRN","B ",19.1,19. 1)
345
346	"BLD",1011 1,"KRN","B ",101,101)
347
348	"BLD",1011 1,"KRN","B ",409.61,4 09.61)
349
350	"BLD",1011 1,"KRN","B ",771,771)
351
352	"BLD",1011 1,"KRN","B ",779.2,77 9.2)
353
354	"BLD",1011 1,"KRN","B ",870,870)
355
356	"BLD",1011 1,"KRN","B ",8989.51, 8989.51)
357
358	"BLD",1011 1,"KRN","B ",8989.52, 8989.52)
359
360	"BLD",1011 1,"KRN","B ",8994,899 4)
361
362	"BLD",1011 1,"QDEF")
363	^^^^^^^^YE S
364	"BLD",1011 1,"QUES",0 )
365	^9.62^^
366	"BLD",1011 1,"REQB",0 )
367	^9.611^2^2
368	"BLD",1011 1,"REQB",1 ,0)
369	PRCA4.53 07^2
370	"BLD",1011 1,"REQB",2 ,0)
371	XMDB1.00 ^2
372	"BLD",1011 1,"REQB"," B","PRCA4 .5307",1)
373
374	"BLD",1011 1,"REQB"," B","XMDB1 .00",2)
375
376	"FIA",340)
377	AR DEBTOR
378	"FIA",340, 0)
379	^RCD(340,
380	"FIA",340, 0,0)
381	340V
382	"FIA",340, 0,1)
383	y^n^p^^^^n ^^n
384	"FIA",340, 0,10)
385
386	"FIA",340, 0,11)
387
388	"FIA",340, 0,"RLRO")
389
390	"FIA",340, 0,"VR")
391	4.5^PRCA
392	"FIA",340, 340)
393	1
394	"FIA",340, 340,.01)
395
396	"FIA",340, 340,.03)
397
398	"FIA",340, 340,7.06)
399
400	"FIA",341)
401	AR EVENT
402	"FIA",341, 0)
403	^RC(341,
404	"FIA",341, 0,0)
405	341I
406	"FIA",341, 0,1)
407	y^n^p^^^^n ^^n
408	"FIA",341, 0,10)
409
410	"FIA",341, 0,11)
411
412	"FIA",341, 0,"RLRO")
413
414	"FIA",341, 0,"VR")
415	4.5^PRCA
416	"FIA",341, 341)
417	1
418	"FIA",341, 341,6.01)
419
420	"FIA",349)
421	AR TRANSMI SSION RECO RDS
422	"FIA",349, 0)
423	^RCT(349,
424	"FIA",349, 0,0)
425	349I
426	"FIA",349, 0,1)
427	y^n^p^^^^n ^^n
428	"FIA",349, 0,10)
429
430	"FIA",349, 0,11)
431
432	"FIA",349, 0,"RLRO")
433
434	"FIA",349, 0,"VR")
435	4.5^PRCA
436	"FIA",349, 349)
437	1
438	"FIA",349, 349,.09)
439
440	"FIA",349. 1)
441	AR TRANSMI SSION TYPE
442	"FIA",349. 1,0)
443	^RCT(349.1 ,
444	"FIA",349. 1,0,0)
445	349.1I
446	"FIA",349. 1,0,1)
447	y^n^f^^^^n ^^n
448	"FIA",349. 1,0,10)
449
450	"FIA",349. 1,0,11)
451
452	"FIA",349. 1,0,"RLRO" )
453
454	"FIA",349. 1,0,"VR")
455	4.5^PRCA
456	"FIA",349. 1,349.1)
457	0
458	"FIA",349. 1,349.11)
459	0
460	"FIA",349. 1,349.12)
461	0
462	"FIA",349. 1,349.141)
463	0
464	"FIA",349. 1,349.151)
465	0
466	"FIA",349. 1,349.161)
467	0
468	"FIA",349. 2)
469	AR CBSS ST ATEMENTS
470	"FIA",349. 2,0)
471	^RCPS(349. 2,
472	"FIA",349. 2,0,0)
473	349.2I
474	"FIA",349. 2,0,1)
475	y^n^p^^^^n ^^n
476	"FIA",349. 2,0,10)
477
478	"FIA",349. 2,0,11)
479
480	"FIA",349. 2,0,"RLRO" )
481
482	"FIA",349. 2,0,"VR")
483	4.5^PRCA
484	"FIA",349. 2,349.2)
485	1
486	"FIA",349. 2,349.2,.0 1)
487
488	"FIA",349. 2,349.2,.0 2)
489
490	"FIA",349. 2,349.2,.0 3)
491
492	"FIA",349. 2,349.2,.1 2)
493
494	"FIA",349. 2,349.2,.1 8)
495
496	"FIA",349. 2,349.2,.1 9)
497
498	"FIA",349. 2,349.2,51 )
499
500	"FIA",349. 2,349.2,61 )
501
502	"FIA",349. 2,349.2,81 )
503
504	"FIA",349. 2,349.2,82 )
505
506	"FIA",349. 2,349.2,83 )
507
508	"FIA",349. 2,349.2,84 )
509
510	"FIA",349. 5)
511	AR ANNUAL PAYMENT ST ATEMENT
512	"FIA",349. 5,0)
513	^RCAP(349. 5,
514	"FIA",349. 5,0,0)
515	349.5
516	"FIA",349. 5,0,1)
517	y^n^f^^^^n ^^n
518	"FIA",349. 5,0,10)
519
520	"FIA",349. 5,0,11)
521
522	"FIA",349. 5,0,"RLRO" )
523
524	"FIA",349. 5,0,"VR")
525	4.5^PRCA
526	"FIA",349. 5,349.5)
527	0
528	"FIA",349. 5,349.51)
529	0
530	"INI")
531	PRE^PRCA31 3P
532	"INIT")
533	EN^PRCA313 P
534	"IX",349,3 49,"SDT",0 )
535	349^SDT^Pa tient Stat ement Day of the Mon th^R^^F^IR ^I^349^^^^ ^LS
536	"IX",349,3 49,"SDT",. 1,0)
537	^^1^1^3161 007^
538	"IX",349,3 49,"SDT",. 1,1,0)
539	This cross -reference is the Pa tient Stat ement Day of the Mon th.
540	"IX",349,3 49,"SDT",1 )
541	S ^RCT(349 ,"SDT",$E( X,1,2),DA) =""
542	"IX",349,3 49,"SDT",2 )
543	K ^RCT(349 ,"SDT",$E( X,1,2),DA)
544	"IX",349,3 49,"SDT",2 .5)
545	K ^RCT(349 ,"SDT")
546	"IX",349,3 49,"SDT",1 1.1,0)
547	^.114IA^1^ 1
548	"IX",349,3 49,"SDT",1 1.1,1,0)
549	1^F^349^.0 9^2^1^F
550	"IX",349,3 49,"SDT",1 1.1,1,2)
551	S X=+$E(X, 6,7)
552	"IX",349.1 ,349.141," STDT4",0)
553	349.141^ST DT4^Patien t Statemen t Date and Last Mess age ACK^R^ ^R^IR^I^34 9.141^^^^
554	^LS
555	"IX",349.1 ,349.141," STDT4",.1, 0)
556	^^2^2^3161 007^
557	"IX",349.1 ,349.141," STDT4",.1, 1,0)
558	This cross -reference is used t o sort by the Patien t Statemen t Date and the
559	"IX",349.1 ,349.141," STDT4",.1, 2,0)
560	Last Messa ge ACK.
561	"IX",349.1 ,349.141," STDT4",1)
562	S ^RCT(349 .1,DA(1),4 ,"STDT4",$ E(X(1),1,7 ),$E(X(2), 1,3),DA)=" "
563	"IX",349.1 ,349.141," STDT4",2)
564	K ^RCT(349 .1,DA(1),4 ,"STDT4",$ E(X(1),1,7 ),$E(X(2), 1,3),DA)
565	"IX",349.1 ,349.141," STDT4",2.5 )
566	K ^RCT(349 .1,DA(1),4 ,"STDT4")
567	"IX",349.1 ,349.141," STDT4",11. 1,0)
568	^.114IA^2^ 2
569	"IX",349.1 ,349.141," STDT4",11. 1,1,0)
570	1^F^349.14 1^.04^7^1^ F
571	"IX",349.1 ,349.141," STDT4",11. 1,1,3)
572
573	"IX",349.1 ,349.141," STDT4",11. 1,2,0)
574	2^F^349.14 1^.01^3^2^ F
575	"IX",349.1 ,349.141," STDT4",11. 1,2,3)
576
577	"IX",349.1 ,349.151," STDT5",0)
578	349.151^ST DT5^Patien t Statemen t Date Ind ex^R^^F^IR ^I^349.151 ^^^^^LS
579	"IX",349.1 ,349.151," STDT5",.1, 0)
580	^^1^1^3161 006^
581	"IX",349.1 ,349.151," STDT5",.1, 1,0)
582	This cross -reference is used t o sort by the Patien t Statemen t Date.
583	"IX",349.1 ,349.151," STDT5",1)
584	S ^RCT(349 .1,DA(1),5 ,"STDT5",$ E(X,1,7),D A)=""
585	"IX",349.1 ,349.151," STDT5",2)
586	K ^RCT(349 .1,DA(1),5 ,"STDT5",$ E(X,1,7),D A)
587	"IX",349.1 ,349.151," STDT5",2.5 )
588	K ^RCT(349 .1,DA(1),5 ,"STDT5")
589	"IX",349.1 ,349.151," STDT5",11. 1,0)
590	^.114IA^1^ 1
591	"IX",349.1 ,349.151," STDT5",11. 1,1,0)
592	1^F^349.15 1^.04^7^1^ F
593	"IX",349.2 ,349.2,"AD ",0)
594	349.2^AD^P atient Sta tement Err ors^R^^F^I R^I^349.2^ ^^^^S
595	"IX",349.2 ,349.2,"AD ",.1,0)
596	^^2^2^3161 007^
597	"IX",349.2 ,349.2,"AD ",.1,1,0)
598	This is th e cross-re ference to find pati ent statem ent errors that are
599	"IX",349.2 ,349.2,"AD ",.1,2,0)
600	returned f rom CBSS.
601	"IX",349.2 ,349.2,"AD ",1)
602	S ^RCPS(34 9.2,"AD",$ E(X,1,1),D A)=""
603	"IX",349.2 ,349.2,"AD ",2)
604	K ^RCPS(34 9.2,"AD",$ E(X,1,1),D A)
605	"IX",349.2 ,349.2,"AD ",2.5)
606	K ^RCPS(34 9.2,"AD")
607	"IX",349.2 ,349.2,"AD ",11.1,0)
608	^.114IA^1^ 1
609	"IX",349.2 ,349.2,"AD ",11.1,1,0 )
610	1^F^349.2^ 51^1^1^F
611	"IX",349.2 ,349.2,"AD ",11.1,1,1 )
612
613	"IX",349.2 ,349.2,"AD ",11.1,1,2 )
614	S X="E"
615	"IX",349.2 ,349.2,"ST DT",0)
616	349.2^STDT ^Patient S tatement D ate^R^^F^I R^I^349.2^ ^^^^LS
617	"IX",349.2 ,349.2,"ST DT",.1,0)
618	^^2^2^3161 007^
619	"IX",349.2 ,349.2,"ST DT",.1,1,0 )
620	Date Patie nt Stateme nt will di splay on p rinted ver sion. Thi s date is
621	"IX",349.2 ,349.2,"ST DT",.1,2,0 )
622	standardly two days after the statement is transmi tted.
623	"IX",349.2 ,349.2,"ST DT",1)
624	S ^RCPS(34 9.2,"STDT" ,$E(X,1,7) ,DA)=""
625	"IX",349.2 ,349.2,"ST DT",2)
626	K ^RCPS(34 9.2,"STDT" ,$E(X,1,7) ,DA)
627	"IX",349.2 ,349.2,"ST DT",2.5)
628	K ^RCPS(34 9.2,"STDT" )
629	"IX",349.2 ,349.2,"ST DT",11.1,0 )
630	^.114IA^1^ 1
631	"IX",349.2 ,349.2,"ST DT",11.1,1 ,0)
632	1^F^349.2^ .19^7^1^F
633	"KRN",19,3 026,-1)
634	2^5
635	"KRN",19,3 026,0)
636	PRCAE FOLL OW-UP^Foll ow-up Lett er Menu^^M ^1^^^^^^^5 3
637	"KRN",19,3 026,10,0)
638	^19.01IP^1 9^15
639	"KRN",19,3 026,10,17, 0)
640	11666^^14
641	"KRN",19,3 026,10,17, "^")
642	RCCPC APPS BUILD AND TRANS
643	"KRN",19,3 026,10,18, 0)
644	11667^^15
645	"KRN",19,3 026,10,18, "^")
646	RCCPC APPS RETRANS
647	"KRN",19,3 026,10,19, 0)
648	11668^^16
649	"KRN",19,3 026,10,19, "^")
650	RCCPC APPS DATA CHEC K
651	"KRN",19,3 026,"U")
652	FOLLOW-UP LETTER MEN U
653	"KRN",19,1 1657,-1)
654	0^4
655	"KRN",19,1 1657,0)
656	PRCA CBS N IGHTLY UPD ATE^CBS Ni ghtly Acco unt Update Program^^ R^^^^^^^^
657	"KRN",19,1 1657,1,0)
658	^^2^2^3160 622^
659	"KRN",19,1 1657,1,1,0 )
660	This optio n runs the Consolida ted Billin g System
661	"KRN",19,1 1657,1,2,0 )
662	Nightly Ac count Upda te program .
663	"KRN",19,1 1657,25)
664	ENTER^PRCA CPS1
665	"KRN",19,1 1657,"U")
666	CBS NIGHTL Y ACCOUNT UPDATE PRO
667	"KRN",19,1 1666,-1)
668	0^6
669	"KRN",19,1 1666,0)
670	RCCPC APPS BUILD AND TRANS^Bui ld and Tra nsmit Annu al Payment File^^A^^ ^^^^^^^^1
671	"KRN",19,1 1666,1,0)
672	^^3^3^3170 224^
673	"KRN",19,1 1666,1,1,0 )
674	This optio n will bui ld the Ann ual Paymen t Statemen t file for the previ ous
675	"KRN",19,1 1666,1,2,0 )
676	year for e very patie nt who has one or mo re payment s in the p revious ye ar
677	"KRN",19,1 1666,1,3,0 )
678	and transm it the fil e to AITC.
679	"KRN",19,1 1666,20)
680	D MANBLD^R CCPCAT
681	"KRN",19,1 1666,"U")
682	BUILD AND TRANSMIT A NNUAL PAYM
683	"KRN",19,1 1667,-1)
684	0^7
685	"KRN",19,1 1667,0)
686	RCCPC APPS RETRANS^R etransmit Current An nual Payme nt File^^A ^^^^^^^^^^ 1
687	"KRN",19,1 1667,1,0)
688	^19.06^3^3 ^3170320^^ ^^
689	"KRN",19,1 1667,1,1,0 )
690	This optio n should o nly to be used when AITC has r equested t he current
691	"KRN",19,1 1667,1,2,0 )
692	Annual Pay ment State ment file be retrans mitted. Th is file wi ll include
693	"KRN",19,1 1667,1,3,0 )
694	every pati ent who ha s one or m ore paymen ts in the previous y ear.
695	"KRN",19,1 1667,20)
696	D RETRANS^ RCCPCAT
697	"KRN",19,1 1667,"U")
698	RETRANSMIT CURRENT A NNUAL PAYM
699	"KRN",19,1 1668,-1)
700	0^8
701	"KRN",19,1 1668,0)
702	RCCPC APPS DATA CHEC K^Annual P ayment Fil e Consiste ncy Check^ ^A^^^^^^^^ ^^1
703	"KRN",19,1 1668,1,0)
704	^^5^5^3170 321^
705	"KRN",19,1 1668,1,1,0 )
706	AR data is extracted from the VistA site s and is s ent to CBS S who then
707	"KRN",19,1 1668,1,2,0 )
708	consolidat es the dat a into the annual pa yment stat ement. The VistA dat a
709	"KRN",19,1 1668,1,3,0 )
710	needs to b e validate d prior to its trans mission. T his menu o ption will
711	"KRN",19,1 1668,1,4,0 )
712	produce a report det ailing whi ch APPS da ta needs t o be revie wed and
713	"KRN",19,1 1668,1,5,0 )
714	updated pr ior to its transmiss ion to CBS S.
715	"KRN",19,1 1668,20)
716	D MANBLD^R CCPCAR
717	"KRN",19,1 1668,"U")
718	ANNUAL PAY MENT FILE CONSISTENC
719	"MBREQ")
720	0
721	"ORD",18,1 9)
722	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
723	"ORD",18,1 9,0)
724	OPTION
725	"PKG",53,- 1)
726	1^1
727	"PKG",53,0 )
728	ACCOUNTS R ECEIVABLE^ PRCA^FMS
729	"PKG",53,2 0,0)
730	^9.402P^1^ 1
731	"PKG",53,2 0,1,0)
732	2^^PRCAMRG
733	"PKG",53,2 0,1,1)
734
735	"PKG",53,2 0,"B",2,1)
736
737	"PKG",53,2 2,0)
738	^9.49I^1^1
739	"PKG",53,2 2,1,0)
740	4.5^305111 9^2960627
741	"PKG",53,2 2,1,"PAH", 1,0)
742	313^317040 5^85
743	"PKG",53,2 2,1,"PAH", 1,1,0)
744	^^1^1^3170 405
745	"PKG",53,2 2,1,"PAH", 1,1,1,0)
746	Consolidat ed Patient Statement
747	"QUES","XP F1",0)
748	Y
749	"QUES","XP F1","??")
750	^D REP^XPD H
751	"QUES","XP F1","A")
752	Shall I wr ite over y our \|FLAG\| File
753	"QUES","XP F1","B")
754	YES
755	"QUES","XP F1","M")
756	D XPF1^XPD IQ
757	"QUES","XP F2",0)
758	Y
759	"QUES","XP F2","??")
760	^D DTA^XPD H
761	"QUES","XP F2","A")
762	Want my da ta \|FLAG\| yours
763	"QUES","XP F2","B")
764	YES
765	"QUES","XP F2","M")
766	D XPF2^XPD IQ
767	"QUES","XP I1",0)
768	YO
769	"QUES","XP I1","??")
770	^D INHIBIT ^XPDH
771	"QUES","XP I1","A")
772	Want KIDS to INHIBIT LOGONs du ring the i nstall
773	"QUES","XP I1","B")
774	NO
775	"QUES","XP I1","M")
776	D XPI1^XPD IQ
777	"QUES","XP M1",0)
778	PO^VA(200, :EM
779	"QUES","XP M1","??")
780	^D MG^XPDH
781	"QUES","XP M1","A")
782	Enter the Coordinato r for Mail Group '\|F LAG\|'
783	"QUES","XP M1","B")
784
785	"QUES","XP M1","M")
786	D XPM1^XPD IQ
787	"QUES","XP O1",0)
788	Y
789	"QUES","XP O1","??")
790	^D MENU^XP DH
791	"QUES","XP O1","A")
792	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
793	"QUES","XP O1","B")
794	YES
795	"QUES","XP O1","M")
796	D XPO1^XPD IQ
797	"QUES","XP Z1",0)
798	Y
799	"QUES","XP Z1","??")
800	^D OPT^XPD H
801	"QUES","XP Z1","A")
802	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
803	"QUES","XP Z1","B")
804	NO
805	"QUES","XP Z1","M")
806	D XPZ1^XPD IQ
807	"QUES","XP Z2",0)
808	Y
809	"QUES","XP Z2","??")
810	^D RTN^XPD H
811	"QUES","XP Z2","A")
812	Want to MO VE routine s to other CPUs
813	"QUES","XP Z2","B")
814	NO
815	"QUES","XP Z2","M")
816	D XPZ2^XPD IQ
817	"RTN")
818	18
819	"RTN","PRC A313P")
820	0^18^B1869 7460^n/a
821	"RTN","PRC A313P",1,0 )
822	PRCA313P ; ALB/BDB - PATCH PRCA 4.5313 P OST-INSTAL L ROUTINE ; 11/2/15 4:15pm
823	"RTN","PRC A313P",2,0 )
824	;;4.5;Acc ounts Rece ivable;3 13;Mar 2 0, 1995;Bu ild 113
825	"RTN","PRC A313P",3,0 )
826	;;Per VA Directive 6402, this routine s hould not be modifie d.
827	"RTN","PRC A313P",4,0 )
828	; This ro utine queu es the Pat ient State ment Auto- Correction Program
829	"RTN","PRC A313P",5,0 )
830	;
831	"RTN","PRC A313P",6,0 )
832	Q
833	"RTN","PRC A313P",7,0 )
834	EN ;Entry point for PRCA4.53 13 post-in stall
835	"RTN","PRC A313P",8,0 )
836	;
837	"RTN","PRC A313P",9,0 )
838	; Delete DD previou s monthly data
839	"RTN","PRC A313P",10, 0)
840	D CLEANUP
841	"RTN","PRC A313P",11, 0)
842	; Set Pat ient State ment days
843	"RTN","PRC A313P",12, 0)
844	D STDT
845	"RTN","PRC A313P",13, 0)
846	; Set AR Transactio n Types
847	"RTN","PRC A313P",14, 0)
848	D SET3491
849	"RTN","PRC A313P",15, 0)
850	;
851	"RTN","PRC A313P",16, 0)
852	Q
853	"RTN","PRC A313P",17, 0)
854	;
855	"RTN","PRC A313P",18, 0)
856	STDT ; En try point for PRCA4 .5313 set of Patien t Statemen t date dep endent up
857	on the Pat ient Last Name
858	"RTN","PRC A313P",19, 0)
859	W !,"Star ting Patie nt Stateme nt Date Re set."
860	"RTN","PRC A313P",20, 0)
861	N DEBT,PA T,DIE
862	"RTN","PRC A313P",21, 0)
863	S DIE="^R CD(340,"
864	"RTN","PRC A313P",22, 0)
865	S DEBT=""
866	"RTN","PRC A313P",23, 0)
867	F S DEBT =$O(^RCD(3 40,"AB","D PT(",DEBT) ) Q:DEBT=" " S PAT=$ P($G(^RCD( 340,DEBT,
868	0)),U) D
869	"RTN","PRC A313P",24, 0)
870	. N DPT,N AME,DA,DR
871	"RTN","PRC A313P",25, 0)
872	. S DPT=$ P(PAT,";", 1)
873	"RTN","PRC A313P",26, 0)
874	. S NAME= $P(^DPT(DP T,0),U)
875	"RTN","PRC A313P",27, 0)
876	. S DA=DE BT
877	"RTN","PRC A313P",28, 0)
878	. S DR=". 03////"_+$ $ACSET^RCC PCFN1(NAME )
879	"RTN","PRC A313P",29, 0)
880	. D ^DIE
881	"RTN","PRC A313P",30, 0)
882	;
883	"RTN","PRC A313P",31, 0)
884	; Set cro ss-referen ce in AR E vent (341) if Patien t Statemen t date exi sts
885	"RTN","PRC A313P",32, 0)
886	N DA,DIK
887	"RTN","PRC A313P",33, 0)
888	S DIK="^R C(341,"
889	"RTN","PRC A313P",34, 0)
890	S DA="" F S DA=$O( ^RC(341,DA )) Q:DA="" I $G(^RC (341,DA,6) )'="" D IX 1^DIK
891	"RTN","PRC A313P",35, 0)
892	;
893	"RTN","PRC A313P",36, 0)
894	W !,"Pati ent Statem ent Date R eset Compl ete."
895	"RTN","PRC A313P",37, 0)
896	Q
897	"RTN","PRC A313P",38, 0)
898	;
899	"RTN","PRC A313P",39, 0)
900	CLEANUP ; PRCA4.5 313
901	"RTN","PRC A313P",40, 0)
902	; Remove site state ment date
903	"RTN","PRC A313P",41, 0)
904	W !,"Star ting Patie nt Stateme nt Cleanup ."
905	"RTN","PRC A313P",42, 0)
906	N DA,DR,D IE,X,RCT
907	"RTN","PRC A313P",43, 0)
908	S DA=1
909	"RTN","PRC A313P",44, 0)
910	S DR=".11 ///@"
911	"RTN","PRC A313P",45, 0)
912	S DIE="^R C(342,"
913	"RTN","PRC A313P",46, 0)
914	D ^DIE
915	"RTN","PRC A313P",47, 0)
916	;
917	"RTN","PRC A313P",48, 0)
918	; Remove all monthl y data
919	"RTN","PRC A313P",49, 0)
920	S DIK="^R CT(349,"
921	"RTN","PRC A313P",50, 0)
922	S DA=0 F S DA=$O(^ RCT(349,DA )) Q:DA="" D ^DIK
923	"RTN","PRC A313P",51, 0)
924	S ^RCT(34 9,0)="AR T RANSMISSIO N RECORDS^ 349I^^"
925	"RTN","PRC A313P",52, 0)
926	S DIK="^R CPS(349.2, "
927	"RTN","PRC A313P",53, 0)
928	S DA=0 F S DA=$O(^ RCPS(349.2 ,DA)) Q:DA ="" D ^DI K
929	"RTN","PRC A313P",54, 0)
930	S ^RCPS(3 49.2,0)="A R CBSS STA TEMENTS^34 9.2I^^"
931	"RTN","PRC A313P",55, 0)
932	F X="PA", "IS" S RCT =$O(^RCT(3 49.1,"B",X ,0)) Q:'RC T K ^RCT( 349.1,+RCT ,4),^RCT(
933	349.1,+RCT ,5)
934	"RTN","PRC A313P",56, 0)
935	;
936	"RTN","PRC A313P",57, 0)
937	W !,"Pati ent Statem ent Cleanu p complete ."
938	"RTN","PRC A313P",58, 0)
939	Q
940	"RTN","PRC A313P",59, 0)
941	;
942	"RTN","PRC A313P",60, 0)
943	SET3491 ; PRCA4.5 313
944	"RTN","PRC A313P",61, 0)
945	; Set val ues for Pr oduction o r Test AR Transmissi on Type
946	"RTN","PRC A313P",62, 0)
947	N PROD,CC ,CP,CA,IEN ,TT,TTVAL
948	"RTN","PRC A313P",63, 0)
949	;
950	"RTN","PRC A313P",64, 0)
951	W !,"Star ting AR Tr ansaction Type Updat e."
952	"RTN","PRC A313P",65, 0)
953	;
954	"RTN","PRC A313P",66, 0)
955	; Set whe ther envir onment is Production or Test a nd define expected/n ew values
956	"RTN","PRC A313P",67, 0)
957	S PROD=$$ PROD^XUPRO D
958	"RTN","PRC A313P",68, 0)
959	S (CC(1), CP(1),CA(1 ))="XXX"
960	"RTN","PRC A313P",69, 0)
961	S CC(3)=" Q-"_$S(PRO D:"CBS",1: "CCT")_" URL "
962	"RTN","PRC A313P",70, 0)
963	S CP(3)=" Q-"_$S(PRO D:"CPP",1: "CPT")_" URL "
964	"RTN","PRC A313P",71, 0)
965	S CA(3)=" Q-"_$S(PRO D:"CAP",1: "CAT")_" URL "
966	"RTN","PRC A313P",72, 0)
967	;
968	"RTN","PRC A313P",73, 0)
969	; Validat e Domains are availa ble. Writ e error if not
970	"RTN","PRC A313P",74, 0)
971	I '$D(^DI C(4.2,"B", CC(3)))!(' $D(^DIC(4. 2,"B",CP(3 ))))!('$D( ^DIC(4.2," B",CA(3))
972	)) D Q
973	"RTN","PRC A313P",75, 0)
974	. N LINE S $P(LINE, "*",79)=""
975	"RTN","PRC A313P",76, 0)
976	. W !,LIN E,!
977	"RTN","PRC A313P",77, 0)
978	. W "Doma ins for PR CA4.5313 have not been fully set up.", !
979	"RTN","PRC A313P",78, 0)
980	. W "Plea se establi sh Domains for: ",!
981	"RTN","PRC A313P",79, 0)
982	. W "CCPC PATIENT S TATEMENTS, PATIENT S TATEMENT U PDATE, and ANNUAL PA YMENT STA
983	TEMENTS."
984	"RTN","PRC A313P",80, 0)
985	. W !,LIN E,!
986	"RTN","PRC A313P",81, 0)
987	;
988	"RTN","PRC A313P",82, 0)
989	; Validat e 'PS', 'P U', and 'P Y' are set for Patie nt Stateme nt, Nightl y Update,
990	and Annua l Payment Statement
991	"RTN","PRC A313P",83, 0)
992	F TT="PS" ,"PU","PY" S IEN=$O( ^RCT(349.1 ,"B",TT,0) ) D
993	"RTN","PRC A313P",84, 0)
994	. N DOMAI N,I
995	"RTN","PRC A313P",85, 0)
996	. I TT="P S" M DOMAI N=CC
997	"RTN","PRC A313P",86, 0)
998	. I TT="P U" M DOMAI N=CP
999	"RTN","PRC A313P",87, 0)
1000	. I TT="P Y" M DOMAI N=CA
1001	"RTN","PRC A313P",88, 0)
1002	. ; If no IEN creat e new leve l one and three with cross-ref erences
1003	"RTN","PRC A313P",89, 0)
1004	. I IEN=" " D SET1(T T,.DOMAIN) Q
1005	"RTN","PRC A313P",90, 0)
1006	. ; If no 3 level o r it is no t set to e xpected va lue reset 3 level
1007	"RTN","PRC A313P",91, 0)
1008	. I IEN'= "" D
1009	"RTN","PRC A313P",92, 0)
1010	. F I=1,3 S TTVAL(I )=$P($G(^R CT(349.1,I EN,3)),U,I )
1011	"RTN","PRC A313P",93, 0)
1012	. I DOMAI N(1)_DOMAI N(3)'=TTVA L(1)_TTVAL (3) D SET3 (IEN,.DOMA IN)
1013	"RTN","PRC A313P",94, 0)
1014	;
1015	"RTN","PRC A313P",95, 0)
1016	W !,"AR T ransaction Type Upda te complet e."
1017	"RTN","PRC A313P",96, 0)
1018	;
1019	"RTN","PRC A313P",97, 0)
1020	Q
1021	"RTN","PRC A313P",98, 0)
1022	;
1023	"RTN","PRC A313P",99, 0)
1024	SET1(TT,DO MAIN) ; P RCA4.531 3
1025	"RTN","PRC A313P",100 ,0)
1026	; Set bot h the 1 an d 3 level for 349.1
1027	"RTN","PRC A313P",101 ,0)
1028	; New and Set Field values fo r DIC(4.2
1029	"RTN","PRC A313P",102 ,0)
1030	N TTNAME, ZZ,DIC,Y
1031	"RTN","PRC A313P",103 ,0)
1032	I TT="PS" S TTNAME= "CCPC PATI ENT STATEM ENT"
1033	"RTN","PRC A313P",104 ,0)
1034	I TT="PU" S TTNAME= "PATIENT S TATEMENT U PDATE"
1035	"RTN","PRC A313P",105 ,0)
1036	I TT="PY" S TTNAME= "ANNUAL PA YMENT STAT EMENTS"
1037	"RTN","PRC A313P",106 ,0)
1038	;
1039	"RTN","PRC A313P",107 ,0)
1040	; Set 1 l evel value s
1041	"RTN","PRC A313P",108 ,0)
1042	S DIC="^R CT(349.1," ,DIC(0)="L "
1043	"RTN","PRC A313P",109 ,0)
1044	S X=TT
1045	"RTN","PRC A313P",110 ,0)
1046	S DIC("DR ")=".02/// /"_TTNAME_ ";.03////" _1_";"
1047	"RTN","PRC A313P",111 ,0)
1048	D FILE^DI CN
1049	"RTN","PRC A313P",112 ,0)
1050	S IEN=+Y
1051	"RTN","PRC A313P",113 ,0)
1052	;
1053	"RTN","PRC A313P",114 ,0)
1054	; Set 3 l evel
1055	"RTN","PRC A313P",115 ,0)
1056	D SET3(IE N,.DOMAIN)
1057	"RTN","PRC A313P",116 ,0)
1058	;
1059	"RTN","PRC A313P",117 ,0)
1060	Q
1061	"RTN","PRC A313P",118 ,0)
1062	SET3(IEN,D OMAIN) ; PRCA4.53 13
1063	"RTN","PRC A313P",119 ,0)
1064	; Set 3 l evel for 3 49.1
1065	"RTN","PRC A313P",120 ,0)
1066	S DOMAIN( "IEN")=$O( ^DIC(4.2," B",DOMAIN( 3),0))
1067	"RTN","PRC A313P",121 ,0)
1068	S ^RCT(34 9.1,IEN,3) =DOMAIN(1) _U_DOMAIN( "IEN")_U_D OMAIN(3)
1069	"RTN","PRC A313P",122 ,0)
1070	;
1071	"RTN","PRC A313P",123 ,0)
1072	Q
1073	"RTN","PRC A313P",124 ,0)
1074	;
1075	"RTN","PRC A313P",125 ,0)
1076	PRE ; Pre -install a ctions for the Data Dictionary
1077	"RTN","PRC A313P",126 ,0)
1078	;
1079	"RTN","PRC A313P",127 ,0)
1080	W !,"Star ting Pre-I nstall Cha nges."
1081	"RTN","PRC A313P",128 ,0)
1082	;
1083	"RTN","PRC A313P",129 ,0)
1084	N DIK,DA
1085	"RTN","PRC A313P",130 ,0)
1086	; Remove DD for 349 .1, elemen ts 41, 42, and 43 - new elemen ts are ent ered duri
1087	ng regular install
1088	"RTN","PRC A313P",131 ,0)
1089	S DIK="^D D(349.1,", DA(1)=349. 1
1090	"RTN","PRC A313P",132 ,0)
1091	F DA=41,4 2,43 D ^DI K
1092	"RTN","PRC A313P",133 ,0)
1093	;
1094	"RTN","PRC A313P",134 ,0)
1095	; Remove DD for 349 , element .09 to cha nge from o ld to new Style Cros s Referen
1096	ce.
1097	"RTN","PRC A313P",135 ,0)
1098	S DIK="^D D(349,",DA (1)=349
1099	"RTN","PRC A313P",136 ,0)
1100	S DA=.09 D ^DIK
1101	"RTN","PRC A313P",137 ,0)
1102	;
1103	"RTN","PRC A313P",138 ,0)
1104	W !,"Pre- Install Ch anges comp lete."
1105	"RTN","PRC A313P",139 ,0)
1106	Q
1107	"RTN","PRC AACR")
1108	0^19^B1249 55572^n/a
1109	"RTN","PRC AACR",1,0)
1110	PRCAACR ;A LBANY/BDB- PATIENT ST ATEMENTS A UTO-CORREC TION REPOR T ;09/21/1 5 3:34 PM
1111	"RTN","PRC AACR",2,0)
1112	;;4.5;Acc ounts Rece ivable;3 07,313;M ar 20, 199 5;Build 11 3
1113	"RTN","PRC AACR",3,0)
1114	;;Per VA Directive 6402, this routine s hould not be modifie d.
1115	"RTN","PRC AACR",4,0)
1116	;
1117	"RTN","PRC AACR",5,0)
1118	Q
1119	"RTN","PRC AACR",6,0)
1120	;
1121	"RTN","PRC AACR",7,0)
1122	PSACRT ; r eport, pri nts sorted individua l transact ions that have been auto-corr
1123	ected
1124	"RTN","PRC AACR",8,0)
1125	N DIC,PAG E,BY,DHD,F ILENUM,FLD S,FR,L,TO, PRCABDT,PR CAEDT,PRCA SORT
1126	"RTN","PRC AACR",9,0)
1127	W !
1128	"RTN","PRC AACR",10,0 )
1129	PSDATE ;
1130	"RTN","PRC AACR",11,0 )
1131	; Determi ne if Auto Correct p rocess is currently running
1132	"RTN","PRC AACR",12,0 )
1133	N PRCASTR T,QUIT,X,X 1,X2,Y
1134	"RTN","PRC AACR",13,0 )
1135	S PRCASTR T=$G(^XTMP ("PRCACPS" ,0)),QUIT= ""
1136	"RTN","PRC AACR",14,0 )
1137	; QUIT if Auto Corr ect proces s is curre ntly runni ng
1138	"RTN","PRC AACR",15,0 )
1139	I PRCASTR T'="" D Q :QUIT
1140	"RTN","PRC AACR",16,0 )
1141	.S Y=$P(P RCASTRT,U, 2)
1142	"RTN","PRC AACR",17,0 )
1143	.D DD^%DT
1144	"RTN","PRC AACR",18,0 )
1145	.S PRCAST RT=Y
1146	"RTN","PRC AACR",19,0 )
1147	.W !!,"Th e Patient Statement Auto-Corre ction Prog ram is cur rently run ning."
1148	"RTN","PRC AACR",20,0 )
1149	.W !,"It was starte d at ",PRC ASTRT," an d can take up to 1 h our to com plete."
1150	"RTN","PRC AACR",21,0 )
1151	.W !!,"If you choos e to conti nue with t his report , it may n ot reflect all of t
1152	he"
1153	"RTN","PRC AACR",22,0 )
1154	.W !,"cha nges from this lates t run of t he Patient Statement Auto-Corr ection Pr
1155	ogram."
1156	"RTN","PRC AACR",23,0 )
1157	.W !
1158	"RTN","PRC AACR",24,0 )
1159	.S DIR(0) ="Y",DIR(" A")="Do yo u want to continue", DIR("B")=" NO"
1160	"RTN","PRC AACR",25,0 )
1161	.D ^DIR
1162	"RTN","PRC AACR",26,0 )
1163	.W !
1164	"RTN","PRC AACR",27,0 )
1165	.; Quit i f ^, ^^, T imeout or No
1166	"RTN","PRC AACR",28,0 )
1167	.I $D(DTO UT)!($D(DU OUT))!($D( DIROUT))!( Y=0) S QUI T=1
1168	"RTN","PRC AACR",29,0 )
1169	.; Send M ailMan mes sage to PR CACPS mail group if Yes
1170	"RTN","PRC AACR",30,0 )
1171	.I Y=1 D PRCAMAIL^P RCACPS(PRC ASTRT)
1172	"RTN","PRC AACR",31,0 )
1173	.K DTOUT, DUOUT,DIRO UT
1174	"RTN","PRC AACR",32,0 )
1175	;
1176	"RTN","PRC AACR",33,0 )
1177	N DIROUT, DIS,DTOUT, DUOUT
1178	"RTN","PRC AACR",34,0 )
1179	S DIR("A" )="Date Ra nge: FROM: ",DIR("B" )="T-7"
1180	"RTN","PRC AACR",35,0 )
1181	S DIR("?" )="The def ault date is T-7. F uture date s may not be entered ."
1182	"RTN","PRC AACR",36,0 )
1183	S DIR(0)= "DO" D ^DI R
1184	"RTN","PRC AACR",37,0 )
1185	S:Y'="" P RCABDT=Y
1186	"RTN","PRC AACR",38,0 )
1187	I $D(DIRU T)&'Y K DI RUT Q
1188	"RTN","PRC AACR",39,0 )
1189	I PRCABDT >DT G PSDA TE
1190	"RTN","PRC AACR",40,0 )
1191	W "(",Y(0 ),")"
1192	"RTN","PRC AACR",41,0 )
1193	K DIR,X,Y
1194	"RTN","PRC AACR",42,0 )
1195	S DIR(0)= "DO"
1196	"RTN","PRC AACR",43,0 )
1197	S DIR("A" )="Date Ra nge: TO: ",DIR("B" )="T"
1198	"RTN","PRC AACR",44,0 )
1199	S DIR("?" )="The def ault date is T, but any date m ay be ente red."
1200	"RTN","PRC AACR",45,0 )
1201	D ^DIR S: Y="" Y=DT
1202	"RTN","PRC AACR",46,0 )
1203	I $D(DIRU T)&'Y K DI RUT Q
1204	"RTN","PRC AACR",47,0 )
1205	W "(",Y(0 ),")"
1206	"RTN","PRC AACR",48,0 )
1207	S PRCAEDT =Y
1208	"RTN","PRC AACR",49,0 )
1209	I PRCABDT >PRCAEDT G PSDATE
1210	"RTN","PRC AACR",50,0 )
1211	K DIR
1212	"RTN","PRC AACR",51,0 )
1213	S DIR(0)= "S^1:Auto- Correct Re ason;2:Deb tor Name;3 :Bill Numb er;4:Trans action Nu
1214	mber;5:Aut o-Correct Date",DIR( "A")="Sort by"
1215	"RTN","PRC AACR",52,0 )
1216	S DIR("B" )=1
1217	"RTN","PRC AACR",53,0 )
1218	D ^DIR K DIR
1219	"RTN","PRC AACR",54,0 )
1220	S PRCASOR T=Y
1221	"RTN","PRC AACR",55,0 )
1222	Q:$D(DTOU T)!($D(DUO UT))!($D(D IROUT))
1223	"RTN","PRC AACR",56,0 )
1224	;
1225	"RTN","PRC AACR",57,0 )
1226	; Prompt for device
1227	"RTN","PRC AACR",58,0 )
1228	W !
1229	"RTN","PRC AACR",59,0 )
1230	N ZTRTN,Z TDESC,ZTSA VE
1231	"RTN","PRC AACR",60,0 )
1232	K IOP,%ZI S,POP,IO(" Q")
1233	"RTN","PRC AACR",61,0 )
1234	S %ZIS="Q "
1235	"RTN","PRC AACR",62,0 )
1236	D ^%ZIS Q :POP
1237	"RTN","PRC AACR",63,0 )
1238	; If Queu ed
1239	"RTN","PRC AACR",64,0 )
1240	I $D(IO(" Q")) D Q
1241	"RTN","PRC AACR",65,0 )
1242	.K IO("Q" )
1243	"RTN","PRC AACR",66,0 )
1244	.I $G(IOS T)["P-MES" S ZTRTN=" PRT^PRCAAC R1"
1245	"RTN","PRC AACR",67,0 )
1246	.I $G(IOS T)'["P-MES " S ZTRTN= "PRT^PRCAA CR"
1247	"RTN","PRC AACR",68,0 )
1248	.S ZTSAVE ("PRCABDT" )="",ZTSAV E("PRCAEDT ")="",ZTSA VE("PRCASO RT")=""
1249	"RTN","PRC AACR",69,0 )
1250	.D ^%ZTLO AD
1251	"RTN","PRC AACR",70,0 )
1252	.D HOME^% ZIS
1253	"RTN","PRC AACR",71,0 )
1254	.I $D(ZTS K)[0 W !!? 5,"Report cancelled! "
1255	"RTN","PRC AACR",72,0 )
1256	.E W !!? 5,"Report queued!"
1257	"RTN","PRC AACR",73,0 )
1258	.K POP
1259	"RTN","PRC AACR",74,0 )
1260	;
1261	"RTN","PRC AACR",75,0 )
1262	;Print Re port if no t QUEUED
1263	"RTN","PRC AACR",76,0 )
1264	PRT ;
1265	"RTN","PRC AACR",77,0 )
1266	; If not queued and output se nt to P-ME S
1267	"RTN","PRC AACR",78,0 )
1268	I $G(IOST )["P-MES" D PRT^PRCA ACR1 Q
1269	"RTN","PRC AACR",79,0 )
1270	;If not q ueued and output not sent to P -MES
1271	"RTN","PRC AACR",80,0 )
1272	U IO
1273	"RTN","PRC AACR",81,0 )
1274	K ^TMP("P RCAACR",$J )
1275	"RTN","PRC AACR",82,0 )
1276	S PAGE=0
1277	"RTN","PRC AACR",83,0 )
1278	S DASH="" ,$P(DASH," -",79)=""
1279	"RTN","PRC AACR",84,0 )
1280	S DIS(0)= "I $D(^PRC A(433,""TA CD"",PRCAT SRT,D0))", L=0
1281	"RTN","PRC AACR",85,0 )
1282	N PRCATSR T,PRCATN,P RCAACD,PRC AACR,PRCAB N,PRCADATA ,PRCADTR,P RCASSN,PRC AACTF,PRC
1283	ATNTF
1284	"RTN","PRC AACR",86,0 )
1285	S PRCATSR T=PRCABDT- .00001
1286	"RTN","PRC AACR",87,0 )
1287	; Loop th rough the specified date range
1288	"RTN","PRC AACR",88,0 )
1289	F S PRCA TSRT=$O(^P RCA(433,"T ACD",PRCAT SRT)) Q:PR CATSRT=""! (PRCATSRT> PRCAEDT)
1290	D
1291	"RTN","PRC AACR",89,0 )
1292	.S PRCATN =""
1293	"RTN","PRC AACR",90,0 )
1294	.; Loop t hrough the transacti ons for th e current date
1295	"RTN","PRC AACR",91,0 )
1296	.F S PRC ATN=$O(^PR CA(433,"TA CD",PRCATS RT,PRCATN) ) Q:'PRCAT N D
1297	"RTN","PRC AACR",92,0 )
1298	..; Load associated data fiel ds for rep ort
1299	"RTN","PRC AACR",93,0 )
1300	..S PRCAT NTF=PRCATN ; Transac tion Numbe r Ticket F lag
1301	"RTN","PRC AACR",94,0 )
1302	..S PRCAB N=$P(^PRCA (433,PRCAT N,0),U,2)
1303	"RTN","PRC AACR",95,0 )
1304	..S PRCAD TR=$$GET1^ DIQ(430,PR CABN_",",9 ) ; (#9) D EBTOR
1305	"RTN","PRC AACR",96,0 )
1306	..S PRCAS SN=$G(^PRC A(430,PRCA BN,0)) ; L oad 0 Node
1307	"RTN","PRC AACR",97,0 )
1308	..S PRCAS SN=$P(PRCA SSN,U,9) ; get IEN o f Debtor
1309	"RTN","PRC AACR",98,0 )
1310	..S PRCAB N=$$GET1^D IQ(433,PRC ATN_",",.0 3) ; (#.03 ) BILL NUM BER
1311	"RTN","PRC AACR",99,0 )
1312	..S PRCAS SN=$$GET1^ DIQ(340,PR CASSN_",", 110) ; SSN
1313	"RTN","PRC AACR",100, 0)
1314	..S PRCAA CD=$$GET1^ DIQ(433,PR CATN_",",9 4,"I") ;(# 94) AUTO-C ORRECTION DATE
1315	"RTN","PRC AACR",101, 0)
1316	..S PRCAA CR=$$GET1^ DIQ(433,PR CATN_",",9 6) ;(#96) AUTO-CORRE CTION TYPE OF ERROR
1317	"RTN","PRC AACR",102, 0)
1318	..S PRCAA CR=$E(PRCA ACR,1,14)
1319	"RTN","PRC AACR",103, 0)
1320	..S PRCAA CTF=$$GET1 ^DIQ(433,P RCATN_",", 97) ;(#97) AUTO-CORRE CTION TICK ET FLAG
1321	"RTN","PRC AACR",104, 0)
1322	..; If Ti cket Flag is set, re set Transa ction Numb er to null
1323	"RTN","PRC AACR",105, 0)
1324	..I PRCAA CTF="YES" S PRCATNTF =""
1325	"RTN","PRC AACR",106, 0)
1326	..;
1327	"RTN","PRC AACR",107, 0)
1328	..; Store in ^TMP s orted by A uto-Correc t Reason, Debtor, #B ill Number
1329	"RTN","PRC AACR",108, 0)
1330	..I PRCAS ORT=1 D Q
1331	"RTN","PRC AACR",109, 0)
1332	...S ^TMP ("PRCAACR" ,$J,PRCAAC R,PRCADTR, PRCABN)=PR CAACR_U_PR CADTR_U_PR CABN_U_PR
1333	CATNTF_U_P RCAACD_U_P RCASSN
1334	"RTN","PRC AACR",110, 0)
1335	..;
1336	"RTN","PRC AACR",111, 0)
1337	..; Store in ^TMP s orted by D ebtor, Bil l Number a nd Transac tion #
1338	"RTN","PRC AACR",112, 0)
1339	..I PRCAS ORT=2 D Q
1340	"RTN","PRC AACR",113, 0)
1341	...S ^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)=PRC ADTR_U_PRC ABN_U_PRCA SSN_U_PRC
1342	ATNTF_U_PR CAACD_U_PR CAACR
1343	"RTN","PRC AACR",114, 0)
1344	..;
1345	"RTN","PRC AACR",115, 0)
1346	..; Store in ^TMP s orted by B ill Number , Debtor a nd Transac tion #
1347	"RTN","PRC AACR",116, 0)
1348	..I PRCAS ORT=3 D Q
1349	"RTN","PRC AACR",117, 0)
1350	...S ^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)=PRC ABN_U_PRCA DTR_U_PRCA SSN_U_PRC
1351	ATNTF_U_PR CAACD_U_PR CAACR
1352	"RTN","PRC AACR",118, 0)
1353	..;
1354	"RTN","PRC AACR",119, 0)
1355	..; Store in ^TMP s orted by T ransaction , Debtor a nd Bill Nu mber
1356	"RTN","PRC AACR",120, 0)
1357	..I PRCAS ORT=4 D Q
1358	"RTN","PRC AACR",121, 0)
1359	...S ^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)=PRC ATNTF_U_PR CADTR_U_PR CABN_U_PR
1360	CASSN_U_PR CAACD_U_PR CAACR
1361	"RTN","PRC AACR",122, 0)
1362	..;
1363	"RTN","PRC AACR",123, 0)
1364	..; Store in ^TMP s orted by A uto-Correc t Reason, Debtor, #B ill Number and Tran
1365	saction Nu mber
1366	"RTN","PRC AACR",124, 0)
1367	..I PRCAS ORT=5 D Q
1368	"RTN","PRC AACR",125, 0)
1369	...S ^TMP ("PRCAACR" ,$J,PRCAAC D,PRCADTR, PRCABN,PRC ATN)=PRCAA CD_U_PRCAD TR_U_PRCA
1370	BN_U_PRCAS SN_U_PRCAT NTF_U_PRCA ACR
1371	"RTN","PRC AACR",126, 0)
1372	;
1373	"RTN","PRC AACR",127, 0)
1374	;
1375	"RTN","PRC AACR",128, 0)
1376	N QUIT ; QUIT befor e end of r eport
1377	"RTN","PRC AACR",129, 0)
1378	S QUIT=""
1379	"RTN","PRC AACR",130, 0)
1380	; Display Auto-Corr ect data s orted by A uto Correc tion Reaso n
1381	"RTN","PRC AACR",131, 0)
1382	I PRCASOR T=1 D
1383	"RTN","PRC AACR",132, 0)
1384	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCAAC R,PRCADTR, PRCABN)=PR CAACR_U_PR CADTR_U_P
1385	RCABN_U_PR CATNTF_U_P RCAACD_U_P RCASSN
1386	"RTN","PRC AACR",133, 0)
1387	.; Displa y Auto Cor rection Re ason heade r
1388	"RTN","PRC AACR",134, 0)
1389	.N Y
1390	"RTN","PRC AACR",135, 0)
1391	.D PSACRT P1
1392	"RTN","PRC AACR",136, 0)
1393	.S PRCAAC R=""
1394	"RTN","PRC AACR",137, 0)
1395	.F S PRC AACR=$O(^T MP("PRCAAC R",$J,PRCA ACR)) Q:PR CAACR="" D Q:QUIT
1396	"RTN","PRC AACR",138, 0)
1397	..S PRCAD TR=""
1398	"RTN","PRC AACR",139, 0)
1399	..F S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC AACR,PRCAD TR)) Q:PRC ADTR="" D Q:QUIT
1400	"RTN","PRC AACR",140, 0)
1401	...S PRCA BN=""
1402	"RTN","PRC AACR",141, 0)
1403	...F S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC AACR,PRCAD TR,PRCABN) ) Q:'PRCAB N D Q:Q
1404	UIT
1405	"RTN","PRC AACR",142, 0)
1406	....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCAAC R,PRCADTR, PRCABN)
1407	"RTN","PRC AACR",143, 0)
1408	....S Y=$ P(PRCADATA ,U,5)
1409	"RTN","PRC AACR",144, 0)
1410	....D DD^ %DT
1411	"RTN","PRC AACR",145, 0)
1412	....S $P( PRCADATA,U ,5)=Y
1413	"RTN","PRC AACR",146, 0)
1414	....W !,$ P(PRCADATA ,U,1),?16, $E($P(PRCA DATA,U,2), 1,18),?36, $E($P(PRCA DATA,U,6)
1415	,6,9),?42, $E($P(PRCA DATA,U,3), 1,11),?55, $J($P(PRCA DATA,U,4), 9),?66,$P( PRCADATA,
1416	U,5)
1417	"RTN","PRC AACR",147, 0)
1418	....I $Y> (IOSL-3) D
1419	"RTN","PRC AACR",148, 0)
1420	.....I $E (IOST,1,2) ="C-" D Q :QUIT
1421	"RTN","PRC AACR",149, 0)
1422	......D P RTC
1423	"RTN","PRC AACR",150, 0)
1424	......I $ D(DIRUT)!( $D(DTOUT)) S QUIT=1
1425	"RTN","PRC AACR",151, 0)
1426	.....D PS ACRTP1
1427	"RTN","PRC AACR",152, 0)
1428	;
1429	"RTN","PRC AACR",153, 0)
1430	; Display Auto-Corr ect data s orted by D ebtor
1431	"RTN","PRC AACR",154, 0)
1432	I PRCASOR T=2 D
1433	"RTN","PRC AACR",155, 0)
1434	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)=PRC ADTR_U_PRC ABN_U_PRC
1435	ASSN_U_PRC ATNTF_U_PR CAACD_U_PR CAACR
1436	"RTN","PRC AACR",156, 0)
1437	.; Displa y Debtor h eader
1438	"RTN","PRC AACR",157, 0)
1439	.D PSACRT P2
1440	"RTN","PRC AACR",158, 0)
1441	.S PRCADT R=""
1442	"RTN","PRC AACR",159, 0)
1443	.F S PRC ADTR=$O(^T MP("PRCAAC R",$J,PRCA DTR)) Q:PR CADTR="" D Q:QUIT
1444	"RTN","PRC AACR",160, 0)
1445	..S PRCAB N=""
1446	"RTN","PRC AACR",161, 0)
1447	..F S PR CABN=$O(^T MP("PRCAAC R",$J,PRCA DTR,PRCABN )) Q:'PRCA BN D Q:Q UIT
1448	"RTN","PRC AACR",162, 0)
1449	...S PRCA TN=""
1450	"RTN","PRC AACR",163, 0)
1451	...F S P RCATN=$O(^ TMP("PRCAA CR",$J,PRC ADTR,PRCAB N,PRCATN)) Q:'PRCATN D Q:QU
1452	IT
1453	"RTN","PRC AACR",164, 0)
1454	....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)
1455	"RTN","PRC AACR",165, 0)
1456	....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
1457	"RTN","PRC AACR",166, 0)
1458	....W !,$ E($P(PRCAD ATA,U,1),1 ,18),?20,$ P(PRCADATA ,U,2),?33, $E($P(PRCA DATA,U,3)
1459	,6,9),?39, $J($P(PRCA DATA,U,4), 9),?50,$P( PRCADATA,U ,5),?64,$P (PRCADATA, U,6)
1460	"RTN","PRC AACR",167, 0)
1461	....I $Y> (IOSL-3) D
1462	"RTN","PRC AACR",168, 0)
1463	.....I $E (IOST,1,2) ="C-" D Q :QUIT
1464	"RTN","PRC AACR",169, 0)
1465	......D P RTC
1466	"RTN","PRC AACR",170, 0)
1467	......I $ D(DIRUT)!( $D(DTOUT)) S QUIT=1
1468	"RTN","PRC AACR",171, 0)
1469	.....D PS ACRTP2
1470	"RTN","PRC AACR",172, 0)
1471	;
1472	"RTN","PRC AACR",173, 0)
1473	; Display Auto-Corr ect data s orted by A UTO-C DATE
1474	"RTN","PRC AACR",174, 0)
1475	I PRCASOR T=3 D
1476	"RTN","PRC AACR",175, 0)
1477	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)=PRC ABN_U_PRCA DTR_U_PRC
1478	ASSN_U_PRC ATNTF_U_PR CAACD_U_PR CAACR
1479	"RTN","PRC AACR",176, 0)
1480	.; Displa y Bill Num ber header
1481	"RTN","PRC AACR",177, 0)
1482	.D PSACRT P3
1483	"RTN","PRC AACR",178, 0)
1484	.S PRCABN =""
1485	"RTN","PRC AACR",179, 0)
1486	.F S PRC ABN=$O(^TM P("PRCAACR ",$J,PRCAB N)) Q:'PRC ABN D Q: QUIT
1487	"RTN","PRC AACR",180, 0)
1488	..S PRCAD TR=""
1489	"RTN","PRC AACR",181, 0)
1490	..F S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC ABN,PRCADT R)) Q:PRCA DTR="" D Q:QUIT
1491	"RTN","PRC AACR",182, 0)
1492	...S PRCA TN=""
1493	"RTN","PRC AACR",183, 0)
1494	...F S P RCATN=$O(^ TMP("PRCAA CR",$J,PRC ABN,PRCADT R,PRCATN)) Q:'PRCATN D Q:QU
1495	IT
1496	"RTN","PRC AACR",184, 0)
1497	....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)
1498	"RTN","PRC AACR",185, 0)
1499	....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
1500	"RTN","PRC AACR",186, 0)
1501	....W !,$ P(PRCADATA ,U,1),?13, $E($P(PRCA DATA,U,2), 1,18),?33, $E($P(PRCA DATA,U,3)
1502	,6,9),?39, $J($P(PRCA DATA,U,4), 9),?50,$P( PRCADATA,U ,5),?64,$P (PRCADATA, U,6)
1503	"RTN","PRC AACR",187, 0)
1504	....I $Y> (IOSL-3) D
1505	"RTN","PRC AACR",188, 0)
1506	.....I $E (IOST,1,2) ="C-" D Q :QUIT
1507	"RTN","PRC AACR",189, 0)
1508	......D P RTC
1509	"RTN","PRC AACR",190, 0)
1510	......I $ D(DIRUT)!( $D(DTOUT)) S QUIT=1
1511	"RTN","PRC AACR",191, 0)
1512	.....D PS ACRTP3
1513	"RTN","PRC AACR",192, 0)
1514	;
1515	"RTN","PRC AACR",193, 0)
1516	; Display Auto-Corr ect data s orted by T ransaction Number
1517	"RTN","PRC AACR",194, 0)
1518	I PRCASOR T=4 D
1519	"RTN","PRC AACR",195, 0)
1520	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)=PRC ATNTF_U_PR CADTR_U_P
1521	RCABN_U_PR CASSN_U_PR CAACD_U_PR CAACR
1522	"RTN","PRC AACR",196, 0)
1523	.; Displa y AUTO-C D ATE header
1524	"RTN","PRC AACR",197, 0)
1525	.D PSACRT P4
1526	"RTN","PRC AACR",198, 0)
1527	.S PRCATN =""
1528	"RTN","PRC AACR",199, 0)
1529	.F S PRC ATN=$O(^TM P("PRCAACR ",$J,PRCAT N)) Q:'PRC ATN D Q: QUIT
1530	"RTN","PRC AACR",200, 0)
1531	..S PRCAD TR=""
1532	"RTN","PRC AACR",201, 0)
1533	..F S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC ATN,PRCADT R)) Q:PRCA DTR="" D Q:QUIT
1534	"RTN","PRC AACR",202, 0)
1535	...S PRCA BN=""
1536	"RTN","PRC AACR",203, 0)
1537	...F S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC ATN,PRCADT R,PRCABN)) Q:'PRCABN D Q:QU
1538	IT
1539	"RTN","PRC AACR",204, 0)
1540	....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)
1541	"RTN","PRC AACR",205, 0)
1542	....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
1543	"RTN","PRC AACR",206, 0)
1544	....W !,$ J($P(PRCAD ATA,U,1),9 ),?11,$E($ P(PRCADATA ,U,2),1,18 ),?31,$P(P RCADATA,U
1545	,3),?44,$E ($P(PRCADA TA,U,4),6, 9),?50,$P( PRCADATA,U ,5),?64,$P (PRCADATA, U,6)
1546	"RTN","PRC AACR",207, 0)
1547	....I $Y> (IOSL-3) D
1548	"RTN","PRC AACR",208, 0)
1549	.....I $E (IOST,1,2) ="C-" D Q :QUIT
1550	"RTN","PRC AACR",209, 0)
1551	......D P RTC
1552	"RTN","PRC AACR",210, 0)
1553	......I $ D(DIRUT)!( $D(DTOUT)) S QUIT=1
1554	"RTN","PRC AACR",211, 0)
1555	.....D PS ACRTP4
1556	"RTN","PRC AACR",212, 0)
1557	;
1558	"RTN","PRC AACR",213, 0)
1559	; Display Auto-Corr ect data s orted by A uto-Correc t date
1560	"RTN","PRC AACR",214, 0)
1561	I PRCASOR T=5 D
1562	"RTN","PRC AACR",215, 0)
1563	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCAAC D,PRCADTR, PRCABN,PRC ATN)=PRCAA CD_U_PRCA
1564	DTR_U_PRCA BN_U_PRCAS SN_U_PRCAT NTF_U_PRCA ACR
1565	"RTN","PRC AACR",216, 0)
1566	.; Displa y AUTO-C D ATE header
1567	"RTN","PRC AACR",217, 0)
1568	.D PSACRT P5
1569	"RTN","PRC AACR",218, 0)
1570	.S PRCAAC D=""
1571	"RTN","PRC AACR",219, 0)
1572	.F S PRC AACD=$O(^T MP("PRCAAC R",$J,PRCA ACD)) Q:PR CAACD="" D Q:QUIT
1573	"RTN","PRC AACR",220, 0)
1574	..S PRCAD TR=""
1575	"RTN","PRC AACR",221, 0)
1576	..F S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC AACD,PRCAD TR)) Q:PRC ADTR="" D Q:QUIT
1577	"RTN","PRC AACR",222, 0)
1578	...S PRCA BN=""
1579	"RTN","PRC AACR",223, 0)
1580	...F S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC AACD,PRCAD TR,PRCABN) ) Q:'PRCAB N D Q:Q
1581	UIT
1582	"RTN","PRC AACR",224, 0)
1583	....S PRC ATN=""
1584	"RTN","PRC AACR",225, 0)
1585	....F S PRCATN=$O( ^TMP("PRCA ACR",$J,PR CAACD,PRCA DTR,PRCABN ,PRCATN)) Q:'PRCATN
1586	D Q:QUI T
1587	"RTN","PRC AACR",226, 0)
1588	.....S PR CADATA=^TM P("PRCAACR ",$J,PRCAA CD,PRCADTR ,PRCABN,PR CATN)
1589	"RTN","PRC AACR",227, 0)
1590	.....S $P (PRCADATA, U,1)=$$GET 1^DIQ(433, PRCATN_"," ,94)
1591	"RTN","PRC AACR",228, 0)
1592	.....W !, $P(PRCADAT A,U,1),?14 ,$E($P(PRC ADATA,U,2) ,1,18),?34 ,$P(PRCADA TA,U,3),?
1593	47,$E($P(P RCADATA,U, 4),6,9),?5 3,$J($P(PR CADATA,U,5 ),9),?64,$ P(PRCADATA ,U,6)
1594	"RTN","PRC AACR",229, 0)
1595	.....I $Y >(IOSL-3) D
1596	"RTN","PRC AACR",230, 0)
1597	......I $ E(IOST,1,2 )="C-" D Q:QUIT
1598	"RTN","PRC AACR",231, 0)
1599	.......D PRTC
1600	"RTN","PRC AACR",232, 0)
1601	.......I $D(DIRUT)! ($D(DTOUT) ) S QUIT=1
1602	"RTN","PRC AACR",233, 0)
1603	......D P SACRTP5
1604	"RTN","PRC AACR",234, 0)
1605	D ^%ZISC
1606	"RTN","PRC AACR",235, 0)
1607	I $E(IOST ,1,2)="C-" ,'$D(DUOUT ),('$D(DTO UT)) W ! S DIR(0)="E " D ^DIR
1608	"RTN","PRC AACR",236, 0)
1609	K X,Y,DAS H,D0
1610	"RTN","PRC AACR",237, 0)
1611	Q
1612	"RTN","PRC AACR",238, 0)
1613	;
1614	"RTN","PRC AACR",239, 0)
1615	PRTC ; Pre ss Return To Continu e
1616	"RTN","PRC AACR",240, 0)
1617	S DIR(0)= "E" D ^DIR
1618	"RTN","PRC AACR",241, 0)
1619	Q
1620	"RTN","PRC AACR",242, 0)
1621	;
1622	"RTN","PRC AACR",243, 0)
1623	PSACRTP1 ; header fo r patient statement auto-corre ction repo rt 1
1624	"RTN","PRC AACR",244, 0)
1625	W @IOF
1626	"RTN","PRC AACR",245, 0)
1627	S PAGE=PA GE+1
1628	"RTN","PRC AACR",246, 0)
1629	W "PAGE " _PAGE,?8," AUTO-CORRE CTED BILLS (SORTED B Y AUTO-COR RECTION RE ASON)",?6
1630	6,$$UPPER^ VALM1($$FM TE^XLFDT(D T))
1631	"RTN","PRC AACR",247, 0)
1632	W !,DASH, !
1633	"RTN","PRC AACR",248, 0)
1634	W !,"AUTO -C REASON" ,?16,"DEBT OR",?36,"S SN",?42,"B ILL NO.",? 55,"TRANS NUM",?66,
1635	"AUTO-C DA TE"
1636	"RTN","PRC AACR",249, 0)
1637	W !,"---- ---------- ",?16,"--- ---------- -----",?36 ,"----",?4 2,"------- ----",?55
1638	,"-------- -",?66,"-- ---------- "
1639	"RTN","PRC AACR",250, 0)
1640	Q
1641	"RTN","PRC AACR",251, 0)
1642	;
1643	"RTN","PRC AACR",252, 0)
1644	PSACRTP2 ; header fo r patient statement auto-corre ction repo rt 2
1645	"RTN","PRC AACR",253, 0)
1646	W @IOF
1647	"RTN","PRC AACR",254, 0)
1648	S PAGE=PA GE+1
1649	"RTN","PRC AACR",255, 0)
1650	W "PAGE " _PAGE,?8," AUTO-CORRE CTED BILLS (SORTED B Y DEBTOR)" ,?66,$$UPP ER^VALM1(
1651	$$FMTE^XLF DT(DT))
1652	"RTN","PRC AACR",256, 0)
1653	W !,DASH, !
1654	"RTN","PRC AACR",257, 0)
1655	W !,"DEBT OR",?20,"B ILL NO.",? 33,"SSN",? 39,"TRANS NUM",?50," AUTO-C DAT E",?64,"A
1656	UTO-C REAS ON"
1657	"RTN","PRC AACR",258, 0)
1658	W !,"---- ---------- ----",?20, "--------- --",?33,"- ---",?39," ---------" ,?50,"---
1659	---------" ,?64,"---- ---------- "
1660	"RTN","PRC AACR",259, 0)
1661	Q
1662	"RTN","PRC AACR",260, 0)
1663	;
1664	"RTN","PRC AACR",261, 0)
1665	PSACRTP3 ; header fo r patient statement auto-corre ction repo rt 3
1666	"RTN","PRC AACR",262, 0)
1667	W @IOF
1668	"RTN","PRC AACR",263, 0)
1669	S PAGE=PA GE+1
1670	"RTN","PRC AACR",264, 0)
1671	W "PAGE " _PAGE,?8," AUTO-CORRE CTED BILLS (SORTED B Y BILL #)" ,?66,$$UPP ER^VALM1(
1672	$$FMTE^XLF DT(DT))
1673	"RTN","PRC AACR",265, 0)
1674	W !,DASH, !
1675	"RTN","PRC AACR",266, 0)
1676	W !,"BILL NO.",?13, "DEBTOR",? 33,"SSN",? 39,"TRANS NUM",?50," AUTO-C DAT E",?64,"A
1677	UTO-C REAS ON"
1678	"RTN","PRC AACR",267, 0)
1679	W !,"---- -------",? 13,"------ ---------- --",?33,"- ---",?39," ---------" ,?50,"---
1680	---------" ,?64,"---- ---------- "
1681	"RTN","PRC AACR",268, 0)
1682	Q
1683	"RTN","PRC AACR",269, 0)
1684	;
1685	"RTN","PRC AACR",270, 0)
1686	PSACRTP4 ; header fo r patient statement auto-corre ction repo rt 4
1687	"RTN","PRC AACR",271, 0)
1688	W @IOF
1689	"RTN","PRC AACR",272, 0)
1690	S PAGE=PA GE+1
1691	"RTN","PRC AACR",273, 0)
1692	W "PAGE " _PAGE,?8," AUTO-CORRE CTED BILLS (SORTED B Y TRANSACT ION NUMBER )",?66,$$
1693	UPPER^VALM 1($$FMTE^X LFDT(DT))
1694	"RTN","PRC AACR",274, 0)
1695	W !,DASH, !
1696	"RTN","PRC AACR",275, 0)
1697	W !,"TRAN S NUM",?11 ,"DEBTOR", ?31,"BILL NO.",?44," SSN",?50," AUTO-C DAT E",?64,"A
1698	UTO-C REAS ON"
1699	"RTN","PRC AACR",276, 0)
1700	W !,"---- -----",?11 ,"-------- ---------- ",?31,"--- --------", ?44,"----" ,?50,"---
1701	---------" ,?64,"---- ---------- "
1702	"RTN","PRC AACR",277, 0)
1703	Q
1704	"RTN","PRC AACR",278, 0)
1705	;
1706	"RTN","PRC AACR",279, 0)
1707	PSACRTP5 ; header fo r patient statement auto-corre ction repo rt 5
1708	"RTN","PRC AACR",280, 0)
1709	W @IOF
1710	"RTN","PRC AACR",281, 0)
1711	S PAGE=PA GE+1
1712	"RTN","PRC AACR",282, 0)
1713	W "PAGE " _PAGE,?8," AUTO-CORRE CTED BILLS (SORTED B Y AUTO-COR RECTION DA TE)",?66,
1714	$$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
1715	"RTN","PRC AACR",283, 0)
1716	W !,DASH, !
1717	"RTN","PRC AACR",284, 0)
1718	W !,"AUTO -C DATE",? 14,"DEBTOR ",?34,"BIL L NO.",?47 ,"SSN",?53 ,"TRANS NU M",?64,"A
1719	UTO-C REAS ON"
1720	"RTN","PRC AACR",285, 0)
1721	W !,"---- --------", ?14,"----- ---------- ---",?34," ---------- -",?47,"-- --",?53,"
1722	---------" ,?64,"---- ---------- "
1723	"RTN","PRC AACR",286, 0)
1724	Q
1725	"RTN","PRC AACR",287, 0)
1726	;
1727	"RTN","PRC AACR",288, 0)
1728	EXIT ;
1729	"RTN","PRC AACR",289, 0)
1730	Q
1731	"RTN","PRC AACR1")
1732	0^20^B1512 71441^n/a
1733	"RTN","PRC AACR1",1,0 )
1734	PRCAACR1 ; ALBANY/BDB -PATIENT S TATEMENTS AUTO-CORRE CTION REPO RT ;09/21/ 15 3:34 P
1735	M
1736	"RTN","PRC AACR1",2,0 )
1737	;;4.5;Acc ounts Rece ivable;3 07,313;M ar 20, 199 5;Build 11 3
1738	"RTN","PRC AACR1",3,0 )
1739	;;Per VA Directive 6402, this routine s hould not be modifie d.
1740	"RTN","PRC AACR1",4,0 )
1741	;
1742	"RTN","PRC AACR1",5,0 )
1743	Q
1744	"RTN","PRC AACR1",6,0 )
1745	;Print Re port when Queued to P-MES
1746	"RTN","PRC AACR1",7,0 )
1747	PRT ;
1748	"RTN","PRC AACR1",8,0 )
1749	U IO
1750	"RTN","PRC AACR1",9,0 )
1751	; build a rray of tr ansaction auto-corre cted
1752	"RTN","PRC AACR1",10, 0)
1753	K ^TMP("P RCAACR1",$ J)
1754	"RTN","PRC AACR1",11, 0)
1755	N DASH,PA GE
1756	"RTN","PRC AACR1",12, 0)
1757	S PAGE=0
1758	"RTN","PRC AACR1",13, 0)
1759	S DASH="" ,$P(DASH," -",79)=""
1760	"RTN","PRC AACR1",14, 0)
1761	N PRCATSR T,PRCATN,P RCAACD,PRC AACR,PRCAB N,PRCADATA ,PRCADTR,P RCASSN,PRC AIEN,PRCA
1762	ACTF,PRCAT NTF,PRCATE MP
1763	"RTN","PRC AACR1",15, 0)
1764	S PRCATSR T=PRCABDT- .00001,PRC AIEN=0
1765	"RTN","PRC AACR1",16, 0)
1766	; Loop th rough the specified date range
1767	"RTN","PRC AACR1",17, 0)
1768	F S PRCA TSRT=$O(^P RCA(433,"T ACD",PRCAT SRT)) Q:PR CATSRT=""! (PRCATSRT> PRCAEDT)
1769	D
1770	"RTN","PRC AACR1",18, 0)
1771	.S PRCATN =""
1772	"RTN","PRC AACR1",19, 0)
1773	.; Loop t hrough the transacti ons for th e current date
1774	"RTN","PRC AACR1",20, 0)
1775	.F S PRC ATN=$O(^PR CA(433,"TA CD",PRCATS RT,PRCATN) ) Q:'PRCAT N D
1776	"RTN","PRC AACR1",21, 0)
1777	..; Load associated data fiel ds for rep ort
1778	"RTN","PRC AACR1",22, 0)
1779	..S PRCAT NTF=PRCATN ; Transac tion Numbe r Ticket F lag
1780	"RTN","PRC AACR1",23, 0)
1781	..S PRCAB N=$P(^PRCA (433,PRCAT N,0),U,2)
1782	"RTN","PRC AACR1",24, 0)
1783	..S PRCAD TR=$$GET1^ DIQ(430,PR CABN_",",9 ) ; (#9) D EBTOR
1784	"RTN","PRC AACR1",25, 0)
1785	..S PRCAS SN=$G(^PRC A(430,PRCA BN,0)) ; L oad 0 Node
1786	"RTN","PRC AACR1",26, 0)
1787	..S PRCAS SN=$P(PRCA SSN,U,9) ; get IEN o f Debtor
1788	"RTN","PRC AACR1",27, 0)
1789	..S PRCAB N=$$GET1^D IQ(433,PRC ATN_",",.0 3) ; (#.03 ) BILL NUM BER
1790	"RTN","PRC AACR1",28, 0)
1791	..S PRCAS SN=$$GET1^ DIQ(340,PR CASSN_",", 110) ; SSN
1792	"RTN","PRC AACR1",29, 0)
1793	..S PRCAS SN=$E(PRCA SSN,6,9)
1794	"RTN","PRC AACR1",30, 0)
1795	..S PRCAA CD=$$GET1^ DIQ(433,PR CATN_",",9 4,"I") ;(# 94) AUTO-C ORRECTION DATE
1796	"RTN","PRC AACR1",31, 0)
1797	..S PRCAA CR=$$GET1^ DIQ(433,PR CATN_",",9 6) ;(#96) AUTO-CORRE CTION TYPE OF ERROR
1798	"RTN","PRC AACR1",32, 0)
1799	..S PRCAA CR=$E(PRCA ACR,1,14)
1800	"RTN","PRC AACR1",33, 0)
1801	..S PRCAA CTF=$$GET1 ^DIQ(433,P RCATN_",", 97) ;(#97) AUTO-CORRE CTION TICK ET FLAG
1802	"RTN","PRC AACR1",34, 0)
1803	..; If Ti cket Flag is set, re set Transa ction Numb er to null
1804	"RTN","PRC AACR1",35, 0)
1805	..I PRCAA CTF="YES" S PRCATNTF =""
1806	"RTN","PRC AACR1",36, 0)
1807	..;
1808	"RTN","PRC AACR1",37, 0)
1809	..; Stor e in ^TMP sorted by Auto-Corre ct Reason, Debtor an d Bill Num ber #
1810	"RTN","PRC AACR1",38, 0)
1811	..I PRCAS ORT=1 D Q
1812	"RTN","PRC AACR1",39, 0)
1813	...S ^TMP ("PRCAACR" ,$J,PRCAAC R,PRCADTR, PRCABN)=PR CAACR_U_PR CADTR_U_PR CABN_U_PR
1814	CATNTF_U_P RCAACD_U_P RCASSN
1815	"RTN","PRC AACR1",40, 0)
1816	..;
1817	"RTN","PRC AACR1",41, 0)
1818	..; Store in ^TMP s orted by D ebtor, Bil l Number a nd Transac tion #
1819	"RTN","PRC AACR1",42, 0)
1820	..I PRCAS ORT=2 D Q
1821	"RTN","PRC AACR1",43, 0)
1822	...S ^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)=PRC ADTR_U_PRC ABN_U_PRCA SSN_U_PRC
1823	ATNTF_U_PR CAACD_U_PR CAACR
1824	"RTN","PRC AACR1",44, 0)
1825	..;
1826	"RTN","PRC AACR1",45, 0)
1827	..; Store in ^TMP s orted by B ill Number , Debtor a nd Transac tion #
1828	"RTN","PRC AACR1",46, 0)
1829	..I PRCAS ORT=3 D Q
1830	"RTN","PRC AACR1",47, 0)
1831	...S ^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)=PRC ABN_U_PRCA DTR_U_PRCA SSN_U_PRC
1832	ATNTF_U_PR CAACD_U_PR CAACR
1833	"RTN","PRC AACR1",48, 0)
1834	..;
1835	"RTN","PRC AACR1",49, 0)
1836	..; Store in ^TMP s orted by T ransaction , Debtor a nd #Bill N umber
1837	"RTN","PRC AACR1",50, 0)
1838	..I PRCAS ORT=4 D Q
1839	"RTN","PRC AACR1",51, 0)
1840	...S ^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)=PRC ATNTF_U_PR CADTR_U_PR CABN_U_PR
1841	CASSN_U_PR CAACD_U_PR CAACR
1842	"RTN","PRC AACR1",52, 0)
1843	..;
1844	"RTN","PRC AACR1",53, 0)
1845	..; Store in ^TMP s orted by A uto-Correc t Date, De btor, #Bil l Number a nd Transa
1846	ction Numb er
1847	"RTN","PRC AACR1",54, 0)
1848	..I PRCAS ORT=5 D Q
1849	"RTN","PRC AACR1",55, 0)
1850	...S ^TMP ("PRCAACR" ,$J,PRCAAC D,PRCADTR, PRCABN,PRC ATN)=PRCAA CD_U_PRCAD TR_U_PRCA
1851	BN_U_PRCAS SN_U_PRCAT NTF_U_PRCA ACR
1852	"RTN","PRC AACR1",56, 0)
1853	..Q
1854	"RTN","PRC AACR1",57, 0)
1855	;
1856	"RTN","PRC AACR1",58, 0)
1857	; Display Auto-Corr ect data s orted by B ill Number
1858	"RTN","PRC AACR1",59, 0)
1859	I PRCASOR T=1 D
1860	"RTN","PRC AACR1",60, 0)
1861	.; Print Header
1862	"RTN","PRC AACR1",61, 0)
1863	.D PSACRT P1
1864	"RTN","PRC AACR1",62, 0)
1865	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCAAC R,PRCADTR, PRCABN)=PR CAACR_U_PR CADTR_U_P
1866	RCABN_U_PR CATNTF_U_P RCAACD_U_P RCASSN
1867	"RTN","PRC AACR1",63, 0)
1868	.S PRCAAC R=""
1869	"RTN","PRC AACR1",64, 0)
1870	.N Y
1871	"RTN","PRC AACR1",65, 0)
1872	.F S PRC AACR=$O(^T MP("PRCAAC R",$J,PRCA ACR)) Q:PR CAACR="" D
1873	"RTN","PRC AACR1",66, 0)
1874	..S PRCAD TR=""
1875	"RTN","PRC AACR1",67, 0)
1876	..F S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC AACR,PRCAD TR)) Q:PRC ADTR="" D
1877	"RTN","PRC AACR1",68, 0)
1878	...S PRCA BN=""
1879	"RTN","PRC AACR1",69, 0)
1880	...F S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC AACR,PRCAD TR,PRCABN) ) Q:'PRCAB N D
1881	"RTN","PRC AACR1",70, 0)
1882	....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCAAC R,PRCADTR, PRCABN)
1883	"RTN","PRC AACR1",71, 0)
1884	....S Y=$ P(PRCADATA ,U,5)
1885	"RTN","PRC AACR1",72, 0)
1886	....D DD^ %DT
1887	"RTN","PRC AACR1",73, 0)
1888	....S $P( PRCADATA,U ,5)=Y
1889	"RTN","PRC AACR1",74, 0)
1890	....S PRC AIEN=PRCAI EN+1
1891	"RTN","PRC AACR1",75, 0)
1892	....; Add Auto-Corr ect Reason
1893	"RTN","PRC AACR1",76, 0)
1894	....S PRC ATEMP=$E($ P(PRCADATA ,U,1),1,14 ),$E(PRCAT EMP,16)=" "
1895	"RTN","PRC AACR1",77, 0)
1896	....; Add 18 chars of Debtor' s name
1897	"RTN","PRC AACR1",78, 0)
1898	....S PRC ATEMP=PRCA TEMP_$E($P (PRCADATA, U,2),1,18) ,$E(PRCATE MP,36)=" "
1899	"RTN","PRC AACR1",79, 0)
1900	....; Add SSN
1901	"RTN","PRC AACR1",80, 0)
1902	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,6 ),$E(PRCAT EMP,42)=" "
1903	"RTN","PRC AACR1",81, 0)
1904	....; Add Bill Numb er
1905	"RTN","PRC AACR1",82, 0)
1906	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,3 ),$E(PRCAT EMP,55)=" "
1907	"RTN","PRC AACR1",83, 0)
1908	....; Add Transacti on Number
1909	"RTN","PRC AACR1",84, 0)
1910	....S PRC ATEMP=PRCA TEMP_$J($P (PRCADATA, U,4),9),$E (PRCATEMP, 66)=" "
1911	"RTN","PRC AACR1",85, 0)
1912	....; Add Auto-Corr ect Date
1913	"RTN","PRC AACR1",86, 0)
1914	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,5 ),$E(PRCAT EMP,74)=" "
1915	"RTN","PRC AACR1",87, 0)
1916	....S ^TM P("PRCAACR 1",$J,PRCA IEN)=PRCAT EMP
1917	"RTN","PRC AACR1",88, 0)
1918	....Q
1919	"RTN","PRC AACR1",89, 0)
1920	;
1921	"RTN","PRC AACR1",90, 0)
1922	; Store i n ^TMP sor ted by Deb tor, Bill Number and Transacti on #
1923	"RTN","PRC AACR1",91, 0)
1924	I PRCASOR T=2 D
1925	"RTN","PRC AACR1",92, 0)
1926	.; Print Header
1927	"RTN","PRC AACR1",93, 0)
1928	.D PSACRT P2
1929	"RTN","PRC AACR1",94, 0)
1930	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)=PRC ADTR_U_PRC ABN_U_PRC
1931	ASSN_U_PRC ATNTF_U_PR CAACD_U_PR CAACR
1932	"RTN","PRC AACR1",95, 0)
1933	.S PRCADT R=""
1934	"RTN","PRC AACR1",96, 0)
1935	.F S PRC ADTR=$O(^T MP("PRCAAC R",$J,PRCA DTR)) Q:PR CADTR="" D
1936	"RTN","PRC AACR1",97, 0)
1937	..S PRCAB N=""
1938	"RTN","PRC AACR1",98, 0)
1939	..F S PR CABN=$O(^T MP("PRCAAC R",$J,PRCA DTR,PRCABN )) Q:'PRCA BN D
1940	"RTN","PRC AACR1",99, 0)
1941	...S PRCA TN=""
1942	"RTN","PRC AACR1",100 ,0)
1943	...F S P RCATN=$O(^ TMP("PRCAA CR",$J,PRC ADTR,PRCAB N,PRCATN)) Q:'PRCATN D
1944	"RTN","PRC AACR1",101 ,0)
1945	....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)
1946	"RTN","PRC AACR1",102 ,0)
1947	....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
1948	"RTN","PRC AACR1",103 ,0)
1949	....S PRC AIEN=PRCAI EN+1
1950	"RTN","PRC AACR1",104 ,0)
1951	....; Add 18 chars of Debtor' s name
1952	"RTN","PRC AACR1",105 ,0)
1953	....S PRC ATEMP=$E($ P(PRCADATA ,U,1),1,18 ),$E(PRCAT EMP,20)=" "
1954	"RTN","PRC AACR1",106 ,0)
1955	....; Add Bill Numb er
1956	"RTN","PRC AACR1",107 ,0)
1957	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,2 ),$E(PRCAT EMP,33)=" "
1958	"RTN","PRC AACR1",108 ,0)
1959	....; Add SSN
1960	"RTN","PRC AACR1",109 ,0)
1961	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,3 ),$E(PRCAT EMP,39)=" "
1962	"RTN","PRC AACR1",110 ,0)
1963	....; Add Transacti on Number
1964	"RTN","PRC AACR1",111 ,0)
1965	....S PRC ATEMP=PRCA TEMP_$J($P (PRCADATA, U,4),9),$E (PRCATEMP, 50)=" "
1966	"RTN","PRC AACR1",112 ,0)
1967	....; Add Auto-Corr ect Date
1968	"RTN","PRC AACR1",113 ,0)
1969	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,5 ),$E(PRCAT EMP,64)=" "
1970	"RTN","PRC AACR1",114 ,0)
1971	....; Add Auto-Corr ect Reason
1972	"RTN","PRC AACR1",115 ,0)
1973	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,6 )
1974	"RTN","PRC AACR1",116 ,0)
1975	....S ^TM P("PRCAACR 1",$J,PRCA IEN)=PRCAT EMP
1976	"RTN","PRC AACR1",117 ,0)
1977	....Q
1978	"RTN","PRC AACR1",118 ,0)
1979	;
1980	"RTN","PRC AACR1",119 ,0)
1981	; Store i n ^TMP sor ted by Aut o-Correct Date, Debt or, Bill N umber and Transacti
1982	on #
1983	"RTN","PRC AACR1",120 ,0)
1984	I PRCASOR T=3 D
1985	"RTN","PRC AACR1",121 ,0)
1986	.; Print Header
1987	"RTN","PRC AACR1",122 ,0)
1988	.D PSACRT P3
1989	"RTN","PRC AACR1",123 ,0)
1990	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)=PRC ABN_U_PRCA DTR_U_PRC
1991	ASSN_U_PRC ATNTF_U_PR CAACD_U_PR CAACR
1992	"RTN","PRC AACR1",124 ,0)
1993	.S PRCABN =""
1994	"RTN","PRC AACR1",125 ,0)
1995	.F S PRC ABN=$O(^TM P("PRCAACR ",$J,PRCAB N)) Q:'PRC ABN D
1996	"RTN","PRC AACR1",126 ,0)
1997	..S PRCAD TR=""
1998	"RTN","PRC AACR1",127 ,0)
1999	..F S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC ABN,PRCADT R)) Q:PRCA DTR="" D
2000	"RTN","PRC AACR1",128 ,0)
2001	...S PRCA TN=""
2002	"RTN","PRC AACR1",129 ,0)
2003	...F S P RCATN=$O(^ TMP("PRCAA CR",$J,PRC ABN,PRCADT R,PRCATN)) Q:'PRCATN D
2004	"RTN","PRC AACR1",130 ,0)
2005	....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)
2006	"RTN","PRC AACR1",131 ,0)
2007	....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
2008	"RTN","PRC AACR1",132 ,0)
2009	....S PRC AIEN=PRCAI EN+1
2010	"RTN","PRC AACR1",133 ,0)
2011	....; Add Bill Numb er
2012	"RTN","PRC AACR1",134 ,0)
2013	....S PRC ATEMP=$P(P RCADATA,U, 1),$E(PRCA TEMP,13)=" "
2014	"RTN","PRC AACR1",135 ,0)
2015	....; Add 18 chars of Debtor' s name
2016	"RTN","PRC AACR1",136 ,0)
2017	....S PRC ATEMP=PRCA TEMP_$E($P (PRCADATA, U,2),1,18) ,$E(PRCATE MP,33)=" "
2018	"RTN","PRC AACR1",137 ,0)
2019	....; Add SSN
2020	"RTN","PRC AACR1",138 ,0)
2021	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,3 ),$E(PRCAT EMP,39)=" "
2022	"RTN","PRC AACR1",139 ,0)
2023	....; Add Transacti on Number
2024	"RTN","PRC AACR1",140 ,0)
2025	....S PRC ATEMP=PRCA TEMP_$J($P (PRCADATA, U,4),9),$E (PRCATEMP, 50)=" "
2026	"RTN","PRC AACR1",141 ,0)
2027	....; Add Auto-Corr ect Date
2028	"RTN","PRC AACR1",142 ,0)
2029	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,5 ),$E(PRCAT EMP,64)=" "
2030	"RTN","PRC AACR1",143 ,0)
2031	....; Add Auto-Corr ect Reason
2032	"RTN","PRC AACR1",144 ,0)
2033	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,6 )
2034	"RTN","PRC AACR1",145 ,0)
2035	....S ^TM P("PRCAACR 1",$J,PRCA IEN)=PRCAT EMP
2036	"RTN","PRC AACR1",146 ,0)
2037	....Q
2038	"RTN","PRC AACR1",147 ,0)
2039	;
2040	"RTN","PRC AACR1",148 ,0)
2041	; Store i n ^TMP sor ted by Tra nsaction, Debtor and #Bill Num ber
2042	"RTN","PRC AACR1",149 ,0)
2043	I PRCASOR T=4 D
2044	"RTN","PRC AACR1",150 ,0)
2045	.; Print Header
2046	"RTN","PRC AACR1",151 ,0)
2047	.D PSACRT P4
2048	"RTN","PRC AACR1",152 ,0)
2049	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)=PRC ATNTF_U_PR CADTR_U_P
2050	RCABN_U_PR CASSN_U_PR CAACD_U_PR CAACR
2051	"RTN","PRC AACR1",153 ,0)
2052	.S PRCATN =""
2053	"RTN","PRC AACR1",154 ,0)
2054	.F S PRC ATN=$O(^TM P("PRCAACR ",$J,PRCAT N)) Q:'PRC ATN D
2055	"RTN","PRC AACR1",155 ,0)
2056	..S PRCAD TR=""
2057	"RTN","PRC AACR1",156 ,0)
2058	..F S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC ATN,PRCADT R)) Q:PRCA DTR="" D
2059	"RTN","PRC AACR1",157 ,0)
2060	...S PRCA BN=""
2061	"RTN","PRC AACR1",158 ,0)
2062	...F S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC ATN,PRCADT R,PRCABN)) Q:'PRCABN D
2063	"RTN","PRC AACR1",159 ,0)
2064	....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)
2065	"RTN","PRC AACR1",160 ,0)
2066	....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
2067	"RTN","PRC AACR1",161 ,0)
2068	....S PRC AIEN=PRCAI EN+1
2069	"RTN","PRC AACR1",162 ,0)
2070	....; Add Transacti on Number
2071	"RTN","PRC AACR1",163 ,0)
2072	....S PRC ATEMP=$J($ P(PRCADATA ,U,1),9),$ E(PRCATEMP ,11)=" "
2073	"RTN","PRC AACR1",164 ,0)
2074	....; Add 18 chars of Debtor' s name
2075	"RTN","PRC AACR1",165 ,0)
2076	....S PRC ATEMP=PRCA TEMP_$E($P (PRCADATA, U,2),1,18) ,$E(PRCATE MP,31)=" "
2077	"RTN","PRC AACR1",166 ,0)
2078	....; Add Bill Numb er
2079	"RTN","PRC AACR1",167 ,0)
2080	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,3 ),$E(PRCAT EMP,44)=" "
2081	"RTN","PRC AACR1",168 ,0)
2082	....; Add SSN
2083	"RTN","PRC AACR1",169 ,0)
2084	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,4 ),$E(PRCAT EMP,50)=" "
2085	"RTN","PRC AACR1",170 ,0)
2086	....; Add Auto-Corr ect Date
2087	"RTN","PRC AACR1",171 ,0)
2088	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,5 ),$E(PRCAT EMP,64)=" "
2089	"RTN","PRC AACR1",172 ,0)
2090	....; Add Auto-Corr ect Reason
2091	"RTN","PRC AACR1",173 ,0)
2092	....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,6 )
2093	"RTN","PRC AACR1",174 ,0)
2094	....S ^TM P("PRCAACR 1",$J,PRCA IEN)=PRCAT EMP
2095	"RTN","PRC AACR1",175 ,0)
2096	....Q
2097	"RTN","PRC AACR1",176 ,0)
2098	;
2099	"RTN","PRC AACR1",177 ,0)
2100	; Display Auto-Corr ect data s orted by A uto-Correc t Reason
2101	"RTN","PRC AACR1",178 ,0)
2102	I PRCASOR T=5 D
2103	"RTN","PRC AACR1",179 ,0)
2104	.; Print Header
2105	"RTN","PRC AACR1",180 ,0)
2106	.D PSACRT P5
2107	"RTN","PRC AACR1",181 ,0)
2108	.; Data L ayout ^TMP ("PRCAACR" ,$J,PRCAAC D,PRCADTR, PRCABN,PRC ATN)=PRCAA CD_U_PRCA
2109	DTR_U_PRCA BN_U_PRCAS SN_U_PRCAT NTF_U_PRCA ACR
2110	"RTN","PRC AACR1",182 ,0)
2111	.S PRCAAC D=""
2112	"RTN","PRC AACR1",183 ,0)
2113	.F S PRC AACD=$O(^T MP("PRCAAC R",$J,PRCA ACD)) Q:PR CAACD="" D
2114	"RTN","PRC AACR1",184 ,0)
2115	..S PRCAD TR=""
2116	"RTN","PRC AACR1",185 ,0)
2117	..F S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC AACD,PRCAD TR)) Q:PRC ADTR="" D
2118	"RTN","PRC AACR1",186 ,0)
2119	...S PRCA BN=""
2120	"RTN","PRC AACR1",187 ,0)
2121	...F S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC AACD,PRCAD TR,PRCABN) ) Q:'PRCAB N D
2122	"RTN","PRC AACR1",188 ,0)
2123	....S PRC ATN=""
2124	"RTN","PRC AACR1",189 ,0)
2125	....F S PRCATN=$O( ^TMP("PRCA ACR",$J,PR CAACD,PRCA DTR,PRCABN ,PRCATN)) Q:'PRCATN
2126	D
2127	"RTN","PRC AACR1",190 ,0)
2128	.....S PR CADATA=^TM P("PRCAACR ",$J,PRCAA CD,PRCADTR ,PRCABN,PR CATN)
2129	"RTN","PRC AACR1",191 ,0)
2130	.....S $P (PRCADATA, U,1)=$$GET 1^DIQ(433, PRCATN_"," ,94)
2131	"RTN","PRC AACR1",192 ,0)
2132	.....S PR CAIEN=PRCA IEN+1
2133	"RTN","PRC AACR1",193 ,0)
2134	.....; Ad d Auto-Cor rect Date
2135	"RTN","PRC AACR1",194 ,0)
2136	.....S PR CATEMP=$P( PRCADATA,U ,1),$E(PRC ATEMP,14)= " "
2137	"RTN","PRC AACR1",195 ,0)
2138	.....; Ad d 18 chars of Debtor 's name
2139	"RTN","PRC AACR1",196 ,0)
2140	.....S PR CATEMP=PRC ATEMP_$E($ P(PRCADATA ,U,2),1,18 ),$E(PRCAT EMP,34)=" "
2141	"RTN","PRC AACR1",197 ,0)
2142	.....; Ad d Bill Num ber
2143	"RTN","PRC AACR1",198 ,0)
2144	.....S PR CATEMP=PRC ATEMP_$P(P RCADATA,U, 3),$E(PRCA TEMP,47)=" "
2145	"RTN","PRC AACR1",199 ,0)
2146	.....; Ad d SSN
2147	"RTN","PRC AACR1",200 ,0)
2148	.....S PR CATEMP=PRC ATEMP_$P(P RCADATA,U, 4),$E(PRCA TEMP,53)=" "
2149	"RTN","PRC AACR1",201 ,0)
2150	.....; Ad d Transact ion Number
2151	"RTN","PRC AACR1",202 ,0)
2152	.....S PR CATEMP=PRC ATEMP_$J($ P(PRCADATA ,U,5),9),$ E(PRCATEMP ,64)=" "
2153	"RTN","PRC AACR1",203 ,0)
2154	.....; Ad d Auto-Cor rect Reaso n
2155	"RTN","PRC AACR1",204 ,0)
2156	.....S PR CATEMP=PRC ATEMP_$P(P RCADATA,U, 6)
2157	"RTN","PRC AACR1",205 ,0)
2158	.....S ^T MP("PRCAAC R1",$J,PRC AIEN)=PRCA TEMP
2159	"RTN","PRC AACR1",206 ,0)
2160	.....Q
2161	"RTN","PRC AACR1",207 ,0)
2162	;
2163	"RTN","PRC AACR1",208 ,0)
2164	; Send Ma ilMan mess age with N o Forward
2165	"RTN","PRC AACR1",209 ,0)
2166	N XMTO,XM SUBJ,XMBOD Y,XMINSTR, XMDUZ
2167	"RTN","PRC AACR1",210 ,0)
2168	I PRCASOR T=1 S XMSU BJ="AUTO-C ORRECTED B ILLS (SORT ED BY AUTO -CORRECTIO N REASON)
2169	"
2170	"RTN","PRC AACR1",211 ,0)
2171	I PRCASOR T=2 S XMSU BJ="AUTO-C ORRECTED B ILLS (SORT ED BY DEBT OR)"
2172	"RTN","PRC AACR1",212 ,0)
2173	I PRCASOR T=3 S XMSU BJ="AUTO-C ORRECTED B ILLS (SORT ED BY BILL #)"
2174	"RTN","PRC AACR1",213 ,0)
2175	I PRCASOR T=4 S XMSU BJ="AUTO-C ORRECTED B ILLS (SORT ED BY TRAN SACTION NU MBER)"
2176	"RTN","PRC AACR1",214 ,0)
2177	I PRCASOR T=5 S XMSU BJ="AUTO-C ORRECTED B ILLS (SORT ED BY AUTO -CORRECTIO N DATE)"
2178	"RTN","PRC AACR1",215 ,0)
2179	S XMTO(DU Z)=""
2180	"RTN","PRC AACR1",216 ,0)
2181	S XMBODY= "^TMP(""PR CAACR1"",$ J)"
2182	"RTN","PRC AACR1",217 ,0)
2183	S XMINSTR ("FLAGS")= "X"
2184	"RTN","PRC AACR1",218 ,0)
2185	S XMDUZ=D UZ
2186	"RTN","PRC AACR1",219 ,0)
2187	D SENDMSG ^XMXAPI(XM DUZ,XMSUBJ ,XMBODY,.X MTO,.XMINS TR)
2188	"RTN","PRC AACR1",220 ,0)
2189	D HOME^%Z IS
2190	"RTN","PRC AACR1",221 ,0)
2191	K IO("Q") ,POP
2192	"RTN","PRC AACR1",222 ,0)
2193	K ^TMP("P RCAACR",$J )
2194	"RTN","PRC AACR1",223 ,0)
2195	K ^TMP("P RCAACR1",$ J)
2196	"RTN","PRC AACR1",224 ,0)
2197	K PRCABDT ,PRCAEDT,P RCASORT
2198	"RTN","PRC AACR1",225 ,0)
2199	Q
2200	"RTN","PRC AACR1",226 ,0)
2201	;
2202	"RTN","PRC AACR1",227 ,0)
2203	PSACRTP1 ; header fo r patient statement auto-corre ction repo rt 1
2204	"RTN","PRC AACR1",228 ,0)
2205	S PAGE=PA GE+1
2206	"RTN","PRC AACR1",229 ,0)
2207	S PRCAIEN =PRCAIEN+1
2208	"RTN","PRC AACR1",230 ,0)
2209	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2210	"RTN","PRC AACR1",231 ,0)
2211	S PRCADAT A="PAGE "_ PAGE,$E(PR CADATA,9)= ""
2212	"RTN","PRC AACR1",232 ,0)
2213	S PRCADAT A=PRCADATA _"AUTO-COR RECTED BIL LS (SORTED BY AUTO-C ORRECTION REASON)"
2214	"RTN","PRC AACR1",233 ,0)
2215	S $E(PRCA DATA,66)=" ",PRCADATA =PRCADATA_ $$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
2216	"RTN","PRC AACR1",234 ,0)
2217	S PRCAIEN =PRCAIEN+1
2218	"RTN","PRC AACR1",235 ,0)
2219	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2220	"RTN","PRC AACR1",236 ,0)
2221	S PRCAIEN =PRCAIEN+1
2222	"RTN","PRC AACR1",237 ,0)
2223	S ^TMP("P RCAACR1",$ J,PRCAIEN) =DASH
2224	"RTN","PRC AACR1",238 ,0)
2225	S PRCAIEN =PRCAIEN+1
2226	"RTN","PRC AACR1",239 ,0)
2227	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2228	"RTN","PRC AACR1",240 ,0)
2229	S PRCADAT A="AUTO-C REASON D EBTOR S SN BILL NO. TR ANS NUM
2230	AUTO-C DAT E"
2231	"RTN","PRC AACR1",241 ,0)
2232	S PRCAIEN =PRCAIEN+1
2233	"RTN","PRC AACR1",242 ,0)
2234	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2235	"RTN","PRC AACR1",243 ,0)
2236	S PRCADAT A="------- ------- - ---------- ------- - --- ----- ------ -- -------
2237	---------- --"
2238	"RTN","PRC AACR1",244 ,0)
2239	S PRCAIEN =PRCAIEN+1
2240	"RTN","PRC AACR1",245 ,0)
2241	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2242	"RTN","PRC AACR1",246 ,0)
2243	Q
2244	"RTN","PRC AACR1",247 ,0)
2245	;
2246	"RTN","PRC AACR1",248 ,0)
2247	PSACRTP2 ; header fo r patient statement auto-corre ction repo rt 2
2248	"RTN","PRC AACR1",249 ,0)
2249	S PAGE=PA GE+1
2250	"RTN","PRC AACR1",250 ,0)
2251	S PRCAIEN =PRCAIEN+1
2252	"RTN","PRC AACR1",251 ,0)
2253	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2254	"RTN","PRC AACR1",252 ,0)
2255	S PRCADAT A="PAGE "_ PAGE,$E(PR CADATA,9)= ""
2256	"RTN","PRC AACR1",253 ,0)
2257	S PRCADAT A=PRCADATA _"AUTO-COR RECTED BIL LS (SORTED BY DEBTOR )"
2258	"RTN","PRC AACR1",254 ,0)
2259	S $E(PRCA DATA,66)=" ",PRCADATA =PRCADATA_ $$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
2260	"RTN","PRC AACR1",255 ,0)
2261	S PRCAIEN =PRCAIEN+1
2262	"RTN","PRC AACR1",256 ,0)
2263	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2264	"RTN","PRC AACR1",257 ,0)
2265	S PRCAIEN =PRCAIEN+1
2266	"RTN","PRC AACR1",258 ,0)
2267	S ^TMP("P RCAACR1",$ J,PRCAIEN) =DASH
2268	"RTN","PRC AACR1",259 ,0)
2269	S PRCAIEN =PRCAIEN+1
2270	"RTN","PRC AACR1",260 ,0)
2271	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2272	"RTN","PRC AACR1",261 ,0)
2273	S PRCADAT A="DEBTOR BILL NO . SSN TRANS NU M AUTO-C DATE AU
2274	TO-C REASO N"
2275	"RTN","PRC AACR1",262 ,0)
2276	S PRCAIEN =PRCAIEN+1
2277	"RTN","PRC AACR1",263 ,0)
2278	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2279	"RTN","PRC AACR1",264 ,0)
2280	S PRCADAT A="------- ---------- - ------- ---- ---- -------- - ------- ----- --
2281	---------- --"
2282	"RTN","PRC AACR1",265 ,0)
2283	S PRCAIEN =PRCAIEN+1
2284	"RTN","PRC AACR1",266 ,0)
2285	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2286	"RTN","PRC AACR1",267 ,0)
2287	Q
2288	"RTN","PRC AACR1",268 ,0)
2289	;
2290	"RTN","PRC AACR1",269 ,0)
2291	PSACRTP3 ; header fo r patient statement auto-corre ction repo rt 3
2292	"RTN","PRC AACR1",270 ,0)
2293	S PAGE=PA GE+1
2294	"RTN","PRC AACR1",271 ,0)
2295	S PRCAIEN =PRCAIEN+1
2296	"RTN","PRC AACR1",272 ,0)
2297	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2298	"RTN","PRC AACR1",273 ,0)
2299	S PRCADAT A="PAGE "_ PAGE,$E(PR CADATA,9)= ""
2300	"RTN","PRC AACR1",274 ,0)
2301	S PRCADAT A=PRCADATA _"AUTO-COR RECTED BIL LS (SORTED BY BILL # )"
2302	"RTN","PRC AACR1",275 ,0)
2303	S $E(PRCA DATA,66)=" ",PRCADATA =PRCADATA_ $$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
2304	"RTN","PRC AACR1",276 ,0)
2305	S PRCAIEN =PRCAIEN+1
2306	"RTN","PRC AACR1",277 ,0)
2307	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2308	"RTN","PRC AACR1",278 ,0)
2309	S PRCAIEN =PRCAIEN+1
2310	"RTN","PRC AACR1",279 ,0)
2311	S ^TMP("P RCAACR1",$ J,PRCAIEN) =DASH
2312	"RTN","PRC AACR1",280 ,0)
2313	S PRCAIEN =PRCAIEN+1
2314	"RTN","PRC AACR1",281 ,0)
2315	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2316	"RTN","PRC AACR1",282 ,0)
2317	S PRCADAT A="BILL NO . DEBT OR SSN TRANS NU M AUTO-C DATE AU
2318	TO-C REASO N"
2319	"RTN","PRC AACR1",283 ,0)
2320	S PRCAIEN =PRCAIEN+1
2321	"RTN","PRC AACR1",284 ,0)
2322	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2323	"RTN","PRC AACR1",285 ,0)
2324	S PRCADAT A="------- ---- ---- ---------- ---- ---- -------- - ------- ----- --
2325	---------- --"
2326	"RTN","PRC AACR1",286 ,0)
2327	S PRCAIEN =PRCAIEN+1
2328	"RTN","PRC AACR1",287 ,0)
2329	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2330	"RTN","PRC AACR1",288 ,0)
2331	Q
2332	"RTN","PRC AACR1",289 ,0)
2333	;
2334	"RTN","PRC AACR1",290 ,0)
2335	PSACRTP4 ; header fo r patient statement auto-corre ction repo rt 4
2336	"RTN","PRC AACR1",291 ,0)
2337	S PAGE=PA GE+1
2338	"RTN","PRC AACR1",292 ,0)
2339	S PRCAIEN =PRCAIEN+1
2340	"RTN","PRC AACR1",293 ,0)
2341	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2342	"RTN","PRC AACR1",294 ,0)
2343	S PRCADAT A="PAGE "_ PAGE,$E(PR CADATA,9)= ""
2344	"RTN","PRC AACR1",295 ,0)
2345	S PRCADAT A=PRCADATA _"AUTO-COR RECTED BIL LS (SORTED BY TRANSA CTION NUMB ER)"
2346	"RTN","PRC AACR1",296 ,0)
2347	S $E(PRCA DATA,66)=" ",PRCADATA =PRCADATA_ $$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
2348	"RTN","PRC AACR1",297 ,0)
2349	S PRCAIEN =PRCAIEN+1
2350	"RTN","PRC AACR1",298 ,0)
2351	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2352	"RTN","PRC AACR1",299 ,0)
2353	S PRCAIEN =PRCAIEN+1
2354	"RTN","PRC AACR1",300 ,0)
2355	S ^TMP("P RCAACR1",$ J,PRCAIEN) =DASH
2356	"RTN","PRC AACR1",301 ,0)
2357	S PRCAIEN =PRCAIEN+1
2358	"RTN","PRC AACR1",302 ,0)
2359	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2360	"RTN","PRC AACR1",303 ,0)
2361	S PRCADAT A="TRANS N UM DEBTOR BILL N O. SSN AUTO-C DATE AU
2362	TO-C REASO N"
2363	"RTN","PRC AACR1",304 ,0)
2364	S PRCAIEN =PRCAIEN+1
2365	"RTN","PRC AACR1",305 ,0)
2366	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2367	"RTN","PRC AACR1",306 ,0)
2368	S PRCADAT A="------- -- ------ ---------- -- ------ ----- --- - ------- ----- --
2369	---------- --"
2370	"RTN","PRC AACR1",307 ,0)
2371	S PRCAIEN =PRCAIEN+1
2372	"RTN","PRC AACR1",308 ,0)
2373	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2374	"RTN","PRC AACR1",309 ,0)
2375	Q
2376	"RTN","PRC AACR1",310 ,0)
2377	;
2378	"RTN","PRC AACR1",311 ,0)
2379	PSACRTP5 ; header fo r patient statement auto-corre ction repo rt 5
2380	"RTN","PRC AACR1",312 ,0)
2381	S PAGE=PA GE+1
2382	"RTN","PRC AACR1",313 ,0)
2383	S PRCAIEN =PRCAIEN+1
2384	"RTN","PRC AACR1",314 ,0)
2385	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2386	"RTN","PRC AACR1",315 ,0)
2387	S PRCADAT A="PAGE "_ PAGE,$E(PR CADATA,9)= ""
2388	"RTN","PRC AACR1",316 ,0)
2389	S PRCADAT A=PRCADATA _"AUTO-COR RECTED BIL LS (SORTED BY AUTO-C ORRECTION DATE)"
2390	"RTN","PRC AACR1",317 ,0)
2391	S $E(PRCA DATA,66)=" ",PRCADATA =PRCADATA_ $$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
2392	"RTN","PRC AACR1",318 ,0)
2393	S PRCAIEN =PRCAIEN+1
2394	"RTN","PRC AACR1",319 ,0)
2395	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2396	"RTN","PRC AACR1",320 ,0)
2397	S PRCAIEN =PRCAIEN+1
2398	"RTN","PRC AACR1",321 ,0)
2399	S ^TMP("P RCAACR1",$ J,PRCAIEN) =DASH
2400	"RTN","PRC AACR1",322 ,0)
2401	S PRCAIEN =PRCAIEN+1
2402	"RTN","PRC AACR1",323 ,0)
2403	S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
2404	"RTN","PRC AACR1",324 ,0)
2405	S PRCADAT A="AUTO-C DATE DEB TOR BIL L NO. SSN TRAN S NUM AU
2406	TO-C REASO N"
2407	"RTN","PRC AACR1",325 ,0)
2408	S PRCAIEN =PRCAIEN+1
2409	"RTN","PRC AACR1",326 ,0)
2410	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2411	"RTN","PRC AACR1",327 ,0)
2412	S PRCADAT A="------- ----- --- ---------- ----- --- -------- ---- ---- ----- --
2413	---------- --"
2414	"RTN","PRC AACR1",328 ,0)
2415	S PRCAIEN =PRCAIEN+1
2416	"RTN","PRC AACR1",329 ,0)
2417	S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
2418	"RTN","PRC AACR1",330 ,0)
2419	Q
2420	"RTN","PRC AACR1",331 ,0)
2421	;
2422	"RTN","PRC AACR1",332 ,0)
2423	EXIT ;
2424	"RTN","PRC AACR1",333 ,0)
2425	Q
2426	"RTN","PRC ACPS1")
2427	0^6^B18771 251^n/a
2428	"RTN","PRC ACPS1",1,0 )
2429	PRCACPS1 ; ALBANY/BDB -PATIENT S TATEMENTS UPDATE ;03 /25/16 3:3 4 PM
2430	"RTN","PRC ACPS1",2,0 )
2431	;;4.5;Acc ounts Rece ivable;3 13;Mar 2 0, 1995;Bu ild 113
2432	"RTN","PRC ACPS1",3,0 )
2433	;;Per VA Directive 6402, this routine s hould not be modifie d.
2434	"RTN","PRC ACPS1",4,0 )
2435	;
2436	"RTN","PRC ACPS1",5,0 )
2437	Q
2438	"RTN","PRC ACPS1",6,0 )
2439	;
2440	"RTN","PRC ACPS1",7,0 )
2441	ENTER ;cal led by the cbs night ly account update pr ogram opti on
2442	"RTN","PRC ACPS1",8,0 )
2443	N ZTDTH,Z TIO,ZTDESC ,ZTRTN,ZTS K,ZTSAVE,R CFULL
2444	"RTN","PRC ACPS1",9,0 )
2445	S RCFULL= 1 ;run the full debt or list
2446	"RTN","PRC ACPS1",10, 0)
2447	W !,"Queu e the pati ent statem ent update program t o run:"
2448	"RTN","PRC ACPS1",11, 0)
2449	S ZTDESC= "Consolida ted Billin g Statemen t Update"
2450	"RTN","PRC ACPS1",12, 0)
2451	S ZTRTN=" DEBTOR^PRC ACPS1",ZTI O="",ZTSAV E("RCFULL" )=""
2452	"RTN","PRC ACPS1",13, 0)
2453	D ^%ZTLOA D
2454	"RTN","PRC ACPS1",14, 0)
2455	Q
2456	"RTN","PRC ACPS1",15, 0)
2457	;
2458	"RTN","PRC ACPS1",16, 0)
2459	DEBTOR ;ca lled by rc cpcbj
2460	"RTN","PRC ACPS1",17, 0)
2461	N DEBTOR, X,DEBTOR0, DEBTOR1,DE BTOR7,CBSS TOT,BALDT
2462	"RTN","PRC ACPS1",18, 0)
2463	K ^XTMP(" RCCBSS",$J )
2464	"RTN","PRC ACPS1",19, 0)
2465	S ^XTMP(" RCCBSS",$J ,0)=$$FMAD D^XLFDT(DT ,3)_"^"_DT
2466	"RTN","PRC ACPS1",20, 0)
2467	S DEBTOR= 0
2468	"RTN","PRC ACPS1",21, 0)
2469	F S DEBT OR=$O(^PRC A(430,"C", DEBTOR)) Q :DEBTOR'?1 N.N D
2470	"RTN","PRC ACPS1",22, 0)
2471	.S DEBTOR 0=$G(^RCD( 340,DEBTOR ,0)),DEBTO R1=$G(^(1) ),DEBTOR7= $G(^(7)),B ALDT=""
2472	"RTN","PRC ACPS1",23, 0)
2473	.Q:$P(DEB TOR0,"^")' ["DPT("
2474	"RTN","PRC ACPS1",24, 0)
2475	.I +$$GET ICN^MPIF00 1(+DEBTOR0 )<0 Q ;qu it if no i cn
2476	"RTN","PRC ACPS1",25, 0)
2477	.S BALDT= $$BILLS(DE BTOR) Q:$P (BALDT,U,2 )=9999999
2478	"RTN","PRC ACPS1",26, 0)
2479	.D RECPD
2480	"RTN","PRC ACPS1",27, 0)
2481	D COMPILE
2482	"RTN","PRC ACPS1",28, 0)
2483	Q
2484	"RTN","PRC ACPS1",29, 0)
2485	;
2486	"RTN","PRC ACPS1",30, 0)
2487	RECPD(BILL ) ;add a n ew account update
2488	"RTN","PRC ACPS1",31, 0)
2489	N REC,RCD FN
2490	"RTN","PRC ACPS1",32, 0)
2491	S RCDFN=+ DEBTOR0
2492	"RTN","PRC ACPS1",33, 0)
2493	S REC="PD ^"_$$GETIC N^MPIF001( RCDFN)_"^"
2494	"RTN","PRC ACPS1",34, 0)
2495	S REC=REC _$$SITE^RC MSITE_$$UP ^XLFSTR($S (($$SSN^RC FN01(DEBTO R)]"")&($$ NAM^RCFN0
2496	1(DEBTOR)] ""):$TR($E ($$SSN^RCF N01(DEBTOR ),1,9)_$E( $P($$NAM^R CFN01(DEBT OR),","),
2497	1,5)," "," "),1:""))_ "^"
2498	"RTN","PRC ACPS1",35, 0)
2499	S REC=REC _RCDFN_"^"
2500	"RTN","PRC ACPS1",36, 0)
2501	S BALDT=$ $BILLS(DEB TOR)
2502	"RTN","PRC ACPS1",37, 0)
2503	S CBSSTOT =+$P(DEBTO R7,U,6)
2504	"RTN","PRC ACPS1",38, 0)
2505	I '$G(RCF ULL) Q:CBS STOT=+BALD T
2506	"RTN","PRC ACPS1",39, 0)
2507	S $P(^RCD (340,DEBTO R,7),U,6)= +BALDT
2508	"RTN","PRC ACPS1",40, 0)
2509	S REC=REC _$$HEX(+BA LDT)_"^"_$ P(BALDT,U, 2)_"^\|"
2510	"RTN","PRC ACPS1",41, 0)
2511	S ^XTMP(" RCCBSS",$J ,DEBTOR)=R EC
2512	"RTN","PRC ACPS1",42, 0)
2513	Q
2514	"RTN","PRC ACPS1",43, 0)
2515	;
2516	"RTN","PRC ACPS1",44, 0)
2517	BILLS(DEBT OR) ;get o ldest bill date
2518	"RTN","PRC ACPS1",45, 0)
2519	N BALTOT, BILL,BN0,P RPDT,OLDDT
2520	"RTN","PRC ACPS1",46, 0)
2521	S BILL=""
2522	"RTN","PRC ACPS1",47, 0)
2523	S BALTOT= 0,OLDDT=99 99999
2524	"RTN","PRC ACPS1",48, 0)
2525	F S BILL =$O(^PRCA( 430,"C",DE BTOR,BILL) ) Q:BILL'? 1N.N D
2526	"RTN","PRC ACPS1",49, 0)
2527	.Q:$D(^PR CA(430,"TC SP",BILL)) ;cs chec k
2528	"RTN","PRC ACPS1",50, 0)
2529	.S BN0=$G (^PRCA(430 ,BILL,0))
2530	"RTN","PRC ACPS1",51, 0)
2531	.I $P(BN0 ,U,8)'=16 Q ;not ac tive
2532	"RTN","PRC ACPS1",52, 0)
2533	.S BALTOT =BALTOT+$$ GET1^DIQ(4 30,BILL,11 )
2534	"RTN","PRC ACPS1",53, 0)
2535	.S PRPDT= $P(^PRCA(4 30,BILL,0) ,U,10) I + PRPDT,OLDD T>PRPDT S OLDDT=PRPD T
2536	"RTN","PRC ACPS1",54, 0)
2537	Q BALTOT_ U_$S(OLDDT '=9999999: $$DTMDY(OL DDT),1:"")
2538	"RTN","PRC ACPS1",55, 0)
2539	;
2540	"RTN","PRC ACPS1",56, 0)
2541	COMPILE ;
2542	"RTN","PRC ACPS1",57, 0)
2543	N RCMSG,D CNTR,REC,R ECC,AMOUNT ,RCNTR,ACT ION,SEQ,SE QTOT
2544	"RTN","PRC ACPS1",58, 0)
2545	S DCNTR=0 ,REC=1,REC C=0,AMOUNT =0,SEQ=1,S EQTOT=0
2546	"RTN","PRC ACPS1",59, 0)
2547	F S DCNT R=$O(^XTMP ("RCCBSS", $J,DCNTR)) S:+DCNTR' >0 SEQTOT= SEQ Q:+DCN TR'>0 D
2548	"RTN","PRC ACPS1",60, 0)
2549	.I REC>45 0 D
2550	"RTN","PRC ACPS1",61, 0)
2551	..S ^XTMP ("RCCBSS", $J,"BUILD" ,SEQ,REC)= ^XTMP("RCC BSS",$J,"B UILD",SEQ, REC)_"~"
2552	"RTN","PRC ACPS1",62, 0)
2553	..D HEADE R
2554	"RTN","PRC ACPS1",63, 0)
2555	..D AITCM SG
2556	"RTN","PRC ACPS1",64, 0)
2557	..S REC=0 ,SEQ=SEQ+1
2558	"RTN","PRC ACPS1",65, 0)
2559	..Q
2560	"RTN","PRC ACPS1",66, 0)
2561	.I REC=0
2562	"RTN","PRC ACPS1",67, 0)
2563	.S REC=RE C+1
2564	"RTN","PRC ACPS1",68, 0)
2565	.S ^XTMP( "RCCBSS",$ J,"BUILD", SEQ,REC)=^ XTMP("RCCB SS",$J,DCN TR)
2566	"RTN","PRC ACPS1",69, 0)
2567	.Q
2568	"RTN","PRC ACPS1",70, 0)
2569	Q:'$D(^XT MP("RCCBSS ",$J,"BUIL D",SEQ))
2570	"RTN","PRC ACPS1",71, 0)
2571	S ^XTMP(" RCCBSS",$J ,"BUILD",S EQ,REC)=^X TMP("RCCBS S",$J,"BUI LD",SEQ,RE C)_"~"
2572	"RTN","PRC ACPS1",72, 0)
2573	D HEADER
2574	"RTN","PRC ACPS1",73, 0)
2575	D AITCMSG
2576	"RTN","PRC ACPS1",74, 0)
2577	Q
2578	"RTN","PRC ACPS1",75, 0)
2579	;
2580	"RTN","PRC ACPS1",76, 0)
2581	AITCMSG ;
2582	"RTN","PRC ACPS1",77, 0)
2583	N XMY,XMD UZ,XMSUB,X MTEXT
2584	"RTN","PRC ACPS1",78, 0)
2585	S SITE=$E ($$SITE^RC MSITE(),1, 3)
2586	"RTN","PRC ACPS1",79, 0)
2587	S XMDUZ=" AR PACKAGE "
2588	"RTN","PRC ACPS1",80, 0)
2589	;S XMY(" P II ")=""
2590	"RTN","PRC ACPS1",81, 0)
2591	S X=$O(^R CT(349.1," B","PU",0) )
2592	"RTN","PRC ACPS1",82, 0)
2593	I X,$P($G (^RCT(349. 1,+X,0))," ^",3) S X= $P($G(^RCT (349.1,+X, 3)),"^")_" @"_$P($G(
2594	^RCT(349.1 ,+X,3)),"^ ",3) S:$P( X,"@",2)]" " XMY(X)=" "
2595	"RTN","PRC ACPS1",83, 0)
2596	S XMY("G. PRCACPS")= ""
2597	"RTN","PRC ACPS1",84, 0)
2598	S XMSUB=S ITE_"/CBSS TRANSMISS ION/BATCH# : "_SEQ
2599	"RTN","PRC ACPS1",85, 0)
2600	S XMTEXT= "^XTMP(""R CCBSS"","_ $J_",""BUI LD"","_SEQ _","
2601	"RTN","PRC ACPS1",86, 0)
2602	D ^XMD
2603	"RTN","PRC ACPS1",87, 0)
2604	Q
2605	"RTN","PRC ACPS1",88, 0)
2606	;
2607	"RTN","PRC ACPS1",89, 0)
2608	HEADER ;
2609	"RTN","PRC ACPS1",90, 0)
2610	;incremen t batch se quence num ber, build new heade r
2611	"RTN","PRC ACPS1",91, 0)
2612	N RCMSG,S ITE
2613	"RTN","PRC ACPS1",92, 0)
2614	S SITE=$E ($$SITE^RC MSITE(),1, 3)
2615	"RTN","PRC ACPS1",93, 0)
2616	S RCMSG=" PU"_"^"_SE Q_"^"_SEQT OT_"^"_(RE C-1)_"^"_S ITE_"^"_$$ DTMDY(DT)_ "^\|"
2617	"RTN","PRC ACPS1",94, 0)
2618	S ^XTMP(" RCCBSS",$J ,"BUILD",S EQ,1)=RCMS G
2619	"RTN","PRC ACPS1",95, 0)
2620	Q
2621	"RTN","PRC ACPS1",96, 0)
2622	;
2623	"RTN","PRC ACPS1",97, 0)
2624	HEX(AMT) ; sets up am ount forma tted as 99 9999999V99 S w/no lea ding blank s and tra
2625	iling sign
2626	"RTN","PRC ACPS1",98, 0)
2627	I $G(AMT) '?.1"-".N. 1".".N S A MT="" G Q
2628	"RTN","PRC ACPS1",99, 0)
2629	S AMT=$TR ($J(AMT,9, 2)," ","")
2630	"RTN","PRC ACPS1",100 ,0)
2631	I $E(AMT) ="-" S AMT =$E(AMT,2, 99)_$E(AMT ,1)
2632	"RTN","PRC ACPS1",101 ,0)
2633	E S AMT= AMT_"+"
2634	"RTN","PRC ACPS1",102 ,0)
2635	S AMT=$P( AMT,".")_$ P(AMT,".", 2)
2636	"RTN","PRC ACPS1",103 ,0)
2637	Q Q AMT
2638	"RTN","PRC ACPS1",104 ,0)
2639	;
2640	"RTN","PRC ACPS1",105 ,0)
2641	DTMDY(DAT) ;Changes date from fm to mmdd yyyy forma t
2642	"RTN","PRC ACPS1",106 ,0)
2643	N YR
2644	"RTN","PRC ACPS1",107 ,0)
2645	I '$G(DAT ) G QDAT
2646	"RTN","PRC ACPS1",108 ,0)
2647	S YR=$E(( $E(DAT,1,3 )+1700),1, 2)
2648	"RTN","PRC ACPS1",109 ,0)
2649	Q $E(DAT, 4,5)_$E(DA T,6,7)_$G( YR)_$E(DAT ,2,3)
2650	"RTN","PRC ACPS1",110 ,0)
2651	QDAT Q ""
2652	"RTN","PRC ACPS1",111 ,0)
2653	;
2654	"RTN","PRC ACPS1",112 ,0)
2655	BLANK(X) ; returns 'x ' blank sp aces
2656	"RTN","PRC ACPS1",113 ,0)
2657	N BLANK
2658	"RTN","PRC ACPS1",114 ,0)
2659	S BLANK=" ",$P(BLANK ," ",X+1)= ""
2660	"RTN","PRC ACPS1",115 ,0)
2661	Q BLANK
2662	"RTN","PRC ACPS1",116 ,0)
2663	;
2664	"RTN","PRC ACPS1",117 ,0)
2665	RJZF(X,Y) ;right jus tify zero fill width Y
2666	"RTN","PRC ACPS1",118 ,0)
2667	S X=$E("0 0000000000 0",1,Y-$L( X))_X
2668	"RTN","PRC ACPS1",119 ,0)
2669	Q X
2670	"RTN","PRC ACPS1",120 ,0)
2671	;
2672	"RTN","PRC ACPS1",121 ,0)
2673	LJSF(X,Y) ;left just ified spac e filled
2674	"RTN","PRC ACPS1",122 ,0)
2675	S X=$E(X, 1,Y)
2676	"RTN","PRC ACPS1",123 ,0)
2677	S X=X_$$B LANK(Y-$L( X))
2678	"RTN","PRC ACPS1",124 ,0)
2679	Q X
2680	"RTN","PRC ACPS1",125 ,0)
2681	;
2682	"RTN","PRC ACPS1",126 ,0)
2683	JD() ; ret urns today 's Julian date YDOY
2684	"RTN","PRC ACPS1",127 ,0)
2685	N XMDDD,X MNOW,XMDT
2686	"RTN","PRC ACPS1",128 ,0)
2687	S XMNOW=$ $NOW^XLFDT
2688	"RTN","PRC ACPS1",129 ,0)
2689	S XMDT=$E (XMNOW,1,7 )
2690	"RTN","PRC ACPS1",130 ,0)
2691	S XMDDD=$ $RJ^XLFSTR ($$FMDIFF^ XLFDT(XMDT ,$E(XMDT,1 ,3)_"0101" ,1)+1,3,"0 ")
2692	"RTN","PRC ACPS1",131 ,0)
2693	Q $E(DT,3 )_XMDDD
2694	"RTN","PRC ACPS1",132 ,0)
2695	;
2696	"RTN","PRC ACPS1",133 ,0)
2697	AMOUNT(X) ;changes a mount to z ero filled , right ju stified
2698	"RTN","PRC ACPS1",134 ,0)
2699	S:X<0 X=- X
2700	"RTN","PRC ACPS1",135 ,0)
2701	S X=$TR($ J(X,0,2)," .")
2702	"RTN","PRC ACPS1",136 ,0)
2703	S X=$E("0 0000000000 0",1,14-$L (X))_X
2704	"RTN","PRC ACPS1",137 ,0)
2705	Q X
2706	"RTN","PRC ACPS1",138 ,0)
2707	;
2708	"RTN","PRC AG")
2709	0^17^B3610 4045^B2201 6512
2710	"RTN","PRC AG",1,0)
2711	PRCAG ;WAS H-ISC@ALTO ONA,PA/CMS -Reprint S tatement/L etter Opti on Entries ;8/23/93
2712	2:42 PM
2713	"RTN","PRC AG",2,0)
2714	V ;;4.5;Ac counts Rec eivable; 149,165,19 8,313;Ma r 20, 1995 ;Build 113
2715	"RTN","PRC AG",3,0)
2716	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
2717	"RTN","PRC AG",4,0)
2718	REP ;ENTRY FROM REPR INT PAT ST ATEMENT
2719	"RTN","PRC AG",5,0)
2720	NEW BEG,E ND,DAT,DAT E,DEB,DIC, HDAT,IOP,S ITE,TYP,X, Y,ZTDESC,Z TRTN,ZTSAV E,%DT,SDT
2721	,%,XDIRUT, %ZIS,POP,Z TIO
2722	"RTN","PRC AG",6,0)
2723	W !!
2724	"RTN","PRC AG",7,0)
2725	ADT ; PRC A4.5313 - Build an d print a list of av ailable da tes for Pa tient Sta
2726	tements wi thin the l ast month
2727	"RTN","PRC AG",8,0)
2728	W !,"Thes e dates in the previ ous month contain Pa tient Stat ements: "
2729	"RTN","PRC AG",9,0)
2730	S DAT="" F S DAT=$ O(^RCPS(34 9.2,"STDT" ,DAT)) Q:D AT="" I $ D(^RC(341, "STDT",DA
2731	T)) W !,$$ DATE^RCCPC PS1(DAT)
2732	"RTN","PRC AG",10,0)
2733	W !!
2734	"RTN","PRC AG",11,0)
2735	S %DT="AE XP",%DT(0) ="-NOW",%D T("A")="En ter a Date to Reprin t: " D ^%D T I Y<1 G
2736	REPQ
2737	"RTN","PRC AG",12,0)
2738	S Y=$P(Y, ".")
2739	"RTN","PRC AG",13,0)
2740	; PRCA4. 5313 - Va lidate tha t Patient Statement Date exist s in 341
2741	"RTN","PRC AG",14,0)
2742	I '$D(^RC (341,"STDT ",Y)) W !! ,*7,"No no tification s sent on that date" ,! G ADT
2743	"RTN","PRC AG",15,0)
2744	S SDT=Y
2745	"RTN","PRC AG",16,0)
2746	W !!,"NOT E: The ran ge is in p rint order not alpha betic!",!
2747	"RTN","PRC AG",17,0)
2748	S X=""
2749	"RTN","PRC AG",18,0)
2750	S BEG=$O( ^RC(341,"S TDT",SDT," "))
2751	"RTN","PRC AG",19,0)
2752	W !,"Do y ou want to Start wit h a Specif ic Patient : "
2753	"RTN","PRC AG",20,0)
2754	S %=2 D Y N^DICN
2755	"RTN","PRC AG",21,0)
2756	I %<0 Q
2757	"RTN","PRC AG",22,0)
2758	I %=1 S X =$$SELNAME (SDT)
2759	"RTN","PRC AG",23,0)
2760	I $D(XDIR UT) Q
2761	"RTN","PRC AG",24,0)
2762	I X'="" S BEG=X
2763	"RTN","PRC AG",25,0)
2764	; PRCA4. 5313 - Us e statemen t date cro ss-referen ce to prov ide a pati ent list
2765	"RTN","PRC AG",26,0)
2766	S X=""
2767	"RTN","PRC AG",27,0)
2768	S END=$O( ^RC(341,"S TDT",SDT," "),-1)
2769	"RTN","PRC AG",28,0)
2770	W !,"Endi ng Patient Bill must be printe d after th e Starting Patient B ill.",!
2771	"RTN","PRC AG",29,0)
2772	W !,"Do y ou want to End with a Specific Patient? "
2773	"RTN","PRC AG",30,0)
2774	S %=2 D Y N^DICN
2775	"RTN","PRC AG",31,0)
2776	I %<0 Q
2777	"RTN","PRC AG",32,0)
2778	I %=1 S X =$$SELNAME (SDT)
2779	"RTN","PRC AG",33,0)
2780	I $D(XDIR UT) Q
2781	"RTN","PRC AG",34,0)
2782	I X'="" S END=X
2783	"RTN","PRC AG",35,0)
2784	I END>0,E ND<BEG W * 7,!,"Endin g bill is before sta rting bill !" G ADT
2785	"RTN","PRC AG",36,0)
2786	S HDAT=99 99999-SDT
2787	"RTN","PRC AG",37,0)
2788	REPD W !! S %ZIS="QN ",IOP="Q", %ZIS("B")= $P($G(^RC( 342,1,0)), U,8) D ^%Z IS G:POP
2789	REPQ
2790	"RTN","PRC AG",38,0)
2791	I '$D(IO( "Q")) W !! ,*7,"YOU M UST QUEUE THIS OUTPU T",! G REP D
2792	"RTN","PRC AG",39,0)
2793	S ZTRTN=" REP^PRCAGS ",ZTDESC=" Reprint AR Patient S tatements" ,ZTSAVE("B EG")="",Z
2794	TSAVE("END ")="",ZTSA VE("HDAT") ="" D ^%ZT LOAD
2795	"RTN","PRC AG",40,0)
2796	REPQ D ^%Z ISC Q
2797	"RTN","PRC AG",41,0)
2798	UB ;ENTRY FROM REPRI NT UB BILL S
2799	"RTN","PRC AG",42,0)
2800	S ETY="UB " ;set eve nt type to UB and us e REB sub- routine
2801	"RTN","PRC AG",43,0)
2802	REB ;ENTRY FROM REPR INT FOLLOW -UP LETTER S
2803	"RTN","PRC AG",44,0)
2804	NEW BEG,E ND,DAT,DAT E,DEB,DIC, IOP,SITE,T YP,X,Y,ZTD ESC,ZTRTN, ZTSAVE,%DT ,DA,DIR,D
2805	TOUT
2806	"RTN","PRC AG",45,0)
2807	D SITE^PR CAGU
2808	"RTN","PRC AG",46,0)
2809	S:'$D(ETY ) ETY="FL"
2810	"RTN","PRC AG",47,0)
2811	REBDT S %D T="AEXP",% DT(0)="-NO W",%DT("A" )="Enter a Date to R eprint: " D ^%DT G:
2812	Y<1 REBQ
2813	"RTN","PRC AG",48,0)
2814	S Y=$P(Y, ".")
2815	"RTN","PRC AG",49,0)
2816	I $P($O(^ RC(341,"C" ,Y)),".")' =Y W !!,*7 ,"No notif ications s ent on tha t date",!
2817	G REBDT
2818	"RTN","PRC AG",50,0)
2819	S DAT=999 9999-Y
2820	"RTN","PRC AG",51,0)
2821	W !!,"Pre ss return at the 'Bi ll:' promp ts to repr int all ", ETY," Lett ers",!,"f
2822	or the dat e selected or select a start a nd/or end point."
2823	"RTN","PRC AG",52,0)
2824	W !,"Do n ot select bills that print on the Patien t Statemen t."
2825	"RTN","PRC AG",53,0)
2826	W !,"NOTE : The rang e is in pr int order not alphab etic!",!
2827	"RTN","PRC AG",54,0)
2828	N DPTNOFZ Y,DPTNOFZK S (DPTNOF ZY,DPTNOFZ K)=1
2829	"RTN","PRC AG",55,0)
2830	S DIC="^P RCA(430,", DIC(0)="AE MNQ",DIC(" A")="Start from Bill : ",DIC("S ")="I "",
2831	18,25,5,24 ,1,2,3,4,2 3,22,""'[( "",""_$P(^ (0),U,2)_" ","")" D ^ DIC I ($D( DTOUT))!(
2832	X["^") G R EBQ
2833	"RTN","PRC AG",56,0)
2834	S BEG=0,Y =+Y
2835	"RTN","PRC AG",57,0)
2836	I Y>0 S B EG=-1,DEB= +$P($G(^PR CA(430,Y,0 )),U,9),TY P=+$O(^RC( 341.1,"AC" ,$S(ETY="
2837	UB":9,1:10 ),0)) F DA TE=DAT-.00 01:0 S DAT E=$O(^RC(3 41,"AD",DE B,TYP,DATE )) Q:$P(D
2838	ATE,".")'= DAT D
2839	"RTN","PRC AG",58,0)
2840	.F DA=0:0 S DA=$O(^ RC(341,"AD ",DEB,TYP, DATE,DA)) Q:'DA I + $G(^RC(341 ,DA,5))=Y
2841	S BEG=DA, DEB=0 Q
2842	"RTN","PRC AG",59,0)
2843	.Q
2844	"RTN","PRC AG",60,0)
2845	I BEG=0 S BEG=$O(^R C(341,"C", +$O(^RC(34 1,"C",9999 999-DAT)), 0)) S:'BEG BEG=-1
2846	"RTN","PRC AG",61,0)
2847	I BEG<0 W *7,!," So rry, not f ound!" G R EBDT
2848	"RTN","PRC AG",62,0)
2849	S DIC("A" )="End aft er Bill: " D ^DIC I ($D(DTOUT) )!(X["^") G REBQ
2850	"RTN","PRC AG",63,0)
2851	S END="*" ,Y=+Y
2852	"RTN","PRC AG",64,0)
2853	I Y>0 S E ND=-1,DEB= +$P($G(^PR CA(430,Y,0 )),U,9),TY P=+$O(^RC( 341.1,"AC" ,$S(ETY="
2854	UB":9,1:10 ),0)) F DA TE=DAT-.00 01:0 S DAT E=$O(^RC(3 41,"AD",DE B,TYP,DATE )) Q:$P(D
2855	ATE,".")'= DAT D
2856	"RTN","PRC AG",65,0)
2857	.F DA=0:0 S DA=$O(^ RC(341,"AD ",DEB,TYP, DATE,DA)) Q:'DA I + $G(^RC(341 ,DA,5))=Y
2858	S END=DA, DEB=0 Q
2859	"RTN","PRC AG",66,0)
2860	.Q
2861	"RTN","PRC AG",67,0) RCCPCAT ;A LB/TGH - P ATCH PRCA* 4.5ANNUAL PAYMENT T RANSMIT I END<0 W 7,!," So rry, not f ound!" G R EBDT

2862	"RTN","PRC AG",68,0)
2863	I END'="* ",END<BEG W *7,!,"En ding bill is before starting b ill!" G RE BDT
2864	"RTN","PRC AG",69,0)
2865	W !!
2866	"RTN","PRC AG",70,0)
2867	REBD I ETY ="UB" S ZT IO="" G RE BD1
2868	"RTN","PRC AG",71,0)
2869	S %ZIS("B ")=$P($G(^ RC(342,1,0 )),U,8),%Z IS="QN",IO P="Q" D ^% ZIS G:POP REBQ
2870	"RTN","PRC AG",72,0)
2871	I '$D(IO( "Q")) W !! ,*7,"YOU M UST QUEUE THIS OUTPU T",! G REB D
2872	"RTN","PRC AG",73,0)
2873	REBD1 S ZT RTN="BILL^ PRCAGS",ZT SAVE("BEG" )="",ZTSAV E("END")=" ",ZTSAVE(" DAT")="",
2874	ZTSAVE("SI TE")="",ZT SAVE("ETY" )=""
2875	"RTN","PRC AG",74,0)
2876	S ZTDESC= $S(ETY="UB ":"AR Repr int UB Let ters",1:"R eprint AR Follow-up Letters")
2877	D ^%ZTLOA D
2878	"RTN","PRC AG",75,0)
2879	REBQ K ETY D ^%ZISC Q
2880	"RTN","PRC AG",76,0)
2881	PRDT ;ENTR Y FROM PRI NT STATEME NT/LETTER BY DATE OP TION
2882	"RTN","PRC AG",77,0)
2883	D PRDT^PR CAGP
2884	"RTN","PRC AG",78,0)
2885	Q
2886	"RTN","PRC AG",79,0)
2887	SELNAME(SD T) ; PRCA ^4.5^313 - Create a list and t hen select a patient name
2888	"RTN","PRC AG",80,0)
2889	N IEN,CNT ,NAME
2890	"RTN","PRC AG",81,0)
2891	W !,"Plea se wait wh ile we bui ld the pat ient list. ",!
2892	"RTN","PRC AG",82,0)
2893	K ^TMP($J ,"LISTNAME ")
2894	"RTN","PRC AG",83,0)
2895	S (IEN,CN T)=0
2896	"RTN","PRC AG",84,0)
2897	F S IEN= $O(^RC(341 ,"STDT",SD T,IEN)) Q: IEN="" D
2898	"RTN","PRC AG",85,0)
2899	. N PAT,N AME
2900	"RTN","PRC AG",86,0)
2901	. S PAT=$ P(^RCD(340 ,$P(^RC(34 1,IEN,0)," ^",5),0)," ;")
2902	"RTN","PRC AG",87,0)
2903	. S NAME= $P(^DPT(PA T,0),U)
2904	"RTN","PRC AG",88,0)
2905	. S ^TMP( $J,"LISTNA ME",NAME)= IEN
2906	"RTN","PRC AG",89,0)
2907	W !,"Plea se enter a ll or part of Patien t Name: " R NAME:DTI ME
2908	"RTN","PRC AG",90,0)
2909	I NAME="^ " S XDIRUT =1 Q ""
2910	"RTN","PRC AG",91,0)
2911	I $G(NAME )'="",$D(^ TMP($J,"LI STNAME",NA ME)) S IEN =^(NAME) Q IEN
2912	"RTN","PRC AG",92,0)
2913	W !!,"Pat ient Name is not an exact matc h."
2914	"RTN","PRC AG",93,0)
2915	W !,"Woul d you like a list of Patient N ames for " _$$DATE^RC CPCPS1(SDT )_"? "
2916	"RTN","PRC AG",94,0)
2917	S %=2 D Y N^DICN
2918	"RTN","PRC AG",95,0)
2919	I %=2 N Q UIT D I Q UIT=1 S Y= -1 Q -1
2920	"RTN","PRC AG",96,0)
2921	. W !,"Al l of the P atient Sta tements fo r this dat e will now print."
2922	"RTN","PRC AG",97,0)
2923	. W !,"Is this corr ect? "
2924	"RTN","PRC AG",98,0)
2925	. S %=1 D YN^DICN S QUIT=%
2926	"RTN","PRC AG",99,0)
2927	S IEN=""
2928	"RTN","PRC AG",100,0)
2929	D SELNM1
2930	"RTN","PRC AG",101,0)
2931	Q IEN
2932	"RTN","PRC AG",102,0)
2933	SELNM1() ; Select n ame
2934	"RTN","PRC AG",103,0)
2935	N DIRUT,X CNT
2936	"RTN","PRC AG",104,0)
2937	K ^TMP($J ,"LISTCNT" )
2938	"RTN","PRC AG",105,0)
2939	; Quit th e listing if no name s to displ ay
2940	"RTN","PRC AG",106,0)
2941	I $O(^TMP ($J,"LISTN AME",NAME) )="" Q
2942	"RTN","PRC AG",107,0)
2943	W @IOF,"N umber",?20 ,"Patient Name"
2944	"RTN","PRC AG",108,0)
2945	F S NAME =$O(^TMP($ J,"LISTNAM E",NAME)) Q:NAME="" D I $D(D IRUT) Q
2946	"RTN","PRC AG",109,0)
2947	. S CNT=C NT+1
2948	"RTN","PRC AG",110,0)
2949	. S ^TMP( $J,"LISTCN T",CNT,NAM E)=^TMP($J ,"LISTNAME ",NAME)
2950	"RTN","PRC AG",111,0)
2951	. W !,CNT ,?20,NAME
2952	"RTN","PRC AG",112,0)
2953	. I ($Y+3 )>IOSL D Q:$D(DIRUT )
2954	"RTN","PRC AG",113,0)
2955	. . S DIR (0)="E" D ^DIR
2956	"RTN","PRC AG",114,0)
2957	. . I X=" ^",($Y+3)< IOSL
2958	"RTN","PRC AG",115,0)
2959	. . W @IO F
2960	"RTN","PRC AG",116,0)
2961	. . I X'= "^" W "Num ber",?20," Patient Na me"
2962	"RTN","PRC AG",117,0)
2963	W !,"Plea se enter n umber of s elected Pa tient Name : " R XCNT :DTIME
2964	"RTN","PRC AG",118,0)
2965	I XCNT="^ "!(XCNT="" ) N % D I %=1 Q
2966	"RTN","PRC AG",119,0)
2967	. W !,"Al l of the P atient Sta tements fo r this dat e will now print."
2968	"RTN","PRC AG",120,0)
2969	. W !,"Is this corr ect?"
2970	"RTN","PRC AG",121,0)
2971	. S %=1 D YN^DICN
2972	"RTN","PRC AG",122,0)
2973	I XCNT="" !('$D(^TMP ($J,"LISTC NT",XCNT)) ) Q
2974	"RTN","PRC AG",123,0)
2975	S CNT=XCN T
2976	"RTN","PRC AG",124,0)
2977	W !!,$O(^ TMP($J,"LI STCNT",CNT ,0)),!,".. .OK? "
2978	"RTN","PRC AG",125,0)
2979	S %=1 D Y N^DICN
2980	"RTN","PRC AG",126,0)
2981	I %=2 D Q
2982	"RTN","PRC AG",127,0)
2983	. W !,"No Patient S elected. "
2984	"RTN","PRC AG",128,0)
2985	. S DIR(0 )="E" D ^D IR
2986	"RTN","PRC AG",129,0)
2987	S NAME=$O (^TMP($J," LISTCNT",C NT,0))
2988	"RTN","PRC AG",130,0)
2989	S IEN=^TM P($J,"LIST CNT",CNT,N AME)
2990	"RTN","PRC AG",131,0)
2991	Q 1
2992	"RTN","RCC PCAP")
2993	0^21^B3974 2487^n/a
2994	"RTN","RCC PCAP",1,0)
2995	RCCPCAP ;A LB/TGH - P ATCH PRCA* 4.5*ANNUAL PAYMENT B UILD ; 2/3 /2016 11:3 0 am
2996	"RTN","RCC PCAP",2,0)
2997	;;4.5;Acc ounts Rece ivable;3 13;Feb 2 0, 2017;Bu ild 113
2998	"RTN","RCC PCAP",3,0)
2999	;;Per VA Directive 6402, this routine s hould not be modifie d.
3000	"RTN","RCC PCAP",4,0)
3001	EN(YEAR,SO URCE,DTTIM E) ; Bui ld the pay ment state ments for Year enter ed
3002	"RTN","RCC PCAP",5,0)
3003	; Year is the first three num bers of th e Internal Date form at and mus t be earl
3004	ier than c urrent Yea r
3005	"RTN","RCC PCAP",6,0)
3006	; Source will be us ed to dete rmine whet her to sch edule or i mmediately start Tr
3007	ansmit aft er Build
3008	"RTN","RCC PCAP",7,0)
3009	; DTTIME is the Tra nsmit date and time in Interna l time fro m Build an d Transmi
3010	t menu opt ion
3011	"RTN","RCC PCAP",8,0)
3012	;
3013	"RTN","RCC PCAP",9,0)
3014	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with warni ng.
3015	"RTN","RCC PCAP",10,0 )
3016	L +^RCAP( 349.5):DIL OCKTM I '$ T W 7,7, !,"Annual Payment is already b eing run
3017	or transmi tted. Try again lat er." Q
3018	"RTN","RCC PCAP",11,0 )
3019	;
3020	"RTN","RCC PCAP",12,0 )
3021	N %,%I,%H ,STARTDT,E NDDT,LINE, PSSEG,PSCN TR,EXIT,DE BTOR,END,N EXT,SIZE
3022	"RTN","RCC PCAP",13,0 )
3023	;
3024	"RTN","RCC PCAP",14,0 )
3025	; Initial ize Incomi ng Variabl es - YEAR will be to Year befo re Current
3026	"RTN","RCC PCAP",15,0 )
3027	; Source will be to "B"ackgro und, and D TTIME to i ts current value, in cluding N
3028	ULL
3029	"RTN","RCC PCAP",16,0 )
3030	I $G(YEAR )="" S YEA R=$E(DT,1, 3)-1
3031	"RTN","RCC PCAP",17,0 )
3032	I $G(SOUR CE)="" S S OURCE="B"
3033	"RTN","RCC PCAP",18,0 )
3034	S DTTIME= $G(DTTIME)
3035	"RTN","RCC PCAP",19,0 )
3036	;
3037	"RTN","RCC PCAP",20,0 )
3038	; Remove previous e ntries fro m file pri or to buil ding new f ile
3039	"RTN","RCC PCAP",21,0 )
3040	D KILL
3041	"RTN","RCC PCAP",22,0 )
3042	;
3043	"RTN","RCC PCAP",23,0 )
3044	; Set Sta rt and End Dates
3045	"RTN","RCC PCAP",24,0 )
3046	S STARTDT =YEAR_"010 0"
3047	"RTN","RCC PCAP",25,0 )
3048	S ENDDT=Y EAR_1232
3049	"RTN","RCC PCAP",26,0 )
3050	S (DEBTOR ,END)=""
3051	"RTN","RCC PCAP",27,0 )
3052	F PSCNTR= 1:1 Q:END D
3053	"RTN","RCC PCAP",28,0 )
3054	. S (NEXT ,SIZE,LINE )=0
3055	"RTN","RCC PCAP",29,0 )
3056	. D SETPS (PSCNTR,YE AR)
3057	"RTN","RCC PCAP",30,0 )
3058	. N LASTP D
3059	"RTN","RCC PCAP",31,0 )
3060	. F S DE BTOR=$O(^P RCA(433,"A TD",DEBTOR )) Q:DEBTO R="" D I NEXT Q
3061	"RTN","RCC PCAP",32,0 )
3062	.. ; Quit if the de btor is no t a patien t
3063	"RTN","RCC PCAP",33,0 )
3064	.. I '$D( ^RCD(340," AB","DPT(" ,DEBTOR)) Q
3065	"RTN","RCC PCAP",34,0 )
3066	.. N PHSE T,PHCNTR,P HSEG,DATE, LTBDT
3067	"RTN","RCC PCAP",35,0 )
3068	.. S (PHS ET,PHCNTR, LTBDT)=0
3069	"RTN","RCC PCAP",36,0 )
3070	.. S DATE =STARTDT
3071	"RTN","RCC PCAP",37,0 )
3072	.. F S D ATE=$O(^PR CA(433,"AT D",DEBTOR, DATE)) Q:D ATE="" Q: DATE>ENDDT D
3073	"RTN","RCC PCAP",38,0 )
3074	... ; Rec heck and Q uit if the date is n ot within the Year
3075	"RTN","RCC PCAP",39,0 )
3076	... I DAT E<STARTDT! (DATE>ENDD T) Q
3077	"RTN","RCC PCAP",40,0 )
3078	... ; Set Final Dat e for this Debtor to determine final tra nsaction
3079	"RTN","RCC PCAP",41,0 )
3080	... N TRA NS
3081	"RTN","RCC PCAP",42,0 )
3082	... S TRA NS=""
3083	"RTN","RCC PCAP",43,0 )
3084	... F S TRANS=$O(^ PRCA(433," ATD",DEBTO R,DATE,TRA NS)) Q:TRA NS="" D
3085	"RTN","RCC PCAP",44,0 )
3086	.... ; Qu it if the Transactio n Type is not Paymen t in Part( 2) or Paym ent in Fu
3087	ll(34)
3088	"RTN","RCC PCAP",45,0 )
3089	.... I $P (^PRCA(433 ,TRANS,1), U,2)'=2&($ P(^PRCA(43 3,TRANS,1) ,U,2)'=34) Q
3090	"RTN","RCC PCAP",46,0 )
3091	.... ; Se t PH Recor d if first time for this Debto r
3092	"RTN","RCC PCAP",47,0 )
3093	.... I 'P HSET D SET PH(DEBTOR, PSCNTR) S PHSET=1
3094	"RTN","RCC PCAP",48,0 )
3095	.... ; Se t PD Recor d for each Payment T ransaction
3096	"RTN","RCC PCAP",49,0 )
3097	.... D SE TPD(DEBTOR ,DATE,TRAN S,PSCNTR)
3098	"RTN","RCC PCAP",50,0 )
3099	.. ;
3100	"RTN","RCC PCAP",51,0 )
3101	.. ; Afte r completi ng each De btor, if t he Size is over 30K, set Next to create
3102	a new PS Record,
3103	"RTN","RCC PCAP",52,0 )
3104	.. ; set Message De limiter at the end o f the PD r ecord, and set End D ate and T
3105	ime
3106	"RTN","RCC PCAP",53,0 )
3107	.. I SIZE >30000 D
3108	"RTN","RCC PCAP",54,0 )
3109	... S ^RC AP(349.5,P SCNTR,LAST PD,0)=^RCA P(349.5,PS CNTR,LASTP D,0)_"~"
3110	"RTN","RCC PCAP",55,0 )
3111	... S NEX T=1
3112	"RTN","RCC PCAP",56,0 )
3113	... D NOW ^%DTC
3114	"RTN","RCC PCAP",57,0 )
3115	... S $P( ^RCAP(349. 5,PSCNTR,0 ),U,4)=%
3116	"RTN","RCC PCAP",58,0 )
3117	.. ;
3118	"RTN","RCC PCAP",59,0 )
3119	.. ; If t he last De btor in AT D has proc essed set End to sto p processi ng, if Ti
3120	lde not fi nal
3121	"RTN","RCC PCAP",60,0 )
3122	.. ; char acter, set Tilde to Last PD re cord, and set End Da te and tim e
3123	"RTN","RCC PCAP",61,0 )
3124	. I DEBTO R="" D
3125	"RTN","RCC PCAP",62,0 )
3126	.. S END= 1
3127	"RTN","RCC PCAP",63,0 )
3128	.. I $E(^ RCAP(349.5 ,PSCNTR,LA STPD,0),$L (^RCAP(349 .5,PSCNTR, LASTPD,0)) )'="~" S
3129	^RCAP(349. 5,PSCNTR,L ASTPD,0)=^ RCAP(349.5 ,PSCNTR,LA STPD,0)_"~ "
3130	"RTN","RCC PCAP",64,0 )
3131	.. D NOW^ %DTC
3132	"RTN","RCC PCAP",65,0 )
3133	.. S $P(^ RCAP(349.5 ,PSCNTR,0) ,U,4)=%
3134	"RTN","RCC PCAP",66,0 )
3135	;
3136	"RTN","RCC PCAP",67,0 )
3137	; PRCA4. 5313 - Un lock prior to transm ission
3138	"RTN","RCC PCAP",68,0 )
3139	L -^RCAP( 349.5):DIL OCKTM
3140	"RTN","RCC PCAP",69,0 )
3141	;
3142	"RTN","RCC PCAP",70,0 )
3143	; If the Source is Background (B) deter mine the d ate and ti me from th e schedul
3144	e based up on site co de
3145	"RTN","RCC PCAP",71,0 )
3146	I SOURCE= "B" S DTTI ME=$$SCHED ^RCCPCAT($ $SITE^RCMS ITE)
3147	"RTN","RCC PCAP",72,0 )
3148	D EN^RCCP CAT(DTTIME )
3149	"RTN","RCC PCAP",73,0 )
3150	;
3151	"RTN","RCC PCAP",74,0 )
3152	Q
3153	"RTN","RCC PCAP",75,0 )
3154	;
3155	"RTN","RCC PCAP",76,0 )
3156	SETPS(PSCN TR,YEAR) ; Get and Set Data f or PS Reco rd into 34 9.5
3157	"RTN","RCC PCAP",77,0 )
3158	; Set Yea r and Buil d Start Da te and Tim e
3159	"RTN","RCC PCAP",78,0 )
3160	N PS,DR,D A,DIE,DIC, X
3161	"RTN","RCC PCAP",79,0 )
3162	S DIC="^R CAP(349.5, ",X=PSCNTR ,DA=.01,DI C(0)="" D FILE^DICN
3163	"RTN","RCC PCAP",80,0 )
3164	D NOW^%DT C
3165	"RTN","RCC PCAP",81,0 )
3166	S $P(^RCA P(349.5,PS CNTR,0),U, 2,3)=YEAR_ U_%
3167	"RTN","RCC PCAP",82,0 )
3168	; Increme nt Line nu mber
3169	"RTN","RCC PCAP",83,0 )
3170	S LINE=LI NE+1
3171	"RTN","RCC PCAP",84,0 )
3172	; Set PSS EG for thi s Segment to PS Coun ter
3173	"RTN","RCC PCAP",85,0 )
3174	S PSSEG(P SCNTR)=PSC NTR
3175	"RTN","RCC PCAP",86,0 )
3176	; Pieces 3 and 6 wi ll be upda ted during the creat ion of oth er PS and PH segmen
3177	ts
3178	"RTN","RCC PCAP",87,0 )
3179	S PS="PS" _U_PSCNTR_ U_PSCNTR_U _$$SITE^RC MSITE_U_$$ FP^RCCPCFN _U_0_U_20_ $E(YEAR,2
3180	,3)_U_$$DA T^RCCPCFN( DT)_U_"}"
3181	"RTN","RCC PCAP",88,0 )
3182	; Update File
3183	"RTN","RCC PCAP",89,0 )
3184	S ^RCAP(3 49.5,PSCNT R,LINE,0)= PS
3185	"RTN","RCC PCAP",90,0 )
3186	; Add len gth to SIZ E
3187	"RTN","RCC PCAP",91,0 )
3188	S SIZE=SI ZE+$L(PS)
3189	"RTN","RCC PCAP",92,0 )
3190	; Update all previo us PS Segm ents piece 3 with cu rrent coun ter
3191	"RTN","RCC PCAP",93,0 )
3192	N I
3193	"RTN","RCC PCAP",94,0 )
3194	S I=0
3195	"RTN","RCC PCAP",95,0 )
3196	F S I=$O (PSSEG(I)) Q:I=PSCNT R S $P(^R CAP(349.5, I,1,0),U,3 )=PSCNTR
3197	"RTN","RCC PCAP",96,0 )
3198	;
3199	"RTN","RCC PCAP",97,0 )
3200	Q
3201	"RTN","RCC PCAP",98,0 )
3202	;
3203	"RTN","RCC PCAP",99,0 )
3204	SETPH(DEBT OR,PSCNTR) ; Get an d Set Data for PH Re cord into 349.5
3205	"RTN","RCC PCAP",100, 0)
3206	N PH,SITE ,PATNAME,A DDRESS,I,A RFLAG,ARAD DR,COUNTRY ,DFN,ICN,D R,DA,DIE,P OSTCODE
3207	"RTN","RCC PCAP",101, 0)
3208	; Increme nt Line nu mber
3209	"RTN","RCC PCAP",102, 0)
3210	S LINE=LI NE+1
3211	"RTN","RCC PCAP",103, 0)
3212	; Increme nt PH Coun ter
3213	"RTN","RCC PCAP",104, 0)
3214	S PHCNTR= PHCNTR+1
3215	"RTN","RCC PCAP",105, 0)
3216	; Set PHS EG for thi s Segment to Line
3217	"RTN","RCC PCAP",106, 0)
3218	S PHSEG(P HCNTR)=LIN E
3219	"RTN","RCC PCAP",107, 0)
3220	; Get DFN and ICN f or Debtor and Patien t - If the ICN retur ns a -1 in the firs
3221	t piece
3222	"RTN","RCC PCAP",108, 0)
3223	; send a Null value as the IC N
3224	"RTN","RCC PCAP",109, 0)
3225	S DFN=+$P (^RCD(340, DEBTOR,0), U)
3226	"RTN","RCC PCAP",110, 0)
3227	S ICN=$$G ETICN^MPIF 001(DFN)
3228	"RTN","RCC PCAP",111, 0)
3229	S ICN=$S( +ICN'=-1:I CN,1:"")
3230	"RTN","RCC PCAP",112, 0)
3231	; Get Acc ount Numbe r -- Sit e code and SSN
3232	"RTN","RCC PCAP",113, 0)
3233	S SITE=$$ SITE^RCMSI TE
3234	"RTN","RCC PCAP",114, 0)
3235	S PH="PH" _U_SITE_$$ SSN^RCFN01 (DEBTOR)
3236	"RTN","RCC PCAP",115, 0)
3237	; Get Pat ient Name
3238	"RTN","RCC PCAP",116, 0)
3239	S PATNAME =$$NAM^RCF N01(DEBTOR )
3240	"RTN","RCC PCAP",117, 0)
3241	S PH=PH_$ E($P(PATNA ME,","),1, 5)_U_$E($P (PATNAME," ,"),1,20)_ U_$E($P($P (PATNAME,
3242	",",2)," " ),1,10)_U_ $E($P(PATN AME," ",2) ,1,10)
3243	"RTN","RCC PCAP",118, 0)
3244	; If Coun try is not '1' get C ountry Nam e and Post al Code
3245	"RTN","RCC PCAP",119, 0)
3246	S COUNTRY =$P($G(^DP T(+$P(^RCD (340,DEBTO R,0),U),.1 1)),U,10)
3247	"RTN","RCC PCAP",120, 0)
3248	S COUNTRY =$S(COUNTR Y=1:"",1:$ $GET1^DIQ( 779.004,CO UNTRY,"POS TAL NAME") )
3249	"RTN","RCC PCAP",121, 0)
3250	I COUNTRY '="" S POS TCODE=$P($ G(^DPT(DFN ,.11)),U,9 )
3251	"RTN","RCC PCAP",122, 0)
3252	; Get Add ress and A RFLAG
3253	"RTN","RCC PCAP",123, 0)
3254	S ADDRESS =$P($$DADD ^RCAMADD(D EBTOR,1),U ,1,6)
3255	"RTN","RCC PCAP",124, 0)
3256	F I=1:1:4 S $P(ADDR ESS,U,I)=$ E($P(ADDRE SS,U,I),1, 40)
3257	"RTN","RCC PCAP",125, 0)
3258	; If the Country is Null the State and Zip Code w ill be use d
3259	"RTN","RCC PCAP",126, 0)
3260	; If the Country is Not Null, the State will be F X and the
3261	"RTN","RCC PCAP",127, 0)
3262	; Zip Cod e will be the Postal Code from the Patie nt (#2) fi le
3263	"RTN","RCC PCAP",128, 0)
3264	S $P(ADDR ESS,U,5)=$ S(COUNTRY= "":$E($P(A DDRESS,U,5 ),1,2),1:" FX")
3265	"RTN","RCC PCAP",129, 0)
3266	S $P(ADDR ESS,U,6)=$ S(COUNTRY= "":$E($P(A DDRESS,U,6 ),1,9),1:$ E(POSTCODE ,1,11))
3267	"RTN","RCC PCAP",130, 0)
3268	S PH=PH_U _ADDRESS
3269	"RTN","RCC PCAP",131, 0)
3270	S ARFLAG= "N"
3271	"RTN","RCC PCAP",132, 0)
3272	S ARADDR= $P($G(^RCD (340,DEBTO R,1)),U,1, 6)
3273	"RTN","RCC PCAP",133, 0)
3274	I ($P(ARA DDR,U)'="" ),($P(ARAD DR,U,4)'=" "),($P(ARA DDR,U,5)'= ""),(($P(A RADDR,U,6
3275	)'="")) S ARFLAG="Y"
3276	"RTN","RCC PCAP",134, 0)
3277	S PH=PH_U _$E(COUNTR Y,1,11)
3278	"RTN","RCC PCAP",135, 0)
3279	; Set DFN and ICN f or Debtor and Patien t with Bla nk space f or Total A mount Rec
3280	eived
3281	"RTN","RCC PCAP",136, 0)
3282	S PH=PH_U _U_SITE_DF N_U_ICN
3283	"RTN","RCC PCAP",137, 0)
3284	; Set ARF LAG from a bove
3285	"RTN","RCC PCAP",138, 0)
3286	S PH=PH_U _ARFLAG
3287	"RTN","RCC PCAP",139, 0)
3288	; Set Bla nk spaces for Last B ill Prepar ed Date fo r Debtor a nd Number of PD Seg
3289	ments
3290	"RTN","RCC PCAP",140, 0)
3291	; and the n Record D elimiter
3292	"RTN","RCC PCAP",141, 0)
3293	S PH=PH_U _U_U_"}"
3294	"RTN","RCC PCAP",142, 0)
3295	; Update file
3296	"RTN","RCC PCAP",143, 0)
3297	S ^RCAP(3 49.5,PSCNT R,LINE,0)= PH
3298	"RTN","RCC PCAP",144, 0)
3299	; Add len gth to SIZ E
3300	"RTN","RCC PCAP",145, 0)
3301	S SIZE=SI ZE+$L(PH)
3302	"RTN","RCC PCAP",146, 0)
3303	; Increme nt PS segm ent piece 6 with ano ther PH re cord
3304	"RTN","RCC PCAP",147, 0)
3305	S $P(^RCA P(349.5,PS SEG(PSCNTR ),1,0),U,6 )=$P(^RCAP (349.5,PSS EG(PSCNTR) ,1,0),U,6
3306	)+1
3307	"RTN","RCC PCAP",148, 0)
3308	Q
3309	"RTN","RCC PCAP",149, 0)
3310	;
3311	"RTN","RCC PCAP",150, 0)
3312	SETPD(DEBT OR,DATE,TR ANS,PSCNTR ) ; Get a nd Set Dat a for PD R ecord into 349.5
3313	"RTN","RCC PCAP",151, 0)
3314	N DR,DA,D IE,PD,AMT, PHTOT,BILL ,CURBDT
3315	"RTN","RCC PCAP",152, 0)
3316	; Get Tra nsaction A mount - Qu it if Amou nt is zero or null
3317	"RTN","RCC PCAP",153, 0)
3318	S AMT=$P( ^PRCA(433, TRANS,1),U ,5)
3319	"RTN","RCC PCAP",154, 0)
3320	I 'AMT Q
3321	"RTN","RCC PCAP",155, 0)
3322	; Format Amount
3323	"RTN","RCC PCAP",156, 0)
3324	S AMT=$TR ($J(AMT,9, 2)," ","")
3325	"RTN","RCC PCAP",157, 0)
3326	S AMT=$P( AMT,".")_$ P(AMT,".", 2)
3327	"RTN","RCC PCAP",158, 0)
3328	;
3329	"RTN","RCC PCAP",159, 0)
3330	S LINE=LI NE+1
3331	"RTN","RCC PCAP",160, 0)
3332	S LASTPD= LINE
3333	"RTN","RCC PCAP",161, 0)
3334	; Format and Set Da te Entered , Amount, and Delimi ter
3335	"RTN","RCC PCAP",162, 0)
3336	S PD="PD" _U_$$DAT^R CCPCFN(DAT E)_U_AMT_U _"}"
3337	"RTN","RCC PCAP",163, 0)
3338	;
3339	"RTN","RCC PCAP",164, 0)
3340	; Add len gth to SIZ E
3341	"RTN","RCC PCAP",165, 0)
3342	S SIZE=SI ZE+$L(PD)
3343	"RTN","RCC PCAP",166, 0)
3344	;
3345	"RTN","RCC PCAP",167, 0)
3346	; Update file
3347	"RTN","RCC PCAP",168, 0)
3348	S ^RCAP(3 49.5,PSCNT R,LINE,0)= PD
3349	"RTN","RCC PCAP",169, 0)
3350	;
3351	"RTN","RCC PCAP",170, 0)
3352	; Get cur rent PH To tal, add A mount, the n reset to PH Segmen t
3353	"RTN","RCC PCAP",171, 0)
3354	S PHTOT=$ P(^RCAP(34 9.5,PSSEG( PSCNTR),PH SEG(PHCNTR ),0),U,13)
3355	"RTN","RCC PCAP",172, 0)
3356	S PHTOT=P HTOT+AMT
3357	"RTN","RCC PCAP",173, 0)
3358	S $P(^RCA P(349.5,PS SEG(PSCNTR ),PHSEG(PH CNTR),0),U ,13)=PHTOT
3359	"RTN","RCC PCAP",174, 0)
3360	;
3361	"RTN","RCC PCAP",175, 0)
3362	; Determi ne the Cur rent Bill Date and i f greater than LTBDT , Latest B ill Date,
3363
3364	"RTN","RCC PCAP",176, 0)
3365	; set to PH Segment and LTBDT
3366	"RTN","RCC PCAP",177, 0)
3367	S BILL=$P (^PRCA(433 ,TRANS,0), U,2)
3368	"RTN","RCC PCAP",178, 0)
3369	S CURBDT= $P(^PRCA(4 30,BILL,0) ,U,10)
3370	"RTN","RCC PCAP",179, 0)
3371	I CURBDT> LTBDT S $P (^RCAP(349 .5,PSSEG(P SCNTR),PHS EG(PHCNTR) ,0),U,17)= $$DAT^RCC
3372	PCFN(CURBD T),LTBDT=C URBDT
3373	"RTN","RCC PCAP",180, 0)
3374	;
3375	"RTN","RCC PCAP",181, 0)
3376	; Increme nt PH segm ent piece 18 with an other PD r ecord
3377	"RTN","RCC PCAP",182, 0)
3378	S $P(^RCA P(349.5,PS SEG(PSCNTR ),PHSEG(PH CNTR),0),U ,18)=$P(^R CAP(349.5, PSSEG(PSC
3379	NTR),PHSEG (PHCNTR),0 ),U,18)+1
3380	"RTN","RCC PCAP",183, 0)
3381	Q
3382	"RTN","RCC PCAP",184, 0)
3383	;
3384	"RTN","RCC PCAP",185, 0)
3385	KILL ; Re move exist ing RCAP(3 49.5 Entri es
3386	"RTN","RCC PCAP",186, 0)
3387	N DA,DIK
3388	"RTN","RCC PCAP",187, 0)
3389	S DIK="^R CAP(349.5, "
3390	"RTN","RCC PCAP",188, 0)
3391	S DA=0 F S DA=$O(^ RCAP(349.5 ,DA)) Q:DA ="" D ^DI K
3392	"RTN","RCC PCAP",189, 0)
3393	Q
3394	"RTN","RCC PCAP",190, 0)
3395	;
3396	"RTN","RCC PCAR")
3397	0^23^B4858 7779^n/a
3398	"RTN","RCC PCAR",1,0)
3399	RCCPCAR ;A LB/TGH - P ATCH PRCA* 4.5*ANNUAL PAYMENT R EPORT ; 2/ 3/2016 11: 30 am
3400	"RTN","RCC PCAR",2,0)
3401	;;4.5;Acc ounts Rece ivable;3 13;Feb 2 0, 2017;Bu ild 113
3402	"RTN","RCC PCAR",3,0)
3403	;;Per VA Directive 6402, this routine s hould not be modifie d.
3404	"RTN","RCC PCAR",4,0)
3405	EN(YEAR) ; Report errors for the payme nt stateme nts for Ye ar entered
3406	"RTN","RCC PCAR",5,0)
3407	; Year is the first three num bers of th e Internal Date form at
3408	"RTN","RCC PCAR",6,0)
3409	;
3410	"RTN","RCC PCAR",7,0)
3411	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with warni ng.
3412	"RTN","RCC PCAR",8,0)
3413	L +^TMP($ J,"MSG"):D ILOCKTM I '$T D Q
3414	"RTN","RCC PCAR",9,0)
3415	. W 7,7 ,!,"Annual Payment E rror Repor t is alrea dy being r un or tran smitted."
3416	"RTN","RCC PCAR",10,0 )
3417	. W !,"Tr y again la ter."
3418	"RTN","RCC PCAR",11,0 )
3419	;
3420	"RTN","RCC PCAR",12,0 )
3421	K ^TMP($J ,"MSG")
3422	"RTN","RCC PCAR",13,0 )
3423	N STARTDT ,ENDDT,LIN E,DEBTOR,P ATSSN
3424	"RTN","RCC PCAR",14,0 )
3425	;
3426	"RTN","RCC PCAR",15,0 )
3427	; Initial ize YEAR t o current year if Nu ll
3428	"RTN","RCC PCAR",16,0 )
3429	I $G(YEAR )="" S YEA R=$E(DT,1, 3)
3430	"RTN","RCC PCAR",17,0 )
3431	;
3432	"RTN","RCC PCAR",18,0 )
3433	; Set Sta rt and End Dates
3434	"RTN","RCC PCAR",19,0 )
3435	S STARTDT =YEAR_"010 0"
3436	"RTN","RCC PCAR",20,0 )
3437	S ENDDT=Y EAR_1232
3438	"RTN","RCC PCAR",21,0 )
3439	S LINE=0
3440	"RTN","RCC PCAR",22,0 )
3441	S DEBTOR= ""
3442	"RTN","RCC PCAR",23,0 )
3443	F S DEBT OR=$O(^PRC A(433,"ATD ",DEBTOR)) Q:DEBTOR= "" D
3444	"RTN","RCC PCAR",24,0 )
3445	. ; Quit if the deb tor is not a patient
3446	"RTN","RCC PCAR",25,0 )
3447	. I '$D(^ RCD(340,"A B","DPT(", DEBTOR)) Q
3448	"RTN","RCC PCAR",26,0 )
3449	. N DATE, PATERROR,P HSET
3450	"RTN","RCC PCAR",27,0 )
3451	. S (PHSE T,PATERROR )=0
3452	"RTN","RCC PCAR",28,0 )
3453	. S DATE= STARTDT
3454	"RTN","RCC PCAR",29,0 )
3455	. F S DA TE=$O(^PRC A(433,"ATD ",DEBTOR,D ATE)) Q:DA TE="" Q:D ATE>ENDDT D
3456	"RTN","RCC PCAR",30,0 )
3457	.. ; Rech eck and Qu it if the date is no t within t he Year
3458	"RTN","RCC PCAR",31,0 )
3459	.. I DATE <STARTDT!( DATE>ENDDT ) Q
3460	"RTN","RCC PCAR",32,0 )
3461	.. ; Set Final Date for this Debtor to determine final tran saction
3462	"RTN","RCC PCAR",33,0 )
3463	.. N TRAN S
3464	"RTN","RCC PCAR",34,0 )
3465	.. S TRAN S=""
3466	"RTN","RCC PCAR",35,0 )
3467	.. F S T RANS=$O(^P RCA(433,"A TD",DEBTOR ,DATE,TRAN S)) Q:TRAN S="" D
3468	"RTN","RCC PCAR",36,0 )
3469	... ; Qui t if the T ransaction Type is n ot Payment in Part(2 ) or Payme nt in Ful
3470	l(34)
3471	"RTN","RCC PCAR",37,0 )
3472	... I $P( ^PRCA(433, TRANS,1),U ,2)'=2&($P (^PRCA(433 ,TRANS,1), U,2)'=34) Q
3473	"RTN","RCC PCAR",38,0 )
3474	... ; Che ck PH Reco rd if firs t time for this Debt or
3475	"RTN","RCC PCAR",39,0 )
3476	... I 'PH SET D CHEC KPH(DEBTOR ) S PHSET= 1
3477	"RTN","RCC PCAR",40,0 )
3478	... ; Che ck PD Reco rd for eac h Payment Transactio n
3479	"RTN","RCC PCAR",41,0 )
3480	... D CHE CKPD(DEBTO R,DATE,TRA NS)
3481	"RTN","RCC PCAR",42,0 )
3482	;
3483	"RTN","RCC PCAR",43,0 )
3484	; If ther e are any errors Sen d MailMan Message wi th Errors in ^TMP($J ,"MSG")
3485	"RTN","RCC PCAR",44,0 )
3486	I $D(^TMP ($J,"MSG") ) D TRANSM IT
3487	"RTN","RCC PCAR",45,0 )
3488	; If ther e are no e rrors Send MailMan M essage wit h No Error s Line
3489	"RTN","RCC PCAR",46,0 )
3490	I '$D(^TM P($J,"MSG" )) D
3491	"RTN","RCC PCAR",47,0 )
3492	. S ^TMP( $J,"MSG",1 ,0)="No an nual patie nt payment data inco nsistencie s found."
3493	"RTN","RCC PCAR",48,0 )
3494	. D TRANS MIT
3495	"RTN","RCC PCAR",49,0 )
3496	;
3497	"RTN","RCC PCAR",50,0 )
3498	K ^TMP($J ,"MSG")
3499	"RTN","RCC PCAR",51,0 )
3500	; PRCA4. 5313 - Un lock follo wing trans mission
3501	"RTN","RCC PCAR",52,0 )
3502	L -^TMP($ J,"MSG"):D ILOCKTM
3503	"RTN","RCC PCAR",53,0 )
3504	Q
3505	"RTN","RCC PCAR",54,0 )
3506	;
3507	"RTN","RCC PCAR",55,0 )
3508	CHECKPH(DE BTOR) ; C heck Data for PH Rec ord
3509	"RTN","RCC PCAR",56,0 )
3510	N SSN,PAT NAME,I,ARA DDR,ADDRER ,DFN,ICN,B ILLDATE,CO UNTRY,ST
3511	"RTN","RCC PCAR",57,0 )
3512	;
3513	"RTN","RCC PCAR",58,0 )
3514	; Get and Check DFN for Debto r. If DFN is Null o r does not start wit h a numbe
3515	r
3516	"RTN","RCC PCAR",59,0 )
3517	; write E rror with Debtor Num ber and th en Quit, a s other da ta is depe ndent upo
3518	n DFN
3519	"RTN","RCC PCAR",60,0 )
3520	S DFN=+$P (^RCD(340, DEBTOR,0), U)
3521	"RTN","RCC PCAR",61,0 )
3522	I 'DFN D SETERROR(" Debtor Num ber: "_DEB TOR,"Missi ng DFN") Q
3523	"RTN","RCC PCAR",62,0 )
3524	;
3525	"RTN","RCC PCAR",63,0 )
3526	; Get Pat ient Name and SSN
3527	"RTN","RCC PCAR",64,0 )
3528	S PATNAME =$$NAM^RCF N01(DEBTOR )
3529	"RTN","RCC PCAR",65,0 )
3530	S SSN=$$S SN^RCFN01( DEBTOR)
3531	"RTN","RCC PCAR",66,0 )
3532	S PATSSN= PATNAME_" LAST-4: " _$E(SSN,6, 9)
3533	"RTN","RCC PCAR",67,0 )
3534	;
3535	"RTN","RCC PCAR",68,0 )
3536	; Get and Check DFN and ICN f or Debtor and Patien t
3537	"RTN","RCC PCAR",69,0 )
3538	I $L(DFN) >8 D SETER ROR(PATSSN ,"Invalid DFN")
3539	"RTN","RCC PCAR",70,0 )
3540	S ICN=$$G ETICN^MPIF 001(DFN)
3541	"RTN","RCC PCAR",71,0 )
3542	I +ICN=-1 !($L(ICN)> 17) D SETE RROR(PATSS N,"Missing or Invali d ICN")
3543	"RTN","RCC PCAR",72,0 )
3544	;
3545	"RTN","RCC PCAR",73,0 )
3546	; Check P atient Nam e and SSN
3547	"RTN","RCC PCAR",74,0 )
3548	I SSN=""! (SSN'?9N) D SETERROR (PATSSN,"M issing or Invalid SS N")
3549	"RTN","RCC PCAR",75,0 )
3550	I $P(PATN AME,",")=" " D SETERR OR(PATSSN, "Missing o r Invalid Last Name" )
3551	"RTN","RCC PCAR",76,0 )
3552	I $P($P(P ATNAME,"," ,2)," ")=" " D SETERR OR(PATSSN, "Missing o r Invalid First Nam
3553	e")
3554	"RTN","RCC PCAR",77,0 )
3555	;
3556	"RTN","RCC PCAR",78,0 )
3557	; Get and Check Add ress
3558	"RTN","RCC PCAR",79,0 )
3559	S ARADDR= $P($$DADD^ RCAMADD(DE BTOR,1),U, 1,6)
3560	"RTN","RCC PCAR",80,0 )
3561	F I=1,4 I $P(ARADDR ,U,I)=""!( $L($P(ARAD DR,U,I))>4 0) D
3562	"RTN","RCC PCAR",81,0 )
3563	. S ADDRE R(I)=$S(I= 1:"Address Line 1",I =4:"City")
3564	"RTN","RCC PCAR",82,0 )
3565	. D SETER ROR(PATSSN ,"Missing or Invalid "_ADDRER( I))
3566	"RTN","RCC PCAR",83,0 )
3567	N ADDRER
3568	"RTN","RCC PCAR",84,0 )
3569	F I=2,3 I $L($P(ARA DDR,U,I))> 40 D
3570	"RTN","RCC PCAR",85,0 )
3571	. S ADDRE R(I)=$S(I= 2:"Address Line 2",I =3:"Addres s Line 3")
3572	"RTN","RCC PCAR",86,0 )
3573	. D SETER ROR(PATSSN ,"Invalid "_ADDRER(I ))
3574	"RTN","RCC PCAR",87,0 )
3575	;
3576	"RTN","RCC PCAR",88,0 )
3577	; If the Zip Code i s Null fro m DADD^RCM ADD set Pi ece 6 of A RADDR to P iece 6 of
3578	.11
3579	"RTN","RCC PCAR",89,0 )
3580	I $P(ARAD DR,U,6)="" S $P(ARAD DR,U,6)=$P ($G(^DPT(D FN,.11)),U ,6)
3581	"RTN","RCC PCAR",90,0 )
3582	;
3583	"RTN","RCC PCAR",91,0 )
3584	; If Coun try is not '1' get C ountry Nam e for use in validat ing the St ate and Z
3585	ip Code
3586	"RTN","RCC PCAR",92,0 )
3587	S COUNTRY =$P($G(^DP T(DFN,.11) ),U,10)
3588	"RTN","RCC PCAR",93,0 )
3589	S COUNTRY =$S(COUNTR Y=1:"",1:$ $GET1^DIQ( 779.004,CO UNTRY,"POS TAL NAME") )
3590	"RTN","RCC PCAR",94,0 )
3591	; If the Country Co de is Not Null and t he Postal Code is gr eater than 11 chara
3592	cters writ e error
3593	"RTN","RCC PCAR",95,0 )
3594	I COUNTRY '="",$L($P ($G(^DPT(D FN,.11)),U ,9))>11 D SETERROR(P ATSSN,"Inv alid Fore
3595	ign Postal Code")
3596	"RTN","RCC PCAR",96,0 )
3597	; State h as three E rror condi tions
3598	"RTN","RCC PCAR",97,0 )
3599	; If the State is N ot Null an d is not 2 character s
3600	"RTN","RCC PCAR",98,0 )
3601	; If the State is N ot Null an d is not a Valid US State
3602	"RTN","RCC PCAR",99,0 )
3603	; If the State is N ot Null an d the Coun try is Not Null
3604	"RTN","RCC PCAR",100, 0)
3605	; If the State is N ull and th e Country is Null
3606	"RTN","RCC PCAR",101, 0)
3607	I $P(ARAD DR,U,5)'=" ",$L($P(AR ADDR,U,5)) '=2 D SETE RROR(PATSS N,"Missing or Inval
3608	id State")
3609	"RTN","RCC PCAR",102, 0)
3610	S ST=$O(^ DIC(5,"C", $P(ARADDR, U,5),""))
3611	"RTN","RCC PCAR",103, 0)
3612	I $P(ARAD DR,U,5)'=" ",ST="" D SETERROR(P ATSSN,"Mis sing or In valid Stat e")
3613	"RTN","RCC PCAR",104, 0)
3614	I $P(ARAD DR,U,5)'=" ",ST'="",$ P(^DIC(5,S T,0),U,6)' =1 D SETER ROR(PATSSN ,"Missing
3615	or Invali d State")
3616	"RTN","RCC PCAR",105, 0)
3617	I $P(ARAD DR,U,5)'=" "&(COUNTRY '="") D SE TERROR(PAT SSN,"Missi ng or Inva lid State
3618	")
3619	"RTN","RCC PCAR",106, 0)
3620	I $P(ARAD DR,U,5)="" &(COUNTRY= "") D SETE RROR(PATSS N,"Missing or Invali d State")
3621	"RTN","RCC PCAR",107, 0)
3622	; Zip Cod e has thre e Error co nditions
3623	"RTN","RCC PCAR",108, 0)
3624	; If the Zip Code i s Not Null and is no t 5 to 9 N umerics
3625	"RTN","RCC PCAR",109, 0)
3626	; If the Zip Code i s Not Null and the C ountry is Not Null
3627	"RTN","RCC PCAR",110, 0)
3628	; If the Zip Code i s Null and the Count ry is Null
3629	"RTN","RCC PCAR",111, 0)
3630	I $P(ARAD DR,U,6)'=" "&($P(ARAD DR,U,6)'?5 .9N) D SET ERROR(PATS SN,"Missin g or Inva
3631	lid Zip Co de")
3632	"RTN","RCC PCAR",112, 0)
3633	I $P(ARAD DR,U,6)'=" "&(COUNTRY '="") D SE TERROR(PAT SSN,"Missi ng or Inva lid Zip C
3634	ode")
3635	"RTN","RCC PCAR",113, 0)
3636	I $P(ARAD DR,U,6)="" &(COUNTRY= "") D SETE RROR(PATSS N,"Missing or Invali d Zip Cod
3637	e")
3638	"RTN","RCC PCAR",114, 0)
3639	Q
3640	"RTN","RCC PCAR",115, 0)
3641	;
3642	"RTN","RCC PCAR",116, 0)
3643	CHECKPD(DE BTOR,DATE, TRANS) ; Get and Se t Data for PD Record into 349. 5
3644	"RTN","RCC PCAR",117, 0)
3645	N AMT
3646	"RTN","RCC PCAR",118, 0)
3647	; Get and Check Tra nsaction A mount
3648	"RTN","RCC PCAR",119, 0)
3649	S AMT=$P( ^PRCA(433, TRANS,1),U ,5)
3650	"RTN","RCC PCAR",120, 0)
3651	; Format Amount
3652	"RTN","RCC PCAR",121, 0)
3653	S AMT=$TR ($J(AMT,9, 2)," ","")
3654	"RTN","RCC PCAR",122, 0)
3655	S AMT=$P( AMT,".")_$ P(AMT,".", 2)
3656	"RTN","RCC PCAR",123, 0)
3657	I 'AMT!($ L(AMT)>10) D SETERRO R(PATSSN," Amount in Transactio n "_TRANS_ " Invalid
3658	")
3659	"RTN","RCC PCAR",124, 0)
3660	;
3661	"RTN","RCC PCAR",125, 0)
3662	; Get and Check Tra nsaction D ate
3663	"RTN","RCC PCAR",126, 0)
3664	I $P(DATE ,".")'?7N. N D SETERR OR(PATSSN, "Date for Transactio n "_TRANS_ " Invalid
3665	")
3666	"RTN","RCC PCAR",127, 0)
3667	Q
3668	"RTN","RCC PCAR",128, 0)
3669	;
3670	"RTN","RCC PCAR",129, 0)
3671	SETERROR(P ATSSN,ERRO R) ; Set the error into TMP($ J,"MSG",LI NE,0) for transmiss
3672	ion
3673	"RTN","RCC PCAR",130, 0)
3674	; If the first time thru for this patie nt set the Name and SSN in mes sage
3675	"RTN","RCC PCAR",131, 0)
3676	; with a blank line above the Patient D ata for sp acing
3677	"RTN","RCC PCAR",132, 0)
3678	I 'PATERR OR D
3679	"RTN","RCC PCAR",133, 0)
3680	. S LINE= LINE+1,^TM P($J,"MSG" ,LINE,0)=" "
3681	"RTN","RCC PCAR",134, 0)
3682	. S LINE= LINE+1,^TM P($J,"MSG" ,LINE,0)=P ATSSN
3683	"RTN","RCC PCAR",135, 0)
3684	. S PATER ROR=1
3685	"RTN","RCC PCAR",136, 0)
3686	; Write E rror to ne xt line wi th a doubl e space in front
3687	"RTN","RCC PCAR",137, 0)
3688	S LINE=LI NE+1 S ^TM P($J,"MSG" ,LINE,0)=" "_ERROR
3689	"RTN","RCC PCAR",138, 0)
3690	Q
3691	"RTN","RCC PCAR",139, 0)
3692	;
3693	"RTN","RCC PCAR",140, 0)
3694	TRANSMIT ; set up and send mail message - copied fr om RCCPCML
3695	"RTN","RCC PCAR",141, 0)
3696	N L,XMDUZ ,XMSUB,XMY ,XMZ,Z,ERR OR,NM,PSN, RTY
3697	"RTN","RCC PCAR",142, 0)
3698	S XMSUB=$ $SITE^RCMS ITE()_" AN NUAL PAYME NT ERROR R EPORT "_20 _$E(YEAR,2 ,3)_" TO
3699	CURRENT DA TE"
3700	"RTN","RCC PCAR",143, 0)
3701	S XMDUZ=" AR PACKAGE "
3702	"RTN","RCC PCAR",144, 0)
3703	I $O(^XMB (3.8,"B"," RCCPC STAT EMENTS","" )),$P($G(^ RC(342,1,0 )),U,12) S XMY("G.R
3704	CCPC STATE MENTS")=""
3705	"RTN","RCC PCAR",145, 0)
3706	S XMDUZ=" AR PACKAGE "
3707	"RTN","RCC PCAR",146, 0)
3708	D XMZ^XMA 2
3709	"RTN","RCC PCAR",147, 0)
3710	I XMZ<1 S RTY=RTY+1 G TRANSMI T:RTY<4 S ERROR=5,NM =0 D ERROR Q
3711	"RTN","RCC PCAR",148, 0)
3712	S (L,L(1) )=0 F S L (1)=$O(^TM P($J,"MSG" ,L(1))) Q: 'L(1) I $ D(^TMP($J, "MSG",L(1
3713	),0)) S L= L+1,^XMB(3 .9,+XMZ,2, L,0)=^TMP( $J,"MSG",L (1),0)
3714	"RTN","RCC PCAR",149, 0)
3715	S ^XMB(3. 9,XMZ,2,0) ="^3.92A^" _L_U_L_U_D T
3716	"RTN","RCC PCAR",150, 0)
3717	D ENT1^XM D
3718	"RTN","RCC PCAR",151, 0)
3719	D NOW^%DT C
3720	"RTN","RCC PCAR",152, 0)
3721	Q
3722	"RTN","RCC PCAR",153, 0)
3723	;
3724	"RTN","RCC PCAR",154, 0)
3725	ERROR ;ER ROR FILE - Copied fr om RCCPCML
3726	"RTN","RCC PCAR",155, 0)
3727	I NM=0 S ^TMP($J,"E RROR",ERRO R,NM)="" Q
3728	"RTN","RCC PCAR",156, 0)
3729	Q
3730	"RTN","RCC PCAR",157, 0)
3731	;
3732	"RTN","RCC PCAR",158, 0)
3733	MANBLD ; Build and Transmit t he Annual Payment St atement Co nsistency Checker
3734	"RTN","RCC PCAR",159, 0)
3735	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with warni ng.
3736	"RTN","RCC PCAR",160, 0)
3737	L +^TMP($ J,"MSG"):D ILOCKTM I '$T D Q
3738	"RTN","RCC PCAR",161, 0)
3739	. W 7,7 ,!,"Annual Payment E rror Repor t is alrea dy being r un or tran smitted."
3740	"RTN","RCC PCAR",162, 0)
3741	. W !,"Tr y again la ter."
3742	"RTN","RCC PCAR",163, 0)
3743	; PRCA4. 5313 - Un lock prior to prepar ing and tr ansmitting
3744	"RTN","RCC PCAR",164, 0)
3745	L -^TMP($ J,"MSG"):D ILOCKTM
3746	"RTN","RCC PCAR",165, 0)
3747	;
3748	"RTN","RCC PCAR",166, 0)
3749	N YEAR,DA TE,DIR,X,Z TIO,ZTRTN, ZTDESC,ZTD TH,ZTSK,QD T,%,%H
3750	"RTN","RCC PCAR",167, 0)
3751	S YEAR=20 _$E(DT,2,3 )
3752	"RTN","RCC PCAR",168, 0)
3753	S DIR(0)= "YAO"
3754	"RTN","RCC PCAR",169, 0)
3755	S DIR("B" )="N"
3756	"RTN","RCC PCAR",170, 0)
3757	S DIR("A" )="Do you want to Ru n and Tran smit the C onsistency Checker f or "_YEAR
3758	_" to the current da te? "
3759	"RTN","RCC PCAR",171, 0)
3760	S DIR("?? ")="^D MAN HLP^RCCPCA R"
3761	"RTN","RCC PCAR",172, 0)
3762	D ^DIR
3763	"RTN","RCC PCAR",173, 0)
3764	I $E(X)'= "Y" Q
3765	"RTN","RCC PCAR",174, 0)
3766	S ZTIO="" ,ZTRTN="EN ^RCCPCAR(" _$E(DT,1,3 )_")"
3767	"RTN","RCC PCAR",175, 0)
3768	S ZTDESC= "Annual Pa yment Stat ement File Consisten cy Checker "
3769	"RTN","RCC PCAR",176, 0)
3770	S ZTDTH=" " D ^%ZTLO AD Q:$G(ZT SK)=""
3771	"RTN","RCC PCAR",177, 0)
3772	S %H=ZTSK ("D") D YM D^%DTC S Q DT=X_%
3773	"RTN","RCC PCAR",178, 0)
3774	Q
3775	"RTN","RCC PCAR",179, 0)
3776	;
3777	"RTN","RCC PCAR",180, 0)
3778	MANHLP ; "??" Help for MANBLD
3779	"RTN","RCC PCAR",181, 0)
3780	W !,"Ente r 'N' or R eturn to Q uit. 'Y' t o Run and Transmit t he Consist ency Chec
3781	ker."
3782	"RTN","RCC PCAR",182, 0)
3783	Q
3784	"RTN","RCC PCAT")
3785	0^22^B3314 6754^n/a
3786	"RTN","RCC PCAT",1,0)
3787	RCCPCAT ;A LB/TGH - P ATCH PRCA* 4.5*ANNUAL PAYMENT T RANSMIT ; 2/3/2016 1 1:30 am
3788	"RTN","RCC PCAT",2,0)
3789	;;4.5;Acc ounts Rece ivable;3 13;Feb 2 0, 2017;Bu ild 113
3790	"RTN","RCC PCAT",3,0)
3791	;;Per VA Directive 6402, this routine s hould not be modifie d.
3792	"RTN","RCC PCAT",4,0)
3793	EN(DTTIME) ;Schedul e the Tran smit
3794	"RTN","RCC PCAT",5,0)
3795	N ZTDESC, ZTASK,ZTDT H,ZTIO,ZTR TN
3796	"RTN","RCC PCAT",6,0)
3797	S ZTIO="" ,ZTRTN="TR ANSMIT^RCC PCAT"
3798	"RTN","RCC PCAT",7,0)
3799	S ZTDESC= "ANNUAL PA YMENT STAT EMENT TRAN SMISSION"
3800	"RTN","RCC PCAT",8,0)
3801	; Initial ize Transm it date an d time
3802	"RTN","RCC PCAT",9,0)
3803	I DTTIME= "" S DTTIM E=%H
3804	"RTN","RCC PCAT",10,0 )
3805	S ZTDTH=D TTIME
3806	"RTN","RCC PCAT",11,0 )
3807	D ^%ZTLOA D Q:$G(ZTS K)=""
3808	"RTN","RCC PCAT",12,0 )
3809	Q
3810	"RTN","RCC PCAT",13,0 )
3811	;
3812	"RTN","RCC PCAT",14,0 )
3813	TRANSMIT ; Send Ann ual Paymen t Statemen t Files to AITC from RCAP(349. 5
3814	"RTN","RCC PCAT",15,0 )
3815	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with warni ng.
3816	"RTN","RCC PCAT",16,0 )
3817	L +^RCAP( 349.5):DIL OCKTM I '$ T W 7,7, !,"Annual Payment is already b eing run
3818	or transmi tted. Try again lat er." Q
3819	"RTN","RCC PCAT",17,0 )
3820	;
3821	"RTN","RCC PCAT",18,0 )
3822	K ^TMP($J ,"MSG")
3823	"RTN","RCC PCAT",19,0 )
3824	N PSCNTR, %,%I,%H,YE AR
3825	"RTN","RCC PCAT",20,0 )
3826	S YEAR=20 _$E($P(^RC AP(349.5,1 ,0),U,2),2 ,3)
3827	"RTN","RCC PCAT",21,0 )
3828	S PSCNTR= 0
3829	"RTN","RCC PCAT",22,0 )
3830	F S PSCN TR=$O(^RCA P(349.5,PS CNTR)) Q:P SCNTR="" Q:PSCNTR=" B" D
3831	"RTN","RCC PCAT",23,0 )
3832	. ; Set T ransmit St art Date a nd Time
3833	"RTN","RCC PCAT",24,0 )
3834	. D NOW^% DTC
3835	"RTN","RCC PCAT",25,0 )
3836	. S $P(^R CAP(349.5, PSCNTR,0), U,5)=%
3837	"RTN","RCC PCAT",26,0 )
3838	. ; Merge all PS el ements int o TMP MSG file
3839	"RTN","RCC PCAT",27,0 )
3840	. M ^TMP( $J,"MSG")= ^RCAP(349. 5,PSCNTR)
3841	"RTN","RCC PCAT",28,0 )
3842	. D MAIL
3843	"RTN","RCC PCAT",29,0 )
3844	. ; Set T ransmit En d Date and Time
3845	"RTN","RCC PCAT",30,0 )
3846	. D NOW^% DTC
3847	"RTN","RCC PCAT",31,0 )
3848	. S $P(^R CAP(349.5, PSCNTR,0), U,6)=%
3849	"RTN","RCC PCAT",32,0 )
3850	;
3851	"RTN","RCC PCAT",33,0 )
3852	; PRCA4. 5313 - Un lock prior to quit
3853	"RTN","RCC PCAT",34,0 )
3854	L -^RCAP( 349.5):DIL OCKTM
3855	"RTN","RCC PCAT",35,0 )
3856	Q
3857	"RTN","RCC PCAT",36,0 )
3858	;
3859	"RTN","RCC PCAT",37,0 )
3860	MAIL ;set up and sen d mail mes sage - cop ied from R CCPCML
3861	"RTN","RCC PCAT",38,0 )
3862	N L,XMDUZ ,XMSUB,XMY ,XMZ,Z,ERR OR,NM,PSN, RTY,X
3863	"RTN","RCC PCAT",39,0 )
3864	S XMSUB=$ $SITE^RCMS ITE()_" AN NUAL PAYME NT TRANSMI SSION "_YE AR
3865	"RTN","RCC PCAT",40,0 )
3866	S XMDUZ=" AR PACKAGE "
3867	"RTN","RCC PCAT",41,0 )
3868	I $O(^XMB (3.8,"B"," RCCPC STAT EMENTS","" )),$P($G(^ RC(342,1,0 )),U,12) S XMY("G.R
3869	CCPC STATE MENTS")=""
3870	"RTN","RCC PCAT",42,0 )
3871	S X=$O(^R CT(349.1," B","PY",0) )
3872	"RTN","RCC PCAT",43,0 )
3873	I X,$P($G (^RCT(349. 1,+X,0)),U ,3) S X=$P ($G(^RCT(3 49.1,+X,3) ),U)_"@"_$ P($G(^RCT
3874	(349.1,+X, 3)),U,3) S :$P(X,"@", 2)]"" XMY( X)=""
3875	"RTN","RCC PCAT",44,0 )
3876	I $P(X,"@ ",2)']"" D Q
3877	"RTN","RCC PCAT",45,0 )
3878	.S ERROR= 6,NM=0 D E RROR
3879	"RTN","RCC PCAT",46,0 )
3880	S XMDUZ=" AR PACKAGE "
3881	"RTN","RCC PCAT",47,0 )
3882	D XMZ^XMA 2
3883	"RTN","RCC PCAT",48,0 )
3884	I XMZ<1 S RTY=RTY+1 G MAIL:RT Y<4 S ERRO R=5,NM=0 D ERROR Q
3885	"RTN","RCC PCAT",49,0 )
3886	S (L,L(1) )=0 F S L (1)=$O(^TM P($J,"MSG" ,L(1))) Q: 'L(1) I $ D(^TMP($J, "MSG",L(1
3887	),0)) S L= L+1,^XMB(3 .9,+XMZ,2, L,0)=^TMP( $J,"MSG",L (1),0)
3888	"RTN","RCC PCAT",50,0 )
3889	S ^XMB(3. 9,XMZ,2,0) ="^3.92A^" _L_U_L_U_D T
3890	"RTN","RCC PCAT",51,0 )
3891	D ENT1^XM D
3892	"RTN","RCC PCAT",52,0 )
3893	D NOW^%DT C
3894	"RTN","RCC PCAT",53,0 )
3895	K ^TMP($J ,"MSG")
3896	"RTN","RCC PCAT",54,0 )
3897	Q
3898	"RTN","RCC PCAT",55,0 )
3899	;
3900	"RTN","RCC PCAT",56,0 )
3901	SCHED(SITE ) ; Deter mine the d ate and ti me for Tra nsmit base d upon Sit e Code an
3902	d table AI TC provide d
3903	"RTN","RCC PCAT",57,0 )
3904	; Time wi ll always be 2:00 AM
3905	"RTN","RCC PCAT",58,0 )
3906	I SITE>40 1&(SITE<52 0) S DTTIM E=$E(DT,1, 5)_"03.020 000" Q DTT IME
3907	"RTN","RCC PCAT",59,0 )
3908	I SITE>51 9&(SITE<54 1) S DTTIM E=$E(DT,1, 5)_"04.020 000" Q DTT IME
3909	"RTN","RCC PCAT",60,0 )
3910	I SITE>54 0&(SITE<55 9) S DTTIM E=$E(DT,1, 5)_"05.020 000" Q DTT IME
3911	"RTN","RCC PCAT",61,0 )
3912	I SITE>56 0&(SITE<58 1) S DTTIM E=$E(DT,1, 5)_"06.020 000" Q DTT IME
3913	"RTN","RCC PCAT",62,0 )
3914	I SITE>58 0&(SITE<59 9) S DTTIM E=$E(DT,1, 5)_"07.020 000" Q DTT IME
3915	"RTN","RCC PCAT",63,0 )
3916	I SITE>59 9&(SITE<62 0) S DTTIM E=$E(DT,1, 5)_"08.020 000" Q DTT IME
3917	"RTN","RCC PCAT",64,0 )
3918	I SITE>61 9&(SITE<64 1) S DTTIM E=$E(DT,1, 5)_"09.020 000" Q DTT IME
3919	"RTN","RCC PCAT",65,0 )
3920	I SITE>64 1&(SITE<65 8) S DTTIM E=$E(DT,1, 5)_"10.020 000" Q DTT IME
3921	"RTN","RCC PCAT",66,0 )
3922	I SITE>65 7&(SITE<67 5) S DTTIM E=$E(DT,1, 5)_"11.020 000" Q DTT IME
3923	"RTN","RCC PCAT",67,0 )
3924	I SITE>67 4&(SITE<75 8) S DTTIM E=$E(DT,1, 5)_"12.020 000" Q DTT IME
3925	"RTN","RCC PCAT",68,0 )
3926	S DTTIME= ""
3927	"RTN","RCC PCAT",69,0 )
3928	Q DTTIME
3929	"RTN","RCC PCAT",70,0 )
3930	;
3931	"RTN","RCC PCAT",71,0 )
3932	MANBLD ; Build and Transmit t he Annual Payment St atement af ter initia l yearly
3933	transmissi on
3934	"RTN","RCC PCAT",72,0 )
3935	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with warni ng.
3936	"RTN","RCC PCAT",73,0 )
3937	L +^RCAP( 349.5):DIL OCKTM I '$ T D MENUER R Q
3938	"RTN","RCC PCAT",74,0 )
3939	; PRCA4. 5313 - Un lock prior to transm itting
3940	"RTN","RCC PCAT",75,0 )
3941	L -^RCAP( 349.5):DIL OCKTM
3942	"RTN","RCC PCAT",76,0 )
3943	;
3944	"RTN","RCC PCAT",77,0 )
3945	N YEAR,DA TE,DIR,X,Z TIO,ZTRTN, ZTDESC,ZTD TH,ZTSK,QD T
3946	"RTN","RCC PCAT",78,0 )
3947	S YEAR=$P ($G(^RCAP( 349.5,1,0) ),U,2)
3948	"RTN","RCC PCAT",79,0 )
3949	S YEAR("E XT")=20_$E (YEAR,2,3)
3950	"RTN","RCC PCAT",80,0 )
3951	S DATE=$P ($G(^RCAP( 349.5,$P(^ RCAP(349.5 ,0),U,4),0 )),U,6)
3952	"RTN","RCC PCAT",81,0 )
3953	S DATE=$S (DATE'="": $$SLH^RCFN 01(DATE),1 :"")
3954	"RTN","RCC PCAT",82,0 )
3955	W !!,"The Annual Pa yment File for "_YEA R("EXT")_" was trans mitted on "_DATE_".
3956	"
3957	"RTN","RCC PCAT",83,0 )
3958	S DIR(0)= "YAO"
3959	"RTN","RCC PCAT",84,0 )
3960	S DIR("B" )="N"
3961	"RTN","RCC PCAT",85,0 )
3962	S DIR("A" )="Do you want to Bu ild and Tr ansmit the file for "_YEAR("EX T")_" aga
3963	in? "
3964	"RTN","RCC PCAT",86,0 )
3965	S DIR("?? ")="^D MAN HLP^RCCPCA T"
3966	"RTN","RCC PCAT",87,0 )
3967	D ^DIR
3968	"RTN","RCC PCAT",88,0 )
3969	I $E(X)'= "Y" Q
3970	"RTN","RCC PCAT",89,0 )
3971	W !!,">> PLEASE CON TACT CUSTO MER SUPPOR T BEFORE P ROCEEDING <<",!!
3972	"RTN","RCC PCAT",90,0 )
3973	S ZTIO="" ,ZTRTN="EN ^RCCPCAP(" _YEAR_","_ """F"""_", "_""""""_" )"
3974	"RTN","RCC PCAT",91,0 )
3975	S ZTDESC= "Build Ann ual Paymen t Statemen t File"
3976	"RTN","RCC PCAT",92,0 )
3977	S ZTDTH=" " D ^%ZTLO AD Q:$G(ZT SK)=""
3978	"RTN","RCC PCAT",93,0 )
3979	S %H=ZTSK ("D") D YM D^%DTC S Q DT=X_%
3980	"RTN","RCC PCAT",94,0 )
3981	Q
3982	"RTN","RCC PCAT",95,0 )
3983	;
3984	"RTN","RCC PCAT",96,0 )
3985	RETRANS ; Retransmi t the exis ting file and allow user to se lect date and time
3986	"RTN","RCC PCAT",97,0 )
3987	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with warni ng.
3988	"RTN","RCC PCAT",98,0 )
3989	L +^RCAP( 349.5):DIL OCKTM I '$ T D MENUER R Q
3990	"RTN","RCC PCAT",99,0 )
3991	; PRCA4. 5313 - Un lock prior to retran smitting
3992	"RTN","RCC PCAT",100, 0)
3993	L -^RCAP( 349.5):DIL OCKTM
3994	"RTN","RCC PCAT",101, 0)
3995	;
3996	"RTN","RCC PCAT",102, 0)
3997	N YEAR,DA TE,DIR,X,Z TIO,ZTRTN, ZTDESC,ZTD TH,ZTSK,QD T
3998	"RTN","RCC PCAT",103, 0)
3999	S YEAR=$P ($G(^RCAP( 349.5,1,0) ),U,2)
4000	"RTN","RCC PCAT",104, 0)
4001	S YEAR("E XT")=20_$E (YEAR,2,3)
4002	"RTN","RCC PCAT",105, 0)
4003	S DATE=$P ($G(^RCAP( 349.5,$P(^ RCAP(349.5 ,0),U,4),0 )),U,6)
4004	"RTN","RCC PCAT",106, 0)
4005	S DATE=$S (DATE'="": $$SLH^RCFN 01(DATE),1 :"")
4006	"RTN","RCC PCAT",107, 0)
4007	W !!,"The Annual Pa yment File for "_YEA R("EXT")_" was trans mitted on "_DATE_".
4008	"
4009	"RTN","RCC PCAT",108, 0)
4010	S DIR(0)= "YAO"
4011	"RTN","RCC PCAT",109, 0)
4012	S DIR("B" )="N"
4013	"RTN","RCC PCAT",110, 0)
4014	S DIR("A" )="Do you want to Re transmit t he existin g file for "_YEAR("E XT")_" ag
4015	ain? "
4016	"RTN","RCC PCAT",111, 0)
4017	S DIR("?? ")="^D RET HLP^RCCPCA T"
4018	"RTN","RCC PCAT",112, 0)
4019	D ^DIR
4020	"RTN","RCC PCAT",113, 0)
4021	I $E(X)'= "Y" Q
4022	"RTN","RCC PCAT",114, 0)
4023	W !!,">> PLEASE CON TACT CUSTO MER SUPPOR T BEFORE P ROCEEDING <<",!!
4024	"RTN","RCC PCAT",115, 0)
4025	S ZTIO="" ,ZTRTN="TR ANSMIT^RCC PCAT"
4026	"RTN","RCC PCAT",116, 0)
4027	S ZTDESC= "Retransmi t Annual P ayment Sta tement Fil e"
4028	"RTN","RCC PCAT",117, 0)
4029	S ZTDTH=" " D ^%ZTLO AD Q:$G(ZT SK)=""
4030	"RTN","RCC PCAT",118, 0)
4031	S %H=ZTSK ("D") D YM D^%DTC S Q DT=X_%
4032	"RTN","RCC PCAT",119, 0)
4033	Q
4034	"RTN","RCC PCAT",120, 0)
4035	;
4036	"RTN","RCC PCAT",121, 0)
4037	ERROR ;ER ROR FILE - Copied fr om RCCPCML
4038	"RTN","RCC PCAT",122, 0)
4039	I NM=0 S ^TMP($J,"E RROR",ERRO R,NM)="" Q
4040	"RTN","RCC PCAT",123, 0)
4041	Q
4042	"RTN","RCC PCAT",124, 0)
4043	;
4044	"RTN","RCC PCAT",125, 0)
4045	MENUERR ; Print err or to scre en if Annu al Payment File has not comple ted for t
4046	his year
4047	"RTN","RCC PCAT",126, 0)
4048	N YEAR
4049	"RTN","RCC PCAT",127, 0)
4050	S YEAR=20 _$E(DT,2,3 )-1
4051	"RTN","RCC PCAT",128, 0)
4052	W !!,"The Build and Transmit of the Ann ual Paymen t File for "_YEAR_" has not c
4053	ompleted."
4054	"RTN","RCC PCAT",129, 0)
4055	W !,"You may not us e this opt ion until it complet es.",!
4056	"RTN","RCC PCAT",130, 0)
4057	D PAUSE^V ALM1
4058	"RTN","RCC PCAT",131, 0)
4059	Q
4060	"RTN","RCC PCAT",132, 0)
4061	;
4062	"RTN","RCC PCAT",133, 0)
4063	MANHLP ; "??" Help for MANBLD and RETRA NS
4064	"RTN","RCC PCAT",134, 0)
4065	W !,"Ente r 'N' or R eturn to Q uit. 'Y' t o Build an d Retransm it file."
4066	"RTN","RCC PCAT",135, 0)
4067	Q
4068	"RTN","RCC PCAT",136, 0)
4069	;
4070	"RTN","RCC PCAT",137, 0)
4071	RETHLP ; "??" Help for MANBLD and RETRA NS
4072	"RTN","RCC PCAT",138, 0)
4073	W !,"Ente r 'N' or R eturn to Q uit. 'Y' t o Retransm it file."
4074	"RTN","RCC PCAT",139, 0)
4075	Q
4076	"RTN","RCC PCBJ")
4077	0^5^B94660 54^B628849 1
4078	"RTN","RCC PCBJ",1,0)
4079	RCCPCBJ ;W ASH-ISC@AL TOONA,PA/N YB-Backgro und Driver for CCPC ;1/7/97 9 :42 AM
4080	"RTN","RCC PCBJ",2,0)
4081	;;4.5;Acc ounts Rece ivable;3 4,76,130,1 53,166,195 ,217,237,3 07,313;M ar 20, 19
4082	95;Build 1 13
4083	"RTN","RCC PCBJ",3,0)
4084	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
4085	"RTN","RCC PCBJ",4,0)
4086	EN ;Starts the backg round job for CCPC 5 days befo re stateme nt day
4087	"RTN","RCC PCBJ",5,0)
4088	N X,X1,X2 ,X3,ZTRTN, ZTIO,ZTDTH ,ZTSK,ZTDE SC,SDT,RCF ULL
4089	"RTN","RCC PCBJ",6,0)
4090	;D ACK P RCA4.531 3 - Moved into OPEN
4091	"RTN","RCC PCBJ",7,0)
4092	D ;run t he cbs nig htly accou nt update program ev eryday
4093	"RTN","RCC PCBJ",8,0)
4094	.N ZTDESC ,ZTASK,ZTD TH,ZTIO,ZT RTN
4095	"RTN","RCC PCBJ",9,0)
4096	.S RCFULL= 0 ;do not send the f ull debtor list
4097	"RTN","RCC PCBJ",10,0 )
4098	.S ZTIO=" ",ZTRTN="D EBTOR^PRCA CPS1"
4099	"RTN","RCC PCBJ",11,0 )
4100	.S ZTDESC ="CBS NIGH TLY ACCOUN T UPDATE P ROGRAM",ZT DTH=$H
4101	"RTN","RCC PCBJ",12,0 )
4102	.D ^%ZTLO AD
4103	"RTN","RCC PCBJ",13,0 )
4104	;
4105	"RTN","RCC PCBJ",14,0 )
4106	I $$DOW^X LFDT(DT,1) =3 D ;run the cbs a uto-correc tion progr am on Wedn esdays
4107	"RTN","RCC PCBJ",15,0 )
4108	.N ZTDESC ,ZTASK,ZTD TH,ZTIO,ZT RTN
4109	"RTN","RCC PCBJ",16,0 )
4110	.S ZTIO=" ",ZTRTN="S TART^PRCAC PS",ZTSAVE ("RCFULL") =""
4111	"RTN","RCC PCBJ",17,0 )
4112	.S ZTDESC ="PATIENT STATEMENTS AUTO-CORR ECTION PRO GRAM",ZTDT H=$H
4113	"RTN","RCC PCBJ",18,0 )
4114	.D ^%ZTLO AD
4115	"RTN","RCC PCBJ",19,0 )
4116	;
4117	"RTN","RCC PCBJ",20,0 )
4118	; PRCA4. 5313 - Ru n the Annu al Payment Statement Build and Transmit
4119	"RTN","RCC PCBJ",21,0 )
4120	; on Janu ary 2nd of each year for the p revious ye ar
4121	"RTN","RCC PCBJ",22,0 )
4122	I $E(DT,4 ,7)="0102" D
4123	"RTN","RCC PCBJ",23,0 )
4124	. N ZTIO, ZTRTN,ZTDE SC,ZTDTH
4125	"RTN","RCC PCBJ",24,0 )
4126	. S ZTIO= "",ZTRTN=" EN^RCCPCAP ",ZTDTH=$H
4127	"RTN","RCC PCBJ",25,0 )
4128	. S ZTDES C="ANNUAL PAYMENT ST ATEMENT BU ILD AND TR ANSMIT"
4129	"RTN","RCC PCBJ",26,0 )
4130	. D ^%ZTL OAD
4131	"RTN","RCC PCBJ",27,0 )
4132	;
4133	"RTN","RCC PCBJ",28,0 )
4134	; PRCA4. 5313 - Ru n the Annu al Payment Error Rep ort on Mar ch, June, September
4135	and
4136	"RTN","RCC PCBJ",29,0 )
4137	; Decembe r 15th
4138	"RTN","RCC PCBJ",30,0 )
4139	I $E(DT,4 ,5)="03"!( $E(DT,4,5) ="06")!($E (DT,4,5)=" 09")!($E(D T,4,5)=12) D
4140	"RTN","RCC PCBJ",31,0 )
4141	. I $E(DT ,6,7)'=15 Q
4142	"RTN","RCC PCBJ",32,0 )
4143	. N ZTIO, ZTRTN,ZTDE SC,ZTDTH
4144	"RTN","RCC PCBJ",33,0 )
4145	. S ZTIO= "",ZTRTN=" EN^RCCPCAR ",ZTDTH=$H
4146	"RTN","RCC PCBJ",34,0 )
4147	. S ZTDES C="ANNUAL PAYMENT ER ROR REPORT "
4148	"RTN","RCC PCBJ",35,0 )
4149	. D ^%ZTL OAD
4150	"RTN","RCC PCBJ",36,0 )
4151	;
4152	"RTN","RCC PCBJ",37,0 )
4153	I DT'<$P( $G(^RC(342 ,1,30)),"^ ",1)&(DT'> $P($G(^RC( 342,1,30)) ,"^",2)) D ^RCEXINA
4154	D
4155	"RTN","RCC PCBJ",38,0 )
4156	;
4157	"RTN","RCC PCBJ",39,0 )
4158	; PRCA4. 5313 - Se t Statemen t Date to two days i n future a nd save fo r Job
4159	"RTN","RCC PCBJ",40,0 )
4160	S X1=DT,X 2=2 D C^%D TC S SDT=X
4161	"RTN","RCC PCBJ",41,0 )
4162	S ZTSAVE( "SDT")=SDT
4163	"RTN","RCC PCBJ",42,0 )
4164	S ZTIO="" ,ZTRTN="OP EN^RCCPCBJ ",ZTDESC=" CBSS PATIE NT STATEME NT"
4165	"RTN","RCC PCBJ",43,0 )
4166	S ZTDTH=$ H D ^%ZTLO AD
4167	"RTN","RCC PCBJ",44,0 )
4168	Q
4169	"RTN","RCC PCBJ",45,0 )
4170	OPEN ;Upda te Open st atus bills to Active or Cancel lation sta tus
4171	"RTN","RCC PCBJ",46,0 )
4172	N DAY,BN, DEBTOR,DA, DIE,DR,P,A MT,DATE
4173	"RTN","RCC PCBJ",47,0 )
4174	N ZTSAVE, ZTRTN,ZTDE SC,ZTASK,% ZIS,ZTDTH
4175	"RTN","RCC PCBJ",48,0 )
4176	; PRCA4. 5313 - Ch eck the ac knowledgem ent for pr evious mon th
4177	"RTN","RCC PCBJ",49,0 )
4178	D TRANCHK ^RCCPCSV1
4179	"RTN","RCC PCBJ",50,0 )
4180	; PRCA4. 5313 - Se t DATE and day of mo nth from S DT and pro cess that date's de
4181	btors
4182	"RTN","RCC PCBJ",51,0 )
4183	S DATE=SD T,DAY=+$E( SDT,6,7),D EBTOR=""
4184	"RTN","RCC PCBJ",52,0 )
4185	F S DEBT OR=$O(^RCD (340,"AC", DAY,DEBTOR )) Q:'DEBT OR D
4186	"RTN","RCC PCBJ",53,0 )
4187	.S BN=0 F S BN=$O( ^PRCA(430, "AS",DEBTO R,$O(^PRCA (430.3,"AC ",112,0)), BN)) Q:'B
4188	N D
4189	"RTN","RCC PCBJ",54,0 )
4190	..S AMT=0 F P=1:1:5 S AMT=$P( $G(^PRCA(4 30,+BN,7)) ,"^",P)+AM T
4191	"RTN","RCC PCBJ",55,0 )
4192	..I $P($G (^PRCA(430 ,+BN,0))," ^",2)=$O(^ PRCA(430.2 ,"AC",33,0 )),AMT Q
4193	"RTN","RCC PCBJ",56,0 )
4194	..S DIE=" ^PRCA(430, ",DA=+BN,D R="8////^S X="_$S(AM T:$O(^PRCA (430.3,"AC ",102,0))
4195	,1:$O(^PRC A(430.3,"A C",111,0)) ) D ^DIE K DA,DIE,DR
4196	"RTN","RCC PCBJ",57,0 )
4197	..Q
4198	"RTN","RCC PCBJ",58,0 )
4199	.Q
4200	"RTN","RCC PCBJ",59,0 )
4201	;
4202	"RTN","RCC PCBJ",60,0 )
4203	; update patient a ccounts wi th interes t and admi n
4204	"RTN","RCC PCBJ",61,0 )
4205	N RCLASDA T
4206	"RTN","RCC PCBJ",62,0 )
4207	S RCLASDA T=DATE
4208	"RTN","RCC PCBJ",63,0 )
4209	I DT>3010 101 D FIRS TPTY^RCBEC HGS
4210	"RTN","RCC PCBJ",64,0 )
4211	; PRCA4. 5313 - Ad ded SDT to process a nd send
4212	"RTN","RCC PCBJ",65,0 )
4213	D EN^RCCP CPS(SDT)
4214	"RTN","RCC PCBJ",66,0 )
4215	D REFUND
4216	"RTN","RCC PCBJ",67,0 )
4217	D EN^RCCP CML(SDT)
4218	"RTN","RCC PCBJ",68,0 )
4219	Q
4220	"RTN","RCC PCBJ",69,0 )
4221	;
4222	"RTN","RCC PCBJ",70,0 )
4223	;
4224	"RTN","RCC PCBJ",71,0 )
4225	REFUND ;Up date Open status PRE PAYMENT bi lls to REF UND REVIEW
4226	"RTN","RCC PCBJ",72,0 )
4227	; PRCA4. 5313 - Ch anged DAY to stateme nt date
4228	"RTN","RCC PCBJ",73,0 )
4229	S DEBTOR= 0,DAY=SDT
4230	"RTN","RCC PCBJ",74,0 )
4231	F S DEBT OR=$O(^RCD (340,"AC", DAY,DEBTOR )) Q:'DEBT OR D
4232	"RTN","RCC PCBJ",75,0 )
4233	.S BN=0 F S BN=$O( ^PRCA(430, "AS",DEBTO R,$O(^PRCA (430.3,"AC ",112,0)), BN)) Q:'B
4234	N D
4235	"RTN","RCC PCBJ",76,0 )
4236	..I $P($G (^PRCA(430 ,+BN,0))," ^",2)=$O(^ PRCA(430.2 ,"AC",33,0 )) S X=$$E N^PRCARFU
4237	(+BN)
4238	"RTN","RCC PCBJ",77,0 )
4239	..Q
4240	"RTN","RCC PCBJ",78,0 )
4241	.Q
4242	"RTN","RCC PCBJ",79,0 )
4243	Q
4244	"RTN","RCC PCBJ",80,0 )
4245	;
4246	"RTN","RCC PCBJ",81,0 )
4247	ACK ;CHECK FOR ACKNO WLEDGEMENT S PRCA4. 5313 - No longer us ed
4248	"RTN","RCC PCBJ",82,0 )
4249	N DEB,MSG ,NO,RCX,X, X1,X2
4250	"RTN","RCC PCBJ",83,0 )
4251	S X1=$$ST D^RCCPCFN, X2=DT D ^% DTC I X>3 D
4252	"RTN","RCC PCBJ",84,0 )
4253	. D TRANC HK^RCCPCSV 1
4254	"RTN","RCC PCBJ",85,0 )
4255	Q
4256	"RTN","RCC PCFN1")
4257	0^7^B68695 13^n/a
4258	"RTN","RCC PCFN1",1,0 )
4259	RCCPCFN1 ; ALB/TGH-Ad ditional F unction ca lls for CB SS ;12/31/ 96 9:27 A M
4260	"RTN","RCC PCFN1",2,0 )
4261	;;4.5;Acc ounts Rece ivable;3 13;Mar 3 1, 2016;Bu ild 113
4262	"RTN","RCC PCFN1",3,0 )
4263	;
4264	"RTN","RCC PCFN1",4,0 )
4265	ACSET(NAME ) ; Deter mine the d ay of the month for each new d ebtor to h ave their
4266	patient s tatement s ent
4267	"RTN","RCC PCFN1",5,0 )
4268	; by the site to CB SS for con solidation .
4269	"RTN","RCC PCFN1",6,0 )
4270	; Input: NAME = Pa tient's Na me
4271	"RTN","RCC PCFN1",7,0 )
4272	; Output: DAY/GROUP = day of month for patient st atement tr ansmission and grou
4273	p number
4274	"RTN","RCC PCFN1",8,0 )
4275	; 0 = if i nvalid fir st charact er of last name
4276	"RTN","RCC PCFN1",9,0 )
4277	;
4278	"RTN","RCC PCFN1",10, 0)
4279	N LTR,GRO UP,DAY,I
4280	"RTN","RCC PCFN1",11, 0)
4281	;
4282	"RTN","RCC PCFN1",12, 0)
4283	; Quit if the patie nt name is not cross -reference d in the P atient Fil e (#2) -
4284	return 0
4285	"RTN","RCC PCFN1",13, 0)
4286	Q:'$D(^DP T("B",NAME )) 0
4287	"RTN","RCC PCFN1",14, 0)
4288	;
4289	"RTN","RCC PCFN1",15, 0)
4290	F I=1,2 S LTR(I)=$E (NAME,I)
4291	"RTN","RCC PCFN1",16, 0)
4292	I "AB"[LT R(1) S GRO UP=1,DAY=$ $GRP1(.LTR ) Q DAY_" /"_GROUP
4293	"RTN","RCC PCFN1",17, 0)
4294	I "CD"[LT R(1) S GRO UP=2,DAY=$ $GRP2(.LTR ) Q DAY_" /"_GROUP
4295	"RTN","RCC PCFN1",18, 0)
4296	I "EFIQ"[ LTR(1) S G ROUP=3,DAY =$$GRP3(.L TR) Q DAY _"/"_GROUP
4297	"RTN","RCC PCFN1",19, 0)
4298	I "GH"[LT R(1) S GRO UP=4,DAY=$ $GRP4(.LTR ) Q DAY_" /"_GROUP
4299	"RTN","RCC PCFN1",20, 0)
4300	I "JK"[LT R(1) S GRO UP=5,DAY=$ $GRP5(.LTR ) Q DAY_" /"_GROUP
4301	"RTN","RCC PCFN1",21, 0)
4302	I "LO"[LT R(1) S GRO UP=6,DAY=$ $GRP6(.LTR ) Q DAY_" /"_GROUP
4303	"RTN","RCC PCFN1",22, 0)
4304	I "MN"[LT R(1) S GRO UP=7,DAY=$ $GRP7(.LTR ) Q DAY_" /"_GROUP
4305	"RTN","RCC PCFN1",23, 0)
4306	I "T"[LTR (1) S GROU P=8,DAY=$$ GRP8(.LTR) Q DAY_"/ "_GROUP
4307	"RTN","RCC PCFN1",24, 0)
4308	I "R"[LTR (1) S GROU P=9,DAY=$$ GRP9(.LTR) Q DAY_"/ "_GROUP
4309	"RTN","RCC PCFN1",25, 0)
4310	I "SV"[LT R(1) S GRO UP=10,DAY= $$GRP10(.L TR) Q DAY _"/"_GROUP
4311	"RTN","RCC PCFN1",26, 0)
4312	I "PUXYZ" [LTR(1) S GROUP=11,D AY=$$GRP11 (.LTR) Q DAY_"/"_GR OUP
4313	"RTN","RCC PCFN1",27, 0)
4314	I "W"[LTR (1) S GROU P=12,DAY=$ $GRP12(.LT R) Q DAY_ "/"_GROUP
4315	"RTN","RCC PCFN1",28, 0)
4316	;
4317	"RTN","RCC PCFN1",29, 0)
4318	Q 0
4319	"RTN","RCC PCFN1",30, 0)
4320	;
4321	"RTN","RCC PCFN1",31, 0)
4322	GRP1(LTR) ;AB
4323	"RTN","RCC PCFN1",32, 0)
4324	;
4325	"RTN","RCC PCFN1",33, 0)
4326	I LTR(1)= "A" S DAY= 1
4327	"RTN","RCC PCFN1",34, 0)
4328	I LTR(1)= "B" D
4329	"RTN","RCC PCFN1",35, 0)
4330	. I "AU"[ LTR(2) S D AY=1
4331	"RTN","RCC PCFN1",36, 0)
4332	. I "AU"' [LTR(2) S DAY=2
4333	"RTN","RCC PCFN1",37, 0)
4334	;
4335	"RTN","RCC PCFN1",38, 0)
4336	Q DAY
4337	"RTN","RCC PCFN1",39, 0)
4338	;
4339	"RTN","RCC PCFN1",40, 0)
4340	GRP2(LTR) ;CD
4341	"RTN","RCC PCFN1",41, 0)
4342	;
4343	"RTN","RCC PCFN1",42, 0)
4344	I LTR(1)= "D" S DAY= 4
4345	"RTN","RCC PCFN1",43, 0)
4346	I LTR(1)= "C" D
4347	"RTN","RCC PCFN1",44, 0)
4348	. I "IRU" [LTR(2) S DAY=4
4349	"RTN","RCC PCFN1",45, 0)
4350	. I "IRU" '[LTR(2) S DAY=6
4351	"RTN","RCC PCFN1",46, 0)
4352	;
4353	"RTN","RCC PCFN1",47, 0)
4354	Q DAY
4355	"RTN","RCC PCFN1",48, 0)
4356	;
4357	"RTN","RCC PCFN1",49, 0)
4358	GRP3(LTR) ;EFIQ
4359	"RTN","RCC PCFN1",50, 0)
4360	;
4361	"RTN","RCC PCFN1",51, 0)
4362	S DAY=7
4363	"RTN","RCC PCFN1",52, 0)
4364	;
4365	"RTN","RCC PCFN1",53, 0)
4366	Q DAY
4367	"RTN","RCC PCFN1",54, 0)
4368	;
4369	"RTN","RCC PCFN1",55, 0)
4370	GRP4(LTR) ;GH
4371	"RTN","RCC PCFN1",56, 0)
4372	;
4373	"RTN","RCC PCFN1",57, 0)
4374	I LTR(1)= "G" S DAY= 8
4375	"RTN","RCC PCFN1",58, 0)
4376	I LTR(1)= "H" D
4377	"RTN","RCC PCFN1",59, 0)
4378	. I "E"[L TR(2) S DA Y=8
4379	"RTN","RCC PCFN1",60, 0)
4380	. I "E"'[ LTR(2) S D AY=10
4381	"RTN","RCC PCFN1",61, 0)
4382	;
4383	"RTN","RCC PCFN1",62, 0)
4384	Q DAY
4385	"RTN","RCC PCFN1",63, 0)
4386	;
4387	"RTN","RCC PCFN1",64, 0)
4388	GRP5(LTR) ;JK
4389	"RTN","RCC PCFN1",65, 0)
4390	;
4391	"RTN","RCC PCFN1",66, 0)
4392	S DAY=12
4393	"RTN","RCC PCFN1",67, 0)
4394	;
4395	"RTN","RCC PCFN1",68, 0)
4396	Q DAY
4397	"RTN","RCC PCFN1",69, 0)
4398	;
4399	"RTN","RCC PCFN1",70, 0)
4400	GRP6(LTR) ;LO
4401	"RTN","RCC PCFN1",71, 0)
4402	;
4403	"RTN","RCC PCFN1",72, 0)
4404	S DAY=14
4405	"RTN","RCC PCFN1",73, 0)
4406	;
4407	"RTN","RCC PCFN1",74, 0)
4408	Q DAY
4409	"RTN","RCC PCFN1",75, 0)
4410	;
4411	"RTN","RCC PCFN1",76, 0)
4412	GRP7(LTR) ;MN
4413	"RTN","RCC PCFN1",77, 0)
4414	;
4415	"RTN","RCC PCFN1",78, 0)
4416	I LTR(1)= "N" S DAY= 17
4417	"RTN","RCC PCFN1",79, 0)
4418	I LTR(1)= "M" D
4419	"RTN","RCC PCFN1",80, 0)
4420	. I "CI"[ LTR(2) S D AY=17
4421	"RTN","RCC PCFN1",81, 0)
4422	. I "CI"' [LTR(2) S DAY=15
4423	"RTN","RCC PCFN1",82, 0)
4424	;
4425	"RTN","RCC PCFN1",83, 0)
4426	Q DAY
4427	"RTN","RCC PCFN1",84, 0)
4428	;
4429	"RTN","RCC PCFN1",85, 0)
4430	GRP8(LTR) ;T
4431	"RTN","RCC PCFN1",86, 0)
4432	;
4433	"RTN","RCC PCFN1",87, 0)
4434	I "ABCDE" [LTR(2) S DAY=19
4435	"RTN","RCC PCFN1",88, 0)
4436	I "FGH"[L TR(2) S DA Y=22
4437	"RTN","RCC PCFN1",89, 0)
4438	I "ABCDEF GH"'[LTR(2 ) S DAY=17
4439	"RTN","RCC PCFN1",90, 0)
4440	;
4441	"RTN","RCC PCFN1",91, 0)
4442	Q DAY
4443	"RTN","RCC PCFN1",92, 0)
4444	;
4445	"RTN","RCC PCFN1",93, 0)
4446	GRP9(LTR) ;R
4447	"RTN","RCC PCFN1",94, 0)
4448	;
4449	"RTN","RCC PCFN1",95, 0)
4450	S DAY=19
4451	"RTN","RCC PCFN1",96, 0)
4452	;
4453	"RTN","RCC PCFN1",97, 0)
4454	Q DAY
4455	"RTN","RCC PCFN1",98, 0)
4456	;
4457	"RTN","RCC PCFN1",99, 0)
4458	GRP10(LTR) ;SV
4459	"RTN","RCC PCFN1",100 ,0)
4460	;
4461	"RTN","RCC PCFN1",101 ,0)
4462	I LTR(1)= "V" S DAY= 22
4463	"RTN","RCC PCFN1",102 ,0)
4464	I LTR(1)= "S" D
4465	"RTN","RCC PCFN1",103 ,0)
4466	. I "CHIM "[LTR(2) S DAY=22
4467	"RTN","RCC PCFN1",104 ,0)
4468	. I "CHIM "'[LTR(2) S DAY=21
4469	"RTN","RCC PCFN1",105 ,0)
4470	;
4471	"RTN","RCC PCFN1",106 ,0)
4472	Q DAY
4473	"RTN","RCC PCFN1",107 ,0)
4474	;
4475	"RTN","RCC PCFN1",108 ,0)
4476	GRP11(LTR) ;PUXYZ
4477	"RTN","RCC PCFN1",109 ,0)
4478	;
4479	"RTN","RCC PCFN1",110 ,0)
4480	S DAY=24
4481	"RTN","RCC PCFN1",111 ,0)
4482	;
4483	"RTN","RCC PCFN1",112 ,0)
4484	Q DAY
4485	"RTN","RCC PCFN1",113 ,0)
4486	;
4487	"RTN","RCC PCFN1",114 ,0)
4488	GRP12(LTR) ;W
4489	"RTN","RCC PCFN1",115 ,0)
4490	;
4491	"RTN","RCC PCFN1",116 ,0)
4492	S DAY=26
4493	"RTN","RCC PCFN1",117 ,0)
4494	;
4495	"RTN","RCC PCFN1",118 ,0)
4496	Q DAY
4497	"RTN","RCC PCML")
4498	0^8^B65098 323^B47881 024
4499	"RTN","RCC PCML",1,0)
4500	RCCPCML ;W ASH-ISC@AL TOONA,PA/L DB-Send CC PC transmi ssion ;12/ 19/96 4:1 6 PM
4501	"RTN","RCC PCML",2,0)
4502	V ;;4.5;Ac counts Rec eivable;** 34,80,93,1 18,133,140 ,160,165,1 87,195,206 ,223,260,
4503	313**;Mar 20, 1995;B uild 113
4504	"RTN","RCC PCML",3,0)
4505	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
4506	"RTN","RCC PCML",4,0)
4507	TRAN ;call from RCCP C TRANSMIT option to interacti vely allow transmiss ion of CC
4508	PC mesages
4509	"RTN","RCC PCML",5,0)
4510	; PRCA4. 5313 - Re written to use Patie nt Stateme nt Date en try
4511	"RTN","RCC PCML",6,0)
4512	N %DT,DTO UT,SDT,X,Y ,ZTRTN,ZTS AVE,ZTDESC ,ZTIO,IEN
4513	"RTN","RCC PCML",7,0)
4514	I '$D(^XU SEC("RCCPC TRANSMIT" ,DUZ)) W * 7,*7,!,"Yo u do not h ave access to do th
4515	is." Q
4516	"RTN","RCC PCML",8,0)
4517	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with warni ng.
4518	"RTN","RCC PCML",9,0)
4519	L +^RCPS( 349.2):DIL OCKTM I '$ T W 7,7, !,"Another date is b eing run o r transmi
4520	tted. Try again lat er." Q
4521	"RTN","RCC PCML",10,0 )
4522	S %DT="AE XP"
4523	"RTN","RCC PCML",11,0 )
4524	S %DT("A" )="Enter s tatement d ate as it will appea r on these statement s: "
4525	"RTN","RCC PCML",12,0 )
4526	; PRCA4. 5313 - Ch anged to a llow for s eparate da tes for st atements b ased upon
4527	last name
4528	"RTN","RCC PCML",13,0 )
4529	D ^%DT Q: (X="^")!($ D(DTOUT))! (Y=-1)
4530	"RTN","RCC PCML",14,0 )
4531	S SDT=Y
4532	"RTN","RCC PCML",15,0 )
4533	; PRCA4. 5313 - Un lock prior to quitti ng
4534	"RTN","RCC PCML",16,0 )
4535	I '$D(^RC PS(349.2," STDT",SDT) ) W !,"The re is not a CCPC fil e for this date." L
4536	-^RCPS(34 9.2):DILOC KTM Q
4537	"RTN","RCC PCML",17,0 )
4538	; PRCA4. 5313 - Un lock prior to quitti ng
4539	"RTN","RCC PCML",18,0 )
4540	S IEN=$O( ^RCPS(349. 2,"STDT",S DT,0)) I ' $P($P($G(^ RCPS(349.2 ,IEN,0))," ^",10),".
4541	") D Q
4542	"RTN","RCC PCML",19,0 )
4543	. W !,"Yo ur CBSS st atement fi le (349.2) is corrup ted. Pleas e rebuild it."
4544	"RTN","RCC PCML",20,0 )
4545	. L -^RCP S(349.2):D ILOCKTM
4546	"RTN","RCC PCML",21,0 )
4547	; PRCA4. 5313 - Un lock prior to jobbin g off
4548	"RTN","RCC PCML",22,0 )
4549	L -^RCPS( 349.2):DIL OCKTM
4550	"RTN","RCC PCML",23,0 )
4551	; PRCA4. 5313 - Al lows for m ultiple st atement da tes
4552	"RTN","RCC PCML",24,0 )
4553	S ZTSAVE( "SDT")=SDT ,ZTRTN="RE TRAN^RCCPC ML",ZTIO=" ",ZTDESC=" Re-transmi t CBSS pa
4554	tient stat ements -us er activat ed"
4555	"RTN","RCC PCML",25,0 )
4556	D ^%ZTLOA D
4557	"RTN","RCC PCML",26,0 )
4558	Q
4559	"RTN","RCC PCML",27,0 )
4560	;
4561	"RTN","RCC PCML",28,0 )
4562	EN(SDT) ;c alled from backgroun d job - PR CA4.5313 Added SDT for backg round job
4563	call
4564	"RTN","RCC PCML",29,0 )
4565	N DA,DIK, LPRINT
4566	"RTN","RCC PCML",30,0 )
4567	D NOW^%DT C
4568	"RTN","RCC PCML",31,0 )
4569	RETRAN N D A,DIK,ERRO R,RCT,X,X1 ,DEB
4570	"RTN","RCC PCML",32,0 )
4571	; PRCA4. 5313 - Pr ovides err or for inc omplete bu ild of 349 .2
4572	"RTN","RCC PCML",33,0 )
4573	S (ERROR, X)=0 F S X=$O(^RCPS (349.2,"ST DT",SDT,X) ) Q:'X I $G(^RCPS(3 49.2,X,6)
4574	) S ERROR= 1,NM=0 D E RROR Q
4575	"RTN","RCC PCML",34,0 )
4576	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with Error .
4577	"RTN","RCC PCML",35,0 )
4578	L +^RCPS( 349.2):DIL OCKTM I '$ T S ERROR= 11,NM=0 D ERROR
4579	"RTN","RCC PCML",36,0 )
4580	I $G(ERRO R) D EXIT Q
4581	"RTN","RCC PCML",37,0 )
4582	K ^TMP($J )
4583	"RTN","RCC PCML",38,0 )
4584	; PRCA4. 5313 - Re moves exis ting 349 f or this da te
4585	"RTN","RCC PCML",39,0 )
4586	S X1=0 F S X1=$O(^ RCT(349,"S DT",+$E(SD T,6,7),X1) ) Q:X1="" I $P(^RCT (349,X1,0
4587	),U,2)="PS " S DA=X1, DIK="^RCT( 349," D ^D IK
4588	"RTN","RCC PCML",40,0 )
4589	F X="PA", "IS","IT" S RCT=$O(^ RCT(349.1, "B",X,0)) I RCT K ^R CT(349.1,+ RCT,4,+$E
4590	(SDT,6,7))
4591	"RTN","RCC PCML",41,0 )
4592	N %,ADD,A MT,ERROR,L ,LN,M,MSG, MCT,MPT1,M TOT,NM,P,P D,PD0,PSN, PT,PT0,PHC T,RCM,RTY
4593	,TAMT,TMSG ,SZ,TRDESC
4594	"RTN","RCC PCML",42,0 )
4595	D DT^DICR W
4596	"RTN","RCC PCML",43,0 )
4597	S (ERROR, RTY)=0
4598	"RTN","RCC PCML",44,0 )
4599	S X=$O(^R CT(349.1," B","PS",0) )
4600	"RTN","RCC PCML",45,0 )
4601	I X,$P($G (^RCT(349. 1,+X,0))," ^",3) S X= $P($G(^RCT (349.1,+X, 3)),"^",3)
4602	"RTN","RCC PCML",46,0 )
4603	I X']"" S ERROR=6,N M=0 D ERRO R,EXIT Q
4604	"RTN","RCC PCML",47,0 )
4605	D PHCT I 'PHCT S ER ROR=1,NM=0 D ERROR,E XIT Q
4606	"RTN","RCC PCML",48,0 )
4607	S MTOT=$O (^TMP($J," MCT",""),- 1)
4608	"RTN","RCC PCML",49,0 )
4609	; PRCA4. 5313 - Re set MTOT a nd MCT(1) for multip le dates o n one day
4610	"RTN","RCC PCML",50,0 )
4611	S MCT(1)= $O(^TMP($J ,"MCT","") )
4612	"RTN","RCC PCML",51,0 )
4613	S MTOT=MT OT-(MCT(1) -1)
4614	"RTN","RCC PCML",52,0 )
4615	S MCT(1)= 0
4616	"RTN","RCC PCML",53,0 )
4617	S MCT=0 F S MCT=$O (^TMP($J," MCT",MCT)) Q:'MCT D PS
4618	"RTN","RCC PCML",54,0 )
4619	EXIT D ERR ML^RCCPCML 1
4620	"RTN","RCC PCML",55,0 )
4621	K SDT,^TM P($J)
4622	"RTN","RCC PCML",56,0 )
4623	; PRCA4. 5313 - Un lock prior to exitin g
4624	"RTN","RCC PCML",57,0 )
4625	L -^RCPS( 349.2):DIL OCKTM
4626	"RTN","RCC PCML",58,0 )
4627	Q
4628	"RTN","RCC PCML",59,0 )
4629	;
4630	"RTN","RCC PCML",60,0 )
4631	F349 ;Get PS segment entry
4632	"RTN","RCC PCML",61,0 )
4633	N DA,D0,D IC,DLAYGO, X
4634	"RTN","RCC PCML",62,0 )
4635	S ERROR=0 K DD,DO S DIC="^RCT (349,",DIC (0)="L",DL AYGO=349,X ="PS."_$TR ($$FMTE^X
4636	LFDT(DT,"2 D"),"/",". ")_"."_RCM D FILE^DI CN
4637	"RTN","RCC PCML",63,0 )
4638	I Y<0 S R TY=RTY+1 G F349:RTY< 4 S ERROR= 2,NM=0 D E RROR Q
4639	"RTN","RCC PCML",64,0 )
4640	S PSN=+Y
4641	"RTN","RCC PCML",65,0 )
4642	Q
4643	"RTN","RCC PCML",66,0 )
4644	;
4645	"RTN","RCC PCML",67,0 )
4646	PS ;Build PS,PH,PD s egments an d messages
4647	"RTN","RCC PCML",68,0 )
4648	S PSN=$O( ^TMP($J,"M CT",MCT,0) )
4649	"RTN","RCC PCML",69,0 )
4650	; PRCA4. 5313 - In crement Co unter for internal s torage
4651	"RTN","RCC PCML",70,0 )
4652	S MCT(1)= MCT(1)+1
4653	"RTN","RCC PCML",71,0 )
4654	; PRCA4. 5313 - Up date to ne w formatti ng
4655	"RTN","RCC PCML",72,0 )
4656	S $P(^RCT (349,+PSN, 0),"^",3,1 0)=MCT(1)_ "^"_MTOT_" ^"_$$SITE^ RCMSITE()_ "^"_$$FP^
4657	RCCPCFN_"^ "_+^TMP($J ,"MCT",MCT )_"^"_$P(^ TMP($J,"MC T",MCT),"^ ",2)_"^"_$ $DAT^RCCP
4658	CFN(SDT)_" ^"_$$DAT^R CCPCFN(DT)
4659	"RTN","RCC PCML",73,0 )
4660	S LN=+PSN ,^TMP($J," MSG",LN)=$ P($G(^RCT( 349,+PSN,0 )),"^",2,1 0)_"^\|"
4661	"RTN","RCC PCML",74,0 )
4662	; Reforma t Statemen t Date to Internal F ormat
4663	"RTN","RCC PCML",75,0 )
4664	S $P(^RCT (349,+PSN, 0),"^",9)= SDT
4665	"RTN","RCC PCML",76,0 )
4666	S MPT1=$P (^TMP($J," MCT",MCT), "^",3)
4667	"RTN","RCC PCML",77,0 )
4668	; PRCA4. 5313 - Su btract num ber of rec ords from last recor d to find number be
4669	fore file starting p oint
4670	"RTN","RCC PCML",78,0 )
4671	S PT=MPT1 -$P(^TMP($ J,"MCT",MC T),"^",1)
4672	"RTN","RCC PCML",79,0 )
4673	F S PT=$ O(^RCPS(34 9.2,"STDT" ,SDT,PT)) Q:PT="" Q :PT=$O(^RC PS(349.2,+ ($P(^TMP(
4674	$J,"MCT",M CT),"^",3) ))) D
4675	"RTN","RCC PCML",80,0 )
4676	.Q:$D(^TM P($J,"ERRP T",+PT))
4677	"RTN","RCC PCML",81,0 )
4678	.S PT0=^R CPS(349.2, +PT,0)
4679	"RTN","RCC PCML",82,0 )
4680	. ; PRCA* 4.5*313 - Set DEB fr om PTO
4681	"RTN","RCC PCML",83,0 )
4682	. S DEB=$ P(PT0,"^")
4683	"RTN","RCC PCML",84,0 )
4684	.S LN=LN+ 1 S ^TMP($ J,"MSG",LN )="PH^"_$$ SITE^RCMSI TE_$$KEY^R CCPCFN(+PT )_"^"_$$N
4685	M^RCCPCFN( +PT)_"^"
4686	"RTN","RCC PCML",85,0 )
4687	.S ADD=$G (^RCPS(349 .2,+PT,1))
4688	"RTN","RCC PCML",86,0 )
4689	.;
4690	"RTN","RCC PCML",87,0 )
4691	.;Remove special ch aracters c ausing pro blems (WIM -0402-2072 8)
4692	"RTN","RCC PCML",88,0 )
4693	.I ADD["~ " S ADD=$T R(ADD,"~", "") ;Remov e tilde
4694	"RTN","RCC PCML",89,0 )
4695	.I ADD["\| " S ADD=$T R(ADD,"\|", "") ;Remov e the pipe symbol
4696	"RTN","RCC PCML",90,0 )
4697	.;
4698	"RTN","RCC PCML",91,0 )
4699	.;Debtor needs larg e print (f ont) IF LP RINT=1
4700	"RTN","RCC PCML",92,0 )
4701	.S LPRINT =$G(^RCPS( 349.2,+PT, 7)) S:LPRI NT="" LPRI NT=0
4702	"RTN","RCC PCML",93,0 )
4703	.;
4704	"RTN","RCC PCML",94,0 )
4705	.F P=1:1: 7 S $P(^TM P($J,"MSG" ,LN),"^",P +5)=$S($P( ADD,"^",P) ]"":$P(ADD ,"^",P),1
4706	:"")
4707	"RTN","RCC PCML",95,0 )
4708	.S ^TMP($ J,"MSG",LN )=^TMP($J, "MSG",LN)_ "^"
4709	"RTN","RCC PCML",96,0 )
4710	.S LN=LN+ 1
4711	"RTN","RCC PCML",97,0 )
4712	.F X=4:1: 8 S $P(AMT ,"^",X-3)= $$HEX^RCCP CFN($P(PT0 ,"^",X))
4713	"RTN","RCC PCML",98,0 )
4714	.S ^TMP($ J,"MSG",LN )=AMT_"^"_ $G(^RCPS(3 49.2,+PT,3 ))_"^"_$G( ^RCPS(349. 2,+PT,4))
4715	_"^"_$O(^R CPS(349.2, +PT,2,""), -1)
4716	"RTN","RCC PCML",99,0 )
4717	.S LN=LN+ 1 I $P($G( ^RCD(340,+ DEB,0)),"; ") S ^TMP( $J,"MSG",L N)="^"_$$S ITE^RCMSI
4718	TE_$$RJ^XL FSTR($TR($ P(^RCD(340 ,+DEB,0)," ;"),".","" ),13,0)
4719	"RTN","RCC PCML",100, 0)
4720	.; PRCA5 .4313 - S et ICN wit h Checksum , AR Flag, and Date of Latest Bill ino
4721	PH data
4722	"RTN","RCC PCML",101, 0)
4723	.N PT8 S PT8=$G(^RC PS(349.2,+ PT,8))
4724	"RTN","RCC PCML",102, 0)
4725	.S ^TMP($ J,"MSG",LN )=$G(^TMP( $J,"MSG",L N))_"^"_LP RINT_"^"_$ P(PT8,"^") _"V"_$P(P
4726	T8,"^",2,3 )_"^"_$$DA T^RCCPCFN( $P(PT8,"^" ,4))_"^\|"
4727	"RTN","RCC PCML",103, 0)
4728	.S $P(^RC PS(349.2,+ PT,0),"^", 11)=+PSN
4729	"RTN","RCC PCML",104, 0)
4730	.S PD=0 F S PD=$O( ^RCPS(349. 2,+PT,2,PD )) Q:'PD I $D(^(PD, 0)) S PD0= ^(0) D
4731	"RTN","RCC PCML",105, 0)
4732	..S AMT(0 )=$$HEX^RC CPCFN($P(P D0,"^",3))
4733	"RTN","RCC PCML",106, 0)
4734	..;Replac e special characters causing p roblem (PR CA*260)
4735	"RTN","RCC PCML",107, 0)
4736	..S TRDES C=$P(PD0," ^",2)
4737	"RTN","RCC PCML",108, 0)
4738	..I TRDES C["~" S TR DESC=$TR(T RDESC,"~", " ") ;Rep lace tilde
4739	"RTN","RCC PCML",109, 0)
4740	..I TRDES C["\|" S TR DESC=$TR(T RDESC,"\|", " ") ;Rep lace the p ipe symbol
4741	"RTN","RCC PCML",110, 0)
4742	..S LN=LN +1,^TMP($J ,"MSG",LN) ="PD^"_$$D AT^RCCPCFN (+PD0)_"^" _TRDESC_"^ "_AMT(0)_
4743	"^"_$P(PD0 ,"^",4)_"^ \|"
4744	"RTN","RCC PCML",111, 0)
4745	S LN=LN+1 ,^TMP($J," MSG",LN)=" ~"
4746	"RTN","RCC PCML",112, 0)
4747	; PRCA4. 5313 - Se t all cros s-referenc es for Fil e
4748	"RTN","RCC PCML",113, 0)
4749	S DA=+PSN ,DIK="^RCT (349," D I X1^DIK
4750	"RTN","RCC PCML",114, 0)
4751	;
4752	"RTN","RCC PCML",115, 0)
4753	MAIL ;set up mail me ssage
4754	"RTN","RCC PCML",116, 0)
4755	N L,XMDUZ ,XMSUB,XMY ,XMZ,Z
4756	"RTN","RCC PCML",117, 0)
4757	S XMSUB=$ $SITE^RCMS ITE()_" CB SS TRANSMI SSION "_SD T
4758	"RTN","RCC PCML",118, 0)
4759	S XMDUZ=" AR PACKAGE "
4760	"RTN","RCC PCML",119, 0)
4761	I $O(^XMB (3.8,"B"," RCCPC STAT EMENTS","" )),$P($G(^ RC(342,1,0 )),"^",12) S XMY("G
4762	.RCCPC STA TEMENTS")= ""
4763	"RTN","RCC PCML",120, 0)
4764	S X=$O(^R CT(349.1," B","PS",0) )
4765	"RTN","RCC PCML",121, 0)
4766	I X,$P($G( ^RCT(349.1 ,+X,0)),"^ ",3) S X=$ P($G(^RCT( 349.1,+X,3 )),"^")_"@ "_$P($G(
4767	^RCT(349.1 ,+X,3)),"^ ",3) S:$P( X,"@",2)]" " XMY(X)=" "
4768	"RTN","RCC PCML",122, 0)
4769	I $P(X,"@ ",2)']"" D Q
4770	"RTN","RCC PCML",123, 0)
4771	.S ERROR= 6,NM=0 D E RROR
4772	"RTN","RCC PCML",124, 0)
4773	S XMDUZ=" AR PACKAGE "
4774	"RTN","RCC PCML",125, 0)
4775	D XMZ^XMA 2
4776	"RTN","RCC PCML",126, 0)
4777	I XMZ<1 S RTY=RTY+1 G MAIL:RT Y<4 S ERRO R=5,NM=0 D ERROR Q
4778	"RTN","RCC PCML",127, 0)
4779	S $P(^RCT (349,+PSN, 0),"^",11, 12)=DT_"^" _XMZ
4780	"RTN","RCC PCML",128, 0)
4781	S (L,L(1) )=0 F S L (1)=$O(^TM P($J,"MSG" ,L(1))) Q: 'L(1) S L =L+1,^XMB( 3.9,+XMZ,
4782	2,L,0)=^TM P($J,"MSG" ,L(1))
4783	"RTN","RCC PCML",129, 0)
4784	S ^XMB(3. 9,XMZ,2,0) ="^3.92A^" _L_"^"_L_" ^"_DT
4785	"RTN","RCC PCML",130, 0)
4786	D ENT1^XM D
4787	"RTN","RCC PCML",131, 0)
4788	D NOW^%DT C
4789	"RTN","RCC PCML",132, 0)
4790	S $P(^RCT (349,+PSN, 0),"^",11, 12)=%_"^"_ XMZ
4791	"RTN","RCC PCML",133, 0)
4792	K ^TMP($J ,"MSG")
4793	"RTN","RCC PCML",134, 0)
4794	Q
4795	"RTN","RCC PCML",135, 0)
4796	;
4797	"RTN","RCC PCML",136, 0)
4798	PHCT ;PH c ount
4799	"RTN","RCC PCML",137, 0)
4800	S (ERROR, PT,PHCT,TA MT,SZ)=0,R CM=1
4801	"RTN","RCC PCML",138, 0)
4802	; PRCA4. 5313 - If last reco rd is for this date reset RCM to next va lue
4803	"RTN","RCC PCML",139, 0)
4804	N FINAL
4805	"RTN","RCC PCML",140, 0)
4806	S FINAL=$ O(^RCT(349 ,"@"),-1)
4807	"RTN","RCC PCML",141, 0)
4808	I FINAL,$ P($P(^RCT( 349,FINAL, 0),"^"),". ",2,4)=$TR ($$FMTE^XL FDT(DT,"2D "),"/",".
4809	") S RCM=$ P($P(^RCT( 349,FINAL, 0),"^"),". ",5)+1
4810	"RTN","RCC PCML",142, 0)
4811	F S PT=$ O(^RCPS(34 9.2,"STDT" ,SDT,PT)) Q:'PT S E RROR=0 D I ERROR,(E RROR<3) Q
4812	"RTN","RCC PCML",143, 0)
4813	. ; PRCA* 4.5*313 - Set DEB to Debtor nu mber
4814	"RTN","RCC PCML",144, 0)
4815	. S DEB=$ P(^RCPS(34 9.2,PT,0), "^")
4816	"RTN","RCC PCML",145, 0)
4817	.S SZ(1)= 0 D ERRCHK Q:ERROR
4818	"RTN","RCC PCML",146, 0)
4819	.S PT0=^R CPS(349.2, +PT,0)
4820	"RTN","RCC PCML",147, 0)
4821	.S PHCT=P HCT+1
4822	"RTN","RCC PCML",148, 0)
4823	.S SZ=550 +SZ,SZ(1)= 550
4824	"RTN","RCC PCML",149, 0)
4825	.S:$G(^RC PS(349.2,+ PT,1))]"" SZ=SZ+$L(^ (1)),SZ(1) =SZ(1)+$L( ^(1))
4826	"RTN","RCC PCML",150, 0)
4827	.S:$G(^RC PS(349.2,+ PT,3))]"" SZ=SZ+$L(^ (3))+1,SZ( 1)=SZ(1)+$ L(^(3))+1
4828	"RTN","RCC PCML",151, 0)
4829	.S:$G(^RC PS(349.2,+ PT,4))]"" SZ=SZ+$L(^ (4))+1,SZ( 1)=SZ(1)+$ L(^(4))+1
4830	"RTN","RCC PCML",152, 0)
4831	.S X=0 F S X=$O(^R CPS(349.2, +PT,2,X)) Q:'X I $D (^(X,0)) S SZ=$L(^(0 ))+SZ,SZ(
4832	1)=SZ(1)+$ L(^(0))
4833	"RTN","RCC PCML",153, 0)
4834	.S TAMT=T AMT+$P(^RC PS(349.2,+ PT,0),"^", 8)
4835	"RTN","RCC PCML",154, 0)
4836	.I SZ>270 00 D
4837	"RTN","RCC PCML",155, 0)
4838	..S RTY=0 D F349 Q: ERROR
4839	"RTN","RCC PCML",156, 0)
4840	..S TAMT= TAMT-$P(PT 0,"^",8)
4841	"RTN","RCC PCML",157, 0)
4842	..S TAMT= $$HEX^RCCP CFN(TAMT)
4843	"RTN","RCC PCML",158, 0)
4844	..S ^TMP( $J,"MCT",R CM)=(PHCT- 1)_"^"_TAM T_"^"_$O(^ RCPS(349.2 ,"STDT",SD T,PT),-1)
4845	_"^"_(SZ-S Z(1))
4846	"RTN","RCC PCML",159, 0)
4847	..S ^TMP( $J,"MCT",R CM,+PSN)=" "
4848	"RTN","RCC PCML",160, 0)
4849	..S RCM=R CM+1,PHCT= 1
4850	"RTN","RCC PCML",161, 0)
4851	..S SZ=SZ (1)
4852	"RTN","RCC PCML",162, 0)
4853	..S TAMT= $P(PT0,"^" ,8)
4854	"RTN","RCC PCML",163, 0)
4855	I 'PT,$O( ^RCPS(349. 2,"STDT",S DT,0)) D
4856	"RTN","RCC PCML",164, 0)
4857	.S RTY=0 D F349 Q:E RROR S ^T MP($J,"MCT ",RCM)=PHC T_"^"_$$HE X^RCCPCFN( TAMT)_"^"
4858	_$O(^RCPS( 349.2,"STD T",SDT,PT) ,-1)
4859	"RTN","RCC PCML",165, 0)
4860	.S ^TMP($ J,"MCT",RC M,+PSN)=""
4861	"RTN","RCC PCML",166, 0)
4862	Q
4863	"RTN","RCC PCML",167, 0)
4864	;
4865	"RTN","RCC PCML",168, 0)
4866	ERROR ;ERR OR FILE
4867	"RTN","RCC PCML",169, 0)
4868	I NM=0 S ^TMP($J,"E RROR",ERRO R,NM)="" Q
4869	"RTN","RCC PCML",170, 0)
4870	S ^TMP($J ,"ERROR",E RROR,NM,$$ SSN^RCFN01 (+DEB))=""
4871	"RTN","RCC PCML",171, 0)
4872	Q
4873	"RTN","RCC PCML",172, 0)
4874	;
4875	"RTN","RCC PCML",173, 0)
4876	ERRCHK ;Er ror check
4877	"RTN","RCC PCML",174, 0)
4878	I '$D(^RC PS(349.2,+ PT,0)) S E RROR=1,NM= 0 D ERROR Q
4879	"RTN","RCC PCML",175, 0)
4880	S PT(1)=P T,PT=$O(^R CPS(349.2, "STDT",SDT ,0)) I '$P (^RCPS(349 .2,PT,0)," ^",18) S
4881	ERROR=1,NM =0 D ERROR S PT=PT(1 ) Q
4882	"RTN","RCC PCML",176, 0)
4883	S PT=PT(1 )
4884	"RTN","RCC PCML",177, 0)
4885	I $$KEY^R CCPCFN(+PT )']"" S ER ROR=4,NM=$ $NAM^RCFN0 1(+DEB) D ERROR S ^T MP($J,"ER
4886	RPT",+PT)= "" Q
4887	"RTN","RCC PCML",178, 0)
4888	I '$D(^RC PS(349.2," AKEY",$$KE Y^RCCPCFN( +PT))) S E RROR=4,NM= $$NAM^RCFN 01(+DEB)
4889	D ERROR S ^TMP($J,"E RRPT",+PT) ="" Q
4890	"RTN","RCC PCML",179, 0)
4891	S ADD=$G( ^RCPS(349. 2,+PT,1))
4892	"RTN","RCC PCML",180, 0)
4893	F P=1:1:7 S ADD(P)= $S($P(ADD, "^",P)]"": $P(ADD,"^" ,P),1:"")
4894	"RTN","RCC PCML",181, 0)
4895	I ADD(1)= "",ADD(2)= "",ADD(3)= "",ADD(4)= "",ADD(5)= "",ADD(6)= "" S ERROR =8,NM=$$N
4896	AM^RCFN01( +DEB) D ER ROR S ^TMP ($J,"ERRPT ",+PT)="" Q
4897	"RTN","RCC PCML",182, 0)
4898	I ADD(1)= "",(ADD(2) =""),(ADD( 3)=""),(AD D(6)="") S ERROR=8,N M=$$NAM^RC FN01(+DEB
4899	) D ERROR S ^TMP($J, "ERRPT",+P T)="" Q
4900	"RTN","RCC PCML",183, 0)
4901	I ADD(4)= ""!(ADD(5) ="")!(ADD( 6)="") S E RROR=8,NM= $$NAM^RCFN 01(+DEB) D ERROR S
4902	^TMP($J,"E RRPT",+PT) =""
4903	"RTN","RCC PCML",184, 0)
4904	F ADD=1:1 :6 I ADD(A DD)'?.ANP S ERROR=10 ,NM=$$NAM^ RCFN01(+DE B),^TMP($J ,"ERRPT",
4905	+PT)="" D ERROR Q
4906	"RTN","RCC PCML",185, 0)
4907	I $P($G(^ RCD(340,+D EB,1)),"^" ,9) S ^TMP ($J,"ERRPT ",+PT)="", ERROR=9,NM =$$NAM^RC
4908	FN01(+DEB) D ERROR
4909	"RTN","RCC PCML",186, 0)
4910	Q
4911	"RTN","RCC PCML1")
4912	0^13^B8787 618^B66823 35
4913	"RTN","RCC PCML1",1,0 )
4914	RCCPCML1 ; ALB@ALTOON A,PA/LDB - Send CCPC transmiss ion (cont. );8/25/00 4:16 PM
4915	"RTN","RCC PCML1",2,0 )
4916	V ;;4.5;Ac counts Rec eivable; 160,313; Mar 20, 19 95;Build 1 13
4917	"RTN","RCC PCML1",3,0 )
4918	;
4919	"RTN","RCC PCML1",4,0 )
4920	ERRML ;ERR OR MESSAGE S
4921	"RTN","RCC PCML1",5,0 )
4922	N CT,ERRO R,LN,PT,SP ,XMDUZ,XMT EXT,XMSUB, XMY
4923	"RTN","RCC PCML1",6,0 )
4924	K ^TMP($J ,"ERRMSG")
4925	"RTN","RCC PCML1",7,0 )
4926	S (ERROR, LN)=0 F S ERROR=$O( ^TMP($J,"E RROR",ERRO R)) Q:'ERR OR D
4927	"RTN","RCC PCML1",8,0 )
4928	. ; PRCA* 4.5*313 - Add header identifyi ng the Sta tement Dat e
4929	"RTN","RCC PCML1",9,0 )
4930	. I LN=0 S LN=LN+1 D
4931	"RTN","RCC PCML1",10, 0)
4932	. . N Y
4933	"RTN","RCC PCML1",11, 0)
4934	. . S Y=S DT X ^DD(" DD")
4935	"RTN","RCC PCML1",12, 0)
4936	. . S ^TM P($J,"ERRM SG",LN)="E RRORS FOR PATIENT ST ATEMENT DA TE: "_Y
4937	"RTN","RCC PCML1",13, 0)
4938	.S LN=LN+ 1 S ^TMP($ J,"ERRMSG" ,LN)=" "
4939	"RTN","RCC PCML1",14, 0)
4940	.S LN=LN+ 1 S ^TMP($ J,"ERRMSG" ,LN)=$P($T (ERRMSG+ER ROR),";;", 2)
4941	"RTN","RCC PCML1",15, 0)
4942	.S LN=LN+ 1 S ^TMP($ J,"ERRMSG" ,LN)=" "
4943	"RTN","RCC PCML1",16, 0)
4944	.S CT=0,P T="" F S PT=$O(^TMP ($J,"ERROR ",ERROR,PT )) Q:PT="" D
4945	"RTN","RCC PCML1",17, 0)
4946	..S CT=CT +1,LN=LN+1
4947	"RTN","RCC PCML1",18, 0)
4948	..I PT=0 S ^TMP($J, "ERRMSG",L N)=" " Q
4949	"RTN","RCC PCML1",19, 0)
4950	..N Y I P T'=0 D
4951	"RTN","RCC PCML1",20, 0)
4952	...S PT(1 )="" F S PT(1)=$O(^ TMP($J,"ER ROR",ERROR ,PT,PT(1)) ) Q:PT(1)= "" D
4953	"RTN","RCC PCML1",21, 0)
4954	....S ^TM P($J,"ERRM SG",LN)=$S ($L(CT)<2: " "_CT,1:C T)_". "
4955	"RTN","RCC PCML1",22, 0)
4956	....S SP= " ",Y=PT,Y= PT_$E(SP,$ L(PT),30)
4957	"RTN","RCC PCML1",23, 0)
4958	....S ^TM P($J,"ERRM SG",LN)=^T MP($J,"ERR MSG",LN)_Y _PT(1)
4959	"RTN","RCC PCML1",24, 0)
4960	S XMDUZ=" AR PACKAGE "
4961	"RTN","RCC PCML1",25, 0)
4962	I $O(^XMB (3.8,"B"," RCCPC STAT EMENTS",0) ) S XMY("G .RCCPC STA TEMENTS")= ""
4963	"RTN","RCC PCML1",26, 0)
4964	E S XMY( $G(DUZ))=" "
4965	"RTN","RCC PCML1",27, 0)
4966	; PRCA4. 5313 - Ch ange CCPC to CBSS an d add Stat ement Date
4967	"RTN","RCC PCML1",28, 0)
4968	N Y S Y=S DT D DD^%D T S SDT=Y
4969	"RTN","RCC PCML1",29, 0)
4970	S XMSUB=" CBSS ERROR S FOUND DU RING TRANS MISSION"
4971	"RTN","RCC PCML1",30, 0)
4972	S XMTEXT= "^TMP($J," "ERRMSG"", "
4973	"RTN","RCC PCML1",31, 0)
4974	D ^XMD
4975	"RTN","RCC PCML1",32, 0)
4976	K ^TMP($J ,"ERRMSG")
4977	"RTN","RCC PCML1",33, 0)
4978	Q
4979	"RTN","RCC PCML1",34, 0)
4980	;
4981	"RTN","RCC PCML1",35, 0)
4982	ERRMSG ;E rror messa ges PRCA 4.5313 - Change CC PC to CBSS
4983	"RTN","RCC PCML1",36, 0)
4984	1 ;;CBSS t ransmissio n process found no r ecords or an incompl ete file. Contact I
4985	RM.
4986	"RTN","RCC PCML1",37, 0)
4987	2 ;;No CBS S transmis sion recor ds transmi tted. Chec k file 349 . Contact IRM.
4988	"RTN","RCC PCML1",38, 0)
4989	3 ;;Corrup ted PH seg ment has b een encoun tered for the follow ing patien t(s):
4990	"RTN","RCC PCML1",39, 0)
4991	4 ;;No key field in CBSS file for the fo llowing pa tient(s):
4992	"RTN","RCC PCML1",40, 0)
4993	5 ;;Mailma n message creation a borted. Pl ease conta ct IRM.
4994	"RTN","RCC PCML1",41, 0)
4995	6 ;;No tra nsmission sent. Defi ne REMOTE DOMAIN in AR TRANSMI SSION TYPE file (34
4996	9.1).
4997	"RTN","RCC PCML1",42, 0)
4998	7 ;;Print Acknowledg ements exi st. Transm ission can not be res ent.
4999	"RTN","RCC PCML1",43, 0)
5000	8 ;;Addres s informat ion is mis sing for t he followi ng patient (s):
5001	"RTN","RCC PCML1",44, 0)
5002	9 ;;Addres s is marke d as ADDRE SS UNKNOWN for the f ollowing p atient(s):
5003	"RTN","RCC PCML1",45, 0)
5004	10 ;;Corru pted Addre ss. Re-ent er address informati on for the following patient(
5005	s):
5006	"RTN","RCC PCML1",46, 0)
5007	11 ;;File did not bu ild or tra nsmit due to another build or transmissi on runnin
5008	g.
5009	"RTN","RCC PCPS")
5010	0^10^B1262 92904^B808 98915
5011	"RTN","RCC PCPS",1,0)
5012	RCCPCPS ;W ASH-ISC@AL TOONA,PA/N YB-Build P atient Sta tement Fil e ;12/19/9 6 4:14 P
5013	M
5014	"RTN","RCC PCPS",2,0)
5015	;;4.5;Acc ounts Rece ivable;**3 4,70,80,48 ,104,116,1 49,170,181 ,190,223,2 37,219,26
5016	5,301,313* *;Mar 20,1 995;Build 113
5017	"RTN","RCC PCPS",3,0)
5018	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
5019	"RTN","RCC PCPS",4,0)
5020	EN(SDT) ; PRCA4.5 313 - For use when c alled by B ackground Job
5021	"RTN","RCC PCPS",5,0)
5022	;
5023	"RTN","RCC PCPS",6,0)
5024	EN1 ;FOR U SE WHEN BU ILDING PS FILE (SDT MUST BE AV AILABLE AS A LOCAL V ARIABLE)
5025	"RTN","RCC PCPS",7,0)
5026	N CCPC,CN T,DAT,DEB, DIK,END,IN ADFL,LDT1, LDT3,PCC,P RN,RCDATE, RCT,SVADM, SVAMT,SVI
5027	NT,SVOTH,S ITE,TXT,VA R,X,%,REP, ERROR,NM
5028	"RTN","RCC PCPS",8,0)
5029	N RCINFUL L,RCINPART S COMM=0
5030	"RTN","RCC PCPS",9,0)
5031	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with warni ng.
5032	"RTN","RCC PCPS",10,0 )
5033	L +^RCPS( 349.2):DIL OCKTM I '$ T D Q
5034	"RTN","RCC PCPS",11,0 )
5035	. D NOW^% DTC S Y=% D DD^%DT
5036	"RTN","RCC PCPS",12,0 )
5037	. W Y W ! !,"Another date is b eing run o r transmit ted. Try again late r."
5038	"RTN","RCC PCPS",13,0 )
5039	. S ERROR =11,NM=0 D ERROR^RCC PCML,ERRML ^RCCPCML1
5040	"RTN","RCC PCPS",14,0 )
5041	; PRCA4. 5313 - Cl ear data f or date be ing create d
5042	"RTN","RCC PCPS",15,0 )
5043	D KILL^RC CPCPS1(SDT )
5044	"RTN","RCC PCPS",16,0 )
5045	; PRCA4. 5313 - Se t date to a month ag o and kill data for that date
5046	"RTN","RCC PCPS",17,0 )
5047	N OLDDT
5048	"RTN","RCC PCPS",18,0 )
5049	S OLDDT=$ $MONTHAGO^ RCCPCPS1(S DT)
5050	"RTN","RCC PCPS",19,0 )
5051	; PRCA4. 5313 - Mo ved to KIL L^RCCPCPS1
5052	"RTN","RCC PCPS",20,0 )
5053	D KILL^RC CPCPS1(OLD DT)
5054	"RTN","RCC PCPS",21,0 )
5055	;
5056	"RTN","RCC PCPS",22,0 )
5057	D DT^DICR W,SITE^PRC AGU
5058	"RTN","RCC PCPS",23,0 )
5059	I '$D(SIT E) W !!,"A R SITE PAR AMETER ENT RIES NOT D EFINED!",? 50 D Q
5060	"RTN","RCC PCPS",24,0 )
5061	. D NOW^% DTC S Y=% D DD^%DT W Y
5062	"RTN","RCC PCPS",25,0 )
5063	. W !!,"C OULD NOT P ROCESS AR PATIENT ST ATEMENTS"
5064	"RTN","RCC PCPS",26,0 )
5065	. ; PRCA* 4.5*313 - Unlock pri or to exit ing
5066	"RTN","RCC PCPS",27,0 )
5067	. L -^RCP S(349.2):D ILOCKTM
5068	"RTN","RCC PCPS",28,0 )
5069	;
5070	"RTN","RCC PCPS",29,0 )
5071	; PRCA4. 5313 - Cl ear ICN Er ror tempor ary storag e
5072	"RTN","RCC PCPS",30,0 )
5073	K ^TMP("I CNERROR",$ J)
5074	"RTN","RCC PCPS",31,0 )
5075	D NOW^%DT C S END=%
5076	"RTN","RCC PCPS",32,0 )
5077	S LDT1=$$ FPS^RCAMFN 01(DT,-1), RCDATE=DT
5078	"RTN","RCC PCPS",33,0 )
5079	S (CNT,DE B)=0,PRN=1
5080	"RTN","RCC PCPS",34,0 )
5081	F S DEB= $O(^RCD(34 0,"AC",+$E (SDT,6,7), DEB)) Q:DE B="" I $D (^RCD(340, "AB","DPT
5082	(",DEB)) D
5083	"RTN","RCC PCPS",35,0 )
5084	. N AMT ,BBAL,BEG, BN,CAT,DES C,ETY,FC,N D,PAT,PBAL ,PC,PSIEN
5085	"RTN","RCC PCPS",36,0 )
5086	. N PDA T,PEND,ST, SVINT,SVAD M,SVOTH,AD DR,ARFLAG, DIC
5087	"RTN","RCC PCPS",37,0 )
5088	. I $L( +$$SSN^RCF N01(DEB))< 5 Q
5089	"RTN","RCC PCPS",38,0 )
5090	. ;Chec k for Emer gency Resp onse Indic ator (ERI) Flag.
5091	"RTN","RCC PCPS",39,0 )
5092	. N RCD FN S RCDFN =+($P($G(^ RCD(340,DE B,0)),"^", 1)) I $$EM ERES^PRCAU TL(RCDFN)
5093	]"" Q
5094	"RTN","RCC PCPS",40,0 )
5095	. ; ini tialize va riables fo r CS - PRC A4.5301
5096	"RTN","RCC PCPS",41,0 )
5097	. N CSB B,CSTCH,CS TPC,CSPREV S (CSBB,C STCH,CSTPC )=0
5098	"RTN","RCC PCPS",42,0 )
5099	. ; PRC A^4.5*313 - If ICN i s null set to send e rror email
5100	"RTN","RCC PCPS",43,0 )
5101	. I $P( $$GETICN^M PIF001(RCD FN),U)=-1 S ^TMP("IC NERROR",$J ,RCDFN)="" Q
5102	"RTN","RCC PCPS",44,0 )
5103	. I $$F LBPD1="" Q
5104	"RTN","RCC PCPS",45,0 )
5105	. I $P( ^PRCA(430, $$FLBPD1,0 ),U,10)="" Q
5106	"RTN","RCC PCPS",46,0 )
5107	. S INA DFL=0
5108	"RTN","RCC PCPS",47,0 )
5109	. S (SV ADM,SVAMT, SVINT,SVOT H)=0
5110	"RTN","RCC PCPS",48,0 )
5111	. N REF ,SBAL,TBAL ,TN,TTY,X, Y
5112	"RTN","RCC PCPS",49,0 )
5113	. K ^TM P("PRCAGT" ,$J)
5114	"RTN","RCC PCPS",50,0 )
5115	. S BEG =+$$LST^RC FN01(DEB,2 )
5116	"RTN","RCC PCPS",51,0 )
5117	. S LDT 3=$S(BEG>0 :$$FPS^RCA MFN01($P(B EG,"."),-3 ),1:0)
5118	"RTN","RCC PCPS",52,0 )
5119	. I $P( BEG,".")'< $P(RCDATE, ".") Q
5120	"RTN","RCC PCPS",53,0 )
5121	. D NOW ^%DTC S EN D=%
5122	"RTN","RCC PCPS",54,0 )
5123	. I BEG <1 S PDAT= "",BEG=0,P BAL=0
5124	"RTN","RCC PCPS",55,0 )
5125	. I BEG S PDAT=BE G,BEG=9999 999.999999 -BEG,PBAL= 0 D PBAL^P RCAGU(DEB, .BEG,.PBA
5126	L) ;get pr ev bal
5127	"RTN","RCC PCPS",56,0 )
5128	. D EN^ PRCAGT(DEB ,BEG,.END)
5129	"RTN","RCC PCPS",57,0 )
5130	. S TBA L=0 D TBAL ^PRCAGT(DE B,.TBAL) ; get trans bal
5131	"RTN","RCC PCPS",58,0 )
5132	. S BBA L=0 D BBAL ^PRCAGU(DE B,.BBAL) ; get bill b al
5133	"RTN","RCC PCPS",59,0 )
5134	. ; ent ire accoun t has been referred to CS - PR CA4.5301
5135	"RTN","RCC PCPS",60,0 )
5136	. I CSB B,CSBB'<BB AL Q
5137	"RTN","RCC PCPS",61,0 )
5138	. S X=$ $PRE^PRCAG U(DEB) S P END=$P(X,U ,2),X=+X I X,BBAL D REF^PRCAGD (DEB,X,$G
5139	(REP)) Q
5140	"RTN","RCC PCPS",62,0 )
5141	. I BBA L=0,PEND,- PEND=PBAL+ TBAL Q
5142	"RTN","RCC PCPS",63,0 )
5143	. I BBA L'=(PBAL+T BAL) D EN^ PRCAGD(DEB ,BBAL,TBAL ,PBAL,BEG, $G(REP)) Q
5144	"RTN","RCC PCPS",64,0 )
5145	. I BBA L'>0,'$D(^ TMP("PRCAG T",$J,DEB) ) Q
5146	"RTN","RCC PCPS",65,0 )
5147	. I BBA L=0,$G(SIT E("ZERO")) Q
5148	"RTN","RCC PCPS",66,0 )
5149	. I BBA L<0,BBAL>- .99 Q
5150	"RTN","RCC PCPS",67,0 )
5151	. I BBA L'<0,'$D(^ XTMP("PRCA GU",$J,DEB )),'COMM Q ;third l etter prin ted,not c
5152	omment
5153	"RTN","RCC PCPS",68,0 )
5154	. S TBA L=TBAL+PBA L
5155	"RTN","RCC PCPS",69,0 )
5156	. ;adju st amounts to be fil ed in 349. 2 for CS b ills - PRC A4.5301
5157	"RTN","RCC PCPS",70,0 )
5158	. S TBA L=TBAL-CSB B ; reduce the total bill bala nce by CS balance
5159	"RTN","RCC PCPS",71,0 )
5160	. S CSP REV=CSBB-( CSTCH+CSTP C) ; compu te the CS previous b alance as the diffe
5161	rence betw een the bi ll balance and the t ransaction balance
5162	"RTN","RCC PCPS",72,0 )
5163	. S PBA L=PBAL-CSP REV ; redu ce the pre vious bala nce by the CS previo us balanc
5164	e
5165	"RTN","RCC PCPS",73,0 )
5166	. S TBA L("CH")=TB AL("CH")-C STCH ; red uce total charges by CS charge s
5167	"RTN","RCC PCPS",74,0 )
5168	. S TBA L("PC")=TB AL("PC")-C STPC ; red uce total credits by CS credit s
5169	"RTN","RCC PCPS",75,0 )
5170	. ;
5171	"RTN","RCC PCPS",76,0 )
5172	. I '$D (^RCPS(349 .2,0)) S ^ (0)="AR CB SS STATEME NTS^349.2I ^"
5173	"RTN","RCC PCPS",77,0 )
5174	. S DIC ="^RCPS(34 9.2,",X=DE B,DA=.01,D IC(0)="" D FILE^DICN
5175	"RTN","RCC PCPS",78,0 )
5176	. S PSI EN=+Y
5177	"RTN","RCC PCPS",79,0 )
5178	. S ^RC PS(349.2,P SIEN,0)=DE B_"^"_$$SS N^RCFN01(D EB)_"^"
5179	"RTN","RCC PCPS",80,0 )
5180	. S ADD R=$$DADD^R CAMADD(DEB ,1) ;get p atient's a ddress, co nfidential if appli
5181	cable
5182	"RTN","RCC PCPS",81,0 )
5183	. S ARF LAG="N" N X
5184	"RTN","RCC PCPS",82,0 )
5185	. S X=$ P($G(^RCD( 340,DEB,1) ),U,1,6) I ($P(X,U)' =""),($P(X ,U,4)'="") ,($P(X,U,
5186	5)'=""),(( $P(X,U,6)' ="")) S AR FLAG="Y"
5187	"RTN","RCC PCPS",83,0 )
5188	. S ^RC PS(349.2,P SIEN,1)=$P (ADDR,"^", 1,6)
5189	"RTN","RCC PCPS",84,0 )
5190	. S ST= $P(ADDR,"^ ",5)
5191	"RTN","RCC PCPS",85,0 )
5192	. S ^RC PS(349.2,P SIEN,7)=$P (^RCD(340, DEB,0),U,7 ) ;large p rint
5193	"RTN","RCC PCPS",86,0 )
5194	. ; PRC A4.5313 - Add four new eleme nts for CB SS
5195	"RTN","RCC PCPS",87,0 )
5196	. S $P( ^RCPS(349. 2,PSIEN,8) ,U)=$P($$G ETICN^MPIF 001(RCDFN) ,"V")
5197	"RTN","RCC PCPS",88,0 )
5198	. S $P( ^RCPS(349. 2,PSIEN,8) ,U,2)=$P($ $GETICN^MP IF001(RCDF N),"V",2)
5199	"RTN","RCC PCPS",89,0 )
5200	. S $P( ^RCPS(349. 2,PSIEN,8) ,U,3)=ARFL AG
5201	"RTN","RCC PCPS",90,0 )
5202	. S $P( ^RCPS(349. 2,PSIEN,8) ,U,4)=""
5203	"RTN","RCC PCPS",91,0 )
5204	. N FLB PD1 S FLBP D1=$$FLBPD 1 I FLBPD1 S $P(^RCP S(349.2,PS IEN,8),U,4 )=$P(^PRC
5205	A(430,FLBP D1,0),U,10 )
5206	"RTN","RCC PCPS",92,0 )
5207	. I $G( ST)'="" S ST=$O(^DIC (5,"C",ST, 0))
5208	"RTN","RCC PCPS",93,0 )
5209	. I $G( ST)>90,'$P ($G(^DIC(5 ,ST,0)),"^ ",6) S FC= $P($G(^DIC (5,ST,0)), "^")
5210	"RTN","RCC PCPS",94,0 )
5211	. S $P( ^RCPS(349. 2,PSIEN,1) ,"^",7)=$G (FC) S:$G( FC)]"" $P( ^RCPS(349. 2,PSIEN,1
5212	),"^",5)=" FX"
5213	"RTN","RCC PCPS",95,0 )
5214	. S:$G( FC)]"" $P( ^RCPS(349. 2,PSIEN,1) ,"^",6)=$P (ADDR,"^", 8)
5215	"RTN","RCC PCPS",96,0 )
5216	. D NOW ^%DTC S $P (^RCPS(349 .2,PSIEN,0 ),"^",10)= %
5217	"RTN","RCC PCPS",97,0 )
5218	. S $P( ^RCPS(349. 2,PSIEN,0) ,"^",3)=$$ NAM^RCFN01 (DEB)
5219	"RTN","RCC PCPS",98,0 )
5220	. S $P( ^RCPS(349. 2,PSIEN,0) ,"^",4,7)= $S(TBAL'>0 :0,1:TBAL) _"^"_PBAL_ "^"_TBAL(
5221	"CH")_"^"_ TBAL("PC") ,$P(^(0)," ^",8)=PBAL +TBAL("CH" )+TBAL("PC ")+TBAL("R F")
5222	"RTN","RCC PCPS",99,0 )
5223	. S $P( ^RCPS(349. 2,PSIEN,0) ,"^",13,17 )=BBAL("PB ")_"^"_BBA L("INT")_" ^"_BBAL("
5224	ADM")_"^"_ BBAL("MF") _"^"_BBAL( "CT")
5225	"RTN","RCC PCPS",100, 0)
5226	. ;
5227	"RTN","RCC PCPS",101, 0)
5228	. N RCB ILLDA,RCDA TA1,RCDEBT DA,RCDESC, RCPSDA,RCT OTAL,RCTRA NDA,RCTRDA TE,VALUE,
5229	RCCOM1,RCC OM2,RCCOM3
5230	"RTN","RCC PCPS",102, 0)
5231	. S RCD EBTDA=DEB
5232	"RTN","RCC PCPS",103, 0)
5233	. I '$D (^RCPS(349 .2,PSIEN,2 ,0)) S ^(0 )="^349.21 DA^^"
5234	"RTN","RCC PCPS",104, 0)
5235	. ;
5236	"RTN","RCC PCPS",105, 0)
5237	. S RCC OM1=$E($TR ($G(SITE(" COM1")),"~ \|^",""),1, 80),(RCCOM 2,RCCOM3)= ""
5238	"RTN","RCC PCPS",106, 0)
5239	. ; Add second co mment line for the G MT-reduced status
5240	"RTN","RCC PCPS",107, 0)
5241	. I $$G MT^PRCAGST (RCDEBTDA) S RCCOM2= "REDUCTION OF INPATI ENT COPAYM ENT DUE T
5242	O GEOGRAPH IC MEANS T EST STATUS "
5243	"RTN","RCC PCPS",108, 0)
5244	. I TBA L'>0 S RCC OM3=" THI S IS NOT A BILL"
5245	"RTN","RCC PCPS",109, 0)
5246	. I RCC OM1'="",RC COM2'="" S $E(RCCOM1 ,80)=" " ; Make sure GMT messag e will be
5247	printed o n separate line.
5248	"RTN","RCC PCPS",110, 0)
5249	. S ^RC PS(349.2,P SIEN,3)=RC COM1_RCCOM 2_RCCOM3
5250	"RTN","RCC PCPS",111, 0)
5251	. ;
5252	"RTN","RCC PCPS",112, 0)
5253	. S RCP SDA=0 ; th is variabl e used to set the de scription on the PS segment
5254	"RTN","RCC PCPS",113, 0)
5255	. S RCT RDATE=0 F S RCTRDAT E=$O(^TMP( "PRCAGT",$ J,RCDEBTDA ,RCTRDATE) ) Q:'RCTR
5256	DATE S RC BILLDA=0 F S RCBILL DA=$O(^TMP ("PRCAGT", $J,RCDEBTD A,RCTRDATE ,RCBILLDA
5257	)) Q:'RCBI LLDA D
5258	"RTN","RCC PCPS",114, 0)
5259	. . ; skip CS b ills/trans actions - PRCA4.53 01
5260	"RTN","RCC PCPS",115, 0)
5261	. . Q :$D(^PRCA( 430,"TCSP" ,RCBILLDA) )
5262	"RTN","RCC PCPS",116, 0)
5263	. . I $P($G(^RC PS(349.2,P SIEN,0))," ^",8)<0 S PC(75)=75
5264	"RTN","RCC PCPS",117, 0)
5265	. . I $P($G(^PR CA(430,RCB ILLDA,6)), "^",2)]"", ($P($G(^PR CA(430,RCB ILLDA,7))
5266	,"^")>0) S PC(1)="01 "
5267	"RTN","RCC PCPS",118, 0)
5268	. . S CAT=$P($G (^PRCA(430 ,RCBILLDA, 0)),"^",2)
5269	"RTN","RCC PCPS",119, 0)
5270	. . S PC=$P($G( ^PRCA(430. 2,CAT,0)), "^",14)
5271	"RTN","RCC PCPS",120, 0)
5272	. . F X=1:1:100 I $P(PC," ,",X)'="" S PCC=$P(P C,",",X),P C(+PCC)=PC C Q:PCC="
5273	"
5274	"RTN","RCC PCPS",121, 0)
5275	. . S PC="",X=0 F S X=$O (PC(X)) Q: X="" I $G (PC(X))'=" " S PC=PC_ PC(X)
5276	"RTN","RCC PCPS",122, 0)
5277	. . S $P(^RCPS( 349.2,PSIE N,4),"^")= PC
5278	"RTN","RCC PCPS",123, 0)
5279	. . ;
5280	"RTN","RCC PCPS",124, 0)
5281	. . I $D(^TMP(" PRCAGT",$J ,RCDEBTDA, RCTRDATE,R CBILLDA,0) ) S AMT=+^ (0) I AMT
5282	D
5283	"RTN","RCC PCPS",125, 0)
5284	. . . ; get the descri ption for the bill
5285	"RTN","RCC PCPS",126, 0)
5286	. . . K RCDES C D BILLDE SC^RCCPCPS 1(RCBILLDA )
5287	"RTN","RCC PCPS",127, 0)
5288	. . . ;
5289	"RTN","RCC PCPS",128, 0)
5290	. . . ; stor e the desc ription in file 349. 2, PS segm ent
5291	"RTN","RCC PCPS",129, 0)
5292	. . . S RCPSD A=RCPSDA+1
5293	"RTN","RCC PCPS",130, 0)
5294	. . . S $P(^R CPS(349.2, PSIEN,2,RC PSDA,0),"^ ",1,4)=$P( RCTRDATE," .")_"^"_$
5295	G(RCDESC(1 ))_"^"_$G( AMT)_"^"_$ P(^PRCA(43 0,RCBILLDA ,0),"^")
5296	"RTN","RCC PCPS",131, 0)
5297	. . . F X=2:1 Q:$G(RCDE SC(X))="" S RCPSDA= RCPSDA+1,^ RCPS(349.2 ,PSIEN,2,
5298	RCPSDA,0)= "^"_RCDESC (X)_"^^"
5299	"RTN","RCC PCPS",132, 0)
5300	. . ;
5301	"RTN","RCC PCPS",133, 0)
5302	. . S RCTRANDA= 0 F S RCT RANDA=$O(^ TMP("PRCAG T",$J,RCDE BTDA,RCTRD ATE,RCBIL
5303	LDA,RCTRAN DA)) D:'RC TRANDA NO Q:'RCTRAND A D
5304	"RTN","RCC PCPS",134, 0)
5305	. . . ; get the descri ption for the transa ction
5306	"RTN","RCC PCPS",135, 0)
5307	. . . K RCDES C D TRANDE SC^RCCPCPS 1(RCTRANDA ),RCDESC
5308	"RTN","RCC PCPS",136, 0)
5309	. . . ; if i t is an in terest/adm in charge, summarize it below
5310	"RTN","RCC PCPS",137, 0)
5311	. . . I $G(RC DESC(1))[" INTEREST" Q
5312	"RTN","RCC PCPS",138, 0)
5313	. . . ; get the value of the tra nsaction f or the sta tement
5314	"RTN","RCC PCPS",139, 0)
5315	. . . S VALUE =$$TRANVAL U^RCDPBTLM (RCTRANDA)
5316	"RTN","RCC PCPS",140, 0)
5317	. . . S VALUE =$P(VALUE, "^",2)+$P( VALUE,"^", 3)+$P(VALU E,"^",4)+$ P(VALUE,"
5318	^",5)+$P(V ALUE,"^",6 )
5319	"RTN","RCC PCPS",141, 0)
5320	. . . ; if i t is a sus pended (47 ) or unsus pended (46 ) transact ion, show
5321	value
5322	"RTN","RCC PCPS",142, 0)
5323	. . . ; make suspended charges a ppear as n egative
5324	"RTN","RCC PCPS",143, 0)
5325	. . . S RCDAT A1=$G(^PRC A(433,RCTR ANDA,1))
5326	"RTN","RCC PCPS",144, 0)
5327	. . . I $P(RC DATA1,"^", 2)=47!($P( RCDATA1,"^ ",2)=46) S VALUE=$P( RCDATA1,"
5328	^",5) I $P (RCDATA1," ^",2)=47 S VALUE=-VA LUE
5329	"RTN","RCC PCPS",145, 0)
5330	. . . ; if i t is an am ended bill , show val ue
5331	"RTN","RCC PCPS",146, 0)
5332	. . . I $P(RC DATA1,"^", 2)=33 S VA LUE=$P(RCD ATA1,"^",5 )
5333	"RTN","RCC PCPS",147, 0)
5334	. . . ; stor e the desc ription in file 349. 2, PS segm ent
5335	"RTN","RCC PCPS",148, 0)
5336	. . . S RCPSD A=RCPSDA+1
5337	"RTN","RCC PCPS",149, 0)
5338	. . . S $P(^R CPS(349.2, PSIEN,2,RC PSDA,0),"^ ",1,5)=$P( RCTRDATE," .")_"^"_$
5339	G(RCDESC(1 ))_"^"_VAL UE_"^"_$P( ^PRCA(430, RCBILLDA,0 ),"^")
5340	"RTN","RCC PCPS",150, 0)
5341	. . . F X=2:1 Q:$G(RCDE SC(X))="" S RCPSDA= RCPSDA+1,^ RCPS(349.2 ,PSIEN,2,
5342	RCPSDA,0)= "^"_RCDESC (X)_"^^"
5343	"RTN","RCC PCPS",151, 0)
5344	. . . ;
5345	"RTN","RCC PCPS",152, 0)
5346	. . . ; for comment tr ansaction ... not su re what th is is for ?
5347	"RTN","RCC PCPS",153, 0)
5348	. . . I $P(RC DATA1,"^", 2)=45,$P($ G(^PRCA(43 3,RCTRANDA ,5)),"^",2 )["your w
5349	aiver righ ts" S ^RCP S(349.2,PS IEN,4)="01 50"
5350	"RTN","RCC PCPS",154, 0)
5351	. ;
5352	"RTN","RCC PCPS",155, 0)
5353	. ; if interest, admin, or other, ad d them her e
5354	"RTN","RCC PCPS",156, 0)
5355	. S X=$ G(RCTOTAL( "INT"))+$G (RCTOTAL(" ADM"))+$G( RCTOTAL("O TH"))
5356	"RTN","RCC PCPS",157, 0)
5357	. I X>0 D
5358	"RTN","RCC PCPS",158, 0)
5359	. . S RCDESC="I NTEREST/AD M. CHARGE (Int:"_$J( $G(RCTOTAL ("INT")),1 ,2)_" Adm
5360	:"_$J($G(R CTOTAL("AD M")),1,2)_ " Other:"_ $J($G(RCTO TAL("OTH") ),1,2)_")"
5361	"RTN","RCC PCPS",159, 0)
5362	. . S RCPSDA=RC PSDA+1
5363	"RTN","RCC PCPS",160, 0)
5364	. . S ^RCPS(349 .2,PSIEN,2 ,RCPSDA,0) ="^"_RCDES C_"^"_$J(X ,1,2)
5365	"RTN","RCC PCPS",161, 0)
5366	. . S ^RCPS(349 .2,PSIEN,2 ,0)="^349. 21DA^"_RCP SDA_"^"_RC PSDA
5367	"RTN","RCC PCPS",162, 0)
5368	. ;
5369	"RTN","RCC PCPS",163, 0)
5370	. ; PRC A4.5313 - Set stat ement date into cros s-referenc e
5371	"RTN","RCC PCPS",164, 0)
5372	. S $P( ^RCPS(349. 2,PSIEN,0) ,U,19)=SDT
5373	"RTN","RCC PCPS",165, 0)
5374	. ;
5375	"RTN","RCC PCPS",166, 0)
5376	. ; se t 0th node
5377	"RTN","RCC PCPS",167, 0)
5378	. I RCP SDA S ^RCP S(349.2,PS IEN,2,0)=" ^349.21DA^ "_RCPSDA_" ^"_RCPSDA
5379	"RTN","RCC PCPS",168, 0)
5380	. ;
5381	"RTN","RCC PCPS",169, 0)
5382	. ; PRC A4.5313 - Set Cros s-Referenc es for thi s Debtor
5383	"RTN","RCC PCPS",170, 0)
5384	. S DA= PSIEN,DIK= "^RCPS(349 .2," D IX1 ^DIK
5385	"RTN","RCC PCPS",171, 0)
5386	. ;
5387	"RTN","RCC PCPS",172, 0)
5388	. ; PRC A4.5313 - Remove d ata for ea ch debtor
5389	"RTN","RCC PCPS",173, 0)
5390	. K ^XT MP("PRCAGU ",$J,DEB)
5391	"RTN","RCC PCPS",174, 0)
5392	. ;
5393	"RTN","RCC PCPS",175, 0)
5394	. I RCP SDA'<287 S ^XTMP("RC CPC",0)=DT ,(^XTMP("R CCPC",RCDE BTDA),^XTM P("RCCPC1
5395	",PSIEN))= "" Q
5396	"RTN","RCC PCPS",176, 0)
5397	. D NO
5398	"RTN","RCC PCPS",177, 0)
5399	;
5400	"RTN","RCC PCPS",178, 0)
5401	S PSIEN=0 S PSIEN=$ O(^RCPS(34 9.2,"STDT" ,SDT,PSIEN )) Q:PSIEN ="" S $P( ^RCPS(349
5402	.2,PSIEN,0 ),"^",18)= 1
5403	"RTN","RCC PCPS",179, 0)
5404	;
5405	"RTN","RCC PCPS",180, 0)
5406	; PRCA4. 5313 - Se nd ICN Err or email i f necessar y
5407	"RTN","RCC PCPS",181, 0)
5408	I $D(^TMP ("ICNERROR ",$J)) D I CNERR^RCCP CPS1 K ^TM P("ICNERRO R",$J)
5409	"RTN","RCC PCPS",182, 0)
5410	;
5411	"RTN","RCC PCPS",183, 0)
5412	K COMM,TR ,TRNIEN
5413	"RTN","RCC PCPS",184, 0)
5414	;
5415	"RTN","RCC PCPS",185, 0)
5416	OSTM ;Proc ess old st atements
5417	"RTN","RCC PCPS",186, 0)
5418	S DIK="^R CPS(349.2, ",DA=0 F S DA=$O(^X TMP("RCCPC 1",DA)) Q: 'DA D ^DI K
5419	"RTN","RCC PCPS",187, 0)
5420	K DA,^XTM P("RCCPC1" )
5421	"RTN","RCC PCPS",188, 0)
5422	;
5423	"RTN","RCC PCPS",189, 0)
5424	STATMNT ;P rint patie nt stateme nts
5425	"RTN","RCC PCPS",190, 0)
5426	N IOP,ZTI O,ZTSAVE,Z TRTN,ZTDES C,ZTASK,%Z IS,ZTDTH,P RCADEV,POP
5427	"RTN","RCC PCPS",191, 0)
5428	S (IOP,PR CADEV)=$P( $G(^RC(342 ,1,0)),"^" ,8)
5429	"RTN","RCC PCPS",192, 0)
5430	I IOP]"" D
5431	"RTN","RCC PCPS",193, 0)
5432	.S ZTRTN= "STM^RCCPC STM",ZTDTH =$H,ZTDESC ="Print ol d AR State ments"
5433	"RTN","RCC PCPS",194, 0)
5434	.S %ZIS=" N0" D ^%ZI S Q:POP
5435	"RTN","RCC PCPS",195, 0)
5436	.S ZTSAVE ("PRCADEV" )="" D ^%Z TLOAD,^%ZI SC
5437	"RTN","RCC PCPS",196, 0)
5438	; PRCA4. 5313 - Un lock prior to exitin g
5439	"RTN","RCC PCPS",197, 0)
5440	L -^RCPS( 349.2):DIL OCKTM
5441	"RTN","RCC PCPS",198, 0)
5442	Q
5443	"RTN","RCC PCPS",199, 0)
5444	;
5445	"RTN","RCC PCPS",200, 0)
5446	NO ;If the re is no a ctivity
5447	"RTN","RCC PCPS",201, 0)
5448	I $G(^RCP S(349.2,PS IEN,4))["0 150" D
5449	"RTN","RCC PCPS",202, 0)
5450	.S ^RCPS( 349.2,PSIE N,2,1,0)=" ^NOTICE: Y ou now hav e delinque nt charges . Please^
5451	^"
5452	"RTN","RCC PCPS",203, 0)
5453	.S ^RCPS( 349.2,PSIE N,2,2,0)=" ^review En forcement of Involun tary Colle ctions^^"
5454	"RTN","RCC PCPS",204, 0)
5455	.S ^RCPS( 349.2,PSIE N,2,3,0)=" ^on revers e.^^"
5456	"RTN","RCC PCPS",205, 0)
5457	.S ^RCPS( 349.2,PSIE N,2,0)="^^ 3^3"
5458	"RTN","RCC PCPS",206, 0)
5459	I $G(^RCP S(349.2,PS IEN,2,1,0) )="" D
5460	"RTN","RCC PCPS",207, 0)
5461	.S ^RCPS( 349.2,PSIE N,2,1,0)=" ^No Activi ty in the Last 30 Da ys!^^"
5462	"RTN","RCC PCPS",208, 0)
5463	.S ^RCPS( 349.2,PSIE N,2,2,0)=" ^Please re fer to pre vious stat ement of r ights.^^"
5464	"RTN","RCC PCPS",209, 0)
5465	.S ^RCPS( 349.2,PSIE N,2,0)="^^ 2^2"
5466	"RTN","RCC PCPS",210, 0)
5467	.I $G(^RC PS(349.2,P SIEN,4))=" " S ^(4)=" 90"
5468	"RTN","RCC PCPS",211, 0)
5469	Q
5470	"RTN","RCC PCPS",212, 0)
5471	BUILD ;Thi s is the e ntry point from the BUILD CCPC file opti on
5472	"RTN","RCC PCPS",213, 0)
5473	N TDT,QDT ,ZTDESC,ZT ASK,ZTSK,Z DTDTH,ZTIO ,ZTRTN,CNC L,%H,%DT,D IR,DTOUT
5474	"RTN","RCC PCPS",214, 0)
5475	; PRCA4. 5313 - Ch eck for lo ck. If lo cked quit with warni ng.
5476	"RTN","RCC PCPS",215, 0)
5477	L +^RCPS( 349.2):DIL OCKTM I '$ T W 7,7, !,"Another date is b eing run o r transmi
5478	tted. Try again lat er." Q
5479	"RTN","RCC PCPS",216, 0)
5480	; PRCA4. 5313 - Re written to use Patie nt Stateme nt Date en try
5481	"RTN","RCC PCPS",217, 0)
5482	S %DT="AE XP"
5483	"RTN","RCC PCPS",218, 0)
5484	S %DT("A" )="Enter t he Patient Statement date for this build : "
5485	"RTN","RCC PCPS",219, 0)
5486	; PRCA4. 5313 - Un lock prior to quitti ng
5487	"RTN","RCC PCPS",220, 0)
5488	D ^%DT I (X="^")!($ D(DTOUT))! (Y=-1) L - ^RCPS(349. 2):DILOCKT M Q
5489	"RTN","RCC PCPS",221, 0)
5490	S SDT=Y
5491	"RTN","RCC PCPS",222, 0)
5492	; PRCA4. 5313 - Ch eck for sp ecific dat es and unl ock prior to quittin g
5493	"RTN","RCC PCPS",223, 0)
5494	I ",1,2,4 ,6,7,8,10, 12,14,15,1 7,19,21,22 ,24,26,"'[ (","_+$E(S DT,6,7)_", ") D K S
5495	DT Q
5496	"RTN","RCC PCPS",224, 0)
5497	. W !!,"I NVALID STA TEMENT DAT E",!
5498	"RTN","RCC PCPS",225, 0)
5499	. L -^RCP S(349.2):D ILOCKTM
5500	"RTN","RCC PCPS",226, 0)
5501	. S DIR(0 )="E",DIR( "A")=" Pre ss ENTER t o Continue " D ^DIR
5502	"RTN","RCC PCPS",227, 0)
5503	S TDT=$O( ^RCPS(349. 2,"STDT",S DT,0)) I T DT D
5504	"RTN","RCC PCPS",228, 0)
5505	.S TDT=$T R($$SLH^RC FN01(SDT), "/","")
5506	"RTN","RCC PCPS",229, 0)
5507	.W *7,!!, "The Patie nt Stateme nts for ", $E(TDT,1,2 )_"/"_$E(T DT,3,4)_"/ "_$E(TDT,
5508	5,8)
5509	"RTN","RCC PCPS",230, 0)
5510	.I $D(^RC T(349,"SDT ",+$E(SDT, 6,7))) D
5511	"RTN","RCC PCPS",231, 0)
5512	..S TDT=$ P(^RCT(349 ,$O(^RCT(3 49,"SDT",+ $E(SDT,6,7 ),0)),0)," ^",10)
5513	"RTN","RCC PCPS",232, 0)
5514	..S TDT=$ TR($$SLH^R CFN01(TDT) ,"/","")
5515	"RTN","RCC PCPS",233, 0)
5516	..W " wer e transmit ted on ",$ E(TDT,1,2) _"/"_$E(TD T,3,4)_"/" _$E(TDT,5, 8)_"."
5517	"RTN","RCC PCPS",234, 0)
5518	.E W " d o not have a transmi ssion date !"
5519	"RTN","RCC PCPS",235, 0)
5520	.W !!,">> PLEASE CO NTACT CUST OMER SUPPO RT BEFORE PROCEEDING <<",!!
5521	"RTN","RCC PCPS",236, 0)
5522	.K DIRUT, DIOUT S DI R(0)="E",D IR("A")=" Press ENTE R to Conti nue with B uild or ^
5523	to Exit" D ^DIR
5524	"RTN","RCC PCPS",237, 0)
5525	; PRCA4. 5313 - Un lock prior to jobbin g off
5526	"RTN","RCC PCPS",238, 0)
5527	L -^RCPS( 349.2):DIL OCKTM
5528	"RTN","RCC PCPS",239, 0)
5529	I $D(DIRU T) K SDT Q
5530	"RTN","RCC PCPS",240, 0)
5531	TIME S ZTI O="",ZTRTN ="EN1^RCCP CPS",ZTDES C="Build C BSS Statem ent File"
5532	"RTN","RCC PCPS",241, 0)
5533	S ZTDTH=" ",ZTSAVE(" SDT")=SDT D ^%ZTLOAD Q:$G(ZTSK )=""
5534	"RTN","RCC PCPS",242, 0)
5535	S %H=ZTSK ("D") D YM D^%DTC S Q DT=X_%
5536	"RTN","RCC PCPS",243, 0)
5537	; PRCA5. 4313 - Al low run an y time
5538	"RTN","RCC PCPS",244, 0)
5539	;I (QDT>D T_"."_0800 )&(QDT<(DT _"."_1801) ) D G TIM E
5540	"RTN","RCC PCPS",245, 0)
5541	;.W !!,*7 ,"You Can Not Queue this Job B etween 8:0 0am and 6: 00pm.",!
5542	"RTN","RCC PCPS",246, 0)
5543	;.D KILL^ %ZTLOAD
5544	"RTN","RCC PCPS",247, 0)
5545	W !,"Queu ed for Bui lding."
5546	"RTN","RCC PCPS",248, 0)
5547	; PRCA4. 5313 - Un lock prior to quitti ng
5548	"RTN","RCC PCPS",249, 0)
5549	L -^RCPS( 349.2):DIL OCKTM
5550	"RTN","RCC PCPS",250, 0)
5551	Q
5552	"RTN","RCC PCPS",251, 0)
5553	;
5554	"RTN","RCC PCPS",252, 0)
5555	RCDESC ;Re move "IN P ART" & "IN FULL" fro m the the bill descr iption
5556	"RTN","RCC PCPS",253, 0)
5557	QUIT:$G(R CDESC(1))= ""
5558	"RTN","RCC PCPS",254, 0)
5559	S RCINFUL L=" (IN FU LL)"
5560	"RTN","RCC PCPS",255, 0)
5561	S RCINPAR T=" (IN PA RT)"
5562	"RTN","RCC PCPS",256, 0)
5563	I RCDESC( 1)[RCINFUL L S RCDESC (1)=$P(RCD ESC(1),RCI NFULL)_$P( RCDESC(1), RCINFULL,
5564	2)
5565	"RTN","RCC PCPS",257, 0)
5566	I RCDESC( 1)[RCINPAR T S RCDESC (1)=$P(RCD ESC(1),RCI NPART)_$P( RCDESC(1), RCINPART,
5567	2)
5568	"RTN","RCC PCPS",258, 0)
5569	Q
5570	"RTN","RCC PCPS",259, 0)
5571	FLBPD1() ; PRCA4.5 313 - Retu rn last bi ll prep da te
5572	"RTN","RCC PCPS",260, 0)
5573	N X1,X2 S X1="" I ' $D(^PRCA(4 30,"ATD",R CDFN)) Q X 1
5574	"RTN","RCC PCPS",261, 0)
5575	S X2=$O(^ PRCA(430," ATD",RCDFN ,X1),-1)
5576	"RTN","RCC PCPS",262, 0)
5577	S X1=$O(^ PRCA(430," ATD",RCDFN ,X2,X1),-1 )
5578	"RTN","RCC PCPS",263, 0)
5579	Q X1
5580	"RTN","RCC PCPS1")
5581	0^11^B6483 3684^B3737 0113
5582	"RTN","RCC PCPS1",1,0 )
5583	RCCPCPS1 ; WISC/RFJ-b uild descr iption for patient s tatement ; 08 Aug 200 1
5584	"RTN","RCC PCPS1",2,0 )
5585	;;4.5;Acc ounts Rece ivable;3 4,48,104,1 70,176,192 ,265,313 ;Mar 20, 1 995;Build
5586	113
5587	"RTN","RCC PCPS1",3,0 )
5588	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
5589	"RTN","RCC PCPS1",4,0 )
5590	Q
5591	"RTN","RCC PCPS1",5,0 )
5592	;
5593	"RTN","RCC PCPS1",6,0 )
5594	;
5595	"RTN","RCC PCPS1",7,0 )
5596	TRANDESC(R CTRANDA,RC WIDTH) ; build the descriptio n array fo r a transa ction
5597	"RTN","RCC PCPS1",8,0 )
5598	;
5599	"RTN","RCC PCPS1",9,0 )
5600	; initia lize
5601	"RTN","RCC PCPS1",10, 0)
5602	N DESCRIP T,RCBILLDA ,RCCATEG,R CCATTXT,RC DATA0,RCDA TA1,RCDATA 3,RCLINE,T RANTYPE,X
5603	"RTN","RCC PCPS1",11, 0)
5604	I '$G(RCW IDTH) S RC WIDTH=50 ; Default m ax. width is 50 char acters
5605	"RTN","RCC PCPS1",12, 0)
5606	K RCDESC
5607	"RTN","RCC PCPS1",13, 0)
5608	S RCLINE= 1,RCDESC(1 )=""
5609	"RTN","RCC PCPS1",14, 0)
5610	;
5611	"RTN","RCC PCPS1",15, 0)
5612	S RCBILLD A=+$P($G(^ PRCA(433,R CTRANDA,0) ),"^",2) I 'RCBILLDA Q
5613	"RTN","RCC PCPS1",16, 0)
5614	S RCDATA0 =^PRCA(430 ,RCBILLDA, 0)
5615	"RTN","RCC PCPS1",17, 0)
5616	S RCCATEG =+$P(RCDAT A0,"^",2), RCCATTXT=$ P($G(^PRCA (430.2,RCC ATEG,0))," ^")
5617	"RTN","RCC PCPS1",18, 0)
5618	S RCDATA1 =^PRCA(433 ,RCTRANDA, 1)
5619	"RTN","RCC PCPS1",19, 0)
5620	S TRANTYP E=$P(RCDAT A1,"^",2)
5621	"RTN","RCC PCPS1",20, 0)
5622	;
5623	"RTN","RCC PCPS1",21, 0)
5624	; build the first line descr iption
5625	"RTN","RCC PCPS1",22, 0)
5626	; if tra nsaction t ype is an increase o r decrease , set desc ription
5627	"RTN","RCC PCPS1",23, 0)
5628	I TRANTYP E=1!(TRANT YPE=35) D
5629	"RTN","RCC PCPS1",24, 0)
5630	. ; if c means t est, set d escription to catego ry for c m eans test
5631	"RTN","RCC PCPS1",25, 0)
5632	. I RCC ATEG=18 S DESCRIPT=$ S($P(RCDAT A0,"^",16) :$P(^PRCA( 430.2,$P(R CDATA0,"^
5633	",16),0)," ^"),1:RCCA TTXT) Q
5634	"RTN","RCC PCPS1",26, 0)
5635	. ; ot herwise, s et to cate gory name
5636	"RTN","RCC PCPS1",27, 0)
5637	. S DES CRIPT=RCCA TTXT
5638	"RTN","RCC PCPS1",28, 0)
5639	;
5640	"RTN","RCC PCPS1",29, 0)
5641	; if the bill cate gory is a rx-copay a nd it is a n increase adjustmen t
5642	"RTN","RCC PCPS1",30, 0)
5643	; then s et the des cription t o copay
5644	"RTN","RCC PCPS1",31, 0)
5645	I RCCATEG =22!(RCCAT EG=23),TRA NTYPE=1 S DESCRIPT=" COPAY"
5646	"RTN","RCC PCPS1",32, 0)
5647	;
5648	"RTN","RCC PCPS1",33, 0)
5649	; if the bill cate gory is ad ult day he alth care, remove he alth
5650	"RTN","RCC PCPS1",34, 0)
5651	I RCCATEG =33 S DESC RIPT="ADUL T DAY CARE "
5652	"RTN","RCC PCPS1",35, 0)
5653	;
5654	"RTN","RCC PCPS1",36, 0)
5655	; if the bill cate gory is re spite or g eriatric e val,
5656	"RTN","RCC PCPS1",37, 0)
5657	; take t he 2nd pie ce removin g institut ional
5658	"RTN","RCC PCPS1",38, 0)
5659	I RCCATEG =35!(RCCAT EG=36)!(RC CATEG=37)! (RCCATEG=3 8) S DESCR IPT=$P(RCC ATTXT,"-"
5660	)_$S(RCCAT EG=35!(RCC ATEG=37):" IN",1:" O UT")_"PATI ENT"
5661	"RTN","RCC PCPS1",39, 0)
5662	;
5663	"RTN","RCC PCPS1",40, 0)
5664	; if it is a comme nt transac tion
5665	"RTN","RCC PCPS1",41, 0)
5666	I TRANTYP E=45 S DES CRIPT="COM MENT: "_$P ($G(^PRCA( 433,RCTRAN DA,5)),"^" ,2)
5667	"RTN","RCC PCPS1",42, 0)
5668	;
5669	"RTN","RCC PCPS1",43, 0)
5670	; prepay ment bill (1=increas e, 35=decr ease, othe rwise refu nd)
5671	"RTN","RCC PCPS1",44, 0)
5672	I RCCATEG =26 S DESC RIPT=$S(TR ANTYPE=1:" OVERPAYMEN T CREDIT", TRANTYPE=3 5:"OVERPA
5673	YMENT CRED IT DECREAS E",1:"OVER PAYMENT RE FUND")
5674	"RTN","RCC PCPS1",45, 0)
5675	;
5676	"RTN","RCC PCPS1",46, 0)
5677	; if the first lin e descript ion not se t (like pa yments), s et it
5678	"RTN","RCC PCPS1",47, 0)
5679	; to the type of t ransaction
5680	"RTN","RCC PCPS1",48, 0)
5681	I $G(DESC RIPT)="" S DESCRIPT= $P($G(^PRC A(430.3,+$ P(RCDATA1, "^",2),0)) ,"^")
5682	"RTN","RCC PCPS1",49, 0)
5683	;
5684	"RTN","RCC PCPS1",50, 0)
5685	; if the transacti on date is different from the process da te,
5686	"RTN","RCC PCPS1",51, 0)
5687	; show i t with the descripti on
5688	"RTN","RCC PCPS1",52, 0)
5689	I $P(RCDA TA1,"^"),$ P($P(RCDAT A1,"^"),". ")'=$P($P( RCDATA1,"^ ",9),".") S DESCRIP
5690	T=DESCRIPT _" ("_$$D ATE($P($P( RCDATA1,"^ "),"."))_" )"
5691	"RTN","RCC PCPS1",53, 0)
5692	;
5693	"RTN","RCC PCPS1",54, 0)
5694	; set th e first de scription line
5695	"RTN","RCC PCPS1",55, 0)
5696	D SETDESC (DESCRIPT)
5697	"RTN","RCC PCPS1",56, 0)
5698	;
5699	"RTN","RCC PCPS1",57, 0)
5700	; if it is a payme nt transac tion, show amount pa id interes t, admin, other
5701	"RTN","RCC PCPS1",58, 0)
5702	I TRANTYP E=2!(TRANT YPE=34) D
5703	"RTN","RCC PCPS1",59, 0)
5704	. S RCD ATA3=$G(^P RCA(433,RC TRANDA,3))
5705	"RTN","RCC PCPS1",60, 0)
5706	. ; if not inter est, admin , or other , quit
5707	"RTN","RCC PCPS1",61, 0)
5708	. I '$P (RCDATA3," ^",2),'$P( RCDATA3,"^ ",3),'$P(R CDATA3,"^" ,4),'$P(RC DATA3,"^"
5709	,5) Q
5710	"RTN","RCC PCPS1",62, 0)
5711	. ;
5712	"RTN","RCC PCPS1",63, 0)
5713	. S DES CRIPT=" ( Int:"_$J(+ $P(RCDATA3 ,"^",2),1, 2)_" Adm: "_$J(+$P(R CDATA3,"^
5714	",3),1,2)
5715	"RTN","RCC PCPS1",64, 0)
5716	. ; ca lculate ot her
5717	"RTN","RCC PCPS1",65, 0)
5718	. S X=$ P(RCDATA1, "^",5)-$P( RCDATA3,"^ ")-$P(RCDA TA3,"^",2) -$P(RCDATA 3,"^",3)
5719	"RTN","RCC PCPS1",66, 0)
5720	. S DES CRIPT=DESC RIPT_$S(X: " Other:"_ $J(X,1,2)_ ")",1:")")
5721	"RTN","RCC PCPS1",67, 0)
5722	. D SET DESC(DESCR IPT)
5723	"RTN","RCC PCPS1",68, 0)
5724	;
5725	"RTN","RCC PCPS1",69, 0)
5726	; if it is a admin cost or i nterest ch arge, tota l the amou nts
5727	"RTN","RCC PCPS1",70, 0)
5728	I TRANTYP E=13!(TRAN TYPE=12) D Q
5729	"RTN","RCC PCPS1",71, 0)
5730	. S X=$ G(^PRCA(43 3,RCTRANDA ,2)) I X=" " Q
5731	"RTN","RCC PCPS1",72, 0)
5732	. S RCT OTAL("INT" )=$G(RCTOT AL("INT")) +$P(X,"^", 7)
5733	"RTN","RCC PCPS1",73, 0)
5734	. S RCT OTAL("ADM" )=$G(RCTOT AL("ADM")) +$P(X,"^", 8)
5735	"RTN","RCC PCPS1",74, 0)
5736	. S RCT OTAL("OTH" )=$G(RCTOT AL("OTH")) +($P(RCDAT A1,"^",5)- $P(X,"^",7 )-$P(X,"^
5737	",8))
5738	"RTN","RCC PCPS1",75, 0)
5739	;
5740	"RTN","RCC PCPS1",76, 0)
5741	; if not an increa se adjustm ent, quit
5742	"RTN","RCC PCPS1",77, 0)
5743	I TRANTYP E'=1 Q
5744	"RTN","RCC PCPS1",78, 0)
5745	;
5746	"RTN","RCC PCPS1",79, 0)
5747	; increa se to c me ans test, ltc or rx- copay, get data from ib
5748	"RTN","RCC PCPS1",80, 0)
5749	I RCCATEG =18!(RCCAT EG=22)!(RC CATEG=23)! ((RCCATEG> 32)&(RCCAT EG<40)) D
5750	"RTN","RCC PCPS1",81, 0)
5751	. S X=" IBRFN1" X ^%ZOSF("TE ST") I '$T Q
5752	"RTN","RCC PCPS1",82, 0)
5753	. K ^TM P("IBRFN1" ,$J)
5754	"RTN","RCC PCPS1",83, 0)
5755	. D STM T^IBRFN1(R CTRANDA)
5756	"RTN","RCC PCPS1",84, 0)
5757	. D IBD ATA
5758	"RTN","RCC PCPS1",85, 0)
5759	Q
5760	"RTN","RCC PCPS1",86, 0)
5761	;
5762	"RTN","RCC PCPS1",87, 0)
5763	;
5764	"RTN","RCC PCPS1",88, 0)
5765	; Return s RCDESC(1 ..n) array of Bill D escription
5766	"RTN","RCC PCPS1",89, 0)
5767	BILLDESC(R CBILLDA,RC WIDTH) ;
5768	"RTN","RCC PCPS1",90, 0)
5769	; initia lize
5770	"RTN","RCC PCPS1",91, 0)
5771	N DESCRIP T,RCCATEG, RCCATTXT,R CDATA0,RCL INE,X
5772	"RTN","RCC PCPS1",92, 0)
5773	I '$G(RCW IDTH) S RC WIDTH=50 ; Default m ax. width is 50 char acters
5774	"RTN","RCC PCPS1",93, 0)
5775	K RCDESC
5776	"RTN","RCC PCPS1",94, 0)
5777	S RCLINE= 1,RCDESC(1 )=""
5778	"RTN","RCC PCPS1",95, 0)
5779	;
5780	"RTN","RCC PCPS1",96, 0)
5781	S RCDATA0 =^PRCA(430 ,RCBILLDA, 0)
5782	"RTN","RCC PCPS1",97, 0)
5783	S RCCATEG =+$P(RCDAT A0,"^",2), RCCATTXT=$ P($G(^PRCA (430.2,RCC ATEG,0))," ^")
5784	"RTN","RCC PCPS1",98, 0)
5785	;
5786	"RTN","RCC PCPS1",99, 0)
5787	; if cat egory=c me ans test, set the de scription and quit
5788	"RTN","RCC PCPS1",100 ,0)
5789	I RCCATEG =18 S DESC RIPT=$S($P (RCDATA0," ^",16):$P( ^PRCA(430. 2,$P(RCDAT A0,"^",16
5790	),0),"^"), 1:RCCATTXT ) D SETDES C(DESCRIPT ) Q
5791	"RTN","RCC PCPS1",101 ,0)
5792	;
5793	"RTN","RCC PCPS1",102 ,0)
5794	; set th e category descripti on
5795	"RTN","RCC PCPS1",103 ,0)
5796	D SETDESC (RCCATTXT)
5797	"RTN","RCC PCPS1",104 ,0)
5798	;
5799	"RTN","RCC PCPS1",105 ,0)
5800	; if cat egory not champva su bsitence a nd not tri care patie nt, quit
5801	"RTN","RCC PCPS1",106 ,0)
5802	I RCCATEG '=27,RCCAT EG'=31 Q
5803	"RTN","RCC PCPS1",107 ,0)
5804	;
5805	"RTN","RCC PCPS1",108 ,0)
5806	; build descriptio n for cham pva subsis tence and tricare pa tient bill s
5807	"RTN","RCC PCPS1",109 ,0)
5808	; get da ta from ib
5809	"RTN","RCC PCPS1",110 ,0)
5810	S X="IBRF N1" X ^%ZO SF("TEST") I '$T Q
5811	"RTN","RCC PCPS1",111 ,0)
5812	K ^TMP("I BRFN1",$J)
5813	"RTN","RCC PCPS1",112 ,0)
5814	D STMTB^I BRFN1($P(R CDATA0,"^" ))
5815	"RTN","RCC PCPS1",113 ,0)
5816	D IBDATA
5817	"RTN","RCC PCPS1",114 ,0)
5818	Q
5819	"RTN","RCC PCPS1",115 ,0)
5820	;
5821	"RTN","RCC PCPS1",116 ,0)
5822	;
5823	"RTN","RCC PCPS1",117 ,0)
5824	IBDATA ; get data f rom IB for descripti on
5825	"RTN","RCC PCPS1",118 ,0)
5826	N IBDATA, IBJ
5827	"RTN","RCC PCPS1",119 ,0)
5828	;
5829	"RTN","RCC PCPS1",120 ,0)
5830	; show I B data
5831	"RTN","RCC PCPS1",121 ,0)
5832	S IBJ=0 F S IBJ=$O (^TMP("IBR FN1",$J,IB J)) Q:'IBJ S IBDATA =^TMP("IBR FN1",$J,I
5833	BJ) D
5834	"RTN","RCC PCPS1",122 ,0)
5835	. ;
5836	"RTN","RCC PCPS1",123 ,0)
5837	. ; if no drug o r bill dat e returned from IB, then it is outpatien t
5838	"RTN","RCC PCPS1",124 ,0)
5839	. I $P( IBDATA,"^" ,3)="" D:$ P(IBDATA," ^",2) SETD ESC("VISIT DATE: "_$ $DATE($P(
5840	IBDATA,"^" ,2))) Q
5841	"RTN","RCC PCPS1",125 ,0)
5842	. ;
5843	"RTN","RCC PCPS1",126 ,0)
5844	. ; if no drug q uantity re turned fro m ib, then it is inp atient
5845	"RTN","RCC PCPS1",127 ,0)
5846	. I '$P (IBDATA,"^ ",6) D Q
5847	"RTN","RCC PCPS1",128 ,0)
5848	. . I $P(IBDATA ,"^",2) D SETDESC(" ADMISSION DATE: "_$ $DATE($P(I BDATA,"^"
5849	,2)))
5850	"RTN","RCC PCPS1",129 ,0)
5851	. . I $P(IBDATA ,"^",3) D SETDESC(" BEGINNING DATE OF B ILLING CYC LE: "_$$D
5852	ATE($P(IBD ATA,"^",3) ))
5853	"RTN","RCC PCPS1",130 ,0)
5854	. . I $P(IBDATA ,"^",4) D SETDESC(" ENDING DA TE OF BILL ING CYCLE: "_$$DATE
5855	($P(IBDATA ,"^",4)))
5856	"RTN","RCC PCPS1",131 ,0)
5857	. . I $P(IBDATA ,"^",5) D SETDESC(" DISCHARGE DATE: "_$ $DATE($P(I BDATA,"^"
5858	,5)))
5859	"RTN","RCC PCPS1",132 ,0)
5860	. ;
5861	"RTN","RCC PCPS1",133 ,0)
5862	. ; ph armacy
5863	"RTN","RCC PCPS1",134 ,0)
5864	. D:$P( IBDATA,"^" ,2) SETDES C("RX:"_$P (IBDATA,"^ ",2))
5865	"RTN","RCC PCPS1",135 ,0)
5866	. D:$P( IBDATA,"^" ,7) SETDES C("FD:"_$$ DATE($P(IB DATA,"^",7 )))
5867	"RTN","RCC PCPS1",136 ,0)
5868	. ;
5869	"RTN","RCC PCPS1",137 ,0)
5870	. ; if not patie nt stateme nt detail, quit
5871	"RTN","RCC PCPS1",138 ,0)
5872	. I $$D ET^RCFN01( $P(RCDATA0 ,"^",9))'= 2 Q
5873	"RTN","RCC PCPS1",139 ,0)
5874	. ;
5875	"RTN","RCC PCPS1",140 ,0)
5876	. ; re turn pharm acy detail
5877	"RTN","RCC PCPS1",141 ,0)
5878	. I $P( IBDATA,"^" ,3)'="" D SETDESC(" DRUG:"_$TR ($P(IBDATA ,"^",3),"\| ~"))
5879	"RTN","RCC PCPS1",142 ,0)
5880	. I $P( IBDATA,"^" ,4) D SETD ESC(" DAYS :"_$P(IBDA TA,"^",4))
5881	"RTN","RCC PCPS1",143 ,0)
5882	. I $P( IBDATA,"^" ,6) D SETD ESC(" QTY: "_$P(IBDAT A,"^",6))
5883	"RTN","RCC PCPS1",144 ,0)
5884	. I $P( IBDATA,"^" ,5)'="" D SETDESC(" PHY:"_$P(I BDATA,"^", 5))
5885	"RTN","RCC PCPS1",145 ,0)
5886	. I $P( IBDATA,"^" ,8) D SETD ESC(" CHG: $"_$J($P(I BDATA,"^", 8),0,2))
5887	"RTN","RCC PCPS1",146 ,0)
5888	;
5889	"RTN","RCC PCPS1",147 ,0)
5890	K ^TMP("I BRFN1",$J)
5891	"RTN","RCC PCPS1",148 ,0)
5892	Q
5893	"RTN","RCC PCPS1",149 ,0)
5894	;
5895	"RTN","RCC PCPS1",150 ,0)
5896	;
5897	"RTN","RCC PCPS1",151 ,0)
5898	; Add lin e to the d escription , not long er than RC WIDTH
5899	"RTN","RCC PCPS1",152 ,0)
5900	; Input: RCLINE,RCW IDTH
5901	"RTN","RCC PCPS1",153 ,0)
5902	; Output: RCDESC
5903	"RTN","RCC PCPS1",154 ,0)
5904	SETDESC(DE SCRIPT) N LENGTH
5905	"RTN","RCC PCPS1",155 ,0)
5906	; calcul ate the le ngth of th e descript ion
5907	"RTN","RCC PCPS1",156 ,0)
5908	S LENGTH= $L(RCDESC( RCLINE))+$ L(DESCRIPT )
5909	"RTN","RCC PCPS1",157 ,0)
5910	I RCDESC( RCLINE)'=" " S LENGTH =LENGTH+1
5911	"RTN","RCC PCPS1",158 ,0)
5912	;
5913	"RTN","RCC PCPS1",159 ,0)
5914	; the de scription line canno t go over RCWIDTH ch aracters
5915	"RTN","RCC PCPS1",160 ,0)
5916	I LENGTH< RCWIDTH S RCDESC(RCL INE)=RCDES C(RCLINE)_ $S(RCDESC( RCLINE)="" :"",1:" "
5917	)_DESCRIPT Q
5918	"RTN","RCC PCPS1",161 ,0)
5919	;
5920	"RTN","RCC PCPS1",162 ,0)
5921	; Descrip tion line to add is over RCWID TH
5922	"RTN","RCC PCPS1",163 ,0)
5923	; The giv en string will be sp litted _on ly_ if the limit is more than 44 charac
5924	ters.
5925	"RTN","RCC PCPS1",164 ,0)
5926	I $L(DESC RIPT)>RCWI DTH D Q
5927	"RTN","RCC PCPS1",165 ,0)
5928	. I RCD ESC(RCLINE )'="" S RC LINE=RCLIN E+1
5929	"RTN","RCC PCPS1",166 ,0)
5930	. S RCD ESC(RCLINE )=$E(DESCR IPT,1,RCWI DTH)
5931	"RTN","RCC PCPS1",167 ,0)
5932	. S RCL INE=RCLINE +1
5933	"RTN","RCC PCPS1",168 ,0)
5934	. S RCD ESC(RCLINE )=$E(DESCR IPT,RCWIDT H+1,2*RCWI DTH)
5935	"RTN","RCC PCPS1",169 ,0)
5936	;
5937	"RTN","RCC PCPS1",170 ,0)
5938	; over R CWIDTH cha racters, s tart new l ine
5939	"RTN","RCC PCPS1",171 ,0)
5940	I RCDESC( RCLINE)'=" " S RCLINE =RCLINE+1
5941	"RTN","RCC PCPS1",172 ,0)
5942	S RCDESC( RCLINE)=DE SCRIPT
5943	"RTN","RCC PCPS1",173 ,0)
5944	Q
5945	"RTN","RCC PCPS1",174 ,0)
5946	;
5947	"RTN","RCC PCPS1",175 ,0)
5948	DATE(FMDT) ; format date mm/d d/yyyy
5949	"RTN","RCC PCPS1",176 ,0)
5950	I 'FMDT Q ""
5951	"RTN","RCC PCPS1",177 ,0)
5952	N X,Y,%DT S %DT="TX ",X=FMDT D ^%DT Q:Y< 0 ""
5953	"RTN","RCC PCPS1",178 ,0)
5954	Q $E(FMDT ,4,5)_"/"_ $E(FMDT,6, 7)_"/"_(17 00+$E(FMDT ,1,3))
5955	"RTN","RCC PCPS1",179 ,0)
5956	;
5957	"RTN","RCC PCPS1",180 ,0)
5958	KILL(SDT) ; PRCA4 .5313 - k ill data p rior to re creating f or this da y of mont
5959	h
5960	"RTN","RCC PCPS1",181 ,0)
5961	;
5962	"RTN","RCC PCPS1",182 ,0)
5963	; Set dat e back one month
5964	"RTN","RCC PCPS1",183 ,0)
5965	N IEN,X,R CT,DA,DIK
5966	"RTN","RCC PCPS1",184 ,0)
5967	;
5968	"RTN","RCC PCPS1",185 ,0)
5969	S IEN=""
5970	"RTN","RCC PCPS1",186 ,0)
5971	F S IEN= $O(^RCPS(3 49.2,"STDT ",SDT,IEN) ) Q:IEN="" S DA=IEN ,DIK="^RCP S(349.2,"
5972	D ^DIK
5973	"RTN","RCC PCPS1",187 ,0)
5974	;
5975	"RTN","RCC PCPS1",188 ,0)
5976	F X="PA", "IS" S RCT =$O(^RCT(3 49.1,"B",X ,0)) Q:'RC T D
5977	"RTN","RCC PCPS1",189 ,0)
5978	. S ACK=" " F S ACK =$O(^RCT(3 49.1,RCT,4 ,"STDT4",S DT,ACK)) Q :ACK="" D
5979	"RTN","RCC PCPS1",190 ,0)
5980	. . S IEN =0 F S IE N=$O(^RCT( 349.1,RCT, 4,"STDT4", SDT,ACK,IE N)) Q:IEN= "" S DA=
5981	IEN,DIK="^ RCT(349.1, "_RCT_",4, " D ^DIK K ^RCT(349. 1,RCT,4,"S TDT4",SDT, ACK,IEN)
5982	"RTN","RCC PCPS1",191 ,0)
5983	. S IEN=0 F S IEN= $O(^RCT(34 9.1,RCT,5, "STDT5",SD T,IEN)) Q: IEN="" S DA=IEN,DI
5984	K="^RCT(34 9.1,"_RCT_ ",5," D ^D IK K ^RCT( 349.1,RCT, 5,"STDT5", SDT,IEN)
5985	"RTN","RCC PCPS1",192 ,0)
5986	;
5987	"RTN","RCC PCPS1",193 ,0)
5988	K ^XTMP(" RCCPC")
5989	"RTN","RCC PCPS1",194 ,0)
5990	;
5991	"RTN","RCC PCPS1",195 ,0)
5992	Q
5993	"RTN","RCC PCPS1",196 ,0)
5994	;
5995	"RTN","RCC PCPS1",197 ,0)
5996	MONTHAGO(S DT) ; PRC A4.5313 - Return d ate one mo nth prior to entered date
5997	"RTN","RCC PCPS1",198 ,0)
5998	; New OLD DT in call ing routin e
5999	"RTN","RCC PCPS1",199 ,0)
6000	S OLDDT=S DT-100
6001	"RTN","RCC PCPS1",200 ,0)
6002	I $E(SDT, 4,5)="01" S OLDDT=($ E(SDT,1,3) -1)_12_$E( SDT,6,7)
6003	"RTN","RCC PCPS1",201 ,0)
6004	Q OLDDT
6005	"RTN","RCC PCPS1",202 ,0)
6006	;
6007	"RTN","RCC PCPS1",203 ,0)
6008	ICNERR ; PRCA4.5 313 - Send email to RCCPC STAT EMENTS Mai l Group wi th all mi
6009	ssing ICNs
6010	"RTN","RCC PCPS1",204 ,0)
6011	N XMTO,XM SUBJ,XMBOD Y,XMINSTR, XMDUZ,XMY, DFN,CNT,I
6012	"RTN","RCC PCPS1",205 ,0)
6013	;
6014	"RTN","RCC PCPS1",206 ,0)
6015	; Create Message at MSG level of tempor ary storag e
6016	"RTN","RCC PCPS1",207 ,0)
6017	S CNT=1,^ TMP("ICNER ROR",$J,"M SG",CNT)=" The Patien t Statemen ts for the se patien
6018	ts were no t sent to CBSS due t o a"
6019	"RTN","RCC PCPS1",208 ,0)
6020	S CNT=2,^ TMP("ICNER ROR",$J,"M SG",CNT)=" missing IC N."
6021	"RTN","RCC PCPS1",209 ,0)
6022	S CNT=3,^ TMP("ICNER ROR",$J,"M SG",CNT)=" NAME SSN
6023	"
6024	"RTN","RCC PCPS1",210 ,0)
6025	S CNT=4,^ TMP("ICNER ROR",$J,"M SG",CNT)=" ========== ========== ========== =========
6026	======="
6027	"RTN","RCC PCPS1",211 ,0)
6028	S DFN="" F S DFN=$ O(^TMP("IC NERROR",$J ,DFN)) Q:D FN="" Q:D FN="MSG" D
6029	"RTN","RCC PCPS1",212 ,0)
6030	. N DPTDA TA,NAME
6031	"RTN","RCC PCPS1",213 ,0)
6032	. S DPTDA TA=$G(^DPT (DFN,0))
6033	"RTN","RCC PCPS1",214 ,0)
6034	. I DPTDA TA="" Q
6035	"RTN","RCC PCPS1",215 ,0)
6036	. S NAME= $P(DPTDATA ,U)
6037	"RTN","RCC PCPS1",216 ,0)
6038	. F I=$L( NAME):1:35 S NAME=NA ME_" "
6039	"RTN","RCC PCPS1",217 ,0)
6040	. S CNT=C NT+1
6041	"RTN","RCC PCPS1",218 ,0)
6042	. S ^TMP( "ICNERROR" ,$J,"MSG", CNT)=NAME_ $P(DPTDATA ,U,9)
6043	"RTN","RCC PCPS1",219 ,0)
6044	;
6045	"RTN","RCC PCPS1",220 ,0)
6046	S XMDUZ=D UZ
6047	"RTN","RCC PCPS1",221 ,0)
6048	S XMTO(DU Z)=""
6049	"RTN","RCC PCPS1",222 ,0)
6050	S XMTO("G .RCCPC STA TEMENTS")= ""
6051	"RTN","RCC PCPS1",223 ,0)
6052	S XMSUBJ= "PATIENTS WITH MISSI NG ICNS"
6053	"RTN","RCC PCPS1",224 ,0)
6054	S XMBODY= "^TMP(""IC NERROR"",$ J,""MSG"") "
6055	"RTN","RCC PCPS1",225 ,0)
6056	S XMINSTR ("FLAGS")= "X"
6057	"RTN","RCC PCPS1",226 ,0)
6058	D SENDMSG ^XMXAPI(XM DUZ,XMSUBJ ,XMBODY,.X MTO,.XMINS TR)
6059	"RTN","RCC PCPS1",227 ,0)
6060	Q
6061	"RTN","RCC PCSE")
6062	0^14^B1349 2869^B5810 439
6063	"RTN","RCC PCSE",1,0)
6064	RCCPCSE ;W ASH-ISC@AL TOONA,PA/L DB - CCPC Statements Errors;5/ 30/96 10: 20 AM ;10
6065	/16/96 8: 42 AM
6066	"RTN","RCC PCSE",2,0)
6067	V ;;4.5;Ac counts Rec eivable; 34,313;M ar 20, 199 5;Build 11 3
6068	"RTN","RCC PCSE",3,0)
6069	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
6070	"RTN","RCC PCSE",4,0)
6071	;
6072	"RTN","RCC PCSE",5,0)
6073	K ^TMP($J )
6074	"RTN","RCC PCSE",6,0)
6075	N ADD,DIR ,DIRUT,ERR ,ERROR,HDR ,LINE,LN,P G,POP,PT,X ,X1,Y,%ZIS ,Z,ZTRTN,Z TDESC,%,%
6076	Y,%DT,ZTSA VE
6077	"RTN","RCC PCSE",7,0)
6078	I '$O(^RC PS(349.2," AD","E",0) ) W !,"THE RE ARE NO CBSS PATIE NT STATEME NT ERRORS
6079	" Q
6080	"RTN","RCC PCSE",8,0)
6081	E W !,"C BSS PATIEN T STATEMEN T ERROR RE PORT"
6082	"RTN","RCC PCSE",9,0)
6083	N IEN,%D, DTOUT,SDT, SDAT,TMPQ, ALL,DTPT
6084	"RTN","RCC PCSE",10,0 )
6085	S (TMPQ,A LL)=0
6086	"RTN","RCC PCSE",11,0 )
6087	S IEN="" F S IEN=$ O(^RCPS(34 9.2,"AD"," E",IEN)) Q :IEN="" I $G(^RCPS( 349.2,IEN
6088	,5))'="" D
6089	"RTN","RCC PCSE",12,0 )
6090	. S SDT=$ P(^RCPS(34 9.2,IEN,0) ,U,19)
6091	"RTN","RCC PCSE",13,0 )
6092	. S DTPT( SDT,IEN)=" "
6093	"RTN","RCC PCSE",14,0 )
6094	. S DTPT( SDT)=$G(DT PT(SDT))+1
6095	"RTN","RCC PCSE",15,0 )
6096	; PRCA4. 5313 - As k about al l dates or specific
6097	"RTN","RCC PCSE",16,0 )
6098	W !,"Do y ou want to print err ors for al l dates av ailable"
6099	"RTN","RCC PCSE",17,0 )
6100	S %=1 D Y N^DICN
6101	"RTN","RCC PCSE",18,0 )
6102	I %=1 S A LL=1 D PRI NT Q
6103	"RTN","RCC PCSE",19,0 )
6104	I %Y="^" Q
6105	"RTN","RCC PCSE",20,0 )
6106	; PRCA4. 5313 - Ad d date pro mpts
6107	"RTN","RCC PCSE",21,0 )
6108	W !,"The following dates have errors to print:"
6109	"RTN","RCC PCSE",22,0 )
6110	S SDT="" F S SDT=$ O(DTPT(SDT )) Q:SDT= "" W !,$$ DATE^RCCPC PS1(SDT)
6111	"RTN","RCC PCSE",23,0 )
6112	S %DT="AE XP"
6113	"RTN","RCC PCSE",24,0 )
6114	S %DT("A" )="Enter P atient Sta tement dat e: "
6115	"RTN","RCC PCSE",25,0 )
6116	D ^%DT Q: (X="^")!($ D(DTOUT))! (Y=-1)
6117	"RTN","RCC PCSE",26,0 )
6118	S SDT=Y
6119	"RTN","RCC PCSE",27,0 )
6120	I '$D(DTP T(SDT)) W !,"There a re no erro r files fo r that dat e." Q
6121	"RTN","RCC PCSE",28,0 )
6122	D PRINT
6123	"RTN","RCC PCSE",29,0 )
6124	Q
6125	"RTN","RCC PCSE",30,0 )
6126	PRINT ; P RCA4.531 3 Determin e print de vice then enter Sort
6127	"RTN","RCC PCSE",31,0 )
6128	D HOME^%Z IS S %ZIS= "QN" D ^%Z IS Q:POP
6129	"RTN","RCC PCSE",32,0 )
6130	I $D(IO(" Q")) D Q
6131	"RTN","RCC PCSE",33,0 )
6132	.S ZTRTN= "SORT^RCCP CSE",ZTDES C="CBSS PA TIENT STAT EMENT ERRO R REPORT"
6133	"RTN","RCC PCSE",34,0 )
6134	. S TMPQ= 1,(ZTSAVE( "DTPT("),Z TSAVE("SDT "),ZTSAVE( "ALL"),ZTS AVE("TMPQ" ))=""
6135	"RTN","RCC PCSE",35,0 )
6136	.D ^%ZTLO AD
6137	"RTN","RCC PCSE",36,0 )
6138	SORT ; PR CA4.5313 - Rewritt en to prin t by date
6139	"RTN","RCC PCSE",37,0 )
6140	S HDR="CB SS PATIENT STATEMENT ERROR REP ORT",LINE= "",$P(LINE ,"=",79)=" ",PG=1
6141	"RTN","RCC PCSE",38,0 )
6142	I 'ALL D SORT1,PRNT Q
6143	"RTN","RCC PCSE",39,0 )
6144	I ALL S S DT=""
6145	"RTN","RCC PCSE",40,0 )
6146	F S SDT= $O(DTPT(SD T)) Q:SDT= "" D SORT 1
6147	"RTN","RCC PCSE",41,0 )
6148	D PRNT
6149	"RTN","RCC PCSE",42,0 )
6150	; PRCA4. 5313 - Re move TMP s torage
6151	"RTN","RCC PCSE",43,0 )
6152	K ^TMP($J )
6153	"RTN","RCC PCSE",44,0 )
6154	Q
6155	"RTN","RCC PCSE",45,0 )
6156	SORT1 ;PR CA4.5313 Print a d ay of erro rs
6157	"RTN","RCC PCSE",46,0 )
6158	N IEN
6159	"RTN","RCC PCSE",47,0 )
6160	S IEN="" F S IEN=$ O(DTPT(SDT ,IEN)) Q:I EN="" D
6161	"RTN","RCC PCSE",48,0 )
6162	.S ERR=$G (^RCPS(349 .2,IEN,5))
6163	"RTN","RCC PCSE",49,0 )
6164	.S ^TMP($ J,"ERR",SD T,IEN)=$P( ^RCPS(349. 2,IEN,0)," ^",3)_"^"_ $P(^(0),"^ ",2)
6165	"RTN","RCC PCSE",50,0 )
6166	.S ADD=$G (^RCPS(349 .2,IEN,1))
6167	"RTN","RCC PCSE",51,0 )
6168	.F X=1:1: 6 S ADD(X) =$P(ADD,"^ ",X),^TMP( $J,"ERR",S DT,IEN,1+X )=ADD(X)
6169	"RTN","RCC PCSE",52,0 )
6170	.F X=1:5 S X1=X+4,E RROR=$E(ER R,X,X1) Q: ERROR="" D
6171	"RTN","RCC PCSE",53,0 )
6172	..S ^TMP( $J,"ERR",S DT,IEN,X+1 0)=ERROR
6173	"RTN","RCC PCSE",54,0 )
6174	..S ERROR =$O(^RCPSE (349.7,"B" ,$E(ERROR, 1,5),""))
6175	"RTN","RCC PCSE",55,0 )
6176	..S ERROR =$P($G(^RC PSE(349.7, +ERROR,0)) ,"^",4)
6177	"RTN","RCC PCSE",56,0 )
6178	..S ^TMP( $J,"ERR",S DT,IEN,X+1 0)=^TMP($J ,"ERR",SDT ,IEN,X+10) _"^"_ERROR
6179	"RTN","RCC PCSE",57,0 )
6180	;
6181	"RTN","RCC PCSE",58,0 )
6182	K ADD
6183	"RTN","RCC PCSE",59,0 )
6184	Q
6185	"RTN","RCC PCSE",60,0 )
6186	PRNT ; PR CA4.5313 - Print b ased upon statement date
6187	"RTN","RCC PCSE",61,0 )
6188	K DIRUT
6189	"RTN","RCC PCSE",62,0 )
6190	S (SDT,IE N)=""
6191	"RTN","RCC PCSE",63,0 )
6192	F S SDT= $O(^TMP($J ,"ERR",SDT )) Q:SDT=" " D Q:$D (DIRUT)
6193	"RTN","RCC PCSE",64,0 )
6194	. W @IOF, ?25,HDR,?7 5,PG,!,LIN E S PG=PG+ 1
6195	"RTN","RCC PCSE",65,0 )
6196	. W !,?20 ,"Patient Statement Date: "_$$ DATE^RCCPC PS1(SDT),! ,LINE
6197	"RTN","RCC PCSE",66,0 )
6198	. F S IE N=$O(^TMP( $J,"ERR",S DT,IEN)) Q :IEN="" D PRNT1 Q:$ D(DIRUT)
6199	"RTN","RCC PCSE",67,0 )
6200	. I 'TMPQ S DIR(0)= "E" D ^DIR Q:$D(DIRU T)
6201	"RTN","RCC PCSE",68,0 )
6202	Q
6203	"RTN","RCC PCSE",69,0 )
6204	PRNT1 ; P RCA4.531 3 - Print based upon statement date
6205	"RTN","RCC PCSE",70,0 )
6206	I ($Y+12) >IOSL D
6207	"RTN","RCC PCSE",71,0 )
6208	.I 'TMPQ S DIR(0)=" E" D ^DIR Q:$D(DIRUT )
6209	"RTN","RCC PCSE",72,0 )
6210	.W @IOF,? 25,HDR,?75 ,PG S PG=P G+1
6211	"RTN","RCC PCSE",73,0 )
6212	Q:$D(DIRU T)
6213	"RTN","RCC PCSE",74,0 )
6214	W !!,$E($ P(^TMP($J, "ERR",SDT, IEN),"^"), 1,25),?37, "ERROR COD ES",!,$P(^ (IEN),"^"
6215	,2),?30,$E (LINE,1,48 )
6216	"RTN","RCC PCSE",75,0 )
6217	F X=2:1:4 S:$G(^TMP ($J,"ERR", SDT,IEN,X) )]"" ADD(X )=^(X)
6218	"RTN","RCC PCSE",76,0 )
6219	S ADD(5)= $G(^TMP($J ,"ERR",SDT ,IEN,5))_" , "_$G(^(6 ))_" "_$G( ^(7))
6220	"RTN","RCC PCSE",77,0 )
6221	S X=7 F S X=$O(^TM P($J,"ERR" ,SDT,IEN,X )) Q:'X S ERR(X-1)= ^(X)
6222	"RTN","RCC PCSE",78,0 )
6223	S (Z,Y)=0 F D Q:Y =""&(Z="")
6224	"RTN","RCC PCSE",79,0 )
6225	.W !
6226	"RTN","RCC PCSE",80,0 )
6227	.I Z'="" S Z=$O(ADD (Z)) I Z'= "",(ADD(Z) ]"") W ADD (Z)
6228	"RTN","RCC PCSE",81,0 )
6229	.I Y'="" S Y=$O(ERR (Y)) I Y'= "" W ?30,$ P(ERR(Y)," ^"),?40,$P (ERR(Y),"^ ",2)
6230	"RTN","RCC PCSE",82,0 )
6231	W !,LINE
6232	"RTN","RCC PCSE",83,0 )
6233	Q
6234	"RTN","RCC PCSV")
6235	0^9^B11821 725^B51994 90
6236	"RTN","RCC PCSV",1,0)
6237	RCCPCSV ; WASH-ISC@A LTOONA,PA/ LDB-Receiv e and Proc ess CCPC m essages ;1 /6/97 11
6238	:36 AM
6239	"RTN","RCC PCSV",2,0)
6240	V ;;4.5;Ac counts Rec eivable; 34,70,87,3 13;Mar 2 0, 1995;Bu ild 113
6241	"RTN","RCC PCSV",3,0)
6242	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
6243	"RTN","RCC PCSV",4,0)
6244	;
6245	"RTN","RCC PCSV",5,0)
6246	EN ;INPUT FROM MESSA GE
6247	"RTN","RCC PCSV",6,0)
6248	RREC ;READ INCOMING MESSAGE
6249	"RTN","RCC PCSV",7,0)
6250	N DAT,DEB ,END,ERR,E RROR,EVN,K EY,LABEL,L N,MSG,P,RC MSG,RCTR,R CX,RCX1,RE ,SBAL,STO
6251	T,TR,TR0,T R1,TXT
6252	"RTN","RCC PCSV",8,0)
6253	N SDT,NOE RR,X,Y,DA
6254	"RTN","RCC PCSV",9,0)
6255	K ^TMP($J )
6256	"RTN","RCC PCSV",10,0 )
6257	S (LN,MSG ,RCX,RE)=0
6258	"RTN","RCC PCSV",11,0 )
6259	S TXT=0 F X XMREC Q:XMER<0!( XMRG="") S TXT=TXT+ 1,^TMP($J, "MSG",TXT) =XMRG
6260	"RTN","RCC PCSV",12,0 )
6261	S (DA(1), NOERR)=""
6262	"RTN","RCC PCSV",13,0 )
6263	S TXT=1 F S TXT=$O (^TMP($J," MSG",TXT)) Q:'TXT D
6264	"RTN","RCC PCSV",14,0 )
6265	.S:^TMP($ J,"MSG",TX T)?1"PA^". E DA(1)=4 S:^TMP($J, "MSG",TXT) ?1"IS".E D A(1)=3
6266	"RTN","RCC PCSV",15,0 )
6267	. ; PRCA* 4.5*313 - Set Statem ent date f rom PA or IS records
6268	"RTN","RCC PCSV",16,0 )
6269	. I "PAIS "[$E(^TMP( $J,"MSG",T XT),1,2) S X=$P(^TMP ($J,"MSG", TXT),"^",7 ) D ^%DT
6270	S SDT=Y
6271	"RTN","RCC PCSV",17,0 )
6272	. ; PRCA* 4.5*313 - If the dat e and sequ ence numbe r have alr eady been processed
6273	quit afte r setting an error
6274	"RTN","RCC PCSV",18,0 )
6275	. I "PAIS "[$P(^TMP( $J,"MSG",T XT),U) I ( $D(^RCT(34 9.1,DA(1), 4,"STDT4", SDT,$P(^T
6276	MP($J,"MSG ",TXT),U,2 )))) D Q
6277	"RTN","RCC PCSV",19,0 )
6278	. . S ERR ="Duplicat e file was received for Patien t Statemen t Date: "_ $P(^TMP($
6279	J,"MSG",TX T),U,7) D ERRMSG
6280	"RTN","RCC PCSV",20,0 )
6281	. . S ERR ="Last Mes sage Ackno wledgement Number: " _$P(^TMP($ J,"MSG",TX T),U,2) D
6282	ERRMSG
6283	"RTN","RCC PCSV",21,0 )
6284	. . S SDT =$P(^TMP($ J,"MSG",TX T),U,7)
6285	"RTN","RCC PCSV",22,0 )
6286	. ; PRCA* 4.5*313 - If IT is r eceived it always pr ocesses
6287	"RTN","RCC PCSV",23,0 )
6288	. I $P(^T MP($J,"MSG ",TXT),U)= "IT" S SDT =$P(^TMP($ J,"MSG",TX T),"^",6), NOERR=1 Q
6289	"RTN","RCC PCSV",24,0 )
6290	.I $G(XMZ )=""!('DA( 1))!($D(ER R)) Q
6291	"RTN","RCC PCSV",25,0 )
6292	.S RCX=RC X+1
6293	"RTN","RCC PCSV",26,0 )
6294	. I "PAIS ADID"[$E(^ TMP($J,"MS G",TXT),1, 2) D
6295	"RTN","RCC PCSV",27,0 )
6296	. . ; PRC A4.5313 - Add Stat ement Date to 349.1, five leve l for PA, IS, AD, a
6297	nd ID reco rds
6298	"RTN","RCC PCSV",28,0 )
6299	. . N DIN UM,DIC,X
6300	"RTN","RCC PCSV",29,0 )
6301	. . S DIN UM=+$G(XMZ )_RCX
6302	"RTN","RCC PCSV",30,0 )
6303	. . S DIC ="^RCT(349 .1,DA(1),5 ,"
6304	"RTN","RCC PCSV",31,0 )
6305	. . S X=$ P(^TMP($J, "MSG",TXT) ,"^",2)
6306	"RTN","RCC PCSV",32,0 )
6307	. . S DIC (0)="L"
6308	"RTN","RCC PCSV",33,0 )
6309	. . S DIC ("DR")=".0 2////"_$P( ^TMP($J,"M SG",TXT)," ^",3)_";.0 3////"_$G( XMZ)_";.0
6310	4////"_SDT
6311	"RTN","RCC PCSV",34,0 )
6312	. . D FIL E^DICN
6313	"RTN","RCC PCSV",35,0 )
6314	. ; PRCA* 4.5*313 - If process ing has oc curred
6315	"RTN","RCC PCSV",36,0 )
6316	. S NOERR =1
6317	"RTN","RCC PCSV",37,0 )
6318	;
6319	"RTN","RCC PCSV",38,0 )
6320	K DA(1)
6321	"RTN","RCC PCSV",39,0 )
6322	I NOERR D SEG,KILL^ XM
6323	"RTN","RCC PCSV",40,0 )
6324	I $O(^TMP ($J,"ERR", 0)) D
6325	"RTN","RCC PCSV",41,0 )
6326	. ; PRCA* 4.5*313 - Change CCP C to CBSS and add da te
6327	"RTN","RCC PCSV",42,0 )
6328	.S XMSUB= "CBSS ERRO R MESSAGE TO STATION FOR "_SDT
6329	"RTN","RCC PCSV",43,0 )
6330	.S XMDUZ= "AR PACKAG E"
6331	"RTN","RCC PCSV",44,0 )
6332	.S XMTEXT ="^TMP($J, "_"""ERR"" ,"
6333	"RTN","RCC PCSV",45,0 )
6334	.I $O(^XM B(3.8,"B", "RCCPC STA TEMENTS",0 )) S XMY(" G.RCCPC ST ATEMENTS") =""
6335	"RTN","RCC PCSV",46,0 )
6336	.D ^XMD
6337	"RTN","RCC PCSV",47,0 )
6338	.K ^TMP($ J)
6339	"RTN","RCC PCSV",48,0 )
6340	. ; PRCA* 4.5*313 - Change to send SDT f or resend
6341	"RTN","RCC PCSV",49,0 )
6342	.D:$G(RE) ="R"&($G(S DT)'="") E N^RCCPCML( SDT)
6343	"RTN","RCC PCSV",50,0 )
6344	E S XMZ= XQMSG,XMSE R="S."_XQS OP D REMSB MSG^XMA1C
6345	"RTN","RCC PCSV",51,0 )
6346	Q
6347	"RTN","RCC PCSV",52,0 )
6348	;
6349	"RTN","RCC PCSV",53,0 )
6350	SEG S RCMS G=1 S RCMS G=$O(^TMP( $J,"MSG",R CMSG)) D
6351	"RTN","RCC PCSV",54,0 )
6352	.S RCTR=^ TMP($J,"MS G",RCMSG)
6353	"RTN","RCC PCSV",55,0 )
6354	.S LABEL= $S(($P(RCT R,"^")]"") &($T(@($P( RCTR,"^")) )]""):$P(R CTR,"^"),1 :"ERROR")
6355	"RTN","RCC PCSV",56,0 )
6356	.D @(LABE L)
6357	"RTN","RCC PCSV",57,0 )
6358	Q
6359	"RTN","RCC PCSV",58,0 )
6360	;
6361	"RTN","RCC PCSV",59,0 )
6362	ERROR ;SEN D ERROR ME SSAGE TO M AIL GROUP
6363	"RTN","RCC PCSV",60,0 )
6364	;
6365	"RTN","RCC PCSV",61,0 )
6366	; PRCA4. 5313 - Ch ange CCPC to CBSS
6367	"RTN","RCC PCSV",62,0 )
6368	S ERR="CB SS ERROR - CANNOT RE AD MESSAGE FROM CBSS " D ERRMSG
6369	"RTN","RCC PCSV",63,0 )
6370	S ERR="An error has occurred in reading a message from the CBSS."
6371	"RTN","RCC PCSV",64,0 )
6372	D ERRMSG
6373	"RTN","RCC PCSV",65,0 )
6374	S ERR="Pl ease conta ct your IR M for assi stance."
6375	"RTN","RCC PCSV",66,0 )
6376	D ERRMSG
6377	"RTN","RCC PCSV",67,0 )
6378	S ERR="Th e MESSAGE WAS AS FOL LOWS:"
6379	"RTN","RCC PCSV",68,0 )
6380	D ERRMSG
6381	"RTN","RCC PCSV",69,0 )
6382	S ERR=^TM P($J,"MSG" ,RCMSG)
6383	"RTN","RCC PCSV",70,0 )
6384	D ERRMSG
6385	"RTN","RCC PCSV",71,0 )
6386	Q
6387	"RTN","RCC PCSV",72,0 )
6388	;
6389	"RTN","RCC PCSV",73,0 )
6390	IS ;INVALI D STATEMEN T
6391	"RTN","RCC PCSV",74,0 )
6392	D IS^RCCP CSV1
6393	"RTN","RCC PCSV",75,0 )
6394	Q
6395	"RTN","RCC PCSV",76,0 )
6396	;
6397	"RTN","RCC PCSV",77,0 )
6398	PA ;STATEM ENT ACKNOW LEDGEMENT
6399	"RTN","RCC PCSV",78,0 )
6400	D PA^RCCP CSV1
6401	"RTN","RCC PCSV",79,0 )
6402	Q
6403	"RTN","RCC PCSV",80,0 )
6404	;
6405	"RTN","RCC PCSV",81,0 )
6406	IT ;INVALI D TRANSMIS SION
6407	"RTN","RCC PCSV",82,0 )
6408	D IT^RCCP CSV1
6409	"RTN","RCC PCSV",83,0 )
6410	Q
6411	"RTN","RCC PCSV",84,0 )
6412	;
6413	"RTN","RCC PCSV",85,0 )
6414	ERRMSG ;ER ROR MESSAG E
6415	"RTN","RCC PCSV",86,0 )
6416	S LN=LN+1 ,^TMP($J," ERR",LN)=E RR
6417	"RTN","RCC PCSV",87,0 )
6418	Q
6419	"RTN","RCC PCSV1")
6420	0^12^B4366 3255^B3201 7096
6421	"RTN","RCC PCSV1",1,0 )
6422	RCCPCSV1 ; WASH-ISC@A LTOONA,PA/ LDB-Receiv e and Proc ess CCPC m essages ;1 /6/97 2:
6423	54 PM
6424	"RTN","RCC PCSV1",2,0 )
6425	;;4.5;Acc ounts Rece ivable;*3 4,70,76,13 0,153,313 *;Mar 20, 1995;Build 113
6426	"RTN","RCC PCSV1",3,0 )
6427	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
6428	"RTN","RCC PCSV1",4,0 )
6429	;
6430	"RTN","RCC PCSV1",5,0 )
6431	IS ;INVALI D STATEMEN T
6432	"RTN","RCC PCSV1",6,0 )
6433	; PRCA4. 5313 - Ad d SDT for Patient St atement Da te
6434	"RTN","RCC PCSV1",7,0 )
6435	N SDAT,SD T,X,Y,ERR
6436	"RTN","RCC PCSV1",8,0 )
6437	S SDAT=$P (RCTR,"^", 7) S (X,SD T)=SDAT D ^%DT S SDA T=Y
6438	"RTN","RCC PCSV1",9,0 )
6439	D CHKTRAN (LABEL)
6440	"RTN","RCC PCSV1",10, 0)
6441	S ERR="The following statement s did not print due to errors: " D ERRMSG
6442	"RTN","RCC PCSV1",11, 0)
6443	S ERR=" " D ERRMSG
6444	"RTN","RCC PCSV1",12, 0)
6445	S ERR=" KEY ER ROR" D ERR MSG S ERR= " " D ERRM SG
6446	"RTN","RCC PCSV1",13, 0)
6447	D ID
6448	"RTN","RCC PCSV1",14, 0)
6449	S ERR="If these err ors are co rrected, t hese state ments will not print until" D
6450	ERRMSG S ERR="the n ext billin g cycle." D ERRMSG
6451	"RTN","RCC PCSV1",15, 0)
6452	Q
6453	"RTN","RCC PCSV1",16, 0)
6454	;
6455	"RTN","RCC PCSV1",17, 0)
6456	ID ;INVALI D STATEMEN T DETAIL E RROR
6457	"RTN","RCC PCSV1",18, 0)
6458	F S RCMS G=$O(^TMP( $J,"MSG",R CMSG)) Q:' RCMSG D
6459	"RTN","RCC PCSV1",19, 0)
6460	. ; PRCA* 4.5*313 - Clean up v ariables
6461	"RTN","RCC PCSV1",20, 0)
6462	. N KEY,D EB,ERROR,R CX,RCX1,ER R,LN
6463	"RTN","RCC PCSV1",21, 0)
6464	.I $P(^TM P($J,"MSG" ,RCMSG),"^ ")'="ID" S ERR="ERRO R IN READI NG CBSS ER ROR RECOR
6465	D" D ERRMS G Q
6466	"RTN","RCC PCSV1",22, 0)
6467	.S KEY=$P (^TMP($J," MSG",RCMSG ),"^",2),K EY=$TR(KEY ," ",""),K EY=$E(KEY, $F(KEY,$$
6468	SITE^RCMSI TE),999)
6469	"RTN","RCC PCSV1",23, 0)
6470	.I KEY']" " D KEYERR Q
6471	"RTN","RCC PCSV1",24, 0)
6472	.S DEB=$O (^RCPS(349 .2,"AKEY", KEY,0)) I 'DEB D KEY ERR Q
6473	"RTN","RCC PCSV1",25, 0)
6474	.S ERROR= $P(^TMP($J ,"MSG",RCM SG),"^",3) ,^RCPS(349 .2,+DEB,5) =ERROR
6475	"RTN","RCC PCSV1",26, 0)
6476	.F RCX=1: 5:21 S RCX 1=RCX+4 S ERR(0)=$E( ERROR,RCX, RCX1) Q:ER R(0)="" D
6477	"RTN","RCC PCSV1",27, 0)
6478	..S ERR(1 )=$O(^RCPS E(349.7,"B ",ERR(0)," "))
6479	"RTN","RCC PCSV1",28, 0)
6480	..I 'ERR( 1) S ERR=" NO ERROR D ESCRIPTION FOR ERROR CODE: "_E RR(0)
6481	"RTN","RCC PCSV1",29, 0)
6482	..I ERR(1 ) S ERR=$P (^RCPSE(34 9.7,+ERR(1 ),0),"^",4 )
6483	"RTN","RCC PCSV1",30, 0)
6484	..S ERR=K EY_" "_ERR (0)_" "_ER R
6485	"RTN","RCC PCSV1",31, 0)
6486	..D ERRMS G
6487	"RTN","RCC PCSV1",32, 0)
6488	..S ERR=" " D ERRMS G
6489	"RTN","RCC PCSV1",33, 0)
6490	.S ^RCPS( 349.2,+DEB ,5)=$P(^TM P($J,"MSG" ,RCMSG),"^ ",3)
6491	"RTN","RCC PCSV1",34, 0)
6492	.S ^RCPS( 349.2,"AD" ,"E",+DEB) =""
6493	"RTN","RCC PCSV1",35, 0)
6494	Q
6495	"RTN","RCC PCSV1",36, 0)
6496	;
6497	"RTN","RCC PCSV1",37, 0)
6498	;
6499	"RTN","RCC PCSV1",38, 0)
6500	KEYERR ;SE ND MESSAGE TO MAIL G ROUP INDIC ATING NO K EY
6501	"RTN","RCC PCSV1",39, 0)
6502	S ERR="CB SS ERROR M ESSAGE - N O AR KEY I D FOR CBSS KEY: "_KE Y D ERRMSG
6503	"RTN","RCC PCSV1",40, 0)
6504	S ERR="Th is patient record is corrupted . Please c ontact IRM ." D ERRMS G
6505	"RTN","RCC PCSV1",41, 0)
6506	S ERR=" " D ERRMSG
6507	"RTN","RCC PCSV1",42, 0)
6508	Q
6509	"RTN","RCC PCSV1",43, 0)
6510	;
6511	"RTN","RCC PCSV1",44, 0)
6512	PA ;STATEM ENT ACKNOW LEDGEMENT
6513	"RTN","RCC PCSV1",45, 0)
6514	N STDT,SS TDT,SDAT,S DT,IEN,DEB ,X,Y,STOT, SEQ,KEY,EN D,SBAL,EVN ,DA,DIK
6515	"RTN","RCC PCSV1",46, 0)
6516	Q:$P(RCTR ,"^")'="PA "
6517	"RTN","RCC PCSV1",47, 0)
6518	; D CHKTR AN(LABEL)
6519	"RTN","RCC PCSV1",48, 0)
6520	S (X,SDT) =$P(RCTR," ^",7) D ^% DT S SDAT= Y
6521	"RTN","RCC PCSV1",49, 0)
6522	D CHKTRAN (LABEL)
6523	"RTN","RCC PCSV1",50, 0)
6524	S STOT=+$ P(RCTR,"^" ,6)
6525	"RTN","RCC PCSV1",51, 0)
6526	S SEQ=+$P (RCTR,"^", 3)
6527	"RTN","RCC PCSV1",52, 0)
6528	F S RCMS G=$O(^TMP( $J,"MSG",R CMSG)) Q:' RCMSG D
6529	"RTN","RCC PCSV1",53, 0)
6530	. N P
6531	"RTN","RCC PCSV1",54, 0)
6532	.S RCTR=^ TMP($J,"MS G",RCMSG)
6533	"RTN","RCC PCSV1",55, 0)
6534	.Q:$P(RCT R,"^")'="A D"
6535	"RTN","RCC PCSV1",56, 0)
6536	.S KEY=$P (RCTR,"^", 2),KEY=$TR (KEY," "," "),KEY=$E( KEY,$F(KEY ,$$SITE^RC MSITE),99
6537	9)
6538	"RTN","RCC PCSV1",57, 0)
6539	.I KEY']" " D KEYERR Q
6540	"RTN","RCC PCSV1",58, 0)
6541	.;PRCA4. 5313 - Fi nd Debtor using IEN from 349.2
6542	"RTN","RCC PCSV1",59, 0)
6543	.S IEN=$O (^RCPS(349 .2,"AKEY", KEY,0))
6544	"RTN","RCC PCSV1",60, 0)
6545	.I '$G(IE N) D KEYER R Q
6546	"RTN","RCC PCSV1",61, 0)
6547	.S DEB=$P (^RCPS(349 .2,IEN,0), U)
6548	"RTN","RCC PCSV1",62, 0)
6549	.;PRCA4. 5313 - Ch ange DEB t o IEN for all date f rom 349.2
6550	"RTN","RCC PCSV1",63, 0)
6551	.I IEN S END=$P(^RC PS(349.2,+ IEN,0),"^" ,10)
6552	"RTN","RCC PCSV1",64, 0)
6553	.S:'$G(EN D) END=$O( ^RCPS(349. 2,"STDT",S DAT,0)),EN D=$P($G(^( +END,0))," ^",10)
6554	"RTN","RCC PCSV1",65, 0)
6555	.F P=13:1 :17 S SBAL (P)=$P(^RC PS(349.2,+ IEN,0),"^" ,P)
6556	"RTN","RCC PCSV1",66, 0)
6557	.;update patient st atement da te in 341 to end pro cess time
6558	"RTN","RCC PCSV1",67, 0)
6559	.D OPEN^R CEVDRV1(2, $P(^RCD(34 0,DEB,0),U ),END,DUZ, $$SITE^RCM SITE,.ERR, .EVN,SBAL
6560	(13)_U_SBA L(14)_U_SB AL(15)_U_S BAL(16)_U_ SBAL(17))
6561	"RTN","RCC PCSV1",68, 0)
6562	.I EVN S DR=".07/// /"_END_";. 11////"_1, DA=+EVN,DI E="^RC(341 ," D ^DIE K DIE,DR,
6563	DA
6564	"RTN","RCC PCSV1",69, 0)
6565	. ; PRCA* 4.5*313 - Add cross- reference for File
6566	"RTN","RCC PCSV1",70, 0)
6567	.I EVN S $P(^RC(341 ,+EVN,6)," ^")=$G(SDA T) D
6568	"RTN","RCC PCSV1",71, 0)
6569	. . S DA= +EVN,DIK=" ^RC(341," D IX1^DIK
6570	"RTN","RCC PCSV1",72, 0)
6571	.;update bill file 430 letter fields
6572	"RTN","RCC PCSV1",73, 0)
6573	.NEW BN,D A,DIC,DIE, DR,II,LET, NOT,X,Y
6574	"RTN","RCC PCSV1",74, 0)
6575	.S DIE="^ PRCA(430," ,NOT=0,BN= 0
6576	"RTN","RCC PCSV1",75, 0)
6577	.F S BN= $O(^PRCA(4 30,"AS",DE B,16,BN)) Q:'BN S D A=BN D
6578	"RTN","RCC PCSV1",76, 0)
6579	..S LET=$ G(^PRCA(43 0,BN,6))
6580	"RTN","RCC PCSV1",77, 0)
6581	..I $P(LE T,"^",21)> END Q
6582	"RTN","RCC PCSV1",78, 0)
6583	..S END=$ G(SDAT)
6584	"RTN","RCC PCSV1",79, 0)
6585	..F II=1: 1:4 Q:$P(L ET,U,II)=E ND I $P(L ET,U,II)=" " S DR=$S( II=1:61,II =2:62,II=
6586	3:63,1:68) _"////^S X ="_END_";6 8.1////^S X="_END D ^DIE Q
6587	"RTN","RCC PCSV1",80, 0)
6588	.;PRCA4. 5313 - Ch ange DEB t o IEN for all date f rom 349.2
6589	"RTN","RCC PCSV1",81, 0)
6590	.S ^RCPS( 349.2,+IEN ,6)=1
6591	"RTN","RCC PCSV1",82, 0)
6592	PAMAIL ;
6593	"RTN","RCC PCSV1",83, 0)
6594	N XMSUB,X MY,XMDUZ,X MTEXT,MSG
6595	"RTN","RCC PCSV1",84, 0)
6596	; PRCA4. 5313 - Ch ange to CB SS
6597	"RTN","RCC PCSV1",85, 0)
6598	S XMSUB=" Patient Ac knowledgme nts receiv ed from CB SS."
6599	"RTN","RCC PCSV1",86, 0)
6600	S XMY("G. RCCPC STAT EMENTS")=" ",XMDUZ="A R PACKAGE" ,XMTEXT="M SG("
6601	"RTN","RCC PCSV1",87, 0)
6602	; PRCA4. 5313 - Ad d Patient Statement Date and r enumber ot her lines
6603	"RTN","RCC PCSV1",88, 0)
6604	S MSG(1)= "For Patie nt Stateme nt Date of "_SDT_"."
6605	"RTN","RCC PCSV1",89, 0)
6606	S MSG(2)= "Patient a cknowledgm ent messag e "_$G(XMZ )_" receiv ed."
6607	"RTN","RCC PCSV1",90, 0)
6608	S MSG(3)= "This mean s that CBS S has prin ted patien t statemen ts for thi s stateme
6609	nt period. "
6610	"RTN","RCC PCSV1",91, 0)
6611	D ^XMD
6612	"RTN","RCC PCSV1",92, 0)
6613	Q
6614	"RTN","RCC PCSV1",93, 0)
6615	;
6616	"RTN","RCC PCSV1",94, 0)
6617	CHKTRAN(LA BEL) ;Chec k for inco mplete mes sage from CCPC
6618	"RTN","RCC PCSV1",95, 0)
6619	; PRCA4. 5313 - Ad d multiple entries b ased upon date to fo ur level
6620	"RTN","RCC PCSV1",96, 0)
6621	Q:$G(LABE L)']""
6622	"RTN","RCC PCSV1",97, 0)
6623	N PSIEN,D A,DIK,DO,D IC,X
6624	"RTN","RCC PCSV1",98, 0)
6625	S LABEL(1 )=+$O(^RCT (349.1,"B" ,LABEL,0))
6626	"RTN","RCC PCSV1",99, 0)
6627	; PRCA4. 5313 - Ad d Patient Statement Date to fo ur level
6628	"RTN","RCC PCSV1",100 ,0)
6629	I LABEL(1 ),$P(^TMP( $J,"MSG",R CMSG),"^", 2)=$P(^TMP ($J,"MSG", RCMSG),"^" ,3) D
6630	"RTN","RCC PCSV1",101 ,0)
6631	. S DIC=" ^RCT(349.1 ,LABEL(1), 4,"
6632	"RTN","RCC PCSV1",102 ,0)
6633	. S X=$P( ^TMP($J,"M SG",RCMSG) ,"^",2)
6634	"RTN","RCC PCSV1",103 ,0)
6635	. S DA(1) =LABEL(1), DIC(0)="L"
6636	"RTN","RCC PCSV1",104 ,0)
6637	. S DIC(" DR")=".02/ ///"_$P(^T MP($J,"MSG ",RCMSG)," ^",3)_";.0 3////"_$G( XMZ)_";.0
6638	4////"_SDA T
6639	"RTN","RCC PCSV1",105 ,0)
6640	. D FILE^ DICN
6641	"RTN","RCC PCSV1",106 ,0)
6642	Q
6643	"RTN","RCC PCSV1",107 ,0)
6644	;
6645	"RTN","RCC PCSV1",108 ,0)
6646	TRANCHK ;C heck for c omplete AC K transmis sion
6647	"RTN","RCC PCSV1",109 ,0)
6648	; PRCA4. 5313 - Ch eck for st atement da tes five t o seven da ys in past since bu
6649	ild and tr ansmit.
6650	"RTN","RCC PCSV1",110 ,0)
6651	N X,Y,DAT E,SDT,I,X1 ,X2
6652	"RTN","RCC PCSV1",111 ,0)
6653	F I=-3:-1 :-5 S X1=D T,X2=I D C ^%DTC S (Y ,SDT)=X D DD^%DT S D ATE=Y D TR ANCHK1
6654	"RTN","RCC PCSV1",112 ,0)
6655	Q
6656	"RTN","RCC PCSV1",113 ,0)
6657	;
6658	"RTN","RCC PCSV1",114 ,0)
6659	TRANCHK1 ; PRCA4.5 313 - Vali date trans mission co mpleteness for date provided.
6660	"RTN","RCC PCSV1",115 ,0)
6661	N MSG,RCT ,SEG,SEQ,I EN,XMDUZ,X MSUB,XMTEX T,XMY
6662	"RTN","RCC PCSV1",116 ,0)
6663	F RCT=3,4 S IEN=$O( ^RCT(349.1 ,RCT,4,"ST DT4",SDT,0 )) I IEN'= "",$P($G(^ RCT(349.1
6664	,+RCT,4,IE N,0)),"^") '=$P($G(^R CT(349.1,+ RCT,4,IEN, 0)),"^",2) D
6665	"RTN","RCC PCSV1",117 ,0)
6666	.S XMDUZ= "AR PACKAG E"
6667	"RTN","RCC PCSV1",118 ,0)
6668	. ; PRCA* 4.5*313 - Change CCP C to CBSS
6669	"RTN","RCC PCSV1",119 ,0)
6670	.S XMSUB= "CBSS ACKN OWLEDGMENT TRANSMISS ION(S) INC OMPLETE"
6671	"RTN","RCC PCSV1",120 ,0)
6672	.I $O(^XM B(3.8,"B", "RCCPC STA TEMENTS",0 )) S XMY(" G.RCCPC ST ATEMENTS") ="" E S
6673	XMY(.5)=""
6674	"RTN","RCC PCSV1",121 ,0)
6675	.S XMTEXT ="MSG("
6676	"RTN","RCC PCSV1",122 ,0)
6677	.S SEG=$S (RCT=3:"IS ",1:"PA")
6678	"RTN","RCC PCSV1",123 ,0)
6679	.S SEG(1) =$P(^RCT(3 49.1,+RCT, 4,IEN,0)," ^",2)
6680	"RTN","RCC PCSV1",124 ,0)
6681	.; PRCA4 .5313 - A dd line id entifying Patient St atement Da te that er rored
6682	"RTN","RCC PCSV1",125 ,0)
6683	.S MSG(2) ="For Pati ent Statem ent Date o f "_DATE_" ."
6684	"RTN","RCC PCSV1",126 ,0)
6685	. ; PRCA* 4.5*313 - Change CCP C to CBSS
6686	"RTN","RCC PCSV1",127 ,0)
6687	.S MSG(3) ="The last "_SEG_" s egment mes sage recei ved from C BSS was nu mbered "_
6688	SEG(1)_"."
6689	"RTN","RCC PCSV1",128 ,0)
6690	.S MSG(4) ="This was not label ed the fin al message in that s egment typ e transmi
6691	ssion."
6692	"RTN","RCC PCSV1",129 ,0)
6693	.S MSG(5) ="This may cause pat ient state ment infor mation to be missing ."
6694	"RTN","RCC PCSV1",130 ,0)
6695	.S MSG(6) ="The last message n umber rece ived was " _$P($G(^RC T(349.1,RC T,4,IEN,0
6696	)),"^",3)
6697	"RTN","RCC PCSV1",131 ,0)
6698	. ; PRCA* 4.5*313 - Change CCP C to CBSS
6699	"RTN","RCC PCSV1",132 ,0)
6700	.S MSG(7) ="Please c ontact the CBSS in A ustin."
6701	"RTN","RCC PCSV1",133 ,0)
6702	.D ^XMD
6703	"RTN","RCC PCSV1",134 ,0)
6704	Q
6705	"RTN","RCC PCSV1",135 ,0)
6706	;
6707	"RTN","RCC PCSV1",136 ,0)
6708	;
6709	"RTN","RCC PCSV1",137 ,0)
6710	IT ;INVALI D TRANSMIS SION
6711	"RTN","RCC PCSV1",138 ,0)
6712	; PRCA4. 5313 - Ch ange messa ge from CC PC to CBSS
6713	"RTN","RCC PCSV1",139 ,0)
6714	N SDT,ERR ,MSG,RCX,R CX1,ERROR, RE
6715	"RTN","RCC PCSV1",140 ,0)
6716	S ERR="Th e CBSS pat ient state ment messa ges were n ot accepte d by CBSS" D ERRMSG
6717	"RTN","RCC PCSV1",141 ,0)
6718	; PRCA4. 5313 - Ad d statemen t date to error mess age
6719	"RTN","RCC PCSV1",142 ,0)
6720	S SDT=$P( ^TMP($J,"M SG",RCMSG) ,"^",6)
6721	"RTN","RCC PCSV1",143 ,0)
6722	S ERR="fo r "_SDT_" due to the following error(s): " D ERRMSG
6723	"RTN","RCC PCSV1",144 ,0)
6724	S ERR=" " D ERRMSG
6725	"RTN","RCC PCSV1",145 ,0)
6726	S RCMSG=1 F S RCMS G=$O(^TMP( $J,"MSG",R CMSG)) Q:' RCMSG D
6727	"RTN","RCC PCSV1",146 ,0)
6728	.S MSG=^T MP($J,"MSG ",RCMSG)
6729	"RTN","RCC PCSV1",147 ,0)
6730	.S MSG=$P (MSG,"^",8 )
6731	"RTN","RCC PCSV1",148 ,0)
6732	.F RCX=1: 5:21 S RCX 1=RCX+4 S ERROR=$E(M SG,RCX,RCX 1) Q:ERROR ="" D
6733	"RTN","RCC PCSV1",149 ,0)
6734	..S ERR(1 )=$O(^RCPS E(349.7,"B ",ERROR,"" ))
6735	"RTN","RCC PCSV1",150 ,0)
6736	..I 'ERR( 1) S ERR=" NO ERROR D ESCRIPTION FOR ERROR CODE: "_E RROR
6737	"RTN","RCC PCSV1",151 ,0)
6738	..I ERR(1 ) S ERR=$P (^RCPSE(34 9.7,+ERR(1 ),0),"^",4 ),ERR=ERRO R_" "_ERR
6739	"RTN","RCC PCSV1",152 ,0)
6740	..I ERR(1 ) S:$P(^RC PSE(349.7, +ERR(1),0) ,"^",3)="R " RE=1
6741	"RTN","RCC PCSV1",153 ,0)
6742	..D ERRMS G
6743	"RTN","RCC PCSV1",154 ,0)
6744	S ERR=" " D ERRMSG
6745	"RTN","RCC PCSV1",155 ,0)
6746	S ERR="Pl ease conta ct IRM."
6747	"RTN","RCC PCSV1",156 ,0)
6748	D ERRMSG
6749	"RTN","RCC PCSV1",157 ,0)
6750	Q
6751	"RTN","RCC PCSV1",158 ,0)
6752	;
6753	"RTN","RCC PCSV1",159 ,0)
6754	ERRMSG ;ER ROR MESSAG E
6755	"RTN","RCC PCSV1",160 ,0)
6756	S LN=LN+1 ,^TMP($J," ERR",LN)=E RR
6757	"RTN","RCC PCSV1",161 ,0)
6758	Q
6759	"RTN","RCC PCT")
6760	0^15^B2364 1825^B2489 697
6761	"RTN","RCC PCT",1,0)
6762	RCCPCT ;WA SH-ISC@ALT OONA,PA/LD B - CCPC P atient Sta tement mes sage total s ;11/7/9
6763	6 10:53 A M
6764	"RTN","RCC PCT",2,0)
6765	;;4.5;Acc ounts Rece ivable;3 4,313;Ma r 20, 1995 ;Build 113
6766	"RTN","RCC PCT",3,0)
6767	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
6768	"RTN","RCC PCT",4,0)
6769	EN ;
6770	"RTN","RCC PCT",5,0)
6771	D GO
6772	"RTN","RCC PCT",6,0)
6773	K TDT,TDT 1,TDT2,TDT 3,DATE,PTO T,TTOT,L,X ,Y,Y1,Y2,D ,IEN,DTOUT ,POP,Q,%,% DT,%ZIS,%
6774	Y
6775	"RTN","RCC PCT",7,0)
6776	Q
6777	"RTN","RCC PCT",8,0)
6778	GO ;
6779	"RTN","RCC PCT",9,0)
6780	W @IOF W !,"This re port will print the total Pati ent Statem ents sent to CBSS a
6781	nd the"
6782	"RTN","RCC PCT",10,0)
6783	W !,"tota l acknowle dged as ha ving been printed wi th three d ifferent r eport"
6784	"RTN","RCC PCT",11,0)
6785	W !,"form ats availa ble."
6786	"RTN","RCC PCT",12,0)
6787	W !!,"The first for mat is jus t a single summary t otal repor t of all S tatement"
6788	"RTN","RCC PCT",13,0)
6789	W !,"Date s."
6790	"RTN","RCC PCT",14,0)
6791	W !!,"The second fo rmat is al l Statemen t Dates pr inted indi vidually w ith total
6792	s"
6793	"RTN","RCC PCT",15,0)
6794	W !,"and a summary total at t he end."
6795	"RTN","RCC PCT",16,0)
6796	W !!,"The third for mat is pri nting the totals for a single Statement Date sele
6797	cted.",!
6798	"RTN","RCC PCT",17,0)
6799	N X K DIR S DIR(0)= "E",DIR("A ")="Press Return to Continue o r ^ to Exi t" D ^DIR
6800	K DIR I X ="^" Q
6801	"RTN","RCC PCT",18,0)
6802	S IEN="" F S IEN=$ O(^RCT(349 ,"SDT",IEN )) Q:IEN=" " S TDT(I EN)=""
6803	"RTN","RCC PCT",19,0)
6804	W @IOF W !!,"The fo llowing Pa tient Stat ement Date s are avai lable for the Total
6805	s Report:" ,!
6806	"RTN","RCC PCT",20,0)
6807	S TDT1="" F S TDT1 =$O(TDT(TD T1)) Q:TDT 1="" D
6808	"RTN","RCC PCT",21,0)
6809	.S TDT3=$ P(^RCT(349 ,$O(^RCT(3 49,"SDT",T DT1,0)),0) ,"^",9) W !,$$DATE^R CCPCPS1(T
6810	DT3)
6811	"RTN","RCC PCT",22,0)
6812	W !!,"Do you want t o print a single tot al for ALL the avail able dates "
6813	"RTN","RCC PCT",23,0)
6814	S %=1 D Y N^DICN I % Y="^" Q
6815	"RTN","RCC PCT",24,0)
6816	I %=1 D Q
6817	"RTN","RCC PCT",25,0)
6818	.D HOME^% ZIS S %ZIS ="AEQ" D ^ %ZIS Q:POP
6819	"RTN","RCC PCT",26,0)
6820	.I $D(IO( "Q")) D Q
6821	"RTN","RCC PCT",27,0)
6822	..S Q=1
6823	"RTN","RCC PCT",28,0)
6824	..S ZTRTN ="STARTS^R CCPCT",ZTD ESC="CBSS ALL PATIEN T STATEMEN TS TOTAL R EPORT"
6825	"RTN","RCC PCT",29,0)
6826	..S ZTSAV E("Q")="", ZTSAVE("TD T(")=""
6827	"RTN","RCC PCT",30,0)
6828	..D ^%ZTL OAD
6829	"RTN","RCC PCT",31,0)
6830	..K ZTRTN ,ZTDESC,ZT SAVE
6831	"RTN","RCC PCT",32,0)
6832	.E D STA RTS Q
6833	"RTN","RCC PCT",33,0)
6834	W !!,"Do you want t o print se parate tot als for AL L the avai lable date s"
6835	"RTN","RCC PCT",34,0)
6836	S %=1 D Y N^DICN I % Y="^" Q
6837	"RTN","RCC PCT",35,0)
6838	I %=1 D Q
6839	"RTN","RCC PCT",36,0)
6840	.D HOME^% ZIS S %ZIS ="AEQ" D ^ %ZIS Q:POP
6841	"RTN","RCC PCT",37,0)
6842	.I $D(IO( "Q")) D Q
6843	"RTN","RCC PCT",38,0)
6844	..S Q=1
6845	"RTN","RCC PCT",39,0)
6846	..S ZTRTN ="START^RC CPCT",ZTDE SC="CBSS A LL PATIENT STATEMENT S TOTAL RE PORT"
6847	"RTN","RCC PCT",40,0)
6848	..S ZTSAV E("Q")="", ZTSAVE("TD T(")=""
6849	"RTN","RCC PCT",41,0)
6850	..D ^%ZTL OAD
6851	"RTN","RCC PCT",42,0)
6852	..K ZTRTN ,ZTDESC,ZT SAVE
6853	"RTN","RCC PCT",43,0)
6854	.E D STA RT Q
6855	"RTN","RCC PCT",44,0)
6856	W ! S %DT ="AEXP",%D T("A")="En ter a sing le Patient Statement date: "
6857	"RTN","RCC PCT",45,0)
6858	D ^%DT Q: (X="^")!($ D(DTOUT))! (Y=-1)
6859	"RTN","RCC PCT",46,0)
6860	S Y1=+$E( Y,6,7),Y2= Y
6861	"RTN","RCC PCT",47,0)
6862	I '$D(TDT (Y1)) W !, "There are no record s for that date." Q
6863	"RTN","RCC PCT",48,0)
6864	D HOME^%Z IS S %ZIS= "AEQ" D ^% ZIS Q:POP
6865	"RTN","RCC PCT",49,0)
6866	I $D(IO(" Q")) D Q
6867	"RTN","RCC PCT",50,0)
6868	.S Q=1
6869	"RTN","RCC PCT",51,0)
6870	.S ZTRTN= "START1^RC CPCT",ZTDE SC="CBSS A LL PATIENT STATEMENT S TOTAL RE PORT"
6871	"RTN","RCC PCT",52,0)
6872	.S ZTSAVE ("Q")="",Z TSAVE("Y1" )="",ZTSAV E("Y2")=""
6873	"RTN","RCC PCT",53,0)
6874	.D ^%ZTLO AD
6875	"RTN","RCC PCT",54,0)
6876	.K ZTRTN, ZTDESC,ZTS AVE
6877	"RTN","RCC PCT",55,0)
6878	START1 ;Th is will pr int a summ ary total for a sing le date
6879	"RTN","RCC PCT",56,0)
6880	N PTOT,TT OT,X,D
6881	"RTN","RCC PCT",57,0)
6882	U IO S (T TOT,X)=0 F S X=$O(^ RCT(349,"S DT",Y1,X)) Q:'X I $ D(^RCT(349 ,X,0)) S
6883	TTOT=$P(^R CT(349,X,0 ),"^",7)+T TOT
6884	"RTN","RCC PCT",58,0)
6885	S (PTOT,X )=0 F S X =$O(^RCPS( 349.2,"STD T",Y2,X)) Q:'X I $G (^RCPS(349 .2,X,6))
6886	S PTOT=PTO T+1
6887	"RTN","RCC PCT",59,0)
6888	I IOST?1" C".E W @IO F
6889	"RTN","RCC PCT",60,0)
6890	W !,?10," CBSS Messa ge Totals for ",$$DA TE^RCCPCPS 1(Y2),!!
6891	"RTN","RCC PCT",61,0)
6892	W "Transm ission Sta tement Tot al : ",$J (TTOT,9)
6893	"RTN","RCC PCT",62,0)
6894	W !,"CBSS Statement s Printed Total : ", $J(PTOT,9)
6895	"RTN","RCC PCT",63,0)
6896	W !,"==== ========== ========== ======="
6897	"RTN","RCC PCT",64,0)
6898	W !,"Tota l Not Prin ted : ", $J(TTOT-PT OT,9),!
6899	"RTN","RCC PCT",65,0)
6900	I '$D(Q) S DIR(0)=" E",DIR("A" )=" Press ENTER to C ontinue" D ^DIR K DI R
6901	"RTN","RCC PCT",66,0)
6902	Q
6903	"RTN","RCC PCT",67,0)
6904	START ;Thi s will pri nt separat e totals f or all ava ilable sta tement dat es
6905	"RTN","RCC PCT",68,0)
6906	N PTOT,TT OT,X,X1,DA TE S (TTOT ,PTOT,X,X1 )=0 S DATE =""
6907	"RTN","RCC PCT",69,0)
6908	U IO S (T DT1,TDT2)= ""
6909	"RTN","RCC PCT",70,0)
6910	I IOST?1" C".E W @IO F
6911	"RTN","RCC PCT",71,0)
6912	F S TDT1 =$O(TDT(TD T1)) Q:TDT 1="" D
6913	"RTN","RCC PCT",72,0)
6914	.I X="^" Q
6915	"RTN","RCC PCT",73,0)
6916	.S TTOT=0
6917	"RTN","RCC PCT",74,0)
6918	.F S TDT 2=$O(^RCT( 349,"SDT", TDT1,TDT2) ) Q:TDT2=" " D
6919	"RTN","RCC PCT",75,0)
6920	..S Y=$P( ^RCT(349,T DT2,0),"^" ,9)
6921	"RTN","RCC PCT",76,0)
6922	..S Y1=+$ E(Y,3,4),D ATE=$$DATE ^RCCPCPS1( Y)
6923	"RTN","RCC PCT",77,0)
6924	..S X=Y D ^%DT
6925	"RTN","RCC PCT",78,0)
6926	..I $D(^R CT(349,TDT 2,0)) S TT OT=$P(^RCT (349,TDT2, 0),"^",7)+ TTOT
6927	"RTN","RCC PCT",79,0)
6928	..S PTOT= 0,X1="" I $D(^RCPS(3 49.2,"STDT ",Y)) F S X1=$O(^RC PS(349.2," STDT",Y,X
6929	1)) Q:'X1 I $G(^RCP S(349.2,X1 ,6)) S PTO T=PTOT+1
6930	"RTN","RCC PCT",80,0)
6931	.W !,?10, "CBSS Mess age Totals for ",DAT E,!!
6932	"RTN","RCC PCT",81,0)
6933	.W "Trans mission St atement To tal : ",$ J(TTOT,9)
6934	"RTN","RCC PCT",82,0)
6935	.W !,"CBS S Statemen ts Printed Total : " ,$J(PTOT,9 )
6936	"RTN","RCC PCT",83,0)
6937	.W !,"=== ========== ========== ========"
6938	"RTN","RCC PCT",84,0)
6939	.W !,"Tot al Not Pri nted : " ,$J(TTOT-P TOT,9),!
6940	"RTN","RCC PCT",85,0)
6941	.I '$D(Q) I $Y+4>IO SL D
6942	"RTN","RCC PCT",86,0)
6943	..K DIR S DIR(0)="E ",DIR("A") ="Press Re turn to Co ntinue or ^ to Exit"
6944	"RTN","RCC PCT",87,0)
6945	..D ^DIR K DIR W @I OF
6946	"RTN","RCC PCT",88,0)
6947	I X="^" Q
6948	"RTN","RCC PCT",89,0)
6949	W !!!," ****** ****** ****** ****** ******** *"
6950	"RTN","RCC PCT",90,0)
6951	STARTS ; T his will p rint the s ummary tot al for ALL available statement s
6952	"RTN","RCC PCT",91,0)
6953	N DATE,PT OT,TTOT,X, D
6954	"RTN","RCC PCT",92,0)
6955	U IO S (T TOT,D)=0 F S D=$O(T DT(D)) Q:D ="" S X=0 F S X=$O (^RCT(349, "SDT",D,X
6956	)) Q:X="" I $D(^RCT (349,X,0)) S TTOT=$P (^RCT(349, X,0),"^",7 )+TTOT
6957	"RTN","RCC PCT",93,0)
6958	S (PTOT,X )=0 F S X =$O(^RCPS( 349.2,X)) Q:'X I $G (^(X,6)) S PTOT=PTOT +1
6959	"RTN","RCC PCT",94,0)
6960	W !!,?10, "CBSS Mess age Totals for ALL a vailable d ates ",!!
6961	"RTN","RCC PCT",95,0)
6962	W "Transm ission Sta tement Tot al : ",$J (TTOT,9)
6963	"RTN","RCC PCT",96,0)
6964	W !,"CBSS Statement s Printed Total : ", $J(PTOT,9)
6965	"RTN","RCC PCT",97,0)
6966	W !,"==== ========== ========== ======="
6967	"RTN","RCC PCT",98,0)
6968	W !,"Tota l Not Prin ted : ", $J(TTOT-PT OT,9),!
6969	"RTN","RCC PCT",99,0)
6970	I '$D(Q) S DIR(0)=" E",DIR("A" )=" Press ENTER to C ontinue" D ^DIR K DI R
6971	"VER")
6972	8.0^22.2
6973	"^DD",340, 340,.01,0)
6974	DEBTOR^RV^ ^0;1^
6975	"^DD",340, 340,.01,1, 0)
6976	^.1
6977	"^DD",340, 340,.01,1, 1,0)
6978	340^B
6979	"^DD",340, 340,.01,1, 1,1)
6980	S ^RCD(340 ,"B",$E(X, 1,30),DA)= ""
6981	"^DD",340, 340,.01,1, 1,2)
6982	K ^RCD(340 ,"B",$E(X, 1,30),DA)
6983	"^DD",340, 340,.01,1, 1,3)
6984	Needed for look-up o f informat ion by Deb tor
6985	"^DD",340, 340,.01,1, 1,"%D",0)
6986	^^2^2^2931 014^^^^
6987	"^DD",340, 340,.01,1, 1,"%D",1,0 )
6988	This is th e regular FileMan 'B ' cross-re ference an d is used throughout the
6989	"^DD",340, 340,.01,1, 1,"%D",2,0 )
6990	AR package for users to look u p informat ion by deb tor.
6991	"^DD",340, 340,.01,1, 2,0)
6992	^^TRIGGER^ 340^.03
6993	"^DD",340, 340,.01,1, 2,1)
6994	X ^DD(340, .01,1,2,1. 3) I X S X =DIV S Y(1 )=$S($D(^R CD(340,D0, 0)):^(0),1 :"") S X=
6995	$P(Y(1),U, 3),X=X S D IU=X K Y X ^DD(340,. 01,1,2,1.1 ) X ^DD(34 0,.01,1,2, 1.4)
6996	"^DD",340, 340,.01,1, 2,1.1)
6997	S X=DIV S X=+$$ACSET ^RCCPCFN1( $P(^DPT($P ($P(^RCD(3 40,D0,0),U ),";"),0), U)) S:X X
6998	=+X
6999	"^DD",340, 340,.01,1, 2,1.3)
7000	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(0)=X S Y(1)=$S($ D(^RCD(340 ,D0,0)):^( 0),1:"")
7001	S X=$P(Y(1 ),U,3)="", Y(2)=X,Y(3 )=X S X=Y( 0),X=X S X =X[";DPT(" ,Y=X,X=Y(2 ),X=X&Y
7002	"^DD",340, 340,.01,1, 2,1.4)
7003	S DIH=$S($ D(^RCD(340 ,DIV(0),0) ):^(0),1:" "),DIV=X S $P(^(0),U ,3)=DIV,DI H=340,DIG
7004	=.03 D ^DI CR:$O(^DD( DIH,DIG,1, 0))>0
7005	"^DD",340, 340,.01,1, 2,2)
7006	Q
7007	"^DD",340, 340,.01,1, 2,3)
7008	Needed for assigning statement days for patients
7009	"^DD",340, 340,.01,1, 2,"%D",0)
7010	^.101^2^2^ 3160502^^^
7011	"^DD",340, 340,.01,1, 2,"%D",1,0 )
7012	This cross -reference sets the statement day for ne w patients as determ ined
7013	"^DD",340, 340,.01,1, 2,"%D",2,0 )
7014	by the fir st two let ters of th e patient' s last nam e.
7015	"^DD",340, 340,.01,1, 2,"CREATE CONDITION" )
7016	STATEMENT DAY=""&(IN TERNAL(DEB TOR)[";DPT (")
7017	"^DD",340, 340,.01,1, 2,"CREATE VALUE")
7018	S X=$$ACSE T^RCCPCFN1 ($P(^DPT($ P($P(^RCD( 340,D0,0) ,U),";"),0 ),U) S:X X =+X
7019	"^DD",340, 340,.01,1, 2,"DELETE VALUE")
7020	NO EFFECT
7021	"^DD",340, 340,.01,1, 2,"DT")
7022	2961010
7023	"^DD",340, 340,.01,1, 2,"FIELD")
7024	STATEMENT DAY
7025	"^DD",340, 340,.01,1, 3,0)
7026	340^AB^MUM PS
7027	"^DD",340, 340,.01,1, 3,1)
7028	S ^RCD(340 ,"AB",$P(X ,";",2),DA )=""
7029	"^DD",340, 340,.01,1, 3,2)
7030	K ^RCD(340 ,"AB",$P(X ,";",2),DA )
7031	"^DD",340, 340,.01,1, 3,3)
7032	Needed to cross-refe rence debt or file by 'type' of debtor
7033	"^DD",340, 340,.01,1, 3,"%D",0)
7034	^^5^5^2931 014^^^^
7035	"^DD",340, 340,.01,1, 3,"%D",1,0 )
7036	This cross -reference allows ra pid look-u p of debto rs in the debtor fil e
7037	"^DD",340, 340,.01,1, 3,"%D",2,0 )
7038	by the 'ty pe' of deb tor. Ther e are five types of debtors (P atient,
7039	"^DD",340, 340,.01,1, 3,"%D",3,0 )
7040	Insurance Company, I nstitution , Vendor, and Person ). This a llows
7041	"^DD",340, 340,.01,1, 3,"%D",4,0 )
7042	the AR sof tware to s can the fi le for onl y a specif ic type of debtor
7043	"^DD",340, 340,.01,1, 3,"%D",5,0 )
7044	rather tha n having t o look at each entry .
7045	"^DD",340, 340,.01,1, 3,"DT")
7046	2930526
7047	"^DD",340, 340,.01,1. 1)
7048	S X=DIV S X=+$$ACSET ^RCCPCFN1( $P(^DPT($P ($P(^RCD(3 40,D0,0),U ),"";""),0 ),U) S:X
7049	X=+X
7050	"^DD",340, 340,.01,3)
7051	Enter Debt or Informa tion
7052	"^DD",340, 340,.01,7. 5)
7053	S:$D(PRCAB T) DIC("V" )="I +Y(0) ="_$P("440 !(+Y(0)=4) ^440!(+Y(0 )=4)^440!( +Y(0)=200
7054	)",U,PRCAB T) S:$D(PR CAT) DIC(" V")="I +Y( 0)="_$S("C P"[PRCAT:2 ,"FV"[PRCA T:440,"T"
7055	[PRCAT:36, "N"[PRCAT: 4,"O"[PRCA T:200,1:"2 00!(+Y(0)= 440)")
7056	"^DD",340, 340,.01,21 ,0)
7057	^^5^5^2970 219^^^^
7058	"^DD",340, 340,.01,21 ,1,0)
7059	This field contains the debtor to which this accou nt belongs to. An
7060	"^DD",340, 340,.01,21 ,2,0)
7061	account ca n belong t o an insur ance compa ny, vendor , institut ion, perso n,
7062	"^DD",340, 340,.01,21 ,3,0)
7063	or patient . Account s can be s et up for Medical Ca re Cost Re covery cha rges
7064	"^DD",340, 340,.01,21 ,4,0)
7065	and also f or non-ben efit debts , such as: Employee bills, Ex- employee b ills,
7066	"^DD",340, 340,.01,21 ,5,0)
7067	and Vendor bills.
7068	"^DD",340, 340,.01,"D T")
7069	3160428
7070	"^DD",340, 340,.01,"V ",0)
7071	^.12P^5^5
7072	"^DD",340, 340,.01,"V ",1,0)
7073	2^PATIENT^ 1^P^n^n
7074	"^DD",340, 340,.01,"V ",1,1)
7075
7076	"^DD",340, 340,.01,"V ",1,2)
7077
7078	"^DD",340, 340,.01,"V ",2,0)
7079	200^OTHER (PERSON)^2 ^O^n^y
7080	"^DD",340, 340,.01,"V ",3,0)
7081	36^3RD PAR TY^4^I^n^n
7082	"^DD",340, 340,.01,"V ",4,0)
7083	4^INSTITUT ION^5^N^n^ n
7084	"^DD",340, 340,.01,"V ",5,0)
7085	440^VENDOR ^3^V^n^n
7086	"^DD",340, 340,.03,0)
7087	STATEMENT DAY^NJ2,0^ ^0;3^K:+X' =X!(X>28)! (X<1)!(X?. E1"."1N.N) X
7088	"^DD",340, 340,.03,1, 0)
7089	^.1
7090	"^DD",340, 340,.03,1, 1,0)
7091	340^AC
7092	"^DD",340, 340,.03,1, 1,1)
7093	S ^RCD(340 ,"AC",$E(X ,1,30),DA) =""
7094	"^DD",340, 340,.03,1, 1,2)
7095	K ^RCD(340 ,"AC",$E(X ,1,30),DA)
7096	"^DD",340, 340,.03,1, 1,3)
7097	Needed for printing of patient statement s and foll ow-up lett ers
7098	"^DD",340, 340,.03,1, 1,"%D",0)
7099	^^4^4^2931 014^^^^
7100	"^DD",340, 340,.03,1, 1,"%D",1,0 )
7101	This cross -reference is used t o print pa tient stat ements and Vendor, P erson,
7102	"^DD",340, 340,.03,1, 1,"%D",2,0 )
7103	and Instit ution foll ow-up lett ers. Sinc e these ty pe of debt ors get no tified
7104	"^DD",340, 340,.03,1, 1,"%D",3,0 )
7105	based on t heir state ment day, this cross -reference allows ra pid look-u p
7106	"^DD",340, 340,.03,1, 1,"%D",4,0 )
7107	of which d ebtor is d ue a notif ication on a particu lar day.
7108	"^DD",340, 340,.03,1, 1,"DT")
7109	2930309
7110	"^DD",340, 340,.03,3)
7111	Type a Num ber betwee n 1 and 28 , 0 Decima l Digits
7112	"^DD",340, 340,.03,5, 1,0)
7113	340^.01^2
7114	"^DD",340, 340,.03,21 ,0)
7115	^^19^19^31 60428^
7116	"^DD",340, 340,.03,21 ,1,0)
7117	A statemen t day is a ssigned to all types of debtor s, except insurance
7118	"^DD",340, 340,.03,21 ,2,0)
7119	companies. A statem ent day is the day t hat a stat ement is g enerated o r a
7120	"^DD",340, 340,.03,21 ,3,0)
7121	follow-up letter is generated for non-be nefit debt s. Except for
7122	"^DD",340, 340,.03,21 ,4,0)
7123	Patient St atements w hich are g enerated t wo days pr ior to thi s day.
7124	"^DD",340, 340,.03,21 ,5,0)
7125	The AR pac kage will hold 'noti fications' from bein g sent unt il the
7126	"^DD",340, 340,.03,21 ,6,0)
7127	debtor's ' statement day' arriv es. This allows all activity since the
7128	"^DD",340, 340,.03,21 ,7,0)
7129	previous s tatement t o print an d update t he debtor on the acc ount
7130	"^DD",340, 340,.03,21 ,8,0)
7131	activity.
7132	"^DD",340, 340,.03,21 ,9,0)
7133
7134	"^DD",340, 340,.03,21 ,10,0)
7135	Patient st atement da ys never c hange, but Instituti on, Person , and Vend or
7136	"^DD",340, 340,.03,21 ,11,0)
7137	statement days are c hanged by the AR sof tware. Wh en these t ype debtor s
7138	"^DD",340, 340,.03,21 ,12,0)
7139	have a new active bi ll, the da te the new active bi ll is crea ted become s
7140	"^DD",340, 340,.03,21 ,13,0)
7141	their 'sta tement day '. This s tatement d ay remains in effect until no
7142	"^DD",340, 340,.03,21 ,14,0)
7143	active bil ls exist f or the deb tor, at wh ich time t he stateme nt day
7144	"^DD",340, 340,.03,21 ,15,0)
7145	is 'delete d'.
7146	"^DD",340, 340,.03,21 ,16,0)
7147
7148	"^DD",340, 340,.03,21 ,17,0)
7149	Insurance companies are notifi ed based o n a bill-s pecific da te.
7150	"^DD",340, 340,.03,21 ,18,0)
7151	Since insu rance comp anies have much more activity, they are notified
7152	"^DD",340, 340,.03,21 ,19,0)
7153	on a const ant basis depending on each in dividual b ill 'due-d ate'.
7154	"^DD",340, 340,.03,"D T")
7155	3160428
7156	"^DD",340, 340,7.06,0 )
7157	CURRENT CB S DEBT AMO UNT^NJ9,2^ ^7;6^S:X[" $" X=$P(X, "$",2) K:X '?."-".N.1 ".".2N!(X
7158	>999999)!( X<-999999) X
7159	"^DD",340, 340,7.06,3 )
7160	Type a dol lar amount between - 999999 and 999999, 2 decimal d igits.
7161	"^DD",340, 340,7.06,2 1,0)
7162	^^7^7^3160 401^
7163	"^DD",340, 340,7.06,2 1,1,0)
7164	This field stores th e debt amo unt curren tly
7165	"^DD",340, 340,7.06,2 1,2,0)
7166	updated to the Conso lidated Bi lling Stat ement Syst em
7167	"^DD",340, 340,7.06,2 1,3,0)
7168	CBSS. Thi s field is used to c ompare the current
7169	"^DD",340, 340,7.06,2 1,4,0)
7170	amount at the CBSS w ith the am ount curre ntly
7171	"^DD",340, 340,7.06,2 1,5,0)
7172	available for receiv ing paymen t. For in creases
7173	"^DD",340, 340,7.06,2 1,6,0)
7174	or decreas es, the de bt amount is forward ed to
7175	"^DD",340, 340,7.06,2 1,7,0)
7176	CBSS.
7177	"^DD",340, 340,7.06," DT")
7178	3160401
7179	"^DD",341, 341,6.01,0 )
7180	CCPC STATE MENT DATE^ D^^6;1^S % DT="EX" D ^%DT S X=Y K:X<1 X
7181	"^DD",341, 341,6.01,1 ,0)
7182	^.1
7183	"^DD",341, 341,6.01,1 ,1,0)
7184	341^STDT
7185	"^DD",341, 341,6.01,1 ,1,1)
7186	S ^RC(341, "STDT",$E( X,1,30),DA )=""
7187	"^DD",341, 341,6.01,1 ,1,2)
7188	K ^RC(341, "STDT",$E( X,1,30),DA )
7189	"^DD",341, 341,6.01,1 ,1,"%D",0)
7190	^.101^2^2^ 3160809^^
7191	"^DD",341, 341,6.01,1 ,1,"%D",1, 0)
7192	This cross reference is used t o sort and print eve nts by the ir Patient
7193	"^DD",341, 341,6.01,1 ,1,"%D",2, 0)
7194	Statement date.
7195	"^DD",341, 341,6.01,1 ,1,"DT")
7196	3160803
7197	"^DD",341, 341,6.01,3 )
7198	Enter date of Patien t Statemen t.
7199	"^DD",341, 341,6.01,2 1,0)
7200	^^1^1^3160 921^
7201	"^DD",341, 341,6.01,2 1,1,0)
7202	This is th e date of the Patien t Statemen t from CBS S.
7203	"^DD",341, 341,6.01," DT")
7204	3160921
7205	"^DD",349, 349,.09,0)
7206	STATEMENT DATE^D^^0; 9^S %DT="E X" D ^%DT S X=Y K:X< 1 X
7207	"^DD",349, 349,.09,3)
7208	Enter the statement date.
7209	"^DD",349, 349,.09,21 ,0)
7210	^^1^1^3161 019^
7211	"^DD",349, 349,.09,21 ,1,0)
7212	This is th e patient statement date.
7213	"^DD",349, 349,.09,"D T")
7214	3161103
7215	"^DD",349. 1,349.1,0)
7216	FIELD^^40^ 14
7217	"^DD",349. 1,349.1,0, "DDA")
7218	N
7219	"^DD",349. 1,349.1,0, "DT")
7220	3161103
7221	"^DD",349. 1,349.1,0, "IX","B",3 49.1,.01)
7222
7223	"^DD",349. 1,349.1,0, "NM","AR T RANSMISSIO N TYPE")
7224
7225	"^DD",349. 1,349.1,0, "PT",349.9 ,.01)
7226
7227	"^DD",349. 1,349.1,0, "VRPK")
7228	PRCA
7229	"^DD",349. 1,349.1,.0 1,0)
7230	CODE^RF^^0 ;1^K:$L(X) >10!($L(X) <2)!'(X'?1 P.E) X
7231	"^DD",349. 1,349.1,.0 1,1,0)
7232	^.1
7233	"^DD",349. 1,349.1,.0 1,1,1,0)
7234	349.1^B
7235	"^DD",349. 1,349.1,.0 1,1,1,1)
7236	S ^RCT(349 .1,"B",$E( X,1,30),DA )=""
7237	"^DD",349. 1,349.1,.0 1,1,1,2)
7238	K ^RCT(349 .1,"B",$E( X,1,30),DA )
7239	"^DD",349. 1,349.1,.0 1,3)
7240	Answer mus t be 2-10 characters in length .
7241	"^DD",349. 1,349.1,.0 1,21,0)
7242	^.001^1^1^ 3040601^^^
7243	"^DD",349. 1,349.1,.0 1,21,1,0)
7244	This field will hold the uniqu e codes fo r the tran smission t ypes.
7245	"^DD",349. 1,349.1,.0 1,23,0)
7246	^^1^1^3040 601^
7247	"^DD",349. 1,349.1,.0 1,23,1,0)
7248
7249	"^DD",349. 1,349.1,.0 1,"DT")
7250	2960216
7251	"^DD",349. 1,349.1,.0 2,0)
7252	EXPANDED N AME^F^^0;2 ^K:$L(X)>3 0!($L(X)<3 ) X
7253	"^DD",349. 1,349.1,.0 2,3)
7254	Answer mus t be 3-30 characters in length .
7255	"^DD",349. 1,349.1,.0 2,21,0)
7256	^^1^1^2960 216^^
7257	"^DD",349. 1,349.1,.0 2,21,1,0)
7258	This is th e expanded name of t he transmi ssion type .
7259	"^DD",349. 1,349.1,.0 2,"DT")
7260	2960216
7261	"^DD",349. 1,349.1,.0 3,0)
7262	ACTIVE^S^0 :NO;1:YES; ^0;3^Q
7263	"^DD",349. 1,349.1,.0 3,21,0)
7264	^^1^1^2960 216^
7265	"^DD",349. 1,349.1,.0 3,21,1,0)
7266	This field will indi cate if th e transmis sion type is being u sed.
7267	"^DD",349. 1,349.1,.0 3,"DT")
7268	2960216
7269	"^DD",349. 1,349.1,.0 4,0)
7270	PURGE FREQ UENCY^NJ4, 0^^0;4^K:+ X'=X!(X>36 50)!(X<30) !(X?.E1"." 1N.N) X
7271	"^DD",349. 1,349.1,.0 4,3)
7272	Type a Num ber betwee n 30 and 3 650, 0 Dec imal Digit s
7273	"^DD",349. 1,349.1,.0 4,21,0)
7274	^^2^2^2960 216^^
7275	"^DD",349. 1,349.1,.0 4,21,1,0)
7276	This field indicates if and wh en a purge of the en tries will take
7277	"^DD",349. 1,349.1,.0 4,21,2,0)
7278	place.
7279	"^DD",349. 1,349.1,.0 4,23,0)
7280	^^2^2^2960 216^
7281	"^DD",349. 1,349.1,.0 4,23,1,0)
7282	Number of days that transmissi on records are on-li ne before
7283	"^DD",349. 1,349.1,.0 4,23,2,0)
7284	purging oc curs.
7285	"^DD",349. 1,349.1,.0 4,"DT")
7286	2960216
7287	"^DD",349. 1,349.1,1, 0)
7288	LOCAL ADDR ESSEE^349. 11P^^1;0
7289	"^DD",349. 1,349.1,2, 0)
7290	LOCAL MAIL GROUP^349. 12P^^2;0
7291	"^DD",349. 1,349.1,31 ,0)
7292	REMOTE ADD RESSEE^F^^ 3;1^K:$L(X )>30!($L(X )<1)!'(X?. A) X
7293	"^DD",349. 1,349.1,31 ,3)
7294	Answer mus t be 1-30 characters in length .
7295	"^DD",349. 1,349.1,31 ,21,0)
7296	^^1^1^2960 430^^^
7297	"^DD",349. 1,349.1,31 ,21,1,0)
7298	This is th e addresse e name at the remote domain.
7299	"^DD",349. 1,349.1,31 ,"DT")
7300	2960430
7301	"^DD",349. 1,349.1,32 ,0)
7302	REMOTE DOM AIN^P4.2'^ DIC(4.2,^3 ;2^Q
7303	"^DD",349. 1,349.1,32 ,1,0)
7304	^.1
7305	"^DD",349. 1,349.1,32 ,1,1,0)
7306	^^TRIGGER^ 349.1^33
7307	"^DD",349. 1,349.1,32 ,1,1,1)
7308	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(1)=$S( $D(^RCT(34 9.1,D0,3)) :^(3),1:"" ) S X=$P(
7309	Y(1),U,3), X=X S DIU= X K Y X ^D D(349.1,32 ,1,1,1.1) X ^DD(349. 1,32,1,1,1 .4)
7310	"^DD",349. 1,349.1,32 ,1,1,1.1)
7311	S X=DIV S I(0,0)=$S( $D(D0):D0, 1:""),D0=D IV S:'$D(^ DIC(4.2,+D 0,0)) D0=- 1 S Y(101
7312	)=$S($D(^D IC(4.2,D0, 0)):^(0),1 :"") S X=$ P(Y(101),U ,1) S D0=I (0,0)
7313	"^DD",349. 1,349.1,32 ,1,1,1.4)
7314	S DIH=$S($ D(^RCT(349 .1,DIV(0), 3)):^(3),1 :""),DIV=X S $P(^(3) ,U,3)=DIV, DIH=349.1
7315	,DIG=33 D ^DICR:$O(^ DD(DIH,DIG ,1,0))>0
7316	"^DD",349. 1,349.1,32 ,1,1,2)
7317	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(1)=$S( $D(^RCT(34 9.1,D0,3)) :^(3),1:"" ) S X=$P(
7318	Y(1),U,3), X=X S DIU= X K Y S X= "" X ^DD(3 49.1,32,1, 1,2.4)
7319	"^DD",349. 1,349.1,32 ,1,1,2.4)
7320	S DIH=$S($ D(^RCT(349 .1,DIV(0), 3)):^(3),1 :""),DIV=X S $P(^(3) ,U,3)=DIV, DIH=349.1
7321	,DIG=33 D ^DICR:$O(^ DD(DIH,DIG ,1,0))>0
7322	"^DD",349. 1,349.1,32 ,1,1,"CREA TE VALUE")
7323	REMOTE DOM AIN:.01
7324	"^DD",349. 1,349.1,32 ,1,1,"DELE TE VALUE")
7325	@
7326	"^DD",349. 1,349.1,32 ,1,1,"FIEL D")
7327	DOMAIN NAM E
7328	"^DD",349. 1,349.1,32 ,21,0)
7329	^.001^2^2^ 3000524^^^
7330	"^DD",349. 1,349.1,32 ,21,1,0)
7331	This is th e remote d omain wher e the tran smission r ecord is b eing
7332	"^DD",349. 1,349.1,32 ,21,2,0)
7333	sent.
7334	"^DD",349. 1,349.1,32 ,"DT")
7335	2960902
7336	"^DD",349. 1,349.1,33 ,0)
7337	DOMAIN NAM E^F^^3;3^K :$L(X)>30! ($L(X)<3) X
7338	"^DD",349. 1,349.1,33 ,3)
7339	Answer mus t be 3-30 characters in length .
7340	"^DD",349. 1,349.1,33 ,5,1,0)
7341	349.1^32^1
7342	"^DD",349. 1,349.1,33 ,9)
7343	^
7344	"^DD",349. 1,349.1,33 ,21,0)
7345	^^1^1^2960 902^
7346	"^DD",349. 1,349.1,33 ,21,1,0)
7347	This is th e name of the DOMAIN from file 4.2 DOMAI N.
7348	"^DD",349. 1,349.1,33 ,"DT")
7349	2960902
7350	"^DD",349. 1,349.1,34 ,0)
7351	RC MAIL AD DRESS^RFX^ ^3;4^K:$L( X)>30!($L( X)<3) X
7352	"^DD",349. 1,349.1,34 ,3)
7353	Answer mus t be 3-30 characters in length .
7354	"^DD",349. 1,349.1,34 ,4)
7355	D MAILADD^ RCRCXMS
7356	"^DD",349. 1,349.1,34 ,21,0)
7357	^.001^2^2^ 3040429^^^ ^
7358	"^DD",349. 1,349.1,34 ,21,1,0)
7359	This field will cont ain the Re gional Cou nsel mail address fo r the
7360	"^DD",349. 1,349.1,34 ,21,2,0)
7361	primary si te. It wi ll be the default ma il address .
7362	"^DD",349. 1,349.1,34 ,23,0)
7363	^.001^1^1^ 3040429^^^ ^
7364	"^DD",349. 1,349.1,34 ,23,1,0)
7365
7366	"^DD",349. 1,349.1,34 ,"DT")
7367	3040407
7368	"^DD",349. 1,349.1,35 ,0)
7369	RC DEATH N OTIFICATIO N ADDRESS^ RF^^3;5^K: $L(X)>40!( $L(X)<2) X
7370	"^DD",349. 1,349.1,35 ,3)
7371	Answer mus t be 2-40 characters in length .
7372	"^DD",349. 1,349.1,35 ,4)
7373	D DEATHADD ^RCRCXMS
7374	"^DD",349. 1,349.1,35 ,21,0)
7375	^.001^3^3^ 3040429^^^ ^
7376	"^DD",349. 1,349.1,35 ,21,1,0)
7377	This field contains the Region al Counsel mail addr ess for de ath
7378	"^DD",349. 1,349.1,35 ,21,2,0)
7379	notificati ons for th e primary site. Thi s will be the defaul t for deat h
7380	"^DD",349. 1,349.1,35 ,21,3,0)
7381	notificati ons.
7382	"^DD",349. 1,349.1,35 ,23,0)
7383	^.001^1^1^ 3040429^^^ ^
7384	"^DD",349. 1,349.1,35 ,23,1,0)
7385
7386	"^DD",349. 1,349.1,35 ,"DT")
7387	3040428
7388	"^DD",349. 1,349.1,40 ,0)
7389	MESSAGE AC KNOWLEDGEM ENT^349.14 1A^^4;0
7390	"^DD",349. 1,349.1,40 ,21,0)
7391	^^5^5^3160 429^
7392	"^DD",349. 1,349.1,40 ,21,1,0)
7393	Message Ac knowledgem ents conta in the top level of data for m essages
7394	"^DD",349. 1,349.1,40 ,21,2,0)
7395	received f rom Austin .
7396	"^DD",349. 1,349.1,40 ,21,3,0)
7397
7398	"^DD",349. 1,349.1,40 ,21,4,0)
7399	The IEN fo r the mult iple Messa ge Acknowl edgements is set in the code t o
7400	"^DD",349. 1,349.1,40 ,21,5,0)
7401	the day of the month for the P atient Sta tement.
7402	"^DD",349. 1,349.1,51 ,0)
7403	ACK MESSAG ES^349.151 A^^5;0
7404	"^DD",349. 1,349.1,51 ,21,0)
7405	^^1^1^3161 006^
7406	"^DD",349. 1,349.1,51 ,21,1,0)
7407	Acknowledg ement Mess ages recei ved from e xternal so urces.
7408	"^DD",349. 1,349.1,61 ,0)
7409	DIVISION O F CARE^349 .161PA^^6; 0
7410	"^DD",349. 1,349.1,61 ,21,0)
7411	^.001^4^4^ 3040517^^^ ^
7412	"^DD",349. 1,349.1,61 ,21,1,0)
7413	This field is a mult iple that allows div isions to be entered if their
7414	"^DD",349. 1,349.1,61 ,21,2,0)
7415	Regional C ounsel mai l addresse s and deat h notifica tion addre sses are
7416	"^DD",349. 1,349.1,61 ,21,3,0)
7417	different from the p rimary add resses.
7418	"^DD",349. 1,349.1,61 ,21,4,0)
7419
7420	"^DD",349. 1,349.1,61 ,23,0)
7421	^.001^1^1^ 3040517^^^ ^
7422	"^DD",349. 1,349.1,61 ,23,1,0)
7423
7424	"^DD",349. 1,349.1,61 ,"DT")
7425	3040514
7426	"^DD",349. 1,349.11,0 )
7427	LOCAL ADDR ESSEE SUB- FIELD^^.01 ^1
7428	"^DD",349. 1,349.11,0 ,"DT")
7429	2960216
7430	"^DD",349. 1,349.11,0 ,"IX","B", 349.11,.01 )
7431
7432	"^DD",349. 1,349.11,0 ,"NM","LOC AL ADDRESS EE")
7433
7434	"^DD",349. 1,349.11,0 ,"UP")
7435	349.1
7436	"^DD",349. 1,349.11,. 01,0)
7437	LOCAL ADDR ESSEE^MP20 0'^VA(200, ^0;1^Q
7438	"^DD",349. 1,349.11,. 01,1,0)
7439	^.1
7440	"^DD",349. 1,349.11,. 01,1,1,0)
7441	349.11^B
7442	"^DD",349. 1,349.11,. 01,1,1,1)
7443	S ^RCT(349 .1,DA(1),1 ,"B",$E(X, 1,30),DA)= ""
7444	"^DD",349. 1,349.11,. 01,1,1,2)
7445	K ^RCT(349 .1,DA(1),1 ,"B",$E(X, 1,30),DA)
7446	"^DD",349. 1,349.11,. 01,21,0)
7447	^^2^2^2960 216^
7448	"^DD",349. 1,349.11,. 01,21,1,0)
7449	The local users who wish to be recepient s of the t ransmissio n messages
7450	"^DD",349. 1,349.11,. 01,21,2,0)
7451	will named in this f ield.
7452	"^DD",349. 1,349.11,. 01,"DT")
7453	2960216
7454	"^DD",349. 1,349.12,0 )
7455	LOCAL MAIL GROUP SUB- FIELD^^.01 ^1
7456	"^DD",349. 1,349.12,0 ,"DT")
7457	2960216
7458	"^DD",349. 1,349.12,0 ,"IX","B", 349.12,.01 )
7459
7460	"^DD",349. 1,349.12,0 ,"NM","LOC AL MAILGRO UP")
7461
7462	"^DD",349. 1,349.12,0 ,"UP")
7463	349.1
7464	"^DD",349. 1,349.12,. 01,0)
7465	LOCAL MAIL GROUP^MP3. 8'^XMB(3.8 ,^0;1^Q
7466	"^DD",349. 1,349.12,. 01,1,0)
7467	^.1
7468	"^DD",349. 1,349.12,. 01,1,1,0)
7469	349.12^B
7470	"^DD",349. 1,349.12,. 01,1,1,1)
7471	S ^RCT(349 .1,DA(1),2 ,"B",$E(X, 1,30),DA)= ""
7472	"^DD",349. 1,349.12,. 01,1,1,2)
7473	K ^RCT(349 .1,DA(1),2 ,"B",$E(X, 1,30),DA)
7474	"^DD",349. 1,349.12,. 01,21,0)
7475	^^2^2^2960 216^
7476	"^DD",349. 1,349.12,. 01,21,1,0)
7477	This field is used t o define a ny mailgro ups which should rec eive the
7478	"^DD",349. 1,349.12,. 01,21,2,0)
7479	transmissi on message s.
7480	"^DD",349. 1,349.12,. 01,"DT")
7481	2960216
7482	"^DD",349. 1,349.141, 0)
7483	MESSAGE AC KNOWLEDGEM ENT SUB-FI ELD^^.04^4
7484	"^DD",349. 1,349.141, 0,"DT")
7485	3160425
7486	"^DD",349. 1,349.141, 0,"NM","ME SSAGE ACKN OWLEDGEMEN T")
7487
7488	"^DD",349. 1,349.141, 0,"UP")
7489	349.1
7490	"^DD",349. 1,349.141, .01,0)
7491	LAST MESSA GE ACK^NJ3 ,0X^^0;1^K :+X'=X!(X> 999)!(X<1) !(X?.E1"." 1.N) X
7492	"^DD",349. 1,349.141, .01,1,0)
7493	^.1^^0
7494	"^DD",349. 1,349.141, .01,3)
7495	Type a num ber betwee n 1 and 99 9, 0 decim al digits.
7496	"^DD",349. 1,349.141, .01,21,0)
7497	^^1^1^3160 425^
7498	"^DD",349. 1,349.141, .01,21,1,0 )
7499	Number of last messa ge type se nt from CB SS.
7500	"^DD",349. 1,349.141, .01,"DT")
7501	3161007
7502	"^DD",349. 1,349.141, .02,0)
7503	FINAL MESS AGE ACK^NJ 3,0^^0;2^K :+X'=X!(X> 999)!(X<1) !(X?.E1"." 1.N) X
7504	"^DD",349. 1,349.141, .02,3)
7505	Type a num ber betwee n 1 and 99 9, 0 decim al digits.
7506	"^DD",349. 1,349.141, .02,21,0)
7507	^^1^1^3160 425^
7508	"^DD",349. 1,349.141, .02,21,1,0 )
7509	Final mess age number of this t ype from C BSS.
7510	"^DD",349. 1,349.141, .02,"DT")
7511	3160425
7512	"^DD",349. 1,349.141, .03,0)
7513	LAST MESSA GE NUMBER^ NJ8,0^^0;3 ^K:+X'=X!( X>99999999 )!(X<1)!(X ?.E1"."1.N ) X
7514	"^DD",349. 1,349.141, .03,3)
7515	Type a num ber betwee n 1 and 99 999999, 0 decimal di gits.
7516	"^DD",349. 1,349.141, .03,21,0)
7517	^^2^2^3160 425^
7518	"^DD",349. 1,349.141, .03,21,1,0 )
7519	This is th e last mes sage numbe r of this type for t he last tr ansmission
7520	"^DD",349. 1,349.141, .03,21,2,0 )
7521	from CBSS.
7522	"^DD",349. 1,349.141, .03,"DT")
7523	3160425
7524	"^DD",349. 1,349.141, .04,0)
7525	PATIENT ST ATEMENT DA TE^DX^^0;4 ^S %DT="EX " D ^%DT S X=Y K:X<1 X
7526	"^DD",349. 1,349.141, .04,1,0)
7527	^.1^^0
7528	"^DD",349. 1,349.141, .04,3)
7529	Enter date of Patien t Statemen t.
7530	"^DD",349. 1,349.141, .04,21,0)
7531	^^1^1^3161 025^
7532	"^DD",349. 1,349.141, .04,21,1,0 )
7533	This is th e Patient Statement Date.
7534	"^DD",349. 1,349.141, .04,"DT")
7535	3161025
7536	"^DD",349. 1,349.151, 0)
7537	ACK MESSAG ES SUB-FIE LD^^.04^4
7538	"^DD",349. 1,349.151, 0,"DT")
7539	3161103
7540	"^DD",349. 1,349.151, 0,"NM","AC K MESSAGES ")
7541
7542	"^DD",349. 1,349.151, 0,"UP")
7543	349.1
7544	"^DD",349. 1,349.151, .01,0)
7545	ACK MESSAG ES^F^^0;1^ K:$L(X)>80 !($L(X)<3) X
7546	"^DD",349. 1,349.151, .01,1,0)
7547	^.1^^0
7548	"^DD",349. 1,349.151, .01,3)
7549	Answer mus t be 3-80 characters in length .
7550	"^DD",349. 1,349.151, .01,21,0)
7551	^^1^1^2970 106^^
7552	"^DD",349. 1,349.151, .01,21,1,0 )
7553	This multi ple will s tore the A cknowlegme nt message s from Aus tin.
7554	"^DD",349. 1,349.151, .01,"DT")
7555	3161005
7556	"^DD",349. 1,349.151, .02,0)
7557	ACCOUNT/SE G ID^F^^0; 2^K:$L(X)> 25!($L(X)< 3) X
7558	"^DD",349. 1,349.151, .02,3)
7559	Answer mus t be 3-25 characters in length .
7560	"^DD",349. 1,349.151, .02,21,0)
7561	^^1^1^2961 114^
7562	"^DD",349. 1,349.151, .02,21,1,0 )
7563	This field stores th e account id for the record.
7564	"^DD",349. 1,349.151, .02,"DT")
7565	2961205
7566	"^DD",349. 1,349.151, .03,0)
7567	ACCOUNT/SE G INFO^F^^ 0;3^K:$L(X )>40!($L(X )<3) X
7568	"^DD",349. 1,349.151, .03,3)
7569	Answer mus t be 3-40 characters in length .
7570	"^DD",349. 1,349.151, .03,21,0)
7571	^^1^1^2961 114^
7572	"^DD",349. 1,349.151, .03,21,1,0 )
7573	This field will stor e the deta iled infor mation abo ut the rec ord if any .
7574	"^DD",349. 1,349.151, .03,"DT")
7575	2961205
7576	"^DD",349. 1,349.151, .04,0)
7577	PATIENT ST ATEMENT DA TE^D^^0;4^ S %DT="EX" D ^%DT S X=Y K:X<1 X
7578	"^DD",349. 1,349.151, .04,3)
7579	Enter date of Patien t Statemen t.
7580	"^DD",349. 1,349.151, .04,21,0)
7581	^^1^1^3161 006^
7582	"^DD",349. 1,349.151, .04,21,1,0 )
7583	The Patien t Statemen t date for Acknowled gement Mes sages.
7584	"^DD",349. 1,349.151, .04,"DT")
7585	3161103
7586	"^DD",349. 1,349.161, 0)
7587	DIVISION O F CARE SUB -FIELD^^.0 4^4
7588	"^DD",349. 1,349.161, 0,"DT")
7589	3040429
7590	"^DD",349. 1,349.161, 0,"IX","B" ,349.161,. 01)
7591
7592	"^DD",349. 1,349.161, 0,"NM","DI VISION OF CARE")
7593
7594	"^DD",349. 1,349.161, 0,"UP")
7595	349.1
7596	"^DD",349. 1,349.161, .01,0)
7597	DIVISION O F CARE^P40 .8'^DG(40. 8,^0;1^Q
7598	"^DD",349. 1,349.161, .01,1,0)
7599	^.1
7600	"^DD",349. 1,349.161, .01,1,1,0)
7601	349.161^B
7602	"^DD",349. 1,349.161, .01,1,1,1)
7603	S ^RCT(349 .1,DA(1),6 ,"B",$E(X, 1,30),DA)= ""
7604	"^DD",349. 1,349.161, .01,1,1,2)
7605	K ^RCT(349 .1,DA(1),6 ,"B",$E(X, 1,30),DA)
7606	"^DD",349. 1,349.161, .01,21,0)
7607	^.001^1^1^ 3040517^^^ ^
7608	"^DD",349. 1,349.161, .01,21,1,0 )
7609	Enter divi sions of c are where bill charg es origina te for thi s site.
7610	"^DD",349. 1,349.161, .01,"DT")
7611	3000524
7612	"^DD",349. 1,349.161, .02,0)
7613	REMOTE DOM AIN^P4.2'^ DIC(4.2,^0 ;2^Q
7614	"^DD",349. 1,349.161, .02,3)
7615
7616	"^DD",349. 1,349.161, .02,21,0)
7617	^.001^1^1^ 3000524^^
7618	"^DD",349. 1,349.161, .02,21,1,0 )
7619	This is th e Remote D omain addr ess where transmissi ons will b e sent for this div
7620	ision.
7621	"^DD",349. 1,349.161, .02,"DT")
7622	3000524
7623	"^DD",349. 1,349.161, .03,0)
7624	RC MAIL AD DRESS^F^^0 ;3^K:$L(X) >30!($L(X) <3) X
7625	"^DD",349. 1,349.161, .03,3)
7626	Answer mus t be 3-30 characters in length .
7627	"^DD",349. 1,349.161, .03,4)
7628	D MAILADD^ RCRCXMS
7629	"^DD",349. 1,349.161, .03,21,0)
7630	^.001^4^4^ 3040429^^
7631	"^DD",349. 1,349.161, .03,21,1,0 )
7632	This field will cont ain the na me of the Regional C ounsel mai l address
7633	"^DD",349. 1,349.161, .03,21,2,0 )
7634	that trans actions fr om the ass ociated Di vision of Care will be sent.
7635	"^DD",349. 1,349.161, .03,21,3,0 )
7636	This field s address will be di fferent fr om the pri mary divis ion's
7637	"^DD",349. 1,349.161, .03,21,4,0 )
7638	RC mail ad dress.
7639	"^DD",349. 1,349.161, .03,23,0)
7640	^^1^1^3040 429^
7641	"^DD",349. 1,349.161, .03,23,1,0 )
7642
7643	"^DD",349. 1,349.161, .03,"DT")
7644	3040325
7645	"^DD",349. 1,349.161, .04,0)
7646	RC DEATH N OTIFICATIO N ADDRESS^ F^^0;4^K:$ L(X)>40!($ L(X)<3) X
7647	"^DD",349. 1,349.161, .04,3)
7648	Answer mus t be 3-40 characters in length .
7649	"^DD",349. 1,349.161, .04,4)
7650	D DEATHADD ^RCRCXMS
7651	"^DD",349. 1,349.161, .04,21,0)
7652	^.001^4^4^ 3040429^^^
7653	"^DD",349. 1,349.161, .04,21,1,0 )
7654	This field will cont ain the na me of the RC death n otificatio ns address
7655	"^DD",349. 1,349.161, .04,21,2,0 )
7656	that death notices f rom the as sociated D ivision of Care will be sent.
7657	"^DD",349. 1,349.161, .04,21,3,0 )
7658	This field s address will be di fferent fr om the pri mary divis ion's
7659	"^DD",349. 1,349.161, .04,21,4,0 )
7660	RC death n otificatio n address.
7661	"^DD",349. 1,349.161, .04,23,0)
7662	^.001^1^1^ 3040429^^
7663	"^DD",349. 1,349.161, .04,23,1,0 )
7664
7665	"^DD",349. 1,349.161, .04,"DT")
7666	3040429
7667	"^DD",349. 2,349.2,.0 1,0)
7668	PATIENT^RP 340'X^RCD( 340,^0;1^Q
7669	"^DD",349. 2,349.2,.0 1,1,0)
7670	^.1^^0
7671	"^DD",349. 2,349.2,.0 1,3)
7672	Enter the Debtor Num ber for th e Patient Statement.
7673	"^DD",349. 2,349.2,.0 1,21,0)
7674	^^2^2^3161 011^^
7675	"^DD",349. 2,349.2,.0 1,21,1,0)
7676	This is th e Debtor n umber to r eceive the Patient S tatement a ssociated
7677	"^DD",349. 2,349.2,.0 1,21,2,0)
7678	with the s pecific Pa tient.
7679	"^DD",349. 2,349.2,.0 1,"DT")
7680	3161011
7681	"^DD",349. 2,349.2,.0 2,0)
7682	SSN^RFXO^^ 0;2^K:$L(X )>10!($L(X )<9) X S X =$$SSN^RCF N01(+DA)
7683	"^DD",349. 2,349.2,.0 2,1,0)
7684	^.1
7685	"^DD",349. 2,349.2,.0 2,1,1,0)
7686	349.2^AKEY 1^MUMPS
7687	"^DD",349. 2,349.2,.0 2,1,1,1)
7688	I $P(^RCPS (349.2,+DA ,0),"^",3) ]"" S ^RCP S(349.2,"A KEY",$E(X, 1,9)_$TR($ E($P($P(^
7689	RCPS(349.2 ,+DA,0),"^ ",3),","), 1,5)," "," "),DA)=""
7690	"^DD",349. 2,349.2,.0 2,1,1,2)
7691	K ^RCPS(34 9.2,"AKEY" ,$E(X,1,9) _$TR($E($P ($P(^RCPS( 349.2,+DA, 0),"^",3), ","),1,5)
7692	," ",""))
7693	"^DD",349. 2,349.2,.0 2,1,1,"%D" ,0)
7694	^.101^1^1^ 3160427^^
7695	"^DD",349. 2,349.2,.0 2,1,1,"%D" ,1,0)
7696	This cross -reference is used t o key the statements for CBSS.
7697	"^DD",349. 2,349.2,.0 2,1,1,"DT" )
7698	2960924
7699	"^DD",349. 2,349.2,.0 2,2)
7700	S Y(0)=Y S Y=Y
7701	"^DD",349. 2,349.2,.0 2,2.1)
7702	S Y=Y
7703	"^DD",349. 2,349.2,.0 2,3)
7704	Answer mus t be 9-10 characters in length .
7705	"^DD",349. 2,349.2,.0 2,21,0)
7706	^^1^1^2960 418^^
7707	"^DD",349. 2,349.2,.0 2,21,1,0)
7708	This is th e SSN for the patien t.
7709	"^DD",349. 2,349.2,.0 2,"DT")
7710	2960924
7711	"^DD",349. 2,349.2,.0 3,0)
7712	PATIENT NA ME^RFX^^0; 3^K:$L(X)> 44!($L(X)< 3) X S X=$ $NAM^RCFN0 1(+DA)
7713	"^DD",349. 2,349.2,.0 3,1,0)
7714	^.1
7715	"^DD",349. 2,349.2,.0 3,1,1,0)
7716	349.2^AKEY 2^MUMPS
7717	"^DD",349. 2,349.2,.0 3,1,1,1)
7718	I $$KEY^RC CPCFN(+DA) ]"" S ^RCP S(349.2,"A KEY",$$KEY ^RCCPCFN(+ DA),DA)=""
7719	"^DD",349. 2,349.2,.0 3,1,1,2)
7720	I $P(^RCPS (349.2,+DA ,0),"^",2) >1 K ^RCPS (349.2,"AK EY",$E($P( ^RCPS(349. 2,+DA,0),
7721	"^",2),1,9 )_$TR($E($ P(X,","),1 ,5)," ","" ))
7722	"^DD",349. 2,349.2,.0 3,1,1,"%D" ,0)
7723	^^1^1^3160 427^
7724	"^DD",349. 2,349.2,.0 3,1,1,"%D" ,1,0)
7725	This cross -reference is used t o key the statements for CBSS.
7726	"^DD",349. 2,349.2,.0 3,1,1,"DT" )
7727	2960924
7728	"^DD",349. 2,349.2,.0 3,3)
7729	Answer mus t be 3-44 characters in length .
7730	"^DD",349. 2,349.2,.0 3,21,0)
7731	^^1^1^2960 418^^^^
7732	"^DD",349. 2,349.2,.0 3,21,1,0)
7733	This is th e patient name as it appears o n the stat ement.
7734	"^DD",349. 2,349.2,.0 3,"DT")
7735	2960924
7736	"^DD",349. 2,349.2,.1 2,0)
7737	INVALID ST ATEMENT ER ROR^P349.7 '^RCPSE(34 9.7,^0;12^ Q
7738	"^DD",349. 2,349.2,.1 2,3)
7739	Enter the error code for the r ecord that was not a ccepted by CBSS.
7740	"^DD",349. 2,349.2,.1 2,21,0)
7741	^^1^1^3160 427^
7742	"^DD",349. 2,349.2,.1 2,21,1,0)
7743	This is th e error co de for the record th at was not accepted by CBSS.
7744	"^DD",349. 2,349.2,.1 2,"DT")
7745	3160909
7746	"^DD",349. 2,349.2,.1 8,0)
7747	CBSS FILE BUILT^S^0: NOT BUILT; 1:BUILT;^0 ;18^Q
7748	"^DD",349. 2,349.2,.1 8,3)
7749	Enter a '1 ' when the CBSS PATI ENT STATEM ENTS file is complet e.
7750	"^DD",349. 2,349.2,.1 8,21,0)
7751	^^2^2^3160 909^^
7752	"^DD",349. 2,349.2,.1 8,21,1,0)
7753	This field will stor e a marker that the CBSS PATIE NT STATEME NTS file
7754	"^DD",349. 2,349.2,.1 8,21,2,0)
7755	(349.2) is a complet e file for that stat ement day.
7756	"^DD",349. 2,349.2,.1 8,"DT")
7757	3160921
7758	"^DD",349. 2,349.2,.1 9,0)
7759	PATIENT ST ATEMENT DA TE^D^^0;19 ^S %DT="EX " D ^%DT S X=Y K:X<1 X
7760	"^DD",349. 2,349.2,.1 9,3)
7761	Enter the date of th e Patient Statement.
7762	"^DD",349. 2,349.2,.1 9,21,0)
7763	^^2^2^3161 019^
7764	"^DD",349. 2,349.2,.1 9,21,1,0)
7765	Date Patie nt Stateme nt will di splay on p rinted ver sion. Thi s date is
7766	"^DD",349. 2,349.2,.1 9,21,2,0)
7767	standardly two days after the statement is transmi tted
7768	"^DD",349. 2,349.2,.1 9,"DT")
7769	3161103
7770	"^DD",349. 2,349.2,51 ,0)
7771	ERROR CODE (S)^F^^5;1 ^K:$L(X)>3 0!($L(X)<5 ) X
7772	"^DD",349. 2,349.2,51 ,1,0)
7773	^.1^^0
7774	"^DD",349. 2,349.2,51 ,3)
7775	Answer mus t be 5-30 characters in length .
7776	"^DD",349. 2,349.2,51 ,21,0)
7777	^^2^2^3161 007^
7778	"^DD",349. 2,349.2,51 ,21,1,0)
7779	These are the error codes sent back by C BSS when a statement cannot be
7780	"^DD",349. 2,349.2,51 ,21,2,0)
7781	printed.
7782	"^DD",349. 2,349.2,51 ,"DT")
7783	3161007
7784	"^DD",349. 2,349.2,61 ,0)
7785	CBSS PRINT ED^S^1:Y;0 :N;^6;1^Q
7786	"^DD",349. 2,349.2,61 ,3)
7787	Enter whet her the pa tient stat ement for this patie nt printed at the CB SS.
7788	"^DD",349. 2,349.2,61 ,21,0)
7789	^^2^2^3160 909^^
7790	"^DD",349. 2,349.2,61 ,21,1,0)
7791	This field indicates whether t he patient statement for this patient pr inted
7792	"^DD",349. 2,349.2,61 ,21,2,0)
7793	at the CCP C or not.
7794	"^DD",349. 2,349.2,61 ,"DT")
7795	3160921
7796	"^DD",349. 2,349.2,81 ,0)
7797	INTEGRATIO N CONTROL NUMBER^NJ1 2,0^^8;1^K :+X'=X!(X> 9999999999 99)!(X<0)! (X?.E1"."
7798	1.N) X
7799	"^DD",349. 2,349.2,81 ,3)
7800	Enter the ICN, a num ber betwee n 0 and 99 9999999999 with no d ecimal dig its.
7801	"^DD",349. 2,349.2,81 ,21,0)
7802	^^2^2^3160 909^
7803	"^DD",349. 2,349.2,81 ,21,1,0)
7804	Machine to machine i dentifier for a pati ent. This field can only be
7805	"^DD",349. 2,349.2,81 ,21,2,0)
7806	edited by CIRN.
7807	"^DD",349. 2,349.2,81 ,"DT")
7808	3160921
7809	"^DD",349. 2,349.2,82 ,0)
7810	ICN CHECKS UM^F^^8;2^ K:$L(X)>6! ($L(X)<6) X
7811	"^DD",349. 2,349.2,82 ,3)
7812	Answer mus t be 6 cha racters in length.
7813	"^DD",349. 2,349.2,82 ,21,0)
7814	^^2^2^3160 428^
7815	"^DD",349. 2,349.2,82 ,21,1,0)
7816	This check sum is the calculate d checksum for the I ntegration Control
7817	"^DD",349. 2,349.2,82 ,21,2,0)
7818	Number. I t verifies the integ rity of th e ICN.
7819	"^DD",349. 2,349.2,82 ,"DT")
7820	3160428
7821	"^DD",349. 2,349.2,83 ,0)
7822	AR FLAG^S^ T:TRUE;F:F ALSE;^8;3^ Q
7823	"^DD",349. 2,349.2,83 ,3)
7824	Enter T fo r 'TRUE' o r F for 'F alse', for whether t he patient address w as obtain
7825	ed from AR storage.
7826	"^DD",349. 2,349.2,83 ,21,0)
7827	^^2^2^3160 428^
7828	"^DD",349. 2,349.2,83 ,21,1,0)
7829	This is a set of cod e, indicat ing whethe r or not t he address was taken
7830	"^DD",349. 2,349.2,83 ,21,2,0)
7831	from the A R DEBTOR ( #340).
7832	"^DD",349. 2,349.2,83 ,"DT")
7833	3160921
7834	"^DD",349. 2,349.2,84 ,0)
7835	DATE OF LA TEST BILL^ DX^^8;4^S %DT="EX" D ^%DT S X= Y K:X<1 X
7836	"^DD",349. 2,349.2,84 ,3)
7837	Enter the date on wh ich the la test bill was establ ished.
7838	"^DD",349. 2,349.2,84 ,21,0)
7839	^^1^1^3160 428^^
7840	"^DD",349. 2,349.2,84 ,21,1,0)
7841	The date t he latest bill was p repared. Time is no t allowed.
7842	"^DD",349. 2,349.2,84 ,"DT")
7843	3160921
7844	"^DD",349. 5,349.5,0)
7845	FIELD^^1^7
7846	"^DD",349. 5,349.5,0, "DT")
7847	3170224
7848	"^DD",349. 5,349.5,0, "IX","B",3 49.5,.01)
7849
7850	"^DD",349. 5,349.5,0, "NM","AR A NNUAL PAYM ENT STATEM ENT")
7851
7852	"^DD",349. 5,349.5,.0 1,0)
7853	PS SEGMENT NUMBER^RN J4,0^^0;1^ K:+X'=X!(X >9999)!(X< 1)!(X?.E1" ."1.N) X
7854	"^DD",349. 5,349.5,.0 1,1,0)
7855	^.1
7856	"^DD",349. 5,349.5,.0 1,1,1,0)
7857	349.5^B
7858	"^DD",349. 5,349.5,.0 1,1,1,1)
7859	S ^RCAP(34 9.5,"B",$E (X,1,30),D A)=""
7860	"^DD",349. 5,349.5,.0 1,1,1,2)
7861	K ^RCAP(34 9.5,"B",$E (X,1,30),D A)
7862	"^DD",349. 5,349.5,.0 1,3)
7863	Enter the PS Segment Number (a number be tween 1 an d 9999).
7864	"^DD",349. 5,349.5,.0 1,21,0)
7865	^^1^1^3170 223^
7866	"^DD",349. 5,349.5,.0 1,21,1,0)
7867	This is th e Segment Number for the "PS" Record Ide ntifier.
7868	"^DD",349. 5,349.5,.0 1,"DT")
7869	3170224
7870	"^DD",349. 5,349.5,.0 2,0)
7871	YEAR^NJ3,0 ^^0;2^K:+X '=X!(X>400 )!(X<300)! (X?.E1"."1 .N) X
7872	"^DD",349. 5,349.5,.0 2,3)
7873	Enter the Year for t his segmen t in Inter nal FileMa n Format ( a number b etween 30
7874	0 and 400) .
7875	"^DD",349. 5,349.5,.0 2,21,0)
7876	^^1^1^3170 223^
7877	"^DD",349. 5,349.5,.0 2,21,1,0)
7878	This is th e Annual P ayment Fil e Year to be process ed.
7879	"^DD",349. 5,349.5,.0 2,"DT")
7880	3170224
7881	"^DD",349. 5,349.5,.0 3,0)
7882	DATE/TIME BUILD STAR TED^D^^0;3 ^S %DT="ES TXR" D ^%D T S X=Y K: 31701 >X X
7883	"^DD",349. 5,349.5,.0 3,3)
7884	Enter the Date and T ime Build Started.
7885	"^DD",349. 5,349.5,.0 3,21,0)
7886	^^1^1^3170 223^
7887	"^DD",349. 5,349.5,.0 3,21,1,0)
7888	This is th e Date and Time that the Build for this file start ed.
7889	"^DD",349. 5,349.5,.0 3,"DT")
7890	3170224
7891	"^DD",349. 5,349.5,.0 4,0)
7892	DATE/TIME BUILD ENDE D^D^^0;4^S %DT="ESTX R" D ^%DT S X=Y K:31 701 >X X
7893	"^DD",349. 5,349.5,.0 4,3)
7894	Enter the Date and T ime Build Ended.
7895	"^DD",349. 5,349.5,.0 4,21,0)
7896	^^1^1^3170 223^
7897	"^DD",349. 5,349.5,.0 4,21,1,0)
7898	This is th e Date and Time that the Build for this file ended .
7899	"^DD",349. 5,349.5,.0 4,"DT")
7900	3170224
7901	"^DD",349. 5,349.5,.0 5,0)
7902	DATE/TIME TRANSMIT S TARTED^D^^ 0;5^S %DT= "ESTXR" D ^%DT S X=Y K:31701 >X X
7903	"^DD",349. 5,349.5,.0 5,3)
7904	Enter the Date and T ime Transm it Started .
7905	"^DD",349. 5,349.5,.0 5,21,0)
7906	^^1^1^3170 223^
7907	"^DD",349. 5,349.5,.0 5,21,1,0)
7908	This is th e Date and Time that the Trans mit for th is file st arted.
7909	"^DD",349. 5,349.5,.0 5,"DT")
7910	3170224
7911	"^DD",349. 5,349.5,.0 6,0)
7912	DATE/TIME TRANSMIT E NDED^D^^0; 6^S %DT="E STXR" D ^% DT S X=Y K :31701 >X X
7913	"^DD",349. 5,349.5,.0 6,3)
7914	Enter Date /Time Tran smit Ended .
7915	"^DD",349. 5,349.5,.0 6,21,0)
7916	^^1^1^3170 223^
7917	"^DD",349. 5,349.5,.0 6,21,1,0)
7918	This is th e Date and Time that the Trans mit for th is file en ded.
7919	"^DD",349. 5,349.5,.0 6,"DT")
7920	3170224
7921	"^DD",349. 5,349.5,1, 0)
7922	STATEMENT FILE LINES ^349.51^^1 ;0
7923	"^DD",349. 5,349.5,1, 21,0)
7924	^^1^1^3170 224^^
7925	"^DD",349. 5,349.5,1, 21,1,0)
7926	This is th e multiple for the A nnual Paym ent Statem ent file l ines.
7927	"^DD",349. 5,349.51,0 )
7928	STATEMENT FILE LINES SUB-FIELD ^^.01^1
7929	"^DD",349. 5,349.51,0 ,"DT")
7930	3170224
7931	"^DD",349. 5,349.51,0 ,"NM","STA TEMENT FIL E LINES")
7932
7933	"^DD",349. 5,349.51,0 ,"UP")
7934	349.5
7935	"^DD",349. 5,349.51,. 01,0)
7936	STATEMENT FILE LINES ^MFJ342^^0 ;1^K:$L(X) >342!($L(X )<1) X
7937	"^DD",349. 5,349.51,. 01,1,0)
7938	^.1^^0
7939	"^DD",349. 5,349.51,. 01,3)
7940	Enter File Lines for Annual Pa yment Stat ement (1 t o 342 char acters).
7941	"^DD",349. 5,349.51,. 01,21,0)
7942	^^1^1^3170 224^
7943	"^DD",349. 5,349.51,. 01,21,1,0)
7944	These are the File L ines for A nnual Paym ent Statem ent.
7945	"^DD",349. 5,349.51,. 01,"DT")
7946	3170224
7947	"^DIC",349 .1,349.1,0 )
7948	AR TRANSMI SSION TYPE ^349.1
7949	"^DIC",349 .1,349.1,0 ,"GL")
7950	^RCT(349.1 ,
7951	"^DIC",349 .1,349.1," %D",0)
7952	^1.001^2^2 ^3160422^^ ^^
7953	"^DIC",349 .1,349.1," %D",1,0)
7954	This file stores the transmiss ion types used in fi le 349
7955	"^DIC",349 .1,349.1," %D",2,0)
7956	AR TRANSMI SSION RECO RDS.
7957	"^DIC",349 .1,"B","AR TRANSMISS ION TYPE", 349.1)
7958
7959	"^DIC",349 .5,349.5,0 )
7960	AR ANNUAL PAYMENT ST ATEMENT^34 9.5
7961	"^DIC",349 .5,349.5,0 ,"GL")
7962	^RCAP(349. 5,
7963	"^DIC",349 .5,349.5," %",0)
7964	^1.005^^
7965	"^DIC",349 .5,349.5," %D",0)
7966	^^3^3^3170 223^
7967	"^DIC",349 .5,349.5," %D",1,0)
7968	This file will hold all of the previous year's pat ient payme nt data fo r
7969	"^DIC",349 .5,349.5," %D",2,0)
7970	that calen dar year a nd persist for only one year t o then be deleted an d
7971	"^DIC",349 .5,349.5," %D",3,0)
7972	replaced a t the begi nning of t he next ca lendar yea r.
7973	"^DIC",349 .5,"B","AR ANNUAL PA YMENT STAT EMENT",349 .5)
7974
7975	"BLD",1011 1,6)
7976	4^
7977	$END KID P RCA4.531 3
		7978