1. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 3/31/2017 2:01:04 PM Central 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.

1.1 Files compared

#	Location	File	Last Modified
1	IB_2_568_PRCA_PSO_BUNDLE_T1B.zip	IB_2_568_PRCA_PSO_BUNDLE_T1B.KID	Mon Feb 6 21:39:56 2017 UTC
2	IB_2_568_PRCA_PSO_BUNDLE_T1B.zip	IB_2_568_PRCA_PSO_BUNDLE_T1B.KID	Fri Mar 31 18:57:05 2017 UTC

1.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	51	35752
Changed	50	100
Inserted	0	0
Removed	0	0

1.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

1.4 Active regular expressions

No regular expressions were active.

1.5 Comparison detail

	1	KIDS Distr ibution sa ved on Feb 06, 2017@ 16:36:06
	2	FY16 HAPE REVENUE EN HANCEMENTS
	3	KIDS:I B2.0568^ PRCA4.53 15^PSO7.0 463^
	4
	5	INSTALL NAME
	6	IB2.0568
	7	"BLD",1019 0,0)
	8	IB2.0568 ^INTEGRATE D BILLING^ 0^3170206^ y
	9	"BLD",1019 0,1,0)
	10	^^313^313^ 3161212^^
	11	"BLD",1019 0,1,1,0)
	12
	13	"BLD",1019 0,1,2,0)
	14	IMPORTANT INSTALLATI ON NOTE:
	15	"BLD",1019 0,1,3,0)
	16	---------- ---------- --------
	17	"BLD",1019 0,1,4,0)
	18	This patch is part o f a multi- package bu ild. There are three patches
	19	"BLD",1019 0,1,5,0)
	20	associated with the FY16 HAPE Revenue En hancement project -
	21	"BLD",1019 0,1,6,0)
	22	IB2.0568 ,PRCA4.5 315 and PS O7.0463. All three patches a re to be
	23	"BLD",1019 0,1,7,0)
	24	installed together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
	25	"BLD",1019 0,1,8,0)
	26
	27	"BLD",1019 0,1,9,0)
	28
	29	"BLD",1019 0,1,10,0)
	30	Descriptio n
	31	"BLD",1019 0,1,11,0)
	32	---------- -
	33	"BLD",1019 0,1,12,0)
	34	The Chief Business O ffice (CBO ) is reque sting syst em enhance ments to
	35	"BLD",1019 0,1,13,0)
	36	The Vetera ns Health Informatio n Systems and Techno logy Archi tecture
	37	"BLD",1019 0,1,14,0)
	38	(VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd
	39	"BLD",1019 0,1,15,0)
	40	Outpatient Pharmacy (PSO) soft ware modul es.
	41	"BLD",1019 0,1,16,0)
	42
	43	"BLD",1019 0,1,17,0)
	44	The missio n of the D epartment of Veteran s Affairs (VA), Offi ce of
	45	"BLD",1019 0,1,18,0)
	46	Informatio n & Techno logy (OI&T ), is to p rovide ben efits and services
	47	"BLD",1019 0,1,19,0)
	48	to veteran s of the U nited Stat es Armed F orces. In meeting th ese
	49	"BLD",1019 0,1,20,0)
	50	goals, OIT strives t o provide high quali ty, effect ive, and e fficient
	51	"BLD",1019 0,1,21,0)
	52	Informatio n Technolo gy (IT) se rvices to those resp onsible fo r
	53	"BLD",1019 0,1,22,0)
	54	providing care to th e veterans at the po int-of-car e, as well as
	55	"BLD",1019 0,1,23,0)
	56	throughout all the p oints of t he veteran s' health care. The VA depends
	57	"BLD",1019 0,1,24,0)
	58	on Informa tion Manag ement/Info rmation Te chnology ( IM/IT) sys tems to
	59	"BLD",1019 0,1,25,0)
	60	meet missi on goals.
	61	"BLD",1019 0,1,26,0)
	62
	63	"BLD",1019 0,1,27,0)
	64	The overal l FY16 HAP E Revenue Enhancemen t project has been f urther
	65	"BLD",1019 0,1,28,0)
	66	divided in to three s ub-project s:
	67	"BLD",1019 0,1,29,0)
	68
	69	"BLD",1019 0,1,30,0)
	70	NSR #20150 506
	71	"BLD",1019 0,1,31,0)
	72	The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the Chief
	73	"BLD",1019 0,1,32,0)
	74	Business O ffice (CBO ), bundles several N SRs with s imilar bus iness
	75	"BLD",1019 0,1,33,0)
	76	needs into a single requiremen ts documen t. Succes sfully add ressing
	77	"BLD",1019 0,1,34,0)
	78	the requir ements con tained wit hin this d ocument wi ll enable the
	79	"BLD",1019 0,1,35,0)
	80	Department of Vetera ns Affairs (VA) to a ppropriate ly bill ce rtain
	81	"BLD",1019 0,1,36,0)
	82	subsets of billable events by correcting , automati ng, or enh ancing
	83	"BLD",1019 0,1,37,0)
	84	current Ve terans Hea lth Inform ation Syst ems and Te chnology
	85	"BLD",1019 0,1,38,0)
	86	Architectu re (VistA) systems.
	87	"BLD",1019 0,1,39,0)
	88
	89	"BLD",1019 0,1,40,0)
	90	NSR #20150 507
	91	"BLD",1019 0,1,41,0)
	92	The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs,
	93	"BLD",1019 0,1,42,0)
	94	as well. T his effort enables t he Departm ent of Vet erans Affa irs (VA)
	95	"BLD",1019 0,1,43,0)
	96	to improve revenue o peration f unctionali ty related to repaym ent plans,
	97	"BLD",1019 0,1,44,0)
	98	late charg e capture, bill susp ension rea sons, the billing of
	99	"BLD",1019 0,1,45,0)
	100	deactivate d provider s, and the display o f appeal r ights and
	101	"BLD",1019 0,1,46,0)
	102	responsibi lities on the Vetera ns Benefic iary trave l Bill of Collection s
	103	"BLD",1019 0,1,47,0)
	104	form. Imp lementatio n of the p roposed en hancements will make a
	105	"BLD",1019 0,1,48,0)
	106	significan t positive impact on stakehold ers and ta rget users .
	107	"BLD",1019 0,1,49,0)
	108
	109	"BLD",1019 0,1,50,0)
	110	NSR #20150 505
	111	"BLD",1019 0,1,51,0)
	112	The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to
	113	"BLD",1019 0,1,52,0)
	114	improve tr acking and reporting of revenu e, and wil l support revenue
	115	"BLD",1019 0,1,53,0)
	116	reporting business r ules and g uidelines.
	117	"BLD",1019 0,1,54,0)
	118
	119	"BLD",1019 0,1,55,0)
	120
	121	"BLD",1019 0,1,56,0)
	122	IB2.0568 patch enh ancements, pertinent to the ab ove NSRs, include:
	123	"BLD",1019 0,1,57,0)
	124
	125	"BLD",1019 0,1,58,0)
	126	1.) When g enerating the RNB (R easons Not Billable) report, t he
	127	"BLD",1019 0,1,59,0)
	128	Integrated Billing s ystem shal l populate the charg es for all types
	129	"BLD",1019 0,1,60,0)
	130	of service s provided . Charges will not b e screened by any bi llable
	131	"BLD",1019 0,1,61,0)
	132	criteria b ut willind icate the full amoun t as if th e care was to be
	133	"BLD",1019 0,1,62,0)
	134	billed.
	135	"BLD",1019 0,1,63,0)
	136
	137	"BLD",1019 0,1,64,0)
	138	2.) The su b-option C laims Trac king Param eter Edit [IBT EDIT TRACKING
	139	"BLD",1019 0,1,65,0)
	140	PARAMETERS ], that cu rrently ha s no key, will be lo cked with a new
	141	"BLD",1019 0,1,66,0)
	142	Security K ey called IB PARAMET ER EDIT.
	143	"BLD",1019 0,1,67,0)
	144
	145	"BLD",1019 0,1,68,0)
	146	3.) The op tion MCCR Site Param eter Displ ay/Edit [I BJ MCCR SI TE
	147	"BLD",1019 0,1,69,0)
	148	PARAMETERS ], which i s currentl y locked w ith the IB SUPERVISO R Security
	149	"BLD",1019 0,1,70,0)
	150	Key, will be instead locked wi th the new key.
	151	"BLD",1019 0,1,71,0)
	152
	153	"BLD",1019 0,1,72,0)
	154	4.) The In tegrated B illing sys tem shall create cla ims tracki ng entries
	155	"BLD",1019 0,1,73,0)
	156	for previo usly unbil led Prosth etics/DME items when new billa ble
	157	"BLD",1019 0,1,74,0)
	158	insurance is entered into the patient's insurance file.
	159	"BLD",1019 0,1,75,0)
	160
	161	"BLD",1019 0,1,76,0)
	162	5.) A new coverage l imitation field shal l be creat ed in the insurance
	163	"BLD",1019 0,1,77,0)
	164	file for P rosthetics . Like th e other ex isting cov erage limi tation
	165	"BLD",1019 0,1,78,0)
	166	fields in the insura nce file ( Inpatient, Outpatien t, Pharmac y etc.),
	167	"BLD",1019 0,1,79,0)
	168	this field will have the follo wing optio ns:
	169	"BLD",1019 0,1,80,0)
	170	0= NOT COVERE D
	171	"BLD",1019 0,1,81,0)
	172	1= COVERED
	173	"BLD",1019 0,1,82,0)
	174	2= CONDITIONA LCOVERAGE
	175	"BLD",1019 0,1,83,0)
	176	Once selec ted, they will show in the pat ient insur ance file as Yes,
	177	"BLD",1019 0,1,84,0)
	178	No, or Con ditional.
	179	"BLD",1019 0,1,85,0)
	180
	181	"BLD",1019 0,1,86,0)
	182	6.) The sy stem shall automatic ally assig n an RNB [ NO PROSTHE TIC
	183	"BLD",1019 0,1,87,0)
	184	COVERAGE ( CV22)] for Prostheti cs/DME ite ms if the patient ha s no
	185	"BLD",1019 0,1,88,0)
	186	coverage f or Prosthe tics in hi s/her insu rance file .
	187	"BLD",1019 0,1,89,0)
	188
	189	"BLD",1019 0,1,90,0)
	190	7.) The sy stem shall have a ne w option t o add Pros thetics it ems to
	191	"BLD",1019 0,1,91,0)
	192	Manual and Nightly C laims Trac king.
	193	"BLD",1019 0,1,92,0)
	194
	195	"BLD",1019 0,1,93,0)
	196	8.) Users will be ab le to sele ct Suspend ed Type fr om the men u to
	197	"BLD",1019 0,1,94,0)
	198	display in the First Party Fol low- Up [I BJD FOLLOW -UP FIRST PARTY]
	199	"BLD",1019 0,1,95,0)
	200	report.
	201	"BLD",1019 0,1,96,0)
	202
	203	"BLD",1019 0,1,97,0)
	204	9.) First Party Foll ow- Up [IB JD FOLLOW- UP FIRST P ARTY] repo rt shall
	205	"BLD",1019 0,1,98,0)
	206	be modifie d to incor porate rea son for su spension.
	207	"BLD",1019 0,1,99,0)
	208
	209	"BLD",1019 0,1,100,0)
	210	10.) A new warning m essage wil l print to the scree n in the E nter/Edit
	211	"BLD",1019 0,1,101,0)
	212	Billing In formation option if an ATTENDI NG, REFERR ING or REN DERING
	213	"BLD",1019 0,1,102,0)
	214	Provider h as a PERSO N CLASS - NEW PERSON file (#20 0) - that was
	215	"BLD",1019 0,1,103,0)
	216	expirated at the tim e of the D ate of Ser vice.
	217	"BLD",1019 0,1,104,0)
	218
	219	"BLD",1019 0,1,105,0)
	220	11.) On th e Third Pa rty Joint Inquiry sc reen, one (1) charac ter space
	221	"BLD",1019 0,1,106,0)
	222	shall be a dded to th e "Type" f ield so th at it will accommoda te five
	223	"BLD",1019 0,1,107,0)
	224	characters (a one-ch aracter cl assificati on indicat or, a forw ard slash
	225	"BLD",1019 0,1,108,0)
	226	(/), a one -character component indicator , a forwar d slash (/ ), and a
	227	"BLD",1019 0,1,109,0)
	228	one-charac ter care t ype) ("X/X /X"). If a bill con tains pres criptions,
	229	"BLD",1019 0,1,110,0)
	230	then an "R " shall be concatena ted to the fifth cha racter sub -type
	231	"BLD",1019 0,1,111,0)
	232	position o f the "Typ e" field. If a bill contains p rosthetics , then a
	233	"BLD",1019 0,1,112,0)
	234	"P" shall be concate nated to f ifth chara cter sub-t ype positi on of the
	235	"BLD",1019 0,1,113,0)
	236	"Type" fie ld.The "Ty pe" field shall cont ain five ( 5) charact ers as
	237	"BLD",1019 0,1,114,0)
	238	follows:
	239	"BLD",1019 0,1,115,0)
	240	1. "I" for Inpatient or "O" fo r Outpatie nt,
	241	"BLD",1019 0,1,116,0)
	242	2. "/" for ward slash character
	243	"BLD",1019 0,1,117,0)
	244	3. "P" for Professio nal or "I" for Insti tutional
	245	"BLD",1019 0,1,118,0)
	246	4. "/" for ward slash character
	247	"BLD",1019 0,1,119,0)
	248	5. "P" for Prostheti cs or "R" for Prescr iptions
	249	"BLD",1019 0,1,120,0)
	250
	251	"BLD",1019 0,1,121,0)
	252	12.) Three new Third Party Ins urance Rat e Types sh all be cre ated in
	253	"BLD",1019 0,1,122,0)
	254	the VistA IB Suite f or the bil lers to ch oose from when billi ng for
	255	"BLD",1019 0,1,123,0)
	256	encounters . They are as follow s:
	257	"BLD",1019 0,1,124,0)
	258	HU MANITARIAN REIMB. IN S.
	259	"BLD",1019 0,1,125,0)
	260	DE NTAL REIMB . INS.
	261	"BLD",1019 0,1,126,0)
	262	IN ELIGIBLE R EIMB. INS.
	263	"BLD",1019 0,1,127,0)
	264
	265	"BLD",1019 0,1,128,0)
	266	13.) Each of the new rate type s above wi ll have th e 'Insurer ' as the
	267	"BLD",1019 0,1,129,0)
	268	responsibl e party.
	269	"BLD",1019 0,1,130,0)
	270
	271	"BLD",1019 0,1,131,0)
	272	14.) Bille rs (revenu e staff) s hould be a ble to ide ntify any remaining
	273	"BLD",1019 0,1,132,0)
	274	charges to the patie nt after t he Third P arty payme nts are re ceived for
	275	"BLD",1019 0,1,133,0)
	276	Emergency Humanitari an, Inelig ible and D ental serv ices so th ey can
	277	"BLD",1019 0,1,134,0)
	278	accomplish balance b illing.
	279	"BLD",1019 0,1,135,0)
	280
	281	"BLD",1019 0,1,136,0)
	282
	283	"BLD",1019 0,1,137,0)
	284
	285	"BLD",1019 0,1,138,0)
	286	Concurrent Developme nt / Depen dencies:
	287	"BLD",1019 0,1,139,0)
	288	---------- ---------- ---------- --------
	289	"BLD",1019 0,1,140,0)
	290	N/A
	291	"BLD",1019 0,1,141,0)
	292
	293	"BLD",1019 0,1,142,0)
	294
	295	"BLD",1019 0,1,143,0)
	296	Patch Comp onents:
	297	"BLD",1019 0,1,144,0)
	298	---------- -------
	299	"BLD",1019 0,1,145,0)
	300
	301	"BLD",1019 0,1,146,0)
	302	Files & Fi elds Assoc iated:
	303	"BLD",1019 0,1,147,0)
	304
	305	"BLD",1019 0,1,148,0)
	306	File Name (Number) Field Na me (Number ) New/ Modified/D eleted
	307	"BLD",1019 0,1,149,0)
	308	---------- -------- -------- ---------- - ---- ---------- ------
	309	"BLD",1019 0,1,150,0)
	310	N/A
	311	"BLD",1019 0,1,151,0)
	312
	313	"BLD",1019 0,1,152,0)
	314	Options As sociated:
	315	"BLD",1019 0,1,153,0)
	316
	317	"BLD",1019 0,1,154,0)
	318	Option Nam e Type New/ Modified/D eleted
	319	"BLD",1019 0,1,155,0)
	320	---------- - ---- ---- ---------- ------
	321	"BLD",1019 0,1,156,0)
	322	IBT SUP MA NUALLY QUE PRSTHTCS ROUTINE NEW
	323	"BLD",1019 0,1,157,0)
	324
	325	"BLD",1019 0,1,158,0)
	326	Protocols Associated :
	327	"BLD",1019 0,1,159,0)
	328
	329	"BLD",1019 0,1,160,0)
	330	Protocol N ame New /Modified/ Deleted
	331	"BLD",1019 0,1,161,0)
	332	---------- --- --- ---------- -------
	333	"BLD",1019 0,1,162,0)
	334	N/A
	335	"BLD",1019 0,1,163,0)
	336
	337	"BLD",1019 0,1,164,0)
	338	Templates Associated :
	339	"BLD",1019 0,1,165,0)
	340
	341	"BLD",1019 0,1,166,0)
	342	Template N ame T ype File Name (Num ber) New/Mod/De l
	343	"BLD",1019 0,1,167,0)
	344	---------- --- - --- ---- ---------- ---- ---------- -
	345	"BLD",1019 0,1,168,0)
	346	IBJT ACTIV E LIST L IST NEW
	347	"BLD",1019 0,1,169,0)
	348	IBJT INACT IVE LIST L IST NEW
	349	"BLD",1019 0,1,170,0)
	350
	351	"BLD",1019 0,1,171,0)
	352	New Servic e Requests (NSRs):
	353	"BLD",1019 0,1,172,0)
	354	---------- ---------- --------
	355	"BLD",1019 0,1,173,0)
	356	20150505 - Revenue R eporting E nhancement s
	357	"BLD",1019 0,1,174,0)
	358	20150506 - Revenue E ligibility Enhanceme nts
	359	"BLD",1019 0,1,175,0)
	360	20150507 - Revenue O perations Enhancemen ts
	361	"BLD",1019 0,1,176,0)
	362
	363	"BLD",1019 0,1,177,0)
	364
	365	"BLD",1019 0,1,178,0)
	366	Patient Sa fety Issue s (PSIs):
	367	"BLD",1019 0,1,179,0)
	368	---------- ---------- ----------
	369	"BLD",1019 0,1,180,0)
	370	N/A
	371	"BLD",1019 0,1,181,0)
	372
	373	"BLD",1019 0,1,182,0)
	374
	375	"BLD",1019 0,1,183,0)
	376	Remedy Tic ket(s) & O verviews:
	377	"BLD",1019 0,1,184,0)
	378	---------- ---------- ---------
	379	"BLD",1019 0,1,185,0)
	380	N/A
	381	"BLD",1019 0,1,186,0)
	382
	383	"BLD",1019 0,1,187,0)
	384	Test Sites :
	385	"BLD",1019 0,1,188,0)
	386	----------
	387	"BLD",1019 0,1,189,0)
	388	Durham VAM C
	389	"BLD",1019 0,1,190,0)
	390
	391	"BLD",1019 0,1,191,0)
	392
	393	"BLD",1019 0,1,192,0)
	394	Software a nd Documen tation Ret rieval Ins tructions:
	395	"BLD",1019 0,1,193,0)
	396	---------- ---------- ---------- ---------- ---------- --
	397	"BLD",1019 0,1,194,0)
	398	Patches fo r this ins tallation are combin ed in host file
	399	"BLD",1019 0,1,195,0)
	400	IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
	401	"BLD",1019 0,1,196,0)
	402
	403	"BLD",1019 0,1,197,0)
	404	Installati on of this host file should be coordinat ed among t he package s
	405	"BLD",1019 0,1,198,0)
	406	affected s ince only one instal lation is necessary.
	407	"BLD",1019 0,1,199,0)
	408
	409	"BLD",1019 0,1,200,0)
	410	The patche s are:
	411	"BLD",1019 0,1,201,0)
	412
	413	"BLD",1019 0,1,202,0)
	414	IB2. 0568
	415	"BLD",1019 0,1,203,0)
	416	PRCA* 4.5*315
	417	"BLD",1019 0,1,204,0)
	418	PSO7 .0463
	419	"BLD",1019 0,1,205,0)
	420
	421	"BLD",1019 0,1,206,0)
	422
	423	"BLD",1019 0,1,207,0)
	424	Sites may retrieve t he KIDS bu ild in one of the fo llowing wa ys:
	425	"BLD",1019 0,1,208,0)
	426
	427	"BLD",1019 0,1,209,0)
	428	(1) The pr eferred me thod is to FTP the f iles from
	429	"BLD",1019 0,1,210,0)
	430	download. DNS . DNS which will transmit the files from the f irst
	431	"BLD",1019 0,1,211,0)
	432	available FTP server .
	433	"BLD",1019 0,1,212,0)
	434
	435	"BLD",1019 0,1,213,0)
	436	(2) Sites may also e lect to re trieve the patch dir ectly from a specifi c
	437	"BLD",1019 0,1,214,0)
	438	server as follows:
	439	"BLD",1019 0,1,215,0)
	440
	441	"BLD",1019 0,1,216,0)
	442	OIFO FTP ADDRE SS DIRECTORY
	443	"BLD",1019 0,1,217,0)
	444	-------- ------ --------- ---------- ----- ---------- --------
	445	"BLD",1019 0,1,218,0)
	446	Albany ftp. DNS . URL anonymous. software
	447	"BLD",1019 0,1,219,0)
	448	Hines ftp. DNS . URL anonymous. software
	449	"BLD",1019 0,1,220,0)
	450	Salt Lake City ftp. DNS . URL anonymous. software
	451	"BLD",1019 0,1,221,0)
	452
	453	"BLD",1019 0,1,222,0)
	454
	455	"BLD",1019 0,1,223,0)
	456	Sites may retrieve d ocumentati on directl y using Se cure File Transfer
	457	"BLD",1019 0,1,224,0)
	458	Protocol ( SFTP) from the ANONY MOUS.SOFTW ARE direct ory at the following
	459	"BLD",1019 0,1,225,0)
	460	OI Field O ffices:
	461	"BLD",1019 0,1,226,0)
	462
	463	"BLD",1019 0,1,227,0)
	464	Albany: .URL
	465	"BLD",1019 0,1,228,0)
	466	Hines: .URL
	467	"BLD",1019 0,1,229,0)
	468	Salt Lake City: . URL
	469	"BLD",1019 0,1,230,0)
	470
	471	"BLD",1019 0,1,231,0)
	472	Documentat ion can al so be foun d on the V A Software Documenta tion
	473	"BLD",1019 0,1,232,0)
	474	Library at :
	475	"BLD",1019 0,1,233,0)
	476	http:// URL /
	477	"BLD",1019 0,1,234,0)
	478
	479	"BLD",1019 0,1,235,0)
	480	Title File Name FTP Mod e
	481	"BLD",1019 0,1,236,0)
	482	---------- ---------- ---------- ---------- ---------- ---------- ---------- -
	483	"BLD",1019 0,1,237,0)
	484	Integrated Billing U ser Guide ib_2_0_um .doc Binar y
	485	"BLD",1019 0,1,238,0)
	486	Integrated Billing T echnical M anual/Secu rity Guide ib_2_0_tm .doc Binar y
	487	"BLD",1019 0,1,239,0)
	488	Integrated Billing D eployment, Installat ion,
	489	"BLD",1019 0,1,240,0)
	490	Back- Out, and R ollback Gu ide
	491	"BLD",1019 0,1,241,0)
	492	FY16Re venueIBVIP _Deploymen t_Installa tion_Guide .doc Binar y
	493	"BLD",1019 0,1,242,0)
	494
	495	"BLD",1019 0,1,243,0)
	496
	497	"BLD",1019 0,1,244,0)
	498
	499	"BLD",1019 0,1,245,0)
	500	Patch Inst allation:
	501	"BLD",1019 0,1,246,0)
	502
	503	"BLD",1019 0,1,247,0)
	504	Pre/Post I nstallatio n Overview :
	505	"BLD",1019 0,1,248,0)
	506	---------- ---------- ---------- -
	507	"BLD",1019 0,1,249,0)
	508	The post i nstallatio n routine, IBY568PO, is not au tomaticall y deleted
	509	"BLD",1019 0,1,250,0)
	510	as part of the insta llation pr ocess. You may delet e it after
	511	"BLD",1019 0,1,251,0)
	512	installati on if you desire.
	513	"BLD",1019 0,1,252,0)
	514
	515	"BLD",1019 0,1,253,0)
	516	Pre-Instal lation Ins tructions:
	517	"BLD",1019 0,1,254,0)
	518	---------- ---------- ----------
	519	"BLD",1019 0,1,255,0)
	520	N/A
	521	"BLD",1019 0,1,256,0)
	522
	523	"BLD",1019 0,1,257,0)
	524	Installati on Instruc tions:
	525	"BLD",1019 0,1,258,0)
	526	---------- ---------- ------
	527	"BLD",1019 0,1,259,0)
	528	This proce ss will in stall new and update d routines and other
	529	"BLD",1019 0,1,260,0)
	530	components listed ab ove. There is a post -install r outine tha t will add
	531	"BLD",1019 0,1,261,0)
	532	entries to a number of files.
	533	"BLD",1019 0,1,262,0)
	534
	535	"BLD",1019 0,1,263,0)
	536	The patch will be re leased in conjunctio n with an Accounts R eceivable
	537	"BLD",1019 0,1,264,0)
	538	patch, PRC A4.5315 and an Out patient Ph armacy pat ch, PSO7. 0463.
	539	"BLD",1019 0,1,265,0)
	540
	541	"BLD",1019 0,1,266,0)
	542	****** ****** ** NOT E **** ****** ****
	543	"BLD",1019 0,1,267,0)
	544	IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS
	545	"BLD",1019 0,1,268,0)
	546	AN EDITE D ERROR WI LL OCCUR.
	547	"BLD",1019 0,1,269,0)
	548	The patc h should b e installe d when NO Outpatient
	549	"BLD",1019 0,1,270,0)
	550	Pharmacy users are on the sy stem.
	551	"BLD",1019 0,1,271,0)
	552	****** ****** ****** ****** ****** ****
	553	"BLD",1019 0,1,272,0)
	554
	555	"BLD",1019 0,1,273,0)
	556	Installat ion will t ake less t han 1 minu te.
	557	"BLD",1019 0,1,274,0)
	558
	559	"BLD",1019 0,1,275,0)
	560	Suggested time to i nstall: no n-peak req uirement h ours.
	561	"BLD",1019 0,1,276,0)
	562
	563	"BLD",1019 0,1,277,0)
	564
	565	"BLD",1019 0,1,278,0)
	566	1. Obtai n the file IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID.
	567	"BLD",1019 0,1,279,0)
	568
	569	"BLD",1019 0,1,280,0)
	570	2. From the Kernel Installat ion & Dist ribution S ystem menu , select
	571	"BLD",1019 0,1,281,0)
	572	the I nstallatio n menu.
	573	"BLD",1019 0,1,282,0)
	574
	575	"BLD",1019 0,1,283,0)
	576	3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
	577	"BLD",1019 0,1,284,0)
	578	promp ted to Ent er a Host File name. You may need to ap pend a
	579	"BLD",1019 0,1,285,0)
	580	direc tory name.
	581	"BLD",1019 0,1,286,0)
	582
	583	"BLD",1019 0,1,287,0)
	584	4. From this menu, you may s elect to u se the fol lowing opt ions
	585	"BLD",1019 0,1,288,0)
	586	(when prompted for INSTAL L NAME, en ter IB2.0 568):
	587	"BLD",1019 0,1,289,0)
	588	a . Verify Checksums in Transpo rt Global - This opt ion will
	589	"BLD",1019 0,1,290,0)
	590	allow y ou to ensu re the int egrity of the routin es that
	591	"BLD",1019 0,1,291,0)
	592	are in the transp ort global .
	593	"BLD",1019 0,1,292,0)
	594	b . Print T ransport G lobal - Th is option will allow you to
	595	"BLD",1019 0,1,293,0)
	596	view th e componen ts of the KIDS build .
	597	"BLD",1019 0,1,294,0)
	598	c . Compare Transport Global to Current S ystem - Th is option
	599	"BLD",1019 0,1,295,0)
	600	will al low you to view all changes th at will be made when
	601	"BLD",1019 0,1,296,0)
	602	this pa tch is ins talled. I t compares all compo nents of
	603	"BLD",1019 0,1,297,0)
	604	this pa tch (routi nes, DD's, templates , etc.).
	605	"BLD",1019 0,1,298,0)
	606	d . Backup a Transpor t Global - This opti on will cr eate a
	607	"BLD",1019 0,1,299,0)
	608	backup message of any routi nes export ed with th is patch.
	609	"BLD",1019 0,1,300,0)
	610	It will not backu p any othe r changes such as DD 's or
	611	"BLD",1019 0,1,301,0)
	612	templat es.
	613	"BLD",1019 0,1,302,0)
	614
	615	"BLD",1019 0,1,303,0)
	616	5. When prompted " Want KIDS to INHIBIT LOGONs du ring the i nstall?
	617	"BLD",1019 0,1,304,0)
	618	NO//" respond NO.
	619	"BLD",1019 0,1,305,0)
	620
	621	"BLD",1019 0,1,306,0)
	622	6. When prompted " Want to DI SABLE Sche duled Opti ons, Menu Options,
	623	"BLD",1019 0,1,307,0)
	624	and P rotocols? NO//" resp ond NO.
	625	"BLD",1019 0,1,308,0)
	626
	627	"BLD",1019 0,1,309,0)
	628
	629	"BLD",1019 0,1,310,0)
	630
	631	"BLD",1019 0,1,311,0)
	632	Post-Insta llation In structions :
	633	"BLD",1019 0,1,312,0)
	634	---------- ---------- ---------- -
	635	"BLD",1019 0,1,313,0)
	636	There are no special tasks to perform af ter this p atch insta llation.
	637	"BLD",1019 0,4,0)
	638	^9.64PA^^
	639	"BLD",1019 0,6.3)
	640	2
	641	"BLD",1019 0,"INI")
	642
	643	"BLD",1019 0,"INID")
	644	^n^
	645	"BLD",1019 0,"INIT")
	646	START^IBY5 68PO
	647	"BLD",1019 0,"KRN",0)
	648	^9.67PA^77 9.2^20
	649	"BLD",1019 0,"KRN",.4 ,0)
	650	.4
	651	"BLD",1019 0,"KRN",.4 01,0)
	652	.401
	653	"BLD",1019 0,"KRN",.4 02,0)
	654	.402
	655	"BLD",1019 0,"KRN",.4 03,0)
	656	.403
	657	"BLD",1019 0,"KRN",.5 ,0)
	658	.5
	659	"BLD",1019 0,"KRN",.8 4,0)
	660	.84
	661	"BLD",1019 0,"KRN",3. 6,0)
	662	3.6
	663	"BLD",1019 0,"KRN",3. 8,0)
	664	3.8
	665	"BLD",1019 0,"KRN",9. 2,0)
	666	9.2
	667	"BLD",1019 0,"KRN",9. 8,0)
	668	9.8
	669	"BLD",1019 0,"KRN",9. 8,"NM",0)
	670	^9.68A^10^ 10
	671	"BLD",1019 0,"KRN",9. 8,"NM",1,0 )
	672	IBJDB21^^0 ^B12749625 8
	673	"BLD",1019 0,"KRN",9. 8,"NM",2,0 )
	674	IBJTLA1^^0 ^B13446872
	675	"BLD",1019 0,"KRN",9. 8,"NM",3,0 )
	676	IBTRE2^^0^ B41201696
	677	"BLD",1019 0,"KRN",9. 8,"NM",4,0 )
	678	IBTRE20^^0 ^B20248565
	679	"BLD",1019 0,"KRN",9. 8,"NM",5,0 )
	680	IBTRKR5^^0 ^B39052603
	681	"BLD",1019 0,"KRN",9. 8,"NM",6,0 )
	682	IBCBB11^^0 ^B10836496 3
	683	"BLD",1019 0,"KRN",9. 8,"NM",7,0 )
	684	IBJTLB1^^0 ^B13573050
	685	"BLD",1019 0,"KRN",9. 8,"NM",8,0 )
	686	IBJDF4^^0^ B41736183
	687	"BLD",1019 0,"KRN",9. 8,"NM",9,0 )
	688	IBJDF41^^0 ^B94990594
	689	"BLD",1019 0,"KRN",9. 8,"NM",10, 0)
	690	IBJDF42^^0 ^B54995736
	691	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBCBB11" ,6)
	692
	693	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDB21" ,1)
	694
	695	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF4", 8)
	696
	697	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF41" ,9)
	698
	699	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF42" ,10)
	700
	701	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJTLA1" ,2)
	702
	703	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJTLB1" ,7)
	704
	705	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBTRE2", 3)
	706
	707	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBTRE20" ,4)
	708
	709	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBTRKR5" ,5)
	710
	711	"BLD",1019 0,"KRN",19 ,0)
	712	19
	713	"BLD",1019 0,"KRN",19 ,"NM",0)
	714	^9.68A^1^1
	715	"BLD",1019 0,"KRN",19 ,"NM",1,0)
	716	IBT SUP MA NUALLY QUE PRSTHTCS^ ^0
	717	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT SUP M ANUALLY QU E PRSTHTCS ",1)
	718
	719	"BLD",1019 0,"KRN",19 .1,0)
	720	19.1
	721	"BLD",1019 0,"KRN",10 1,0)
	722	101
	723	"BLD",1019 0,"KRN",40 9.61,0)
	724	409.61
	725	"BLD",1019 0,"KRN",40 9.61,"NM", 0)
	726	^9.68A^2^2
	727	"BLD",1019 0,"KRN",40 9.61,"NM", 1,0)
	728	IBJT ACTIV E LIST^^0
	729	"BLD",1019 0,"KRN",40 9.61,"NM", 2,0)
	730	IBJT INACT IVE LIST^^ 0
	731	"BLD",1019 0,"KRN",40 9.61,"NM", "B","IBJT ACTIVE LIS T",1)
	732
	733	"BLD",1019 0,"KRN",40 9.61,"NM", "B","IBJT INACTIVE L IST",2)
	734
	735	"BLD",1019 0,"KRN",77 1,0)
	736	771
	737	"BLD",1019 0,"KRN",77 9.2,0)
	738	779.2
	739	"BLD",1019 0,"KRN",87 0,0)
	740	870
	741	"BLD",1019 0,"KRN",89 89.51,0)
	742	8989.51
	743	"BLD",1019 0,"KRN",89 89.52,0)
	744	8989.52
	745	"BLD",1019 0,"KRN",89 94,0)
	746	8994
	747	"BLD",1019 0,"KRN","B ",.4,.4)
	748
	749	"BLD",1019 0,"KRN","B ",.401,.40 1)
	750
	751	"BLD",1019 0,"KRN","B ",.402,.40 2)
	752
	753	"BLD",1019 0,"KRN","B ",.403,.40 3)
	754
	755	"BLD",1019 0,"KRN","B ",.5,.5)
	756
	757	"BLD",1019 0,"KRN","B ",.84,.84)
	758
	759	"BLD",1019 0,"KRN","B ",3.6,3.6)
	760
	761	"BLD",1019 0,"KRN","B ",3.8,3.8)
	762
	763	"BLD",1019 0,"KRN","B ",9.2,9.2)
	764
	765	"BLD",1019 0,"KRN","B ",9.8,9.8)
	766
	767	"BLD",1019 0,"KRN","B ",19,19)
	768
	769	"BLD",1019 0,"KRN","B ",19.1,19. 1)
	770
	771	"BLD",1019 0,"KRN","B ",101,101)
	772
	773	"BLD",1019 0,"KRN","B ",409.61,4 09.61)
	774
	775	"BLD",1019 0,"KRN","B ",771,771)
	776
	777	"BLD",1019 0,"KRN","B ",779.2,77 9.2)
	778
	779	"BLD",1019 0,"KRN","B ",870,870)
	780
	781	"BLD",1019 0,"KRN","B ",8989.51, 8989.51)
	782
	783	"BLD",1019 0,"KRN","B ",8989.52, 8989.52)
	784
	785	"BLD",1019 0,"KRN","B ",8994,899 4)
	786
	787	"BLD",1019 0,"QDEF")
	788	^^^^NO^^^^ NO^^NO
	789	"BLD",1019 0,"QUES",0 )
	790	^9.62^^
	791	"BLD",1019 0,"REQB",0 )
	792	^9.611^10^ 10
	793	"BLD",1019 0,"REQB",1 ,0)
	794	IB2.080^ 1
	795	"BLD",1019 0,"REQB",2 ,0)
	796	IB2.061^ 1
	797	"BLD",1019 0,"REQB",3 ,0)
	798	IB2.051^ 1
	799	"BLD",1019 0,"REQB",4 ,0)
	800	IB2.0153 ^1
	801	"BLD",1019 0,"REQB",5 ,0)
	802	IB2.0137 ^1
	803	"BLD",1019 0,"REQB",6 ,0)
	804	IB2.0183 ^1
	805	"BLD",1019 0,"REQB",7 ,0)
	806	IB2.0276 ^1
	807	"BLD",1019 0,"REQB",8 ,0)
	808	IB2.0451 ^1
	809	"BLD",1019 0,"REQB",9 ,0)
	810	IB2.0516 ^1
	811	"BLD",1019 0,"REQB",1 0,0)
	812	IB2.0530 ^1
	813	"BLD",1019 0,"REQB"," B","IB2.0 137",5)
	814
	815	"BLD",1019 0,"REQB"," B","IB2.0 153",4)
	816
	817	"BLD",1019 0,"REQB"," B","IB2.0 183",6)
	818
	819	"BLD",1019 0,"REQB"," B","IB2.0 276",7)
	820
	821	"BLD",1019 0,"REQB"," B","IB2.0 451",8)
	822
	823	"BLD",1019 0,"REQB"," B","IB2.0 51",3)
	824
	825	"BLD",1019 0,"REQB"," B","IB2.0 516",9)
	826
	827	"BLD",1019 0,"REQB"," B","IB2.0 530",10)
	828
	829	"BLD",1019 0,"REQB"," B","IB2.0 61",2)
	830
	831	"BLD",1019 0,"REQB"," B","IB2.0 80",1)
	832
	833	"INIT")
	834	START^IBY5 68PO
	835	"KRN",19,1 1784,-1)
	836	0^1
	837	"KRN",19,1 1784,0)
	838	IBT SUP MA NUALLY QUE PRSTHTCS^ Manually A dd Prosthe tics to Cl aims Track ing^^R^^^^
	839	^^^^INTEGR ATED BILLI NG
	840	"KRN",19,1 1784,1,0)
	841	^^5^5^3161 101^
	842	"KRN",19,1 1784,1,1,0 )
	843	This optio n allows t he user to select a date range of prosth etics
	844	"KRN",19,1 1784,1,2,0 )
	845	encounters and tries to add th em to the Claims tra cking modu le.
	846	"KRN",19,1 1784,1,3,0 )
	847
	848	"KRN",19,1 1784,1,4,0 )
	849	The option will auto matically queue off a task to add prosth etics and
	850	"KRN",19,1 1784,1,5,0 )
	851	when compl ete send t he request ing user a mail mess age.
	852	"KRN",19,1 1784,25)
	853	EN^IBTRKR5
	854	"KRN",19,1 1784,"U")
	855	MANUALLY A DD PROSTHE TICS TO CL
	856	"KRN",409. 61,84,-1)
	857	0^1
	858	"KRN",409. 61,84,0)
	859	IBJT ACTIV E LIST^1^^ 80^4^20^1^ 1^Active B ill^IBJT A CTIVE LIST SCREEN ME NU^Third P
	860	arty Activ e Bills^1^ ^1
	861	"KRN",409. 61,84,1)
	862	^VALM HIDD EN ACTIONS
	863	"KRN",409. 61,84,"ARR AY")
	864	^TMP("IBJ TLA",$J)
	865	"KRN",409. 61,84,"COL ",0)
	866	^409.621^1 4^14
	867	"KRN",409. 61,84,"COL ",1,0)
	868	NUMBER^1^3
	869	"KRN",409. 61,84,"COL ",2,0)
	870	BILL^4^9^ Bill #
	871	"KRN",409. 61,84,"COL ",3,0)
	872	HD^14^1
	873	"KRN",409. 61,84,"COL ",4,0)
	874	STFROM^15^ 8^From
	875	"KRN",409. 61,84,"COL ",5,0)
	876	STTO^24^8^ To
	877	"KRN",409. 61,84,"COL ",6,0)
	878	TYPE^37^5^ Type
	879	"KRN",409. 61,84,"COL ",7,0)
	880	ARST^42^4^ Stat
	881	"KRN",409. 61,84,"COL ",8,0)
	882	RATE^47^7^ Rate
	883	"KRN",409. 61,84,"COL ",9,0)
	884	CB^55^1
	885	"KRN",409. 61,84,"COL ",10,0)
	886	INSUR^56^7 ^Insurer
	887	"KRN",409. 61,84,"COL ",11,0)
	888	OAMT^64^8^ Orig Amt
	889	"KRN",409. 61,84,"COL ",12,0)
	890	CAMT^73^8^ Curr Amt
	891	"KRN",409. 61,84,"COL ",13,0)
	892	REFER^13^1
	893	"KRN",409. 61,84,"COL ",14,0)
	894	MT?^33^3^M T?
	895	"KRN",409. 61,84,"COL ","B","ARS T",7)
	896
	897	"KRN",409. 61,84,"COL ","B","BIL L",2)
	898
	899	"KRN",409. 61,84,"COL ","B","CAM T",12)
	900
	901	"KRN",409. 61,84,"COL ","B","CB" ,9)
	902
	903	"KRN",409. 61,84,"COL ","B","HD" ,3)
	904
	905	"KRN",409. 61,84,"COL ","B","INS UR",10)
	906
	907	"KRN",409. 61,84,"COL ","B","MT? ",14)
	908
	909	"KRN",409. 61,84,"COL ","B","NUM BER",1)
	910
	911	"KRN",409. 61,84,"COL ","B","OAM T",11)
	912
	913	"KRN",409. 61,84,"COL ","B","RAT E",8)
	914
	915	"KRN",409. 61,84,"COL ","B","REF ER",13)
	916
	917	"KRN",409. 61,84,"COL ","B","STF ROM",4)
	918
	919	"KRN",409. 61,84,"COL ","B","STT O",5)
	920
	921	"KRN",409. 61,84,"COL ","B","TYP E",6)
	922
	923	"KRN",409. 61,84,"FNL ")
	924	D EXIT^IBJ TLA
	925	"KRN",409. 61,84,"HDR ")
	926	D HDR^IBJT LA
	927	"KRN",409. 61,84,"HLP ")
	928	D HELP^IBJ TLA
	929	"KRN",409. 61,84,"INI T")
	930	D INIT^IBJ TLA
	931	"KRN",409. 61,95,-1)
	932	0^2
	933	"KRN",409. 61,95,0)
	934	IBJT INACT IVE LIST^1 ^^80^5^20^ 1^1^Inacti ve Bill^IB JT INACTIV E LIST SCR EEN MENU^I
	935	nactive Bi lls^1^^1
	936	"KRN",409. 61,95,1)
	937	^VALM HIDD EN ACTIONS
	938	"KRN",409. 61,95,"ARR AY")
	939	^TMP("IBJ TLB",$J)
	940	"KRN",409. 61,95,"COL ",0)
	941	^409.621^1 3^13
	942	"KRN",409. 61,95,"COL ",1,0)
	943	NUMBER^1^3
	944	"KRN",409. 61,95,"COL ",2,0)
	945	BILL^4^12^ Bill #
	946	"KRN",409. 61,95,"COL ",3,0)
	947	HD^17^1
	948	"KRN",409. 61,95,"COL ",4,0)
	949	STFROM^18^ 8^From
	950	"KRN",409. 61,95,"COL ",5,0)
	951	STTO^27^8^ To
	952	"KRN",409. 61,95,"COL ",6,0)
	953	TYPE^36^5^ Type
	954	"KRN",409. 61,95,"COL ",7,0)
	955	ARST^41^4^ Stat
	956	"KRN",409. 61,95,"COL ",8,0)
	957	RATE^46^7^ Rate
	958	"KRN",409. 61,95,"COL ",9,0)
	959	CB^54^1
	960	"KRN",409. 61,95,"COL ",10,0)
	961	INSUR^55^7 ^Insurer
	962	"KRN",409. 61,95,"COL ",11,0)
	963	OAMT^64^8^ Orig Amt
	964	"KRN",409. 61,95,"COL ",12,0)
	965	CAMT^73^8^ Curr Amt
	966	"KRN",409. 61,95,"COL ",13,0)
	967	REFER^16^1
	968	"KRN",409. 61,95,"COL ","B","ARS T",7)
	969
	970	"KRN",409. 61,95,"COL ","B","BIL L",2)
	971
	972	"KRN",409. 61,95,"COL ","B","CAM T",12)
	973
	974	"KRN",409. 61,95,"COL ","B","CB" ,9)
	975
	976	"KRN",409. 61,95,"COL ","B","HD" ,3)
	977
	978	"KRN",409. 61,95,"COL ","B","INS UR",10)
	979
	980	"KRN",409. 61,95,"COL ","B","NUM BER",1)
	981
	982	"KRN",409. 61,95,"COL ","B","OAM T",11)
	983
	984	"KRN",409. 61,95,"COL ","B","RAT E",8)
	985
	986	"KRN",409. 61,95,"COL ","B","REF ER",13)
	987
	988	"KRN",409. 61,95,"COL ","B","STF ROM",4)
	989
	990	"KRN",409. 61,95,"COL ","B","STT O",5)
	991
	992	"KRN",409. 61,95,"COL ","B","TYP E",6)
	993
	994	"KRN",409. 61,95,"FNL ")
	995	D EXIT^IBJ TLB
	996	"KRN",409. 61,95,"HDR ")
	997	D HDR^IBJT LB
	998	"KRN",409. 61,95,"HLP ")
	999	D HELP^IBJ TLB
	1000	"KRN",409. 61,95,"INI T")
	1001	D INIT^IBJ TLB
	1002	"MBREQ")
	1003	0
	1004	"ORD",17,4 09.61)
	1005	409.61;17; 1;;;;LME1^ XPDIA1;;;L MDEL^XPDIA 1
	1006	"ORD",17,4 09.61,0)
	1007	LIST TEMPL ATE
	1008	"ORD",18,1 9)
	1009	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
	1010	"ORD",18,1 9,0)
	1011	OPTION
	1012	"PKG",49,- 1)
	1013	1^1
	1014	"PKG",49,0 )
	1015	INTEGRATED BILLING^I B^INTEGRAT ED BILLING
	1016	"PKG",49,2 0,0)
	1017	^9.402P^1^ 1
	1018	"PKG",49,2 0,1,0)
	1019	2^^IBAXDR
	1020	"PKG",49,2 0,1,1)
	1021
	1022	"PKG",49,2 0,"B",2,1)
	1023
	1024	"PKG",49,2 2,0)
	1025	^9.49I^1^1
	1026	"PKG",49,2 2,1,0)
	1027	2.0^305111 9^2960627
	1028	"PKG",49,2 2,1,"PAH", 1,0)
	1029	568^317020 6
	1030	"PKG",49,2 2,1,"PAH", 1,1,0)
	1031	^^313^313^ 3170206
	1032	"PKG",49,2 2,1,"PAH", 1,1,1,0)
	1033
	1034	"PKG",49,2 2,1,"PAH", 1,1,2,0)
	1035	IMPORTANT INSTALLATI ON NOTE:
	1036	"PKG",49,2 2,1,"PAH", 1,1,3,0)
	1037	---------- ---------- --------
	1038	"PKG",49,2 2,1,"PAH", 1,1,4,0)
	1039	This patch is part o f a multi- package bu ild. There are three patches
	1040	"PKG",49,2 2,1,"PAH", 1,1,5,0)
	1041	associated with the FY16 HAPE Revenue En hancement project -
	1042	"PKG",49,2 2,1,"PAH", 1,1,6,0)
	1043	IB2.0568 ,PRCA4.5 315 and PS O7.0463. All three patches a re to be
	1044	"PKG",49,2 2,1,"PAH", 1,1,7,0)
	1045	installed together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
	1046	"PKG",49,2 2,1,"PAH", 1,1,8,0)
	1047
	1048	"PKG",49,2 2,1,"PAH", 1,1,9,0)
	1049
	1050	"PKG",49,2 2,1,"PAH", 1,1,10,0)
	1051	Descriptio n
	1052	"PKG",49,2 2,1,"PAH", 1,1,11,0)
	1053	---------- -
	1054	"PKG",49,2 2,1,"PAH", 1,1,12,0)
	1055	The Chief Business O ffice (CBO ) is reque sting syst em enhance ments to
	1056	"PKG",49,2 2,1,"PAH", 1,1,13,0)
	1057	The Vetera ns Health Informatio n Systems and Techno logy Archi tecture
	1058	"PKG",49,2 2,1,"PAH", 1,1,14,0)
	1059	(VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd
	1060	"PKG",49,2 2,1,"PAH", 1,1,15,0)
	1061	Outpatient Pharmacy (PSO) soft ware modul es.
	1062	"PKG",49,2 2,1,"PAH", 1,1,16,0)
	1063
	1064	"PKG",49,2 2,1,"PAH", 1,1,17,0)
	1065	The missio n of the D epartment of Veteran s Affairs (VA), Offi ce of
	1066	"PKG",49,2 2,1,"PAH", 1,1,18,0)
	1067	Informatio n & Techno logy (OI&T ), is to p rovide ben efits and services
	1068	"PKG",49,2 2,1,"PAH", 1,1,19,0)
	1069	to veteran s of the U nited Stat es Armed F orces. In meeting th ese
	1070	"PKG",49,2 2,1,"PAH", 1,1,20,0)
	1071	goals, OIT strives t o provide high quali ty, effect ive, and e fficient
	1072	"PKG",49,2 2,1,"PAH", 1,1,21,0)
	1073	Informatio n Technolo gy (IT) se rvices to those resp onsible fo r
	1074	"PKG",49,2 2,1,"PAH", 1,1,22,0)
	1075	providing care to th e veterans at the po int-of-car e, as well as
	1076	"PKG",49,2 2,1,"PAH", 1,1,23,0)
	1077	throughout all the p oints of t he veteran s' health care. The VA depends
	1078	"PKG",49,2 2,1,"PAH", 1,1,24,0)
	1079	on Informa tion Manag ement/Info rmation Te chnology ( IM/IT) sys tems to
	1080	"PKG",49,2 2,1,"PAH", 1,1,25,0)
	1081	meet missi on goals.
	1082	"PKG",49,2 2,1,"PAH", 1,1,26,0)
	1083
	1084	"PKG",49,2 2,1,"PAH", 1,1,27,0)
	1085	The overal l FY16 HAP E Revenue Enhancemen t project has been f urther
	1086	"PKG",49,2 2,1,"PAH", 1,1,28,0)
	1087	divided in to three s ub-project s:
	1088	"PKG",49,2 2,1,"PAH", 1,1,29,0)
	1089
	1090	"PKG",49,2 2,1,"PAH", 1,1,30,0)
	1091	NSR #20150 506
	1092	"PKG",49,2 2,1,"PAH", 1,1,31,0)
	1093	The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the Chief
	1094	"PKG",49,2 2,1,"PAH", 1,1,32,0)
	1095	Business O ffice (CBO ), bundles several N SRs with s imilar bus iness
	1096	"PKG",49,2 2,1,"PAH", 1,1,33,0)
	1097	needs into a single requiremen ts documen t. Succes sfully add ressing
	1098	"PKG",49,2 2,1,"PAH", 1,1,34,0)
	1099	the requir ements con tained wit hin this d ocument wi ll enable the
	1100	"PKG",49,2 2,1,"PAH", 1,1,35,0)
	1101	Department of Vetera ns Affairs (VA) to a ppropriate ly bill ce rtain
	1102	"PKG",49,2 2,1,"PAH", 1,1,36,0)
	1103	subsets of billable events by correcting , automati ng, or enh ancing
	1104	"PKG",49,2 2,1,"PAH", 1,1,37,0)
	1105	current Ve terans Hea lth Inform ation Syst ems and Te chnology
	1106	"PKG",49,2 2,1,"PAH", 1,1,38,0)
	1107	Architectu re (VistA) systems.
	1108	"PKG",49,2 2,1,"PAH", 1,1,39,0)
	1109
	1110	"PKG",49,2 2,1,"PAH", 1,1,40,0)
	1111	NSR #20150 507
	1112	"PKG",49,2 2,1,"PAH", 1,1,41,0)
	1113	The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs,
	1114	"PKG",49,2 2,1,"PAH", 1,1,42,0)
	1115	as well. T his effort enables t he Departm ent of Vet erans Affa irs (VA)
	1116	"PKG",49,2 2,1,"PAH", 1,1,43,0)
	1117	to improve revenue o peration f unctionali ty related to repaym ent plans,
	1118	"PKG",49,2 2,1,"PAH", 1,1,44,0)
	1119	late charg e capture, bill susp ension rea sons, the billing of
	1120	"PKG",49,2 2,1,"PAH", 1,1,45,0)
	1121	deactivate d provider s, and the display o f appeal r ights and
	1122	"PKG",49,2 2,1,"PAH", 1,1,46,0)
	1123	responsibi lities on the Vetera ns Benefic iary trave l Bill of Collection s
	1124	"PKG",49,2 2,1,"PAH", 1,1,47,0)
	1125	form. Imp lementatio n of the p roposed en hancements will make a
	1126	"PKG",49,2 2,1,"PAH", 1,1,48,0)
	1127	significan t positive impact on stakehold ers and ta rget users .
	1128	"PKG",49,2 2,1,"PAH", 1,1,49,0)
	1129
	1130	"PKG",49,2 2,1,"PAH", 1,1,50,0)
	1131	NSR #20150 505
	1132	"PKG",49,2 2,1,"PAH", 1,1,51,0)
	1133	The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to
	1134	"PKG",49,2 2,1,"PAH", 1,1,52,0)
	1135	improve tr acking and reporting of revenu e, and wil l support revenue
	1136	"PKG",49,2 2,1,"PAH", 1,1,53,0)
	1137	reporting business r ules and g uidelines.
	1138	"PKG",49,2 2,1,"PAH", 1,1,54,0)
	1139
	1140	"PKG",49,2 2,1,"PAH", 1,1,55,0)
	1141
	1142	"PKG",49,2 2,1,"PAH", 1,1,56,0)
	1143	IB2.0568 patch enh ancements, pertinent to the ab ove NSRs, include:
	1144	"PKG",49,2 2,1,"PAH", 1,1,57,0)
	1145
	1146	"PKG",49,2 2,1,"PAH", 1,1,58,0)
	1147	1.) When g enerating the RNB (R easons Not Billable) report, t he
	1148	"PKG",49,2 2,1,"PAH", 1,1,59,0)
	1149	Integrated Billing s ystem shal l populate the charg es for all types
	1150	"PKG",49,2 2,1,"PAH", 1,1,60,0)
	1151	of service s provided . Charges will not b e screened by any bi llable
	1152	"PKG",49,2 2,1,"PAH", 1,1,61,0)
	1153	criteria b ut willind icate the full amoun t as if th e care was to be
	1154	"PKG",49,2 2,1,"PAH", 1,1,62,0)
	1155	billed.
	1156	"PKG",49,2 2,1,"PAH", 1,1,63,0)
	1157
	1158	"PKG",49,2 2,1,"PAH", 1,1,64,0)
	1159	2.) The su b-option C laims Trac king Param eter Edit [IBT EDIT TRACKING
	1160	"PKG",49,2 2,1,"PAH", 1,1,65,0)
	1161	PARAMETERS ], that cu rrently ha s no key, will be lo cked with a new
	1162	"PKG",49,2 2,1,"PAH", 1,1,66,0)
	1163	Security K ey called IB PARAMET ER EDIT.
	1164	"PKG",49,2 2,1,"PAH", 1,1,67,0)
	1165
	1166	"PKG",49,2 2,1,"PAH", 1,1,68,0)
	1167	3.) The op tion MCCR Site Param eter Displ ay/Edit [I BJ MCCR SI TE
	1168	"PKG",49,2 2,1,"PAH", 1,1,69,0)
	1169	PARAMETERS ], which i s currentl y locked w ith the IB SUPERVISO R Security
	1170	"PKG",49,2 2,1,"PAH", 1,1,70,0)
	1171	Key, will be instead locked wi th the new key.
	1172	"PKG",49,2 2,1,"PAH", 1,1,71,0)
	1173
	1174	"PKG",49,2 2,1,"PAH", 1,1,72,0)
	1175	4.) The In tegrated B illing sys tem shall create cla ims tracki ng entries
	1176	"PKG",49,2 2,1,"PAH", 1,1,73,0)
	1177	for previo usly unbil led Prosth etics/DME items when new billa ble
	1178	"PKG",49,2 2,1,"PAH", 1,1,74,0)
	1179	insurance is entered into the patient's insurance file.
	1180	"PKG",49,2 2,1,"PAH", 1,1,75,0)
	1181
	1182	"PKG",49,2 2,1,"PAH", 1,1,76,0)
	1183	5.) A new coverage l imitation field shal l be creat ed in the insurance
	1184	"PKG",49,2 2,1,"PAH", 1,1,77,0)
	1185	file for P rosthetics . Like th e other ex isting cov erage limi tation
	1186	"PKG",49,2 2,1,"PAH", 1,1,78,0)
	1187	fields in the insura nce file ( Inpatient, Outpatien t, Pharmac y etc.),
	1188	"PKG",49,2 2,1,"PAH", 1,1,79,0)
	1189	this field will have the follo wing optio ns:
	1190	"PKG",49,2 2,1,"PAH", 1,1,80,0)
	1191	0= NOT COVERE D
	1192	"PKG",49,2 2,1,"PAH", 1,1,81,0)
	1193	1= COVERED
	1194	"PKG",49,2 2,1,"PAH", 1,1,82,0)
	1195	2= CONDITIONA LCOVERAGE
	1196	"PKG",49,2 2,1,"PAH", 1,1,83,0)
	1197	Once selec ted, they will show in the pat ient insur ance file as Yes,
	1198	"PKG",49,2 2,1,"PAH", 1,1,84,0)
	1199	No, or Con ditional.
	1200	"PKG",49,2 2,1,"PAH", 1,1,85,0)
	1201
	1202	"PKG",49,2 2,1,"PAH", 1,1,86,0)
	1203	6.) The sy stem shall automatic ally assig n an RNB [ NO PROSTHE TIC
	1204	"PKG",49,2 2,1,"PAH", 1,1,87,0)
	1205	COVERAGE ( CV22)] for Prostheti cs/DME ite ms if the patient ha s no
	1206	"PKG",49,2 2,1,"PAH", 1,1,88,0)
	1207	coverage f or Prosthe tics in hi s/her insu rance file .
	1208	"PKG",49,2 2,1,"PAH", 1,1,89,0)
	1209
	1210	"PKG",49,2 2,1,"PAH", 1,1,90,0)
	1211	7.) The sy stem shall have a ne w option t o add Pros thetics it ems to
	1212	"PKG",49,2 2,1,"PAH", 1,1,91,0)
	1213	Manual and Nightly C laims Trac king.
	1214	"PKG",49,2 2,1,"PAH", 1,1,92,0)
	1215
	1216	"PKG",49,2 2,1,"PAH", 1,1,93,0)
	1217	8.) Users will be ab le to sele ct Suspend ed Type fr om the men u to
	1218	"PKG",49,2 2,1,"PAH", 1,1,94,0)
	1219	display in the First Party Fol low- Up [I BJD FOLLOW -UP FIRST PARTY]
	1220	"PKG",49,2 2,1,"PAH", 1,1,95,0)
	1221	report.
	1222	"PKG",49,2 2,1,"PAH", 1,1,96,0)
	1223
	1224	"PKG",49,2 2,1,"PAH", 1,1,97,0)
	1225	9.) First Party Foll ow- Up [IB JD FOLLOW- UP FIRST P ARTY] repo rt shall
	1226	"PKG",49,2 2,1,"PAH", 1,1,98,0)
	1227	be modifie d to incor porate rea son for su spension.
	1228	"PKG",49,2 2,1,"PAH", 1,1,99,0)
	1229
	1230	"PKG",49,2 2,1,"PAH", 1,1,100,0)
	1231	10.) A new warning m essage wil l print to the scree n in the E nter/Edit
	1232	"PKG",49,2 2,1,"PAH", 1,1,101,0)
	1233	Billing In formation option if an ATTENDI NG, REFERR ING or REN DERING
	1234	"PKG",49,2 2,1,"PAH", 1,1,102,0)
	1235	Provider h as a PERSO N CLASS - NEW PERSON file (#20 0) - that was
	1236	"PKG",49,2 2,1,"PAH", 1,1,103,0)
	1237	expirated at the tim e of the D ate of Ser vice.
	1238	"PKG",49,2 2,1,"PAH", 1,1,104,0)
	1239
	1240	"PKG",49,2 2,1,"PAH", 1,1,105,0)
	1241	11.) On th e Third Pa rty Joint Inquiry sc reen, one (1) charac ter space
	1242	"PKG",49,2 2,1,"PAH", 1,1,106,0)
	1243	shall be a dded to th e "Type" f ield so th at it will accommoda te five
	1244	"PKG",49,2 2,1,"PAH", 1,1,107,0)
	1245	characters (a one-ch aracter cl assificati on indicat or, a forw ard slash
	1246	"PKG",49,2 2,1,"PAH", 1,1,108,0)
	1247	(/), a one -character component indicator , a forwar d slash (/ ), and a
	1248	"PKG",49,2 2,1,"PAH", 1,1,109,0)
	1249	one-charac ter care t ype) ("X/X /X"). If a bill con tains pres criptions,
	1250	"PKG",49,2 2,1,"PAH", 1,1,110,0)
	1251	then an "R " shall be concatena ted to the fifth cha racter sub -type
	1252	"PKG",49,2 2,1,"PAH", 1,1,111,0)
	1253	position o f the "Typ e" field. If a bill contains p rosthetics , then a
	1254	"PKG",49,2 2,1,"PAH", 1,1,112,0)
	1255	"P" shall be concate nated to f ifth chara cter sub-t ype positi on of the
	1256	"PKG",49,2 2,1,"PAH", 1,1,113,0)
	1257	"Type" fie ld.The "Ty pe" field shall cont ain five ( 5) charact ers as
	1258	"PKG",49,2 2,1,"PAH", 1,1,114,0)
	1259	follows:
	1260	"PKG",49,2 2,1,"PAH", 1,1,115,0)
	1261	1. "I" for Inpatient or "O" fo r Outpatie nt,
	1262	"PKG",49,2 2,1,"PAH", 1,1,116,0)
	1263	2. "/" for ward slash character
	1264	"PKG",49,2 2,1,"PAH", 1,1,117,0)
	1265	3. "P" for Professio nal or "I" for Insti tutional
	1266	"PKG",49,2 2,1,"PAH", 1,1,118,0)
	1267	4. "/" for ward slash character
	1268	"PKG",49,2 2,1,"PAH", 1,1,119,0)
	1269	5. "P" for Prostheti cs or "R" for Prescr iptions
	1270	"PKG",49,2 2,1,"PAH", 1,1,120,0)
	1271
	1272	"PKG",49,2 2,1,"PAH", 1,1,121,0)
	1273	12.) Three new Third Party Ins urance Rat e Types sh all be cre ated in
	1274	"PKG",49,2 2,1,"PAH", 1,1,122,0)
	1275	the VistA IB Suite f or the bil lers to ch oose from when billi ng for
	1276	"PKG",49,2 2,1,"PAH", 1,1,123,0)
	1277	encounters . They are as follow s:
	1278	"PKG",49,2 2,1,"PAH", 1,1,124,0)
	1279	HU MANITARIAN REIMB. IN S.
	1280	"PKG",49,2 2,1,"PAH", 1,1,125,0)
	1281	DE NTAL REIMB . INS.
	1282	"PKG",49,2 2,1,"PAH", 1,1,126,0)
	1283	IN ELIGIBLE R EIMB. INS.
	1284	"PKG",49,2 2,1,"PAH", 1,1,127,0)
	1285
	1286	"PKG",49,2 2,1,"PAH", 1,1,128,0)
	1287	13.) Each of the new rate type s above wi ll have th e 'Insurer ' as the
	1288	"PKG",49,2 2,1,"PAH", 1,1,129,0)
	1289	responsibl e party.
	1290	"PKG",49,2 2,1,"PAH", 1,1,130,0)
	1291
	1292	"PKG",49,2 2,1,"PAH", 1,1,131,0)
	1293	14.) Bille rs (revenu e staff) s hould be a ble to ide ntify any remaining
	1294	"PKG",49,2 2,1,"PAH", 1,1,132,0)
	1295	charges to the patie nt after t he Third P arty payme nts are re ceived for
	1296	"PKG",49,2 2,1,"PAH", 1,1,133,0)
	1297	Emergency Humanitari an, Inelig ible and D ental serv ices so th ey can
	1298	"PKG",49,2 2,1,"PAH", 1,1,134,0)
	1299	accomplish balance b illing.
	1300	"PKG",49,2 2,1,"PAH", 1,1,135,0)
	1301
	1302	"PKG",49,2 2,1,"PAH", 1,1,136,0)
	1303
	1304	"PKG",49,2 2,1,"PAH", 1,1,137,0)
	1305
	1306	"PKG",49,2 2,1,"PAH", 1,1,138,0)
	1307	Concurrent Developme nt / Depen dencies:
	1308	"PKG",49,2 2,1,"PAH", 1,1,139,0)
	1309	---------- ---------- ---------- --------
	1310	"PKG",49,2 2,1,"PAH", 1,1,140,0)
	1311	N/A
	1312	"PKG",49,2 2,1,"PAH", 1,1,141,0)
	1313
	1314	"PKG",49,2 2,1,"PAH", 1,1,142,0)
	1315
	1316	"PKG",49,2 2,1,"PAH", 1,1,143,0)
	1317	Patch Comp onents:
	1318	"PKG",49,2 2,1,"PAH", 1,1,144,0)
	1319	---------- -------
	1320	"PKG",49,2 2,1,"PAH", 1,1,145,0)
	1321
	1322	"PKG",49,2 2,1,"PAH", 1,1,146,0)
	1323	Files & Fi elds Assoc iated:
	1324	"PKG",49,2 2,1,"PAH", 1,1,147,0)
	1325
	1326	"PKG",49,2 2,1,"PAH", 1,1,148,0)
	1327	File Name (Number) Field Na me (Number ) New/ Modified/D eleted
	1328	"PKG",49,2 2,1,"PAH", 1,1,149,0)
	1329	---------- -------- -------- ---------- - ---- ---------- ------
	1330	"PKG",49,2 2,1,"PAH", 1,1,150,0)
	1331	N/A
	1332	"PKG",49,2 2,1,"PAH", 1,1,151,0)
	1333
	1334	"PKG",49,2 2,1,"PAH", 1,1,152,0)
	1335	Options As sociated:
	1336	"PKG",49,2 2,1,"PAH", 1,1,153,0)
	1337
	1338	"PKG",49,2 2,1,"PAH", 1,1,154,0)
	1339	Option Nam e Type New/ Modified/D eleted
	1340	"PKG",49,2 2,1,"PAH", 1,1,155,0)
	1341	---------- - ---- ---- ---------- ------
	1342	"PKG",49,2 2,1,"PAH", 1,1,156,0)
	1343	IBT SUP MA NUALLY QUE PRSTHTCS ROUTINE NEW
	1344	"PKG",49,2 2,1,"PAH", 1,1,157,0)
	1345
	1346	"PKG",49,2 2,1,"PAH", 1,1,158,0)
	1347	Protocols Associated :
	1348	"PKG",49,2 2,1,"PAH", 1,1,159,0)
	1349
	1350	"PKG",49,2 2,1,"PAH", 1,1,160,0)
	1351	Protocol N ame New /Modified/ Deleted
	1352	"PKG",49,2 2,1,"PAH", 1,1,161,0)
	1353	---------- --- --- ---------- -------
	1354	"PKG",49,2 2,1,"PAH", 1,1,162,0)
	1355	N/A
	1356	"PKG",49,2 2,1,"PAH", 1,1,163,0)
	1357
	1358	"PKG",49,2 2,1,"PAH", 1,1,164,0)
	1359	Templates Associated :
	1360	"PKG",49,2 2,1,"PAH", 1,1,165,0)
	1361
	1362	"PKG",49,2 2,1,"PAH", 1,1,166,0)
	1363	Template N ame T ype File Name (Num ber) New/Mod/De l
	1364	"PKG",49,2 2,1,"PAH", 1,1,167,0)
	1365	---------- --- - --- ---- ---------- ---- ---------- -
	1366	"PKG",49,2 2,1,"PAH", 1,1,168,0)
	1367	IBJT ACTIV E LIST L IST NEW
	1368	"PKG",49,2 2,1,"PAH", 1,1,169,0)
	1369	IBJT INACT IVE LIST L IST NEW
	1370	"PKG",49,2 2,1,"PAH", 1,1,170,0)
	1371
	1372	"PKG",49,2 2,1,"PAH", 1,1,171,0)
	1373	New Servic e Requests (NSRs):
	1374	"PKG",49,2 2,1,"PAH", 1,1,172,0)
	1375	---------- ---------- --------
	1376	"PKG",49,2 2,1,"PAH", 1,1,173,0)
	1377	20150505 - Revenue R eporting E nhancement s
	1378	"PKG",49,2 2,1,"PAH", 1,1,174,0)
	1379	20150506 - Revenue E ligibility Enhanceme nts
	1380	"PKG",49,2 2,1,"PAH", 1,1,175,0)
	1381	20150507 - Revenue O perations Enhancemen ts
	1382	"PKG",49,2 2,1,"PAH", 1,1,176,0)
	1383
	1384	"PKG",49,2 2,1,"PAH", 1,1,177,0)
	1385
	1386	"PKG",49,2 2,1,"PAH", 1,1,178,0)
	1387	Patient Sa fety Issue s (PSIs):
	1388	"PKG",49,2 2,1,"PAH", 1,1,179,0)
	1389	---------- ---------- ----------
	1390	"PKG",49,2 2,1,"PAH", 1,1,180,0)
	1391	N/A
	1392	"PKG",49,2 2,1,"PAH", 1,1,181,0)
	1393
	1394	"PKG",49,2 2,1,"PAH", 1,1,182,0)
	1395
	1396	"PKG",49,2 2,1,"PAH", 1,1,183,0)
	1397	Remedy Tic ket(s) & O verviews:
	1398	"PKG",49,2 2,1,"PAH", 1,1,184,0)
	1399	---------- ---------- ---------
	1400	"PKG",49,2 2,1,"PAH", 1,1,185,0)
	1401	N/A
	1402	"PKG",49,2 2,1,"PAH", 1,1,186,0)
	1403
	1404	"PKG",49,2 2,1,"PAH", 1,1,187,0)
	1405	Test Sites :
	1406	"PKG",49,2 2,1,"PAH", 1,1,188,0)
	1407	----------
	1408	"PKG",49,2 2,1,"PAH", 1,1,189,0)
	1409	Durham VAM C
	1410	"PKG",49,2 2,1,"PAH", 1,1,190,0)
	1411
	1412	"PKG",49,2 2,1,"PAH", 1,1,191,0)
	1413
	1414	"PKG",49,2 2,1,"PAH", 1,1,192,0)
	1415	Software a nd Documen tation Ret rieval Ins tructions:
	1416	"PKG",49,2 2,1,"PAH", 1,1,193,0)
	1417	---------- ---------- ---------- ---------- ---------- --
	1418	"PKG",49,2 2,1,"PAH", 1,1,194,0)
	1419	Patches fo r this ins tallation are combin ed in host file
	1420	"PKG",49,2 2,1,"PAH", 1,1,195,0)
	1421	IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
	1422	"PKG",49,2 2,1,"PAH", 1,1,196,0)
	1423
	1424	"PKG",49,2 2,1,"PAH", 1,1,197,0)
	1425	Installati on of this host file should be coordinat ed among t he package s
	1426	"PKG",49,2 2,1,"PAH", 1,1,198,0)
	1427	affected s ince only one instal lation is necessary.
	1428	"PKG",49,2 2,1,"PAH", 1,1,199,0)
	1429
	1430	"PKG",49,2 2,1,"PAH", 1,1,200,0)
	1431	The patche s are:
	1432	"PKG",49,2 2,1,"PAH", 1,1,201,0)
	1433
	1434	"PKG",49,2 2,1,"PAH", 1,1,202,0)
	1435	IB2. 0568
	1436	"PKG",49,2 2,1,"PAH", 1,1,203,0)
	1437	PRCA* 4.5*315
	1438	"PKG",49,2 2,1,"PAH", 1,1,204,0)
	1439	PSO7 .0463
	1440	"PKG",49,2 2,1,"PAH", 1,1,205,0)
	1441
	1442	"PKG",49,2 2,1,"PAH", 1,1,206,0)
	1443
	1444	"PKG",49,2 2,1,"PAH", 1,1,207,0)
	1445	Sites may retrieve t he KIDS bu ild in one of the fo llowing wa ys:
	1446	"PKG",49,2 2,1,"PAH", 1,1,208,0)
	1447
	1448	"PKG",49,2 2,1,"PAH", 1,1,209,0)
	1449	(1) The pr eferred me thod is to FTP the f iles from
	1450	"PKG",49,2 2,1,"PAH", 1,1,210,0)
	1451	download. DNS . DNS which will transmit the files from the f irst
	1452	"PKG",49,2 2,1,"PAH", 1,1,211,0)
	1453	available FTP server .
	1454	"PKG",49,2 2,1,"PAH", 1,1,212,0)
	1455
	1456	"PKG",49,2 2,1,"PAH", 1,1,213,0)
	1457	(2) Sites may also e lect to re trieve the patch dir ectly from a specifi c
	1458	"PKG",49,2 2,1,"PAH", 1,1,214,0)
	1459	server as follows:
	1460	"PKG",49,2 2,1,"PAH", 1,1,215,0)
	1461
	1462	"PKG",49,2 2,1,"PAH", 1,1,216,0)
	1463	OIFO FTP ADDRE SS DIRECTORY
	1464	"PKG",49,2 2,1,"PAH", 1,1,217,0)
	1465	-------- ------ --------- ---------- ----- ---------- --------
	1466	"PKG",49,2 2,1,"PAH", 1,1,218,0)
	1467	Albany URL anonymous. software
	1468	"PKG",49,2 2,1,"PAH", 1,1,219,0)
	1469	Hines . URL anonymous. software
	1470	"PKG",49,2 2,1,"PAH", 1,1,220,0)
	1471	Salt Lake City . URL anonymous. software
	1472	"PKG",49,2 2,1,"PAH", 1,1,221,0)
	1473
	1474	"PKG",49,2 2,1,"PAH", 1,1,222,0)
	1475
	1476	"PKG",49,2 2,1,"PAH", 1,1,223,0)
	1477	Sites may retrieve d ocumentati on directl y using Se cure File Transfer
	1478	"PKG",49,2 2,1,"PAH", 1,1,224,0)
	1479	Protocol ( SFTP) from the ANONY MOUS.SOFTW ARE direct ory at the following
	1480	"PKG",49,2 2,1,"PAH", 1,1,225,0)
	1481	OI Field O ffices:
	1482	"PKG",49,2 2,1,"PAH", 1,1,226,0)
	1483
	1484	"PKG",49,2 2,1,"PAH", 1,1,227,0)
	1485	Albany: URL
	1486	"PKG",49,2 2,1,"PAH", 1,1,228,0)
	1487	Hines: DNS .U RL
	1488	"PKG",49,2 2,1,"PAH", 1,1,229,0)
	1489	Salt Lake City: URL
	1490	"PKG",49,2 2,1,"PAH", 1,1,230,0)
	1491
	1492	"PKG",49,2 2,1,"PAH", 1,1,231,0)
	1493	Documentat ion can al so be foun d on the V A Software Documenta tion
	1494	"PKG",49,2 2,1,"PAH", 1,1,232,0)
	1495	Library at :
	1496	"PKG",49,2 2,1,"PAH", 1,1,233,0)
	1497	http:// URL /
	1498	"PKG",49,2 2,1,"PAH", 1,1,234,0)
	1499
	1500	"PKG",49,2 2,1,"PAH", 1,1,235,0)
	1501	Title File Name FTP Mod e
	1502	"PKG",49,2 2,1,"PAH", 1,1,236,0)
	1503	---------- ---------- ---------- ---------- ---------- ---------- ---------- -
	1504	"PKG",49,2 2,1,"PAH", 1,1,237,0)
	1505	Integrated Billing U ser Guide ib_2_0_um .doc Binar y
	1506	"PKG",49,2 2,1,"PAH", 1,1,238,0)
	1507	Integrated Billing T echnical M anual/Secu rity Guide ib_2_0_tm .doc Binar y
	1508	"PKG",49,2 2,1,"PAH", 1,1,239,0)
	1509	Integrated Billing D eployment, Installat ion,
	1510	"PKG",49,2 2,1,"PAH", 1,1,240,0)
	1511	Back- Out, and R ollback Gu ide
	1512	"PKG",49,2 2,1,"PAH", 1,1,241,0)
	1513	FY16Re venueIBVIP _Deploymen t_Installa tion_Guide .doc Binar y
	1514	"PKG",49,2 2,1,"PAH", 1,1,242,0)
	1515
	1516	"PKG",49,2 2,1,"PAH", 1,1,243,0)
	1517
	1518	"PKG",49,2 2,1,"PAH", 1,1,244,0)
	1519
	1520	"PKG",49,2 2,1,"PAH", 1,1,245,0)
	1521	Patch Inst allation:
	1522	"PKG",49,2 2,1,"PAH", 1,1,246,0)
	1523
	1524	"PKG",49,2 2,1,"PAH", 1,1,247,0)
	1525	Pre/Post I nstallatio n Overview :
	1526	"PKG",49,2 2,1,"PAH", 1,1,248,0)
	1527	---------- ---------- ---------- -
	1528	"PKG",49,2 2,1,"PAH", 1,1,249,0)
	1529	The post i nstallatio n routine, IBY568PO, is not au tomaticall y deleted
	1530	"PKG",49,2 2,1,"PAH", 1,1,250,0)
	1531	as part of the insta llation pr ocess. You may delet e it after
	1532	"PKG",49,2 2,1,"PAH", 1,1,251,0)
	1533	installati on if you desire.
	1534	"PKG",49,2 2,1,"PAH", 1,1,252,0)
	1535
	1536	"PKG",49,2 2,1,"PAH", 1,1,253,0)
	1537	Pre-Instal lation Ins tructions:
	1538	"PKG",49,2 2,1,"PAH", 1,1,254,0)
	1539	---------- ---------- ----------
	1540	"PKG",49,2 2,1,"PAH", 1,1,255,0)
	1541	N/A
	1542	"PKG",49,2 2,1,"PAH", 1,1,256,0)
	1543
	1544	"PKG",49,2 2,1,"PAH", 1,1,257,0)
	1545	Installati on Instruc tions:
	1546	"PKG",49,2 2,1,"PAH", 1,1,258,0)
	1547	---------- ---------- ------
	1548	"PKG",49,2 2,1,"PAH", 1,1,259,0)
	1549	This proce ss will in stall new and update d routines and other
	1550	"PKG",49,2 2,1,"PAH", 1,1,260,0)
	1551	components listed ab ove. There is a post -install r outine tha t will add
	1552	"PKG",49,2 2,1,"PAH", 1,1,261,0)
	1553	entries to a number of files.
	1554	"PKG",49,2 2,1,"PAH", 1,1,262,0)
	1555
	1556	"PKG",49,2 2,1,"PAH", 1,1,263,0)
	1557	The patch will be re leased in conjunctio n with an Accounts R eceivable
	1558	"PKG",49,2 2,1,"PAH", 1,1,264,0)
	1559	patch, PRC A4.5315 and an Out patient Ph armacy pat ch, PSO7. 0463.
	1560	"PKG",49,2 2,1,"PAH", 1,1,265,0)
	1561
	1562	"PKG",49,2 2,1,"PAH", 1,1,266,0)
	1563	****** ****** ** NOT E **** ****** ****
	1564	"PKG",49,2 2,1,"PAH", 1,1,267,0)
	1565	IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS
	1566	"PKG",49,2 2,1,"PAH", 1,1,268,0)
	1567	AN EDITE D ERROR WI LL OCCUR.
	1568	"PKG",49,2 2,1,"PAH", 1,1,269,0)
	1569	The patc h should b e installe d when NO Outpatient
	1570	"PKG",49,2 2,1,"PAH", 1,1,270,0)
	1571	Pharmacy users are on the sy stem.
	1572	"PKG",49,2 2,1,"PAH", 1,1,271,0)
	1573	****** ****** ****** ****** ****** ****
	1574	"PKG",49,2 2,1,"PAH", 1,1,272,0)
	1575
	1576	"PKG",49,2 2,1,"PAH", 1,1,273,0)
	1577	Installat ion will t ake less t han 1 minu te.
	1578	"PKG",49,2 2,1,"PAH", 1,1,274,0)
	1579
	1580	"PKG",49,2 2,1,"PAH", 1,1,275,0)
	1581	Suggested time to i nstall: no n-peak req uirement h ours.
	1582	"PKG",49,2 2,1,"PAH", 1,1,276,0)
	1583
	1584	"PKG",49,2 2,1,"PAH", 1,1,277,0)
	1585
	1586	"PKG",49,2 2,1,"PAH", 1,1,278,0)
	1587	1. Obtai n the file IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID.
	1588	"PKG",49,2 2,1,"PAH", 1,1,279,0)
	1589
	1590	"PKG",49,2 2,1,"PAH", 1,1,280,0)
	1591	2. From the Kernel Installat ion & Dist ribution S ystem menu , select
	1592	"PKG",49,2 2,1,"PAH", 1,1,281,0)
	1593	the I nstallatio n menu.
	1594	"PKG",49,2 2,1,"PAH", 1,1,282,0)
	1595
	1596	"PKG",49,2 2,1,"PAH", 1,1,283,0)
	1597	3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
	1598	"PKG",49,2 2,1,"PAH", 1,1,284,0)
	1599	promp ted to Ent er a Host File name. You may need to ap pend a
	1600	"PKG",49,2 2,1,"PAH", 1,1,285,0)
	1601	direc tory name.
	1602	"PKG",49,2 2,1,"PAH", 1,1,286,0)
	1603
	1604	"PKG",49,2 2,1,"PAH", 1,1,287,0)
	1605	4. From this menu, you may s elect to u se the fol lowing opt ions
	1606	"PKG",49,2 2,1,"PAH", 1,1,288,0)
	1607	(when prompted for INSTAL L NAME, en ter IB2.0 568):
	1608	"PKG",49,2 2,1,"PAH", 1,1,289,0)
	1609	a . Verify Checksums in Transpo rt Global - This opt ion will
	1610	"PKG",49,2 2,1,"PAH", 1,1,290,0)
	1611	allow y ou to ensu re the int egrity of the routin es that
	1612	"PKG",49,2 2,1,"PAH", 1,1,291,0)
	1613	are in the transp ort global .
	1614	"PKG",49,2 2,1,"PAH", 1,1,292,0)
	1615	b . Print T ransport G lobal - Th is option will allow you to
	1616	"PKG",49,2 2,1,"PAH", 1,1,293,0)
	1617	view th e componen ts of the KIDS build .
	1618	"PKG",49,2 2,1,"PAH", 1,1,294,0)
	1619	c . Compare Transport Global to Current S ystem - Th is option
	1620	"PKG",49,2 2,1,"PAH", 1,1,295,0)
	1621	will al low you to view all changes th at will be made when
	1622	"PKG",49,2 2,1,"PAH", 1,1,296,0)
	1623	this pa tch is ins talled. I t compares all compo nents of
	1624	"PKG",49,2 2,1,"PAH", 1,1,297,0)
	1625	this pa tch (routi nes, DD's, templates , etc.).
	1626	"PKG",49,2 2,1,"PAH", 1,1,298,0)
	1627	d . Backup a Transpor t Global - This opti on will cr eate a
	1628	"PKG",49,2 2,1,"PAH", 1,1,299,0)
	1629	backup message of any routi nes export ed with th is patch.
	1630	"PKG",49,2 2,1,"PAH", 1,1,300,0)
	1631	It will not backu p any othe r changes such as DD 's or
	1632	"PKG",49,2 2,1,"PAH", 1,1,301,0)
	1633	templat es.
	1634	"PKG",49,2 2,1,"PAH", 1,1,302,0)
	1635
	1636	"PKG",49,2 2,1,"PAH", 1,1,303,0)
	1637	5. When prompted " Want KIDS to INHIBIT LOGONs du ring the i nstall?
	1638	"PKG",49,2 2,1,"PAH", 1,1,304,0)
	1639	NO//" respond NO.
	1640	"PKG",49,2 2,1,"PAH", 1,1,305,0)
	1641
	1642	"PKG",49,2 2,1,"PAH", 1,1,306,0)
	1643	6. When prompted " Want to DI SABLE Sche duled Opti ons, Menu Options,
	1644	"PKG",49,2 2,1,"PAH", 1,1,307,0)
	1645	and P rotocols? NO//" resp ond NO.
	1646	"PKG",49,2 2,1,"PAH", 1,1,308,0)
	1647
	1648	"PKG",49,2 2,1,"PAH", 1,1,309,0)
	1649
	1650	"PKG",49,2 2,1,"PAH", 1,1,310,0)
	1651
	1652	"PKG",49,2 2,1,"PAH", 1,1,311,0)
	1653	Post-Insta llation In structions :
	1654	"PKG",49,2 2,1,"PAH", 1,1,312,0)
	1655	---------- ---------- ---------- -
	1656	"PKG",49,2 2,1,"PAH", 1,1,313,0)
	1657	There are no special tasks to perform af ter this p atch insta llation.
	1658	"QUES","XP F1",0)
	1659	Y
	1660	"QUES","XP F1","??")
	1661	^D REP^XPD H
	1662	"QUES","XP F1","A")
	1663	Shall I wr ite over y our \|FLAG\| File
	1664	"QUES","XP F1","B")
	1665	YES
	1666	"QUES","XP F1","M")
	1667	D XPF1^XPD IQ
	1668	"QUES","XP F2",0)
	1669	Y
	1670	"QUES","XP F2","??")
	1671	^D DTA^XPD H
	1672	"QUES","XP F2","A")
	1673	Want my da ta \|FLAG\| yours
	1674	"QUES","XP F2","B")
	1675	YES
	1676	"QUES","XP F2","M")
	1677	D XPF2^XPD IQ
	1678	"QUES","XP I1",0)
	1679	YO
	1680	"QUES","XP I1","??")
	1681	^D INHIBIT ^XPDH
	1682	"QUES","XP I1","A")
	1683	Want KIDS to INHIBIT LOGONs du ring the i nstall
	1684	"QUES","XP I1","B")
	1685	NO
	1686	"QUES","XP I1","M")
	1687	D XPI1^XPD IQ
	1688	"QUES","XP M1",0)
	1689	PO^VA(200, :EM
	1690	"QUES","XP M1","??")
	1691	^D MG^XPDH
	1692	"QUES","XP M1","A")
	1693	Enter the Coordinato r for Mail Group '\|F LAG\|'
	1694	"QUES","XP M1","B")
	1695
	1696	"QUES","XP M1","M")
	1697	D XPM1^XPD IQ
	1698	"QUES","XP O1",0)
	1699	Y
	1700	"QUES","XP O1","??")
	1701	^D MENU^XP DH
	1702	"QUES","XP O1","A")
	1703	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	1704	"QUES","XP O1","B")
	1705	NO
	1706	"QUES","XP O1","M")
	1707	D XPO1^XPD IQ
	1708	"QUES","XP Z1",0)
	1709	Y
	1710	"QUES","XP Z1","??")
	1711	^D OPT^XPD H
	1712	"QUES","XP Z1","A")
	1713	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	1714	"QUES","XP Z1","B")
	1715	NO
	1716	"QUES","XP Z1","M")
	1717	D XPZ1^XPD IQ
	1718	"QUES","XP Z2",0)
	1719	Y
	1720	"QUES","XP Z2","??")
	1721	^D RTN^XPD H
	1722	"QUES","XP Z2","A")
	1723	Want to MO VE routine s to other CPUs
	1724	"QUES","XP Z2","B")
	1725	NO
	1726	"QUES","XP Z2","M")
	1727	D XPZ2^XPD IQ
	1728	"RTN")
	1729	11
	1730	"RTN","IBC BB11")
	1731	0^6^B10836 4963
	1732	"RTN","IBC BB11",1,0)
	1733	IBCBB11 ;A LB/AAS/OIF O-BP/PIJ - CONTINUAT ION OF EDI T CHECK RO UTINE ;12 Jun 2006
	1734	3:45 PM
	1735	"RTN","IBC BB11",2,0)
	1736	;;2.0;INT EGRATED BI LLING;51 ,343,363,3 71,395,392 ,401,384,4 00,436,432 ,516,568
	1737	;21-MAR-94 ;Build 2
	1738	"RTN","IBC BB11",3,0)
	1739	;Per VA D irective 6 402, this routine sh ould not b e modified .
	1740	"RTN","IBC BB11",4,0)
	1741	;
	1742	"RTN","IBC BB11",5,0)
	1743	WARN(IBDIS P) ; Set w arning in global
	1744	"RTN","IBC BB11",6,0)
	1745	; DISP = warning te xt to disp lay
	1746	"RTN","IBC BB11",7,0)
	1747	;
	1748	"RTN","IBC BB11",8,0)
	1749	N Z
	1750	"RTN","IBC BB11",9,0)
	1751	S Z=+$O(^ TMP($J,"BI LL-WARN"," "),-1)
	1752	"RTN","IBC BB11",10,0 )
	1753	I Z=0 S ^ TMP($J,"BI LL-WARN",1 )=$J("",5) _"Warnin gs:",Z=1
	1754	"RTN","IBC BB11",11,0 )
	1755	S Z=Z+1,^ TMP($J,"BI LL-WARN",Z )=$J("",5) _IBDISP
	1756	"RTN","IBC BB11",12,0 )
	1757	Q
	1758	"RTN","IBC BB11",13,0 )
	1759	;
	1760	"RTN","IBC BB11",14,0 )
	1761	MULTDIV(IB IFN,IBND0) ; Check f or multipl e division s on a bil l ien IBIF N
	1762	"RTN","IBC BB11",15,0 )
	1763	; IBND0 = 0-node of bill
	1764	"RTN","IBC BB11",16,0 )
	1765	;
	1766	"RTN","IBC BB11",17,0 )
	1767	; Functi on returns 1 if more than 1 di vision fou nd on bill
	1768	"RTN","IBC BB11",18,0 )
	1769	N Z,Z0,Z1 ,MULT
	1770	"RTN","IBC BB11",19,0 )
	1771	S MULT=0, Z1=$P(IBND 0,U,22)
	1772	"RTN","IBC BB11",20,0 )
	1773	I Z1 D
	1774	"RTN","IBC BB11",21,0 )
	1775	. S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"RC", Z)) Q:'Z S Z0=$P(^( Z,0),U,7) I Z0,Z0'=Z
	1776	1 S MULT=1 Q
	1777	"RTN","IBC BB11",22,0 )
	1778	. S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"CP", Z)) Q:'Z S Z0=$P(^( Z,0),U,6) I Z0,Z0'=Z
	1779	1 S MULT=2 Q
	1780	"RTN","IBC BB11",23,0 )
	1781	I 'Z1 S M ULT=3
	1782	"RTN","IBC BB11",24,0 )
	1783	Q MULT
	1784	"RTN","IBC BB11",25,0 )
	1785	;
	1786	"RTN","IBC BB11",26,0 )
	1787	;; PREGNA NCY DX COD ES: V22- V24, V27 -V28, 630*-677 *
	1788	"RTN","IBC BB11",27,0 )
	1789	;; FLU SH OTS PROCED URE CODES: 90724, G0 008, 90732 , G0009
	1790	"RTN","IBC BB11",28,0 )
	1791	;
	1792	"RTN","IBC BB11",29,0 )
	1793	NPICHK ; C heck for r equired NP Is
	1794	"RTN","IBC BB11",30,0 )
	1795	N IBNPIS, IBNONPI,IB NPIREQ,Z,I BNFI,IBTF, IBWC,IBXSA VE,IBPRV,I BLINE,IBPR VNT1,IBPRV
	1796	NT2
	1797	"RTN","IBC BB11",31,0 )
	1798	;*** pij start IB2 0436 ***
	1799	"RTN","IBC BB11",32,0 )
	1800	N IBRATYP E,IBLEGAL
	1801	"RTN","IBC BB11",33,0 )
	1802	S (IBRATY PE,IBLEGAL )=""
	1803	"RTN","IBC BB11",34,0 )
	1804	S IBRATYP E=$P($G(^D GCR(399,IB IFN,0)),U, 7)
	1805	"RTN","IBC BB11",35,0 )
	1806	; Legal t ypes for t his use.
	1807	"RTN","IBC BB11",36,0 )
	1808	; 7=NO F AULT INS.
	1809	"RTN","IBC BB11",37,0 )
	1810	; 10=TORT FEASOR
	1811	"RTN","IBC BB11",38,0 )
	1812	; 11=WORK ERS' COMP.
	1813	"RTN","IBC BB11",39,0 )
	1814	S IBNFI=$ O(^DGCR(39 9.3,"B","N O FAULT IN S.",0)) S: 'IBNFI IBN FI=7
	1815	"RTN","IBC BB11",40,0 )
	1816	S IBTF=$O (^DGCR(399 .3,"B","TO RT FEASOR" ,0)) S:'IB TF IBTF=10
	1817	"RTN","IBC BB11",41,0 )
	1818	S IBWC=$O (^DGCR(399 .3,"B","WO RKERS' COM P.",0)) S: 'IBWC IBWC =11
	1819	"RTN","IBC BB11",42,0 )
	1820	;
	1821	"RTN","IBC BB11",43,0 )
	1822	I IBRATYP E=IBNFI!(I BRATYPE=IB TF)!(IBRAT YPE=IBWC) D
	1823	"RTN","IBC BB11",44,0 )
	1824	. ; One o f the lega l types - force loca l print
	1825	"RTN","IBC BB11",45,0 )
	1826	. S IBLEG AL=1
	1827	"RTN","IBC BB11",46,0 )
	1828	;* pij end *
	1829	"RTN","IBC BB11",47,0 )
	1830	S IBNPIRE Q=$$NPIREQ ^IBCEP81(D T) ; Chec k if NPI i s required
	1831	"RTN","IBC BB11",48,0 )
	1832	; Check p roviders
	1833	"RTN","IBC BB11",49,0 )
	1834	; IB2.0 432 change d the NPI check to t he new Pro vider Arra y
	1835	"RTN","IBC BB11",50,0 )
	1836	;S IBNPIS =$$PROVNPI ^IBCEF73A( IBIFN,.IBN ONPI)
	1837	"RTN","IBC BB11",51,0 )
	1838	D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1)
	1839	"RTN","IBC BB11",52,0 )
	1840	S IBPRV=" "
	1841	"RTN","IBC BB11",53,0 )
	1842	F S IBPR V=$O(IBXSA VE("PROVIN F",IBIFN," C",1,IBPRV )) Q:'IBPR V D
	1843	"RTN","IBC BB11",54,0 )
	1844	. I $P($G (IBXSAVE(" PROVINF",I BIFN,"C",1 ,IBPRV,0)) ,U,4)="" S IBNONPI(I BPRV)=""
	1845	"RTN","IBC BB11",55,0 )
	1846	S IBLINE= ""
	1847	"RTN","IBC BB11",56,0 )
	1848	F S IBLI NE=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE)) Q: 'IBLINE D
	1849	"RTN","IBC BB11",57,0 )
	1850	. S IBPRV =""
	1851	"RTN","IBC BB11",58,0 )
	1852	. F S IB PRV=$O(IBX SAVE("L-PR OV",IBIFN, IBLINE,"C" ,1,IBPRV)) Q:IBPRV=" " D
	1853	"RTN","IBC BB11",59,0 )
	1854	.. I $P($ G(IBXSAVE( "L-PROV",I BIFN,IBLIN E,"C",1,IB PRV,0)),U, 4)="" S IB NONPI(IBPR
	1855	V)=""
	1856	"RTN","IBC BB11",60,0 )
	1857	I $D(IBNO NPI) S IBP RV="" F S IBPRV=$O( IBNONPI(IB PRV)) Q:'I BPRV D
	1858	"RTN","IBC BB11",61,0 )
	1859	. S IBER= IBER_"IB"_ (140+IBPRV )_";" Q ; If requir ed, set er ror IB25 16
	1860	"RTN","IBC BB11",62,0 )
	1861	; Check o rganizatio ns
	1862	"RTN","IBC BB11",63,0 )
	1863	S IBNONPI =""
	1864	"RTN","IBC BB11",64,0 )
	1865	S IBNPIS= $$ORGNPI^I BCEF73A(IB IFN,.IBNON PI)
	1866	"RTN","IBC BB11",65,0 )
	1867	I $L(IBNO NPI) F Z=1 :1:$L(IBNO NPI,U) D
	1868	"RTN","IBC BB11",66,0 )
	1869	. S IBER= IBER_$P("I B339;^IB34 0;^IB341;" ,U,$P(IBNO NPI,U,Z)) ; DEM;432 Added NPI
	1870	errors.
	1871	"RTN","IBC BB11",67,0 )
	1872	Q
	1873	"RTN","IBC BB11",68,0 )
	1874	;
	1875	"RTN","IBC BB11",69,0 )
	1876	TAXCHK ; C heck for r equired ta xonomies
	1877	"RTN","IBC BB11",70,0 )
	1878	N IBDT,IB LINE,IBNOT AX,IBNOTAX 1,IBNOTAX2 ,IBPRV,IBT AXS,IBXSAV E,Z
	1879	"RTN","IBC BB11",71,0 )
	1880	;
	1881	"RTN","IBC BB11",72,0 )
	1882	; MRD;IB* 2.0*516 - This check is now mo ot; 'today ' is alway s on or
	1883	"RTN","IBC BB11",73,0 )
	1884	; after M ay 23, 200 8, so taxo nomy codes are alway s required
	1885	"RTN","IBC BB11",74,0 )
	1886	; for cer tain provi ders.
	1887	"RTN","IBC BB11",75,0 )
	1888	;S IBTAXR EQ=$$TAXRE Q^IBCEP81( DT) ; Che ck if taxo nomy is re quired
	1889	"RTN","IBC BB11",76,0 )
	1890	;
	1891	"RTN","IBC BB11",77,0 )
	1892	; Check p roviders
	1893	"RTN","IBC BB11",78,0 )
	1894	; IB2.0 432 change d the Taxo nomy check to the ne w Provider Array
	1895	"RTN","IBC BB11",79,0 )
	1896	;S IBTAXS =$$PROVTAX ^IBCEF73A( IBIFN,.IBN OTAX)
	1897	"RTN","IBC BB11",80,0 )
	1898	D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1)
	1899	"RTN","IBC BB11",81,0 )
	1900	S IBPRV=" "
	1901	"RTN","IBC BB11",82,0 )
	1902	F S IBPR V=$O(IBXSA VE("PROVIN F",IBIFN," C",1,IBPRV )) Q:'IBPR V D
	1903	"RTN","IBC BB11",83,0 )
	1904	. I $G(IB XSAVE("PRO VINF",IBIF N,"C",1,IB PRV,"TAXON OMY"))="" D
	1905	"RTN","IBC BB11",84,0 )
	1906	.. S IBNO TAX(IBPRV) =""
	1907	"RTN","IBC BB11",85,0 )
	1908	.. S IBNO TAX1=$P(IB XSAVE("PRO VINF",IBIF N,"C",1,IB PRV),";",1 ) ; New v ariables I
	1909	BNOTAX1 an d IBNOTAX2 for IB2. 0568 - De activated Provider
	1910	"RTN","IBC BB11",86,0 )
	1911	.. S IBNO TAX2(IBPRV ,IBNOTAX1) =""
	1912	"RTN","IBC BB11",87,0 )
	1913	.. Q
	1914	"RTN","IBC BB11",88,0 )
	1915	. Q
	1916	"RTN","IBC BB11",89,0 )
	1917	;
	1918	"RTN","IBC BB11",90,0 )
	1919	S IBLINE= ""
	1920	"RTN","IBC BB11",91,0 )
	1921	F S IBLI NE=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE)) Q: 'IBLINE D
	1922	"RTN","IBC BB11",92,0 )
	1923	. S IBPRV =""
	1924	"RTN","IBC BB11",93,0 )
	1925	. F S IB PRV=$O(IBX SAVE("L-PR OV",IBIFN, IBLINE,"C" ,1,IBPRV)) Q:IBPRV=" " D
	1926	"RTN","IBC BB11",94,0 )
	1927	.. I $G(I BXSAVE("L- PROV",IBIF N,IBLINE," C",1,IBPRV ,"TAXONOMY "))="" D
	1928	"RTN","IBC BB11",95,0 )
	1929	... S IBN OTAX(IBPRV )=""
	1930	"RTN","IBC BB11",96,0 )
	1931	... S IBN OTAX1=$P(I BXSAVE("L- PROV",IBIF N,IBLINE," C",1,IBPRV ),";",1) ; New vari
	1932	ables IBNO TAX1 and I BNOTAX2 fo r IB2.05 68 - Deact ivated Pro vider
	1933	"RTN","IBC BB11",97,0 )
	1934	... S IBN OTAX2(IBPR V,IBNOTAX1 )=""
	1935	"RTN","IBC BB11",98,0 )
	1936	... Q
	1937	"RTN","IBC BB11",99,0 )
	1938	.. Q
	1939	"RTN","IBC BB11",100, 0)
	1940	. Q
	1941	"RTN","IBC BB11",101, 0)
	1942	;
	1943	"RTN","IBC BB11",102, 0)
	1944	; IB251 = Referring provider taxonomy m issing.
	1945	"RTN","IBC BB11",103, 0)
	1946	; IB253 = Rendering provider taxonomy m issing.
	1947	"RTN","IBC BB11",104, 0)
	1948	; IB254 = Attending provider taxonomy m issing.
	1949	"RTN","IBC BB11",105, 0)
	1950	;
	1951	"RTN","IBC BB11",106, 0)
	1952	I $D(IBNO TAX) S IBP RV="" F S IBPRV=$O( IBNOTAX(IB PRV)) Q:'I BPRV D
	1953	"RTN","IBC BB11",107, 0)
	1954	. ; Only Referring, Rendering and Atten ding are c urrently s ent to the payer
	1955	"RTN","IBC BB11",108, 0)
	1956	. ;I IBTA XREQ,"134" [IBPRV S I BER=IBER_" IB"_(250+I BPRV)_";" Q ; MRD;I B2.0516
	1957	- Always r equired.
	1958	"RTN","IBC BB11",109, 0)
	1959	. I "134" [IBPRV D Q
	1960	"RTN","IBC BB11",110, 0)
	1961	.. S IBER =IBER_"IB" _(250+IBPR V)_";" ; I f required , set erro r
	1962	"RTN","IBC BB11",111, 0)
	1963	.. S IBPR VNT1=$O(IB NOTAX2(IBP RV,"")) ; New check for Deacti vated Prov ider IB*2.
	1964	0*568 next three lin es
	1965	"RTN","IBC BB11",112, 0)
	1966	.. S IBPR VNT2=$$SPE C^IBCEU(IB PRVNT1,IBE VDT)
	1967	"RTN","IBC BB11",113, 0)
	1968	.. I '$G( IBPRVNT2) D WARN($P( "Referring ^Operating ^Rendering ^Attending ^Supervisi
	1969	ng^^^^Othe r",U,IBPRV )_" Provid er PERSON CLASS/taxo nomy was n ot active at DOS.")
	1970	; set war ning
	1971	"RTN","IBC BB11",114, 0)
	1972	. D WARN( "Taxonomy for the "_ $P("referr ing^operat ing^render ing^attend ing^superv
	1973	ising^^^^o ther",U,IB PRV)_" pro vider has no value") ; Else, set warnin g
	1974	"RTN","IBC BB11",115, 0)
	1975	. Q
	1976	"RTN","IBC BB11",116, 0)
	1977	;
	1978	"RTN","IBC BB11",117, 0)
	1979	; Check o rganizatio ns. The f unction OR GTAX will set IBNOTA X to be a
	1980	"RTN","IBC BB11",118, 0)
	1981	; list of entities missing ta xonomy cod es, if any (n, n^m, n^m^p,
	1982	"RTN","IBC BB11",119, 0)
	1983	; where e ach 1 is s ervice fac ility, 2 i s non-VA s ervice fac ility and
	1984	"RTN","IBC BB11",120, 0)
	1985	; 3 is bi lling prov ider.
	1986	"RTN","IBC BB11",121, 0)
	1987	;
	1988	"RTN","IBC BB11",122, 0)
	1989	S IBNOTAX =""
	1990	"RTN","IBC BB11",123, 0)
	1991	S IBTAXS= $$ORGTAX^I BCEF73A(IB IFN,.IBNOT AX)
	1992	"RTN","IBC BB11",124, 0)
	1993	I $L(IBNO TAX) F Z=1 :1:$L(IBNO TAX,U) D
	1994	"RTN","IBC BB11",125, 0)
	1995	. ; IB167 = Billing Provider taxonomy m issing.
	1996	"RTN","IBC BB11",126, 0)
	1997	. ;I IBTA XREQ,$P(IB NOTAX,U,Z) =3 S IBER= IBER_"IB16 7;" Q ; M RD;IB2.0 516 - Alwa
	1998	ys require d.
	1999	"RTN","IBC BB11",127, 0)
	2000	. I $P(IB NOTAX,U,Z) =3 S IBER= IBER_"IB16 7;" Q
	2001	"RTN","IBC BB11",128, 0)
	2002	. ; MRD;I B2.0516 - Remove w arning mes sage for m issing tax onomy code for lab o
	2003	r facility .
	2004	"RTN","IBC BB11",129, 0)
	2005	. ; D WAR N("Taxonom y for the "_$P("Serv ice Facili ty^Non-VA Service Fa cility^Bil
	2006	ling Provi der",U,$P( IBNOTAX,U, Z))_" has no value") ; Else, set warnin g
	2007	"RTN","IBC BB11",130, 0)
	2008	. Q
	2009	"RTN","IBC BB11",131, 0)
	2010	;
	2011	"RTN","IBC BB11",132, 0)
	2012	Q
	2013	"RTN","IBC BB11",133, 0)
	2014	;
	2015	"RTN","IBC BB11",134, 0)
	2016	VALNDC(IBI FN,IBDFN) ; IB2363 - validat e NDC# bet ween PRESC RIPTION fi le (#52)
	2017	"RTN","IBC BB11",135, 0)
	2018	; and IB BILL/CLAIM S PRESCRIP TION REFIL L file (#3 62.4)
	2019	"RTN","IBC BB11",136, 0)
	2020	; input - IBIFN = i nternal en try number of the bi lling reco rd in the BILL/CLAIM
	2021	S file (#3 99)
	2022	"RTN","IBC BB11",137, 0)
	2023	; IBDFN = i nternal en try number of patien t record i n the PATI ENT file (
	2024	#2)
	2025	"RTN","IBC BB11",138, 0)
	2026	N IBX,IBR XCOL
	2027	"RTN","IBC BB11",139, 0)
	2028	; call pr ogram that determine s if NDC d ifferences exist
	2029	"RTN","IBC BB11",140, 0)
	2030	D VALNDC^ IBEFUNC3(I BIFN,IBDFN ,.IBRXCOL)
	2031	"RTN","IBC BB11",141, 0)
	2032	Q:'$D(IBR XCOL)
	2033	"RTN","IBC BB11",142, 0)
	2034	; at leas t one RX o n the IB r ecord has an NDC dis crepancy
	2035	"RTN","IBC BB11",143, 0)
	2036	S IBX=0 F S IBX=$O (IBRXCOL(I BX)) Q:'IB X D WARN( "NDC# on B ill does n ot equal t
	2037	he NDC# on Rx "_IBRX COL(IBX))
	2038	"RTN","IBC BB11",144, 0)
	2039	Q
	2040	"RTN","IBC BB11",145, 0)
	2041	;
	2042	"RTN","IBC BB11",146, 0)
	2043	PRIIDCHK ; Check for required Pimarary I D (SSN/EIN )
	2044	"RTN","IBC BB11",147, 0)
	2045	; If the provider i s on the c laim, he m ust have o ne
	2046	"RTN","IBC BB11",148, 0)
	2047	;
	2048	"RTN","IBC BB11",149, 0)
	2049	N IBI,IBZ
	2050	"RTN","IBC BB11",150, 0)
	2051	I $$TXMT^ IBCEF4(IBI FN) D
	2052	"RTN","IBC BB11",151, 0)
	2053	. D F^IBC EF("N-ALL ATT/REND P ROV SSN/EI ","IBZ",,I BIFN)
	2054	"RTN","IBC BB11",152, 0)
	2055	. S IBI=" " F S IBI =$O(^DGCR( 399,IBIFN, "PRV","B", IBI)) Q:IB I="" D
	2056	"RTN","IBC BB11",153, 0)
	2057	.. I $P(I BZ,U,IBI)= "" S IBER= IBER_$S(IB I=1:"IB151 ;",IBI=2:" IB152;",IB I=3!(IBI=4
	2058	):"IB321;" ,IBI=5:"IB 153;",IBI= 9:"IB154;" ,1:"")
	2059	"RTN","IBC BB11",154, 0)
	2060	Q
	2061	"RTN","IBC BB11",155, 0)
	2062	;
	2063	"RTN","IBC BB11",156, 0)
	2064	RXNPI(IBIF N) ; check for multi ple pharma cy npi's o n the same bill
	2065	"RTN","IBC BB11",157, 0)
	2066	N IBORG,I BRXNPI,IBX ,IBY
	2067	"RTN","IBC BB11",158, 0)
	2068	S IBORG=$ $RXSITE^IB CEF73A(IBI FN,.IBORG)
	2069	"RTN","IBC BB11",159, 0)
	2070	S IBX=0 F S IBX=$O (IBORG(IBX )) Q:'IBX S IBY=0 F S IBY=$O (IBORG(IBX ,IBY)) Q:'
	2071	IBY S IBR XNPI(+IBOR G(IBX,IBY) )=""
	2072	"RTN","IBC BB11",160, 0)
	2073	S (IBX,IB Y)=0 F S IBX=$O(IBR XNPI(IBX)) Q:'IBX S IBY=IBY+1
	2074	"RTN","IBC BB11",161, 0)
	2075	I IBY>1 D WARN("Bil l has pres criptions resulting from "_IBY _" differe nt NPI loc
	2076	ations")
	2077	"RTN","IBC BB11",162, 0)
	2078	Q
	2079	"RTN","IBC BB11",163, 0)
	2080	;
	2081	"RTN","IBC BB11",164, 0)
	2082	ROICHK(IBI FN,IBDFN,I BINS) ; IB 2.0384 - check pre scriptions that cont ain the
	2083	"RTN","IBC BB11",165, 0)
	2084	; special handling code U aga inst the C laims Trac king ROI f ile (#356. 25)
	2085	"RTN","IBC BB11",166, 0)
	2086	; to see if an ROI is on file
	2087	"RTN","IBC BB11",167, 0)
	2088	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2089	"RTN","IBC BB11",168, 0)
	2090	; IBDFN = I EN of the patient
	2091	"RTN","IBC BB11",169, 0)
	2092	; IBINS = I EN of the payer insu rance comp any (#36)
	2093	"RTN","IBC BB11",170, 0)
	2094	; OUTPUT - 0 = no e rror
	2095	"RTN","IBC BB11",171, 0)
	2096	; 1 = a pr escription is sensit ive and th ere is no ROI on fil e
	2097	"RTN","IBC BB11",172, 0)
	2098	;
	2099	"RTN","IBC BB11",173, 0)
	2100	N IBX,IBY 0,IBRXIEN, IBDT,IBDRU G,ROIQ
	2101	"RTN","IBC BB11",174, 0)
	2102	S ROIQ=0
	2103	"RTN","IBC BB11",175, 0)
	2104	S IBX=0 F S IBX=$O (^IBA(362. 4,"C",IBIF N,IBX)) Q: 'IBX D
	2105	"RTN","IBC BB11",176, 0)
	2106	.S IBY0=^ IBA(362.4, IBX,0),IBR XIEN=$P(IB Y0,U,5) I 'IBRXIEN Q
	2107	"RTN","IBC BB11",177, 0)
	2108	.S IBDT=$ P(IBY0,U,3 ),IBDRUG=$ P(IBY0,U,4 )
	2109	"RTN","IBC BB11",178, 0)
	2110	.D ZERO^I BRXUTL(IBD RUG)
	2111	"RTN","IBC BB11",179, 0)
	2112	.I ^TMP($ J,"IBDRUG" ,IBDRUG,3) ["U" D
	2113	"RTN","IBC BB11",180, 0)
	2114	.. I $$RO I^IBNCPDR4 (IBDFN,IBD RUG,IBINS, IBDT) Q ; ROI is on file
	2115	"RTN","IBC BB11",181, 0)
	2116	.. D WARN ("ROI not on file fo r prescrip tion "_$$R XAPI1^IBNC PUT1(IBRXI EN,.01,"E"
	2117	))
	2118	"RTN","IBC BB11",182, 0)
	2119	.. S ROIQ =1
	2120	"RTN","IBC BB11",183, 0)
	2121	ROICHKQ ;
	2122	"RTN","IBC BB11",184, 0)
	2123	K ^TMP($J ,"IBDRUG")
	2124	"RTN","IBC BB11",185, 0)
	2125	Q ROIQ
	2126	"RTN","IBC BB11",186, 0)
	2127	;
	2128	"RTN","IBC BB11",187, 0)
	2129	AMBCK(IBIF N) ; IB 2.0432 - if ambula nce locati on defined , address must be de
	2130	fined
	2131	"RTN","IBC BB11",188, 0)
	2132	; if ther e is anyth ing entere d in any o f the addr ess fields (either p /up or dro
	2133	p/off fiel ds), than there need s to be:
	2134	"RTN","IBC BB11",189, 0)
	2135	; Address 1, State and ZIP un less the S tate is no t a US sta te or poss ession, th
	2136	en zip cod e is not n eeded (CMS 1500 only)
	2137	"RTN","IBC BB11",190, 0)
	2138	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2139	"RTN","IBC BB11",191, 0)
	2140	; OUTPUT - 0 = no e rror
	2141	"RTN","IBC BB11",192, 0)
	2142	; 1 = Erro r
	2143	"RTN","IBC BB11",193, 0)
	2144	;
	2145	"RTN","IBC BB11",194, 0)
	2146	N IBPAMB, IBDAMB,IBA MBR,IBCK
	2147	"RTN","IBC BB11",195, 0)
	2148	S IBAMBR= 0
	2149	"RTN","IBC BB11",196, 0)
	2150	Q:$$INSPR F^IBCEF(IB IFN)'=0 IB AMBR
	2151	"RTN","IBC BB11",197, 0)
	2152	S IBPAMB= $G(^DGCR(3 99,IBIFN," U5")),IBDA MB=$G(^DGC R(399,IBIF N,"U6"))
	2153	"RTN","IBC BB11",198, 0)
	2154	S IBCK(5) =$$NOPUNCT ^IBCEF($P( IBPAMB,U,2 ,6),1),IBC K(6)=$$NOP UNCT^IBCEF ($P(IBDAMB
	2155	,U,1,6),1)
	2156	"RTN","IBC BB11",199, 0)
	2157	I IBCK(5) ="",IBCK(6 )="" Q IBA MBR
	2158	"RTN","IBC BB11",200, 0)
	2159	; at this point we know that at least o ne ambulan ce field h as data, s o check to
	2160	see if al l have dat a
	2161	"RTN","IBC BB11",201, 0)
	2162	I IBCK(5) '="" F I=2 ,4,5 I $P( IBPAMB,U,I )="" S IBA MBR=1
	2163	"RTN","IBC BB11",202, 0)
	2164	I IBCK(6) '="" F I=1 ,2,4,5 I $ P(IBDAMB,U ,I)="" S I BAMBR=1
	2165	"RTN","IBC BB11",203, 0)
	2166	Q:IBAMBR= 1 IBAMBR
	2167	"RTN","IBC BB11",204, 0)
	2168	; now che ck zip cod e. OK to be null if state is not a US P osession
	2169	"RTN","IBC BB11",205, 0)
	2170	F I="IBPA MB","IBDAM B" I $P(I, U,5)'="",$ P($G(^DIC( 5,$P(I,U,5 ),0)),U,6) =1,$P(I,U,
	2171	6)="" S IB AMBR=1
	2172	"RTN","IBC BB11",206, 0)
	2173	Q IBAMBR
	2174	"RTN","IBC BB11",207, 0)
	2175	;
	2176	"RTN","IBC BB11",208, 0)
	2177	COBAMT(IBI FN) ; IB 2.0432 - IF there is a COB a mt. it mus t equal th e Total Cl
	2178	aim Charge Amount
	2179	"RTN","IBC BB11",209, 0)
	2180	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2181	"RTN","IBC BB11",210, 0)
	2182	; OUTPUT - 0 = no e rror
	2183	"RTN","IBC BB11",211, 0)
	2184	; 1 = Erro r
	2185	"RTN","IBC BB11",212, 0)
	2186	;
	2187	"RTN","IBC BB11",213, 0)
	2188	Q:IBIFN=" " 0
	2189	"RTN","IBC BB11",214, 0)
	2190	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)="" 0
	2191	"RTN","IBC BB11",215, 0)
	2192	Q:+$P($G( ^DGCR(399, IBIFN,"U1" )),U)'=+$P ($G(^DGCR( 399,IBIFN, "U4")),U) 1
	2193	"RTN","IBC BB11",216, 0)
	2194	Q 0
	2195	"RTN","IBC BB11",217, 0)
	2196	;
	2197	"RTN","IBC BB11",218, 0)
	2198	COBMRA(IBI FN) ; IB 2.0432 - If there is a 'COB total non- covered am ount' (Fil
	2199	e#399, Fie ld#260),
	2200	"RTN","IBC BB11",219, 0)
	2201	; Primary Insurance must be M edicare th at never w ent to Med icare, and this must
	2202	be a 2nda ry or tert iary claim
	2203	"RTN","IBC BB11",220, 0)
	2204	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2205	"RTN","IBC BB11",221, 0)
	2206	; OUTPUT - 0 = no e rror
	2207	"RTN","IBC BB11",222, 0)
	2208	; 1 = Erro r
	2209	"RTN","IBC BB11",223, 0)
	2210	;
	2211	"RTN","IBC BB11",224, 0)
	2212	N IBP
	2213	"RTN","IBC BB11",225, 0)
	2214	Q:IBIFN=" " 0
	2215	"RTN","IBC BB11",226, 0)
	2216	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)="" 0
	2217	"RTN","IBC BB11",227, 0)
	2218	S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN
	2219	"RTN","IBC BB11",228, 0)
	2220	I $$WNRBI LL^IBEFUNC (IBIFN,1), $P($G(^DGC R(399,IBP, "S")),U,7) ="",$$COBN ^IBCEF(IBI
	2221	FN)>1 Q 0
	2222	"RTN","IBC BB11",229, 0)
	2223	Q 1
	2224	"RTN","IBC BB11",230, 0)
	2225	;
	2226	"RTN","IBC BB11",231, 0)
	2227	COBSEC(IBI FN) ; IB 2.0432 - If there is NOT a ' COB total non-covere d amount'
	2228	(File#399, Field#260 ),
	2229	"RTN","IBC BB11",232, 0)
	2230	; and Pri mary Insur ance is Me dicare tha t never we nt to Medi care, 2nda ry or tert
	2231	iary claim cannot be set to tr ansmit
	2232	"RTN","IBC BB11",233, 0)
	2233	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2234	"RTN","IBC BB11",234, 0)
	2235	; OUTPUT - 0 = no e rror
	2236	"RTN","IBC BB11",235, 0)
	2237	; 1 = Erro r
	2238	"RTN","IBC BB11",236, 0)
	2239	;
	2240	"RTN","IBC BB11",237, 0)
	2241	N IBP
	2242	"RTN","IBC BB11",238, 0)
	2243	Q:IBIFN=" " 0
	2244	"RTN","IBC BB11",239, 0)
	2245	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)'="" 0
	2246	"RTN","IBC BB11",240, 0)
	2247	Q:$$COBN^ IBCEF(IBIF N)<2 0
	2248	"RTN","IBC BB11",241, 0)
	2249	S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN
	2250	"RTN","IBC BB11",242, 0)
	2251	I $$WNRBI LL^IBEFUNC (IBIFN,1), $P($G(^DGC R(399,IBP, "S")),U,7) ="",$P($G( ^DGCR(399,
	2252	IBIFN,"TX" )),U,8)'=1 Q 1
	2253	"RTN","IBC BB11",243, 0)
	2254	Q 0
	2255	"RTN","IBC BB11",244, 0)
	2256	;
	2257	"RTN","IBC BB11",245, 0)
	2258	TMCK(IBIFN ) ; IB2. 0432 - At tachment C ontrol Num ber - REQU IRED when Transmissi
	2259	on Method = BM, EL, EM, or FT
	2260	"RTN","IBC BB11",246, 0)
	2261	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2262	"RTN","IBC BB11",247, 0)
	2263	; OUTPUT - 0 = no e rror
	2264	"RTN","IBC BB11",248, 0)
	2265	; 1 = Erro r
	2266	"RTN","IBC BB11",249, 0)
	2267	;
	2268	"RTN","IBC BB11",250, 0)
	2269	N IBAC
	2270	"RTN","IBC BB11",251, 0)
	2271	Q:IBIFN=" " 0
	2272	"RTN","IBC BB11",252, 0)
	2273	F I=1,3 S IBAC(I)=$ P($G(^DGCR (399,IBIFN ,"U8")),U, I)
	2274	"RTN","IBC BB11",253, 0)
	2275	Q:IBAC(3) ="" 0
	2276	"RTN","IBC BB11",254, 0)
	2277	Q:IBAC(1) '="" 0
	2278	"RTN","IBC BB11",255, 0)
	2279	Q:IBAC(3) ="AA" 0
	2280	"RTN","IBC BB11",256, 0)
	2281	Q 1
	2282	"RTN","IBC BB11",257, 0)
	2283	;
	2284	"RTN","IBC BB11",258, 0)
	2285	ACCK(IBIFN ) ; IB2.0 432 If an y of the l oop info i s present, then Repo rt Type &
	2286	Transmissi on Method req'd
	2287	"RTN","IBC BB11",259, 0)
	2288	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2289	"RTN","IBC BB11",260, 0)
	2290	; OUTPUT - 0 = no e rror
	2291	"RTN","IBC BB11",261, 0)
	2292	; 1 = Erro r
	2293	"RTN","IBC BB11",262, 0)
	2294	;
	2295	"RTN","IBC BB11",263, 0)
	2296	N IBAC
	2297	"RTN","IBC BB11",264, 0)
	2298	Q:IBIFN=" " 0
	2299	"RTN","IBC BB11",265, 0)
	2300	F I=1:1:3 S IBAC(I) =$P($G(^DG CR(399,IBI FN,"U8")), U,I)
	2301	"RTN","IBC BB11",266, 0)
	2302	; All fie lds null, no error
	2303	"RTN","IBC BB11",267, 0)
	2304	I IBAC(1) ="",IBAC(2 )="",IBAC( 3)="" Q 0
	2305	"RTN","IBC BB11",268, 0)
	2306	; Both re quired fie lds comple te, no err or
	2307	"RTN","IBC BB11",269, 0)
	2308	I IBAC(2) '="",IBAC( 3)'="" Q 0
	2309	"RTN","IBC BB11",270, 0)
	2310	; At this point, on e of the 2 required fields has data and one does n ot, so err
	2311	or
	2312	"RTN","IBC BB11",271, 0)
	2313	Q 1
	2314	"RTN","IBC BB11",272, 0)
	2315	;
	2316	"RTN","IBC BB11",273, 0)
	2317	LNTMCK(IBI FN) ; DEM ;IB2.043 2 - (Line Level) Att achment Co ntrol Numb er - REQUI
	2318	RED when T ransmissio n Method = BM, EL, E M, or FT
	2319	"RTN","IBC BB11",274, 0)
	2320	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2321	"RTN","IBC BB11",275, 0)
	2322	; OUTPUT - IBLNERR = 0 = no e rror
	2323	"RTN","IBC BB11",276, 0)
	2324	; IBLNERR = 1 = Erro r
	2325	"RTN","IBC BB11",277, 0)
	2326	;
	2327	"RTN","IBC BB11",278, 0)
	2328	N IBAC,IB PROCP,I,IB LNERR
	2329	"RTN","IBC BB11",279, 0)
	2330	S IBLNERR =0 ; DEM; 432 - Init ialize err or flag IB LNERR to ' 0' for no errors.
	2331	"RTN","IBC BB11",280, 0)
	2332	Q:IBIFN=" " IBLNERR
	2333	"RTN","IBC BB11",281, 0)
	2334	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL
	2335	NERR
	2336	"RTN","IBC BB11",282, 0)
	2337	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,0 ))#10) ; DEM;432 - Node '0' i s procedur
	2338	e node.
	2339	"RTN","IBC BB11",283, 0)
	2340	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; DEM;432 - Node '1' i s line lev
	2341	el Attachm ent Contro l fields.
	2342	"RTN","IBC BB11",284, 0)
	2343	. F I=1,3 S IBAC(I) =$P(^DGCR( 399,IBIFN, "CP",IBPRO CP,1),U,I)
	2344	"RTN","IBC BB11",285, 0)
	2345	. I IBAC( 3)="" S IB LNERR=0 Q
	2346	"RTN","IBC BB11",286, 0)
	2347	. I IBAC( 1)'="" S I BLNERR=0 Q
	2348	"RTN","IBC BB11",287, 0)
	2349	. I (IBAC (3)="AA") S IBLNERR= 0 Q
	2350	"RTN","IBC BB11",288, 0)
	2351	. S IBLNE RR=1
	2352	"RTN","IBC BB11",289, 0)
	2353	. Q
	2354	"RTN","IBC BB11",290, 0)
	2355	;
	2356	"RTN","IBC BB11",291, 0)
	2357	Q IBLNERR
	2358	"RTN","IBC BB11",292, 0)
	2359	;
	2360	"RTN","IBC BB11",293, 0)
	2361	LNACCK(IBI FN) ; DEM; IB2.0432 (Line Lev el) If any of the lo op info is present,
	2362	then Repor t Type & T ransmissio n Method r eq'd
	2363	"RTN","IBC BB11",294, 0)
	2364	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2365	"RTN","IBC BB11",295, 0)
	2366	; OUTPUT - IBLNERR = 0 = no e rror
	2367	"RTN","IBC BB11",296, 0)
	2368	; IBLNERR = 1 = Erro r
	2369	"RTN","IBC BB11",297, 0)
	2370	;
	2371	"RTN","IBC BB11",298, 0)
	2372	N IBAC,IB PROCP,I,IB LNERR
	2373	"RTN","IBC BB11",299, 0)
	2374	S IBLNERR =0 ; DEM; 432 - Init ialize err or flag IB LNERR to ' 0' for no errors.
	2375	"RTN","IBC BB11",300, 0)
	2376	Q:IBIFN=" " IBLNERR
	2377	"RTN","IBC BB11",301, 0)
	2378	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL
	2379	NERR
	2380	"RTN","IBC BB11",302, 0)
	2381	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,0 ))#10) ; DEM;432 - Node '0' i s procedur
	2382	e node.
	2383	"RTN","IBC BB11",303, 0)
	2384	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; DEM;432 - Node '1' i s line lev
	2385	el Attachm ent Contro l fields.
	2386	"RTN","IBC BB11",304, 0)
	2387	. F I=1:1 :3 S IBAC( I)=$P(^DGC R(399,IBIF N,"CP",IBP ROCP,1),U, I)
	2388	"RTN","IBC BB11",305, 0)
	2389	. ; All f ields null , no error
	2390	"RTN","IBC BB11",306, 0)
	2391	. I IBAC( 1)="",IBAC (2)="",IBA C(3)="" S IBLNERR=0 Q
	2392	"RTN","IBC BB11",307, 0)
	2393	. ; Both required f ields comp lete, no e rror
	2394	"RTN","IBC BB11",308, 0)
	2395	. I IBAC( 2)'="",IBA C(3)'="" S IBLNERR=0 Q
	2396	"RTN","IBC BB11",309, 0)
	2397	. ; At th is point, one of the 2 require d fields h as data an d one does not, so e
	2398	rror
	2399	"RTN","IBC BB11",310, 0)
	2400	. S IBLNE RR=1
	2401	"RTN","IBC BB11",311, 0)
	2402	. Q
	2403	"RTN","IBC BB11",312, 0)
	2404	;
	2405	"RTN","IBC BB11",313, 0)
	2406	Q IBLNERR
	2407	"RTN","IBJ DB21")
	2408	0^1^B12749 6258
	2409	"RTN","IBJ DB21",1,0)
	2410	IBJDB21 ;A LB/RB - RE ASONS NOT BILLABLE R EPORT (COM PILE) ;19- JUN-00
	2411	"RTN","IBJ DB21",2,0)
	2412	;;2.0;INT EGRATED BI LLING;12 3,159,185, 399,437,45 8,568;21 -MAR-94;Bu ild 2
	2413	"RTN","IBJ DB21",3,0)
	2414	;;Per VA Directive 6402, this routine s hould not be modifie d.
	2415	"RTN","IBJ DB21",4,0)
	2416	;;
	2417	"RTN","IBJ DB21",5,0)
	2418	EN ; - Ent ry point f rom IBJDB2 .
	2419	"RTN","IBJ DB21",6,0)
	2420	K ^TMP("I BJDB2",$J) ,IB,IBE,EN CTYP,EPIEN ,IBADMDT,R ELBILL
	2421	"RTN","IBJ DB21",7,0)
	2422	I '$G(IBX TRACT) D
	2423	"RTN","IBJ DB21",8,0)
	2424	. F X=1:1 :4 I IBSEL [X S IBE(X )=IBEPS(X) ; Set epi sodes for report.
	2425	"RTN","IBJ DB21",9,0)
	2426	;
	2427	"RTN","IBJ DB21",10,0 )
	2428	; - Print the heade r line for the Excel spreadshe et
	2429	"RTN","IBJ DB21",11,0 )
	2430	I $G(IBEX CEL) D PHD L
	2431	"RTN","IBJ DB21",12,0 )
	2432	;
	2433	"RTN","IBJ DB21",13,0 )
	2434	; - Compi le reason not billab le (RNB) d ata for ep isode.
	2435	"RTN","IBJ DB21",14,0 )
	2436	S IBRNB=0 F S IBRN B=$S(IBSRN B'="A":$O( IBSRNB(IBR NB)),1:$O( ^IBE(356.8 ,IBRNB)))
	2437	Q:'IBRNB D
	2438	"RTN","IBJ DB21",15,0 )
	2439	.S IB0=0 F S IB0=$ O(^IBT(356 ,"AR",IBRN B,IB0)) Q: 'IB0 D
	2440	"RTN","IBJ DB21",16,0 )
	2441	..S IBN0= $G(^IBT(35 6,IB0,0)), IBN1=$G(^I BT(356,IB0 ,1)) Q:'IB N0!('IBN1)
	2442	"RTN","IBJ DB21",17,0 )
	2443	..S IBEP= +$P(IBN0,U ,18) I IBS EL'[IBEP Q ; Get ep isode.
	2444	"RTN","IBJ DB21",18,0 )
	2445	..S (IBRN B1,IBSORT1 )=$P($G(^I BE(356.8,I BRNB,0)),U )
	2446	"RTN","IBJ DB21",19,0 )
	2447	..;
	2448	"RTN","IBJ DB21",20,0 )
	2449	..; - Get valid dat e entered/ episode da te and amo unt for re port.
	2450	"RTN","IBJ DB21",21,0 )
	2451	..S IBEPD =+$P(IBN0, U,6)\1,IBD EN=+IBN1\1
	2452	"RTN","IBJ DB21",22,0 )
	2453	..S IBDT= $S($E(IBD) ="D":IBDEN ,1:IBEPD)
	2454	"RTN","IBJ DB21",23,0 )
	2455	..Q:IBDT< IBBDT!(IBD T>IBEDT)
	2456	"RTN","IBJ DB21",24,0 )
	2457	..S IBAMT =$$AMOUNT( IBEP,IB0)
	2458	"RTN","IBJ DB21",25,0 )
	2459	..I IBAMT <0 Q ;Qui t if amoun t is -1 *5 68
	2460	"RTN","IBJ DB21",26,0 )
	2461	..;
	2462	"RTN","IBJ DB21",27,0 )
	2463	..; - Get division, if necess ary.
	2464	"RTN","IBJ DB21",28,0 )
	2465	..I IBSD D Q:'VAUT D&('$D(VAU TD(IBDIV)) )
	2466	"RTN","IBJ DB21",29,0 )
	2467	...S IBDI V=$$DIV^IB JD1(IB0)
	2468	"RTN","IBJ DB21",30,0 )
	2469	..E S IB DIV=$S($G( IBEXCEL):+ $$PRIM^VAS ITE(),1:0)
	2470	"RTN","IBJ DB21",31,0 )
	2471	..;
	2472	"RTN","IBJ DB21",32,0 )
	2473	..; - Pro vider & Sp ecialty
	2474	"RTN","IBJ DB21",33,0 )
	2475	..S (IBPR V,IBSPC)=" ",IBQT=0
	2476	"RTN","IBJ DB21",34,0 )
	2477	..I IBEP= 1!(IBEP=2) D I IBQT Q
	2478	"RTN","IBJ DB21",35,0 )
	2479	...S IBPR SP=$$PRVSP C(IBEP,IB0 )
	2480	"RTN","IBJ DB21",36,0 )
	2481	...I IBSP RV'="A",'$ D(IBSPRV(+ IBPRSP)) S IBQT=1 Q
	2482	"RTN","IBJ DB21",37,0 )
	2483	...I IBEP =1,IBSISP' ="A",'$D(I BSISP(+$P( IBPRSP,U,3 ))) S IBQT =1 Q
	2484	"RTN","IBJ DB21",38,0 )
	2485	...I IBEP =2,IBSOSP' ="A",'$D(I BSOSP(+$P( IBPRSP,U,3 ))) S IBQT =1 Q
	2486	"RTN","IBJ DB21",39,0 )
	2487	...S IBPR V=$S($P(IB PRSP,U,2)' ="":$P(IBP RSP,U,2),1 :" UNKNO WN ")
	2488	"RTN","IBJ DB21",40,0 )
	2489	...S IBSP C=$S($P(IB PRSP,U,4)' ="":$P(IBP RSP,U,4),1 :" UNKNO WN ")
	2490	"RTN","IBJ DB21",41,0 )
	2491	..;
	2492	"RTN","IBJ DB21",42,0 )
	2493	..; - Get remaining data for detailed r eport.
	2494	"RTN","IBJ DB21",43,0 )
	2495	..S DFN=+ $P(IBN0,U, 2)
	2496	"RTN","IBJ DB21",44,0 )
	2497	..D DEM^V ADPT S IBP T=$E(VADM( 1),1,25),I BSSN=$P(VA DM(2),U)
	2498	"RTN","IBJ DB21",45,0 )
	2499	..S DIC=" ^VA(200,", DA=+$P(IBN 1,U,4),DR= ".01",DIQ= "IBCLK" D EN^DIQ1
	2500	"RTN","IBJ DB21",46,0 )
	2501	..S IBCLK =$E($G(IBC LK(200,DA, .01)),1,20 )
	2502	"RTN","IBJ DB21",47,0 )
	2503	..I ($P(I BN0,U,18)= 2)&($$EXTE RNAL^DILFD (356,.19," ",$P(IBN0, U,19))["72 HOUR RULE
	2504	") D
	2505	"RTN","IBJ DB21",48,0 )
	2506	...S IBAD MDT=$$ADMD T^IBTUTL5( DFN,$P(IBN 0,U,6))
	2507	"RTN","IBJ DB21",49,0 )
	2508	..E S IB ADMDT=""
	2509	"RTN","IBJ DB21",50,0 )
	2510	..S ENCTY P=$P(^IBE( 356.6,$P(I BN0,U,18), 0),U,3) S EPDT=$E($P (IBN0,U,6) ,1,7)
	2511	"RTN","IBJ DB21",51,0 )
	2512	..S EPIEN =$S(ENCTYP =3:$P(IBN0 ,U,8),ENCT YP=4:$P(IB N0,U,9),1: "")
	2513	"RTN","IBJ DB21",52,0 )
	2514	..S RELBI LL=$$RELBI L^IBTUTL5( EPIEN,EPDT ,DFN,ENCTY P)
	2515	"RTN","IBJ DB21",53,0 )
	2516	..;
	2517	"RTN","IBJ DB21",54,0 )
	2518	..; - Get totals fo r summary.
	2519	"RTN","IBJ DB21",55,0 )
	2520	..I '$D(I B(IBDIV,IB EP,IBRNB)) S IB(IBDI V,IBEP,IBR NB)="0^0"
	2521	"RTN","IBJ DB21",56,0 )
	2522	..S $P(IB (IBDIV,IBE P,IBRNB),U )=$P(IB(IB DIV,IBEP,I BRNB),U)+1
	2523	"RTN","IBJ DB21",57,0 )
	2524	..S $P(IB (IBDIV,IBE P,IBRNB),U ,2)=$P(IB( IBDIV,IBEP ,IBRNB),U, 2)+IBAMT
	2525	"RTN","IBJ DB21",58,0 )
	2526	..I IBRPT ="S" Q
	2527	"RTN","IBJ DB21",59,0 )
	2528	..;
	2529	"RTN","IBJ DB21",60,0 )
	2530	..S IBSOR T1=$S(IBSO RT="P":IBP RV,IBSORT= "S":IBSPC, 1:IBSORT1)
	2531	"RTN","IBJ DB21",61,0 )
	2532	..S:IBSOR T1="" IBSO RT1=" "
	2533	"RTN","IBJ DB21",62,0 )
	2534	..;
	2535	"RTN","IBJ DB21",63,0 )
	2536	..I $G(IB EXCEL) D Q
	2537	"RTN","IBJ DB21",64,0 )
	2538	...W !,$E ($P($G(^DG (40.8,IBDI V,0)),U),1 ,25),U
	2539	"RTN","IBJ DB21",65,0 )
	2540	...W $S(I BEP<4:$E(I BE(IBEP)), 1:"H"),U,I BPT,U,$E(I BSSN,6,10) ,U
	2541	"RTN","IBJ DB21",66,0 )
	2542	...W $E($ $INS^IBJD1 (+$P(IBN0, U,2),IBEPD ),1,25),U
	2543	"RTN","IBJ DB21",67,0 )
	2544	...W $$DT ^IBJD(IBEP D,1),U,$$D T^IBJD(IBD EN,1),U
	2545	"RTN","IBJ DB21",68,0 )
	2546	...W $$DT ^IBJD($P(I BN1,U,3),1 ),U,IBCLK, U,IBADMDT, U,$E(IBRNB 1,1,25),U
	2547	"RTN","IBJ DB21",69,0 )
	2548	...W $E(I BPRV,1,25) ,U,$E(IBSP C,1,25),U, IBAMT,U
	2549	"RTN","IBJ DB21",70,0 )
	2550	...I RELB ILL>0 F X= 2:1:$P(REL BILL,";",1 )+1 W $P(R ELBILL,";" ,X)_" "
	2551	"RTN","IBJ DB21",71,0 )
	2552	...I RELB ILL<0 W ""
	2553	"RTN","IBJ DB21",72,0 )
	2554	...W U,$P (IBN1,U,8)
	2555	"RTN","IBJ DB21",73,0 )
	2556	..;
	2557	"RTN","IBJ DB21",74,0 )
	2558	..S X=IBE PD_U_IBDEN _U_$P(IBN1 ,U,3)_U_IB CLK_U_IBRN B1
	2559	"RTN","IBJ DB21",75,0 )
	2560	..S X=X_U _IBPRV_U_I BSPC_U_IBA MT_U_$E($P (IBN1,U,8) ,1,50)_U_I BADMDT_U_R ELBILL
	2561	"RTN","IBJ DB21",76,0 )
	2562	..S ^TMP( "IBJDB2",$ J,IBDIV,IB EP,IBSORT1 ,IBPT_"@@" _$E(IBSSN, 6,10))=$$I NS^IBJD1(+
	2563	$P(IBN0,U, 2),IBEPD)
	2564	"RTN","IBJ DB21",77,0 )
	2565	..S ^TMP( "IBJDB2",$ J,IBDIV,IB EP,IBSORT1 ,IBPT_"@@" _$E(IBSSN, 6,10),+IBN 0)=X
	2566	"RTN","IBJ DB21",78,0 )
	2567	;
	2568	"RTN","IBJ DB21",79,0 )
	2569	I '$G(IBE XCEL) D EN ^IBJDB22 ; Print rep ort(s).
	2570	"RTN","IBJ DB21",80,0 )
	2571	;
	2572	"RTN","IBJ DB21",81,0 )
	2573	ENQ K ^TMP ("IBJDB2")
	2574	"RTN","IBJ DB21",82,0 )
	2575	K DA,DIC, DIQ,DR,IB, IB0,IBAMT, IBCLK,IBDE N,IBDIV,IB DT,IBE,IBE P,IBEPD,IB I
	2576	"RTN","IBJ DB21",83,0 )
	2577	K IBN0,IB N1,IBN2,IB PRSP,IBPRV ,IBPT,IBQT ,IBRNB,IBR NB1,IBSORT 1,IBSPC
	2578	"RTN","IBJ DB21",84,0 )
	2579	K IBSSN,V ADM,X1,X2
	2580	"RTN","IBJ DB21",85,0 )
	2581	Q
	2582	"RTN","IBJ DB21",86,0 )
	2583	;
	2584	"RTN","IBJ DB21",87,0 )
	2585	AMOUNT(EPS ,CLM) ; Re turn the A mount not billed
	2586	"RTN","IBJ DB21",88,0 )
	2587	; Input: EPS - Epis ode(1=Inpa tient,2=Ou tpatient,3 =Prosthet. ,4=Prescr. )
	2588	"RTN","IBJ DB21",89,0 )
	2589	; CLM - Poin ter to Cla im Trackin g File (#3 56)
	2590	"RTN","IBJ DB21",90,0 )
	2591	;Output: AMOUNT not billed
	2592	"RTN","IBJ DB21",91,0 )
	2593	;
	2594	"RTN","IBJ DB21",92,0 )
	2595	N ADM,ADM DT,AMOUNT, BLBS,BLDT, CPT,CPTLST ,DA,DR,DCH D,DFN,DIC, DIQ,DIV,DR G,SPCLTY
	2596	"RTN","IBJ DB21",93,0 )
	2597	N IBRX,EN C,ENCDT,EP DT,PFT,PRS T,PTF,RIMB ,VCPT,TTCS T,X
	2598	"RTN","IBJ DB21",94,0 )
	2599	;
	2600	"RTN","IBJ DB21",95,0 )
	2601	S AMOUNT= 0,X=$G(^IB T(356,CLM, 0))
	2602	"RTN","IBJ DB21",96,0 )
	2603	S ENC=+$P (X,U,4) ; Encoun ter (Po inter to # 409.68)
	2604	"RTN","IBJ DB21",97,0 )
	2605	S ADM=+$P (X,U,5) ; Admiss ion (Po inter to # 405)
	2606	"RTN","IBJ DB21",98,0 )
	2607	S PRST=+$ P(X,U,9) ; Prothe tics (Po inter to # 660)
	2608	"RTN","IBJ DB21",99,0 )
	2609	S EPDT=$P (X,U,6) ; Episod e Date (FM format)
	2610	"RTN","IBJ DB21",100, 0)
	2611	S IBRX=+$ P(X,U,8)
	2612	"RTN","IBJ DB21",101, 0)
	2613	;
	2614	"RTN","IBJ DB21",102, 0)
	2615	; - Assum es REIMBUR SABLE INS. as the RA TE TYPE
	2616	"RTN","IBJ DB21",103, 0)
	2617	S RIMB=$O (^DGCR(399 .3,"B","RE IMBURSABLE INS.",0)) I 'RIMB S RIMB=8
	2618	"RTN","IBJ DB21",104, 0)
	2619	;
	2620	"RTN","IBJ DB21",105, 0)
	2621	G @("AMT" _EPS)
	2622	"RTN","IBJ DB21",106, 0)
	2623	;
	2624	"RTN","IBJ DB21",107, 0)
	2625	AMT1 ; - I npatient C harges
	2626	"RTN","IBJ DB21",108, 0)
	2627	I 'ADM S AMOUNT=-1 G QAMT
	2628	"RTN","IBJ DB21",109, 0)
	2629	S X=$G(^D GPM(ADM,0) ) I X="" S AMOUNT=-1 G QAMT
	2630	"RTN","IBJ DB21",110, 0)
	2631	S PTF=$P( X,U,16) I 'PTF S AMO UNT=-1 G Q AMT
	2632	"RTN","IBJ DB21",111, 0)
	2633	S ADMDT=$ P(X,U)\1,D FN=+$P(X,U ,3)
	2634	"RTN","IBJ DB21",112, 0)
	2635	I $P(X,U, 17) S DCHD =$P($G(^DG PM(+$P(X,U ,17),0)),U )\1
	2636	"RTN","IBJ DB21",113, 0)
	2637	I '$G(DCH D) S DCHD= $$DT^XLFDT ()
	2638	"RTN","IBJ DB21",114, 0)
	2639	;
	2640	"RTN","IBJ DB21",115, 0)
	2641	K ^TMP($J ,"IBCRC-PT F"),^TMP($ J,"IBCRC-D IV"),^TMP( $J,"IBCRC- INDT")
	2642	"RTN","IBJ DB21",116, 0)
	2643	D PTF^IBC RBG(PTF) I '$D(^TMP( $J,"IBCRC- PTF")) S A MOUNT=-1 G QAMT ;*5 68
	2644	"RTN","IBJ DB21",117, 0)
	2645	D PTFDV^I BCRBG(PTF) I '$D(^TM P($J,"IBCR C-DIV")) S AMOUNT=-1 G QAMT ; *568
	2646	"RTN","IBJ DB21",118, 0)
	2647	D BSLOS^I BCRBG(ADMD T,DCHD,1,A DM,0) I '$ D(^TMP($J, "IBCRC-IND T")) S AMO UNT=-1 G Q
	2648	AMT ;*568
	2649	"RTN","IBJ DB21",119, 0)
	2650	;
	2651	"RTN","IBJ DB21",120, 0)
	2652	S BLDT=""
	2653	"RTN","IBJ DB21",121, 0)
	2654	F S BLDT =$O(^TMP($ J,"IBCRC-I NDT",BLDT) ) Q:BLDT=" " D
	2655	"RTN","IBJ DB21",122, 0)
	2656	.S X=^TMP ($J,"IBCRC -INDT",BLD T)
	2657	"RTN","IBJ DB21",123, 0)
	2658	.S BLBS=$ P(X,U,2),D RG=$P(X,U, 4),DIV=$P( X,U,5),SPC LTY=$P(X,U ,6)
	2659	"RTN","IBJ DB21",124, 0)
	2660	.;
	2661	"RTN","IBJ DB21",125, 0)
	2662	.; - Tort Liable Ch arge (prio r to 09/01 /99)
	2663	"RTN","IBJ DB21",126, 0)
	2664	.I BLDT<2 990901 D Q
	2665	"RTN","IBJ DB21",127, 0)
	2666	..S AMOUN T=AMOUNT+$ $BICOST^IB CRCI(RIMB, 1,BLDT,"IN PATIENT BE DSECTION S TAY",BLBS)
	2667	"RTN","IBJ DB21",128, 0)
	2668	.;
	2669	"RTN","IBJ DB21",129, 0)
	2670	.; - Reas onable Cha rges (on 0 9/01/99 or later)
	2671	"RTN","IBJ DB21",130, 0)
	2672	.I $$NODR G^IBCRBG2( SPCLTY)["O bservation " Q
	2673	"RTN","IBJ DB21",131, 0)
	2674	.I $$NODR G^IBCRBG2( SPCLTY)["N ursing Hom e Care" D Q
	2675	"RTN","IBJ DB21",132, 0)
	2676	..S BLBS= $$MCCRUTL^ IBCRU1("SK ILLED NURS ING CARE", 25)
	2677	"RTN","IBJ DB21",133, 0)
	2678	..S AMOUN T=AMOUNT+$ $BICOST^IB CRCI(RIMB, 1,BLDT,"IN PATIENT BE DSECTION S TAY",BLBS,
	2679	"",DIV,"", 1)
	2680	"RTN","IBJ DB21",134, 0)
	2681	.;
	2682	"RTN","IBJ DB21",135, 0)
	2683	.S BLBS=$ $BSUPD^IBC RBG2(+SPCL TY,BLDT,1)
	2684	"RTN","IBJ DB21",136, 0)
	2685	.S AMOUNT =AMOUNT+$$ BICOST^IBC RCI(RIMB,1 ,BLDT,"INP ATIENT DRG ",DRG,"",D IV,"",1,BL
	2686	BS)
	2687	"RTN","IBJ DB21",137, 0)
	2688	;
	2689	"RTN","IBJ DB21",138, 0)
	2690	; - Add t he Profess ional Aver age Amount per Episo de (Reason .Chg only)
	2691	"RTN","IBJ DB21",139, 0)
	2692	I EPDT'<2 990901 S A MOUNT=AMOU NT+$$AVG(E PDT)
	2693	"RTN","IBJ DB21",140, 0)
	2694	;
	2695	"RTN","IBJ DB21",141, 0)
	2696	; - Subtr act the am ount bille d for this Episode
	2697	"RTN","IBJ DB21",142, 0)
	2698	S AMOUNT= AMOUNT-$$C LAMT(DFN,E PDT,1) I A MOUNT=0 S AMOUNT=-1 ;*568
	2699	"RTN","IBJ DB21",143, 0)
	2700	;
	2701	"RTN","IBJ DB21",144, 0)
	2702	K ^TMP($J ,"IBCRC-PT F"),^TMP($ J,"IBCRC-D IV"),^TMP( $J,"IBCRC- INDT")
	2703	"RTN","IBJ DB21",145, 0)
	2704	;
	2705	"RTN","IBJ DB21",146, 0)
	2706	G QAMT
	2707	"RTN","IBJ DB21",147, 0)
	2708	;
	2709	"RTN","IBJ DB21",148, 0)
	2710	AMT2 ; - O utpatient Charges
	2711	"RTN","IBJ DB21",149, 0)
	2712	S X=$$GET OE^SDOE(EN C),ENCDT=+ $P(X,U),DF N=+$P(X,U, 2),DIV=$P( X,U,11)
	2713	"RTN","IBJ DB21",150, 0)
	2714	;
	2715	"RTN","IBJ DB21",151, 0)
	2716	; - Tort Liable Cha rge (prior to 09/01/ 99)
	2717	"RTN","IBJ DB21",152, 0)
	2718	I ENCDT<2 990901 D G QAMT
	2719	"RTN","IBJ DB21",153, 0)
	2720	. S AMOUN T=+$$BICOS T^IBCRCI(R IMB,3,ENCD T,"OUTPATI ENT VISIT DATE")
	2721	"RTN","IBJ DB21",154, 0)
	2722	;
	2723	"RTN","IBJ DB21",155, 0)
	2724	S AMOUNT= $$OPT(ENC, EPDT) ;*5 68
	2725	"RTN","IBJ DB21",156, 0)
	2726	G QAMT ; *568
	2727	"RTN","IBJ DB21",157, 0)
	2728	;
	2729	"RTN","IBJ DB21",158, 0)
	2730	AMT3 ; Pro sthetic Ch arges
	2731	"RTN","IBJ DB21",159, 0)
	2732	N NTBLD
	2733	"RTN","IBJ DB21",160, 0)
	2734	S NTBLD=$ $PRSAMT^IB TUTL5(EPDT ,PRST) I N TBLD=0 S A MOUNT=-1 G QAMT ;*5 68
	2735	"RTN","IBJ DB21",161, 0)
	2736	S DIC="^R MPR(660,", DA=PRST,DR ="14",DIQ= "TTCST" D EN^DIQ1
	2737	"RTN","IBJ DB21",162, 0)
	2738	S AMOUNT= +$G(TTCST( 660,DA,14) )
	2739	"RTN","IBJ DB21",163, 0)
	2740	G QAMT
	2741	"RTN","IBJ DB21",164, 0)
	2742	;
	2743	"RTN","IBJ DB21",165, 0)
	2744	AMT4 ; - P rescriptio n Charges
	2745	"RTN","IBJ DB21",166, 0)
	2746	;
	2747	"RTN","IBJ DB21",167, 0)
	2748	; Protect Rx intern al entry # before RX AMT call s witches to RX number
	2749	"RTN","IBJ DB21",168, 0)
	2750	N IBRXIEN ,NTBLD S I BRXIEN=IBR X
	2751	"RTN","IBJ DB21",169, 0)
	2752	;
	2753	"RTN","IBJ DB21",170, 0)
	2754	; - Tort Liable Cha rge & Reas onable Cha rge (same source)
	2755	"RTN","IBJ DB21",171, 0)
	2756	S NTBLD=$ $RXAMT^IBT UTL5(EPDT, IBRX) I NT BLD=0 S AM OUNT=-1 G QAMT ;*56 8
	2757	"RTN","IBJ DB21",172, 0)
	2758	;
	2759	"RTN","IBJ DB21",173, 0)
	2760	; Patch 4 37 update to call ch arge maste r with eno ugh inform ation
	2761	"RTN","IBJ DB21",174, 0)
	2762	; to look up actual cost of pr escription
	2763	"RTN","IBJ DB21",175, 0)
	2764	;
	2765	"RTN","IBJ DB21",176, 0)
	2766	N IBBI,IB RSNEW
	2767	"RTN","IBJ DB21",177, 0)
	2768	;
	2769	"RTN","IBJ DB21",178, 0)
	2770	; check c harge mast er for the type of b illing--VA Cost or n ot
	2771	"RTN","IBJ DB21",179, 0)
	2772	S IBBI=$$ EVNTITM^IB CRU3(+RIMB ,3,"PRESCR IPTION FIL L",EPDT,.I BRSNEW)
	2773	"RTN","IBJ DB21",180, 0)
	2774	;
	2775	"RTN","IBJ DB21",181, 0)
	2776	S DFN=$$F ILE^IBRXUT L(IBRXIEN, 2)
	2777	"RTN","IBJ DB21",182, 0)
	2778	I $G(DFN) >0&(IBBI[" VA COST") D
	2779	"RTN","IBJ DB21",183, 0)
	2780	. N IBQT Y,IBCOST,I BRFNUM,IBS UBND,IBFEE ,IBRXNODE
	2781	"RTN","IBJ DB21",184, 0)
	2782	.; if th is is a re fill look up the ref ill info f or cost an d quantity
	2783	"RTN","IBJ DB21",185, 0)
	2784	. S IBRF NUM=$$RFLN UM^IBRXUTL (IBRXIEN,E PDT,"")
	2785	"RTN","IBJ DB21",186, 0)
	2786	. I IBRF NUM>0 D
	2787	"RTN","IBJ DB21",187, 0)
	2788	.. S I BSUBND=$$Z EROSUB^IBR XUTL(DFN,I BRXIEN,IBR FNUM)
	2789	"RTN","IBJ DB21",188, 0)
	2790	.. S I BQTY=$P($G (IBSUBND), U,4)
	2791	"RTN","IBJ DB21",189, 0)
	2792	.. S I BCOST=$P($ G(IBSUBND) ,U,11)
	2793	"RTN","IBJ DB21",190, 0)
	2794	.;
	2795	"RTN","IBJ DB21",191, 0)
	2796	.; if th is was an original f ill look u p zero nod e for Rx i nfo
	2797	"RTN","IBJ DB21",192, 0)
	2798	. E D
	2799	"RTN","IBJ DB21",193, 0)
	2800	.. S I BRXNODE=$$ RXZERO^IBR XUTL(DFN,I BRXIEN)
	2801	"RTN","IBJ DB21",194, 0)
	2802	.. S I BQTY=$P($G (IBRXNODE) ,U,7)
	2803	"RTN","IBJ DB21",195, 0)
	2804	.. S I BCOST=$P($ G(IBRXNODE ),U,17)
	2805	"RTN","IBJ DB21",196, 0)
	2806	.;
	2807	"RTN","IBJ DB21",197, 0)
	2808	. S IBRS NEW=+$O(IB RSNEW($P(I BBI,";"),0 ))
	2809	"RTN","IBJ DB21",198, 0)
	2810	. S AMOU NT=$J(+$$R ATECHG^IBC RCC(+IBRSN EW,IBQTY*I BCOST,EPDT ,.IBFEE),0 ,2)
	2811	"RTN","IBJ DB21",199, 0)
	2812	E D
	2813	"RTN","IBJ DB21",200, 0)
	2814	. S AMOU NT=+$$BICO ST^IBCRCI( RIMB,3,EPD T,"PRESCRI PTION FILL ")
	2815	"RTN","IBJ DB21",201, 0)
	2816	;
	2817	"RTN","IBJ DB21",202, 0)
	2818	;
	2819	"RTN","IBJ DB21",203, 0)
	2820	QAMT I AMO UNT=0 S AM OUNT=-1 ;* 568
	2821	"RTN","IBJ DB21",204, 0)
	2822	Q AMOUNT
	2823	"RTN","IBJ DB21",205, 0)
	2824	;
	2825	"RTN","IBJ DB21",206, 0)
	2826	CLAMT(DFN, EPDT,PT) ; Returns t he Total A mount of C laims for Patient/Ep isode
	2827	"RTN","IBJ DB21",207, 0)
	2828	;
	2829	"RTN","IBJ DB21",208, 0)
	2830	; Input: DFN - Poi nter to th e Patient File #2
	2831	"RTN","IBJ DB21",209, 0)
	2832	; EPDT - Epi sode Date
	2833	"RTN","IBJ DB21",210, 0)
	2834	; PT - 0=O utpatient, 1=Inpatie nt
	2835	"RTN","IBJ DB21",211, 0)
	2836	;
	2837	"RTN","IBJ DB21",212, 0)
	2838	N CLAMT,C LM,DAY,IBD ,X
	2839	"RTN","IBJ DB21",213, 0)
	2840	S CLAMT=0 ,DAY=EPDT- 1,CLM=""
	2841	"RTN","IBJ DB21",214, 0)
	2842	F S CLM= $O(^DGCR(3 99,"C",DFN ,CLM)) Q:' CLM D
	2843	"RTN","IBJ DB21",215, 0)
	2844	.S X=$G(^ DGCR(399,C LM,0))
	2845	"RTN","IBJ DB21",216, 0)
	2846	.I $P($P( X,U,3),"." )=$P(EPDT, ".") D
	2847	"RTN","IBJ DB21",217, 0)
	2848	..S IBD=$ $CKBIL^IBT UBOU(CLM,P T) Q:IBD=" "
	2849	"RTN","IBJ DB21",218, 0)
	2850	..I '$P(I BD,U,3) Q ; Not aut horized
	2851	"RTN","IBJ DB21",219, 0)
	2852	..S CLAMT =CLAMT+$G( ^DGCR(399, CLM,"U1"))
	2853	"RTN","IBJ DB21",220, 0)
	2854	;
	2855	"RTN","IBJ DB21",221, 0)
	2856	QCLAMT Q C LAMT
	2857	"RTN","IBJ DB21",222, 0)
	2858	;
	2859	"RTN","IBJ DB21",223, 0)
	2860	OPT(IBOE,I BDT) ; - H as the out patient en counter be en billed?
	2861	"RTN","IBJ DB21",224, 0)
	2862	; Input : IBOE=poi nter to ou tpatient e ncounter i n file #40 9.68
	2863	"RTN","IBJ DB21",225, 0)
	2864	; IBDT=eve nt date CL AIMS TRACK ING(#356)
	2865	"RTN","IBJ DB21",226, 0)
	2866	;
	2867	"RTN","IBJ DB21",227, 0)
	2868	; ; *P re-set var iables: DF N=patient IEN, RIMB= bill rate
	2869	"RTN","IBJ DB21",228, 0)
	2870	;
	2871	"RTN","IBJ DB21",229, 0)
	2872	;
	2873	"RTN","IBJ DB21",230, 0)
	2874	I '$G(DFN )!('$G(IBD T))!('$G(R IMB))!('$G (IBOE)) S IBRTN=0 G OPTQ
	2875	"RTN","IBJ DB21",231, 0)
	2876	N IBCN,IB CPT,IBCT,I BDATA,IBDA Y,IBDIV,IB XX,IBYD,IB YY,IBZ,IBM RA,IBCPTSU M,IBTCHRG,
	2877	IBRTN,IBAU TH
	2878	"RTN","IBJ DB21",232, 0)
	2879	; - Check to be sur e the enco unter is b illable.
	2880	"RTN","IBJ DB21",233, 0)
	2881	I $$INPT^ IBAMTS1(DF N,IBDT\1_. 2359) S IB RTN=-1 G O PTQ ; Bec ame inpati ent same d
	2882	ay.
	2883	"RTN","IBJ DB21",234, 0)
	2884	I $$ENCL^ IBAMTS2(IB OE)["1" S IBRTN=-1 G OPTQ ; " ao^ir^sc^s wa^mst^hnc ^cv^shad"
	2885	encounter.
	2886	"RTN","IBJ DB21",235, 0)
	2887	;
	2888	"RTN","IBJ DB21",236, 0)
	2889	;
	2890	"RTN","IBJ DB21",237, 0)
	2891	; - Gathe r all proc edures ass ociated wi th the enc ounter.
	2892	"RTN","IBJ DB21",238, 0)
	2893	D GETCPT^ SDOE(IBOE, "IBYY") I '$G(IBYY) S IBRTN=-1 G OPTQ ; Check CPT qty.
	2894	"RTN","IBJ DB21",239, 0)
	2895	;
	2896	"RTN","IBJ DB21",240, 0)
	2897	; - Deter mine the e ncounter d ivision.
	2898	"RTN","IBJ DB21",241, 0)
	2899	S IBDIV=+ $P($$GETOE ^SDOE(IBOE ),U,11) S: 'IBDIV IBD IV=+$$PRIM ^VASITE()
	2900	"RTN","IBJ DB21",242, 0)
	2901	;
	2902	"RTN","IBJ DB21",243, 0)
	2903	; - Build array of all billab le encount er procedu res.
	2904	"RTN","IBJ DB21",244, 0)
	2905	S IBXX=0 F S IBXX= $O(IBYY(IB XX)) Q:'IB XX D
	2906	"RTN","IBJ DB21",245, 0)
	2907	. ;
	2908	"RTN","IBJ DB21",246, 0)
	2909	. ; - Get procedure pointer a nd code.
	2910	"RTN","IBJ DB21",247, 0)
	2911	. S IBZ=+ IBYY(IBXX) ,IBCN=$P($ $CPT^ICPTC OD(IBZ),"^ ",2)
	2912	"RTN","IBJ DB21",248, 0)
	2913	. ;
	2914	"RTN","IBJ DB21",249, 0)
	2915	. ; - Ign ore LAB se rvices for vets with Medicare Supplement al coverag e.
	2916	"RTN","IBJ DB21",250, 0)
	2917	. I IBCN> 79999,IBCN <90000 Q
	2918	"RTN","IBJ DB21",251, 0)
	2919	. ;
	2920	"RTN","IBJ DB21",252, 0)
	2921	. ; - Get the insti tutional/p rofessiona l charge c omponents.
	2922	"RTN","IBJ DB21",253, 0)
	2923	. S IBCPT (IBZ,1)=+$ $BICOST^IB CRCI(RIMB, 3,IBDT,"PR OCEDURE",I BZ,"",IBDI V,"",1)
	2924	"RTN","IBJ DB21",254, 0)
	2925	. S IBCPT (IBZ,2)=+$ $BICOST^IB CRCI(RIMB, 3,IBDT,"PR OCEDURE",I BZ,"",IBDI V,"",2)
	2926	"RTN","IBJ DB21",255, 0)
	2927	. ;
	2928	"RTN","IBJ DB21",256, 0)
	2929	. ; - Eli minate com ponents wi thout a ch arge.
	2930	"RTN","IBJ DB21",257, 0)
	2931	. S IBCPT SUM(IBZ)=+ $G(IBCPT(I BZ,1))+$G( IBCPT(IBZ, 2))
	2932	"RTN","IBJ DB21",258, 0)
	2933	. I 'IBCP T(IBZ,1) K IBCPT(IBZ ,1)
	2934	"RTN","IBJ DB21",259, 0)
	2935	. I 'IBCP T(IBZ,2) K IBCPT(IBZ ,2)
	2936	"RTN","IBJ DB21",260, 0)
	2937	;
	2938	"RTN","IBJ DB21",261, 0)
	2939	I '$D(IBC PT) S IBRT N=-1 G OPT Q ; Quit i f no billa ble proced ures remai n.
	2940	"RTN","IBJ DB21",262, 0)
	2941	;
	2942	"RTN","IBJ DB21",263, 0)
	2943	; - Look at all of the vet's bills for the day an d eliminat e
	2944	"RTN","IBJ DB21",264, 0)
	2945	; from the array those proc edures tha t have bee n billed.
	2946	"RTN","IBJ DB21",265, 0)
	2947	S IBXX=0 S IBDAY=$E (IBDT,1,7)
	2948	"RTN","IBJ DB21",266, 0)
	2949	F S IBXX =$O(^DGCR( 399,"AOPV" ,DFN,IBDAY ,IBXX)) Q: 'IBXX D
	2950	"RTN","IBJ DB21",267, 0)
	2951	. ;
	2952	"RTN","IBJ DB21",268, 0)
	2953	. ; - Per form gener al checks on the cla im.
	2954	"RTN","IBJ DB21",269, 0)
	2955	. S IBDAT A=$$CKBIL^ IBTUBOU(IB XX) Q:IBDA TA=""
	2956	"RTN","IBJ DB21",270, 0)
	2957	. S IBAUT H=$P($G(IB DATA),U,2)
	2958	"RTN","IBJ DB21",271, 0)
	2959	. I $G(IB AUTH)<2&($ G(IBAUTH)> 5) Q
	2960	"RTN","IBJ DB21",272, 0)
	2961	. ; - The episode h as been bi lled. Chec k the reve nue code m ultiple fo r
	2962	"RTN","IBJ DB21",273, 0)
	2963	. ; all procedure s billed o n the clai m.
	2964	"RTN","IBJ DB21",274, 0)
	2965	. S IBYY= 0
	2966	"RTN","IBJ DB21",275, 0)
	2967	. F S IB YY=$O(^DGC R(399,IBXX ,"RC",IBYY )) Q:'IBYY S IBYD=^ (IBYY,0) D
	2968	"RTN","IBJ DB21",276, 0)
	2969	. . ;
	2970	"RTN","IBJ DB21",277, 0)
	2971	. . ; - G et the pro cedure cod e,charge t ype and to tal charge s for the revenue co
	2972	de.
	2973	"RTN","IBJ DB21",278, 0)
	2974	. . S IBZ =$P(IBYD,U ,6)
	2975	"RTN","IBJ DB21",279, 0)
	2976	. . S IBC T=$S($P(IB YD,U,12):$ P(IBYD,U,1 2),1:$P(IB DATA,U,4))
	2977	"RTN","IBJ DB21",280, 0)
	2978	. . S IBT CHRG=$P(IB YD,U,4)
	2979	"RTN","IBJ DB21",281, 0)
	2980	. . I 'IB Z!('IBCT) Q ; Can't determine code/char ge type fo r procedur e.
	2981	"RTN","IBJ DB21",282, 0)
	2982	. . ; Del ete proced ure from u nbilled pr ocedures a rray.
	2983	"RTN","IBJ DB21",283, 0)
	2984	. . I $G( IBTCHRG)'< $G(IBCPTSU M(IBZ)) K IBCPT(IBZ)
	2985	"RTN","IBJ DB21",284, 0)
	2986	. . I $D( IBCPT(IBZ, IBCT)) K I BCPT(IBZ,I BCT)
	2987	"RTN","IBJ DB21",285, 0)
	2988	;
	2989	"RTN","IBJ DB21",286, 0)
	2990	; - Again , quit if no billabl e procedur es remain.
	2991	"RTN","IBJ DB21",287, 0)
	2992	I '$D(IBC PT) S IBRT N=-1 G OPT Q
	2993	"RTN","IBJ DB21",288, 0)
	2994	; - If th ere are bi llable pro cedures re turn TOTAL AMOUNT
	2995	"RTN","IBJ DB21",289, 0)
	2996	I $D(IBCP T) S (IBZ, IBCT,IBRTN )=0
	2997	"RTN","IBJ DB21",290, 0)
	2998	F S IBZ= $O(IBCPT(I BZ)) Q:'IB Z D
	2999	"RTN","IBJ DB21",291, 0)
	3000	.F S IBC T=$O(IBCPT (IBZ,IBCT) ) Q:'IBCT D
	3001	"RTN","IBJ DB21",292, 0)
	3002	..S IBRTN =IBRTN+IBC PT(IBZ,IBC T)
	3003	"RTN","IBJ DB21",293, 0)
	3004	I IBRTN=0 S IBRTN=- 1
	3005	"RTN","IBJ DB21",294, 0)
	3006	;
	3007	"RTN","IBJ DB21",295, 0)
	3008	OPTQ K IBC PT Q IBRTN
	3009	"RTN","IBJ DB21",296, 0)
	3010	;
	3011	"RTN","IBJ DB21",297, 0)
	3012	AVG(EPDT) ; Returns the Averag e Amount o f Inpatien t Professi onal per
	3013	"RTN","IBJ DB21",298, 0)
	3014	; Number of Episodes for the pr evious 12 months
	3015	"RTN","IBJ DB21",299, 0)
	3016	N AVG,M,Z
	3017	"RTN","IBJ DB21",300, 0)
	3018	S AVG=0,M =EPDT\100* 100
	3019	"RTN","IBJ DB21",301, 0)
	3020	I '$D(^IB E(356.19,M ,1)) S M=$ O(^IBE(356 .19,M),-1) I 'M G QA VG
	3021	"RTN","IBJ DB21",302, 0)
	3022	S Z=$G(^I BE(356.19, M,1)) I $P (Z,U,12) S AVG=$P(Z, U,11)/$P(Z ,U,12)
	3023	"RTN","IBJ DB21",303, 0)
	3024	QAVG Q $J( AVG,0,2)
	3025	"RTN","IBJ DB21",304, 0)
	3026	;
	3027	"RTN","IBJ DB21",305, 0)
	3028	PRVSPC(EPS ,CLM) ; Re turn the P rovider an d the Spec ialty
	3029	"RTN","IBJ DB21",306, 0)
	3030	; Input: EPS - Epi sode(1 = I npatient O R 2 = Outp atient)
	3031	"RTN","IBJ DB21",307, 0)
	3032	; CLM - Poi nter to Cl aim Tracki ng File (# 356)
	3033	"RTN","IBJ DB21",308, 0)
	3034	; Output: Provider Code (Poin ter to #20 0) ^ Provi der Name ^
	3035	"RTN","IBJ DB21",309, 0)
	3036	; Specialty Code (Poi nter to #4 0.7 or #45 .7) ^ Spec ialty Name
	3037	"RTN","IBJ DB21",310, 0)
	3038	;
	3039	"RTN","IBJ DB21",311, 0)
	3040	N ADM,DFN ,ENC,PRI,P RS,PRV,PRV LST,SPC,ST P,X,VAIN,V AINDT
	3041	"RTN","IBJ DB21",312, 0)
	3042	;
	3043	"RTN","IBJ DB21",313, 0)
	3044	S X=$G(^I BT(356,CLM ,0))
	3045	"RTN","IBJ DB21",314, 0)
	3046	S DFN=$P( X,U,2),ENC =$P(X,U,4) ,ADM=$P(X, U,5),PRS=$ P(X,U,8)
	3047	"RTN","IBJ DB21",315, 0)
	3048	;
	3049	"RTN","IBJ DB21",316, 0)
	3050	S (PRV,SP C)="^"
	3051	"RTN","IBJ DB21",317, 0)
	3052	I EPS=1,A DM D G QP S ; Inpat ient
	3053	"RTN","IBJ DB21",318, 0)
	3054	.S X=$G(^ DGPM(ADM,0 )),VAINDT= $P(X,U)\1 I 'VAINDT Q
	3055	"RTN","IBJ DB21",319, 0)
	3056	.D INP^VA DPT S PRV= $G(VAIN(11 )),SPC=$G( VAIN(3))
	3057	"RTN","IBJ DB21",320, 0)
	3058	.S:PRV="" PRV="^" S :SPC="" SP C="^"
	3059	"RTN","IBJ DB21",321, 0)
	3060	;
	3061	"RTN","IBJ DB21",322, 0)
	3062	I EPS=2,E NC D G QP S ; Outpa tient
	3063	"RTN","IBJ DB21",323, 0)
	3064	.D GETPRV ^SDOE(ENC, "PRVLST")
	3065	"RTN","IBJ DB21",324, 0)
	3066	.S (X,PRI )=""
	3067	"RTN","IBJ DB21",325, 0)
	3068	.F S X=$ O(PRVLST(X ),-1) Q:X= ""!PRI D
	3069	"RTN","IBJ DB21",326, 0)
	3070	..N IBX S PRV=+PRVL ST(X)
	3071	"RTN","IBJ DB21",327, 0)
	3072	..I $P(PR VLST(X),U, 4)="P" S P RI=1 ; Pri mary provi der
	3073	"RTN","IBJ DB21",328, 0)
	3074	..I PRV S PRV=PRV_U _$P($G(^VA (200,+PRV, 0)),U)
	3075	"RTN","IBJ DB21",329, 0)
	3076	..S IBX=$ $GETOE^SDO E(ENC),STP =$P(IBX,U, 3)
	3077	"RTN","IBJ DB21",330, 0)
	3078	..I STP'= "" S SPC=S TP_U_$P($G (^DIC(40.7 ,STP,0)),U )
	3079	"RTN","IBJ DB21",331, 0)
	3080	;
	3081	"RTN","IBJ DB21",332, 0)
	3082	QPS Q (PRV _U_SPC)
	3083	"RTN","IBJ DB21",333, 0)
	3084	;
	3085	"RTN","IBJ DB21",334, 0)
	3086	PHDL ; - P rint the h eader line for the E xcel sprea dsheet
	3087	"RTN","IBJ DB21",335, 0)
	3088	N X
	3089	"RTN","IBJ DB21",336, 0)
	3090	S X="Divi sion^Svc^P atient^SSN ^Insurance ^Episode D t^Dt Enter ed^Dt Lst Edit^"
	3091	"RTN","IBJ DB21",337, 0)
	3092	S X=X_"Ls t Edited B y^Next Adm ission^RNB Cat^Provi der^Specia lty^Entry Amt^Relate
	3093	d Bills^Co mments"
	3094	"RTN","IBJ DB21",338, 0)
	3095	W !,X
	3096	"RTN","IBJ DB21",339, 0)
	3097	Q
	3098	"RTN","IBJ DF4")
	3099	0^8^B41736 183
	3100	"RTN","IBJ DF4",1,0)
	3101	IBJDF4 ;AL B/RB - FIR ST PARTY F OLLOW-UP R EPORT ;15- APR-00
	3102	"RTN","IBJ DF4",2,0)
	3103	;;2.0;INT EGRATED BI LLING;12 3,204,220, 568;21-M AR-94;Buil d 2
	3104	"RTN","IBJ DF4",3,0)
	3105	;Per VA D irective 6 402, this routine sh ould not b e modified .
	3106	"RTN","IBJ DF4",4,0)
	3107	;
	3108	"RTN","IBJ DF4",5,0)
	3109	EN ; - Opt ion entry point.
	3110	"RTN","IBJ DF4",6,0)
	3111	S IBEXCEL =0
	3112	"RTN","IBJ DF4",7,0)
	3113	;
	3114	"RTN","IBJ DF4",8,0)
	3115	; - Selec t AR categ ories to p rint.
	3116	"RTN","IBJ DF4",9,0)
	3117	S IBPRT=" Choose whi ch type of receivabl es to prin t:"
	3118	"RTN","IBJ DF4",10,0)
	3119	K IBOPT
	3120	"RTN","IBJ DF4",11,0)
	3121	S IBOPT(1 )="EMERGEN CY/HUMANIT ARIAN"
	3122	"RTN","IBJ DF4",12,0)
	3123	S IBOPT(2 )="INELIGI BLE"
	3124	"RTN","IBJ DF4",13,0)
	3125	S IBOPT(3 )="C-MEANS TEST & RX COPAY"
	3126	"RTN","IBJ DF4",14,0)
	3127	S IBOPT(4 )="LONG TE RM CARE CO PAY"
	3128	"RTN","IBJ DF4",15,0)
	3129	S IBOPT(5 )="ALL OF THE ABOVE"
	3130	"RTN","IBJ DF4",16,0)
	3131	S IBSEL=$ $MLTP^IBJD (IBPRT,.IB OPT,1) I ' IBSEL G EN Q
	3132	"RTN","IBJ DF4",17,0)
	3133	;
	3134	"RTN","IBJ DF4",18,0)
	3135	STA ; - Ch oose bill status.
	3136	"RTN","IBJ DF4",19,0)
	3137	W !!,"Run report fo r (A)CTIVE ARs, (S)U SPENDED AR s, or (B)O TH: B// "
	3138	"RTN","IBJ DF4",20,0)
	3139	R X:DTIME G:'$T!(X[ "^") ENQ S :X="" X="B " S X=$E(X )
	3140	"RTN","IBJ DF4",21,0)
	3141	I "AaBbSs "'[X S IBO FF=1 D HEL P^IBJDF4H G STA
	3142	"RTN","IBJ DF4",22,0)
	3143	S IBSTA=$ S("Aa"[X:" A","Ss"[X: "S",1:"B")
	3144	"RTN","IBJ DF4",23,0)
	3145	W " ",$S (IBSTA="A" :"ACTIVE", IBSTA="S": "SUSPENDED ",1:"BOTH" )
	3146	"RTN","IBJ DF4",24,0)
	3147	;
	3148	"RTN","IBJ DF4",25,0)
	3149	SUSTYP ;If SUSPENDED is chosen , prompt f or which s uspended b ills to di splay IB*2
	3150	.0*568/DRF
	3151	"RTN","IBJ DF4",26,0)
	3152	I IBSTA=" S" D
	3153	"RTN","IBJ DF4",27,0)
	3154	. N X,XX, I,CH,LAST
	3155	"RTN","IBJ DF4",28,0)
	3156	. K IBSUS
	3157	"RTN","IBJ DF4",29,0)
	3158	. S XX=^D D(433,90,0 ),XX=$P(XX ,"^",3) F I=1:1 S CH =$P(XX,";" ,I) Q:CH=" " S IBSUS
	3159	($P(CH,":" ,1))=$P(CH ,":",2)
	3160	"RTN","IBJ DF4",30,0)
	3161	. S LAST= $O(IBSUS(" "),-1),IBS US(LAST+1) ="ALL OF T HE ABOVE"
	3162	"RTN","IBJ DF4",31,0)
	3163	. S IBPRT ="Choose w hich suspe nded types to print: "
	3164	"RTN","IBJ DF4",32,0)
	3165	. S IBSEL ST=$$MLTP0 (IBPRT,.IB SUS,1)
	3166	"RTN","IBJ DF4",33,0)
	3167	I IBSTA=" S",IBSELST ="" G ENQ
	3168	"RTN","IBJ DF4",34,0)
	3169	;
	3170	"RTN","IBJ DF4",35,0)
	3171	; - Selec t a detail ed or summ ary report .
	3172	"RTN","IBJ DF4",36,0)
	3173	D DS^IBJD G ENQ:IBR PT["^"
	3174	"RTN","IBJ DF4",37,0)
	3175	I IBRPT=" S" D G RC
	3176	"RTN","IBJ DF4",38,0)
	3177	. S IBSN= "N",IBSNA= "ALL",IBSN F="",IBSNL ="zzzzz",I BSMN="A"
	3178	"RTN","IBJ DF4",39,0)
	3179	;
	3180	"RTN","IBJ DF4",40,0)
	3181	; - Deter mine sorti ng (By nam e or Last 4 SSN)
	3182	"RTN","IBJ DF4",41,0)
	3183	S IBSN=$$ SNL^IBJD() G ENQ:IBS N="^"
	3184	"RTN","IBJ DF4",42,0)
	3185	;
	3186	"RTN","IBJ DF4",43,0)
	3187	; - Deter mine the r ange
	3188	"RTN","IBJ DF4",44,0)
	3189	S X=$$INT V^IBJD("PA TIENT "_$S (IBSN="N": "NAME",1:" LAST 4")) G ENQ:X="^ "
	3190	"RTN","IBJ DF4",45,0)
	3191	S IBSNF=$ P(X,"^",1) ,IBSNL=$P( X,"^",2),I BSNA=$P(X, "^",3)
	3192	"RTN","IBJ DF4",46,0)
	3193	;
	3194	"RTN","IBJ DF4",47,0)
	3195	AGE ; - De termine if the activ e receivab le must be within an age range .
	3196	"RTN","IBJ DF4",48,0)
	3197	W !!,"Inc lude (A)LL ",$S(IBST A="A":"act ive ",IBST A="S":"sus pended ",1 :""),"ARs
	3198	or those w ithin an A GE (R)ANGE : ALL// "
	3199	"RTN","IBJ DF4",49,0)
	3200	R X:DTIME G:'$T!(X[ "^") ENQ S :X="" X="A " S X=$E(X )
	3201	"RTN","IBJ DF4",50,0)
	3202	I "ARar"' [X S IBOFF =9 D HELP^ IBJDF4H G AGE
	3203	"RTN","IBJ DF4",51,0)
	3204	S IBSMN=$ S("Rr"[X:" R",1:"A") W " ",$S( IBSMN="R": "RANGE",1: "ALL")
	3205	"RTN","IBJ DF4",52,0)
	3206	I IBSMN=" A" G AMT
	3207	"RTN","IBJ DF4",53,0)
	3208	;
	3209	"RTN","IBJ DF4",54,0)
	3210	; - Deter mine the a ctive rece ivable age range.
	3211	"RTN","IBJ DF4",55,0)
	3212	W !,"EXAM PLE Range: 31-60 day s"
	3213	"RTN","IBJ DF4",56,0)
	3214	S DIR(0)= "NA^1:9999 9"
	3215	"RTN","IBJ DF4",57,0)
	3216	S DIR("A" )="Enter t he minimum age of th e receivab le: "
	3217	"RTN","IBJ DF4",58,0)
	3218	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=16 D HELP^IBJ DF4H"
	3219	"RTN","IBJ DF4",59,0)
	3220	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	3221	"RTN","IBJ DF4",60,0)
	3222	S IBSMN=+ Y W " ", IBSMN," DA YS" K DIRO UT,DTOUT,D UOUT,DIRUT
	3223	"RTN","IBJ DF4",61,0)
	3224	;
	3225	"RTN","IBJ DF4",62,0)
	3226	S DIR(0)= "NA^"_IBSM N_":99999"
	3227	"RTN","IBJ DF4",63,0)
	3228	S DIR("A" )="Enter t he maximum age of th e receivab le: "
	3229	"RTN","IBJ DF4",64,0)
	3230	S DIR("B" )=IBSMN,DI R("T")=DTI ME,DIR("?" )="^S IBOF F=21 D HEL P^IBJDF4H"
	3231	"RTN","IBJ DF4",65,0)
	3232	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	3233	"RTN","IBJ DF4",66,0)
	3234	S IBSMX=+ Y W " ", IBSMX," DA YS" K DIRO UT,DTOUT,D UOUT,DIRUT
	3235	"RTN","IBJ DF4",67,0)
	3236	;
	3237	"RTN","IBJ DF4",68,0)
	3238	AMT ; - Pr int receiv ables with a minimum balance.
	3239	"RTN","IBJ DF4",69,0)
	3240	S DIR(0)= "Y",DIR("B ")="NO" W !
	3241	"RTN","IBJ DF4",70,0)
	3242	S DIR("A" )="Print r eceivables with a mi nimum bala nce"
	3243	"RTN","IBJ DF4",71,0)
	3244	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=26 D HELP^IBJ DF4H"
	3245	"RTN","IBJ DF4",72,0)
	3246	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	3247	"RTN","IBJ DF4",73,0)
	3248	S IBSAM=+ Y K DIROUT ,DTOUT,DUO UT,DIRUT G :'IBSAM EX CEL
	3249	"RTN","IBJ DF4",74,0)
	3250	;
	3251	"RTN","IBJ DF4",75,0)
	3252	AMT1 ; - D etermine t he minimum balance a mount.
	3253	"RTN","IBJ DF4",76,0)
	3254	S DIR(0)= "NA^1:9999 999"
	3255	"RTN","IBJ DF4",77,0)
	3256	S DIR("A" )="Enter t he minimum balance a mount of t he receiva ble: "
	3257	"RTN","IBJ DF4",78,0)
	3258	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=33 D HELP^IBJ DF4H"
	3259	"RTN","IBJ DF4",79,0)
	3260	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	3261	"RTN","IBJ DF4",80,0)
	3262	S IBSAM=+ Y K DIROUT ,DTOUT,DUO UT,DIRUT
	3263	"RTN","IBJ DF4",81,0)
	3264	;
	3265	"RTN","IBJ DF4",82,0)
	3266	EXCEL ; - Determine whether to gather da ta for Exc el report.
	3267	"RTN","IBJ DF4",83,0)
	3268	S IBEXCEL =$$EXCEL^I BJD() G EN Q:IBEXCEL= "^"
	3269	"RTN","IBJ DF4",84,0)
	3270	I IBEXCEL S IBSH=1, IBSH1="M" G RC
	3271	"RTN","IBJ DF4",85,0)
	3272	;
	3273	"RTN","IBJ DF4",86,0)
	3274	BCH ; - De termine wh ether to i nclude the bill comm ent histor y.
	3275	"RTN","IBJ DF4",87,0)
	3276	S DIR(0)= "Y",DIR("B ")="NO" W !
	3277	"RTN","IBJ DF4",88,0)
	3278	S DIR("A" )="Include the bill comment hi story with each rece ivable"
	3279	"RTN","IBJ DF4",89,0)
	3280	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=38 D HELP^IBJ DF4H"
	3281	"RTN","IBJ DF4",90,0)
	3282	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	3283	"RTN","IBJ DF4",91,0)
	3284	S IBSH=+Y K DIROUT, DTOUT,DUOU T,DIRUT G: 'IBSH RC
	3285	"RTN","IBJ DF4",92,0)
	3286	;
	3287	"RTN","IBJ DF4",93,0)
	3288	S DIR(0)= "SA^A:ALL; M:MOST REC ENT"
	3289	"RTN","IBJ DF4",94,0)
	3290	S DIR("A" )="Print ( A)LL comme nts or the (M)OST RE CENT comme nt: "
	3291	"RTN","IBJ DF4",95,0)
	3292	S DIR("B" )="ALL",DI R("T")=DTI ME,DIR("?" )="^S IBOF F=47 D HEL P^IBJDF4H"
	3293	"RTN","IBJ DF4",96,0)
	3294	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	3295	"RTN","IBJ DF4",97,0)
	3296	S IBSH1=Y K DIROUT, DTOUT,DUOU T,DIRUT G: IBSH1="A" RC
	3297	"RTN","IBJ DF4",98,0)
	3298	;
	3299	"RTN","IBJ DF4",99,0)
	3300	S DIR(0)= "NAO^1:999 "
	3301	"RTN","IBJ DF4",100,0 )
	3302	S DIR("A" )="Minimum age of mo st recent bill comme nt (option al): "
	3303	"RTN","IBJ DF4",101,0 )
	3304	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=54 D HELP^IBJ DF4H"
	3305	"RTN","IBJ DF4",102,0 )
	3306	D ^DIR K DIR G:$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	3307	"RTN","IBJ DF4",103,0 )
	3308	S IBSH2=+ Y W:IBSH2 " days" K DIROUT,DTO UT,DUOUT
	3309	"RTN","IBJ DF4",104,0 )
	3310	;
	3311	"RTN","IBJ DF4",105,0 )
	3312	RC ; - Inc lude recei vables ref erred to R egional Co unsel?
	3313	"RTN","IBJ DF4",106,0 )
	3314	S DIR(0)= "Y",DIR("B ")="NO",DI R("T")=DTI ME W !
	3315	"RTN","IBJ DF4",107,0 )
	3316	S DIR("A" )="Include ARs refer red to Reg ional Coun sel"
	3317	"RTN","IBJ DF4",108,0 )
	3318	S DIR("?" )="^S IBOF F=61 D HEL P^IBJDF4H"
	3319	"RTN","IBJ DF4",109,0 )
	3320	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	3321	"RTN","IBJ DF4",110,0 )
	3322	S IBSRC=+ Y K DIROUT ,DTOUT,DUO UT,DIRUT
	3323	"RTN","IBJ DF4",111,0 )
	3324	;
	3325	"RTN","IBJ DF4",112,0 )
	3326	DEV ; - Se lect a dev ice.
	3327	"RTN","IBJ DF4",113,0 )
	3328	I '$G(IBE XCEL) D
	3329	"RTN","IBJ DF4",114,0 )
	3330	. W !!,"N ote: This report wil l search t hrough all "
	3331	"RTN","IBJ DF4",115,0 )
	3332	. W $S(IB STA="A":"a ctive",IBS TA="S":"su spended",1 :"active & suspended ")," recei
	3333	vables."
	3334	"RTN","IBJ DF4",116,0 )
	3335	. W !?6," It is reco mmended th at you que ue it to r un after n ormal busi ness hours
	3336	."
	3337	"RTN","IBJ DF4",117,0 )
	3338	;
	3339	"RTN","IBJ DF4",118,0 )
	3340	I $G(IBEX CEL) D EXM SG^IBJD
	3341	"RTN","IBJ DF4",119,0 )
	3342	;
	3343	"RTN","IBJ DF4",120,0 )
	3344	W ! S %ZI S="QM" D ^ %ZIS G:POP ENQ
	3345	"RTN","IBJ DF4",121,0 )
	3346	I $D(IO(" Q")) D G ENQ
	3347	"RTN","IBJ DF4",122,0 )
	3348	.S ZTRTN= "DQ^IBJDF4 ",ZTDESC=" IB - FIRST PARTY FOL LOW-UP REP ORT"
	3349	"RTN","IBJ DF4",123,0 )
	3350	.S ZTSAVE ("IB*")="" D ^%ZTLOA D
	3351	"RTN","IBJ DF4",124,0 )
	3352	.I $G(ZTS K) W !!,"T his job ha s been que ued. The t ask no. is ",ZTSK,". "
	3353	"RTN","IBJ DF4",125,0 )
	3354	.E W !!, "Unable to queue thi s job."
	3355	"RTN","IBJ DF4",126,0 )
	3356	.K ZTSK,I O("Q") D H OME^%ZIS
	3357	"RTN","IBJ DF4",127,0 )
	3358	;
	3359	"RTN","IBJ DF4",128,0 )
	3360	U IO
	3361	"RTN","IBJ DF4",129,0 )
	3362	;
	3363	"RTN","IBJ DF4",130,0 )
	3364	; If call ed by the Extraction Module, c hange extr act status for the 5
	3365	"RTN","IBJ DF4",131,0 )
	3366	; reports : Emergenc y/Humanita rian, Inel igible rec eivables, C-Means Te st,
	3367	"RTN","IBJ DF4",132,0 )
	3368	; RX Copay /SC VET an d RX Copay /NSC VET
	3369	"RTN","IBJ DF4",133,0 )
	3370	DQ I $G(IB XTRACT) F I=12:1:16 D E^IBJDE( I,1)
	3371	"RTN","IBJ DF4",134,0 )
	3372	;
	3373	"RTN","IBJ DF4",135,0 )
	3374	D ST^IBJD F41 ; Co mpile and print the report.
	3375	"RTN","IBJ DF4",136,0 )
	3376	;
	3377	"RTN","IBJ DF4",137,0 )
	3378	ENQ K IBSE L,IBSN,IBS NF,IBSNL,I BOFF,IBSNA ,IBSH,IBSH 1,IBSH2,IB SAM,IBSRC, IBTEXT
	3379	"RTN","IBJ DF4",138,0 )
	3380	K IBI,IBO PT,IBPRT,I BSTA,IBEXC EL,IBRPT,I BSMN,IBSMX ,POP,DIROU T,DTOUT,DU OUT
	3381	"RTN","IBJ DF4",139,0 )
	3382	K DIRUT,% ZIS,ZTDESC ,ZTRTN,ZTS AVE,I,X,Y
	3383	"RTN","IBJ DF4",140,0 )
	3384	Q
	3385	"RTN","IBJ DF4",141,0 )
	3386	;
	3387	"RTN","IBJ DF4",142,0 )
	3388	MLTP0(PRPT ,OPT,ALL) ; Function for multi ple value selection
	3389	"RTN","IBJ DF4",143,0 )
	3390	; Input: PRPT - Str ing to be prompted t o the user , before l isting opt ions
	3391	"RTN","IBJ DF4",144,0 )
	3392	; OPT - Arr ay contain ing the po ssible ent ries (inde xed by cod e)
	3393	"RTN","IBJ DF4",145,0 )
	3394	; Obs : Code mus t be seque ntial star ting with 0
	3395	"RTN","IBJ DF4",146,0 )
	3396	; ALL - Fla g indicati ng if the last optio n is ALL O F THE ABOV E
	3397	"RTN","IBJ DF4",147,0 )
	3398	;
	3399	"RTN","IBJ DF4",148,0 )
	3400	; Output: MLTP - Us er selecti on, i.e. " 1,2,3," or "1," or N ULL (nothi ng
	3401	"RTN","IBJ DF4",149,0 )
	3402	; w as selecte d)
	3403	"RTN","IBJ DF4",150,0 )
	3404	;
	3405	"RTN","IBJ DF4",151,0 )
	3406	N A,DIR,D IRUT,DTOUT ,DUOUT,DIR OUT,I,IX,L ST,MLTP
	3407	"RTN","IBJ DF4",152,0 )
	3408	;
	3409	"RTN","IBJ DF4",153,0 )
	3410	PRPT S MLT P="",ALL=+ $G(ALL)
	3411	"RTN","IBJ DF4",154,0 )
	3412	S LST=$O( OPT(""),-1 )
	3413	"RTN","IBJ DF4",155,0 )
	3414	S DIR(0)= "LO^0:"_LS T_"^K:+$P( X,""-"",2) >"_LST_" X "
	3415	"RTN","IBJ DF4",156,0 )
	3416	S DIR("A" ,1)=$G(PRP T),DIR("A" ,2)=""
	3417	"RTN","IBJ DF4",157,0 )
	3418	S A="",IX =3
	3419	"RTN","IBJ DF4",158,0 )
	3420	F S A=$O (OPT(A)) Q:A="" D
	3421	"RTN","IBJ DF4",159,0 )
	3422	. S DIR(" A",IX)=" "_A_" - " _$G(OPT(A) ),IX=IX+1
	3423	"RTN","IBJ DF4",160,0 )
	3424	S DIR("A" ,IX)="",DI R("A")="Se lect",DIR( "B")=LST,D IR("T")=DT IME W !
	3425	"RTN","IBJ DF4",161,0 )
	3426	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) G Q T
	3427	"RTN","IBJ DF4",162,0 )
	3428	S MLTP=Y K DIROUT,D TOUT,DUOUT ,DIRUT
	3429	"RTN","IBJ DF4",163,0 )
	3430	;
	3431	"RTN","IBJ DF4",164,0 )
	3432	I ALL,MLT P[LST S ML TP=LST_","
	3433	"RTN","IBJ DF4",165,0 )
	3434	;
	3435	"RTN","IBJ DF4",166,0 )
	3436	S DIR(0)= "Y",DIR("A ",1)="You have selec ted",DIR(" A",2)=""
	3437	"RTN","IBJ DF4",167,0 )
	3438	S A="",IX =3
	3439	"RTN","IBJ DF4",168,0 )
	3440	F I=1:1:( $L(MLTP,", ")-1) D
	3441	"RTN","IBJ DF4",169,0 )
	3442	. S DIR(" A",IX)=" "_$P(MLT P,",",I)_" - "_$G(OP T($P(MLTP, ",",I)))
	3443	"RTN","IBJ DF4",170,0 )
	3444	. S IX=IX +1
	3445	"RTN","IBJ DF4",171,0 )
	3446	S DIR("A" ,IX)=""
	3447	"RTN","IBJ DF4",172,0 )
	3448	S DIR("A" )="Are you sure",DIR ("B")="NO" ,DIR("T")= DTIME W !
	3449	"RTN","IBJ DF4",173,0 )
	3450	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) S M LTP=0 G QT
	3451	"RTN","IBJ DF4",174,0 )
	3452	K DIROUT, DTOUT,DUOU T,DIRUT I 'Y K DIR G PRPT
	3453	"RTN","IBJ DF4",175,0 )
	3454	;
	3455	"RTN","IBJ DF4",176,0 )
	3456	I ALL,MLT P[LST D
	3457	"RTN","IBJ DF4",177,0 )
	3458	. S MLTP= "" F I=(LS T-1):-1:1 S MLTP=I_" ,"_MLTP
	3459	"RTN","IBJ DF4",178,0 )
	3460	;
	3461	"RTN","IBJ DF4",179,0 )
	3462	QT Q MLTP
	3463	"RTN","IBJ DF41")
	3464	0^9^B94990 594
	3465	"RTN","IBJ DF41",1,0)
	3466	IBJDF41 ;A LB/RB - FI RST PARTY FOLLOW-UP REPORT (CO MPILE) ;15 -APR-00
	3467	"RTN","IBJ DF41",2,0)
	3468	;;2.0;INT EGRATED BI LLING;12 3,159,204, 356,451,47 3,568;21 -MAR-94;Bu ild 2
	3469	"RTN","IBJ DF41",3,0)
	3470	;;Per VA Directive 6402, this routine s hould not be modifie d.
	3471	"RTN","IBJ DF41",4,0)
	3472	;
	3473	"RTN","IBJ DF41",5,0)
	3474	ST ; - Tas ked entry point.
	3475	"RTN","IBJ DF41",6,0)
	3476	K IB,IBCA T,^TMP("IB JDF4",$J)
	3477	"RTN","IBJ DF41",7,0)
	3478	S IBQ=0
	3479	"RTN","IBJ DF41",8,0)
	3480	;
	3481	"RTN","IBJ DF41",9,0)
	3482	; - Set s elected ca tegories f or report.
	3483	"RTN","IBJ DF41",10,0 )
	3484	I IBSEL[1 S IBCAT(2 )=1
	3485	"RTN","IBJ DF41",11,0 )
	3486	I IBSEL[2 S IBCAT(1 )=2
	3487	"RTN","IBJ DF41",12,0 )
	3488	I IBSEL[3 S IBCAT(1 8)=3 F X=2 2,23 S IBC AT(X)=4
	3489	"RTN","IBJ DF41",13,0 )
	3490	I IBSEL[4 F X=33:1: 39 S IBCAT (X)=5
	3491	"RTN","IBJ DF41",14,0 )
	3492	;
	3493	"RTN","IBJ DF41",15,0 )
	3494	; - Print the heade r line for the Excel spreadshe et
	3495	"RTN","IBJ DF41",16,0 )
	3496	I $G(IBEX CEL) D PHD L
	3497	"RTN","IBJ DF41",17,0 )
	3498	;
	3499	"RTN","IBJ DF41",18,0 )
	3500	; - Find data requi red for re port.
	3501	"RTN","IBJ DF41",19,0 )
	3502	F IB=16,1 9,40 D G: IBQ ENQ
	3503	"RTN","IBJ DF41",20,0 )
	3504	. I IBSTA ="A",IB'=1 6 Q ; Active A R's only.
	3505	"RTN","IBJ DF41",21,0 )
	3506	. I IBSTA ="S",IB=16 Q ; Suspende d AR's onl y.
	3507	"RTN","IBJ DF41",22,0 )
	3508	. I IB'=4 0 D
	3509	"RTN","IBJ DF41",23,0 )
	3510	. . S IBC AT=""
	3511	"RTN","IBJ DF41",24,0 )
	3512	. . F S IBCAT=$O(I BCAT(IBCAT )) Q:IBCAT ="" D
	3513	"RTN","IBJ DF41",25,0 )
	3514	. . . D I NIT^IBJDF4 3
	3515	"RTN","IBJ DF41",26,0 )
	3516	. S IBA=0
	3517	"RTN","IBJ DF41",27,0 )
	3518	. F S IB A=$O(^PRCA (430,"AC", IB,IBA)) Q :'IBA D Q:IBQ
	3519	"RTN","IBJ DF41",28,0 )
	3520	. . D PRO C
	3521	"RTN","IBJ DF41",29,0 )
	3522	;
	3523	"RTN","IBJ DF41",30,0 )
	3524	I 'IBQ,'$ G(IBEXCEL) D EN^IBJD F42 ; Prin t the repo rt.
	3525	"RTN","IBJ DF41",31,0 )
	3526	;
	3527	"RTN","IBJ DF41",32,0 )
	3528	ENQ K ^TMP ("IBJDF4", $J)
	3529	"RTN","IBJ DF41",33,0 )
	3530	I $D(ZTQU EUED) S ZT REQ="@" G ENQ1
	3531	"RTN","IBJ DF41",34,0 )
	3532	;
	3533	"RTN","IBJ DF41",35,0 )
	3534	D ^%ZISC
	3535	"RTN","IBJ DF41",36,0 )
	3536	ENQ1 K IB, IB0,IBA,IB A1,IBADM,I BAGE,IBAR, IBAR1,IBBA ,IBBN,IBBU ,IBC,IBCAT ,IBCAT1
	3537	"RTN","IBJ DF41",37,0 )
	3538	K IBELIG, IBEXCEL,IB FLG,IBAI,I BAIQ,IBIDX ,IBIO,IBIN T,IBN,IBPA ,IBPD,IBPA T
	3539	"RTN","IBJ DF41",38,0 )
	3540	K IBPT,IB Q,IBRFD,IB RFT,IBSRC, IBRP,IBVA, COM,COM1,D AT,DFN,X,X 1,X2,Y,Z
	3541	"RTN","IBJ DF41",39,0 )
	3542	Q
	3543	"RTN","IBJ DF41",40,0 )
	3544	;
	3545	"RTN","IBJ DF41",41,0 )
	3546	PROC ; - P rocess dat a for repo rt(s).
	3547	"RTN","IBJ DF41",42,0 )
	3548	I IBA#100 =0 D Q:IB Q
	3549	"RTN","IBJ DF41",43,0 )
	3550	. S IBQ=$ $STOP^IBOU TL("First Party Foll ow-Up Repo rt")
	3551	"RTN","IBJ DF41",44,0 )
	3552	S IBAR=$G (^PRCA(430 ,IBA,0)) I 'IBAR Q
	3553	"RTN","IBJ DF41",45,0 )
	3554	S IBCAT=+ $P(IBAR,U, 2) I '$D(I BCAT(IBCAT )) Q ; Get valid AR category.
	3555	"RTN","IBJ DF41",46,0 )
	3556	I '$$CLMA CT^IBJD(IB A,IBCAT) Q ; Inv alid IB cl aim/action
	3557	.
	3558	"RTN","IBJ DF41",47,0 )
	3559	I IBSTA=" S" S IBSUS TYP=$$SUST (IBA) I IB SELST'[(IB SUSTYP_"," ) Q ;Filt er by susp
	3560	ended type IB2568/ DRF
	3561	"RTN","IBJ DF41",48,0 )
	3562	S IBPT=$$ PAT(IBA) I IBPT="" Q ; Get patient i nfo.
	3563	"RTN","IBJ DF41",49,0 )
	3564	S DFN=$P( IBPT,U,2)
	3565	"RTN","IBJ DF41",50,0 )
	3566	S IBAGE=$ $FMDIFF^XL FDT(DT,+$P (IBAR,U,10 ))
	3567	"RTN","IBJ DF41",51,0 )
	3568	I IBSMN,I BAGE<IBSMN !(IBAGE>IB SMX) Q ; AR outside ag e range.
	3569	"RTN","IBJ DF41",52,0 )
	3570	S IBVA=$$ VA^IBJD1(D FN),IBBN=$ P(IBAR,U), IBPD=$P($$ PYMT^IBJD1 (IBA),U)
	3571	"RTN","IBJ DF41",53,0 )
	3572	S IBPAT=$ P(IBPT,U)_ "@@"_DFN
	3573	"RTN","IBJ DF41",54,0 )
	3574	;
	3575	"RTN","IBJ DF41",55,0 )
	3576	; - Check the AR ba lance amou nts, if ne cessary.
	3577	"RTN","IBJ DF41",56,0 )
	3578	S (IBADM, IBBA,IBINT ,IBPA)=0,I BN=$G(^PRC A(430,IBA, 7))
	3579	"RTN","IBJ DF41",57,0 )
	3580	F X=1:1:5 D
	3581	"RTN","IBJ DF41",58,0 )
	3582	. S IBBA= IBBA+$P(IB N,U,X)
	3583	"RTN","IBJ DF41",59,0 )
	3584	. S:X=1 I BPA=+IBN S :X=2 IBINT =$P(IBN,U, 2) S:X=3 I BADM=$P(IB N,U,3)
	3585	"RTN","IBJ DF41",60,0 )
	3586	;
	3587	"RTN","IBJ DF41",61,0 )
	3588	I '$G(IBE XCEL) D EN ^IBJDF43 I IBRPT="S" Q ; Ge t summary stats.
	3589	"RTN","IBJ DF41",62,0 )
	3590	;
	3591	"RTN","IBJ DF41",63,0 )
	3592	I IBSAM,I BBA<IBSAM Q
	3593	"RTN","IBJ DF41",64,0 )
	3594	;
	3595	"RTN","IBJ DF41",65,0 )
	3596	; - Check if AR was referred to R-Regio nal Counse l, D-DMC, or T-TOP
	3597	"RTN","IBJ DF41",66,0 )
	3598	; and e xclude, if necessary .
	3599	"RTN","IBJ DF41",67,0 )
	3600	S IB0=$S( IB=40:19,1 :IB),IBIDX =0,IBRFT=" "
	3601	"RTN","IBJ DF41",68,0 )
	3602	S IBAIQ=0 ,IBAI=$G(^ TMP("IBJDF 4",$J,IBPA T,0,"A"))
	3603	"RTN","IBJ DF41",69,0 )
	3604	S IBRFD=$ P($G(^PRCA (430,IBA,6 )),U,4)
	3605	"RTN","IBJ DF41",70,0 )
	3606	I IBRPT=" D",IBRFD D I IBAIQ Q ; Referred to RC
	3607	"RTN","IBJ DF41",71,0 )
	3608	. S IBRFT ="R" I IBA I'["R" S I BAI=IBAI_" R"
	3609	"RTN","IBJ DF41",72,0 )
	3610	. I 'IBSR C S IBAIQ= 1 Q
	3611	"RTN","IBJ DF41",73,0 )
	3612	. D SREF( "R",IBRFD, IB0,,.IBID X)
	3613	"RTN","IBJ DF41",74,0 )
	3614	S IBRFD=+ $G(^PRCA(4 30,IBA,12) )
	3615	"RTN","IBJ DF41",75,0 )
	3616	I IBRPT=" D",IBRFD D ; Referred to DMC
	3617	"RTN","IBJ DF41",76,0 )
	3618	. S IBRFT =IBRFT_"D" I IBAI'[" D" S IBAI= IBAI_"D"
	3619	"RTN","IBJ DF41",77,0 )
	3620	. D SREF( "D",IBRFD, IB0,,.IBID X)
	3621	"RTN","IBJ DF41",78,0 )
	3622	S IBRFD=+ $G(^PRCA(4 30,IBA,14) )
	3623	"RTN","IBJ DF41",79,0 )
	3624	I IBRPT=" D",IBRFD D ; Referred to TOP
	3625	"RTN","IBJ DF41",80,0 )
	3626	. S IBRFT =IBRFT_"T" I IBAI'[" T" S IBAI= IBAI_"T"
	3627	"RTN","IBJ DF41",81,0 )
	3628	. D SREF( "T",IBRFD, IB0,,.IBID X)
	3629	"RTN","IBJ DF41",82,0 )
	3630	;
	3631	"RTN","IBJ DF41",83,0 )
	3632	; - Check if AR is on P-Repay ment plan or F-Defau lted repay ment plan.
	3633	"RTN","IBJ DF41",84,0 )
	3634	; and e xclude if repayment plan is ac tive.
	3635	"RTN","IBJ DF41",85,0 )
	3636	S IBRP=$$ RP(IBA)
	3637	"RTN","IBJ DF41",86,0 )
	3638	I IBRP D
	3639	"RTN","IBJ DF41",87,0 )
	3640	. I IBRP= 2 S IBRFT= IBRFT_"F" I IBAI'[" F" S IBAI= IBAI_"F"
	3641	"RTN","IBJ DF41",88,0 )
	3642	. I IBRP= 1 S IBRFT= IBRFT_"P" I IBAI'["P "&(IBAI'[" F") S IBAI =IBAI_"P"
	3643	"RTN","IBJ DF41",89,0 )
	3644	. D SREF( "P",$P(IBR P,"^",2),I B0,$S(+IBR P=2:1,1:0) ,.IBIDX)
	3645	"RTN","IBJ DF41",90,0 )
	3646	;
	3647	"RTN","IBJ DF41",91,0 )
	3648	I IBIDX S IBFLG=1
	3649	"RTN","IBJ DF41",92,0 )
	3650	;
	3651	"RTN","IBJ DF41",93,0 )
	3652	; - Check if VA Emp loyee
	3653	"RTN","IBJ DF41",94,0 )
	3654	I $P(IBVA ,"^")["*", IBAI'["V" S IBAI=IBA I_"V"
	3655	"RTN","IBJ DF41",95,0 )
	3656	;
	3657	"RTN","IBJ DF41",96,0 )
	3658	I IBAI'=" " S ^TMP(" IBJDF4",$J ,IBPAT,0," A")=IBAI
	3659	"RTN","IBJ DF41",97,0 )
	3660	;
	3661	"RTN","IBJ DF41",98,0 )
	3662	; IB2.0 451 - Chec k for EEOB on associ ated 3rd p arty bills and attac h EOB indi
	3663	cator '%' if applica ble
	3664	"RTN","IBJ DF41",99,0 )
	3665	S IBBN=$$ IBEEOBCK(I BBN,DFN)_I BBN ; Pas s AR BILL# , Pat ID
	3666	"RTN","IBJ DF41",100, 0)
	3667	;
	3668	"RTN","IBJ DF41",101, 0)
	3669	; - Set u p indexes for detail report.
	3670	"RTN","IBJ DF41",102, 0)
	3671	I $G(IBEX CEL) D Q
	3672	"RTN","IBJ DF41",103, 0)
	3673	. S IBEXC EL1=$P($G( ^PRCA(430. 2,IBCAT,0) ),U,2)_U_$ P(IBPT,U,3 )_U_$P(IBV A,U)_U_$P(
	3674	IBPT,U,4)_ U_$$DT^IBJ D($P(IBPT, U,6),1)_U_ $$ELIG^IBJ DF42(+$P(I BPT,U,5))_ U
	3675	"RTN","IBJ DF41",104, 0)
	3676	. S IBEXC EL1=IBEXCE L1_$$GET1^ DIQ(2,DFN, .381)_U_$$ MTRX(DFN)_ U_IBBN_U_$ S(IB=16:"A
	3677	",1:"S")_U _IBRFT_U_$ $DT^IBJD($ P(IBAR,U,1 0),1)_U_$$ DT^IBJD(IB PD,1)_U_IB BA_U_IBPA_
	3678	U_IBINT_U_ IBADM_U
	3679	"RTN","IBJ DF41",105, 0)
	3680	. I IBSH D COM
	3681	"RTN","IBJ DF41",106, 0)
	3682	. S IBD=0 I DAT!IBP D S IBD=$$ FMDIFF^XLF DT(DT,$S(' DAT:IBPD,1 :$G(DAT)))
	3683	"RTN","IBJ DF41",107, 0)
	3684	. S IBEXC EL1=IBEXCE L1_U_IBD
	3685	"RTN","IBJ DF41",108, 0)
	3686	. I IBSTA ="S" S IBE XCEL1=IBEX CEL1_U_IBS USTYP
	3687	"RTN","IBJ DF41",109, 0)
	3688	. W !,IBE XCEL1 K IB D,IBEXCEL1
	3689	"RTN","IBJ DF41",110, 0)
	3690	;
	3691	"RTN","IBJ DF41",111, 0)
	3692	I '($D(^T MP("IBJDF4 ",$J,IBPAT ))#10) D
	3693	"RTN","IBJ DF41",112, 0)
	3694	. S ^TMP( "IBJDF4",$ J,IBPAT)=$ P(IBPT,U,3 ,5)_U_$$MT RX(DFN)_U_ $P(IBPT,U, 6)_"^"_$P(
	3695	IBVA,"^",2 )_"^"_$$AC CBAL($P(IB PT,U,7))
	3696	"RTN","IBJ DF41",113, 0)
	3697	S ^TMP("I BJDF4",$J, IBPAT,IB0, IBCAT,IBBN )=IBPD_U_I BBA_U_IBPA _U_IBINT_U _IBADM_U_I
	3698	BIDX
	3699	"RTN","IBJ DF41",114, 0)
	3700	;
	3701	"RTN","IBJ DF41",115, 0)
	3702	I IBSH D COM
	3703	"RTN","IBJ DF41",116, 0)
	3704	Q
	3705	"RTN","IBJ DF41",117, 0)
	3706	;
	3707	"RTN","IBJ DF41",118, 0)
	3708	ACCBAL(DFN ) ; Calcul ates the A ccount Bal ance for t he Bill
	3709	"RTN","IBJ DF41",119, 0)
	3710	; Input: DFN - Pati ent/Debtor internal number
	3711	"RTN","IBJ DF41",120, 0)
	3712	; Output: BAL - Pat ient/Debto r Account Balance
	3713	"RTN","IBJ DF41",121, 0)
	3714	;
	3715	"RTN","IBJ DF41",122, 0)
	3716	N B0,B7,B AL,BILL,I
	3717	"RTN","IBJ DF41",123, 0)
	3718	S (BAL,BI LL)=0
	3719	"RTN","IBJ DF41",124, 0)
	3720	F S BILL =$O(^PRCA( 430,"C",DF N,BILL)) Q :BILL="" D
	3721	"RTN","IBJ DF41",125, 0)
	3722	. S B0=$G (^PRCA(430 ,BILL,0)) I $P(B0,"^ ",8)'=16 Q
	3723	"RTN","IBJ DF41",126, 0)
	3724	. S B7=$G (^PRCA(430 ,BILL,7))
	3725	"RTN","IBJ DF41",127, 0)
	3726	. F I=1:1 :5 S BAL=B AL+$P(B7," ^",I)
	3727	"RTN","IBJ DF41",128, 0)
	3728	Q BAL
	3729	"RTN","IBJ DF41",129, 0)
	3730	;
	3731	"RTN","IBJ DF41",130, 0)
	3732	PHDL ; - P rint the h eader line for the E xcel sprea dsheet
	3733	"RTN","IBJ DF41",131, 0)
	3734	N X
	3735	"RTN","IBJ DF41",132, 0)
	3736	S X="Cat^ Patient^VA Empl.?^SS N^Dt Death ^Prim.Elig .^Med.Elig .?^"
	3737	"RTN","IBJ DF41",133, 0)
	3738	S X=X_"Me ans Tst St s^Means Ts t Dt^RX Co pay Exemp. Sts^RX Cop ay Exemp.D t^"
	3739	"RTN","IBJ DF41",134, 0)
	3740	S X=X_"Bi ll #^Act/S usp^Refer. to^Dt Bil l prep.^La st Pymt Dt ^"
	3741	"RTN","IBJ DF41",135, 0)
	3742	S X=X_"Cu rr.Bal.^Pr inc.Bal.^I nt.^Admin. ^Last Comm .Dt^Days L st Comm.^"
	3743	"RTN","IBJ DF41",136, 0)
	3744	I IBSTA=" S" S X=X_" Susp.Rsn" ; IB2.05 68/DRF Add suspended reson to Excel outp
	3745	ut
	3746	"RTN","IBJ DF41",137, 0)
	3747	W !,X
	3748	"RTN","IBJ DF41",138, 0)
	3749	Q
	3750	"RTN","IBJ DF41",139, 0)
	3751	;
	3752	"RTN","IBJ DF41",140, 0)
	3753	PAT(X) ; - Find the AR patient and decid e to inclu de the AR.
	3754	"RTN","IBJ DF41",141, 0)
	3755	; Inpu t: X=AR po inter to f ile #430 a nd pre-set variables IBS*
	3756	"RTN","IBJ DF41",142, 0)
	3757	; Outpu t: Y=Sort key (name or last 4) ^ Patient pointer t o file #2
	3758	"RTN","IBJ DF41",143, 0)
	3759	; ^ Nam e ^ SSN ^ Eligibilit ies ^ Date of death (if any)
	3760	"RTN","IBJ DF41",144, 0)
	3761	; ^ Deb tor pointe r to file #340
	3762	"RTN","IBJ DF41",145, 0)
	3763	N PAT,KEY ,DBTR,DFN, DEATH,NAME ,SSN,VAEL, VADM,X1,X2
	3764	"RTN","IBJ DF41",146, 0)
	3765	S PAT="" G:'$G(X) P ATQ
	3766	"RTN","IBJ DF41",147, 0)
	3767	S DBTR=+$ P($G(^PRCA (430,X,0)) ,U,9)
	3768	"RTN","IBJ DF41",148, 0)
	3769	S X1=$P($ G(^RCD(340 ,DBTR,0)), U) G:X1'[" DPT" PATQ
	3770	"RTN","IBJ DF41",149, 0)
	3771	S DFN=+X1 G:'DFN PA TQ D DEM^V ADPT
	3772	"RTN","IBJ DF41",150, 0)
	3773	S NAME=VA DM(1),SSN= $P(VADM(2) ,"^"),DEAT H=VADM(6)\ 1
	3774	"RTN","IBJ DF41",151, 0)
	3775	S KEY=$S( IBSN="N":N AME,1:$E(S SN,6,9))
	3776	"RTN","IBJ DF41",152, 0)
	3777	I KEY=""! (IBSNF'="@ "&('DFN)) G PATQ
	3778	"RTN","IBJ DF41",153, 0)
	3779	I $D(IBSN A) G:IBSNA ="ALL"&('D FN) PATQ G :IBSNA="NU LL"&(DFN) PATQ
	3780	"RTN","IBJ DF41",154, 0)
	3781	I $G(IBSN A)="ALL" G PATC
	3782	"RTN","IBJ DF41",155, 0)
	3783	I IBSNF=" @",IBSNL=" zzzzz" G P ATC
	3784	"RTN","IBJ DF41",156, 0)
	3785	I IBSNF'= KEY,IBSNF] KEY G PATQ
	3786	"RTN","IBJ DF41",157, 0)
	3787	I IBSNL'= KEY,KEY]IB SNL G PATQ
	3788	"RTN","IBJ DF41",158, 0)
	3789	;
	3790	"RTN","IBJ DF41",159, 0)
	3791	PATC ; - S et patient eligibili ties.
	3792	"RTN","IBJ DF41",160, 0)
	3793	D ELIG^VA DPT S X2=+ $G(VAEL(1) )_";"
	3794	"RTN","IBJ DF41",161, 0)
	3795	I +X2 S X 1=0 F S X 1=$O(VAEL( 1,X1)) Q:' X1 S X2=X 2_X1_";"
	3796	"RTN","IBJ DF41",162, 0)
	3797	;
	3798	"RTN","IBJ DF41",163, 0)
	3799	S PAT=KEY _U_DFN_U_$ E(NAME,1,2 6)_U_SSN_U _X2_U_DEAT H
	3800	"RTN","IBJ DF41",164, 0)
	3801	S PAT=PAT _U_DBTR
	3802	"RTN","IBJ DF41",165, 0)
	3803	PATQ Q PAT
	3804	"RTN","IBJ DF41",166, 0)
	3805	;
	3806	"RTN","IBJ DF41",167, 0)
	3807	RP(X) ; - Check if c laim/recei vable is u nder a rep ayment pla n.
	3808	"RTN","IBJ DF41",168, 0)
	3809	; Inpu t: X=Bill pointer to file #399 /#430
	3810	"RTN","IBJ DF41",169, 0)
	3811	; Outpu t: 0-Not o n repay pl an, 1-On r epay plan, 2-On defa ulted plan
	3812	"RTN","IBJ DF41",170, 0)
	3813	N Z
	3814	"RTN","IBJ DF41",171, 0)
	3815	S Z=$$REP DATA^RCBEC HGA(X,1) I Z="" Q 0
	3816	"RTN","IBJ DF41",172, 0)
	3817	I '$P(Z," ^",7) Q (" 1^"_$P(Z," ^"))
	3818	"RTN","IBJ DF41",173, 0)
	3819	Q ("2^"_$ P(Z,"^"))
	3820	"RTN","IBJ DF41",174, 0)
	3821	;
	3822	"RTN","IBJ DF41",175, 0)
	3823	MTRX(X) ; - Return p atient's m eans test and/or RX copay stat us and mos t recent
	3824	"RTN","IBJ DF41",176, 0)
	3825	; test dates for both.
	3826	"RTN","IBJ DF41",177, 0)
	3827	; Inpu t: X=Patie nt pointer to file # 2 and opt. variable IBEXCEL
	3828	"RTN","IBJ DF41",178, 0)
	3829	; Outpu t: Y=Means test stat us ^ Date ^ RX copay status ^ Date
	3830	"RTN","IBJ DF41",179, 0)
	3831	N MTST,RX ST,Y
	3832	"RTN","IBJ DF41",180, 0)
	3833	S Y="^^^" ,MTST=$$LS T^DGMTU(X) ,RXST=$$RX ST^IBARXEU (X)
	3834	"RTN","IBJ DF41",181, 0)
	3835	I '$G(IBE XCEL) D
	3836	"RTN","IBJ DF41",182, 0)
	3837	. S $P(Y, "^",1,2)=$ P(MTST,"^" ,3)_"^"_$$ DAT1^IBOUT L($P(MTST, "^",2))
	3838	"RTN","IBJ DF41",183, 0)
	3839	. S $P(Y, "^",3)=$S( 'RXST:"NON -EXEMPT",+ RXST=1:"EX EMPT",1:"" )
	3840	"RTN","IBJ DF41",184, 0)
	3841	. I $P(Y, "^",3)'="" S $P(Y,"^ ",4)=$$DAT 1^IBOUTL($ P(RXST,"^" ,5))
	3842	"RTN","IBJ DF41",185, 0)
	3843	I $G(IBEX CEL) D
	3844	"RTN","IBJ DF41",186, 0)
	3845	. S $P(Y, "^",1,2)=$ P(MTST,"^" ,4)_"^"_$$ DT^IBJD($P (MTST,"^", 2),1)
	3846	"RTN","IBJ DF41",187, 0)
	3847	. S $P(Y, "^",3)=$S( 'RXST:"M", +RXST=1:"E ",1:"")
	3848	"RTN","IBJ DF41",188, 0)
	3849	. I $P(Y, "^",3)'="" S $P(Y,"^ ",4)=$$DT^ IBJD($P(RX ST,"^",5), 1)
	3850	"RTN","IBJ DF41",189, 0)
	3851	Q Y
	3852	"RTN","IBJ DF41",190, 0)
	3853	;
	3854	"RTN","IBJ DF41",191, 0)
	3855	SREF(RFT,D AT,STS,DEF ,IDX) ; Se t the "ref erred to" informatio n on the
	3856	"RTN","IBJ DF41",192, 0)
	3857	; tem porary glo bal ^TMP
	3858	"RTN","IBJ DF41",193, 0)
	3859	;Input: R FT: "R": R C, "D": DM C, "T": TO P, "P": RE PAYMENT PL AN
	3860	"RTN","IBJ DF41",194, 0)
	3861	; D AT: Date i t was refe rred/estab lished
	3862	"RTN","IBJ DF41",195, 0)
	3863	; S TS: Receiv able statu s (16-Acti ve,19-Susp ended)
	3864	"RTN","IBJ DF41",196, 0)
	3865	; D EF: Repaym ent Plan i n Default? (1 - YES, 0 - NO)
	3866	"RTN","IBJ DF41",197, 0)
	3867	; I DX: Subscr ipt to be set in the Temporary global ^T MP
	3868	"RTN","IBJ DF41",198, 0)
	3869	;Output: IDX: Subsc ript set i n the Temp orary glob al ^TMP
	3870	"RTN","IBJ DF41",199, 0)
	3871	;
	3872	"RTN","IBJ DF41",200, 0)
	3873	N SREF,ID X1
	3874	"RTN","IBJ DF41",201, 0)
	3875	S DEF=+$G (DEF),IDX= +$G(IDX)
	3876	"RTN","IBJ DF41",202, 0)
	3877	I RFT="R" S SREF="R EFERRED TO RC"
	3878	"RTN","IBJ DF41",203, 0)
	3879	I RFT="D" S SREF="R EFERRED TO DMC"
	3880	"RTN","IBJ DF41",204, 0)
	3881	I RFT="T" S SREF="R EFERRED TO TOP"
	3882	"RTN","IBJ DF41",205, 0)
	3883	I RFT="P" D
	3884	"RTN","IBJ DF41",206, 0)
	3885	. S SREF= "REPAYMENT PLAN ESTA BLISHED"
	3886	"RTN","IBJ DF41",207, 0)
	3887	. I $G(DE F) S SREF= SREF_" (CU RRENTLY IN DEFAULT)"
	3888	"RTN","IBJ DF41",208, 0)
	3889	;
	3890	"RTN","IBJ DF41",209, 0)
	3891	I 'IDX S IDX=$O(^TM P("IBJDF4" ,$J,IBPAT, 0,"C",STS, ""),-1)+1
	3892	"RTN","IBJ DF41",210, 0)
	3893	S IDX1=$O (^TMP("IBJ DF4",$J,IB PAT,0,"C", STS,IDX,"" ),-1)+1
	3894	"RTN","IBJ DF41",211, 0)
	3895	S ^TMP("I BJDF4",$J, IBPAT,0,"C ",STS,IDX, IDX1)=DAT
	3896	"RTN","IBJ DF41",212, 0)
	3897	S ^TMP("I BJDF4",$J, IBPAT,0,"C ",STS,IDX, IDX1,1)=SR EF
	3898	"RTN","IBJ DF41",213, 0)
	3899	Q
	3900	"RTN","IBJ DF41",214, 0)
	3901	;
	3902	"RTN","IBJ DF41",215, 0)
	3903	COM ; - Ge t bill com ments.
	3904	"RTN","IBJ DF41",216, 0)
	3905	I 'IBIDX, '$G(IBEXCE L) D
	3906	"RTN","IBJ DF41",217, 0)
	3907	. S IBFLG =0,IBIDX=$ O(^TMP("IB JDF4",$J,I BPAT,0,"C" ,IB0,""),- 1)+1
	3908	"RTN","IBJ DF41",218, 0)
	3909	;
	3910	"RTN","IBJ DF41",219, 0)
	3911	S DAT=0,I BA1=$S(IBS H1="M":999 999999,1:0 )
	3912	"RTN","IBJ DF41",220, 0)
	3913	F S IBA1 =$S(IBSH1= "M":$O(^PR CA(433,"C" ,IBA,IBA1) ,-1),1:$O( ^PRCA(433, "C",IBA,IB
	3914	A1))) Q:'I BA1 D I IBSH1="M", DAT Q
	3915	"RTN","IBJ DF41",221, 0)
	3916	. S IBC=$ G(^PRCA(43 3,IBA1,1)) Q:'IBC
	3917	"RTN","IBJ DF41",222, 0)
	3918	. I $G(IB SH2),$$FMD IFF^XLFDT( DT,+IBC)>I BSH2 Q ; Comment ag e not mini mum.
	3919	"RTN","IBJ DF41",223, 0)
	3920	. I $P(IB C,U,2)'=35 ,$P(IBC,U, 2)'=45 Q ; Not de crease/com ment trans act.
	3921	"RTN","IBJ DF41",224, 0)
	3922	. S DAT=$ S(IBC:+IBC \1,1:+$P(I BC,U,9)\1)
	3923	"RTN","IBJ DF41",225, 0)
	3924	. I $G(IB EXCEL),IBS H1="M" S I BEXCEL1=IB EXCEL1_$$D T^IBJD(DAT ,1) Q
	3925	"RTN","IBJ DF41",226, 0)
	3926	. ;
	3927	"RTN","IBJ DF41",227, 0)
	3928	. ; - App end brief and transa ction comm ents.
	3929	"RTN","IBJ DF41",228, 0)
	3930	. K COM,C OM1 S COM( 0)=DAT,X1= 0
	3931	"RTN","IBJ DF41",229, 0)
	3932	. S COM1( 1)=$P($G(^ PRCA(433,I BA1,5)),U, 2)
	3933	"RTN","IBJ DF41",230, 0)
	3934	. S COM1( 2)=$E($P($ G(^PRCA(43 3,IBA1,8)) ,U,6),1,70 )
	3935	"RTN","IBJ DF41",231, 0)
	3936	. S COM(1 )=COM1(1)_ $S(COM1(1) ]""&(COM1( 2)]""):"\|" ,1:"")_COM 1(2)
	3937	"RTN","IBJ DF41",232, 0)
	3938	. I COM(1 )]"" S COM (1)=""_C OM(1)_"" ,X1=1
	3939	"RTN","IBJ DF41",233, 0)
	3940	. ;
	3941	"RTN","IBJ DF41",234, 0)
	3942	. ; - Get main comm ents.
	3943	"RTN","IBJ DF41",235, 0)
	3944	. S X2=0
	3945	"RTN","IBJ DF41",236, 0)
	3946	. F S X2 =$O(^PRCA( 433,IBA1,7 ,X2)) Q:'X 2 D
	3947	"RTN","IBJ DF41",237, 0)
	3948	. . S COM ($S(X1:X2+ 1,1:X2))=^ PRCA(433,I BA1,7,X2,0 )
	3949	"RTN","IBJ DF41",238, 0)
	3950	. ;
	3951	"RTN","IBJ DF41",239, 0)
	3952	. I $G(IB EXCEL) Q
	3953	"RTN","IBJ DF41",240, 0)
	3954	. ;
	3955	"RTN","IBJ DF41",241, 0)
	3956	. S IBFLG =1,^TMP("I BJDF4",$J, IBPAT,0,"C ",IB0,IBID X,IBA1)=$G (COM(0)),X 1=0
	3957	"RTN","IBJ DF41",242, 0)
	3958	. F S X1 =$O(COM(X1 )) Q:X1="" D
	3959	"RTN","IBJ DF41",243, 0)
	3960	. . S ^TM P("IBJDF4" ,$J,IBPAT, 0,"C",IB0, IBIDX,IBA1 ,X1)=COM(X 1)
	3961	"RTN","IBJ DF41",244, 0)
	3962	;
	3963	"RTN","IBJ DF41",245, 0)
	3964	I '$G(IBE XCEL),IBFL G D
	3965	"RTN","IBJ DF41",246, 0)
	3966	. S $P(^T MP("IBJDF4 ",$J,IBPAT ,IB0,IBCAT ,IBBN),"^" ,6)=IBIDX
	3967	"RTN","IBJ DF41",247, 0)
	3968	Q
	3969	"RTN","IBJ DF41",248, 0)
	3970	; IB2.0 451 - Use Event Dat e to find an associa ted 3rd Pa rty bill w ith an ass
	3971	ociated EE OB
	3972	"RTN","IBJ DF41",249, 0)
	3973	IBEEOBCK(I BBN,DFN) ; Passed AR Bill, Pat ient ID
	3974	"RTN","IBJ DF41",250, 0)
	3975	; Functio n will qui t as soon as a 3rd p arty bill is located that has an associa
	3976	ted EEOB
	3977	"RTN","IBJ DF41",251, 0)
	3978	;
	3979	"RTN","IBJ DF41",252, 0)
	3980	; Find 3r d Party Bi lls with a n Event Da te
	3981	"RTN","IBJ DF41",253, 0)
	3982	N IBREF,I BEEOB,IBDT
	3983	"RTN","IBJ DF41",254, 0)
	3984	S IBEEOB= ""
	3985	"RTN","IBJ DF41",255, 0)
	3986	; Loop th rough Xref of ARbill (#430) to Action fi le (#350)
	3987	"RTN","IBJ DF41",256, 0)
	3988	I +$G(IBB N) S IBREF =0 F S IB REF=$O(^IB ("ABIL",IB BN,IBREF)) Q:'IBREF D Q:IBEE
	3989	OB="%"
	3990	"RTN","IBJ DF41",257, 0)
	3991	. S IBDT= $P($G(^IB( IBREF,0)), "^",17) ;G et event D ate
	3992	"RTN","IBJ DF41",258, 0)
	3993	. I IBDT S IBEEOB=$ $TPEVDT(DF N,IBDT)
	3994	"RTN","IBJ DF41",259, 0)
	3995	. I IBDT S IBEEOB=$ $TPOPV(DFN ,IBDT)
	3996	"RTN","IBJ DF41",260, 0)
	3997	;
	3998	"RTN","IBJ DF41",261, 0)
	3999	Q IBEEOB
	4000	"RTN","IBJ DF41",262, 0)
	4001	;
	4002	"RTN","IBJ DF41",263, 0)
	4003	; IB2.0 451 - Trav erse all T HIRD PARTY bills for a patient with a sp ecific Eve
	4004	nt Date (3 99,.03)
	4005	"RTN","IBJ DF41",264, 0)
	4006	TPEVDT(DFN ,EVDT) ;
	4007	"RTN","IBJ DF41",265, 0)
	4008	; Functio n will qui t as soon as a 3rd p arty bill is located that has an associa
	4009	ted EEOB
	4010	"RTN","IBJ DF41",266, 0)
	4011	; IB2.0 473 - Use the 399,"A PDT" (by p atient) in dex instea d of the 3 99,"D" ind
	4012	ex for eff iciency
	4013	"RTN","IBJ DF41",267, 0)
	4014	I '$G(DFN )!'$G(EVDT ) Q ""
	4015	"RTN","IBJ DF41",268, 0)
	4016	N IBIFN,I BEEOB
	4017	"RTN","IBJ DF41",269, 0)
	4018	S IBEEOB= "",IBIFN=" "
	4019	"RTN","IBJ DF41",270, 0)
	4020	F S IBIF N=$O(^DGCR (399,"APDT ",DFN,IBIF N),-1) Q:' IBIFN D Q:IBEEOB=" %"
	4021	"RTN","IBJ DF41",271, 0)
	4022	. I $D(^D GCR(399,"A PDT",DFN,I BIFN,99999 99-EVDT)) S IBEEOB=$ $EEOBCK(IB IFN)
	4023	"RTN","IBJ DF41",272, 0)
	4024	Q IBEEOB
	4025	"RTN","IBJ DF41",273, 0)
	4026	;
	4027	"RTN","IBJ DF41",274, 0)
	4028	; IB2.0 451 - Trav erse all T HIRD PARTY bills for a patient with any Opt Visit
	4029	Dates same as Event Date (399, 43)
	4030	"RTN","IBJ DF41",275, 0)
	4031	TPOPV(DFN, EVDT) ;
	4032	"RTN","IBJ DF41",276, 0)
	4033	; Functio n will qui t as soon as a 3rd p arty bill is located that has an associa
	4034	ted EEOB
	4035	"RTN","IBJ DF41",277, 0)
	4036	N IBIFN,I BEEOB
	4037	"RTN","IBJ DF41",278, 0)
	4038	S IBEEOB= ""
	4039	"RTN","IBJ DF41",279, 0)
	4040	I +$G(DFN ),+$G(EVDT ) S IBIFN= 0 F S IBI FN=$O(^DGC R(399,"AOP V",DFN,EVD T,IBIFN))
	4041	Q:'IBIFN D Q:IBEEO B="%"
	4042	"RTN","IBJ DF41",280, 0)
	4043	. ; attac h EOB indi cator '%' to bill # when appli cable
	4044	"RTN","IBJ DF41",281, 0)
	4045	. S IBEEO B=$$EEOBCK (IBIFN)
	4046	"RTN","IBJ DF41",282, 0)
	4047	Q IBEEOB
	4048	"RTN","IBJ DF41",283, 0)
	4049	;
	4050	"RTN","IBJ DF41",284, 0)
	4051	; IB2.0 451 - Chec k for EEOB indicator
	4052	"RTN","IBJ DF41",285, 0)
	4053	EEOBCK(IBB ILL) ;
	4054	"RTN","IBJ DF41",286, 0)
	4055	; Check f or 1st and 3rd party payment a ctivity on bill
	4056	"RTN","IBJ DF41",287, 0)
	4057	; IBBILL is the IEN for the b ill # in f iles #399/ #430 and m ust be val id,
	4058	"RTN","IBJ DF41",288, 0)
	4059	; check t he EOB typ e and excl ude it if it is an M RA. Otherw ise,
	4060	"RTN","IBJ DF41",289, 0)
	4061	; returns the EEOB indicator '%' if pay ment activ ity was fo und.
	4062	"RTN","IBJ DF41",290, 0)
	4063	; Access to file #3 61.1 cover ed by IA # 4051.
	4064	"RTN","IBJ DF41",291, 0)
	4065	; Access to file #3 99 covered by IA #38 20.
	4066	"RTN","IBJ DF41",292, 0)
	4067	N IBOUT,I BVAL,Z
	4068	"RTN","IBJ DF41",293, 0)
	4069	I $G(IBBI LL)=0 Q ""
	4070	"RTN","IBJ DF41",294, 0)
	4071	I '$O(^IB M(361.1,"B ",IBBILL,0 )) Q "" ; no entry here
	4072	"RTN","IBJ DF41",295, 0)
	4073	I $P($G(^ DGCR(399,I BBILL,0)), "^",13)=1 Q "" ;avo id 'ENTERE D/NOT REVI EWED' stat
	4074	us
	4075	"RTN","IBJ DF41",296, 0)
	4076	; handle both singl e and mult iple bill entries in file #361 .1
	4077	"RTN","IBJ DF41",297, 0)
	4078	S Z=0 F S Z=$O(^IB M(361.1,"B ",IBBILL,Z )) Q:'Z D Q:$G(IBO UT)="%"
	4079	"RTN","IBJ DF41",298, 0)
	4080	. S IBVAL =$G(^IBM(3 61.1,Z,0))
	4081	"RTN","IBJ DF41",299, 0)
	4082	. S IBOUT =$S($P(IBV AL,"^",4)= 1:"",$P(IB VAL,"^",4) =0:"%",1:" ")
	4083	"RTN","IBJ DF41",300, 0)
	4084	Q IBOUT ; EOB indi cator for either 1st or 3rd pa rty paymen t on bill
	4085	"RTN","IBJ DF41",301, 0)
	4086	;
	4087	"RTN","IBJ DF41",302, 0)
	4088	;
	4089	"RTN","IBJ DF41",303, 0)
	4090	SUST(IBA) ;Look for suspended type for a suspended bill IB2 568/DRF
	4091	"RTN","IBJ DF41",304, 0)
	4092	N TRANS,S T
	4093	"RTN","IBJ DF41",305, 0)
	4094	S ST=""
	4095	"RTN","IBJ DF41",306, 0)
	4096	S TRANS=$ O(^PRCA(43 3,"C",IBA, ""),-1)
	4097	"RTN","IBJ DF41",307, 0)
	4098	S ST=$P($ G(^PRCA(43 3,TRANS,1) ),U,11)
	4099	"RTN","IBJ DF41",308, 0)
	4100	I ST="" S ST="NONE"
	4101	"RTN","IBJ DF41",309, 0)
	4102	Q ST
	4103	"RTN","IBJ DF42")
	4104	0^10^B5499 5736
	4105	"RTN","IBJ DF42",1,0)
	4106	IBJDF42 ;A LB/RB - FI RST PARTY FOLLOW-UP REPORT (PR INT);15-AP R-00
	4107	"RTN","IBJ DF42",2,0)
	4108	;;2.0;INT EGRATED BI LLING;*12 3,204,568 *;21-MAR-9 4;Build 2
	4109	"RTN","IBJ DF42",3,0)
	4110	;Per VA D irective 6 402, this routine sh ould not b e modified .
	4111	"RTN","IBJ DF42",4,0)
	4112	;
	4113	"RTN","IBJ DF42",5,0)
	4114	EN ; - Pri nt the Fol low-up rep ort.
	4115	"RTN","IBJ DF42",6,0)
	4116	;
	4117	"RTN","IBJ DF42",7,0)
	4118	S IBCT(1) ="INELIGIB LE",IBCT(2 )="EMERG/H UMAN.",IBC T(18)="C M EANS TEST"
	4119	"RTN","IBJ DF42",8,0)
	4120	S IBCT(22 )="RX COPA Y/SC",IBCT (23)="RX C OPAY/NSC"
	4121	"RTN","IBJ DF42",9,0)
	4122	S IBCT(33 )="ADHC LT C"
	4123	"RTN","IBJ DF42",10,0 )
	4124	S IBCT(34 )="DOM LTC "
	4125	"RTN","IBJ DF42",11,0 )
	4126	S IBCT(35 )="RESPITE INPT LTC"
	4127	"RTN","IBJ DF42",12,0 )
	4128	S IBCT(36 )="RESPITE OPT LTC"
	4129	"RTN","IBJ DF42",13,0 )
	4130	S IBCT(37 )="GERIATR IC INPT LT C"
	4131	"RTN","IBJ DF42",14,0 )
	4132	S IBCT(38 )="GERIATR IC OPT LTC "
	4133	"RTN","IBJ DF42",15,0 )
	4134	S IBCT(39 )="NURSING HOME LTC"
	4135	"RTN","IBJ DF42",16,0 )
	4136	;
	4137	"RTN","IBJ DF42",17,0 )
	4138	S IBQ=0 D NOW^%DTC S IBRUN=$$ DAT2^IBOUT L(%) G:IBR PT="S" SUM
	4139	"RTN","IBJ DF42",18,0 )
	4140	S IBPRTFL G=0 D DET D PAUSE:'I BPRTFLG I IBQ!'IBPRT FLG G ENQ
	4141	"RTN","IBJ DF42",19,0 )
	4142	;
	4143	"RTN","IBJ DF42",20,0 )
	4144	D PAUSE I IBQ G ENQ
	4145	"RTN","IBJ DF42",21,0 )
	4146	;
	4147	"RTN","IBJ DF42",22,0 )
	4148	SUM I 'IBQ D PRT^IBJ DF43 ; Pri nt summary .
	4149	"RTN","IBJ DF42",23,0 )
	4150	ENQ K IB0, IBAI,IBC,I BCAT,IBCD, IBC1,IBC2, IBCT,IBCNT ,IBN,IBP,I BPAG,IBQ,I BRUN,IBS
	4151	"RTN","IBJ DF42",24,0 )
	4152	K IBST,IB TOT,%,DFN, IBPRTFLG
	4153	"RTN","IBJ DF42",25,0 )
	4154	Q
	4155	"RTN","IBJ DF42",26,0 )
	4156	;
	4157	"RTN","IBJ DF42",27,0 )
	4158	DET ; - Pr int report for a spe cific cate gory.
	4159	"RTN","IBJ DF42",28,0 )
	4160	;
	4161	"RTN","IBJ DF42",29,0 )
	4162	D HDR1 G: IBQ DETQ
	4163	"RTN","IBJ DF42",30,0 )
	4164	S (IBPT,I B,IBCAT,IB 0)=""
	4165	"RTN","IBJ DF42",31,0 )
	4166	F S IBPT =$O(^TMP(" IBJDF4",$J ,IBPT)) Q: IBPT="" D Q:IBQ
	4167	"RTN","IBJ DF42",32,0 )
	4168	. I $O(^T MP("IBJDF4 ",$J,IBPT, 0))="" Q
	4169	"RTN","IBJ DF42",33,0 )
	4170	. S IBP=$ G(^TMP("IB JDF4",$J,I BPT))
	4171	"RTN","IBJ DF42",34,0 )
	4172	. I $Y>(I OSL-14) D PAUSE Q:IB Q D HDR1 Q:IBQ
	4173	"RTN","IBJ DF42",35,0 )
	4174	. D WPAT
	4175	"RTN","IBJ DF42",36,0 )
	4176	. F IB=16 ,19 D Q:I BQ
	4177	"RTN","IBJ DF42",37,0 )
	4178	. . I IBS TA="A",IB' =16 Q
	4179	"RTN","IBJ DF42",38,0 )
	4180	. . I IBS TA="S",IB= 16 Q
	4181	"RTN","IBJ DF42",39,0 )
	4182	. . I '$D (^TMP("IBJ DF4",$J,IB PT,IB)) D Q
	4183	"RTN","IBJ DF42",40,0 )
	4184	. . . I $ Y>(IOSL-5) D PAUSE Q :IBQ D HD R1,WPAT,HD R2 Q:IBQ
	4185	"RTN","IBJ DF42",41,0 )
	4186	. . . W ! ,"-> NO "_ $S(IB=16:" ACTIVE",1: "SUSPENDED ")_" BILLS ."
	4187	"RTN","IBJ DF42",42,0 )
	4188	. . I $Y> (IOSL-9) D PAUSE Q:I BQ D HDR1 ,WPAT Q:IB Q
	4189	"RTN","IBJ DF42",43,0 )
	4190	. . D HDR 2
	4191	"RTN","IBJ DF42",44,0 )
	4192	. . K IBF LG S IBTOT ="",IBCNT= 0
	4193	"RTN","IBJ DF42",45,0 )
	4194	. . F S IBCAT=$O(^ TMP("IBJDF 4",$J,IBPT ,IB,IBCAT) ) Q:IBCAT= "" D Q:I BQ
	4195	"RTN","IBJ DF42",46,0 )
	4196	. . . F S IB0=$O(^ TMP("IBJDF 4",$J,IBPT ,IB,IBCAT, IB0)) Q:IB 0="" D Q :IBQ
	4197	"RTN","IBJ DF42",47,0 )
	4198	. . . . S IBN=$G(^T MP("IBJDF4 ",$J,IBPT, IB,IBCAT,I B0))
	4199	"RTN","IBJ DF42",48,0 )
	4200	. . . . I $Y>(IOSL- 5) D PAUSE Q:IBQ D HDR1,WPAT, HDR2 Q:IBQ
	4201	"RTN","IBJ DF42",49,0 )
	4202	. . . . D WBIL Q:IB Q
	4203	"RTN","IBJ DF42",50,0 )
	4204	. . . . S IBCNT=IBC NT+1
	4205	"RTN","IBJ DF42",51,0 )
	4206	. . . I ' IBQ,$O(^TM P("IBJDF4" ,$J,IBPT,I B,IBCAT))= "" D
	4207	"RTN","IBJ DF42",52,0 )
	4208	. . . . D TOT W !
	4209	"RTN","IBJ DF42",53,0 )
	4210	. . ; - D isplay bil l comment history, i f selected .
	4211	"RTN","IBJ DF42",54,0 )
	4212	. . S IBP RTFLG=1
	4213	"RTN","IBJ DF42",55,0 )
	4214	. . D WCO M(IBPT,IB)
	4215	"RTN","IBJ DF42",56,0 )
	4216	;
	4217	"RTN","IBJ DF42",57,0 )
	4218	I 'IBPRTF LG D
	4219	"RTN","IBJ DF42",58,0 )
	4220	. W !!!!! !,"There a re no rece ivables fo r the para meters ent ered."
	4221	"RTN","IBJ DF42",59,0 )
	4222	;
	4223	"RTN","IBJ DF42",60,0 )
	4224	DETQ Q
	4225	"RTN","IBJ DF42",61,0 )
	4226	;
	4227	"RTN","IBJ DF42",62,0 )
	4228	WPAT ; - W rite patie nt data.
	4229	"RTN","IBJ DF42",63,0 )
	4230	N I,X
	4231	"RTN","IBJ DF42",64,0 )
	4232	S DFN=$P( IBPT,"@@", 2),IBAI=$G (^TMP("IBJ DF4",$J,IB PT,0,"A"))
	4233	"RTN","IBJ DF42",65,0 )
	4234	W !!,"Pat ient Name : ",$P (IBP,U) W: IBAI["V" " *"
	4235	"RTN","IBJ DF42",66,0 )
	4236	W ?63,"SS N: ",$$SSN ($P(IBP,U, 2)),!,"Mea ns Test St atus: ",$P (IBP,U,4)
	4237	"RTN","IBJ DF42",67,0 )
	4238	W:$P(IBP, U,5)'="" " ("_$P(IBP ,U,5)_")"
	4239	"RTN","IBJ DF42",68,0 )
	4240	W ?58,"Me dicaid: ", $$GET1^DIQ (2,DFN,.38 1)
	4241	"RTN","IBJ DF42",69,0 )
	4242	W !,"RX C opay Statu s : ",$P( IBP,U,6)
	4243	"RTN","IBJ DF42",70,0 )
	4244	W:$P(IBP, U,7)'="" " ("_$P(IBP ,U,7)_")"
	4245	"RTN","IBJ DF42",71,0 )
	4246	W:$P(IBP, U,8) ?53," Date of De ath: ",$$D AT1^IBOUTL ($P(IBP,U, 8))
	4247	"RTN","IBJ DF42",72,0 )
	4248	W !,"Elig ibilities : " S X =$$ELIG($P (IBP,U,3))
	4249	"RTN","IBJ DF42",73,0 )
	4250	F I=1:1 Q :X="" W ? 19,$E(X,1, 61) S X=$E (X,62,999) I X'="" W !
	4251	"RTN","IBJ DF42",74,0 )
	4252	S X=$$INF O(IBAI)
	4253	"RTN","IBJ DF42",75,0 )
	4254	I X'="" D
	4255	"RTN","IBJ DF42",76,0 )
	4256	. W !,"Ad ditional I nfo : "
	4257	"RTN","IBJ DF42",77,0 )
	4258	. F I=1:1 Q:X="" W ?19,$E(X, 1,61) S X= $E(X,62,99 9) I X'="" W !
	4259	"RTN","IBJ DF42",78,0 )
	4260	;
	4261	"RTN","IBJ DF42",79,0 )
	4262	Q
	4263	"RTN","IBJ DF42",80,0 )
	4264	;
	4265	"RTN","IBJ DF42",81,0 )
	4266	WBIL ; - W rite bill data.
	4267	"RTN","IBJ DF42",82,0 )
	4268	W ! W:'$D (IBFLG(IBC AT)) IBCT( IBCAT) W ? 13,IB0
	4269	"RTN","IBJ DF42",83,0 )
	4270	W:$P(IBN, "^",6) ?25 ,$J("("_$P (IBN,"^",6 )_")",4)
	4271	"RTN","IBJ DF42",84,0 )
	4272	W ?30,$$D AT1^IBOUTL (+IBN)
	4273	"RTN","IBJ DF42",85,0 )
	4274	W ?39,$J( $FN($P(IBN ,U,2),",", 2),10),?50 ,$J($FN($P (IBN,U,3), ",",2),10)
	4275	"RTN","IBJ DF42",86,0 )
	4276	W ?61,$J( $FN($P(IBN ,U,4),",", 2),9),?71, $J($FN($P( IBN,U,5)," ,",2),9)
	4277	"RTN","IBJ DF42",87,0 )
	4278	I $G(IBST A)="S" W ? 82,$S(IBSU STYP="NONE ":IBSUSTYP ,1:IBSUS(I BSUSTYP))
	4279	"RTN","IBJ DF42",88,0 )
	4280	S $P(IBTO T,"^")=$P( IBTOT,"^") +$P(IBN,U, 2)
	4281	"RTN","IBJ DF42",89,0 )
	4282	S $P(IBTO T,"^",2)=$ P(IBTOT,"^ ",2)+$P(IB N,U,3)
	4283	"RTN","IBJ DF42",90,0 )
	4284	S $P(IBTO T,"^",3)=$ P(IBTOT,"^ ",3)+$P(IB N,U,4)
	4285	"RTN","IBJ DF42",91,0 )
	4286	S $P(IBTO T,"^",4)=$ P(IBTOT,"^ ",4)+$P(IB N,U,5)
	4287	"RTN","IBJ DF42",92,0 )
	4288	S IBFLG(I BCAT)=""
	4289	"RTN","IBJ DF42",93,0 )
	4290	Q
	4291	"RTN","IBJ DF42",94,0 )
	4292	;
	4293	"RTN","IBJ DF42",95,0 )
	4294	WCOM(IBPT, IB) ; - Wr ite bill c omments.
	4295	"RTN","IBJ DF42",96,0 )
	4296	N CMDT,CO NT,DIWL,DI WR,IBIDX,I BTR,IBLN,I BX,X
	4297	"RTN","IBJ DF42",97,0 )
	4298	;
	4299	"RTN","IBJ DF42",98,0 )
	4300	S (IBIDX, IBTR,IBLN) ="",DIWL=1 ,DIWR=64 K ^UTILITY( $J,"W")
	4301	"RTN","IBJ DF42",99,0 )
	4302	F S IBID X=$O(^TMP( "IBJDF4",$ J,IBPT,0," C",IB,IBID X)) Q:IBID X="" D Q :IBQ
	4303	"RTN","IBJ DF42",100, 0)
	4304	. I $Y>(I OSL-6) D W CPB Q:IBQ
	4305	"RTN","IBJ DF42",101, 0)
	4306	. D WCD(I BIDX)
	4307	"RTN","IBJ DF42",102, 0)
	4308	. F S IB TR=$O(^TMP ("IBJDF4", $J,IBPT,0, "C",IB,IBI DX,IBTR)) Q:IBTR="" D Q:IBQ
	4309	"RTN","IBJ DF42",103, 0)
	4310	. . S CMD T=$G(^TMP( "IBJDF4",$ J,IBPT,0," C",IB,IBID X,IBTR))
	4311	"RTN","IBJ DF42",104, 0)
	4312	. . I $Y> (IOSL-4) D WCPB Q:IB Q
	4313	"RTN","IBJ DF42",105, 0)
	4314	. . S CON T=0 D WCD( ,1,)
	4315	"RTN","IBJ DF42",106, 0)
	4316	. . F S IBLN=$O(^T MP("IBJDF4 ",$J,IBPT, 0,"C",IB,I BIDX,IBTR, IBLN)) Q:I BLN="" D
	4317	Q:IBQ
	4318	"RTN","IBJ DF42",107, 0)
	4319	. . . S I BX=$G(^TMP ("IBJDF4", $J,IBPT,0, "C",IB,IBI DX,IBTR,IB LN))
	4320	"RTN","IBJ DF42",108, 0)
	4321	. . . I $ E(IBX)=" " ,$L(IBX)>1 S $E(IBX) =""
	4322	"RTN","IBJ DF42",109, 0)
	4323	. . . S X =IBX D ^DI WP
	4324	"RTN","IBJ DF42",110, 0)
	4325	. . . I ' CONT,$L(IB X)<66 D WC TX
	4326	"RTN","IBJ DF42",111, 0)
	4327	. . . S C ONT=$L(IBX )>65
	4328	"RTN","IBJ DF42",112, 0)
	4329	. . . I ' $O(^TMP("I BJDF4",$J, IBPT,0,"C" ,IB,IBIDX, IBTR,IBLN) ) D
	4330	"RTN","IBJ DF42",113, 0)
	4331	. . . . D :$D(^UTILI TY($J,"W") ) WCTX
	4332	"RTN","IBJ DF42",114, 0)
	4333	K ^UTILIT Y($J,"W")
	4334	"RTN","IBJ DF42",115, 0)
	4335	Q
	4336	"RTN","IBJ DF42",116, 0)
	4337	;
	4338	"RTN","IBJ DF42",117, 0)
	4339	WCD(I,D,C) ; - Write the comme nt date.
	4340	"RTN","IBJ DF42",118, 0)
	4341	; Input: I - Index # "(I)"
	4342	"RTN","IBJ DF42",119, 0)
	4343	; D - Print the Date " - MM/DD/ YY"
	4344	"RTN","IBJ DF42",120, 0)
	4345	; C - Print the Cont. "(Continue d)"
	4346	"RTN","IBJ DF42",121, 0)
	4347	;
	4348	"RTN","IBJ DF42",122, 0)
	4349	W:$G(I) ! ,"(",I,")" W:$G(D) ? 3," - ",$$ DAT1^IBOUT L(CMDT),": "
	4350	"RTN","IBJ DF42",123, 0)
	4351	W:$G(C) " (Continued )",!
	4352	"RTN","IBJ DF42",124, 0)
	4353	Q
	4354	"RTN","IBJ DF42",125, 0)
	4355	;
	4356	"RTN","IBJ DF42",126, 0)
	4357	WCTX ; - W rite the c omment tex t.
	4358	"RTN","IBJ DF42",127, 0)
	4359	N LIN,WLI N,Z
	4360	"RTN","IBJ DF42",128, 0)
	4361	S LIN=""
	4362	"RTN","IBJ DF42",129, 0)
	4363	F S LIN= $O(^UTILIT Y($J,"W",1 ,LIN)) Q:L IN="" D Q:IBQ
	4364	"RTN","IBJ DF42",130, 0)
	4365	. S WLIN= $G(^UTILIT Y($J,"W",1 ,LIN,0)) Q :WLIN=""
	4366	"RTN","IBJ DF42",131, 0)
	4367	. W ?16,W LIN
	4368	"RTN","IBJ DF42",132, 0)
	4369	. I '$O(^ UTILITY($J ,"W",1,LIN )) W ! Q
	4370	"RTN","IBJ DF42",133, 0)
	4371	. I $Y>(I OSL-4) D W CPB,WCD(IB IDX,1,1) Q
	4372	"RTN","IBJ DF42",134, 0)
	4373	. W !
	4374	"RTN","IBJ DF42",135, 0)
	4375	K ^UTILIT Y($J,"W")
	4376	"RTN","IBJ DF42",136, 0)
	4377	Q
	4378	"RTN","IBJ DF42",137, 0)
	4379	;
	4380	"RTN","IBJ DF42",138, 0)
	4381	WCPB ; - P age Break in the mid dle of the Comments
	4382	"RTN","IBJ DF42",139, 0)
	4383	D PAUSE Q :IBQ D HD R1,WPAT W !!
	4384	"RTN","IBJ DF42",140, 0)
	4385	Q
	4386	"RTN","IBJ DF42",141, 0)
	4387	;
	4388	"RTN","IBJ DF42",142, 0)
	4389	HDR1 ; - W rite the r eport head er.
	4390	"RTN","IBJ DF42",143, 0)
	4391	N X,I
	4392	"RTN","IBJ DF42",144, 0)
	4393	W:'$G(IBP AG) ! I $E (IOST,1,2) ="C-"!$G(I BPAG) W @I OF,*13
	4394	"RTN","IBJ DF42",145, 0)
	4395	S IBPAG=$ G(IBPAG)+1 W "First Party Foll ow-Up Repo rt"
	4396	"RTN","IBJ DF42",146, 0)
	4397	W ?34,"Ru n Date: ", IBRUN,?71, "Page: ",$ J(IBPAG,3)
	4398	"RTN","IBJ DF42",147, 0)
	4399	S X="ALL "_$S(IBSTA '="S":"ACT IVE",1:"") _$S(IBSTA= "B":" AND ",1:"")
	4400	"RTN","IBJ DF42",148, 0)
	4401	S X=X_$S( IBSTA'="A" :"SUSPENDE D",1:"")_$ $TYPE(IBSE L)_" RECEI VABLES"
	4402	"RTN","IBJ DF42",149, 0)
	4403	I IBSMN'= "A" S X=X_ " OVER "_I BSMN_" AND UNDER "_I BSMX_" DAY S OLD"
	4404	"RTN","IBJ DF42",150, 0)
	4405	S X=X_" / BY "_$S(I BSN="N":"N AME",1:"LA ST 4 SSN")
	4406	"RTN","IBJ DF42",151, 0)
	4407	S X=X_" ( "_$S($G(IB SNA)="ALL" :"ALL",1:" From "_$S( IBSNF="":" FIRST",1:I BSNF)_" to
	4408	"_$S(IBSN L="zzzzz": "LAST",1:I BSNL))_")"
	4409	"RTN","IBJ DF42",152, 0)
	4410	S X=X_" / "_$S('IBS AM:"NO ",1 :"")_"MINI MUM BALANC E"
	4411	"RTN","IBJ DF42",153, 0)
	4412	S X=X_$S( IBSAM:": $ "_$FN(IBSA M,",",2),1 :"")
	4413	"RTN","IBJ DF42",154, 0)
	4414	S X=X_" / "_$S('IBS H:"NO ",IB SH1="A":"A LL ",1:"ON LY ")_"COM MENTS"
	4415	"RTN","IBJ DF42",155, 0)
	4416	S X=X_$S( $G(IBSH2): " LESS THA N "_IBSH2_ " DAYS OLD ",1:"")
	4417	"RTN","IBJ DF42",156, 0)
	4418	S X=X_" / RECEIVABL ES REFERRE D TO RC "_ $S('IBSRC: "NOT ",1:" ")_"INCLUD ED"
	4419	"RTN","IBJ DF42",157, 0)
	4420	F I=1:1 W !,$E(X,1, 80) S X=$E (X,81,999) I X="" Q
	4421	"RTN","IBJ DF42",158, 0)
	4422	;
	4423	"RTN","IBJ DF42",159, 0)
	4424	S IBQ=$$S TOP^IBOUTL ("First Pa rty Follow -Up Report ")
	4425	"RTN","IBJ DF42",160, 0)
	4426	Q
	4427	"RTN","IBJ DF42",161, 0)
	4428	;
	4429	"RTN","IBJ DF42",162, 0)
	4430	TYPE(SEL) ; Returns a string w ith the ty pe of rece ivables (d escription )
	4431	"RTN","IBJ DF42",163, 0)
	4432	; selecte d or NULL if ALL rec eivable ty pe have be en selecte d.
	4433	"RTN","IBJ DF42",164, 0)
	4434	; SEL - U ser input for the pa rameter "T ype of Rec eivable"
	4435	"RTN","IBJ DF42",165, 0)
	4436	;
	4437	"RTN","IBJ DF42",166, 0)
	4438	N TYPE,I, X
	4439	"RTN","IBJ DF42",167, 0)
	4440	I SEL="1, 2,3," Q ""
	4441	"RTN","IBJ DF42",168, 0)
	4442	S TYPE="" ,X="EMERGE NCY/HUMANI TARIAN^INE LIGIBLE^C- MEANS TEST & RX COPA Y"
	4443	"RTN","IBJ DF42",169, 0)
	4444	F I=2:1:( $L(SEL,"," )-1) D
	4445	"RTN","IBJ DF42",170, 0)
	4446	. S TYPE= TYPE_$S(I= ($L(SEL,", ")-1)&(TYP E'=""):" A ND ",1:", ")
	4447	"RTN","IBJ DF42",171, 0)
	4448	. S TYPE= TYPE_$P(X, "^",+$P(SE L,",",I))
	4449	"RTN","IBJ DF42",172, 0)
	4450	S $E(TYPE ,1)=""
	4451	"RTN","IBJ DF42",173, 0)
	4452	;
	4453	"RTN","IBJ DF42",174, 0)
	4454	Q TYPE
	4455	"RTN","IBJ DF42",175, 0)
	4456	;
	4457	"RTN","IBJ DF42",176, 0)
	4458	HDR2 ; - W rite bill sub-header .
	4459	"RTN","IBJ DF42",177, 0)
	4460	W ! I IBS TA="B" W ! ,$S(IB=16: "ACTIVE",1 :"SUSPENDE D")
	4461	"RTN","IBJ DF42",178, 0)
	4462	W ! I IBS TA="B" W $ S(IB=16:"= =====",1:" =========" )
	4463	"RTN","IBJ DF42",179, 0)
	4464	W:IBSH ?2 6,"COM" W ?30,"Last" ,?40,"Curr ent",?51," Principal"
	4465	"RTN","IBJ DF42",180, 0)
	4466	W !,"Cate gory",?13, "Bill Numb er",?26,"R EF"
	4467	"RTN","IBJ DF42",181, 0)
	4468	W ?30,"Pa yment",?40 ,"Balance" ,?51,"Bala nce",?62," Interest", ?72,"Admin ."
	4469	"RTN","IBJ DF42",182, 0)
	4470	I IBSTA=" S" W ?82," Suspended Type"
	4471	"RTN","IBJ DF42",183, 0)
	4472	W !,$$DAS H(96,1)
	4473	"RTN","IBJ DF42",184, 0)
	4474	Q
	4475	"RTN","IBJ DF42",185, 0)
	4476	;
	4477	"RTN","IBJ DF42",186, 0)
	4478	TOT ; - Wr ite balanc e total fo r patient.
	4479	"RTN","IBJ DF42",187, 0)
	4480	N I,J
	4481	"RTN","IBJ DF42",188, 0)
	4482	I IBCNT>1 W ! F I=4 0,51,62,72 W ?I,$E(" ---------" ,1,$S(I>60 :8,1:9))
	4483	"RTN","IBJ DF42",189, 0)
	4484	W:IBCNT'> 1 !
	4485	"RTN","IBJ DF42",190, 0)
	4486	W !,"Acco unt Balanc e: $"_$FN( $P(IBP,"^" ,10),",",2 )
	4487	"RTN","IBJ DF42",191, 0)
	4488	I IBCNT'> 1 Q
	4489	"RTN","IBJ DF42",192, 0)
	4490	S J=1 F I =39,50,60, 70 W ?I,$J ($FN($P(IB TOT,"^",J) ,",",2),10 ) S J=J+1
	4491	"RTN","IBJ DF42",193, 0)
	4492	Q
	4493	"RTN","IBJ DF42",194, 0)
	4494	;
	4495	"RTN","IBJ DF42",195, 0)
	4496	DASH(X,Y) ; - Return a dashed line.
	4497	"RTN","IBJ DF42",196, 0)
	4498	Q $TR($J( "",X)," ", $S(Y:"-",1 :"="))
	4499	"RTN","IBJ DF42",197, 0)
	4500	;
	4501	"RTN","IBJ DF42",198, 0)
	4502	ELIG(X) ; - Return e ligibility code name .
	4503	"RTN","IBJ DF42",199, 0)
	4504	; X - Eli gibility c odes separ ated by se mi-collon (;)
	4505	"RTN","IBJ DF42",200, 0)
	4506	;
	4507	"RTN","IBJ DF42",201, 0)
	4508	N ELIG,I
	4509	"RTN","IBJ DF42",202, 0)
	4510	S ELIG="" F I=1:1:$ L(X,";") D
	4511	"RTN","IBJ DF42",203, 0)
	4512	. I '$P(X ,";",I) Q
	4513	"RTN","IBJ DF42",204, 0)
	4514	. S ELIG= ELIG_", "_ $E($P($G(^ DIC(8,+$P( X,";",I),0 )),U),1,20 )
	4515	"RTN","IBJ DF42",205, 0)
	4516	S $E(ELIG ,1,2)=""
	4517	"RTN","IBJ DF42",206, 0)
	4518	;
	4519	"RTN","IBJ DF42",207, 0)
	4520	Q ELIG
	4521	"RTN","IBJ DF42",208, 0)
	4522	;
	4523	"RTN","IBJ DF42",209, 0)
	4524	INFO(X) ; - Return t he patient Additiona l Informat ion about the Patien t Accout
	4525	"RTN","IBJ DF42",210, 0)
	4526	; X - Fla gs represe nting the observatio ns
	4527	"RTN","IBJ DF42",211, 0)
	4528	;
	4529	"RTN","IBJ DF42",212, 0)
	4530	N INFO,I
	4531	"RTN","IBJ DF42",213, 0)
	4532	S INFO="" F I=1:1:$ L(X) D
	4533	"RTN","IBJ DF42",214, 0)
	4534	. I $E(X, I)="V" S I NFO=INFO_" , '*' - VA EMPLOYEE"
	4535	"RTN","IBJ DF42",215, 0)
	4536	. I $E(X, I)="R" S I NFO=INFO_" , REFERRED TO RC"
	4537	"RTN","IBJ DF42",216, 0)
	4538	. I $E(X, I)="D" S I NFO=INFO_" , REFERRED TO DMC"
	4539	"RTN","IBJ DF42",217, 0)
	4540	. I $E(X, I)="T" S I NFO=INFO_" , REFERRED TO TOP"
	4541	"RTN","IBJ DF42",218, 0)
	4542	. I $E(X, I)="P" S I NFO=INFO_" , UNDER RE PAYMENT PL AN"
	4543	"RTN","IBJ DF42",219, 0)
	4544	. I $E(X, I)="F" S I NFO=INFO_" , UNDER DE FAULTED RE PAYMENT PL AN"
	4545	"RTN","IBJ DF42",220, 0)
	4546	S $E(INFO ,1,2)=""
	4547	"RTN","IBJ DF42",221, 0)
	4548	;
	4549	"RTN","IBJ DF42",222, 0)
	4550	Q INFO
	4551	"RTN","IBJ DF42",223, 0)
	4552	;
	4553	"RTN","IBJ DF42",224, 0)
	4554	SSN(X) ; - Format th e SSN.
	4555	"RTN","IBJ DF42",225, 0)
	4556	Q $S(X]"" :$E(X,1,3) _"-"_$E(X, 4,5)_"-"_$ E(X,6,10), 1:"")
	4557	"RTN","IBJ DF42",226, 0)
	4558	;
	4559	"RTN","IBJ DF42",227, 0)
	4560	PAUSE ; - Page break .
	4561	"RTN","IBJ DF42",228, 0)
	4562	I $E(IOST ,1,2)'="C- " Q
	4563	"RTN","IBJ DF42",229, 0)
	4564	N IBX,DIR ,DIRUT,DUO UT,DTOUT,D IROUT,X,Y
	4565	"RTN","IBJ DF42",230, 0)
	4566	F IBX=$Y: 1:(IOSL-3) W !
	4567	"RTN","IBJ DF42",231, 0)
	4568	S DIR(0)= "E" D ^DIR S:$D(DIRU T)!($D(DUO UT)) IBQ=1
	4569	"RTN","IBJ DF42",232, 0)
	4570	Q
	4571	"RTN","IBJ TLA1")
	4572	0^2^B13446 872
	4573	"RTN","IBJ TLA1",1,0)
	4574	IBJTLA1 ;A LB/ARH - T PI ACTIVE BILLS LIST BUILD ;2/ 14/95
	4575	"RTN","IBJ TLA1",2,0)
	4576	;;2.0;INT EGRATED BI LLING;39 ,80,61,51, 153,137,18 3,276,451, 516,530,56 8;21-MAR
	4577	-94;Build 2
	4578	"RTN","IBJ TLA1",3,0)
	4579	;;Per VA Directive 6402, this routine s hould not be modifie d.
	4580	"RTN","IBJ TLA1",4,0)
	4581	;
	4582	"RTN","IBJ TLA1",5,0)
	4583	BLDA ; bui ld active list for t hird party joint inq uiry activ e list
	4584	"RTN","IBJ TLA1",6,0)
	4585	N IBIFN,I BCNT S VAL MCNT=0,IBC NT=0
	4586	"RTN","IBJ TLA1",7,0)
	4587	S IBIFN=0 F S IBIF N=$O(^DGCR (399,"C",D FN,IBIFN)) Q:'IBIFN I $$ACTIV E^IBJTU4(I
	4588	BIFN) W ". " D SCRN
	4589	"RTN","IBJ TLA1",8,0)
	4590	;
	4591	"RTN","IBJ TLA1",9,0)
	4592	I VALMCNT =0 D SET(" ",0),SET( "No Active Bills for this Pati ent",0)
	4593	"RTN","IBJ TLA1",10,0 )
	4594	;
	4595	"RTN","IBJ TLA1",11,0 )
	4596	Q
	4597	"RTN","IBJ TLA1",12,0 )
	4598	;
	4599	"RTN","IBJ TLA1",13,0 )
	4600	SCRN ; add bill to s creen list (IBIFN,DF N must be defined)
	4601	"RTN","IBJ TLA1",14,0 )
	4602	N X,IBY,I BD0,IBDU,I BDM,TYPE,R EJFLAG,IND FLG,IBTYP S X=""
	4603	"RTN","IBJ TLA1",15,0 )
	4604	S IBCNT=I BCNT+1,IBD 0=$G(^DGCR (399,+IBIF N,0)),IBDU =$G(^DGCR( 399,+IBIFN ,"U")),IBD
	4605	M=$G(^DGCR (399,+IBIF N,"M"))
	4606	"RTN","IBJ TLA1",16,0 )
	4607	S IBY=IBC NT,X=$$SET FLD^VALM1( IBY,X,"NUM BER")
	4608	"RTN","IBJ TLA1",17,0 )
	4609	; IB2.0 451 - get EEOB indic ator for b ill # when applicabl e
	4610	"RTN","IBJ TLA1",18,0 )
	4611	S IBPFLAG =$$EEOB(+I BIFN)
	4612	"RTN","IBJ TLA1",19,0 )
	4613	S REJFLAG =+$$BILLRE J^IBJTU6($ P(IBD0,U)) ;IB2.05 30 Add ind icator for rejects
	4614	"RTN","IBJ TLA1",20,0 )
	4615	S INDFLG= $S($G(IBPF LAG)'="":" %",1:"")_$ S(REJFLAG: "c",1:"") S:INDFLG=" " INDFLG="
	4616	"
	4617	"RTN","IBJ TLA1",21,0 )
	4618	S IBY=IND FLG_$P(IBD 0,U,1)_$$E CME^IBTRE( IBIFN),X=$ $SETFLD^VA LM1(IBY,X, "BILL") ;a
	4619	dd EEOB in dicator '% ' to bill number whe n applicab le
	4620	"RTN","IBJ TLA1",22,0 )
	4621	S IBY=$S( $$REF^IBJT U31(+IBIFN ):"r",1:"" ),X=$$SETF LD^VALM1(I BY,X,"REFE R")
	4622	"RTN","IBJ TLA1",23,0 )
	4623	S IBY=$S( $$IB^IBRUT L(+IBIFN,0 ):"*",1:"" ),X=$$SETF LD^VALM1(I BY,X,"HD")
	4624	"RTN","IBJ TLA1",24,0 )
	4625	S IBY=$$D ATE($P(IBD U,U,1)),X= $$SETFLD^V ALM1(IBY,X ,"STFROM")
	4626	"RTN","IBJ TLA1",25,0 )
	4627	S IBY=$$D ATE($P(IBD U,U,2)),X= $$SETFLD^V ALM1(IBY,X ,"STTO")
	4628	"RTN","IBJ TLA1",26,0 )
	4629	;
	4630	"RTN","IBJ TLA1",27,0 )
	4631	S IBY=$P( $$LST^DGMT U(DFN,$P(I BDU,U)),U, 4),IBY=$S( IBY="C":"Y ES",IBY="P ":"PEN",IB
	4632	Y="R":"REQ ",IBY="G": "GMT",1:"N O"),X=$$SE TFLD^VALM1 (IBY,X,"MT ?")
	4633	"RTN","IBJ TLA1",28,0 )
	4634	;S IBY=$$ TYPE($P(IB D0,U,5))_$ $TF($P(IBD 0,U,6))_$S ($P(IBD0,U ,27)=1:"I" ,$P(IBD0,U
	4635	,27)=2:"P" ,1:""),X=$ $SETFLD^VA LM1(IBY,X, "TYPE") ; 516 - baa
	4636	"RTN","IBJ TLA1",29,0 )
	4637	S TYPE=$$ TYPE($P(IB D0,U,5)) I $E(TYPE,2 )="P" S TY PE=$E(TYPE ) ; 516 - baa
	4638	"RTN","IBJ TLA1",30,0 )
	4639	;S IBY=TY PE_"/"_$S( $P(IBD0,U, 27)=1:"I", $P(IBD0,U, 27)=2:"P", 1:""),X=$$ SETFLD^VAL
	4640	M1(IBY,X," TYPE") ; 516 - baa
	4641	"RTN","IBJ TLA1",31,0 )
	4642	S IBY=TYP E_"/"_$S($ P(IBD0,U,2 7)=1:"I",$ P(IBD0,U,2 7)=2:"P",1 :" "),X=$$ SETFLD^VAL
	4643	M1(IBY,X," TYPE") ; 5 68 - lmh r et space i f null
	4644	"RTN","IBJ TLA1",32,0 )
	4645	;
	4646	"RTN","IBJ TLA1",33,0 )
	4647	; Return care type for (I)npa t,(O)utpat , (R)x or (P)rosthet ics - add under TJPI
	4648	screen TY PE column - 568
	4649	"RTN","IBJ TLA1",34,0 )
	4650	S IBTYP=$ $TYP^IBRFN (IBIFN)
	4651	"RTN","IBJ TLA1",35,0 )
	4652	S IBTYP=$ S(IBTYP="" :-1,IBTYP= "PR":"P",I BTYP="PH": "R",1:IBTY P)
	4653	"RTN","IBJ TLA1",36,0 )
	4654	S IBY=IBY _"/"_IBTYP ,X=$$SETFL D^VALM1(IB Y,X,"TYPE" )
	4655	"RTN","IBJ TLA1",37,0 )
	4656	;
	4657	"RTN","IBJ TLA1",38,0 )
	4658	S IBY=" " _$P($$ARST ATA^IBJTU4 (IBIFN),U, 2),X=$$SET FLD^VALM1( IBY,X,"ARS T")
	4659	"RTN","IBJ TLA1",39,0 )
	4660	;
	4661	"RTN","IBJ TLA1",40,0 )
	4662	S IBY=$P( $G(^DGCR(3 99.3,+$P(I BD0,U,7),0 )),U,4),X= $$SETFLD^V ALM1(IBY,X ,"RATE")
	4663	"RTN","IBJ TLA1",41,0 )
	4664	S IBY=$S( $$MINS^IBJ TU31(+IBIF N):"+",1:" "),X=$$SET FLD^VALM1( IBY,X,"CB" )
	4665	"RTN","IBJ TLA1",42,0 )
	4666	S IBY=+$G (^DGCR(399 ,+IBIFN,"M P"))
	4667	"RTN","IBJ TLA1",43,0 )
	4668	I 'IBY,$$ MCRWNR^IBE FUNC($$CUR R^IBCEF2(I BIFN)) S I BY=+$$CURR ^IBCEF2(IB IFN)
	4669	"RTN","IBJ TLA1",44,0 )
	4670	S IBY=$P( $G(^DIC(36 ,+IBY,0)), U,1)
	4671	"RTN","IBJ TLA1",45,0 )
	4672	S X=$$SET FLD^VALM1( IBY,X,"INS UR")
	4673	"RTN","IBJ TLA1",46,0 )
	4674	S IBY=$$B ILL^RCJIBF N2(IBIFN)
	4675	"RTN","IBJ TLA1",47,0 )
	4676	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,1),8,2) ,X,"OAMT")
	4677	"RTN","IBJ TLA1",48,0 )
	4678	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,3),8,2) ,X,"CAMT")
	4679	"RTN","IBJ TLA1",49,0 )
	4680	D SET(X,I BCNT)
	4681	"RTN","IBJ TLA1",50,0 )
	4682	Q
	4683	"RTN","IBJ TLA1",51,0 )
	4684	;
	4685	"RTN","IBJ TLA1",52,0 )
	4686	DATE(X) ; date in ex ternal for mat
	4687	"RTN","IBJ TLA1",53,0 )
	4688	N Y S Y=" " I X?7N.E S Y=$E(X, 4,5)_"/"_$ E(X,6,7)_" /"_$E(X,2, 3)
	4689	"RTN","IBJ TLA1",54,0 )
	4690	Q Y
	4691	"RTN","IBJ TLA1",55,0 )
	4692	;
	4693	"RTN","IBJ TLA1",56,0 )
	4694	TYPE(X) ; return abb reviated f orm of Bil l Classifi cation (39 9,.05)
	4695	"RTN","IBJ TLA1",57,0 )
	4696	Q $S(X=1: "IP",X=2:" IH",X=3:"O P",X=4:"OH ",1:"")
	4697	"RTN","IBJ TLA1",58,0 )
	4698	;
	4699	"RTN","IBJ TLA1",59,0 )
	4700	TF(X) ; re turn abbre viated for m of Timef rame of Bi ll (399,.0 6)
	4701	"RTN","IBJ TLA1",60,0 )
	4702	Q $S(X=2: "-F",X=3:" -C",X=4:"- L",X'=1:"- O",1:"")
	4703	"RTN","IBJ TLA1",61,0 )
	4704	;
	4705	"RTN","IBJ TLA1",62,0 )
	4706	SET(X,CNT) ; set up list manag er screen array
	4707	"RTN","IBJ TLA1",63,0 )
	4708	S VALMCNT =VALMCNT+1
	4709	"RTN","IBJ TLA1",64,0 )
	4710	S ^TMP("I BJTLA",$J, VALMCNT,0) =X Q:'CNT
	4711	"RTN","IBJ TLA1",65,0 )
	4712	S ^TMP("I BJTLA",$J, "IDX",VALM CNT,+CNT)= ""
	4713	"RTN","IBJ TLA1",66,0 )
	4714	S ^TMP("I BJTLAX",$J ,CNT)=VALM CNT_U_IBIF N
	4715	"RTN","IBJ TLA1",67,0 )
	4716	Q
	4717	"RTN","IBJ TLA1",68,0 )
	4718	;
	4719	"RTN","IBJ TLA1",69,0 )
	4720	EEOB(IBIFN ) ; get pa yment info rmation
	4721	"RTN","IBJ TLA1",70,0 )
	4722	; IB2.0 451 - find an EOB pa yment for a bill
	4723	"RTN","IBJ TLA1",71,0 )
	4724	; input i s the IEN for the bi ll # in fi le #399 an d must be valid,
	4725	"RTN","IBJ TLA1",72,0 )
	4726	; output is the EEO B indicato r '%' if a payment i s found in file #361 .1,
	4727	"RTN","IBJ TLA1",73,0 )
	4728	; exclude EOB type MRA (Medic are).
	4729	"RTN","IBJ TLA1",74,0 )
	4730	N IBPFLAG ,IBVAL,Z
	4731	"RTN","IBJ TLA1",75,0 )
	4732	I $G(IBIF N)=0 Q ""
	4733	"RTN","IBJ TLA1",76,0 )
	4734	I '$O(^IB M(361.1,"B ",IBIFN,0) ) Q "" ; no entry h ere
	4735	"RTN","IBJ TLA1",77,0 )
	4736	I $P($G(^ DGCR(399,I BIFN,0))," ^",13)=1 Q "" ;avoi d 'ENTERED /NOT REVIE WED' statu
	4737	s
	4738	"RTN","IBJ TLA1",78,0 )
	4739	; handle both singl e and mult iple bill entries in file #361 .1
	4740	"RTN","IBJ TLA1",79,0 )
	4741	S Z=0 F S Z=$O(^IB M(361.1,"B ",IBIFN,Z) ) Q:'Z D Q:$G(IBPF LAG)="%"
	4742	"RTN","IBJ TLA1",80,0 )
	4743	. S IBVAL =$G(^IBM(3 61.1,Z,0))
	4744	"RTN","IBJ TLA1",81,0 )
	4745	. S IBPFL AG=$S($P(I BVAL,"^",4 )=1:"",$P( IBVAL,"^", 4)=0:"%",1 :"")
	4746	"RTN","IBJ TLA1",82,0 )
	4747	Q IBPFLAG ; EOB in dicator fo r either 1 st or 3rd payment on bill
	4748	"RTN","IBJ TLA1",83,0 )
	4749	;
	4750	"RTN","IBJ TLB1")
	4751	0^7^B13573 050
	4752	"RTN","IBJ TLB1",1,0)
	4753	IBJTLB1 ;A LB/ARH - T PI INACTIV E LIST BUI LD ;2/14/9 5
	4754	"RTN","IBJ TLB1",2,0)
	4755	;;2.0;INT EGRATED BI LLING;39 ,80,61,137 ,276,451,5 16,530,568 ;21-MAR- 94;Build 2
	4756	"RTN","IBJ TLB1",3,0)
	4757	;;Per VA Directive 6402, this routine s hould not be modifie d.
	4758	"RTN","IBJ TLB1",4,0)
	4759	;
	4760	"RTN","IBJ TLB1",5,0)
	4761	BLDA ; bui ld active list for t hird party joint inq uiry activ e list, DF N must be
	4762	defined
	4763	"RTN","IBJ TLB1",6,0)
	4764	; first s earch star ts at dt a nd works b ackwards f or 6 month s of bills or IBMAXC
	4765	NT bills, whichever is greater
	4766	"RTN","IBJ TLB1",7,0)
	4767	; all bil ls for a s ingle day are includ ed in the same searc h so even IBMAXCNT m
	4768	ay be exce eded
	4769	"RTN","IBJ TLB1",8,0)
	4770	; if IBEN D is defin ed on entr y it is us ed as the end dt of the search , otherwis
	4771	e DT is us ed
	4772	"RTN","IBJ TLB1",9,0)
	4773	; IBBEG i s left def ined on ex it, if it has a valu e then it is used by the Chang
	4774	e Dates ac tion to de fine the n ext
	4775	"RTN","IBJ TLB1",10,0 )
	4776	; end dat e of the s earch, thi s results in each CD action de fault work ing backwa
	4777	rds throug h the date range unt il
	4778	"RTN","IBJ TLB1",11,0 )
	4779	; no bill s are foun d and IBBE G is null then searc h restarts at DT, IB END is def
	4780	ined so ca n tell if range chan ged
	4781	"RTN","IBJ TLB1",12,0 )
	4782	N IBIFN,I BCNT,IBBDT ,IBEDT,IBF IRST,IBLAS T,IBDT1,IB DT2,IBMAXC NT K IBHMS G
	4783	"RTN","IBJ TLB1",13,0 )
	4784	S IBEDT=$ S(+$G(IBEN D):IBEND,1 :DT),IBBDT =$$FMADD^X LFDT(IBEDT ,-180),IBM AXCNT=52
	4785	"RTN","IBJ TLB1",14,0 )
	4786	;
	4787	"RTN","IBJ TLB1",15,0 )
	4788	S (VALMCN T,IBCNT)=0 ,IBDT1=$S( IBEDT'="": -(IBEDT+.0 1),1:""),I BDT2=-IBBD T
	4789	"RTN","IBJ TLB1",16,0 )
	4790	S IBFIRST =IBBDT,IBL AST=-$O(^D GCR(399,"A PDS",DFN," "))
	4791	"RTN","IBJ TLB1",17,0 )
	4792	;
	4793	"RTN","IBJ TLB1",18,0 )
	4794	F S IBDT 1=$O(^DGCR (399,"APDS ",DFN,IBDT 1)) Q:'IBD T1!(IBDT1> IBDT2&(IBC NT'<IBMAXC
	4795	NT)) S IB FIRST=-IBD T1 D
	4796	"RTN","IBJ TLB1",19,0 )
	4797	. S IBIFN =0 F S IB IFN=$O(^DG CR(399,"AP DS",DFN,IB DT1,IBIFN) ) Q:'IBIFN I '$$ACT
	4798	IVE^IBJTU4 (IBIFN) D SCRN W "."
	4799	"RTN","IBJ TLB1",20,0 )
	4800	;
	4801	"RTN","IBJ TLB1",21,0 )
	4802	S IBBEG=$ S('IBDT1:" ",IBBDT>IB FIRST:IBFI RST,1:IBBD T),IBBDT=$ S(+IBBEG:$ $DATE(IBBE
	4803	G),1:"BEGI N")
	4804	"RTN","IBJ TLB1",22,0 )
	4805	S IBEND=$ S(IBEDT="" !(IBLAST'> IBEDT):"", 1:IBEDT),I BEDT=$S(+I BEND:$$DAT E(IBEND),1
	4806	:"END")
	4807	"RTN","IBJ TLB1",23,0 )
	4808	;
	4809	"RTN","IBJ TLB1",24,0 )
	4810	I 'IBBEG, 'IBEND S I BHMSG="** All Inacti ve Bills * *"
	4811	"RTN","IBJ TLB1",25,0 )
	4812	I $G(IBHM SG)="" S I BHMSG=IBBD T_" - "_IB EDT
	4813	"RTN","IBJ TLB1",26,0 )
	4814	S IBHMSG= IBHMSG_" ("_VALMCN T_")"
	4815	"RTN","IBJ TLB1",27,0 )
	4816	;
	4817	"RTN","IBJ TLB1",28,0 )
	4818	I VALMCNT =0 D SET(" ",0),SET( "No Inacti ve Bills f or this Pa tient",0)
	4819	"RTN","IBJ TLB1",29,0 )
	4820	;
	4821	"RTN","IBJ TLB1",30,0 )
	4822	Q
	4823	"RTN","IBJ TLB1",31,0 )
	4824	;
	4825	"RTN","IBJ TLB1",32,0 )
	4826	SCRN ; add bill to s creen list (IBIFN,DF N must be defined)
	4827	"RTN","IBJ TLB1",33,0 )
	4828	N X,IBY,I BD0,IBDU,I BDM,TYPE,R EJFLAG,IND FLG S X=""
	4829	"RTN","IBJ TLB1",34,0 )
	4830	S IBCNT=I BCNT+1,IBD 0=$G(^DGCR (399,+IBIF N,0)),IBDU =$G(^DGCR( 399,+IBIFN ,"U")),IBD
	4831	M=$G(^DGCR (399,+IBIF N,"M"))
	4832	"RTN","IBJ TLB1",35,0 )
	4833	S IBY=IBC NT,X=$$SET FLD^VALM1( IBY,X,"NUM BER")
	4834	"RTN","IBJ TLB1",36,0 )
	4835	; IB2.0 451 - get EEOB indic ator for b ill # when applicabl e
	4836	"RTN","IBJ TLB1",37,0 )
	4837	S IBPFLAG =$$EEOB^IB JTLA1(+IBI FN)
	4838	"RTN","IBJ TLB1",38,0 )
	4839	S REJFLAG =+$$BILLRE J^IBJTU6($ P(IBD0,U)) ;IB2.05 30 Add ind icator for rejects
	4840	"RTN","IBJ TLB1",39,0 )
	4841	S INDFLG= $S($G(IBPF LAG)'="":" %",1:"")_$ S(REJFLAG: "c",1:"") S:INDFLG=" " INDFLG="
	4842	"
	4843	"RTN","IBJ TLB1",40,0 )
	4844	S IBY=$P( IBD0,U,1)_ $$ECME^IBT RE(IBIFN), X=$$SETFLD ^VALM1(IBY ,X,"BILL")
	4845	"RTN","IBJ TLB1",41,0 )
	4846	S IBY=IND FLG_IBY,X= $$SETFLD^V ALM1(IBY,X ,"BILL")
	4847	"RTN","IBJ TLB1",42,0 )
	4848	S IBY=$S( $$REF^IBJT U31(+IBIFN ):"r",1:"" ),X=$$SETF LD^VALM1(I BY,X,"REFE R")
	4849	"RTN","IBJ TLB1",43,0 )
	4850	S IBY=$S( $$IB^IBRUT L(+IBIFN,0 ):"*",1:"" ),X=$$SETF LD^VALM1(I BY,X,"HD")
	4851	"RTN","IBJ TLB1",44,0 )
	4852	S IBY=$$D ATE($P(IBD U,U,1)),X= $$SETFLD^V ALM1(IBY,X ,"STFROM")
	4853	"RTN","IBJ TLB1",45,0 )
	4854	S IBY=$$D ATE($P(IBD U,U,2)),X= $$SETFLD^V ALM1(IBY,X ,"STTO")
	4855	"RTN","IBJ TLB1",46,0 )
	4856	;
	4857	"RTN","IBJ TLB1",47,0 )
	4858	;S IBY=$$ TYPE($P(IB D0,U,5))_$ $TF($P(IBD 0,U,6)),X= $$SETFLD^V ALM1(IBY,X ,"TYPE")
	4859	"RTN","IBJ TLB1",48,0 )
	4860	S TYPE=$$ TYPE($P(IB D0,U,5)) I $E(TYPE,2 )="P" S TY PE=$E(TYPE ) ; 516 - baa
	4861	"RTN","IBJ TLB1",49,0 )
	4862	;S IBY=TY PE_"/"_$S( $P(IBD0,U, 27)=1:"I", $P(IBD0,U, 27)=2:"P", 1:""),X=$$ SETFLD^VAL
	4863	M1(IBY,X," TYPE") ; 516 - baa
	4864	"RTN","IBJ TLB1",50,0 )
	4865	S IBY=TYP E_"/"_$S($ P(IBD0,U,2 7)=1:"I",$ P(IBD0,U,2 7)=2:"P",1 :" "),X=$$ SETFLD^VAL
	4866	M1(IBY,X," TYPE")
	4867	"RTN","IBJ TLB1",51,0 )
	4868	S IBTYP=$ $TYP^IBRFN (IBIFN)
	4869	"RTN","IBJ TLB1",52,0 )
	4870	S IBTYP=$ S(IBTYP="" :-1,IBTYP= "PR":"P",I BTYP="PH": "R",1:IBTY P)
	4871	"RTN","IBJ TLB1",53,0 )
	4872	S IBY=IBY _"/"_IBTYP ,X=$$SETFL D^VALM1(IB Y,X,"TYPE" )
	4873	"RTN","IBJ TLB1",54,0 )
	4874	S IBY=" " _$P($$ARST ATA^IBJTU4 (IBIFN),U, 2),X=$$SET FLD^VALM1( IBY,X,"ARS T")
	4875	"RTN","IBJ TLB1",55,0 )
	4876	;
	4877	"RTN","IBJ TLB1",56,0 )
	4878	S IBY=$P( $G(^DGCR(3 99.3,+$P(I BD0,U,7),0 )),U,4),X= $$SETFLD^V ALM1(IBY,X ,"RATE")
	4879	"RTN","IBJ TLB1",57,0 )
	4880	S IBY=$S( $$MINS^IBJ TU31(IBIFN ):"+",1:"" ),X=$$SETF LD^VALM1(I BY,X,"CB")
	4881	"RTN","IBJ TLB1",58,0 )
	4882	S IBY=+$G (^DGCR(399 ,+IBIFN,"M P"))
	4883	"RTN","IBJ TLB1",59,0 )
	4884	I 'IBY,$$ MCRWNR^IBE FUNC(+$$CU RR^IBCEF2( IBIFN)) S IBY=+$$CUR R^IBCEF2(I BIFN)
	4885	"RTN","IBJ TLB1",60,0 )
	4886	S IBY=$P( $G(^DIC(36 ,+IBY,0)), U,1),X=$$S ETFLD^VALM 1(IBY,X,"I NSUR")
	4887	"RTN","IBJ TLB1",61,0 )
	4888	S IBY=$$B ILL^RCJIBF N2(IBIFN)
	4889	"RTN","IBJ TLB1",62,0 )
	4890	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,1),8,2) ,X,"OAMT")
	4891	"RTN","IBJ TLB1",63,0 )
	4892	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,3),8,2) ,X,"CAMT")
	4893	"RTN","IBJ TLB1",64,0 )
	4894	D SET(X,I BCNT)
	4895	"RTN","IBJ TLB1",65,0 )
	4896	Q
	4897	"RTN","IBJ TLB1",66,0 )
	4898	;
	4899	"RTN","IBJ TLB1",67,0 )
	4900	DATE(X) ; date in ex ternal for mat
	4901	"RTN","IBJ TLB1",68,0 )
	4902	Q $E(X,4, 5)_"/"_$E( X,6,7)_"/" _$E(X,2,3)
	4903	"RTN","IBJ TLB1",69,0 )
	4904	;
	4905	"RTN","IBJ TLB1",70,0 )
	4906	TYPE(X) ; return abb reviated f orm of Bil l Classifi cation (39 9,.05)
	4907	"RTN","IBJ TLB1",71,0 )
	4908	; modifie d for 516 - baa
	4909	"RTN","IBJ TLB1",72,0 )
	4910	;Q $S(X=1 :"IP",X=2: "IH",X=3:" OP",X=4:"O H",1:"")
	4911	"RTN","IBJ TLB1",73,0 )
	4912	Q $S(X=1: "I",X=2:"I H",X=3:"O" ,X=4:"OH", 1:"")
	4913	"RTN","IBJ TLB1",74,0 )
	4914	;
	4915	"RTN","IBJ TLB1",75,0 )
	4916	TF(X) ; re turn abbre viated for m of Timef rame of Bi ll (399,.0 6)
	4917	"RTN","IBJ TLB1",76,0 )
	4918	Q $S(X=2: "-F",X=3:" -C",X=4:"- L",X'=1:"- O",1:"")
	4919	"RTN","IBJ TLB1",77,0 )
	4920	;
	4921	"RTN","IBJ TLB1",78,0 )
	4922	SET(X,CNT) ; set up list manag er screen array
	4923	"RTN","IBJ TLB1",79,0 )
	4924	S VALMCNT =VALMCNT+1
	4925	"RTN","IBJ TLB1",80,0 )
	4926	S ^TMP("I BJTLB",$J, VALMCNT,0) =X Q:'CNT
	4927	"RTN","IBJ TLB1",81,0 )
	4928	S ^TMP("I BJTLB",$J, "IDX",VALM CNT,+CNT)= ""
	4929	"RTN","IBJ TLB1",82,0 )
	4930	S ^TMP("I BJTLBX",$J ,CNT)=VALM CNT_U_IBIF N
	4931	"RTN","IBJ TLB1",83,0 )
	4932	Q
	4933	"RTN","IBT RE2")
	4934	0^3^B41201 696
	4935	"RTN","IBT RE2",1,0)
	4936	IBTRE2 ;AL B/AAS - CL AIMS TRACK ING - ACTI ONS ;27-JU N-93
	4937	"RTN","IBT RE2",2,0)
	4938	;;2.0;INT EGRATED BI LLING;23 ,121,249,3 12,315,568 ;21-MAR- 94;Build 2
	4939	"RTN","IBT RE2",3,0)
	4940	;;Per VA Directive 6402, this routine s hould not be modifie d.
	4941	"RTN","IBT RE2",4,0)
	4942	;
	4943	"RTN","IBT RE2",5,0)
	4944	% G EN^IBT RE
	4945	"RTN","IBT RE2",6,0)
	4946	;
	4947	"RTN","IBT RE2",7,0)
	4948	AT ; -- Ad d tracking entry
	4949	"RTN","IBT RE2",8,0)
	4950	I '$$PFSS WARN^IBBSH DWN() S VA LMBCK="R" Q ;IB2.031 2
	4951	"RTN","IBT RE2",9,0)
	4952	D FULL^VA LM1
	4953	"RTN","IBT RE2",10,0)
	4954	N X,Y,DIC ,DA,DR,DD, DO,DIR,DIR UT,DTOUT,D UOUT,IBETY P,IBQUIT,I BTDT,VAIN, VAINDT,IBT
	4955	RN,IBTDTE
	4956	"RTN","IBT RE2",11,0)
	4957	;
	4958	"RTN","IBT RE2",12,0)
	4959	TEST S IBQ UIT=0
	4960	"RTN","IBT RE2",13,0)
	4961	S DIC(0)= "AEQMNZ",D IC="^IBE(3 56.6,",DIC ("S")="I $ P(^(0),U,3 )<3!($P(^( 0),U,3)=4)
	4962	",DIC("A") ="Select T racking Ty pe: " ;56 8
	4963	"RTN","IBT RE2",14,0)
	4964	D ^DIC K DIC S IBET YP=+Y I +Y <0 G ATQ
	4965	"RTN","IBT RE2",15,0)
	4966	W !
	4967	"RTN","IBT RE2",16,0)
	4968	;
	4969	"RTN","IBT RE2",17,0)
	4970	ADM I IBET YP=$O(^IBE (356.6,"AC ",1,0)) D I IBQUIT G ATQ
	4971	"RTN","IBT RE2",18,0)
	4972	.N DIR
	4973	"RTN","IBT RE2",19,0)
	4974	.S DIR("? ")=" "
	4975	"RTN","IBT RE2",20,0)
	4976	.S DIR("? ",1)=" Enter any Date!"
	4977	"RTN","IBT RE2",21,0)
	4978	.S DIR("? ",2)=" "
	4979	"RTN","IBT RE2",22,0)
	4980	.S DIR("? ",3)=" If the pat ient was a n inpatien t on that date the s ystem will
	4981	use the"
	4982	"RTN","IBT RE2",23,0)
	4983	.S DIR("? ",4)=" correct ad mission da te. If yo u are trac king an ad missions a
	4984	t another"
	4985	"RTN","IBT RE2",24,0)
	4986	.S DIR("? ",5)=" facility y ou may ent er that da te. Enter '??' to g et a list
	4987	of the"
	4988	"RTN","IBT RE2",25,0)
	4989	.S DIR("? ",6)=" last 10 ad missions f or this pa tient."
	4990	"RTN","IBT RE2",26,0)
	4991	.S DIR("? ?")="^D LI STA^IBTRE2 0"
	4992	"RTN","IBT RE2",27,0)
	4993	.S DIR(0) ="DO^::AEX TP",DIR("A ")="Admiss ion Date"
	4994	"RTN","IBT RE2",28,0)
	4995	.D ^DIR K DIR S (IB TDT,VAINDT )=+Y I $P( VAINDT,"." ,2)="" S V AINDT=VAIN DT+.24
	4996	"RTN","IBT RE2",29,0)
	4997	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	4998	"RTN","IBT RE2",30,0)
	4999	.; -- che ck for val id admissi on
	5000	"RTN","IBT RE2",31,0)
	5001	.S VA200= "" D INP^V ADPT I VAI N(1)="" D ;look for one day a dmission
	5002	"RTN","IBT RE2",32,0)
	5003	..S IBX=+ $O(^(+$O(^ DGPM("ATID 1",DFN,999 9999-IBTDT )),0)),IBX =+$G(^DGPM (IBX,0))
	5004	"RTN","IBT RE2",33,0)
	5005	..I $E(IB X,1,7)=IBT DT S VAIND T=IBX D IN P^VADPT ;9 999999.999 9999
	5006	"RTN","IBT RE2",34,0)
	5007	..I VAIN( 1) W !!,"W ARNING: Th is appears to be a o ne day sta y."
	5008	"RTN","IBT RE2",35,0)
	5009	.I VAIN(1 )="" D
	5010	"RTN","IBT RE2",36,0)
	5011	..W !!,*7 ,"WARNING: Patient d oes not ap pear to be an inpati ent on thi s date!",!
	5012	"RTN","IBT RE2",37,0)
	5013	..I VAIN( 7)="" S VA IN(7)=IBTD T,Y=IBTDT D D^DIQ S $P(VAIN(7) ,"^",2)=Y
	5014	"RTN","IBT RE2",38,0)
	5015	.;
	5016	"RTN","IBT RE2",39,0)
	5017	.S DIR("? ")="No adm ission was found for this date , enter 'Y es' if you want to a
	5018	dd this an yway, or ' No' if you do not wi sh to trac k this dat e."
	5019	"RTN","IBT RE2",40,0)
	5020	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Admissi on Date "_
	5021	$P(VAIN(7) ,"^",2),DI R("B")="NO "
	5022	"RTN","IBT RE2",41,0)
	5023	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	5024	"RTN","IBT RE2",42,0)
	5025	.I VAIN(1 ) D ADM^IB TUTL(VAIN( 1))
	5026	"RTN","IBT RE2",43,0)
	5027	.I 'VAIN( 1) D OTH^I BTUTL(DFN, IBETYP,IBT DT)
	5028	"RTN","IBT RE2",44,0)
	5029	.Q
	5030	"RTN","IBT RE2",45,0)
	5031	;
	5032	"RTN","IBT RE2",46,0)
	5033	OPT I IBET YP=$O(^IBE (356.6,"AC ",2,0)) D I IBQUIT G ATQ
	5034	"RTN","IBT RE2",47,0)
	5035	.;
	5036	"RTN","IBT RE2",48,0)
	5037	.N DIR,IB SD,IBARRAY
	5038	"RTN","IBT RE2",49,0)
	5039	.;get all possible scheduling data for patient
	5040	"RTN","IBT RE2",50,0)
	5041	.K ^TMP($ J,"SDAMA30 1")
	5042	"RTN","IBT RE2",51,0)
	5043	.S IBARRA Y(4)=DFN,I BARRAY("SO RT")="P",I BARRAY("FL DS")="1;2; 3;10;12",I BSD=$$SDAP
	5044	I^SDAMA301 (.IBARRAY)
	5045	"RTN","IBT RE2",52,0)
	5046	.;
	5047	"RTN","IBT RE2",53,0)
	5048	.S DIR("? ")="Time i s Required ."
	5049	"RTN","IBT RE2",54,0)
	5050	.S DIR("? ",1)=" Enter the Outpatient Visit Dat e."
	5051	"RTN","IBT RE2",55,0)
	5052	.S DIR("? ",2)=" If no sche duled visi t is found you will be given a warning.
	5053	Enter"
	5054	"RTN","IBT RE2",56,0)
	5055	.S DIR("? ",3)=" '??' to ge t a list o f schedule d visits b etween "_$ $DAT1^IBOU
	5056	TL(IBTBDT) _" and "_$ $DAT1^IBOU TL(IBTEDT) _"."
	5057	"RTN","IBT RE2",57,0)
	5058	.I '$D(IB TASS) S DI R("?",4)=" Use th e change d ate range action to change lis
	5059	ting of sc heduled Vi sits."
	5060	"RTN","IBT RE2",58,0)
	5061	.S DIR("? ?")="^D LI STO^IBTRE2 0"
	5062	"RTN","IBT RE2",59,0)
	5063	.S DIR(0) ="DO^::AEX TP",DIR("A ")="Outpat ient Visit Date"
	5064	"RTN","IBT RE2",60,0)
	5065	.D ^DIR K DIR S IBT DT=Y
	5066	"RTN","IBT RE2",61,0)
	5067	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	5068	"RTN","IBT RE2",62,0)
	5069	.;
	5070	"RTN","IBT RE2",63,0)
	5071	.; check scheduling and encou nters file for entri es
	5072	"RTN","IBT RE2",64,0)
	5073	.S X=$D(^ TMP($J,"SD AMA301",DF N,IBTDT))
	5074	"RTN","IBT RE2",65,0)
	5075	.;
	5076	"RTN","IBT RE2",66,0)
	5077	.I 'X,IBS D<0 W !!,* 7,"WARNING : Unable t o look up Visit info rmation fo r this Pat
	5078	ient" X "N IBX S IBX =0 F S IB X=$O(^TMP( $J,""SDAMA 301"",IBX) ) W !?5,IB X,?10,$G(^
	5079	(IBX))"
	5080	"RTN","IBT RE2",67,0)
	5081	.;
	5082	"RTN","IBT RE2",68,0)
	5083	.I 'X,IBS D S Y=$O(^ TMP($J,"SD AMA301",DF N,$P(IBTDT ,"."))) I $P(IBTDT," .")=$P(Y,"
	5084	.") S IBTD T=Y,X=1
	5085	"RTN","IBT RE2",69,0)
	5086	.;
	5087	"RTN","IBT RE2",70,0)
	5088	.; if non say so
	5089	"RTN","IBT RE2",71,0)
	5090	.I 'X,IBS D'=-1 W !! ,*7,"WARNI NG: No Vis it informa tion for t his Patien t for this
	5091	date.",!
	5092	"RTN","IBT RE2",72,0)
	5093	.;
	5094	"RTN","IBT RE2",73,0)
	5095	.; ask if okay to a dd entry.
	5096	"RTN","IBT RE2",74,0)
	5097	.S Y=IBTD T D D^DIQ S IBTDTE=Y
	5098	"RTN","IBT RE2",75,0)
	5099	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Visit D ate "_IBTD
	5100	TE,DIR("B" )="NO"
	5101	"RTN","IBT RE2",76,0)
	5102	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	5103	"RTN","IBT RE2",77,0)
	5104	.D OPT^IB TUTL1(DFN, IBETYP,IBT DT,$P($G(^ TMP($J,"SD AMA301",DF N,IBTDT)), "^",12))
	5105	"RTN","IBT RE2",78,0)
	5106	.K ^TMP($ J,"SDAMA30 1")
	5107	"RTN","IBT RE2",79,0)
	5108	.Q
	5109	"RTN","IBT RE2",80,0)
	5110	;
	5111	"RTN","IBT RE2",81,0)
	5112	SCH I IBET YP=$O(^IBE (356.6,"AC ",5,0)) D I IBQUIT G ATQ
	5113	"RTN","IBT RE2",82,0)
	5114	.N DIR
	5115	"RTN","IBT RE2",83,0)
	5116	.S DIR("? ")=" "
	5117	"RTN","IBT RE2",84,0)
	5118	.S DIR("? ",1)=" Enter date of the sc heduled ad mission."
	5119	"RTN","IBT RE2",85,0)
	5120	.S DIR("? ",2)=" If you use the sched uled admis sion packa ge to sche dule admis
	5121	sions"
	5122	"RTN","IBT RE2",86,0)
	5123	.S DIR("? ",3)=" you may en ter '??' t o get a li st of sche duled admi ssions bet
	5124	ween"
	5125	"RTN","IBT RE2",87,0)
	5126	.S DIR("? ",4)=" "_$$DAT1^I BOUTL(IBTB DT)_" and "_$$DAT1^I BOUTL(IBTE DT)_". Us
	5127	e the chan ge date ra nge action "
	5128	"RTN","IBT RE2",88,0)
	5129	.S DIR("? ",5)=" to change listing of scheduled admission s."
	5130	"RTN","IBT RE2",89,0)
	5131	.S DIR("? ",5)=" This shoul d be a fut ure schedu led admiss ion."
	5132	"RTN","IBT RE2",90,0)
	5133	.S DIR(0) ="DO^::AEX T",DIR("A" )="Schedul ed Admissi on Date"
	5134	"RTN","IBT RE2",91,0)
	5135	.S DIR("? ?")="^D LI STS^IBTRE2 0"
	5136	"RTN","IBT RE2",92,0)
	5137	.D ^DIR K DIR S IBT DT=+Y
	5138	"RTN","IBT RE2",93,0)
	5139	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	5140	"RTN","IBT RE2",94,0)
	5141	.; ask if okay to a dd entry.
	5142	"RTN","IBT RE2",95,0)
	5143	.D FINDS^ IBTRE20
	5144	"RTN","IBT RE2",96,0)
	5145	.S Y=IBTD T D D^DIQ S IBTDTE=Y
	5146	"RTN","IBT RE2",97,0)
	5147	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Schedul ed Adm. Da
	5148	te "_IBTDT E,DIR("B") ="NO"
	5149	"RTN","IBT RE2",98,0)
	5150	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	5151	"RTN","IBT RE2",99,0)
	5152	.I IBTDT\ 1'>DT S VA INDT=IBTDT \1+.24 D I NP^VADPT I $G(VAIN(1 )) D Q
	5153	"RTN","IBT RE2",100,0 )
	5154	..W !!,"P atient an inpatient on this da te, using inpatient admission. "
	5155	"RTN","IBT RE2",101,0 )
	5156	..D ADM^I BTUTL(VAIN (1))
	5157	"RTN","IBT RE2",102,0 )
	5158	.D SCH^IB TUTL2(DFN, IBTDT)
	5159	"RTN","IBT RE2",103,0 )
	5160	.Q
	5161	"RTN","IBT RE2",104,0 )
	5162	;
	5163	"RTN","IBT RE2",105,0 )
	5164	PRO I IBET YP=$O(^IBE (356.6,"AC ",3,0)) D I IBQUIT G ATQ
	5165	"RTN","IBT RE2",106,0 )
	5166	.;
	5167	"RTN","IBT RE2",107,0 )
	5168	.N DIR,IB SD,IBARRAY ,C
	5169	"RTN","IBT RE2",108,0 )
	5170	.;get all possible scheduling data for patient
	5171	"RTN","IBT RE2",109,0 )
	5172	.S IBARRA Y(0)=DFN
	5173	"RTN","IBT RE2",110,0 )
	5174	.;
	5175	"RTN","IBT RE2",111,0 )
	5176	.D LISTP^ IBTRE20
	5177	"RTN","IBT RE2",112,0 )
	5178	.W !
	5179	"RTN","IBT RE2",113,0 )
	5180	.I C=0 S IBQUIT=1 Q
	5181	"RTN","IBT RE2",114,0 )
	5182	.S DIR("? ")="Prosth etics"
	5183	"RTN","IBT RE2",115,0 )
	5184	.S DIR(0) ="N",DIR(" A")="Prost hetics Ent ry"
	5185	"RTN","IBT RE2",116,0 )
	5186	.D ^DIR K DIR
	5187	"RTN","IBT RE2",117,0 )
	5188	.I $D(DIR UT) S IBQU IT=1 Q
	5189	"RTN","IBT RE2",118,0 )
	5190	.I Y>0 S RC=IBARRAY (Y),IBDEL= $P(RC,U,3) ,IBPRO=$P( RC,U,4),PI EN=$P(RC,U ,1),IBPR=$
	5191	P(RC,U,2), IBDELO=$P( RC,U,5)
	5192	"RTN","IBT RE2",119,0 )
	5193	.;
	5194	"RTN","IBT RE2",120,0 )
	5195	.; ask if okay to a dd entry.
	5196	"RTN","IBT RE2",121,0 )
	5197	.S Y=IBDE L D D^DIQ S IBTDTE=Y
	5198	"RTN","IBT RE2",122,0 )
	5199	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Prosthe tics "_IBP
	5200	RO_" for " _IBDELO,DI R("B")="NO "
	5201	"RTN","IBT RE2",123,0 )
	5202	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	5203	"RTN","IBT RE2",124,0 )
	5204	.S PCOV=$ $PTCOV^IBC NSU3(DFN,I BDEL,"PROS THETICS")
	5205	"RTN","IBT RE2",125,0 )
	5206	.S IBMARK ="" I 'PCO V S IBMARK ="NO PROST HETIC COVE RAGE"
	5207	"RTN","IBT RE2",126,0 )
	5208	.D PRO^IB TUTL1(DFN, IBDEL,PIEN ,IBMARK)
	5209	"RTN","IBT RE2",127,0 )
	5210	.Q
	5211	"RTN","IBT RE2",128,0 )
	5212	;
	5213	"RTN","IBT RE2",129,0 )
	5214	I $G(IBQU IT) G ATQ
	5215	"RTN","IBT RE2",130,0 )
	5216	I $D(IBTA SS) Q ; l eave prema turely if from assig n reason
	5217	"RTN","IBT RE2",131,0 )
	5218	;
	5219	"RTN","IBT RE2",132,0 )
	5220	I $G(IBTR N) N IBTAT RK S IBTAT RK=1 D QE1 ^IBTRE1
	5221	"RTN","IBT RE2",133,0 )
	5222	;
	5223	"RTN","IBT RE2",134,0 )
	5224	D BLD^IBT RE
	5225	"RTN","IBT RE2",135,0 )
	5226	;
	5227	"RTN","IBT RE2",136,0 )
	5228	ATQ Q:$D(I BTASS)
	5229	"RTN","IBT RE2",137,0 )
	5230	I $G(IBQU IT) W !,"N othing Add ed",! D PA USE^VALM1
	5231	"RTN","IBT RE2",138,0 )
	5232	S VALMBCK ="R"
	5233	"RTN","IBT RE2",139,0 )
	5234	Q
	5235	"RTN","IBT RE20")
	5236	0^4^B20248 565
	5237	"RTN","IBT RE20",1,0)
	5238	IBTRE20 ;A LB/AAS - C LAIMS TRAC KING EXECU TABLE HELP ;13-OCT-9 3
	5239	"RTN","IBT RE20",2,0)
	5240	;;2.0;INT EGRATED BI LLING;40 ,91,249; 21-MAR-94; Build 2
	5241	"RTN","IBT RE20",3,0)
	5242	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
	5243	"RTN","IBT RE20",4,0)
	5244	;
	5245	"RTN","IBT RE20",5,0)
	5246	;
	5247	"RTN","IBT RE20",6,0)
	5248	LISTA ; -- list inpa tient admi ssions for patient
	5249	"RTN","IBT RE20",7,0)
	5250	N C,I,J,N ,X,Y,IBX
	5251	"RTN","IBT RE20",8,0)
	5252	K ^TMP("I BM",$J)
	5253	"RTN","IBT RE20",9,0)
	5254	Q:'$D(DFN )
	5255	"RTN","IBT RE20",10,0 )
	5256	S C=0 F I =0:0 S I=$ O(^DGPM("A TID1",DFN, I)) Q:'I S N=$O(^(I ,0)) I $D( ^DGPM(+N,0
	5257	)) S D=^(0 ),C=C+1,^T MP("IBM",$ J,C)=N_"^" _D
	5258	"RTN","IBT RE20",11,0 )
	5259	;
	5260	"RTN","IBT RE20",12,0 )
	5261	I C=0 W ! !,"No Admi ssions to Choose Fro m." Q
	5262	"RTN","IBT RE20",13,0 )
	5263	;
	5264	"RTN","IBT RE20",14,0 )
	5265	W !!,"CHO OSE FROM:" F IBI=1:1 :10 Q:'$D( ^TMP("IBM" ,$J,IBI)) D WRA
	5266	"RTN","IBT RE20",15,0 )
	5267	K ^TMP("I BM",$J)
	5268	"RTN","IBT RE20",16,0 )
	5269	Q
	5270	"RTN","IBT RE20",17,0 )
	5271	;
	5272	"RTN","IBT RE20",18,0 )
	5273	WRA S IBX= $P(^TMP("I BM",$J,IBI ),"^",2,20 ),Y=+IBX X ^DD("DD")
	5274	"RTN","IBT RE20",19,0 )
	5275	W !," ",Y
	5276	"RTN","IBT RE20",20,0 )
	5277	W ?27,$S( '$D(^DG(40 5.1,+$P(IB X,"^",4),0 )):"",$P(^ (0),"^",7) ]"":$P(^(0 ),"^",7),1
	5278	:$E($P(^(0 ),"^",1),1 ,20))
	5279	"RTN","IBT RE20",21,0 )
	5280	;
	5281	"RTN","IBT RE20",22,0 )
	5282	W ?50,"TO : ",$E($P ($G(^DIC(4 2,+$P(IBX, "^",6),0)) ,"^"),1,17 )
	5283	"RTN","IBT RE20",23,0 )
	5284	I $D(^DG( 405.4,+$P( IBX,"^",7) ,0)) W " [ ",$E($P(^( 0),"^",1), 1,10),"]"
	5285	"RTN","IBT RE20",24,0 )
	5286	I $P(IBX, "^",18)=9 W !?23,"FR OM: ",$P( $G(^DIC(4, +$P(IBX,"^ ",5),0))," ^")
	5287	"RTN","IBT RE20",25,0 )
	5288	Q
	5289	"RTN","IBT RE20",26,0 )
	5290	;
	5291	"RTN","IBT RE20",27,0 )
	5292	LISTO ; -- list outp atient app ointments
	5293	"RTN","IBT RE20",28,0 )
	5294	N C,I,J,N ,X,Y,IBX,I BI,IBDT
	5295	"RTN","IBT RE20",29,0 )
	5296	; assumes ^TMP($J," SDAMA301", DFN,IBTDT) defined a nd IBSD(re sult from SD)
	5297	"RTN","IBT RE20",30,0 )
	5298	Q:'$D(DFN )
	5299	"RTN","IBT RE20",31,0 )
	5300	;
	5301	"RTN","IBT RE20",32,0 )
	5302	I IBSD<0 W !!,"Unab le to look -up Outpat ient Visit s to Choos e From." D Q
	5303	"RTN","IBT RE20",33,0 )
	5304	. N IBX F S IBX=$O (^TMP($J," SDAMA301", IBX)) Q:'I BX W !?5, IBX,?10,$G (^(IBX))
	5305	"RTN","IBT RE20",34,0 )
	5306	;
	5307	"RTN","IBT RE20",35,0 )
	5308	I IBSD=0 W !!,"No O utpatient Visits to Choose Fro m." Q
	5309	"RTN","IBT RE20",36,0 )
	5310	;
	5311	"RTN","IBT RE20",37,0 )
	5312	W !!,"CHO OSE FROM:" S IBI=0,I BDT=$G(IBT BDT) F S IBDT=$O(^T MP($J,"SDA MA301",DFN
	5313	,IBDT)),IB I=IBI+1 Q: 'IBDT!(IBI >12) D WR O
	5314	"RTN","IBT RE20",38,0 )
	5315	Q
	5316	"RTN","IBT RE20",39,0 )
	5317	;
	5318	"RTN","IBT RE20",40,0 )
	5319	WRO N IBSD D,Y
	5320	"RTN","IBT RE20",41,0 )
	5321	S Y=IBDT X ^DD("DD" ) W !," ",Y
	5322	"RTN","IBT RE20",42,0 )
	5323	S IBSDD=$ G(^TMP($J, "SDAMA301" ,DFN,IBDT) )
	5324	"RTN","IBT RE20",43,0 )
	5325	W ?27,"Cl inic: ",$P ($P(IBSDD, "^",2),";" ,2),?60," Type: ",$E ($P($P(IBS DD,"^",10)
	5326	,";",2),1, 12)
	5327	"RTN","IBT RE20",44,0 )
	5328	;
	5329	"RTN","IBT RE20",45,0 )
	5330	S IBSDD=$ P(IBSDD,"^ ",3) I $L( IBSDD),$P( IBSDD,";") '="R" W !, ?10," [Sta tus: ",$P(
	5331	IBSDD,";", 2),"]"
	5332	"RTN","IBT RE20",46,0 )
	5333	Q
	5334	"RTN","IBT RE20",47,0 )
	5335	;
	5336	"RTN","IBT RE20",48,0 )
	5337	LISTS ; -- list sche duled admi ssions
	5338	"RTN","IBT RE20",49,0 )
	5339	N C,I,J,N ,X,Y,IBX,I BI
	5340	"RTN","IBT RE20",50,0 )
	5341	K ^TMP("I BM",$J)
	5342	"RTN","IBT RE20",51,0 )
	5343	Q:'$D(DFN )
	5344	"RTN","IBT RE20",52,0 )
	5345	S C=0 F I =0:0 S I=$ O(^DGS(41. 1,"B",DFN, I)) Q:'I I $D(^DGS( 41.1,+I,0) ) S D=$G(^
	5346	DGS(41.1,+ I,0)) I $P (D,"^",2)' <IBTBDT,$P (D,"^",2)' >IBTEDT S C=C+1,^TMP ("IBM",$J,
	5347	C)=I_"^"_D
	5348	"RTN","IBT RE20",53,0 )
	5349	;
	5350	"RTN","IBT RE20",54,0 )
	5351	I C=0 W ! !,"No Sche duled Admi ssions to Choose Fro m." Q
	5352	"RTN","IBT RE20",55,0 )
	5353	;
	5354	"RTN","IBT RE20",56,0 )
	5355	W !!,"CHO OSE FROM:" F IBI=1:1 :12 Q:'$D( ^TMP("IBM" ,$J,IBI)) D WRS
	5356	"RTN","IBT RE20",57,0 )
	5357	K ^TMP("I BM",$J)
	5358	"RTN","IBT RE20",58,0 )
	5359	Q
	5360	"RTN","IBT RE20",59,0 )
	5361	;
	5362	"RTN","IBT RE20",60,0 )
	5363	WRS S IBX= $P($G(^TMP ("IBM",$J, IBI)),"^", 2,20),Y=$P (IBX,"^",2 ) X ^DD("D D")
	5364	"RTN","IBT RE20",61,0 )
	5365	W !," ",Y
	5366	"RTN","IBT RE20",62,0 )
	5367	W ?27," S pec: ",$E( $P($G(^DIC (45.7,+$P( IBX,"^",9) ,0)),"^"), 1,25)
	5368	"RTN","IBT RE20",63,0 )
	5369	;
	5370	"RTN","IBT RE20",64,0 )
	5371	W ?58," T o: ",$E($P ($G(^DIC(4 2,+$P(IBX, "^",8),0)) ,"^"),1,16 )
	5372	"RTN","IBT RE20",65,0 )
	5373	Q
	5374	"RTN","IBT RE20",66,0 )
	5375	;
	5376	"RTN","IBT RE20",67,0 )
	5377	FINDS ; -- match a s cheduled a dmission
	5378	"RTN","IBT RE20",68,0 )
	5379	Q:'$D(DFN )
	5380	"RTN","IBT RE20",69,0 )
	5381	Q:'$D(IBT DT)
	5382	"RTN","IBT RE20",70,0 )
	5383	N I,J
	5384	"RTN","IBT RE20",71,0 )
	5385	S I=0 F S I=$O(^DG S(41.1,"B" ,DFN,I)) Q :'I S J=$ P($G(^DGS( 41.1,I,0)) ,"^",2) Q:
	5386	IBTDT=J I $P(IBTDT, ".")=$P(J, ".") S IBT DT=J Q
	5387	"RTN","IBT RE20",72,0 )
	5388	Q
	5389	"RTN","IBT RE20",73,0 )
	5390	;
	5391	"RTN","IBT RE20",74,0 )
	5392	ID ; -- wr ite out id entifier f or entry, called by ^dd(356,0, "id","writ e")
	5393	"RTN","IBT RE20",75,0 )
	5394	N IBOE,IB OE0
	5395	"RTN","IBT RE20",76,0 )
	5396	S IBOE=$P (^(0),"^", 4),IBOE0=$ $SCE^IBSDU (+IBOE) I IBOE,$P(IB OE0,U,4) W ?58,"["_$
	5397	E($P($G(^S C(+$P(IBOE 0,U,4),0)) ,U),1,20), "]"
	5398	"RTN","IBT RE20",77,0 )
	5399	Q
	5400	"RTN","IBT RE20",78,0 )
	5401	;
	5402	"RTN","IBT RE20",79,0 )
	5403	PRINT ; pa tch 40, cu stom look up. Input : IBX -- 0th node in file # 356.
	5404	"RTN","IBT RE20",80,0 )
	5405	Q:$D(IBX) [0
	5406	"RTN","IBT RE20",81,0 )
	5407	N NAM,EPI S,EVENT,DI SPL,CLIN
	5408	"RTN","IBT RE20",82,0 )
	5409	S NAM=$E( $P($G(^DPT (+$P(IBX,U ,2),0)),U) ,1,22)
	5410	"RTN","IBT RE20",83,0 )
	5411	S EPIS=$P ($P(IBX,U, 6),".")
	5412	"RTN","IBT RE20",84,0 )
	5413	I EPIS S EPIS=$E(EP IS,4,5)_"- "_$E(EPIS, 6,7)_"-"_$ E(EPIS,2,3 )
	5414	"RTN","IBT RE20",85,0 )
	5415	S EVENT=$ E($P($G(^I BE(356.6,+ $P(IBX,U,1 8),0)),U), 1,5)
	5416	"RTN","IBT RE20",86,0 )
	5417	S DISPL=$ $EXPAND^IB TRE(356,.0 7,$P(IBX,U ,7))
	5418	"RTN","IBT RE20",87,0 )
	5419	S CLIN=+$ $SCE^IBSDU (+$P(IBX," ^",4),4)
	5420	"RTN","IBT RE20",88,0 )
	5421	I CLIN S DISPL="["_ $E($P($G(^ SC(CLIN,0) ),U),1,22) _"]"
	5422	"RTN","IBT RE20",89,0 )
	5423	W ?13,NAM ,?37,EPIS, ?47,EVENT, ?54,DISPL
	5424	"RTN","IBT RE20",90,0 )
	5425	Q
	5426	"RTN","IBT RE20",91,0 )
	5427	;
	5428	"RTN","IBT RE20",92,0 )
	5429	LISTP ; -- list inpa tient admi ssions for patient
	5430	"RTN","IBT RE20",93,0 )
	5431	N I,X,Y,P ,P1,P2,DDT ,DDTO,IBX
	5432	"RTN","IBT RE20",94,0 )
	5433	K ^TMP("I BPRO",$J)
	5434	"RTN","IBT RE20",95,0 )
	5435	Q:'$D(DFN )
	5436	"RTN","IBT RE20",96,0 )
	5437	S (I,C)=0
	5438	"RTN","IBT RE20",97,0 )
	5439	F S I=$O (^RMPR(660 ,"C",DFN,I )) Q:'I I $D(^RMPR( 660,I,0)) S D=^(0) D
	5440	"RTN","IBT RE20",98,0 )
	5441	.S SDT=$P (D,U,12) I SDT<IBTBD T!(SDT>IBT EDT) Q
	5442	"RTN","IBT RE20",99,0 )
	5443	.I $O(^IB T(356,"APR O",I,0)) Q
	5444	"RTN","IBT RE20",100, 0)
	5445	.S C=C+1, ^TMP("IBPR O",$J,C)=I _"^"_D
	5446	"RTN","IBT RE20",101, 0)
	5447	;
	5448	"RTN","IBT RE20",102, 0)
	5449	I C=0 W ! !,"No Pros thetics to Choose Fr om." Q
	5450	"RTN","IBT RE20",103, 0)
	5451	;
	5452	"RTN","IBT RE20",104, 0)
	5453	W !!,"CHO OSE FROM:" F IBI=1:1 :10 Q:'$D( ^TMP("IBPR O",$J,IBI) ) D WRP
	5454	"RTN","IBT RE20",105, 0)
	5455	K ^TMP("I BPRO",$J)
	5456	"RTN","IBT RE20",106, 0)
	5457	Q
	5458	"RTN","IBT RE20",107, 0)
	5459	;
	5460	"RTN","IBT RE20",108, 0)
	5461	WRP S IBX= $P(^TMP("I BPRO",$J,I BI),"^",1, 20),N=$P(I BX,U,1),P= $P(IBX,U,7 ),P1=$P(^R
	5462	MPR(661,P, 0),U,1),P2 =$P(^PRC(4 41,P1,0),U ,2)
	5463	"RTN","IBT RE20",109, 0)
	5464	S DDT=$P( IBX,U,13), DDTO=$$FMT E^XLFDT(DD T,"2DZ"),I BARRAY(IBI )=N_U_P_U_ DDT_U_P2_U
	5465	_DDTO
	5466	"RTN","IBT RE20",110, 0)
	5467	S TP=$P(I BX,U,4),TY PE=$S(TP=" I":"INITIA L ISSUE",T P="R":"REP LACE",TP=" S":"SPARE"
	5468	,TP="X":"R EPAIR",1:" RENTAL")
	5469	"RTN","IBT RE20",111, 0)
	5470	W !," ", IBI,?10,$E (P2,1,25), ?40,TYPE,? 58,"DELIVE RED:",DDTO
	5471	"RTN","IBT RE20",112, 0)
	5472	;
	5473	"RTN","IBT RE20",113, 0)
	5474	Q
	5475	"RTN","IBT RKR5")
	5476	0^5^B39052 603
	5477	"RTN","IBT RKR5",1,0)
	5478	IBTRKR5 ;A LB/AAS - C LAIMS TRAC KING - ADD /TRACK PRO STHETICS ; 13-JAN-94
	5479	"RTN","IBT RKR5",2,0)
	5480	;;2.0;INT EGRATED BI LLING;13 ,260,312,3 39,389,474 ,498,568 ;21-MAR-94 ;Build 2
	5481	"RTN","IBT RKR5",3,0)
	5482	;;Per VA Directive 6402, this routine s hould not be modifie d.
	5483	"RTN","IBT RKR5",4,0)
	5484	;
	5485	"RTN","IBT RKR5",5,0)
	5486	% ; -- ent ry point f or nightly backgroun d job
	5487	"RTN","IBT RKR5",6,0)
	5488	N IBTSBDT ,IBTSEDT
	5489	"RTN","IBT RKR5",7,0)
	5490	S IBTSBDT =$$FMADD^X LFDT(DT,$S ($E(DT,6,7 )=10:-730, 1:-20))-.1 ;IB2.0 568
	5491	"RTN","IBT RKR5",8,0)
	5492	S IBTSEDT =$$FMADD^X LFDT(DT,-3 )+.9
	5493	"RTN","IBT RKR5",9,0)
	5494	D EN1
	5495	"RTN","IBT RKR5",10,0 )
	5496	Q
	5497	"RTN","IBT RKR5",11,0 )
	5498	;
	5499	"RTN","IBT RKR5",12,0 )
	5500	EN ; -- en try point to ask dat e range
	5501	"RTN","IBT RKR5",13,0 )
	5502	N IBSWINF O S IBSWIN FO=$$SWSTA T^IBBAPI() ; IB2.0312
	5503	"RTN","IBT RKR5",14,0 )
	5504	N IBBDT,I BEDT,IBTSB DT,IBTSEDT ,IBTALK
	5505	"RTN","IBT RKR5",15,0 )
	5506	S IBTALK= 1
	5507	"RTN","IBT RKR5",16,0 )
	5508	I '$P($G( ^IBE(350.9 ,1,6)),"^" ,4) W !!," I'm sorry, Tracking of Prosthe tics is cu
	5509	rrently tu rned off." G ENQ
	5510	"RTN","IBT RKR5",17,0 )
	5511	W !!!,"Se lect the D ate Range of Prosthe tics to Ad d to Claim s Tracking .",!
	5512	"RTN","IBT RKR5",18,0 )
	5513	D DATE^IB OUTL
	5514	"RTN","IBT RKR5",19,0 )
	5515	I IBBDT<1 !(IBEDT<1) G ENQ
	5516	"RTN","IBT RKR5",20,0 )
	5517	S IBTSBDT =IBBDT,IBT SEDT=IBEDT
	5518	"RTN","IBT RKR5",21,0 )
	5519	;
	5520	"RTN","IBT RKR5",22,0 )
	5521	; -- chec k selected dates ; IB2.0312
	5522	"RTN","IBT RKR5",23,0 )
	5523	; Do NOT PROCESS on VistA if Start or E nd>=Switch Eff Dt ; CCR-930
	5524	"RTN","IBT RKR5",24,0 )
	5525	I +IBSWIN FO,((IBTSB DT+1)>$P(I BSWINFO,"^ ",2))!((IB TSEDT+1)>$ P(IBSWINFO ,"^",2)) D
	5526	G EN
	5527	"RTN","IBT RKR5",25,0 )
	5528	.W !!,"T he Begin O R End Date CANNOT be on or aft er the PFS S Effectiv e date"
	5529	"RTN","IBT RKR5",26,0 )
	5530	.W ": ", $$FMTE^XLF DT($P(IBSW INFO,"^",2 ))
	5531	"RTN","IBT RKR5",27,0 )
	5532	;
	5533	"RTN","IBT RKR5",28,0 )
	5534	S IBTRKR= $G(^IBE(35 0.9,1,6))
	5535	"RTN","IBT RKR5",29,0 )
	5536	; start d ate can't be before parameters
	5537	"RTN","IBT RKR5",30,0 )
	5538	I +IBTRKR ,IBTSBDT<+ IBTRKR S I BTSBDT=IBT RKR W !!," Begin date is before Claims Tr
	5539	acking Sta rt Date, c hanged to ",$$DAT1^I BOUTL(IBTS BDT)
	5540	"RTN","IBT RKR5",31,0 )
	5541	; -- end date into future
	5542	"RTN","IBT RKR5",32,0 )
	5543	I IBTSEDT >$$FMADD^X LFDT(DT,-3 ) W !!,"I' ll automat ically cha nge the en d date to
	5544	3 days pri or to the date queue d to run."
	5545	"RTN","IBT RKR5",33,0 )
	5546	;
	5547	"RTN","IBT RKR5",34,0 )
	5548	W !!,"Thi s should b e queued t o run afte r hours"
	5549	"RTN","IBT RKR5",35,0 )
	5550	W !!!,"I' m going to automatic ally queue this off and send y ou a"
	5551	"RTN","IBT RKR5",36,0 )
	5552	W !,"mail message w hen comple te.",!
	5553	"RTN","IBT RKR5",37,0 )
	5554	S ZTIO="" ,ZTRTN="EN 1^IBTRKR5" ,ZTSAVE("I B*")="",ZT DESC="IB - Add Prost hetics to
	5555	Claims Tra cking"
	5556	"RTN","IBT RKR5",38,0 )
	5557	D ^%ZTLOA D I $G(ZTS K) K ZTSK W !,"Reque st Queued"
	5558	"RTN","IBT RKR5",39,0 )
	5559	ENQ K ZTSK ,ZTIO,ZTSA VE,ZTDESC, ZTRTN
	5560	"RTN","IBT RKR5",40,0 )
	5561	D HOME^%Z IS
	5562	"RTN","IBT RKR5",41,0 )
	5563	Q
	5564	"RTN","IBT RKR5",42,0 )
	5565	;
	5566	"RTN","IBT RKR5",43,0 )
	5567	EN1 ; -- a dd prostet hics to cl aims track ing file
	5568	"RTN","IBT RKR5",44,0 )
	5569	N I,J,X,Y ,IBTRKR,IB DT,DFN,IBD ATA,IBCNT, IBCNT1,IBC NT2,IBDTS, PROCOV
	5570	"RTN","IBT RKR5",45,0 )
	5571	N IBSWINF O S IBSWIN FO=$$SWSTA T^IBBAPI() ; IB2.0312
	5572	"RTN","IBT RKR5",46,0 )
	5573	;
	5574	"RTN","IBT RKR5",47,0 )
	5575	; -- chec k paramete rs
	5576	"RTN","IBT RKR5",48,0 )
	5577	S IBTRKR= $G(^IBE(35 0.9,1,6))
	5578	"RTN","IBT RKR5",49,0 )
	5579	G:'$P(IBT RKR,"^",5) EN1Q ; qu it if prot hetics tra cking off
	5580	"RTN","IBT RKR5",50,0 )
	5581	I +IBTRKR ,IBTSBDT<+ IBTRKR S I BTSBDT=IBT RKR ; star t date can 't be befo re paramet
	5582	ers
	5583	"RTN","IBT RKR5",51,0 )
	5584	;
	5585	"RTN","IBT RKR5",52,0 )
	5586	; -- user s can queu e into fut ure, make sure dates not after date run
	5587	"RTN","IBT RKR5",53,0 )
	5588	I IBTSEDT >$$FMADD^X LFDT(DT,-3 ) S IBMESS ="(Selecte d end date of "_$$DA T1^IBOUTL(
	5589	IBTSEDT)_" automatic ally chang ed to "_$$ DAT1^IBOUT L($$FMADD^ XLFDT(DT,- 3))_".)",I
	5590	BTSEDT=$$F MADD^XLFDT (DT,-3)
	5591	"RTN","IBT RKR5",54,0 )
	5592	;
	5593	"RTN","IBT RKR5",55,0 )
	5594	;S IBPRTY P=$O(^IBE( 356.6,"AC" ,3,0)) ; t his is the event typ e pointer for prosth
	5595	etics
	5596	"RTN","IBT RKR5",56,0 )
	5597	;
	5598	"RTN","IBT RKR5",57,0 )
	5599	; -- cnt= total cou nt, cnt1=c ount added nsc, cnt2 =count of pending
	5600	"RTN","IBT RKR5",58,0 )
	5601	S (IBCNT, IBCNT1,IBC NT2)=0
	5602	"RTN","IBT RKR5",59,0 )
	5603	S (IBDTS, IBDT)=IBTS BDT-.0001
	5604	"RTN","IBT RKR5",60,0 )
	5605	;
	5606	"RTN","IBT RKR5",61,0 )
	5607	; loop tw ice, once for shipmn et date (n ew search) , and once for
	5608	"RTN","IBT RKR5",62,0 )
	5609	; deliver y date (ol d search) for backwa rd compati bility.
	5610	"RTN","IBT RKR5",63,0 )
	5611	F S IBDT =$O(^RMPR( 660,"AF",I BDT)) Q:'I BDT!(IBDT> IBTSEDT) D
	5612	"RTN","IBT RKR5",64,0 )
	5613	.; Do NOT PROCES S on VistA if IBDT>= Switch Eff Date ; CCR-930
	5614	"RTN","IBT RKR5",65,0 )
	5615	.I +IB SWINFO,(IB DT+1)>$P(I BSWINFO,"^ ",2) Q ; IB2.0312
	5616	"RTN","IBT RKR5",66,0 )
	5617	.S IBD A=0 F S I BDA=$O(^RM PR(660,"AF ",IBDT,IBD A)) Q:'IBD A D PRCHK
	5618	"RTN","IBT RKR5",67,0 )
	5619	;
	5620	"RTN","IBT RKR5",68,0 )
	5621	; reset d ate and do old check
	5622	"RTN","IBT RKR5",69,0 )
	5623	S IBDT=IB DTS
	5624	"RTN","IBT RKR5",70,0 )
	5625	F S IBDT =$O(^RMPR( 660,"CT",I BDT)) Q:'I BDT!(IBDT> IBTSEDT) D
	5626	"RTN","IBT RKR5",71,0 )
	5627	.; Do NOT PROCES S on VistA if IBDT>= Switch Eff Date ; CCR-930
	5628	"RTN","IBT RKR5",72,0 )
	5629	.I +IB SWINFO,(IB DT+1)>$P(I BSWINFO,"^ ",2) Q ; IB2.0312
	5630	"RTN","IBT RKR5",73,0 )
	5631	.S IBD A="" F S IBDA=$O(^R MPR(660,"C T",IBDT,IB DA)) Q:'IB DA D PRCH K
	5632	"RTN","IBT RKR5",74,0 )
	5633	;
	5634	"RTN","IBT RKR5",75,0 )
	5635	I $G(IBTA LK) D BULL ;^IBTRKR5 1
	5636	"RTN","IBT RKR5",76,0 )
	5637	EN1Q I $D( ZTQUEUED) S ZTREQ="@ "
	5638	"RTN","IBT RKR5",77,0 )
	5639	Q
	5640	"RTN","IBT RKR5",78,0 )
	5641	;
	5642	"RTN","IBT RKR5",79,0 )
	5643	PRCHK ; -- check and add item
	5644	"RTN","IBT RKR5",80,0 )
	5645	N IBE,IBP ,IBDX,IBRM ARK,IBARR, IBT,IBINS
	5646	"RTN","IBT RKR5",81,0 )
	5647	S IBCNT=I BCNT+1,IBR MARK=""
	5648	"RTN","IBT RKR5",82,0 )
	5649	I '$D(ZTQ UEUED),($G (IBTALK)) W "."
	5650	"RTN","IBT RKR5",83,0 )
	5651	;
	5652	"RTN","IBT RKR5",84,0 )
	5653	S IBDATA= $G(^RMPR(6 60,+IBDA,0 )) Q:IBDAT A=""
	5654	"RTN","IBT RKR5",85,0 )
	5655	S DFN=$P( IBDATA,"^" ,2) Q:'DFN
	5656	"RTN","IBT RKR5",86,0 )
	5657	; quit if non billa ble PSAS H CPCS code is found
	5658	"RTN","IBT RKR5",87,0 )
	5659	S SCDATA= $G(^RMPR(6 60,+IBDA," BA1"))
	5660	"RTN","IBT RKR5",88,0 )
	5661	I $$IBPHP (IBDA) Q
	5662	"RTN","IBT RKR5",89,0 )
	5663	D CL^SDCO 21(DFN,IBD T,"",.IBAR R)
	5664	"RTN","IBT RKR5",90,0 )
	5665	;
	5666	"RTN","IBT RKR5",91,0 )
	5667	; -- chec ks copied from rmprb il v2.0 /f eb 2, 1994
	5668	"RTN","IBT RKR5",92,0 )
	5669	Q:'$D(^RM PR(660,+IB DA,"AM"))
	5670	"RTN","IBT RKR5",93,0 )
	5671	Q:$P(^RMP R(660,+IBD A,0),U,9)= ""!($P(^(0 ),U,12)="" )!($P(^(0) ,U,14)="V" )!($P(^(0)
	5672	,U,2)="")! ($P(^(0),U ,15)="*")
	5673	"RTN","IBT RKR5",94,0 )
	5674	;Q:($P(^R MPR(660,+I BDA,"AM"), U,3)=2)!($ P(^("AM"), U,3)=3)
	5675	"RTN","IBT RKR5",95,0 )
	5676	;
	5677	"RTN","IBT RKR5",96,0 )
	5678	;
	5679	"RTN","IBT RKR5",97,0 )
	5680	I $O(^IBT (356,"APRO ",IBDA,0)) G PRCHKQ ; already in claims tracking
	5681	"RTN","IBT RKR5",98,0 )
	5682	;
	5683	"RTN","IBT RKR5",99,0 )
	5684	; -- see if trackin g only ins ured and p t is insur ed
	5685	"RTN","IBT RKR5",100, 0)
	5686	I $P(IBTR KR,"^",5)= 1,'$$INSUR ED^IBCNS1( DFN,IBDT) G PRCHKQ ; patient n ot insured
	5687	"RTN","IBT RKR5",101, 0)
	5688	;
	5689	"RTN","IBT RKR5",102, 0)
	5690	; -- if c lasificati ons requir ed, check exemptions
	5691	"RTN","IBT RKR5",103, 0)
	5692	S SCR=0
	5693	"RTN","IBT RKR5",104, 0)
	5694	I '$D(IBA RR) G CLQ
	5695	"RTN","IBT RKR5",105, 0)
	5696	;IB2.05 68
	5697	"RTN","IBT RKR5",106, 0)
	5698	N IBSC
	5699	"RTN","IBT RKR5",107, 0)
	5700	F IBP=1:1 :4 S IBDX( IBP)=$G(^R MPR(660,+I BDA,"BA"_I BP)) D
	5701	"RTN","IBT RKR5",108, 0)
	5702	.S SCR=0 F SCP=2:1: 8 Q:SCR=1 I $P(IBDX (IBP),U,SC P)[1 S IBS C(IBP)=SCP ,SCR=1
	5703	"RTN","IBT RKR5",109, 0)
	5704	I 'SCR S IBRMARK="N EEDS SC DE TERMINATIO N" G CLQ ; no ICD no de in RMPR , use old
	5705	method of determinin g status
	5706	"RTN","IBT RKR5",110, 0)
	5707	S IBRMARK =""
	5708	"RTN","IBT RKR5",111, 0)
	5709	S IBE=0 F S IBE=$O (IBARR(IBE )) Q:'IBE D Q:($L( $G(IBRMARK )))
	5710	"RTN","IBT RKR5",112, 0)
	5711	.F IBP=1: 1:4 Q:$L($ G(IBRMARK) ) D
	5712	"RTN","IBT RKR5",113, 0)
	5713	..S (SUB, REC)="" I IBSC(IBP) S SUB="CL" _IBSC(IBP) ,REC=$T(@S UB)
	5714	"RTN","IBT RKR5",114, 0)
	5715	..S IBRMA RK=$S(REC' ="":$P(REC ,";",3),1: "NEEDS SC DETERMINAT ION")
	5716	"RTN","IBT RKR5",115, 0)
	5717	;
	5718	"RTN","IBT RKR5",116, 0)
	5719	;
	5720	"RTN","IBT RKR5",117, 0)
	5721	CLQ ; -- o k to add t o tracking module
	5722	"RTN","IBT RKR5",118, 0)
	5723	S PROCOV= 0,SCR=+$G( SCR)
	5724	"RTN","IBT RKR5",119, 0)
	5725	S PROCOV= +$$PTCOV^I BCNSU3(DFN ,IBDT,"PRO STHETICS")
	5726	"RTN","IBT RKR5",120, 0)
	5727	I 'PROCOV ,IBRMARK=" NEEDS SC D ETERMINATI ON" S IBRM ARK="NO PR OSTHETIC C OVERAGE"
	5728	"RTN","IBT RKR5",121, 0)
	5729	I 'PROCOV ,IBRMARK=" " S IBRMAR K="NO PROS THETIC COV ERAGE"
	5730	"RTN","IBT RKR5",122, 0)
	5731	D PRO^IBT UTL1(DFN,I BDT,IBDA,$ G(IBRMARK) ) I '$D(ZT QUEUED),$G (IBTALK) W "+"
	5732	"RTN","IBT RKR5",123, 0)
	5733	I SCR=1 S IBCNT2=IB CNT2+1
	5734	"RTN","IBT RKR5",124, 0)
	5735	I SCR=0 S IBCNT1=IB CNT1+1
	5736	"RTN","IBT RKR5",125, 0)
	5737	K VAEL,VA ,IBDATA,DF N,X,Y
	5738	"RTN","IBT RKR5",126, 0)
	5739	PRCHKQ Q
	5740	"RTN","IBT RKR5",127, 0)
	5741	;
	5742	"RTN","IBT RKR5",128, 0)
	5743	IBPHP(IBDA ) ; non bi llable PSA S HCPCS co des
	5744	"RTN","IBT RKR5",129, 0)
	5745	; input-p atient ite m in #660
	5746	"RTN","IBT RKR5",130, 0)
	5747	; output- value if t he code wi th the fir st 2 chars in the st ring is fo und
	5748	"RTN","IBT RKR5",131, 0)
	5749	N IBPSAS, IBPIN S IB PIN=""
	5750	"RTN","IBT RKR5",132, 0)
	5751	S IBPSAS= ",BA,DI,DL ,EC,EV,FE, HI,HN,HS,N R,RE,SB,SI ,TH,TM,TR, VA,"
	5752	"RTN","IBT RKR5",133, 0)
	5753	; return the pointe r^descript ion^the co de (#661.1 ,.01)
	5754	"RTN","IBT RKR5",134, 0)
	5755	S IBPIN=$ $PIN^IBATU TL(+IBDA)
	5756	"RTN","IBT RKR5",135, 0)
	5757	S IBPIN=$ P(IBPIN,U, 3)
	5758	"RTN","IBT RKR5",136, 0)
	5759	S IBPIN=$ F(IBPSAS," ,"_$E(IBPI N,1,2)_"," )
	5760	"RTN","IBT RKR5",137, 0)
	5761	Q IBPIN
	5762	"RTN","IBT RKR5",138, 0)
	5763	;
	5764	"RTN","IBT RKR5",139, 0)
	5765	BULL ; -- send bulle tin
	5766	"RTN","IBT RKR5",140, 0)
	5767	;
	5768	"RTN","IBT RKR5",141, 0)
	5769	S XMSUB=" Prosthetic Items add ed to Clai ms Trackin g Complete "
	5770	"RTN","IBT RKR5",142, 0)
	5771	S IBT(1)= "The proce ss to auto matically add Prosth etic Items has succe ssfully co
	5772	mpleted."
	5773	"RTN","IBT RKR5",143, 0)
	5774	S IBT(1.1 )=""
	5775	"RTN","IBT RKR5",144, 0)
	5776	S IBT(2)= " Start D ate: "_$$D AT1^IBOUTL (IBTSBDT)
	5777	"RTN","IBT RKR5",145, 0)
	5778	S IBT(3)= " End D ate: "_$$D AT1^IBOUTL (IBTSEDT)
	5779	"RTN","IBT RKR5",146, 0)
	5780	I $D(IBME SS) S IBT( 3.1)=IBMES S
	5781	"RTN","IBT RKR5",147, 0)
	5782	S IBT(4)= ""
	5783	"RTN","IBT RKR5",148, 0)
	5784	S IBT(5)= " Total Pr osthetics Items chec ked: "_$G( IBCNT)
	5785	"RTN","IBT RKR5",149, 0)
	5786	S IBT(6)= "Total NSC Prostheti c Items Ad ded: "_$G( IBCNT1)
	5787	"RTN","IBT RKR5",150, 0)
	5788	S IBT(7)= " Total SC Prostheti c Items Ad ded: "_$G( IBCNT2)
	5789	"RTN","IBT RKR5",151, 0)
	5790	S IBT(8)= ""
	5791	"RTN","IBT RKR5",152, 0)
	5792	S IBT(9)= "*The item s added as SC requir e determin ation and editing to be billed
	5793	"
	5794	"RTN","IBT RKR5",153, 0)
	5795	D SEND^IB TRKR31
	5796	"RTN","IBT RKR5",154, 0)
	5797	BULLQ Q
	5798	"RTN","IBT RKR5",155, 0)
	5799	;
	5800	"RTN","IBT RKR5",156, 0)
	5801	CLTXT ; cl assificati on text fo r reason n ot billabl e
	5802	"RTN","IBT RKR5",157, 0)
	5803	;;
	5804	"RTN","IBT RKR5",158, 0)
	5805	CL2 ;;AGEN T ORANGE
	5806	"RTN","IBT RKR5",159, 0)
	5807	CL3 ;;IONI ZING RADIA TION
	5808	"RTN","IBT RKR5",160, 0)
	5809	CL4 ;;SC T REATMENT
	5810	"RTN","IBT RKR5",161, 0)
	5811	CL5 ;;SOUT HWEST ASIA
	5812	"RTN","IBT RKR5",162, 0)
	5813	CL6 ;;MILI TARY SEXUA L TRAUMA
	5814	"RTN","IBT RKR5",163, 0)
	5815	CL7 ;;HEAD /NECK CANC ER
	5816	"RTN","IBT RKR5",164, 0)
	5817	CL8 ;;COMB AT VETERAN
	5818	"RTN","IBY 568PO")
	5819	0^^B946868 53
	5820	"RTN","IBY 568PO",1,0 )
	5821	IBY568PO ; ALB/BAA - Post insta ll routine for patch 568; 5-AU G-16
	5822	"RTN","IBY 568PO",2,0 )
	5823	;;2.0;INT EGRATED BI LLING;56 8;21-MAR -94;Build 2
	5824	"RTN","IBY 568PO",3,0 )
	5825	;;Per VA Directive 6402, this routine s hould not be modifie d.
	5826	"RTN","IBY 568PO",4,0 )
	5827	;
	5828	"RTN","IBY 568PO",5,0 )
	5829	Q
	5830	"RTN","IBY 568PO",6,0 )
	5831	; This po st-install routine w ill create a new sec urity key
	5832	"RTN","IBY 568PO",7,0 )
	5833	; called IB PARAMET ER EDIT.
	5834	"RTN","IBY 568PO",8,0 )
	5835	; It will be added to two men u options/
	5836	"RTN","IBY 568PO",9,0 )
	5837	;
	5838	"RTN","IBY 568PO",10, 0)
	5839	; The new IB PARAME TER EDIT k ey will be used to l ock
	5840	"RTN","IBY 568PO",11, 0)
	5841	;
	5842	"RTN","IBY 568PO",12, 0)
	5843	; IB T EDIT TRA CKING PARA METERS
	5844	"RTN","IBY 568PO",13, 0)
	5845	; IB J MCCR SIT E PARAMETE RS
	5846	"RTN","IBY 568PO",14, 0)
	5847	;
	5848	"RTN","IBY 568PO",15, 0)
	5849	; This ro utine will add PROST HETICS to Plan Cover age Limita tions file
	5850	"RTN","IBY 568PO",16, 0)
	5851	;
	5852	"RTN","IBY 568PO",17, 0)
	5853	; This ro utine will add three new rate types.
	5854	"RTN","IBY 568PO",18, 0)
	5855	;
	5856	"RTN","IBY 568PO",19, 0)
	5857	; HU MANITARIAN REIMB. IN S.
	5858	"RTN","IBY 568PO",20, 0)
	5859	; IN ELIGIBLE R EIMB. INS.
	5860	"RTN","IBY 568PO",21, 0)
	5861	; DE NTAL REIMB . INS
	5862	"RTN","IBY 568PO",22, 0)
	5863	;
	5864	"RTN","IBY 568PO",23, 0)
	5865	;
	5866	"RTN","IBY 568PO",24, 0)
	5867	START ; CA LL SECTION S
	5868	"RTN","IBY 568PO",25, 0)
	5869	D MES^XPD UTL(" Sta rting post -install f or IB2.0 528")
	5870	"RTN","IBY 568PO",26, 0)
	5871	D NEWKEY
	5872	"RTN","IBY 568PO",27, 0)
	5873	D KEYS
	5874	"RTN","IBY 568PO",28, 0)
	5875	D RIDER
	5876	"RTN","IBY 568PO",29, 0)
	5877	D PLAN
	5878	"RTN","IBY 568PO",30, 0)
	5879	D ADDRT
	5880	"RTN","IBY 568PO",31, 0)
	5881	D ADDRS ; add Rate Schedules (363)
	5882	"RTN","IBY 568PO",32, 0)
	5883	; Complet ion messag e
	5884	"RTN","IBY 568PO",33, 0)
	5885	D MES^XPD UTL(" Fin ished post -install f or IB2.0 568")
	5886	"RTN","IBY 568PO",34, 0)
	5887	Q
	5888	"RTN","IBY 568PO",35, 0)
	5889	;
	5890	"RTN","IBY 568PO",36, 0)
	5891	NEWKEY ; a dd new IB PARAMETER EDIT key
	5892	"RTN","IBY 568PO",37, 0)
	5893	N IBFLAG, IBOPT,DA,D IC,DIE,DR, X
	5894	"RTN","IBY 568PO",38, 0)
	5895	D MES^XPD UTL("New s ecurity ke y...")
	5896	"RTN","IBY 568PO",39, 0)
	5897	; Check w hether the key exist s
	5898	"RTN","IBY 568PO",40, 0)
	5899	I +$O(^DI C(19.1,"B" ,"IB PARAM ETER EDIT" ,0)) D MES ^XPDUTL("K ey IB PARA METER EDIT
	5900	already e xists.") Q
	5901	"RTN","IBY 568PO",41, 0)
	5902	;
	5903	"RTN","IBY 568PO",42, 0)
	5904	S IBKEY=" IB PARAMET ER EDIT"
	5905	"RTN","IBY 568PO",43, 0)
	5906	S IBIEN=$ $FIND1^DIC (19.1,""," X",IBKEY," ","","IBER R") I $D(I BERR) D BM ES^XPDUTL(
	5907	"Error in NEWKEY-IBY 568PO - Ca nnot add " _IBKEY_" t o Security Key file #19.1") Q
	5908	"RTN","IBY 568PO",44, 0)
	5909	I +IBIEN D BMES^XPD UTL("Secur ity Key "_ IBKEY_" al ready exis ts in the SECURITY K
	5910	EY file - not added" ) Q
	5911	"RTN","IBY 568PO",45, 0)
	5912	;
	5913	"RTN","IBY 568PO",46, 0)
	5914	D BMES^XP DUTL("Addi ng new sec urity key, "_IBKEY_" , to the S ECURITY KE Y file")
	5915	"RTN","IBY 568PO",47, 0)
	5916	S DIC(0)= "LMX"
	5917	"RTN","IBY 568PO",48, 0)
	5918	S IBARR(1 9.1,"+1,", .01)=IBKEY
	5919	"RTN","IBY 568PO",49, 0)
	5920	D UPDATE^ DIE("E","I BARR","IBI EN","IBERR ")
	5921	"RTN","IBY 568PO",50, 0)
	5922	;
	5923	"RTN","IBY 568PO",51, 0)
	5924	I '+$G(IB IEN(1))!($ D(IBERR)) D Q
	5925	"RTN","IBY 568PO",52, 0)
	5926	. D BMES^ XPDUTL("A problem wa s encounte red trying to add se curity key , "_IBKEY)
	5927	"RTN","IBY 568PO",53, 0)
	5928	. D BMES^ XPDUTL("Th e entry mu st be adde d manually to the SE CURITY KEY file")
	5929	"RTN","IBY 568PO",54, 0)
	5930	;
	5931	"RTN","IBY 568PO",55, 0)
	5932	D BMES^XP DUTL("Secu rity Key, "_IBKEY_", was succe ssfully ad ded to the SECURITY
	5933	KEY file")
	5934	"RTN","IBY 568PO",56, 0)
	5935	Q
	5936	"RTN","IBY 568PO",57, 0)
	5937	;
	5938	"RTN","IBY 568PO",58, 0)
	5939	KEYS ; Add security key to IBT EDIT TRAC KING PARAM ETERS and IBJ MCCR S ITE PARAME
	5940	TERS
	5941	"RTN","IBY 568PO",59, 0)
	5942	N IBFLAG, IBOPT,DA,D IC,DIE,DR, X
	5943	"RTN","IBY 568PO",60, 0)
	5944	D MES^XPD UTL("New s ecurity ke y...")
	5945	"RTN","IBY 568PO",61, 0)
	5946	; Check w hether the key exist s
	5947	"RTN","IBY 568PO",62, 0)
	5948	I '+$O(^D IC(19.1,"B ","IB PARA METER EDIT ",0)) D ME S^XPDUTL(" Key IB PAR AMETER EDI
	5949	T does not exists.") Q
	5950	"RTN","IBY 568PO",63, 0)
	5951	;
	5952	"RTN","IBY 568PO",64, 0)
	5953	; Lock op tions IBT EDIT TRACK ING PARAME TERS and I BJ MCCR SI TE PARAMET ERS with n
	5954	ewly named key
	5955	"RTN","IBY 568PO",65, 0)
	5956	D MES^XPD UTL("Assig ning key t o options. ..")
	5957	"RTN","IBY 568PO",66, 0)
	5958	F IBOPT=" IBT EDIT T RACKING PA RAMETERS", "IBJ MCCR SITE PARAM ETERS","IB AUTO BILL
	5959	ER PARAMS" ,"IB EDIT SITE PARAM ETERS" D
	5960	"RTN","IBY 568PO",67, 0)
	5961	.S DA=$$F IND1^DIC(1 9,"","X",I BOPT,"B")
	5962	"RTN","IBY 568PO",68, 0)
	5963	.I 'DA D MES^XPDUTL ("Option " _IBOPT_" n ot found i n system." ) Q
	5964	"RTN","IBY 568PO",69, 0)
	5965	.S DIE=19 ,DR="3///I B PARAMETE R EDIT"
	5966	"RTN","IBY 568PO",70, 0)
	5967	.L +^DIC( 19,DA):0 I $T D ^DIE L -^DIC(1 9,DA) Q
	5968	"RTN","IBY 568PO",71, 0)
	5969	.D MES^XP DUTL("Opti on "_IBOPT _" is lock ed by anot her user." )
	5970	"RTN","IBY 568PO",72, 0)
	5971	Q
	5972	"RTN","IBY 568PO",73, 0)
	5973	;
	5974	"RTN","IBY 568PO",74, 0)
	5975	;
	5976	"RTN","IBY 568PO",75, 0)
	5977	RIDER ; ad d Prostihe tic Insura nce Rider (355.6)
	5978	"RTN","IBY 568PO",76, 0)
	5979	N IBNAME, DD,DO,DLAY GO,DIC,X,Y ,IBDA,IBAR R,IBX
	5980	"RTN","IBY 568PO",77, 0)
	5981	D MES^XPD UTL(" ")
	5982	"RTN","IBY 568PO",78, 0)
	5983	;
	5984	"RTN","IBY 568PO",79, 0)
	5985	S IBNAME= "PROSTHETI CS COVERAG E"
	5986	"RTN","IBY 568PO",80, 0)
	5987	I $O(^IBE (355.6,"B" ,IBNAME,0) ) S IBX=" - "_IBNA ME_" Insur ance Rider (355.6) a
	5988	lready exi sts, no ch ange" D ME S^XPDUTL(I BX) Q
	5989	"RTN","IBY 568PO",81, 0)
	5990	;
	5991	"RTN","IBY 568PO",82, 0)
	5992	K DD,DO S DLAYGO=35 5.6,DIC="^ IBE(355.6, ",DIC(0)=" L",X=IBNAM E D FILE^D ICN K DIC
	5993	I Y<1 K X, Y Q
	5994	"RTN","IBY 568PO",83, 0)
	5995	S IBDA=+Y
	5996	"RTN","IBY 568PO",84, 0)
	5997	;
	5998	"RTN","IBY 568PO",85, 0)
	5999	S IBX=" * "_IBNAM E_" Insura nce Rider (355.6) ad ded" D MES ^XPDUTL(IB X)
	6000	"RTN","IBY 568PO",86, 0)
	6001	Q
	6002	"RTN","IBY 568PO",87, 0)
	6003	;
	6004	"RTN","IBY 568PO",88, 0)
	6005	PLAN ; add Prostheti cs to Plan Coverage Limitation s
	6006	"RTN","IBY 568PO",89, 0)
	6007	D MES^XPD UTL("Addin g PROSTHET ICS to Pla n Coverage Limitatio ns file... ")
	6008	"RTN","IBY 568PO",90, 0)
	6009	N IBA,IBN AME,IBRIDE R,IBRDA,IB X,DD,DO,DL AYGO,DIC,X ,Y,IBDA,DI E,DA,DR,IB FILE
	6010	"RTN","IBY 568PO",91, 0)
	6011	S IBFILE= " Plan Lim itation Ca tegory (#3 55.31) "
	6012	"RTN","IBY 568PO",92, 0)
	6013	;
	6014	"RTN","IBY 568PO",93, 0)
	6015	S IBNAME= "PROSTHETI CS",IBRIDE R="PROSTHE TICS COVER AGE"
	6016	"RTN","IBY 568PO",94, 0)
	6017	S IBRDA=$ O(^IBE(355 .6,"B",IBR IDER,0)) I 'IBRDA S IBX=" - "_IBNAME_I BFILE_"Not
	6018	Added, Ri der Missin g" D MES^X PDUTL(IBX) Q
	6019	"RTN","IBY 568PO",95, 0)
	6020	;
	6021	"RTN","IBY 568PO",96, 0)
	6022	I $O(^IBE (355.31,"B ",IBNAME,0 )) S IBA=" >> "_IBNAM E_IBFILE_" exists, no change" D
	6023	MES^XPDUT L(IBA) Q
	6024	"RTN","IBY 568PO",97, 0)
	6025	;
	6026	"RTN","IBY 568PO",98, 0)
	6027	K DD,DO S DLAYGO=35 5.31,DIC=" ^IBE(355.3 1,",DIC(0) ="L",X=IBN AME D FILE ^DICN K DI
	6028	C S IBDA=+ Y I Y<1 K X,Y Q
	6029	"RTN","IBY 568PO",99, 0)
	6030	;
	6031	"RTN","IBY 568PO",100 ,0)
	6032	S DIE="^I BE(355.31, ",DA=+IBDA ,DR=".02// //Prosthet ics covera ge" D ^DIE K DIE,DA,
	6033	DR,X,Y
	6034	"RTN","IBY 568PO",101 ,0)
	6035	;
	6036	"RTN","IBY 568PO",102 ,0)
	6037	D MES^XPD UTL("Prost hetics Pla n added... ..")
	6038	"RTN","IBY 568PO",103 ,0)
	6039	;
	6040	"RTN","IBY 568PO",104 ,0)
	6041	Q
	6042	"RTN","IBY 568PO",105 ,0)
	6043	;
	6044	"RTN","IBY 568PO",106 ,0)
	6045	ADDRT ; Ad d Rate Typ es (399.3)
	6046	"RTN","IBY 568PO",107 ,0)
	6047	N IBA,IBC NT,FLG,IBI ,REC,IBAR, DD,DO,DLAY GO,DIC,DIE ,DA,DR,X,Y ,RN
	6048	"RTN","IBY 568PO",108 ,0)
	6049	S IBCNT=0
	6050	"RTN","IBY 568PO",109 ,0)
	6051	;
	6052	"RTN","IBY 568PO",110 ,0)
	6053	D MES^XPD UTL(" -> Adding new Rate T ype entrie s to file 399.3 ..." )
	6054	"RTN","IBY 568PO",111 ,0)
	6055	;
	6056	"RTN","IBY 568PO",112 ,0)
	6057	S C=";",( FLG,IBCNT) =0
	6058	"RTN","IBY 568PO",113 ,0)
	6059	F RTNUM=1 9,20,21 D
	6060	"RTN","IBY 568PO",114 ,0)
	6061	. S IBI=" RT"_RTNUM
	6062	"RTN","IBY 568PO",115 ,0)
	6063	. S REC=$ P($T(@IBI) ,";",3,99)
	6064	"RTN","IBY 568PO",116 ,0)
	6065	. S RTNAM =$P(REC,C, 1)
	6066	"RTN","IBY 568PO",117 ,0)
	6067	. S IBAR= $P(REC,C,6 ),IBAR=$O( ^PRCA(430. 2,"B",IBAR ,0)) I 'IB AR D Q
	6068	"RTN","IBY 568PO",118 ,0)
	6069	.. D MES^ XPDUTL(" * *** AR Cat egory "_IB AR_" does not exist, RT not ad ded.")
	6070	"RTN","IBY 568PO",119 ,0)
	6071	. ; do a lookup and quit if e xists.
	6072	"RTN","IBY 568PO",120 ,0)
	6073	. S DONE= $$NEW(RTNA M,RTNUM,RE C) Q:DONE= -1
	6074	"RTN","IBY 568PO",121 ,0)
	6075	. ;
	6076	"RTN","IBY 568PO",122 ,0)
	6077	. D MES^X PDUTL("New Rate Type "_RTNAM_" added") S FLG=1,IBC NT=IBCNT+1
	6078	"RTN","IBY 568PO",123 ,0)
	6079	;
	6080	"RTN","IBY 568PO",124 ,0)
	6081	RTQ I FLG S IBA(1)=" >> " _IBCNT_" R ate Types added (399 .3)..." D MES^XPDUTL
	6082	(.IBA)
	6083	"RTN","IBY 568PO",125 ,0)
	6084	Q
	6085	"RTN","IBY 568PO",126 ,0)
	6086	;
	6087	"RTN","IBY 568PO",127 ,0)
	6088	NEW(NAM,NU M,REC) ; c reate new rate type
	6089	"RTN","IBY 568PO",128 ,0)
	6090	; see if entry exis ts
	6091	"RTN","IBY 568PO",129 ,0)
	6092	N DD,DO,D LAYGO,DIC, DIE,DA,DR, X,Y,RN
	6093	"RTN","IBY 568PO",130 ,0)
	6094	S DA=NAM
	6095	"RTN","IBY 568PO",131 ,0)
	6096	S DIC="^D GCR(399.3, " D ^DIC S OUT=+Y
	6097	"RTN","IBY 568PO",132 ,0)
	6098	I OUT>0 D MES^XPDUT L(" "_NAM _" already exists.")
	6099	"RTN","IBY 568PO",133 ,0)
	6100	; add ent ry
	6101	"RTN","IBY 568PO",134 ,0)
	6102	K DO
	6103	"RTN","IBY 568PO",135 ,0)
	6104	S DIC(0)= "L",DLAYGO =399.3,DR= "",X=NAM,D A=NUM
	6105	"RTN","IBY 568PO",136 ,0)
	6106	D FILE^DI CN I +Y=-1 D MES^XPD UTL(" "_NAM_" failed to add!") Q +Y
	6107	"RTN","IBY 568PO",137 ,0)
	6108	S RN=+Y
	6109	"RTN","IBY 568PO",138 ,0)
	6110	S DA=RN
	6111	"RTN","IBY 568PO",139 ,0)
	6112	S DR=".02 ////"_$P(R EC,C,2)_"; .04////"_$ P(REC,C,4) _";.05//// "_$P(REC,C ,5)_";.06/
	6113	///"_IBAR_ ";.07////" _$P(REC,C, 7)
	6114	"RTN","IBY 568PO",140 ,0)
	6115	S DIE="^D GCR(399.3, "
	6116	"RTN","IBY 568PO",141 ,0)
	6117	D ^DIE
	6118	"RTN","IBY 568PO",142 ,0)
	6119	S DIC(0)= "L",DLAYGO =399.3,DR= "",DA=RN
	6120	"RTN","IBY 568PO",143 ,0)
	6121	S DR=".08 ////"_$P(R EC,C,8)_"; .09////0;. 1////"_$P( REC,C,10)_ ";"
	6122	"RTN","IBY 568PO",144 ,0)
	6123	S DIE="^D GCR(399.3, "
	6124	"RTN","IBY 568PO",145 ,0)
	6125	D ^DIE
	6126	"RTN","IBY 568PO",146 ,0)
	6127	Q 1
	6128	"RTN","IBY 568PO",147 ,0)
	6129	;
	6130	"RTN","IBY 568PO",148 ,0)
	6131	ADDRS ; Ad d Rate Sch edules (36 3) for EME RGENCY/HUM ANITARIAN REIMB. & I NELIGIBLE
	6132	HOSP. REIM B.
	6133	"RTN","IBY 568PO",149 ,0)
	6134	D MES^XPD UTL(" -> Adding new Rate S chedules t o file 363 ...")
	6135	"RTN","IBY 568PO",150 ,0)
	6136	N IBA,IBC NT,IBI,IBL N,IBFN,IBR T,IBBS,IBC NTCS,IBJ,I BLNCS,IBCS ,IBCSFN,IB VDT,DD,DO,
	6137	DLAYGO,DIC ,DIE,DA,DR ,X,Y S IBC NT=0
	6138	"RTN","IBY 568PO",151 ,0)
	6139	;
	6140	"RTN","IBY 568PO",152 ,0)
	6141	F IBI=1:1 S IBLN=$P ($T(RSF+IB I),";;",2) Q:IBLN="E ND" I $E( IBLN)?1A D
	6142	"RTN","IBY 568PO",153 ,0)
	6143	. ;Check for proble ms
	6144	"RTN","IBY 568PO",154 ,0)
	6145	. I $O(^I BE(363,"B" ,$P(IBLN,U ,1),0)) Q ;Already exists
	6146	"RTN","IBY 568PO",155 ,0)
	6147	. S IBBS= $P(IBLN,U, 4) I IBBS' ="" S IBBS =$$MCCRUTL (IBBS,13) Q:'IBBS ; Billable s
	6148	ervice inv alid
	6149	"RTN","IBY 568PO",156 ,0)
	6150	. S IBRT= $P(IBLN,U, 2),IBRT=$O (^DGCR(399 .3,"B",IBR T,0)) D Q :'IBRT
	6151	"RTN","IBY 568PO",157 ,0)
	6152	. S IBRN= $P(IBLN,U, 1)
	6153	"RTN","IBY 568PO",158 ,0)
	6154	.. I 'IBR T D MSG(" Rate Ty pe "_$P(IB LN,U,2)_" not define d, RS "_$P
	6155	(IBLN,U,1) _" not cre ated")
	6156	"RTN","IBY 568PO",159 ,0)
	6157	.. I +$P( $G(^DGCR(3 99.3,+IBRT ,0)),U,3) S IBRT=0 D MSG(" **** Rate Type
	6158	"_$P(IBLN, U,2)_" not Active, R S "_$P(IBL N,U,1)_" n ot created ")
	6159	"RTN","IBY 568PO",160 ,0)
	6160	. ;No pro blems foun d, so crea te entry
	6161	"RTN","IBY 568PO",161 ,0)
	6162	. K DD,DO
	6163	"RTN","IBY 568PO",162 ,0)
	6164	. S DLAYG O=363,DIC= "^IBE(363, ",DIC(0)=" L",X=$P(IB LN,U,1)
	6165	"RTN","IBY 568PO",163 ,0)
	6166	. D FILE^ DICN K DIC ,DINUM,DLA YGO
	6167	"RTN","IBY 568PO",164 ,0)
	6168	. I Y<1 K X,Y Q
	6169	"RTN","IBY 568PO",165 ,0)
	6170	. S IBFN= +Y,IBCNT=I BCNT+1
	6171	"RTN","IBY 568PO",166 ,0)
	6172	. S IBVDT =$$VERSDT^ IBCRU8(2)
	6173	"RTN","IBY 568PO",167 ,0)
	6174	. I $P(IB LN,U,1)["R X" S RXDT= $$RXDT() I RXDT="" S RXDT=3110 318
	6175	"RTN","IBY 568PO",168 ,0)
	6176	. S DR=". 02////"_IB RT_";.03// //"_$P(IBL N,U,3) I + IBBS S DR= DR_";.04// //"_IBBS
	6177	"RTN","IBY 568PO",169 ,0)
	6178	. S DR=DR _";.05//// "_$S($P(IB LN,U,1)["R X":RXDT,1: IBVDT)
	6179	"RTN","IBY 568PO",170 ,0)
	6180	. I $P(IB LN,U,1)["R X",IBDISP] "" S DR=DR _";1.01/// "_IBDISP
	6181	"RTN","IBY 568PO",171 ,0)
	6182	. I $P(IB LN,U,1)["R X",IBADMIN ]"" S DR=D R_";1.02// //"_IBADMI N
	6183	"RTN","IBY 568PO",172 ,0)
	6184	. I $P(IB LN,U,1)["R X",IBADJST ]"" S DR=D R_";10//// "_IBADJST
	6185	"RTN","IBY 568PO",173 ,0)
	6186	. S DIE=" ^IBE(363," ,DA=+Y D ^ DIE K DIE, DA,DR,X,Y
	6187	"RTN","IBY 568PO",174 ,0)
	6188	. S IBCNT CS=0
	6189	"RTN","IBY 568PO",175 ,0)
	6190	. ; add a ll Reasona ble Charge s Charge S ets
	6191	"RTN","IBY 568PO",176 ,0)
	6192	. I $P(IB LN,U,1)["R X" S IBCNT CS=$$RSCS( IBFN,RXDT)
	6193	"RTN","IBY 568PO",177 ,0)
	6194	. I $P(IB LN,U,1)'[" RX" S IBCN TCS=$$RSCS (IBFN,IBVD T)
	6195	"RTN","IBY 568PO",178 ,0)
	6196	. D MES^X PDUTL(" Total Charge Se t"_$S(IBCN TCS=1:" ", 1:"s ")_IB CNTCS_" ad
	6197	ded to the rate sche dule.")
	6198	"RTN","IBY 568PO",179 ,0)
	6199	D MES^XPD UTL(" Rate Sc hedules co mpleted.")
	6200	"RTN","IBY 568PO",180 ,0)
	6201	Q ;ADDRS
	6202	"RTN","IBY 568PO",181 ,0)
	6203	;
	6204	"RTN","IBY 568PO",182 ,0)
	6205	;
	6206	"RTN","IBY 568PO",183 ,0)
	6207	RSCS(IBFN, IBVDT) ; a dd existin g Charge S ets to HR & IR
	6208	"RTN","IBY 568PO",184 ,0)
	6209	; copy th e Charge S ets from t he corresp onding RI RS (v2)
	6210	"RTN","IBY 568PO",185 ,0)
	6211	N IBCNT,I BNRS,IBRSN M,IBTY,IBC OPY,IBCS,I BXFN,IBCSF N,IBCSNM,I BCSAA,IBNA ME
	6212	"RTN","IBY 568PO",186 ,0)
	6213	S (IBCNT, IBCOPY)=0
	6214	"RTN","IBY 568PO",187 ,0)
	6215	S IBNRS=$ G(^IBE(363 ,+$G(IBFN) ,0)),IBRSN M=$P(IBNRS ,"^",1)
	6216	"RTN","IBY 568PO",188 ,0)
	6217	S IBTY=$P (IBNRS,"^" ,3)
	6218	"RTN","IBY 568PO",189 ,0)
	6219	I IBRSNM[ "INPT" S I BCOPY=+$$R SEXISTS(IB VDT,"RI-IN PT")
	6220	"RTN","IBY 568PO",190 ,0)
	6221	I IBRSNM[ "SNF" S IB COPY=+$$RS EXISTS(IBV DT,"RI-SNF ")
	6222	"RTN","IBY 568PO",191 ,0)
	6223	I IBRSNM[ "OPT" S IB COPY=+$$RS EXISTS(IBV DT,"RI-OPT ")
	6224	"RTN","IBY 568PO",192 ,0)
	6225	I IBRSNM[ "RX" S IBC OPY=+$$RSE XISTS(IBVD T,"RI-RX")
	6226	"RTN","IBY 568PO",193 ,0)
	6227	I IBRSNM[ "DENTAL" S IBVDT="", IBCOPY=+$$ RSEXISTS(I BVDT,"RI-O PT")
	6228	"RTN","IBY 568PO",194 ,0)
	6229	I 'IBCOPY G RSCSQ
	6230	"RTN","IBY 568PO",195 ,0)
	6231	I +$P($G( ^IBE(363,+ IBCOPY,0)) ,U,3)=IBTY D
	6232	"RTN","IBY 568PO",196 ,0)
	6233	. S IBXFN =0 F S IB XFN=$O(^IB E(363,IBCO PY,11,IBXF N)) Q:'IBX FN D
	6234	"RTN","IBY 568PO",197 ,0)
	6235	.. S IBCS =$G(^IBE(3 63,IBCOPY, 11,IBXFN,0 )),IBCSFN= +IBCS
	6236	"RTN","IBY 568PO",198 ,0)
	6237	.. I +$$R SCSFILE(IB FN,$P($G(^ IBE(363.1, IBCSFN,0)) ,U,1),$P(I BCS,U,2)) S IBCNT=IB
	6238	CNT+1
	6239	"RTN","IBY 568PO",199 ,0)
	6240	RSCSQ Q IB CNT
	6241	"RTN","IBY 568PO",200 ,0)
	6242	;
	6243	"RTN","IBY 568PO",201 ,0)
	6244	;
	6245	"RTN","IBY 568PO",202 ,0)
	6246	RSCSFILE(I BFN,IBCSNM ,IBCSAA) ; Add Charg e Set to a Rate Sche dule
	6247	"RTN","IBY 568PO",203 ,0)
	6248	N IBX,DD, DO,DLAYGO, DIC,DA,DR, X,Y,IBCSFN S IBX=0
	6249	"RTN","IBY 568PO",204 ,0)
	6250	I $G(^IBE (363,+$G(I BFN),0))=" " G RSCSFQ
	6251	"RTN","IBY 568PO",205 ,0)
	6252	I $G(IBCS NM)="" G R SCSFQ
	6253	"RTN","IBY 568PO",206 ,0)
	6254	S IBCSFN= $O(^IBE(36 3.1,"B",IB CSNM,0)) I 'IBCSFN G RSCSFQ
	6255	"RTN","IBY 568PO",207 ,0)
	6256	I $O(^IBE (363,IBFN, 11,"B",IBC SFN,0)) G RSCSFQ
	6257	"RTN","IBY 568PO",208 ,0)
	6258	S DLAYGO= 363,DA(1)= +IBFN,DIC= "^IBE(363, "_DA(1)_", 11,",DIC(0 )="L"
	6259	"RTN","IBY 568PO",209 ,0)
	6260	S X=IBCSN M,DIC("DR" )=".02///" _$G(IBCSAA ),DIC("P") ="363.0011 P" D ^DIC S:+Y IBX=1
	6261	"RTN","IBY 568PO",210 ,0)
	6262	RSCSFQ Q I BX
	6263	"RTN","IBY 568PO",211 ,0)
	6264	;
	6265	"RTN","IBY 568PO",212 ,0)
	6266	;
	6267	"RTN","IBY 568PO",213 ,0)
	6268	RSEXISTS(I BVDT,IBNAM E) ; retur n RS IFN i f Rate Sch edule exis ts for Eff ective Dat
	6269	e
	6270	"RTN","IBY 568PO",214 ,0)
	6271	N IBX,IBR SFN,IBRS0 S IBX=0
	6272	"RTN","IBY 568PO",215 ,0)
	6273	S IBRSFN= 0 F S IBR SFN=$O(^IB E(363,IBRS FN)) Q:'I BRSFN D I IBX Q
	6274	"RTN","IBY 568PO",216 ,0)
	6275	. S IBRS0 =$G(^IBE(3 63,IBRSFN, 0))
	6276	"RTN","IBY 568PO",217 ,0)
	6277	. I $P(IB RS0,U,1)=I BNAME,$P(I BRS0,U,5)= IBVDT S IB X=IBRSFN
	6278	"RTN","IBY 568PO",218 ,0)
	6279	Q IBX
	6280	"RTN","IBY 568PO",219 ,0)
	6281	;
	6282	"RTN","IBY 568PO",220 ,0)
	6283	;
	6284	"RTN","IBY 568PO",221 ,0)
	6285	MCCRUTL(X, P) ; retur ns IFN of item in 39 9.1 if Nam e is found and piece P is true
	6286	"RTN","IBY 568PO",222 ,0)
	6287	N IBX,IBY S IBY=""
	6288	"RTN","IBY 568PO",223 ,0)
	6289	I $G(X)'= "" S IBX=0 F S IBX= $O(^DGCR(3 99.1,"B",X ,IBX)) Q:' IBX I $P( $G(^DGCR(3
	6290	99.1,IBX,0 )),U,+$G(P )) S IBY=I BX
	6291	"RTN","IBY 568PO",224 ,0)
	6292	Q IBY
	6293	"RTN","IBY 568PO",225 ,0)
	6294	;
	6295	"RTN","IBY 568PO",226 ,0)
	6296	;
	6297	"RTN","IBY 568PO",227 ,0)
	6298	MSG(X) ;
	6299	"RTN","IBY 568PO",228 ,0)
	6300	N IBX S I BX=$O(IBA( 999999),-1 ) S:'IBX I BX=1 S IBX =IBX+1
	6301	"RTN","IBY 568PO",229 ,0)
	6302	S IBA(IBX )=$G(X)
	6303	"RTN","IBY 568PO",230 ,0)
	6304	Q ;MSG
	6305	"RTN","IBY 568PO",231 ,0)
	6306	;
	6307	"RTN","IBY 568PO",232 ,0)
	6308	RXDT() ;Co py the act ive RX cha rge schedu le from RI to FR
	6309	"RTN","IBY 568PO",233 ,0)
	6310	S IBCS="" ,IBCS=$O(^ IBE(363,"B ","RI-RX", IBCS),-1)
	6311	"RTN","IBY 568PO",234 ,0)
	6312	S IBCS0=^ IBE(363,IB CS,0)
	6313	"RTN","IBY 568PO",235 ,0)
	6314	S IBDISP= $P($G(^IBE (363,IBCS, 1)),U,1),I BADMIN=$P( $G(^IBE(36 3,IBCS,1)) ,U,2)
	6315	"RTN","IBY 568PO",236 ,0)
	6316	S IBADJST =$G(^IBE(3 63,IBCS,10 ))
	6317	"RTN","IBY 568PO",237 ,0)
	6318	Q $P(IBCS 0,U,5)
	6319	"RTN","IBY 568PO",238 ,0)
	6320	;
	6321	"RTN","IBY 568PO",239 ,0)
	6322	NEWRT ;Rat e Type
	6323	"RTN","IBY 568PO",240 ,0)
	6324	RT19 ;;HUM ANITARIAN REIMB. INS .;HUMANITA RIAN REIMB . INS.;0;H UM REIM;1; EMERGENCY/
	6325	HUMANITARI AN REIMB.; i;1;0;1
	6326	"RTN","IBY 568PO",241 ,0)
	6327	RT20 ;;INE LIGIBLE RE IMB. INS.; INELIGIBLE REIMB. IN S.;0;INE R EIM;1;INEL IGIBLE HOS
	6328	P. REIMB.; i;1;0;1
	6329	"RTN","IBY 568PO",242 ,0)
	6330	RT21 ;;DEN TAL REIMB. INS.;DENT AL REIMB. INS.;0;DEN REIM;1;EM ERGENCY/HU MANITARIAN
	6331	REIMB.;i; 1;0;1
	6332	"RTN","IBY 568PO",243 ,0)
	6333	;;END
	6334	"RTN","IBY 568PO",244 ,0)
	6335	;
	6336	"RTN","IBY 568PO",245 ,0)
	6337	RSF ;Rate Schedules (363) for EMERGENCY/ HUMANITARI AN REIMB. & INELIGIB LE HOSP. R
	6338	EIMB.
	6339	"RTN","IBY 568PO",246 ,0)
	6340	;;
	6341	"RTN","IBY 568PO",247 ,0)
	6342	;;HR-INPT ^HUMANITAR IAN REIMB. INS.^1^IN PATIENT
	6343	"RTN","IBY 568PO",248 ,0)
	6344	;;HR-SNF^ HUMANITARI AN REIMB. INS.^1^SKI LLED NURSI NG
	6345	"RTN","IBY 568PO",249 ,0)
	6346	;;HR-OPT^ HUMANITARI AN REIMB. INS.^3
	6347	"RTN","IBY 568PO",250 ,0)
	6348	;;HR-RX^H UMANITARIA N REIMB. I NS.^3
	6349	"RTN","IBY 568PO",251 ,0)
	6350	;;HR-OPT DENTAL^DEN TAL REIMB. INS.^3
	6351	"RTN","IBY 568PO",252 ,0)
	6352	;;IR-INPT ^INELIGIBL E REIMB. I NS.^1^INPA TIENT
	6353	"RTN","IBY 568PO",253 ,0)
	6354	;;IR-SNF^ INELIGIBLE REIMB. IN S.^1^SKILL ED NURSING
	6355	"RTN","IBY 568PO",254 ,0)
	6356	;;IR-OPT^ INELIGIBLE REIMB. IN S.^3
	6357	"RTN","IBY 568PO",255 ,0)
	6358	;;IR-RX^I NELIGIBLE REIMB. INS .^3
	6359	"RTN","IBY 568PO",256 ,0)
	6360	;;END
	6361	"VER")
	6362	8.0^22.0
	6363	INSTALL NAME
	6364	PRCA4.53 15
	6365	"BLD",1019 1,0)
	6366	PRCA4.53 15^ACCOUNT S RECEIVAB LE^0^31702 06^y
	6367	"BLD",1019 1,1,0)
	6368	^^367^367^ 3161212^
	6369	"BLD",1019 1,1,1,0)
	6370
	6371	"BLD",1019 1,1,2,0)
	6372	IMPORTANT INSTALLATI ON NOTE:
	6373	"BLD",1019 1,1,3,0)
	6374	---------- ---------- --------
	6375	"BLD",1019 1,1,4,0)
	6376	This patch is part o f a multi- package bu ild. There are three patches
	6377	"BLD",1019 1,1,5,0)
	6378	associated with the FY16 HAPE Revenue En hancement project - IB2.0568 ,
	6379	"BLD",1019 1,1,6,0)
	6380	PRCA4.53 15 and PSO 7.0463. All three patches ar e to be in stalled
	6381	"BLD",1019 1,1,7,0)
	6382	together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
	6383	"BLD",1019 1,1,8,0)
	6384
	6385	"BLD",1019 1,1,9,0)
	6386
	6387	"BLD",1019 1,1,10,0)
	6388	Descriptio n
	6389	"BLD",1019 1,1,11,0)
	6390	---------- -
	6391	"BLD",1019 1,1,12,0)
	6392	The Chief Business O ffice (CBO ) is reque sting syst em enhance ments to
	6393	"BLD",1019 1,1,13,0)
	6394	The Vetera ns Health Informatio n Systems and Techno logy Archi tecture
	6395	"BLD",1019 1,1,14,0)
	6396	(VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd
	6397	"BLD",1019 1,1,15,0)
	6398	Outpatient Pharmacy (PSO) soft ware modul es.
	6399	"BLD",1019 1,1,16,0)
	6400
	6401	"BLD",1019 1,1,17,0)
	6402	The missio n of the D epartment of Veteran s Affairs (VA), Offi ce of
	6403	"BLD",1019 1,1,18,0)
	6404	Informatio n & Techno logy (OI&T ), is to p rovide ben efits and services
	6405	"BLD",1019 1,1,19,0)
	6406	to veteran s of the U nited Stat es Armed F orces. In meeting th ese goals,
	6407	"BLD",1019 1,1,20,0)
	6408	OIT strive s to provi de high qu ality, eff ective, an d efficien t
	6409	"BLD",1019 1,1,21,0)
	6410	Informatio n Technolo gy (IT) se rvices to those resp onsible fo r
	6411	"BLD",1019 1,1,22,0)
	6412	providing care to th e veterans at the po int-of-car e, as well as
	6413	"BLD",1019 1,1,23,0)
	6414	throughout all the p oints of t he veteran s' health care. The VA depends
	6415	"BLD",1019 1,1,24,0)
	6416	on Informa tion Manag ement/Info rmationTec hnology (I M/IT) syst ems to mee t
	6417	"BLD",1019 1,1,25,0)
	6418	mission go als.
	6419	"BLD",1019 1,1,26,0)
	6420
	6421	"BLD",1019 1,1,27,0)
	6422	The overal l FY16 HAP E Revenue Enhancemen t project has been f urther
	6423	"BLD",1019 1,1,28,0)
	6424	divided in to three s ub-project s:
	6425	"BLD",1019 1,1,29,0)
	6426
	6427	"BLD",1019 1,1,30,0)
	6428	NSR #20150 506
	6429	"BLD",1019 1,1,31,0)
	6430	The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the Chief
	6431	"BLD",1019 1,1,32,0)
	6432	Business O ffice (CBO ), bundles several N SRs with s imilar bus iness
	6433	"BLD",1019 1,1,33,0)
	6434	needs into a single requiremen ts documen t. Succes sfully add ressing
	6435	"BLD",1019 1,1,34,0)
	6436	the requir ements con tained wit hin this d ocument wi ll enable the
	6437	"BLD",1019 1,1,35,0)
	6438	Department of Vetera ns Affairs (VA) to a ppropriate ly bill ce rtain
	6439	"BLD",1019 1,1,36,0)
	6440	subsets of billable events by correcting , automati ng, or enh ancing
	6441	"BLD",1019 1,1,37,0)
	6442	current Ve terans Hea lth Inform ation Syst ems and Te chnology A rchitectur e
	6443	"BLD",1019 1,1,38,0)
	6444	(VistA) sy stems.
	6445	"BLD",1019 1,1,39,0)
	6446
	6447	"BLD",1019 1,1,40,0)
	6448	NSR #20150 507
	6449	"BLD",1019 1,1,41,0)
	6450	The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs,
	6451	"BLD",1019 1,1,42,0)
	6452	as well. T his effort enables t he Departm ent of Vet erans Affa irs (VA)
	6453	"BLD",1019 1,1,43,0)
	6454	to improve revenue o peration f unctionali ty related to repaym ent plans,
	6455	"BLD",1019 1,1,44,0)
	6456	late charg e capture, bill susp ension rea sons, the billing of
	6457	"BLD",1019 1,1,45,0)
	6458	deactivate d provider s, and the display o f appeal r ights and
	6459	"BLD",1019 1,1,46,0)
	6460	responsibi lities on the Vetera ns Benefic iary trave l Bill of Collection s
	6461	"BLD",1019 1,1,47,0)
	6462	form. Imp lementatio n of the p roposed en hancements will make a
	6463	"BLD",1019 1,1,48,0)
	6464	significan t positive impact on stakehold ers and ta rget users .
	6465	"BLD",1019 1,1,49,0)
	6466
	6467	"BLD",1019 1,1,50,0)
	6468	NSR #20150 505
	6469	"BLD",1019 1,1,51,0)
	6470	The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to
	6471	"BLD",1019 1,1,52,0)
	6472	improve tr acking and reporting of revenu e, and wil l support revenue
	6473	"BLD",1019 1,1,53,0)
	6474	reporting business r ules and g uidelines.
	6475	"BLD",1019 1,1,54,0)
	6476
	6477	"BLD",1019 1,1,55,0)
	6478
	6479	"BLD",1019 1,1,56,0)
	6480	PRCA4.53 15 patch e nhancement s, pertine nt to the above NSRs , include:
	6481	"BLD",1019 1,1,57,0)
	6482
	6483	"BLD",1019 1,1,58,0)
	6484	1.) By mea ns of the new Enter / Edit Rep ayment Pla n option, the user
	6485	"BLD",1019 1,1,59,0)
	6486	will creat e the Repa yment Plan by debtor . Note: Th e 'Enter / Edit
	6487	"BLD",1019 1,1,60,0)
	6488	Repayment Plan' menu option na me will re place the 'Set up Re payment
	6489	"BLD",1019 1,1,61,0)
	6490	Plan' menu option na me.
	6491	"BLD",1019 1,1,62,0)
	6492
	6493	"BLD",1019 1,1,63,0)
	6494	2.) On the Enter / E dit Repaym ent Plan o ption, if the AR Deb tor has
	6495	"BLD",1019 1,1,64,0)
	6496	Active bil ls, the sy stem will now displa y a select able list of bills
	6497	"BLD",1019 1,1,65,0)
	6498	for the de btor.
	6499	"BLD",1019 1,1,66,0)
	6500
	6501	"BLD",1019 1,1,67,0)
	6502	3.) On the Enter / E dit Repaym ent Plan o ption, whe n displayi ng a list
	6503	"BLD",1019 1,1,68,0)
	6504	of Active bills for the Debtor , the syst em will di splay step s to the
	6505	"BLD",1019 1,1,69,0)
	6506	user to se t up the R epayment P lan.
	6507	"BLD",1019 1,1,70,0)
	6508
	6509	"BLD",1019 1,1,71,0)
	6510	4.) On the Enter /Ed it Repayme nt Plan op tion, once a Repayme nt Plan
	6511	"BLD",1019 1,1,72,0)
	6512	has been c reated or modified, the summar y of the R epayment P lan is
	6513	"BLD",1019 1,1,73,0)
	6514	displayed.
	6515	"BLD",1019 1,1,74,0)
	6516
	6517	"BLD",1019 1,1,75,0)
	6518	5.) On the Enter / E dit Repaym ent Plan o ption, the system ch ecks to
	6519	"BLD",1019 1,1,76,0)
	6520	see if a R epayment P lan has al ready been created f or the Vet eran.
	6521	"BLD",1019 1,1,77,0)
	6522
	6523	"BLD",1019 1,1,78,0)
	6524	6.) On the Enter / E dit Repaym ent Plan o ption, whe n choosing to Edit
	6525	"BLD",1019 1,1,79,0)
	6526	the Repaym ent Plan, all Active bills for the debto r will be displayed
	6527	"BLD",1019 1,1,80,0)
	6528	allowing t he user to add new A ctive bill s to the R epayment P lan as wel l
	6529	"BLD",1019 1,1,81,0)
	6530	as change the due da te of firs t payment and/or the repayment amount du e
	6531	"BLD",1019 1,1,82,0)
	6532	on the Rep ayment Pla n.
	6533	"BLD",1019 1,1,83,0)
	6534
	6535	"BLD",1019 1,1,84,0)
	6536	7.) On the Enter / E dit Repaym ent Plan o ption, if the Debtor does not
	6537	"BLD",1019 1,1,85,0)
	6538	have new A ctive bill s that can be added to the Rep ayment Pla n, the use r
	6539	"BLD",1019 1,1,86,0)
	6540	will proce ed to iden tify the r epayment a mount due and/or rep ayment
	6541	"BLD",1019 1,1,87,0)
	6542	amount due date on t he Repayme nt Plan.
	6543	"BLD",1019 1,1,88,0)
	6544
	6545	"BLD",1019 1,1,89,0)
	6546	8.) On the Enter / E dit Repaym ent Plan o ption, a d esignated identifier
	6547	"BLD",1019 1,1,90,0)
	6548	will signi fy when an Active bi ll is part of a Repa yment Plan .
	6549	"BLD",1019 1,1,91,0)
	6550
	6551	"BLD",1019 1,1,92,0)
	6552	9.) On the Enter / E dit Repaym ent Plan o ption, the system wi ll display
	6553	"BLD",1019 1,1,93,0)
	6554	previously made paym ents to th e Repaymen t Plan.
	6555	"BLD",1019 1,1,94,0)
	6556
	6557	"BLD",1019 1,1,95,0)
	6558	10.) On th e Enter / Edit Repay ment Plan option, th e User has the optio n
	6559	"BLD",1019 1,1,96,0)
	6560	to enter D ebtor Comm ents durin g the setu p process.
	6561	"BLD",1019 1,1,97,0)
	6562
	6563	"BLD",1019 1,1,98,0)
	6564	11.) The A R Clerk wi ll be able to select Suspended Type from the menu
	6565	"BLD",1019 1,1,99,0)
	6566	to display in the St atus Listi ng For Bil ls [PRCAL STATUS LIS T] report.
	6567	"BLD",1019 1,1,100,0)
	6568
	6569	"BLD",1019 1,1,101,0)
	6570	12.) Statu s Listing For Bills [PRCAL STA TUS LIST] report sha ll be
	6571	"BLD",1019 1,1,102,0)
	6572	modified t o incorpor ate reason for suspe nsion.
	6573	"BLD",1019 1,1,103,0)
	6574
	6575	"BLD",1019 1,1,104,0)
	6576	13.) Provi de the abi lity to lo ck the opt ion to upd ate late p ayment
	6577	"BLD",1019 1,1,105,0)
	6578	charges (I nterest/Ad min/Penalt y Rates [P RCAF U ADM IN.RATE]) with a new
	6579	"BLD",1019 1,1,106,0)
	6580	security k ey.
	6581	"BLD",1019 1,1,107,0)
	6582
	6583	"BLD",1019 1,1,108,0)
	6584	14.) The s ystem will allow the user to i dentify if the Bill of
	6585	"BLD",1019 1,1,109,0)
	6586	Collection s letter a pplies to Veterans B eneficiary Travel (F orm 1114).
	6587	"BLD",1019 1,1,110,0)
	6588
	6589	"BLD",1019 1,1,111,0)
	6590	15.) The s ystem will print the Notice of Rights an d Responsi bilities
	6591	"BLD",1019 1,1,112,0)
	6592	when the B ill of Col lections p ertains to Veterans Beneficiar y Travel.
	6593	"BLD",1019 1,1,113,0)
	6594
	6595	"BLD",1019 1,1,114,0)
	6596	16.) VistA AR Softwa re Package shall dis continue g eneration of the
	6597	"BLD",1019 1,1,115,0)
	6598	Mailman me ssage/bull etin, "ARD C Detail R eport for MON/ YYYY" , without
	6599	"BLD",1019 1,1,116,0)
	6600	interrupti ng any oth er transfe r data wit hin ARDC.
	6601	"BLD",1019 1,1,117,0)
	6602
	6603	"BLD",1019 1,1,118,0)
	6604	17.) The V istA AR So ftware Pac kage shall allow the generatio n of a
	6605	"BLD",1019 1,1,119,0)
	6606	report of bills cont aining the same info rmation as the disco ntinued
	6607	"BLD",1019 1,1,120,0)
	6608	"ARDC Deta il Report for MON/YY YY" with t he followi ng excepti ons/
	6609	"BLD",1019 1,1,121,0)
	6610	additions:
	6611	"BLD",1019 1,1,122,0)
	6612	Th e report s hall inclu de current status bi lls (New B ill, Activ e,
	6613	"BLD",1019 1,1,123,0)
	6614	Re turned for Amendment , Amended Bill, Open , and Susp ended bill s)
	6615	"BLD",1019 1,1,124,0)
	6616	on ly;
	6617	"BLD",1019 1,1,125,0)
	6618
	6619	"BLD",1019 1,1,126,0)
	6620	Th e report s hall inclu de a colum n for the Fund numbe r associat ed
	6621	"BLD",1019 1,1,127,0)
	6622	wi th each li ne item on the repor t; and
	6623	"BLD",1019 1,1,128,0)
	6624
	6625	"BLD",1019 1,1,129,0)
	6626	Th e report s hall inclu de a colum n for the RSC associ ated with
	6627	"BLD",1019 1,1,130,0)
	6628	ea ch line it em on the report.
	6629	"BLD",1019 1,1,131,0)
	6630
	6631	"BLD",1019 1,1,132,0)
	6632	18.) Curre ntly, when non-healt hcare debt of $25 or greater i s in a
	6633	"BLD",1019 1,1,133,0)
	6634	delinquent status fo r 180 days , VistA tr ansmits th is debt to TOP
	6635	"BLD",1019 1,1,134,0)
	6636	(via AITC and DMC) f or initiat ion of the standard collection process.
	6637	"BLD",1019 1,1,135,0)
	6638	To maintai n complian ce with Th e DATA Act of 2014, the 180-da y date
	6639	"BLD",1019 1,1,136,0)
	6640	parameter shall be c hanged to 120 days.
	6641	"BLD",1019 1,1,137,0)
	6642
	6643	"BLD",1019 1,1,138,0)
	6644	19.) A ne w audit tr ail is nee ded for de tailing ev ents or tr ansactions
	6645	"BLD",1019 1,1,139,0)
	6646	that have occurred o n healthca re debts r eferred fo r debt col lection, t o
	6647	"BLD",1019 1,1,140,0)
	6648	effectivel y support Veterans a nd reconci le account s.
	6649	"BLD",1019 1,1,141,0)
	6650
	6651	"BLD",1019 1,1,142,0)
	6652	20.) Vist A shall pr ovide enha nced repor ting capab ility, usa bility
	6653	"BLD",1019 1,1,143,0)
	6654	features, and additi onal data elements f or managin g healthca re debts
	6655	"BLD",1019 1,1,144,0)
	6656	referred f or debt co llection t o improve VHA's abil ity to pro vide suppo rt
	6657	"BLD",1019 1,1,145,0)
	6658	to Veteran s and mana ge account s.
	6659	"BLD",1019 1,1,146,0)
	6660
	6661	"BLD",1019 1,1,147,0)
	6662	21.) Crea te report to track s top/reacti vate debts . VistA sh all provid e
	6663	"BLD",1019 1,1,148,0)
	6664	a Stop/Rea ctivate re port to id entify hea lthcare de bts that a re placed
	6665	"BLD",1019 1,1,149,0)
	6666	in the cor responding status.
	6667	"BLD",1019 1,1,150,0)
	6668
	6669	"BLD",1019 1,1,151,0)
	6670	22.) Impr ove automa tion in ma nagement o f debt col lection. V istA shall
	6671	"BLD",1019 1,1,152,0)
	6672	utilize ex isting fun ctionality , such as List Manag er, and ot her
	6673	"BLD",1019 1,1,153,0)
	6674	automation capabilit ies to imp rove debt collection managemen t"
	6675	"BLD",1019 1,1,154,0)
	6676
	6677	"BLD",1019 1,1,155,0)
	6678	23.) The existing M edication Co-Pay Exe mption Rep ort [PRCAX CO-PAY
	6679	"BLD",1019 1,1,156,0)
	6680	EXEMPTION REPORT] sh all be mod ified with the follo wing field changes:
	6681	"BLD",1019 1,1,157,0)
	6682	Ch ange PT ID from full Social Se curity Num ber (SSN) to LastN +
	6683	"BLD",1019 1,1,158,0)
	6684	4SSN
	6685	"BLD",1019 1,1,159,0)
	6686	Ad d Rx#
	6687	"BLD",1019 1,1,160,0)
	6688	Ad d Drug Nam e (first 1 0 to 12 ch aracters)
	6689	"BLD",1019 1,1,161,0)
	6690	Ad d Fill/Ref ill Date
	6691	"BLD",1019 1,1,162,0)
	6692	Ad d Effectiv e Date of Exemption
	6693	"BLD",1019 1,1,163,0)
	6694
	6695	"BLD",1019 1,1,164,0)
	6696	24.) A ne w Third Pa rty Accoun ts Receiva ble catego ry called
	6697	"BLD",1019 1,1,165,0)
	6698	'EMERGENCY /HUMANITAR IAN REIMB. ' shall be created i n Accounts Receivabl es
	6699	"BLD",1019 1,1,166,0)
	6700	with the i nsurer as the respon sible part y.
	6701	"BLD",1019 1,1,167,0)
	6702
	6703	"BLD",1019 1,1,168,0)
	6704	25.) A new Third Par ty Account s Receivab le categor y called ' INELIGIBLE
	6705	"BLD",1019 1,1,169,0)
	6706	HOSP. REIM B' shall b e created in Account s Receivab les with t he insurer
	6707	"BLD",1019 1,1,170,0)
	6708	as the res ponsible p arty.
	6709	"BLD",1019 1,1,171,0)
	6710
	6711	"BLD",1019 1,1,172,0)
	6712	26.) A one -character "Type" fi eld shall be added t o the Clai ms Matchin g
	6713	"BLD",1019 1,1,173,0)
	6714	Report tha t will ind icate the third-part y claim ca re-type (" I" for
	6715	"BLD",1019 1,1,174,0)
	6716	Inpatient, "O" for O utpatient, "P" for P rosthetics , and "R" for
	6717	"BLD",1019 1,1,175,0)
	6718	Prescripti on
	6719	"BLD",1019 1,1,176,0)
	6720	[Rx]) on t he report of third-p arty bills .
	6721	"BLD",1019 1,1,177,0)
	6722
	6723	"BLD",1019 1,1,178,0)
	6724	27.) When a user gen erates a C laims Matc hing Repor t for a pa tient, all
	6725	"BLD",1019 1,1,179,0)
	6726	records fo r that pat ient are c urrently p roduced on the repor t. At
	6727	"BLD",1019 1,1,180,0)
	6728	times, use rs need to generate informatio n regardin g only cer tain types
	6729	"BLD",1019 1,1,181,0)
	6730	of care fo r a patien t. The sy stem shall allow the user to c hoose
	6731	"BLD",1019 1,1,182,0)
	6732	between pr oducing a Claims Mat ching Repo rt contain ing (1) al l records
	6733	"BLD",1019 1,1,183,0)
	6734	for a pati ent, or (2 ) only rec ords of a certain ca re type (" I" for
	6735	"BLD",1019 1,1,184,0)
	6736	Inpatient, "O" for O utpatient, "P" for P rosthetics , or "R" f or
	6737	"BLD",1019 1,1,185,0)
	6738	Prescripti on [Rx]).
	6739	"BLD",1019 1,1,186,0)
	6740
	6741	"BLD",1019 1,1,187,0)
	6742	28.) The C laims Matc hing Repor t, when ex ported, sh all be in a line
	6743	"BLD",1019 1,1,188,0)
	6744	format so that infor mation on the report may be ea sily expor ted to
	6745	"BLD",1019 1,1,189,0)
	6746	Microsoft Excel.
	6747	"BLD",1019 1,1,190,0)
	6748
	6749	"BLD",1019 1,1,191,0)
	6750
	6751	"BLD",1019 1,1,192,0)
	6752
	6753	"BLD",1019 1,1,193,0)
	6754	Concurrent Developme nt / Depen dencies:
	6755	"BLD",1019 1,1,194,0)
	6756	---------- ---------- ---------- --------
	6757	"BLD",1019 1,1,195,0)
	6758	N/A
	6759	"BLD",1019 1,1,196,0)
	6760
	6761	"BLD",1019 1,1,197,0)
	6762
	6763	"BLD",1019 1,1,198,0)
	6764	Patch Comp onents:
	6765	"BLD",1019 1,1,199,0)
	6766	---------- -------
	6767	"BLD",1019 1,1,200,0)
	6768
	6769	"BLD",1019 1,1,201,0)
	6770	Files & Fi elds Assoc iated:
	6771	"BLD",1019 1,1,202,0)
	6772
	6773	"BLD",1019 1,1,203,0)
	6774	File Name (Number) Field Na me (Number ) New/ Modified/D eleted
	6775	"BLD",1019 1,1,204,0)
	6776	---------- -------- -------- ---------- - ---- ---------- ------
	6777	"BLD",1019 1,1,205,0)
	6778	N/A
	6779	"BLD",1019 1,1,206,0)
	6780
	6781	"BLD",1019 1,1,207,0)
	6782	Options As sociated:
	6783	"BLD",1019 1,1,208,0)
	6784
	6785	"BLD",1019 1,1,209,0)
	6786	Option Nam e Type New/ Modified/D eleted
	6787	"BLD",1019 1,1,210,0)
	6788	---------- - ---- ---- ---------- ------
	6789	"BLD",1019 1,1,211,0)
	6790	PRCA ARDC REPORT ROUTINE NEW
	6791	"BLD",1019 1,1,212,0)
	6792
	6793	"BLD",1019 1,1,213,0)
	6794	Protocols Associated :
	6795	"BLD",1019 1,1,214,0)
	6796
	6797	"BLD",1019 1,1,215,0)
	6798	Protocol N ame New /Modified/ Deleted
	6799	"BLD",1019 1,1,216,0)
	6800	---------- --- --- ---------- -------
	6801	"BLD",1019 1,1,217,0)
	6802	N/A
	6803	"BLD",1019 1,1,218,0)
	6804
	6805	"BLD",1019 1,1,219,0)
	6806	Templates Associated :
	6807	"BLD",1019 1,1,220,0)
	6808
	6809	"BLD",1019 1,1,221,0)
	6810	Template N ame T ype File Name (Num ber) New/Mod/De l
	6811	"BLD",1019 1,1,222,0)
	6812	---------- --- - --- ---- ---------- ---- ---------- -
	6813	"BLD",1019 1,1,223,0)
	6814	N/A
	6815	"BLD",1019 1,1,224,0)
	6816
	6817	"BLD",1019 1,1,225,0)
	6818	New Servic e Requests (NSRs):
	6819	"BLD",1019 1,1,226,0)
	6820	---------- ---------- --------
	6821	"BLD",1019 1,1,227,0)
	6822	20150505 - Revenue R eporting E nhancement s
	6823	"BLD",1019 1,1,228,0)
	6824	20150506 - Revenue E ligibility Enhanceme nts
	6825	"BLD",1019 1,1,229,0)
	6826	20150507 - Revenue O perations Enhancemen ts
	6827	"BLD",1019 1,1,230,0)
	6828
	6829	"BLD",1019 1,1,231,0)
	6830
	6831	"BLD",1019 1,1,232,0)
	6832	Patient Sa fety Issue s (PSIs):
	6833	"BLD",1019 1,1,233,0)
	6834	---------- ---------- ----------
	6835	"BLD",1019 1,1,234,0)
	6836	N/A
	6837	"BLD",1019 1,1,235,0)
	6838
	6839	"BLD",1019 1,1,236,0)
	6840
	6841	"BLD",1019 1,1,237,0)
	6842	Remedy Tic ket(s) & O verviews:
	6843	"BLD",1019 1,1,238,0)
	6844	---------- ---------- ---------
	6845	"BLD",1019 1,1,239,0)
	6846	N/A
	6847	"BLD",1019 1,1,240,0)
	6848
	6849	"BLD",1019 1,1,241,0)
	6850	Test Sites :
	6851	"BLD",1019 1,1,242,0)
	6852	----------
	6853	"BLD",1019 1,1,243,0)
	6854	Durham VAM C
	6855	"BLD",1019 1,1,244,0)
	6856
	6857	"BLD",1019 1,1,245,0)
	6858
	6859	"BLD",1019 1,1,246,0)
	6860	Software a nd Documen tation Ret rieval Ins tructions:
	6861	"BLD",1019 1,1,247,0)
	6862	---------- ---------- ---------- ---------- ---------- --
	6863	"BLD",1019 1,1,248,0)
	6864	Patches fo r this ins tallation are combin ed in host file
	6865	"BLD",1019 1,1,249,0)
	6866	IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
	6867	"BLD",1019 1,1,250,0)
	6868
	6869	"BLD",1019 1,1,251,0)
	6870	Installati on of this host file should be coordinat ed among t he package s
	6871	"BLD",1019 1,1,252,0)
	6872	affected s ince only one instal lation is necessary.
	6873	"BLD",1019 1,1,253,0)
	6874
	6875	"BLD",1019 1,1,254,0)
	6876	The patche s are:
	6877	"BLD",1019 1,1,255,0)
	6878
	6879	"BLD",1019 1,1,256,0)
	6880	IB2. 0568
	6881	"BLD",1019 1,1,257,0)
	6882	PRCA* 4.5*315
	6883	"BLD",1019 1,1,258,0)
	6884	PSO7 .0463
	6885	"BLD",1019 1,1,259,0)
	6886
	6887	"BLD",1019 1,1,260,0)
	6888
	6889	"BLD",1019 1,1,261,0)
	6890	Sites may retrieve t he KIDS bu ild in one of the fo llowing wa ys:
	6891	"BLD",1019 1,1,262,0)
	6892
	6893	"BLD",1019 1,1,263,0)
	6894	(1) The pr eferred me thod is to FTP the f iles from
	6895	"BLD",1019 1,1,264,0)
	6896	download.D NS .D NS
	6897	"BLD",1019 1,1,265,0)
	6898	which will transmit the files from the f irst avail able FTP s erver.
	6899	"BLD",1019 1,1,266,0)
	6900
	6901	"BLD",1019 1,1,267,0)
	6902	(2) Sites may also e lect to re trieve the patch dir ectly from a specifi c
	6903	"BLD",1019 1,1,268,0)
	6904	server as follows:
	6905	"BLD",1019 1,1,269,0)
	6906
	6907	"BLD",1019 1,1,270,0)
	6908	OIFO FTP ADDRE SS DIRECTORY
	6909	"BLD",1019 1,1,271,0)
	6910	-------- ------ --------- ---------- ----- ---------- --------
	6911	"BLD",1019 1,1,272,0)
	6912	Albany ftp.fo-alb any. URL anonymous. software
	6913	"BLD",1019 1,1,273,0)
	6914	Hines ftp. DNS . URL anonymous. software
	6915	"BLD",1019 1,1,274,0)
	6916	Salt Lake City ftp.fo-slc . URL anonymous. software
	6917	"BLD",1019 1,1,275,0)
	6918
	6919	"BLD",1019 1,1,276,0)
	6920
	6921	"BLD",1019 1,1,277,0)
	6922	Sites may retrieve d ocumentati on directl y using Se cure File Transfer
	6923	"BLD",1019 1,1,278,0)
	6924	Protocol ( SFTP) from the ANONY MOUS.SOFTW ARE direct ory at the following
	6925	"BLD",1019 1,1,279,0)
	6926	OI Field O ffices:
	6927	"BLD",1019 1,1,280,0)
	6928
	6929	"BLD",1019 1,1,281,0)
	6930	Albany: fo-albany. URL
	6931	"BLD",1019 1,1,282,0)
	6932	Hines: DNS .U RL
	6933	"BLD",1019 1,1,283,0)
	6934	Salt Lake City: fo-slc. URL
	6935	"BLD",1019 1,1,284,0)
	6936
	6937	"BLD",1019 1,1,285,0)
	6938	Documentat ion can al so be foun d on the V A Software Documenta tion
	6939	"BLD",1019 1,1,286,0)
	6940	Library at :
	6941	"BLD",1019 1,1,287,0)
	6942	http:// URL /
	6943	"BLD",1019 1,1,288,0)
	6944
	6945	"BLD",1019 1,1,289,0)
	6946	Title File Na me FTP Mod e
	6947	"BLD",1019 1,1,290,0)
	6948	---------- ---------- ---------- ---------- ---------- ---------- ---------- -
	6949	"BLD",1019 1,1,291,0)
	6950	Accounts R eceivable Technical Manual/Sec urity Guid e
	6951	"BLD",1019 1,1,292,0)
	6952	prca_4_ 5_tm+r0515 .doc Binar y
	6953	"BLD",1019 1,1,293,0)
	6954	Accounts R eceivable Deployment , Installa tion,
	6955	"BLD",1019 1,1,294,0)
	6956	Back- Out, and R ollback Gu ide
	6957	"BLD",1019 1,1,295,0)
	6958	FY16Re venueARVIP _Deploymen t_Installa tion_Guide .doc Binar y
	6959	"BLD",1019 1,1,296,0)
	6960
	6961	"BLD",1019 1,1,297,0)
	6962
	6963	"BLD",1019 1,1,298,0)
	6964
	6965	"BLD",1019 1,1,299,0)
	6966	Patch Inst allation:
	6967	"BLD",1019 1,1,300,0)
	6968
	6969	"BLD",1019 1,1,301,0)
	6970	Pre/Post I nstallatio n Overview :
	6971	"BLD",1019 1,1,302,0)
	6972	---------- ---------- ---------- -
	6973	"BLD",1019 1,1,303,0)
	6974	The post i nstallatio n routine, PRCA315P, is not au tomaticall y deleted
	6975	"BLD",1019 1,1,304,0)
	6976	as part of the insta llation pr ocess. You may delet e it after
	6977	"BLD",1019 1,1,305,0)
	6978	installati on if you desire.
	6979	"BLD",1019 1,1,306,0)
	6980
	6981	"BLD",1019 1,1,307,0)
	6982	Pre-Instal lation Ins tructions:
	6983	"BLD",1019 1,1,308,0)
	6984	---------- ---------- ----------
	6985	"BLD",1019 1,1,309,0)
	6986	N/A
	6987	"BLD",1019 1,1,310,0)
	6988
	6989	"BLD",1019 1,1,311,0)
	6990	Installati on Instruc tions:
	6991	"BLD",1019 1,1,312,0)
	6992	---------- ---------- ------
	6993	"BLD",1019 1,1,313,0)
	6994	This proce ss will in stall new and update d routines and other
	6995	"BLD",1019 1,1,314,0)
	6996	components listed ab ove. There is a post -install r outine tha t will add
	6997	"BLD",1019 1,1,315,0)
	6998	entries to a number of files.
	6999	"BLD",1019 1,1,316,0)
	7000
	7001	"BLD",1019 1,1,317,0)
	7002	The patch will be re leased in conjunctio n with an Integrated Billing
	7003	"BLD",1019 1,1,318,0)
	7004	patch, IB* 4.5568, a nd an Outp atient Pha rmacy patc h, PSO7.0 *463.
	7005	"BLD",1019 1,1,319,0)
	7006
	7007	"BLD",1019 1,1,320,0)
	7008	****** ****** ** NOT E **** ****** ****
	7009	"BLD",1019 1,1,321,0)
	7010	IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS
	7011	"BLD",1019 1,1,322,0)
	7012	AN EDITE D ERROR WI LL OCCUR.
	7013	"BLD",1019 1,1,323,0)
	7014	The patc h should b e installe d when NO Outpatient
	7015	"BLD",1019 1,1,324,0)
	7016	Pharmacy users are on the sy stem.
	7017	"BLD",1019 1,1,325,0)
	7018	****** ****** ****** ****** ****** ****
	7019	"BLD",1019 1,1,326,0)
	7020
	7021	"BLD",1019 1,1,327,0)
	7022	Installat ion will t ake less t han 1 minu te.
	7023	"BLD",1019 1,1,328,0)
	7024
	7025	"BLD",1019 1,1,329,0)
	7026	Suggested time to i nstall: no n-peak req uirement h ours.
	7027	"BLD",1019 1,1,330,0)
	7028
	7029	"BLD",1019 1,1,331,0)
	7030
	7031	"BLD",1019 1,1,332,0)
	7032	1. Obtai n the file IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID
	7033	"BLD",1019 1,1,333,0)
	7034
	7035	"BLD",1019 1,1,334,0)
	7036	2. From the Kernel Installat ion & Dist ribution S ystem menu , select
	7037	"BLD",1019 1,1,335,0)
	7038	the I nstallatio n menu.
	7039	"BLD",1019 1,1,336,0)
	7040
	7041	"BLD",1019 1,1,337,0)
	7042	3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
	7043	"BLD",1019 1,1,338,0)
	7044	promp ted to Ent er a Host File name. You may need to ap pend a
	7045	"BLD",1019 1,1,339,0)
	7046	direc tory name.
	7047	"BLD",1019 1,1,340,0)
	7048
	7049	"BLD",1019 1,1,341,0)
	7050	4. From this menu, you may s elect to u se the fol lowing opt ions
	7051	"BLD",1019 1,1,342,0)
	7052	(when prompted for INSTAL L NAME, en ter IB2.0 568):
	7053	"BLD",1019 1,1,343,0)
	7054	a . Verify Checksums in Transpo rt Global - This opt ion will
	7055	"BLD",1019 1,1,344,0)
	7056	allow y ou to ensu re the int egrity of the routin es that ar e
	7057	"BLD",1019 1,1,345,0)
	7058	in the transport global.
	7059	"BLD",1019 1,1,346,0)
	7060	b . Print T ransport G lobal - Th is option will allow you to
	7061	"BLD",1019 1,1,347,0)
	7062	view th e componen ts of the KIDS build .
	7063	"BLD",1019 1,1,348,0)
	7064	c . Compare Transport Global to Current S ystem - Th is option
	7065	"BLD",1019 1,1,349,0)
	7066	will al low you to view all changes th at will be made when
	7067	"BLD",1019 1,1,350,0)
	7068	this pa tch is ins talled. I t compares all compo nents of
	7069	"BLD",1019 1,1,351,0)
	7070	this pa tch (routi nes, DD's, templates , etc.).
	7071	"BLD",1019 1,1,352,0)
	7072	d . Backup a Transpor t Global - This opti on will cr eate a
	7073	"BLD",1019 1,1,353,0)
	7074	backup message of any routi nes export ed with th is patch.
	7075	"BLD",1019 1,1,354,0)
	7076	It will not backu p any othe r changes such as DD 's or
	7077	"BLD",1019 1,1,355,0)
	7078	templat es.
	7079	"BLD",1019 1,1,356,0)
	7080
	7081	"BLD",1019 1,1,357,0)
	7082	5. When prompted " Want KIDS to INHIBIT LOGONs du ring the i nstall?
	7083	"BLD",1019 1,1,358,0)
	7084	NO//" respond N O.
	7085	"BLD",1019 1,1,359,0)
	7086
	7087	"BLD",1019 1,1,360,0)
	7088	6. When prompted " Want to DI SABLE Sche duled Opti ons, Menu Options,
	7089	"BLD",1019 1,1,361,0)
	7090	and P rotocols? NO//" resp ond NO.
	7091	"BLD",1019 1,1,362,0)
	7092
	7093	"BLD",1019 1,1,363,0)
	7094
	7095	"BLD",1019 1,1,364,0)
	7096
	7097	"BLD",1019 1,1,365,0)
	7098	Post-Insta llation In structions :
	7099	"BLD",1019 1,1,366,0)
	7100	---------- ---------- ---------- -
	7101	"BLD",1019 1,1,367,0)
	7102	There are no special tasks to perform af ter this p atch insta llation.
	7103	"BLD",1019 1,4,0)
	7104	^9.64PA^^0
	7105	"BLD",1019 1,6.3)
	7106	2
	7107	"BLD",1019 1,"ABPKG")
	7108	n
	7109	"BLD",1019 1,"INID")
	7110	^n
	7111	"BLD",1019 1,"INIT")
	7112	PRCA315P
	7113	"BLD",1019 1,"KRN",0)
	7114	^9.67PA^77 9.2^20
	7115	"BLD",1019 1,"KRN",.4 ,0)
	7116	.4
	7117	"BLD",1019 1,"KRN",.4 ,"NM",0)
	7118	^9.68A^2^2
	7119	"BLD",1019 1,"KRN",.4 ,"NM",1,0)
	7120	PRCA TCSP RECALLB FILE #430 ^430^0
	7121	"BLD",1019 1,"KRN",.4 ,"NM",2,0)
	7122	PRCA TCSP RECALLD FILE #430 ^430^0
	7123	"BLD",1019 1,"KRN",.4 ,"NM","B", "PRCA TCSP RECALLB FILE #43 0",1)
	7124
	7125	"BLD",1019 1,"KRN",.4 ,"NM","B", "PRCA TCSP RECALLD FILE #43 0",2)
	7126
	7127	"BLD",1019 1,"KRN",.4 01,0)
	7128	.401
	7129	"BLD",1019 1,"KRN",.4 02,0)
	7130	.402
	7131	"BLD",1019 1,"KRN",.4 03,0)
	7132	.403
	7133	"BLD",1019 1,"KRN",.5 ,0)
	7134	.5
	7135	"BLD",1019 1,"KRN",.8 4,0)
	7136	.84
	7137	"BLD",1019 1,"KRN",3. 6,0)
	7138	3.6
	7139	"BLD",1019 1,"KRN",3. 8,0)
	7140	3.8
	7141	"BLD",1019 1,"KRN",9. 2,0)
	7142	9.2
	7143	"BLD",1019 1,"KRN",9. 8,0)
	7144	9.8
	7145	"BLD",1019 1,"KRN",9. 8,"NM",0)
	7146	^9.68A^16^ 16
	7147	"BLD",1019 1,"KRN",9. 8,"NM",1,0 )
	7148	PRCAXP^^0^ B23479334
	7149	"BLD",1019 1,"KRN",9. 8,"NM",2,0 )
	7150	RCDPRTP^^0 ^B12581802
	7151	"BLD",1019 1,"KRN",9. 8,"NM",3,0 )
	7152	RCDPRTP0^^ 0^B3949255 9
	7153	"BLD",1019 1,"KRN",9. 8,"NM",4,0 )
	7154	RCDPRTP2^^ 0^B1805802 8
	7155	"BLD",1019 1,"KRN",9. 8,"NM",5,0 )
	7156	RCRJRCOU^^ 0^B3147503 6
	7157	"BLD",1019 1,"KRN",9. 8,"NM",6,0 )
	7158	RCRJRCOR^^ 0^B6695057 6
	7159	"BLD",1019 1,"KRN",9. 8,"NM",7,0 )
	7160	RCMSITE^^0 ^B10167680
	7161	"BLD",1019 1,"KRN",9. 8,"NM",8,0 )
	7162	PRCABIL1^^ 0^B5441112 6
	7163	"BLD",1019 1,"KRN",9. 8,"NM",9,0 )
	7164	PRCABD^^0^ B17130552
	7165	"BLD",1019 1,"KRN",9. 8,"NM",10, 0)
	7166	RCDPRTEX^^ 0^B265762
	7167	"BLD",1019 1,"KRN",9. 8,"NM",11, 0)
	7168	PRCAPCL^^0 ^B41532110
	7169	"BLD",1019 1,"KRN",9. 8,"NM",12, 0)
	7170	RCTCSP1^^0 ^B38198129 6
	7171	"BLD",1019 1,"KRN",9. 8,"NM",13, 0)
	7172	RCTCSJR^^0 ^B11983636 1
	7173	"BLD",1019 1,"KRN",9. 8,"NM",14, 0)
	7174	RCTCSP2^^0 ^B12290617 4
	7175	"BLD",1019 1,"KRN",9. 8,"NM",15, 0)
	7176	RCTCSP4^^0 ^B75717092
	7177	"BLD",1019 1,"KRN",9. 8,"NM",16, 0)
	7178	RCTCSPU^^0 ^B55616924
	7179	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCABD", 9)
	7180
	7181	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCABIL1 ",8)
	7182
	7183	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAPCL" ,11)
	7184
	7185	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAXP", 1)
	7186
	7187	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPRTEX ",10)
	7188
	7189	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPRTP" ,2)
	7190
	7191	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPRTP0 ",3)
	7192
	7193	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPRTP2 ",4)
	7194
	7195	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCMSITE" ,7)
	7196
	7197	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCRJRCOR ",6)
	7198
	7199	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCRJRCOU ",5)
	7200
	7201	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSJR" ,13)
	7202
	7203	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP1" ,12)
	7204
	7205	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP2" ,14)
	7206
	7207	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP4" ,15)
	7208
	7209	"BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSPU" ,16)
	7210
	7211	"BLD",1019 1,"KRN",19 ,0)
	7212	19
	7213	"BLD",1019 1,"KRN",19 ,"NM",0)
	7214	^9.68A^4^4
	7215	"BLD",1019 1,"KRN",19 ,"NM",1,0)
	7216	PRCA ARDC REPORT^^0
	7217	"BLD",1019 1,"KRN",19 ,"NM",2,0)
	7218	PRCH RECON CILE MENU^ ^0
	7219	"BLD",1019 1,"KRN",19 ,"NM",3,0)
	7220	RCTCSP MEN U^^0
	7221	"BLD",1019 1,"KRN",19 ,"NM",4,0)
	7222	RCTCSP STO P REACTIVA TE REPORT^ ^0
	7223	"BLD",1019 1,"KRN",19 ,"NM","B", "PRCA ARDC REPORT",1 )
	7224
	7225	"BLD",1019 1,"KRN",19 ,"NM","B", "PRCH RECO NCILE MENU ",2)
	7226
	7227	"BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP ME NU",3)
	7228
	7229	"BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP ST OP REACTIV ATE REPORT ",4)
	7230
	7231	"BLD",1019 1,"KRN",19 .1,0)
	7232	19.1
	7233	"BLD",1019 1,"KRN",19 .1,"NM",0)
	7234	^9.68A^1^1
	7235	"BLD",1019 1,"KRN",19 .1,"NM",1, 0)
	7236	PRCAF LATE CHARGES^^ 0
	7237	"BLD",1019 1,"KRN",19 .1,"NM","B ","PRCAF L ATE CHARGE S",1)
	7238
	7239	"BLD",1019 1,"KRN",10 1,0)
	7240	101
	7241	"BLD",1019 1,"KRN",40 9.61,0)
	7242	409.61
	7243	"BLD",1019 1,"KRN",77 1,0)
	7244	771
	7245	"BLD",1019 1,"KRN",77 9.2,0)
	7246	779.2
	7247	"BLD",1019 1,"KRN",87 0,0)
	7248	870
	7249	"BLD",1019 1,"KRN",89 89.51,0)
	7250	8989.51
	7251	"BLD",1019 1,"KRN",89 89.52,0)
	7252	8989.52
	7253	"BLD",1019 1,"KRN",89 94,0)
	7254	8994
	7255	"BLD",1019 1,"KRN","B ",.4,.4)
	7256
	7257	"BLD",1019 1,"KRN","B ",.401,.40 1)
	7258
	7259	"BLD",1019 1,"KRN","B ",.402,.40 2)
	7260
	7261	"BLD",1019 1,"KRN","B ",.403,.40 3)
	7262
	7263	"BLD",1019 1,"KRN","B ",.5,.5)
	7264
	7265	"BLD",1019 1,"KRN","B ",.84,.84)
	7266
	7267	"BLD",1019 1,"KRN","B ",3.6,3.6)
	7268
	7269	"BLD",1019 1,"KRN","B ",3.8,3.8)
	7270
	7271	"BLD",1019 1,"KRN","B ",9.2,9.2)
	7272
	7273	"BLD",1019 1,"KRN","B ",9.8,9.8)
	7274
	7275	"BLD",1019 1,"KRN","B ",19,19)
	7276
	7277	"BLD",1019 1,"KRN","B ",19.1,19. 1)
	7278
	7279	"BLD",1019 1,"KRN","B ",101,101)
	7280
	7281	"BLD",1019 1,"KRN","B ",409.61,4 09.61)
	7282
	7283	"BLD",1019 1,"KRN","B ",771,771)
	7284
	7285	"BLD",1019 1,"KRN","B ",779.2,77 9.2)
	7286
	7287	"BLD",1019 1,"KRN","B ",870,870)
	7288
	7289	"BLD",1019 1,"KRN","B ",8989.51, 8989.51)
	7290
	7291	"BLD",1019 1,"KRN","B ",8989.52, 8989.52)
	7292
	7293	"BLD",1019 1,"KRN","B ",8994,899 4)
	7294
	7295	"BLD",1019 1,"QDEF")
	7296	^^^^NO^^^^ NO^^NO
	7297	"BLD",1019 1,"QUES",0 )
	7298	^9.62^^
	7299	"BLD",1019 1,"REQB",0 )
	7300	^9.611^8^8
	7301	"BLD",1019 1,"REQB",1 ,0)
	7302	PRCA4.52 39^2
	7303	"BLD",1019 1,"REQB",2 ,0)
	7304	PRCA4.51 03^2
	7305	"BLD",1019 1,"REQB",3 ,0)
	7306	PRCA4.51 51^1
	7307	"BLD",1019 1,"REQB",4 ,0)
	7308	PRCA4.51 86^1
	7309	"BLD",1019 1,"REQB",5 ,0)
	7310	PRCA4.52 76^1
	7311	"BLD",1019 1,"REQB",6 ,0)
	7312	PRCA4.53 03^1
	7313	"BLD",1019 1,"REQB",7 ,0)
	7314	PRCA4.52 33^1
	7315	"BLD",1019 1,"REQB",8 ,0)
	7316	PRCA4.52 98^1
	7317	"BLD",1019 1,"REQB"," B","PRCA4 .5103",2)
	7318
	7319	"BLD",1019 1,"REQB"," B","PRCA4 .5151",3)
	7320
	7321	"BLD",1019 1,"REQB"," B","PRCA4 .5186",4)
	7322
	7323	"BLD",1019 1,"REQB"," B","PRCA4 .5233",7)
	7324
	7325	"BLD",1019 1,"REQB"," B","PRCA4 .5239",1)
	7326
	7327	"BLD",1019 1,"REQB"," B","PRCA4 .5276",5)
	7328
	7329	"BLD",1019 1,"REQB"," B","PRCA4 .5298",8)
	7330
	7331	"BLD",1019 1,"REQB"," B","PRCA4 .5303",6)
	7332
	7333	"INIT")
	7334	PRCA315P
	7335	"KRN",.4,1 554,-1)
	7336	0^1
	7337	"KRN",.4,1 554,0)
	7338	PRCA TCSP RECALLB^31 70119.1538 ^^430^^^31 70130
	7339	"KRN",.4,1 554,"%D",0 )
	7340	^^2^2^3150 730^^
	7341	"KRN",.4,1 554,"%D",1 ,0)
	7342	This print template supports t he Cross-S ervicing
	7343	"KRN",.4,1 554,"%D",2 ,0)
	7344	Recall Rep ort sorted by bill n umber.
	7345	"KRN",.4,1 554,"DXS", 1,9)
	7346	S DEBTOR=$ P($G(^PRCA (430,D0,0) ),U,9),X=$ E($$SSN^RC FN01($P(^R CD(340,DEB TOR,0),"^"
	7347	)),6,9),X= $S(X<0:"", 1:X) W X
	7348	"KRN",.4,1 554,"F",1)
	7349	.01;L11;C1 //~9;L18;C 14//~
	7350	"KRN",.4,1 554,"F",2)
	7351	X DXS(1,9) ;L5;C34;Z; "S DEBTOR= $P($G(^PRC A(430,D0,0 )),U,9),X= $E($$SSN^R CFN01($P(^
	7352	RCD(340,DE BTOR,0),"^ ")),6,9),X =$S(X<0:"" ,1:X) W X" ~155;R8;C4 0//~
	7353	"KRN",.4,1 554,"F",3)
	7354	S DIP(1)=$ S($D(^PRCA (430,D0,15 )):^(15),1 :"") S X=$ P(DIP(1),U ,3) S:X X= $E(X,4,5)_
	7355	"/"_$E(X,6 ,7)_"/"_$E (X,2,3) W X K DIP;Z; "NUMDATE(T CSP RECALL EFF. DATE )"~
	7356	"KRN",.4,1 554,"F",4)
	7357	S DIP(1)=$ S($D(^PRCA (430,D0,15 )):^(15),1 :"") S X=$ P(DIP(1),U ,4),X=X W X K DIP;L2
	7358	;C64//;Z;" INTERNAL(T CSP RECALL REASON)"~ W "-";X//; Z;"W "-""~
	7359	"KRN",.4,1 554,"F",5)
	7360	154;X;L10; C67//~
	7361	"KRN",.4,1 554,"H")
	7362	ACCOUNTS R ECEIVABLE LIST
	7363	"KRN",.4,1 555,-1)
	7364	0^2
	7365	"KRN",.4,1 555,0)
	7366	PRCA TCSP RECALLD^31 70119.1537 ^^430^^^31 70121
	7367	"KRN",.4,1 555,"%D",0 )
	7368	^^2^2^3150 730^^
	7369	"KRN",.4,1 555,"%D",1 ,0)
	7370	This print template supports t he Cross-S ervicing
	7371	"KRN",.4,1 555,"%D",2 ,0)
	7372	Recall Rep ort sorted by debtor .
	7373	"KRN",.4,1 555,"DXS", 1,9)
	7374	S DEBTOR=$ P($G(^PRCA (430,D0,0) ),U,9),X=$ E($$SSN^RC FN01($P(^R CD(340,DEB TOR,0),"^"
	7375	)),6,9),X= $S(X<0:"", 1:X) W X
	7376	"KRN",.4,1 555,"F",1)
	7377	9;L18;C1// ~.01;L11;C 21//~
	7378	"KRN",.4,1 555,"F",2)
	7379	X DXS(1,9) ;L5;C34;Z; "S DEBTOR= $P($G(^PRC A(430,D0,0 )),U,9),X= $E($$SSN^R CFN01($P(^
	7380	RCD(340,DE BTOR,0),"^ ")),6,9),X =$S(X<0:"" ,1:X) W X" ~155;R8;C4 0//~
	7381	"KRN",.4,1 555,"F",3)
	7382	S DIP(1)=$ S($D(^PRCA (430,D0,15 )):^(15),1 :"") S X=$ P(DIP(1),U ,3) S:X X= $E(X,4,5)_
	7383	"/"_$E(X,6 ,7)_"/"_$E (X,2,3) W X K DIP;Z; "NUMDATE(T CSP RECALL EFF. DATE )"~
	7384	"KRN",.4,1 555,"F",4)
	7385	S DIP(1)=$ S($D(^PRCA (430,D0,15 )):^(15),1 :"") S X=$ P(DIP(1),U ,4),X=X W X K DIP;L2
	7386	;C64//;Z;" INTERNAL(T CSP RECALL REASON)"~ W "-";X//; Z;"W "-""~
	7387	"KRN",.4,1 555,"F",5)
	7388	154;X;L10; C67//~
	7389	"KRN",.4,1 555,"H")
	7390	ACCOUNTS R ECEIVABLE LIST
	7391	"KRN",19,7 337,-1)
	7392	0^2
	7393	"KRN",19,7 337,0)
	7394	PRCH RECON CILE MENU^ Reconcilia tion Menu^ ^M^^^^^^^^ IFCAP
	7395	"KRN",19,7 337,1,0)
	7396	^^3^3^2970 509^^^^
	7397	"KRN",19,7 337,1,1,0)
	7398	This menu contains t he purchas e card opt ions to
	7399	"KRN",19,7 337,1,2,0)
	7400	reconcile an order, remove a r econciliat ion, and
	7401	"KRN",19,7 337,1,3,0)
	7402	to display the ET-FM S document .
	7403	"KRN",19,7 337,10,0)
	7404	^19.01IP^5 ^5
	7405	"KRN",19,7 337,10,5,0 )
	7406	11653
	7407	"KRN",19,7 337,10,5," ^")
	7408	PRCA ARDC REPORT
	7409	"KRN",19,7 337,99)
	7410	64300,4099 0
	7411	"KRN",19,7 337,"U")
	7412	RECONCILIA TION MENU
	7413	"KRN",19,1 1653,-1)
	7414	0^1
	7415	"KRN",19,1 1653,0)
	7416	PRCA ARDC REPORT^ARD C Detail R eport^^R^^ ^^^^^^ACCO UNTS RECEI VABLE
	7417	"KRN",19,1 1653,1,0)
	7418	^^2^2^3161 003^
	7419	"KRN",19,1 1653,1,1,0 )
	7420	This repor t was gene rated from the month ly backgou nd proces and genera ted
	7421	"KRN",19,1 1653,1,2,0 )
	7422	a MailMan message. It can now only be r an manuall y through this optio n.
	7423	"KRN",19,1 1653,10.1)
	7424	ARDC Detai ls
	7425	"KRN",19,1 1653,25)
	7426	START^RCRJ RCOU
	7427	"KRN",19,1 1653,"U")
	7428	ARDC DETAI L REPORT
	7429	"KRN",19,1 1797,-1)
	7430	0^3
	7431	"KRN",19,1 1797,0)
	7432	RCTCSP MEN U^Cross-Se rvicing Me nu^^M^^^^^ ^^^
	7433	"KRN",19,1 1797,1,0)
	7434	^19.06^2^2 ^3170206^^ ^^
	7435	"KRN",19,1 1797,1,1,0 )
	7436	This menu is placed on the AR Supervisor 's Menu. It contain s
	7437	"KRN",19,1 1797,1,2,0 )
	7438	options f or Cross-S ervicing.
	7439	"KRN",19,1 1797,10,0)
	7440	^19.01IP^1 1^11
	7441	"KRN",19,1 1797,10,11 ,0)
	7442	11807
	7443	"KRN",19,1 1797,10,11 ,"^")
	7444	RCTCSP STO P REACTIVA TE REPORT
	7445	"KRN",19,1 1797,99)
	7446	64320,3860 4
	7447	"KRN",19,1 1797,"U")
	7448	CROSS-SERV ICING MENU
	7449	"KRN",19,1 1807,-1)
	7450	0^4
	7451	"KRN",19,1 1807,0)
	7452	RCTCSP STO P REACTIVA TE REPORT^ Cross-Serv icing Stop Reactivat e Report^^ R^^^^^^^^
	7453	"KRN",19,1 1807,1,0)
	7454	^^3^3^3170 206^
	7455	"KRN",19,1 1807,1,1,0 )
	7456	The Cross- Servicing Stop React ivate Repo rt lists t he bills t hat have
	7457	"KRN",19,1 1807,1,2,0 )
	7458	been stopp ed from Cr oss-Servic ing. The report has three sor t options:
	7459	"KRN",19,1 1807,1,3,0 )
	7460	1.) Bill N umber, 2.) Debtor Na me 3.) Dat e of Stop
	7461	"KRN",19,1 1807,25)
	7462	EN^RCTCSP4
	7463	"KRN",19,1 1807,"U")
	7464	CROSS-SERV ICING STOP REACTIVAT
	7465	"KRN",19.1 ,617,-1)
	7466	0^1
	7467	"KRN",19.1 ,617,0)
	7468	PRCAF LATE CHARGES
	7469	"KRN",19.1 ,617,1,0)
	7470	^^2^2^3161 116^
	7471	"KRN",19.1 ,617,1,1,0 )
	7472	This is a key for th e AR actio n in PRCAF U ADMIN.R ATE to all ow edits
	7473	"KRN",19.1 ,617,1,2,0 )
	7474	to the Int erest/Admi n and Pena lty Rates.
	7475	"MBREQ")
	7476	0
	7477	"ORD",3,19 .1)
	7478	19.1;3;;;K EY^XPDTA1; KEYF1^XPDI A1;KEYE1^X PDIA1;KEYF 2^XPDIA1;; KEYDEL^XPD IA1
	7479	"ORD",3,19 .1,0)
	7480	SECURITY K EY
	7481	"ORD",5,.4 )
	7482	.4;5;;;EDE OUT^DIFROM SO(.4,DA," ",XPDA);FP RE^DIFROMS I(.4,"",XP DA);EPRE^D IFROMSI(.4
	7483	,DA,$E("N" ,$G(XPDNEW )),XPDA,"" ,OLDA);;EP OST^DIFROM SI(.4,DA," ",XPDA);DE L^DIFROMSK
	7484	(.4,"",%)
	7485	"ORD",5,.4 ,0)
	7486	PRINT TEMP LATE
	7487	"ORD",18,1 9)
	7488	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
	7489	"ORD",18,1 9,0)
	7490	OPTION
	7491	"PKG",53,- 1)
	7492	1^1
	7493	"PKG",53,0 )
	7494	ACCOUNTS R ECEIVABLE^ PRCA^FMS
	7495	"PKG",53,2 0,0)
	7496	^9.402P^1^ 1
	7497	"PKG",53,2 0,1,0)
	7498	2^^PRCAMRG
	7499	"PKG",53,2 0,1,1)
	7500
	7501	"PKG",53,2 0,"B",2,1)
	7502
	7503	"PKG",53,2 2,0)
	7504	^9.49I^1^1
	7505	"PKG",53,2 2,1,0)
	7506	4.5^305111 9^2960627
	7507	"PKG",53,2 2,1,"PAH", 1,0)
	7508	315^317020 6
	7509	"PKG",53,2 2,1,"PAH", 1,1,0)
	7510	^^367^367^ 3170206
	7511	"PKG",53,2 2,1,"PAH", 1,1,1,0)
	7512
	7513	"PKG",53,2 2,1,"PAH", 1,1,2,0)
	7514	IMPORTANT INSTALLATI ON NOTE:
	7515	"PKG",53,2 2,1,"PAH", 1,1,3,0)
	7516	---------- ---------- --------
	7517	"PKG",53,2 2,1,"PAH", 1,1,4,0)
	7518	This patch is part o f a multi- package bu ild. There are three patches
	7519	"PKG",53,2 2,1,"PAH", 1,1,5,0)
	7520	associated with the FY16 HAPE Revenue En hancement project - IB2.0568 ,
	7521	"PKG",53,2 2,1,"PAH", 1,1,6,0)
	7522	PRCA4.53 15 and PSO 7.0463. All three patches ar e to be in stalled
	7523	"PKG",53,2 2,1,"PAH", 1,1,7,0)
	7524	together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
	7525	"PKG",53,2 2,1,"PAH", 1,1,8,0)
	7526
	7527	"PKG",53,2 2,1,"PAH", 1,1,9,0)
	7528
	7529	"PKG",53,2 2,1,"PAH", 1,1,10,0)
	7530	Descriptio n
	7531	"PKG",53,2 2,1,"PAH", 1,1,11,0)
	7532	---------- -
	7533	"PKG",53,2 2,1,"PAH", 1,1,12,0)
	7534	The Chief Business O ffice (CBO ) is reque sting syst em enhance ments to
	7535	"PKG",53,2 2,1,"PAH", 1,1,13,0)
	7536	The Vetera ns Health Informatio n Systems and Techno logy Archi tecture
	7537	"PKG",53,2 2,1,"PAH", 1,1,14,0)
	7538	(VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd
	7539	"PKG",53,2 2,1,"PAH", 1,1,15,0)
	7540	Outpatient Pharmacy (PSO) soft ware modul es.
	7541	"PKG",53,2 2,1,"PAH", 1,1,16,0)
	7542
	7543	"PKG",53,2 2,1,"PAH", 1,1,17,0)
	7544	The missio n of the D epartment of Veteran s Affairs (VA), Offi ce of
	7545	"PKG",53,2 2,1,"PAH", 1,1,18,0)
	7546	Informatio n & Techno logy (OI&T ), is to p rovide ben efits and services
	7547	"PKG",53,2 2,1,"PAH", 1,1,19,0)
	7548	to veteran s of the U nited Stat es Armed F orces. In meeting th ese goals,
	7549	"PKG",53,2 2,1,"PAH", 1,1,20,0)
	7550	OIT strive s to provi de high qu ality, eff ective, an d efficien t
	7551	"PKG",53,2 2,1,"PAH", 1,1,21,0)
	7552	Informatio n Technolo gy (IT) se rvices to those resp onsible fo r
	7553	"PKG",53,2 2,1,"PAH", 1,1,22,0)
	7554	providing care to th e veterans at the po int-of-car e, as well as
	7555	"PKG",53,2 2,1,"PAH", 1,1,23,0)
	7556	throughout all the p oints of t he veteran s' health care. The VA depends
	7557	"PKG",53,2 2,1,"PAH", 1,1,24,0)
	7558	on Informa tion Manag ement/Info rmationTec hnology (I M/IT) syst ems to mee t
	7559	"PKG",53,2 2,1,"PAH", 1,1,25,0)
	7560	mission go als.
	7561	"PKG",53,2 2,1,"PAH", 1,1,26,0)
	7562
	7563	"PKG",53,2 2,1,"PAH", 1,1,27,0)
	7564	The overal l FY16 HAP E Revenue Enhancemen t project has been f urther
	7565	"PKG",53,2 2,1,"PAH", 1,1,28,0)
	7566	divided in to three s ub-project s:
	7567	"PKG",53,2 2,1,"PAH", 1,1,29,0)
	7568
	7569	"PKG",53,2 2,1,"PAH", 1,1,30,0)
	7570	NSR #20150 506
	7571	"PKG",53,2 2,1,"PAH", 1,1,31,0)
	7572	The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the Chief
	7573	"PKG",53,2 2,1,"PAH", 1,1,32,0)
	7574	Business O ffice (CBO ), bundles several N SRs with s imilar bus iness
	7575	"PKG",53,2 2,1,"PAH", 1,1,33,0)
	7576	needs into a single requiremen ts documen t. Succes sfully add ressing
	7577	"PKG",53,2 2,1,"PAH", 1,1,34,0)
	7578	the requir ements con tained wit hin this d ocument wi ll enable the
	7579	"PKG",53,2 2,1,"PAH", 1,1,35,0)
	7580	Department of Vetera ns Affairs (VA) to a ppropriate ly bill ce rtain
	7581	"PKG",53,2 2,1,"PAH", 1,1,36,0)
	7582	subsets of billable events by correcting , automati ng, or enh ancing
	7583	"PKG",53,2 2,1,"PAH", 1,1,37,0)
	7584	current Ve terans Hea lth Inform ation Syst ems and Te chnology A rchitectur e
	7585	"PKG",53,2 2,1,"PAH", 1,1,38,0)
	7586	(VistA) sy stems.
	7587	"PKG",53,2 2,1,"PAH", 1,1,39,0)
	7588
	7589	"PKG",53,2 2,1,"PAH", 1,1,40,0)
	7590	NSR #20150 507
	7591	"PKG",53,2 2,1,"PAH", 1,1,41,0)
	7592	The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs,
	7593	"PKG",53,2 2,1,"PAH", 1,1,42,0)
	7594	as well. T his effort enables t he Departm ent of Vet erans Affa irs (VA)
	7595	"PKG",53,2 2,1,"PAH", 1,1,43,0)
	7596	to improve revenue o peration f unctionali ty related to repaym ent plans,
	7597	"PKG",53,2 2,1,"PAH", 1,1,44,0)
	7598	late charg e capture, bill susp ension rea sons, the billing of
	7599	"PKG",53,2 2,1,"PAH", 1,1,45,0)
	7600	deactivate d provider s, and the display o f appeal r ights and
	7601	"PKG",53,2 2,1,"PAH", 1,1,46,0)
	7602	responsibi lities on the Vetera ns Benefic iary trave l Bill of Collection s
	7603	"PKG",53,2 2,1,"PAH", 1,1,47,0)
	7604	form. Imp lementatio n of the p roposed en hancements will make a
	7605	"PKG",53,2 2,1,"PAH", 1,1,48,0)
	7606	significan t positive impact on stakehold ers and ta rget users .
	7607	"PKG",53,2 2,1,"PAH", 1,1,49,0)
	7608
	7609	"PKG",53,2 2,1,"PAH", 1,1,50,0)
	7610	NSR #20150 505
	7611	"PKG",53,2 2,1,"PAH", 1,1,51,0)
	7612	The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to
	7613	"PKG",53,2 2,1,"PAH", 1,1,52,0)
	7614	improve tr acking and reporting of revenu e, and wil l support revenue
	7615	"PKG",53,2 2,1,"PAH", 1,1,53,0)
	7616	reporting business r ules and g uidelines.
	7617	"PKG",53,2 2,1,"PAH", 1,1,54,0)
	7618
	7619	"PKG",53,2 2,1,"PAH", 1,1,55,0)
	7620
	7621	"PKG",53,2 2,1,"PAH", 1,1,56,0)
	7622	PRCA4.53 15 patch e nhancement s, pertine nt to the above NSRs , include:
	7623	"PKG",53,2 2,1,"PAH", 1,1,57,0)
	7624
	7625	"PKG",53,2 2,1,"PAH", 1,1,58,0)
	7626	1.) By mea ns of the new Enter / Edit Rep ayment Pla n option, the user
	7627	"PKG",53,2 2,1,"PAH", 1,1,59,0)
	7628	will creat e the Repa yment Plan by debtor . Note: Th e 'Enter / Edit
	7629	"PKG",53,2 2,1,"PAH", 1,1,60,0)
	7630	Repayment Plan' menu option na me will re place the 'Set up Re payment
	7631	"PKG",53,2 2,1,"PAH", 1,1,61,0)
	7632	Plan' menu option na me.
	7633	"PKG",53,2 2,1,"PAH", 1,1,62,0)
	7634
	7635	"PKG",53,2 2,1,"PAH", 1,1,63,0)
	7636	2.) On the Enter / E dit Repaym ent Plan o ption, if the AR Deb tor has
	7637	"PKG",53,2 2,1,"PAH", 1,1,64,0)
	7638	Active bil ls, the sy stem will now displa y a select able list of bills
	7639	"PKG",53,2 2,1,"PAH", 1,1,65,0)
	7640	for the de btor.
	7641	"PKG",53,2 2,1,"PAH", 1,1,66,0)
	7642
	7643	"PKG",53,2 2,1,"PAH", 1,1,67,0)
	7644	3.) On the Enter / E dit Repaym ent Plan o ption, whe n displayi ng a list
	7645	"PKG",53,2 2,1,"PAH", 1,1,68,0)
	7646	of Active bills for the Debtor , the syst em will di splay step s to the
	7647	"PKG",53,2 2,1,"PAH", 1,1,69,0)
	7648	user to se t up the R epayment P lan.
	7649	"PKG",53,2 2,1,"PAH", 1,1,70,0)
	7650
	7651	"PKG",53,2 2,1,"PAH", 1,1,71,0)
	7652	4.) On the Enter /Ed it Repayme nt Plan op tion, once a Repayme nt Plan
	7653	"PKG",53,2 2,1,"PAH", 1,1,72,0)
	7654	has been c reated or modified, the summar y of the R epayment P lan is
	7655	"PKG",53,2 2,1,"PAH", 1,1,73,0)
	7656	displayed.
	7657	"PKG",53,2 2,1,"PAH", 1,1,74,0)
	7658
	7659	"PKG",53,2 2,1,"PAH", 1,1,75,0)
	7660	5.) On the Enter / E dit Repaym ent Plan o ption, the system ch ecks to
	7661	"PKG",53,2 2,1,"PAH", 1,1,76,0)
	7662	see if a R epayment P lan has al ready been created f or the Vet eran.
	7663	"PKG",53,2 2,1,"PAH", 1,1,77,0)
	7664
	7665	"PKG",53,2 2,1,"PAH", 1,1,78,0)
	7666	6.) On the Enter / E dit Repaym ent Plan o ption, whe n choosing to Edit
	7667	"PKG",53,2 2,1,"PAH", 1,1,79,0)
	7668	the Repaym ent Plan, all Active bills for the debto r will be displayed
	7669	"PKG",53,2 2,1,"PAH", 1,1,80,0)
	7670	allowing t he user to add new A ctive bill s to the R epayment P lan as wel l
	7671	"PKG",53,2 2,1,"PAH", 1,1,81,0)
	7672	as change the due da te of firs t payment and/or the repayment amount du e
	7673	"PKG",53,2 2,1,"PAH", 1,1,82,0)
	7674	on the Rep ayment Pla n.
	7675	"PKG",53,2 2,1,"PAH", 1,1,83,0)
	7676
	7677	"PKG",53,2 2,1,"PAH", 1,1,84,0)
	7678	7.) On the Enter / E dit Repaym ent Plan o ption, if the Debtor does not
	7679	"PKG",53,2 2,1,"PAH", 1,1,85,0)
	7680	have new A ctive bill s that can be added to the Rep ayment Pla n, the use r
	7681	"PKG",53,2 2,1,"PAH", 1,1,86,0)
	7682	will proce ed to iden tify the r epayment a mount due and/or rep ayment
	7683	"PKG",53,2 2,1,"PAH", 1,1,87,0)
	7684	amount due date on t he Repayme nt Plan.
	7685	"PKG",53,2 2,1,"PAH", 1,1,88,0)
	7686
	7687	"PKG",53,2 2,1,"PAH", 1,1,89,0)
	7688	8.) On the Enter / E dit Repaym ent Plan o ption, a d esignated identifier
	7689	"PKG",53,2 2,1,"PAH", 1,1,90,0)
	7690	will signi fy when an Active bi ll is part of a Repa yment Plan .
	7691	"PKG",53,2 2,1,"PAH", 1,1,91,0)
	7692
	7693	"PKG",53,2 2,1,"PAH", 1,1,92,0)
	7694	9.) On the Enter / E dit Repaym ent Plan o ption, the system wi ll display
	7695	"PKG",53,2 2,1,"PAH", 1,1,93,0)
	7696	previously made paym ents to th e Repaymen t Plan.
	7697	"PKG",53,2 2,1,"PAH", 1,1,94,0)
	7698
	7699	"PKG",53,2 2,1,"PAH", 1,1,95,0)
	7700	10.) On th e Enter / Edit Repay ment Plan option, th e User has the optio n
	7701	"PKG",53,2 2,1,"PAH", 1,1,96,0)
	7702	to enter D ebtor Comm ents durin g the setu p process.
	7703	"PKG",53,2 2,1,"PAH", 1,1,97,0)
	7704
	7705	"PKG",53,2 2,1,"PAH", 1,1,98,0)
	7706	11.) The A R Clerk wi ll be able to select Suspended Type from the menu
	7707	"PKG",53,2 2,1,"PAH", 1,1,99,0)
	7708	to display in the St atus Listi ng For Bil ls [PRCAL STATUS LIS T] report.
	7709	"PKG",53,2 2,1,"PAH", 1,1,100,0)
	7710
	7711	"PKG",53,2 2,1,"PAH", 1,1,101,0)
	7712	12.) Statu s Listing For Bills [PRCAL STA TUS LIST] report sha ll be
	7713	"PKG",53,2 2,1,"PAH", 1,1,102,0)
	7714	modified t o incorpor ate reason for suspe nsion.
	7715	"PKG",53,2 2,1,"PAH", 1,1,103,0)
	7716
	7717	"PKG",53,2 2,1,"PAH", 1,1,104,0)
	7718	13.) Provi de the abi lity to lo ck the opt ion to upd ate late p ayment
	7719	"PKG",53,2 2,1,"PAH", 1,1,105,0)
	7720	charges (I nterest/Ad min/Penalt y Rates [P RCAF U ADM IN.RATE]) with a new
	7721	"PKG",53,2 2,1,"PAH", 1,1,106,0)
	7722	security k ey.
	7723	"PKG",53,2 2,1,"PAH", 1,1,107,0)
	7724
	7725	"PKG",53,2 2,1,"PAH", 1,1,108,0)
	7726	14.) The s ystem will allow the user to i dentify if the Bill of
	7727	"PKG",53,2 2,1,"PAH", 1,1,109,0)
	7728	Collection s letter a pplies to Veterans B eneficiary Travel (F orm 1114).
	7729	"PKG",53,2 2,1,"PAH", 1,1,110,0)
	7730
	7731	"PKG",53,2 2,1,"PAH", 1,1,111,0)
	7732	15.) The s ystem will print the Notice of Rights an d Responsi bilities
	7733	"PKG",53,2 2,1,"PAH", 1,1,112,0)
	7734	when the B ill of Col lections p ertains to Veterans Beneficiar y Travel.
	7735	"PKG",53,2 2,1,"PAH", 1,1,113,0)
	7736
	7737	"PKG",53,2 2,1,"PAH", 1,1,114,0)
	7738	16.) VistA AR Softwa re Package shall dis continue g eneration of the
	7739	"PKG",53,2 2,1,"PAH", 1,1,115,0)
	7740	Mailman me ssage/bull etin, "ARD C Detail R eport for MON/ YYYY" , without
	7741	"PKG",53,2 2,1,"PAH", 1,1,116,0)
	7742	interrupti ng any oth er transfe r data wit hin ARDC.
	7743	"PKG",53,2 2,1,"PAH", 1,1,117,0)
	7744
	7745	"PKG",53,2 2,1,"PAH", 1,1,118,0)
	7746	17.) The V istA AR So ftware Pac kage shall allow the generatio n of a
	7747	"PKG",53,2 2,1,"PAH", 1,1,119,0)
	7748	report of bills cont aining the same info rmation as the disco ntinued
	7749	"PKG",53,2 2,1,"PAH", 1,1,120,0)
	7750	"ARDC Deta il Report for MON/YY YY" with t he followi ng excepti ons/
	7751	"PKG",53,2 2,1,"PAH", 1,1,121,0)
	7752	additions:
	7753	"PKG",53,2 2,1,"PAH", 1,1,122,0)
	7754	Th e report s hall inclu de current status bi lls (New B ill, Activ e,
	7755	"PKG",53,2 2,1,"PAH", 1,1,123,0)
	7756	Re turned for Amendment , Amended Bill, Open , and Susp ended bill s)
	7757	"PKG",53,2 2,1,"PAH", 1,1,124,0)
	7758	on ly;
	7759	"PKG",53,2 2,1,"PAH", 1,1,125,0)
	7760
	7761	"PKG",53,2 2,1,"PAH", 1,1,126,0)
	7762	Th e report s hall inclu de a colum n for the Fund numbe r associat ed
	7763	"PKG",53,2 2,1,"PAH", 1,1,127,0)
	7764	wi th each li ne item on the repor t; and
	7765	"PKG",53,2 2,1,"PAH", 1,1,128,0)
	7766
	7767	"PKG",53,2 2,1,"PAH", 1,1,129,0)
	7768	Th e report s hall inclu de a colum n for the RSC associ ated with
	7769	"PKG",53,2 2,1,"PAH", 1,1,130,0)
	7770	ea ch line it em on the report.
	7771	"PKG",53,2 2,1,"PAH", 1,1,131,0)
	7772
	7773	"PKG",53,2 2,1,"PAH", 1,1,132,0)
	7774	18.) Curre ntly, when non-healt hcare debt of $25 or greater i s in a
	7775	"PKG",53,2 2,1,"PAH", 1,1,133,0)
	7776	delinquent status fo r 180 days , VistA tr ansmits th is debt to TOP
	7777	"PKG",53,2 2,1,"PAH", 1,1,134,0)
	7778	(via AITC and DMC) f or initiat ion of the standard collection process.
	7779	"PKG",53,2 2,1,"PAH", 1,1,135,0)
	7780	To maintai n complian ce with Th e DATA Act of 2014, the 180-da y date
	7781	"PKG",53,2 2,1,"PAH", 1,1,136,0)
	7782	parameter shall be c hanged to 120 days.
	7783	"PKG",53,2 2,1,"PAH", 1,1,137,0)
	7784
	7785	"PKG",53,2 2,1,"PAH", 1,1,138,0)
	7786	19.) A ne w audit tr ail is nee ded for de tailing ev ents or tr ansactions
	7787	"PKG",53,2 2,1,"PAH", 1,1,139,0)
	7788	that have occurred o n healthca re debts r eferred fo r debt col lection, t o
	7789	"PKG",53,2 2,1,"PAH", 1,1,140,0)
	7790	effectivel y support Veterans a nd reconci le account s.
	7791	"PKG",53,2 2,1,"PAH", 1,1,141,0)
	7792
	7793	"PKG",53,2 2,1,"PAH", 1,1,142,0)
	7794	20.) Vist A shall pr ovide enha nced repor ting capab ility, usa bility
	7795	"PKG",53,2 2,1,"PAH", 1,1,143,0)
	7796	features, and additi onal data elements f or managin g healthca re debts
	7797	"PKG",53,2 2,1,"PAH", 1,1,144,0)
	7798	referred f or debt co llection t o improve VHA's abil ity to pro vide suppo rt
	7799	"PKG",53,2 2,1,"PAH", 1,1,145,0)
	7800	to Veteran s and mana ge account s.
	7801	"PKG",53,2 2,1,"PAH", 1,1,146,0)
	7802
	7803	"PKG",53,2 2,1,"PAH", 1,1,147,0)
	7804	21.) Crea te report to track s top/reacti vate debts . VistA sh all provid e
	7805	"PKG",53,2 2,1,"PAH", 1,1,148,0)
	7806	a Stop/Rea ctivate re port to id entify hea lthcare de bts that a re placed
	7807	"PKG",53,2 2,1,"PAH", 1,1,149,0)
	7808	in the cor responding status.
	7809	"PKG",53,2 2,1,"PAH", 1,1,150,0)
	7810
	7811	"PKG",53,2 2,1,"PAH", 1,1,151,0)
	7812	22.) Impr ove automa tion in ma nagement o f debt col lection. V istA shall
	7813	"PKG",53,2 2,1,"PAH", 1,1,152,0)
	7814	utilize ex isting fun ctionality , such as List Manag er, and ot her
	7815	"PKG",53,2 2,1,"PAH", 1,1,153,0)
	7816	automation capabilit ies to imp rove debt collection managemen t"
	7817	"PKG",53,2 2,1,"PAH", 1,1,154,0)
	7818
	7819	"PKG",53,2 2,1,"PAH", 1,1,155,0)
	7820	23.) The existing M edication Co-Pay Exe mption Rep ort [PRCAX CO-PAY
	7821	"PKG",53,2 2,1,"PAH", 1,1,156,0)
	7822	EXEMPTION REPORT] sh all be mod ified with the follo wing field changes:
	7823	"PKG",53,2 2,1,"PAH", 1,1,157,0)
	7824	Ch ange PT ID from full Social Se curity Num ber (SSN) to LastN +
	7825	"PKG",53,2 2,1,"PAH", 1,1,158,0)
	7826	4SSN
	7827	"PKG",53,2 2,1,"PAH", 1,1,159,0)
	7828	Ad d Rx#
	7829	"PKG",53,2 2,1,"PAH", 1,1,160,0)
	7830	Ad d Drug Nam e (first 1 0 to 12 ch aracters)
	7831	"PKG",53,2 2,1,"PAH", 1,1,161,0)
	7832	Ad d Fill/Ref ill Date
	7833	"PKG",53,2 2,1,"PAH", 1,1,162,0)
	7834	Ad d Effectiv e Date of Exemption
	7835	"PKG",53,2 2,1,"PAH", 1,1,163,0)
	7836
	7837	"PKG",53,2 2,1,"PAH", 1,1,164,0)
	7838	24.) A ne w Third Pa rty Accoun ts Receiva ble catego ry called
	7839	"PKG",53,2 2,1,"PAH", 1,1,165,0)
	7840	'EMERGENCY /HUMANITAR IAN REIMB. ' shall be created i n Accounts Receivabl es
	7841	"PKG",53,2 2,1,"PAH", 1,1,166,0)
	7842	with the i nsurer as the respon sible part y.
	7843	"PKG",53,2 2,1,"PAH", 1,1,167,0)
	7844
	7845	"PKG",53,2 2,1,"PAH", 1,1,168,0)
	7846	25.) A new Third Par ty Account s Receivab le categor y called ' INELIGIBLE
	7847	"PKG",53,2 2,1,"PAH", 1,1,169,0)
	7848	HOSP. REIM B' shall b e created in Account s Receivab les with t he insurer
	7849	"PKG",53,2 2,1,"PAH", 1,1,170,0)
	7850	as the res ponsible p arty.
	7851	"PKG",53,2 2,1,"PAH", 1,1,171,0)
	7852
	7853	"PKG",53,2 2,1,"PAH", 1,1,172,0)
	7854	26.) A one -character "Type" fi eld shall be added t o the Clai ms Matchin g
	7855	"PKG",53,2 2,1,"PAH", 1,1,173,0)
	7856	Report tha t will ind icate the third-part y claim ca re-type (" I" for
	7857	"PKG",53,2 2,1,"PAH", 1,1,174,0)
	7858	Inpatient, "O" for O utpatient, "P" for P rosthetics , and "R" for
	7859	"PKG",53,2 2,1,"PAH", 1,1,175,0)
	7860	Prescripti on
	7861	"PKG",53,2 2,1,"PAH", 1,1,176,0)
	7862	[Rx]) on t he report of third-p arty bills .
	7863	"PKG",53,2 2,1,"PAH", 1,1,177,0)
	7864
	7865	"PKG",53,2 2,1,"PAH", 1,1,178,0)
	7866	27.) When a user gen erates a C laims Matc hing Repor t for a pa tient, all
	7867	"PKG",53,2 2,1,"PAH", 1,1,179,0)
	7868	records fo r that pat ient are c urrently p roduced on the repor t. At
	7869	"PKG",53,2 2,1,"PAH", 1,1,180,0)
	7870	times, use rs need to generate informatio n regardin g only cer tain types
	7871	"PKG",53,2 2,1,"PAH", 1,1,181,0)
	7872	of care fo r a patien t. The sy stem shall allow the user to c hoose
	7873	"PKG",53,2 2,1,"PAH", 1,1,182,0)
	7874	between pr oducing a Claims Mat ching Repo rt contain ing (1) al l records
	7875	"PKG",53,2 2,1,"PAH", 1,1,183,0)
	7876	for a pati ent, or (2 ) only rec ords of a certain ca re type (" I" for
	7877	"PKG",53,2 2,1,"PAH", 1,1,184,0)
	7878	Inpatient, "O" for O utpatient, "P" for P rosthetics , or "R" f or
	7879	"PKG",53,2 2,1,"PAH", 1,1,185,0)
	7880	Prescripti on [Rx]).
	7881	"PKG",53,2 2,1,"PAH", 1,1,186,0)
	7882
	7883	"PKG",53,2 2,1,"PAH", 1,1,187,0)
	7884	28.) The C laims Matc hing Repor t, when ex ported, sh all be in a line
	7885	"PKG",53,2 2,1,"PAH", 1,1,188,0)
	7886	format so that infor mation on the report may be ea sily expor ted to
	7887	"PKG",53,2 2,1,"PAH", 1,1,189,0)
	7888	Microsoft Excel.
	7889	"PKG",53,2 2,1,"PAH", 1,1,190,0)
	7890
	7891	"PKG",53,2 2,1,"PAH", 1,1,191,0)
	7892
	7893	"PKG",53,2 2,1,"PAH", 1,1,192,0)
	7894
	7895	"PKG",53,2 2,1,"PAH", 1,1,193,0)
	7896	Concurrent Developme nt / Depen dencies:
	7897	"PKG",53,2 2,1,"PAH", 1,1,194,0)
	7898	---------- ---------- ---------- --------
	7899	"PKG",53,2 2,1,"PAH", 1,1,195,0)
	7900	N/A
	7901	"PKG",53,2 2,1,"PAH", 1,1,196,0)
	7902
	7903	"PKG",53,2 2,1,"PAH", 1,1,197,0)
	7904
	7905	"PKG",53,2 2,1,"PAH", 1,1,198,0)
	7906	Patch Comp onents:
	7907	"PKG",53,2 2,1,"PAH", 1,1,199,0)
	7908	---------- -------
	7909	"PKG",53,2 2,1,"PAH", 1,1,200,0)
	7910
	7911	"PKG",53,2 2,1,"PAH", 1,1,201,0)
	7912	Files & Fi elds Assoc iated:
	7913	"PKG",53,2 2,1,"PAH", 1,1,202,0)
	7914
	7915	"PKG",53,2 2,1,"PAH", 1,1,203,0)
	7916	File Name (Number) Field Na me (Number ) New/ Modified/D eleted
	7917	"PKG",53,2 2,1,"PAH", 1,1,204,0)
	7918	---------- -------- -------- ---------- - ---- ---------- ------
	7919	"PKG",53,2 2,1,"PAH", 1,1,205,0)
	7920	N/A
	7921	"PKG",53,2 2,1,"PAH", 1,1,206,0)
	7922
	7923	"PKG",53,2 2,1,"PAH", 1,1,207,0)
	7924	Options As sociated:
	7925	"PKG",53,2 2,1,"PAH", 1,1,208,0)
	7926
	7927	"PKG",53,2 2,1,"PAH", 1,1,209,0)
	7928	Option Nam e Type New/ Modified/D eleted
	7929	"PKG",53,2 2,1,"PAH", 1,1,210,0)
	7930	---------- - ---- ---- ---------- ------
	7931	"PKG",53,2 2,1,"PAH", 1,1,211,0)
	7932	PRCA ARDC REPORT ROUTINE NEW
	7933	"PKG",53,2 2,1,"PAH", 1,1,212,0)
	7934
	7935	"PKG",53,2 2,1,"PAH", 1,1,213,0)
	7936	Protocols Associated :
	7937	"PKG",53,2 2,1,"PAH", 1,1,214,0)
	7938
	7939	"PKG",53,2 2,1,"PAH", 1,1,215,0)
	7940	Protocol N ame New /Modified/ Deleted
	7941	"PKG",53,2 2,1,"PAH", 1,1,216,0)
	7942	---------- --- --- ---------- -------
	7943	"PKG",53,2 2,1,"PAH", 1,1,217,0)
	7944	N/A
	7945	"PKG",53,2 2,1,"PAH", 1,1,218,0)
	7946
	7947	"PKG",53,2 2,1,"PAH", 1,1,219,0)
	7948	Templates Associated :
	7949	"PKG",53,2 2,1,"PAH", 1,1,220,0)
	7950
	7951	"PKG",53,2 2,1,"PAH", 1,1,221,0)
	7952	Template N ame T ype File Name (Num ber) New/Mod/De l
	7953	"PKG",53,2 2,1,"PAH", 1,1,222,0)
	7954	---------- --- - --- ---- ---------- ---- ---------- -
	7955	"PKG",53,2 2,1,"PAH", 1,1,223,0)
	7956	N/A
	7957	"PKG",53,2 2,1,"PAH", 1,1,224,0)
	7958
	7959	"PKG",53,2 2,1,"PAH", 1,1,225,0)
	7960	New Servic e Requests (NSRs):
	7961	"PKG",53,2 2,1,"PAH", 1,1,226,0)
	7962	---------- ---------- --------
	7963	"PKG",53,2 2,1,"PAH", 1,1,227,0)
	7964	20150505 - Revenue R eporting E nhancement s
	7965	"PKG",53,2 2,1,"PAH", 1,1,228,0)
	7966	20150506 - Revenue E ligibility Enhanceme nts
	7967	"PKG",53,2 2,1,"PAH", 1,1,229,0)
	7968	20150507 - Revenue O perations Enhancemen ts
	7969	"PKG",53,2 2,1,"PAH", 1,1,230,0)
	7970
	7971	"PKG",53,2 2,1,"PAH", 1,1,231,0)
	7972
	7973	"PKG",53,2 2,1,"PAH", 1,1,232,0)
	7974	Patient Sa fety Issue s (PSIs):
	7975	"PKG",53,2 2,1,"PAH", 1,1,233,0)
	7976	---------- ---------- ----------
	7977	"PKG",53,2 2,1,"PAH", 1,1,234,0)
	7978	N/A
	7979	"PKG",53,2 2,1,"PAH", 1,1,235,0)
	7980
	7981	"PKG",53,2 2,1,"PAH", 1,1,236,0)
	7982
	7983	"PKG",53,2 2,1,"PAH", 1,1,237,0)
	7984	Remedy Tic ket(s) & O verviews:
	7985	"PKG",53,2 2,1,"PAH", 1,1,238,0)
	7986	---------- ---------- ---------
	7987	"PKG",53,2 2,1,"PAH", 1,1,239,0)
	7988	N/A
	7989	"PKG",53,2 2,1,"PAH", 1,1,240,0)
	7990
	7991	"PKG",53,2 2,1,"PAH", 1,1,241,0)
	7992	Test Sites :
	7993	"PKG",53,2 2,1,"PAH", 1,1,242,0)
	7994	----------
	7995	"PKG",53,2 2,1,"PAH", 1,1,243,0)
	7996	Durham VAM C
	7997	"PKG",53,2 2,1,"PAH", 1,1,244,0)
	7998
	7999	"PKG",53,2 2,1,"PAH", 1,1,245,0)
	8000
	8001	"PKG",53,2 2,1,"PAH", 1,1,246,0)
	8002	Software a nd Documen tation Ret rieval Ins tructions:
	8003	"PKG",53,2 2,1,"PAH", 1,1,247,0)
	8004	---------- ---------- ---------- ---------- ---------- --
	8005	"PKG",53,2 2,1,"PAH", 1,1,248,0)
	8006	Patches fo r this ins tallation are combin ed in host file
	8007	"PKG",53,2 2,1,"PAH", 1,1,249,0)
	8008	IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
	8009	"PKG",53,2 2,1,"PAH", 1,1,250,0)
	8010
	8011	"PKG",53,2 2,1,"PAH", 1,1,251,0)
	8012	Installati on of this host file should be coordinat ed among t he package s
	8013	"PKG",53,2 2,1,"PAH", 1,1,252,0)
	8014	affected s ince only one instal lation is necessary.
	8015	"PKG",53,2 2,1,"PAH", 1,1,253,0)
	8016
	8017	"PKG",53,2 2,1,"PAH", 1,1,254,0)
	8018	The patche s are:
	8019	"PKG",53,2 2,1,"PAH", 1,1,255,0)
	8020
	8021	"PKG",53,2 2,1,"PAH", 1,1,256,0)
	8022	IB2. 0568
	8023	"PKG",53,2 2,1,"PAH", 1,1,257,0)
	8024	PRCA* 4.5*315
	8025	"PKG",53,2 2,1,"PAH", 1,1,258,0)
	8026	PSO7 .0463
	8027	"PKG",53,2 2,1,"PAH", 1,1,259,0)
	8028
	8029	"PKG",53,2 2,1,"PAH", 1,1,260,0)
	8030
	8031	"PKG",53,2 2,1,"PAH", 1,1,261,0)
	8032	Sites may retrieve t he KIDS bu ild in one of the fo llowing wa ys:
	8033	"PKG",53,2 2,1,"PAH", 1,1,262,0)
	8034
	8035	"PKG",53,2 2,1,"PAH", 1,1,263,0)
	8036	(1) The pr eferred me thod is to FTP the f iles from
	8037	"PKG",53,2 2,1,"PAH", 1,1,264,0)
	8038	download.D NS .D NS
	8039	"PKG",53,2 2,1,"PAH", 1,1,265,0)
	8040	which will transmit the files from the f irst avail able FTP s erver.
	8041	"PKG",53,2 2,1,"PAH", 1,1,266,0)
	8042
	8043	"PKG",53,2 2,1,"PAH", 1,1,267,0)
	8044	(2) Sites may also e lect to re trieve the patch dir ectly from a specifi c
	8045	"PKG",53,2 2,1,"PAH", 1,1,268,0)
	8046	server as follows:
	8047	"PKG",53,2 2,1,"PAH", 1,1,269,0)
	8048
	8049	"PKG",53,2 2,1,"PAH", 1,1,270,0)
	8050	OIFO FTP ADDRE SS DIRECTORY
	8051	"PKG",53,2 2,1,"PAH", 1,1,271,0)
	8052	-------- ------ --------- ---------- ----- ---------- --------
	8053	"PKG",53,2 2,1,"PAH", 1,1,272,0)
	8054	Albany ftp.fo-alb any. URL anonymous. software
	8055	"PKG",53,2 2,1,"PAH", 1,1,273,0)
	8056	Hines ftp. DNS . URL anonymous. software
	8057	"PKG",53,2 2,1,"PAH", 1,1,274,0)
	8058	Salt Lake City ftp.fo-slc . URL anonymous. software
	8059	"PKG",53,2 2,1,"PAH", 1,1,275,0)
	8060
	8061	"PKG",53,2 2,1,"PAH", 1,1,276,0)
	8062
	8063	"PKG",53,2 2,1,"PAH", 1,1,277,0)
	8064	Sites may retrieve d ocumentati on directl y using Se cure File Transfer
	8065	"PKG",53,2 2,1,"PAH", 1,1,278,0)
	8066	Protocol ( SFTP) from the ANONY MOUS.SOFTW ARE direct ory at the following
	8067	"PKG",53,2 2,1,"PAH", 1,1,279,0)
	8068	OI Field O ffices:
	8069	"PKG",53,2 2,1,"PAH", 1,1,280,0)
	8070
	8071	"PKG",53,2 2,1,"PAH", 1,1,281,0)
	8072	Albany: fo-albany. URL
	8073	"PKG",53,2 2,1,"PAH", 1,1,282,0)
	8074	Hines: DNS .U RL
	8075	"PKG",53,2 2,1,"PAH", 1,1,283,0)
	8076	Salt Lake City: fo-slc. URL
	8077	"PKG",53,2 2,1,"PAH", 1,1,284,0)
	8078
	8079	"PKG",53,2 2,1,"PAH", 1,1,285,0)
	8080	Documentat ion can al so be foun d on the V A Software Documenta tion
	8081	"PKG",53,2 2,1,"PAH", 1,1,286,0)
	8082	Library at :
	8083	"PKG",53,2 2,1,"PAH", 1,1,287,0)
	8084	http:// URL /
	8085	"PKG",53,2 2,1,"PAH", 1,1,288,0)
	8086
	8087	"PKG",53,2 2,1,"PAH", 1,1,289,0)
	8088	Title File Na me FTP Mod e
	8089	"PKG",53,2 2,1,"PAH", 1,1,290,0)
	8090	---------- ---------- ---------- ---------- ---------- ---------- ---------- -
	8091	"PKG",53,2 2,1,"PAH", 1,1,291,0)
	8092	Accounts R eceivable Technical Manual/Sec urity Guid e
	8093	"PKG",53,2 2,1,"PAH", 1,1,292,0)
	8094	prca_4_ 5_tm+r0515 .doc Binar y
	8095	"PKG",53,2 2,1,"PAH", 1,1,293,0)
	8096	Accounts R eceivable Deployment , Installa tion,
	8097	"PKG",53,2 2,1,"PAH", 1,1,294,0)
	8098	Back- Out, and R ollback Gu ide
	8099	"PKG",53,2 2,1,"PAH", 1,1,295,0)
	8100	FY16Re venueARVIP _Deploymen t_Installa tion_Guide .doc Binar y
	8101	"PKG",53,2 2,1,"PAH", 1,1,296,0)
	8102
	8103	"PKG",53,2 2,1,"PAH", 1,1,297,0)
	8104
	8105	"PKG",53,2 2,1,"PAH", 1,1,298,0)
	8106
	8107	"PKG",53,2 2,1,"PAH", 1,1,299,0)
	8108	Patch Inst allation:
	8109	"PKG",53,2 2,1,"PAH", 1,1,300,0)
	8110
	8111	"PKG",53,2 2,1,"PAH", 1,1,301,0)
	8112	Pre/Post I nstallatio n Overview :
	8113	"PKG",53,2 2,1,"PAH", 1,1,302,0)
	8114	---------- ---------- ---------- -
	8115	"PKG",53,2 2,1,"PAH", 1,1,303,0)
	8116	The post i nstallatio n routine, PRCA315P, is not au tomaticall y deleted
	8117	"PKG",53,2 2,1,"PAH", 1,1,304,0)
	8118	as part of the insta llation pr ocess. You may delet e it after
	8119	"PKG",53,2 2,1,"PAH", 1,1,305,0)
	8120	installati on if you desire.
	8121	"PKG",53,2 2,1,"PAH", 1,1,306,0)
	8122
	8123	"PKG",53,2 2,1,"PAH", 1,1,307,0)
	8124	Pre-Instal lation Ins tructions:
	8125	"PKG",53,2 2,1,"PAH", 1,1,308,0)
	8126	---------- ---------- ----------
	8127	"PKG",53,2 2,1,"PAH", 1,1,309,0)
	8128	N/A
	8129	"PKG",53,2 2,1,"PAH", 1,1,310,0)
	8130
	8131	"PKG",53,2 2,1,"PAH", 1,1,311,0)
	8132	Installati on Instruc tions:
	8133	"PKG",53,2 2,1,"PAH", 1,1,312,0)
	8134	---------- ---------- ------
	8135	"PKG",53,2 2,1,"PAH", 1,1,313,0)
	8136	This proce ss will in stall new and update d routines and other
	8137	"PKG",53,2 2,1,"PAH", 1,1,314,0)
	8138	components listed ab ove. There is a post -install r outine tha t will add
	8139	"PKG",53,2 2,1,"PAH", 1,1,315,0)
	8140	entries to a number of files.
	8141	"PKG",53,2 2,1,"PAH", 1,1,316,0)
	8142
	8143	"PKG",53,2 2,1,"PAH", 1,1,317,0)
	8144	The patch will be re leased in conjunctio n with an Integrated Billing
	8145	"PKG",53,2 2,1,"PAH", 1,1,318,0)
	8146	patch, IB* 4.5568, a nd an Outp atient Pha rmacy patc h, PSO7.0 *463.
	8147	"PKG",53,2 2,1,"PAH", 1,1,319,0)
	8148
	8149	"PKG",53,2 2,1,"PAH", 1,1,320,0)
	8150	****** ****** ** NOT E **** ****** ****
	8151	"PKG",53,2 2,1,"PAH", 1,1,321,0)
	8152	IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS
	8153	"PKG",53,2 2,1,"PAH", 1,1,322,0)
	8154	AN EDITE D ERROR WI LL OCCUR.
	8155	"PKG",53,2 2,1,"PAH", 1,1,323,0)
	8156	The patc h should b e installe d when NO Outpatient
	8157	"PKG",53,2 2,1,"PAH", 1,1,324,0)
	8158	Pharmacy users are on the sy stem.
	8159	"PKG",53,2 2,1,"PAH", 1,1,325,0)
	8160	****** ****** ****** ****** ****** ****
	8161	"PKG",53,2 2,1,"PAH", 1,1,326,0)
	8162
	8163	"PKG",53,2 2,1,"PAH", 1,1,327,0)
	8164	Installat ion will t ake less t han 1 minu te.
	8165	"PKG",53,2 2,1,"PAH", 1,1,328,0)
	8166
	8167	"PKG",53,2 2,1,"PAH", 1,1,329,0)
	8168	Suggested time to i nstall: no n-peak req uirement h ours.
	8169	"PKG",53,2 2,1,"PAH", 1,1,330,0)
	8170
	8171	"PKG",53,2 2,1,"PAH", 1,1,331,0)
	8172
	8173	"PKG",53,2 2,1,"PAH", 1,1,332,0)
	8174	1. Obtai n the file IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID
	8175	"PKG",53,2 2,1,"PAH", 1,1,333,0)
	8176
	8177	"PKG",53,2 2,1,"PAH", 1,1,334,0)
	8178	2. From the Kernel Installat ion & Dist ribution S ystem menu , select
	8179	"PKG",53,2 2,1,"PAH", 1,1,335,0)
	8180	the I nstallatio n menu.
	8181	"PKG",53,2 2,1,"PAH", 1,1,336,0)
	8182
	8183	"PKG",53,2 2,1,"PAH", 1,1,337,0)
	8184	3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
	8185	"PKG",53,2 2,1,"PAH", 1,1,338,0)
	8186	promp ted to Ent er a Host File name. You may need to ap pend a
	8187	"PKG",53,2 2,1,"PAH", 1,1,339,0)
	8188	direc tory name.
	8189	"PKG",53,2 2,1,"PAH", 1,1,340,0)
	8190
	8191	"PKG",53,2 2,1,"PAH", 1,1,341,0)
	8192	4. From this menu, you may s elect to u se the fol lowing opt ions
	8193	"PKG",53,2 2,1,"PAH", 1,1,342,0)
	8194	(when prompted for INSTAL L NAME, en ter IB2.0 568):
	8195	"PKG",53,2 2,1,"PAH", 1,1,343,0)
	8196	a . Verify Checksums in Transpo rt Global - This opt ion will
	8197	"PKG",53,2 2,1,"PAH", 1,1,344,0)
	8198	allow y ou to ensu re the int egrity of the routin es that ar e
	8199	"PKG",53,2 2,1,"PAH", 1,1,345,0)
	8200	in the transport global.
	8201	"PKG",53,2 2,1,"PAH", 1,1,346,0)
	8202	b . Print T ransport G lobal - Th is option will allow you to
	8203	"PKG",53,2 2,1,"PAH", 1,1,347,0)
	8204	view th e componen ts of the KIDS build .
	8205	"PKG",53,2 2,1,"PAH", 1,1,348,0)
	8206	c . Compare Transport Global to Current S ystem - Th is option
	8207	"PKG",53,2 2,1,"PAH", 1,1,349,0)
	8208	will al low you to view all changes th at will be made when
	8209	"PKG",53,2 2,1,"PAH", 1,1,350,0)
	8210	this pa tch is ins talled. I t compares all compo nents of
	8211	"PKG",53,2 2,1,"PAH", 1,1,351,0)
	8212	this pa tch (routi nes, DD's, templates , etc.).
	8213	"PKG",53,2 2,1,"PAH", 1,1,352,0)
	8214	d . Backup a Transpor t Global - This opti on will cr eate a
	8215	"PKG",53,2 2,1,"PAH", 1,1,353,0)
	8216	backup message of any routi nes export ed with th is patch.
	8217	"PKG",53,2 2,1,"PAH", 1,1,354,0)
	8218	It will not backu p any othe r changes such as DD 's or
	8219	"PKG",53,2 2,1,"PAH", 1,1,355,0)
	8220	templat es.
	8221	"PKG",53,2 2,1,"PAH", 1,1,356,0)
	8222
	8223	"PKG",53,2 2,1,"PAH", 1,1,357,0)
	8224	5. When prompted " Want KIDS to INHIBIT LOGONs du ring the i nstall?
	8225	"PKG",53,2 2,1,"PAH", 1,1,358,0)
	8226	NO//" respond N O.
	8227	"PKG",53,2 2,1,"PAH", 1,1,359,0)
	8228
	8229	"PKG",53,2 2,1,"PAH", 1,1,360,0)
	8230	6. When prompted " Want to DI SABLE Sche duled Opti ons, Menu Options,
	8231	"PKG",53,2 2,1,"PAH", 1,1,361,0)
	8232	and P rotocols? NO//" resp ond NO.
	8233	"PKG",53,2 2,1,"PAH", 1,1,362,0)
	8234
	8235	"PKG",53,2 2,1,"PAH", 1,1,363,0)
	8236
	8237	"PKG",53,2 2,1,"PAH", 1,1,364,0)
	8238
	8239	"PKG",53,2 2,1,"PAH", 1,1,365,0)
	8240	Post-Insta llation In structions :
	8241	"PKG",53,2 2,1,"PAH", 1,1,366,0)
	8242	---------- ---------- ---------- -
	8243	"PKG",53,2 2,1,"PAH", 1,1,367,0)
	8244	There are no special tasks to perform af ter this p atch insta llation.
	8245	"QUES","XP F1",0)
	8246	Y
	8247	"QUES","XP F1","??")
	8248	^D REP^XPD H
	8249	"QUES","XP F1","A")
	8250	Shall I wr ite over y our \|FLAG\| File
	8251	"QUES","XP F1","B")
	8252	YES
	8253	"QUES","XP F1","M")
	8254	D XPF1^XPD IQ
	8255	"QUES","XP F2",0)
	8256	Y
	8257	"QUES","XP F2","??")
	8258	^D DTA^XPD H
	8259	"QUES","XP F2","A")
	8260	Want my da ta \|FLAG\| yours
	8261	"QUES","XP F2","B")
	8262	YES
	8263	"QUES","XP F2","M")
	8264	D XPF2^XPD IQ
	8265	"QUES","XP I1",0)
	8266	YO
	8267	"QUES","XP I1","??")
	8268	^D INHIBIT ^XPDH
	8269	"QUES","XP I1","A")
	8270	Want KIDS to INHIBIT LOGONs du ring the i nstall
	8271	"QUES","XP I1","B")
	8272	NO
	8273	"QUES","XP I1","M")
	8274	D XPI1^XPD IQ
	8275	"QUES","XP M1",0)
	8276	PO^VA(200, :EM
	8277	"QUES","XP M1","??")
	8278	^D MG^XPDH
	8279	"QUES","XP M1","A")
	8280	Enter the Coordinato r for Mail Group '\|F LAG\|'
	8281	"QUES","XP M1","B")
	8282
	8283	"QUES","XP M1","M")
	8284	D XPM1^XPD IQ
	8285	"QUES","XP O1",0)
	8286	Y
	8287	"QUES","XP O1","??")
	8288	^D MENU^XP DH
	8289	"QUES","XP O1","A")
	8290	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	8291	"QUES","XP O1","B")
	8292	NO
	8293	"QUES","XP O1","M")
	8294	D XPO1^XPD IQ
	8295	"QUES","XP Z1",0)
	8296	Y
	8297	"QUES","XP Z1","??")
	8298	^D OPT^XPD H
	8299	"QUES","XP Z1","A")
	8300	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	8301	"QUES","XP Z1","B")
	8302	NO
	8303	"QUES","XP Z1","M")
	8304	D XPZ1^XPD IQ
	8305	"QUES","XP Z2",0)
	8306	Y
	8307	"QUES","XP Z2","??")
	8308	^D RTN^XPD H
	8309	"QUES","XP Z2","A")
	8310	Want to MO VE routine s to other CPUs
	8311	"QUES","XP Z2","B")
	8312	NO
	8313	"QUES","XP Z2","M")
	8314	D XPZ2^XPD IQ
	8315	"RTN")
	8316	17
	8317	"RTN","PRC A315P")
	8318	0^^B951697 4
	8319	"RTN","PRC A315P",1,0 )
	8320	PRCA315P ; SLT/BAA-PR CA4.5315 POST INST ALL
	8321	"RTN","PRC A315P",2,0 )
	8322	;;4.5;Acc ounts Rece ivable;3 15;Mar 2 0, 1995;Bu ild 2
	8323	"RTN","PRC A315P",3,0 )
	8324	;;Per VA Directive 6402, this routine s hould not be modifie d.
	8325	"RTN","PRC A315P",4,0 )
	8326	POSTINIT ;
	8327	"RTN","PRC A315P",5,0 )
	8328	;
	8329	"RTN","PRC A315P",6,0 )
	8330	D BMES^XP DUTL(" >> Starting the Post-I nitializat ion routin e ...")
	8331	"RTN","PRC A315P",7,0 )
	8332	; AR CATE GORIES
	8333	"RTN","PRC A315P",8,0 )
	8334	D ARCAT
	8335	"RTN","PRC A315P",9,0 )
	8336	D REVSC
	8337	"RTN","PRC A315P",10, 0)
	8338	D MES^XPD UTL(" >> End of the Post-Init ialization routine . ..")
	8339	"RTN","PRC A315P",11, 0)
	8340	Q
	8341	"RTN","PRC A315P",12, 0)
	8342	;
	8343	"RTN","PRC A315P",13, 0)
	8344	;
	8345	"RTN","PRC A315P",14, 0)
	8346	ARCAT ;AR CATEGORY E NTRIES (43 0.2)
	8347	"RTN","PRC A315P",15, 0)
	8348	N %,D,D0, DA,DI,DIC, DIE,DIK,DI NUM,DLAYGO ,DQ,DR,RCD ATA,RCDINU M,X,Y,FLG
	8349	"RTN","PRC A315P",16, 0)
	8350	D MES^XPD UTL(" -> Adding new AR Cat egory entr ies to fil e 430.2 .. .")
	8351	"RTN","PRC A315P",17, 0)
	8352	;
	8353	"RTN","PRC A315P",18, 0)
	8354	; instal l entries in file 43 0.2
	8355	"RTN","PRC A315P",19, 0)
	8356	S FLG=0
	8357	"RTN","PRC A315P",20, 0)
	8358	F RCDINUM =46,47 D
	8359	"RTN","PRC A315P",21, 0)
	8360	. S RCS=" CT"_RCDINU M
	8361	"RTN","PRC A315P",22, 0)
	8362	. S RCDAT A=$P($T(@R CS),";",3, 99)
	8363	"RTN","PRC A315P",23, 0)
	8364	. S (DIC, DIE)="^PRC A(430.2,", DIC(0)="L" ,DLAYGO=43 0.2
	8365	"RTN","PRC A315P",24, 0)
	8366	. ;
	8367	"RTN","PRC A315P",25, 0)
	8368	. S IBNAM E=$P(RCDAT A,";")
	8369	"RTN","PRC A315P",26, 0)
	8370	. ;
	8371	"RTN","PRC A315P",27, 0)
	8372	. I $D(^P RCA(430.2, RCDINUM,0) ) S DIK="^ PRCA(430.2 ,",DA=RCDI NUM D ^DIK
	8373	"RTN","PRC A315P",28, 0)
	8374	. ;
	8375	"RTN","PRC A315P",29, 0)
	8376	. S (DIC, DIE)="^PRC A(430.2,", DIC(0)="L" ,DLAYGO=43 0.2
	8377	"RTN","PRC A315P",30, 0)
	8378	. ;
	8379	"RTN","PRC A315P",31, 0)
	8380	. ; set the fields
	8381	"RTN","PRC A315P",32, 0)
	8382	. S (DINU M,DA)=RCDI NUM,X=IBNA ME
	8383	"RTN","PRC A315P",33, 0)
	8384	. S DIC(" DR")="1/// /"_$P(RCDA TA,";",2)_ ";2////"_$ P(RCDATA," ;",3)_";3/ ///"_$P(RC
	8385	DATA,";",6 )_";5////" _$P(RCDATA ,";",5)_"; 6////"_$P( RCDATA,";" ,4)
	8386	"RTN","PRC A315P",34, 0)
	8387	. S DIC(" DR")=DIC(" DR")_";7// //2;9///0; 10///0;11/ //0;12//// "_$P(RCDAT A,";",7)_"
	8388	;13///2;"
	8389	"RTN","PRC A315P",35, 0)
	8390	. ; add entry
	8391	"RTN","PRC A315P",36, 0)
	8392	. S X=IBN AME D FILE ^DICN K DI C I Y<1 K X,Y Q
	8393	"RTN","PRC A315P",37, 0)
	8394	. D MES^X PDUTL("New accounts Receivable category "_IBNAME_" added") S FLG=1
	8395	"RTN","PRC A315P",38, 0)
	8396	;
	8397	"RTN","PRC A315P",39, 0)
	8398	I FLG D M ES^XPDUTL( "New accou nts Receiv able categ ories adde d")
	8399	"RTN","PRC A315P",40, 0)
	8400	;
	8401	"RTN","PRC A315P",41, 0)
	8402	Q
	8403	"RTN","PRC A315P",42, 0)
	8404	;
	8405	"RTN","PRC A315P",43, 0)
	8406	;
	8407	"RTN","PRC A315P",44, 0)
	8408	REVSC ;REV ENUE SOURC E CODE ent ries in fi le #347.3
	8409	"RTN","PRC A315P",45, 0)
	8410	N I,RSCDA TA,DIC,Y,G BL,DA,X,DI E,DR
	8411	"RTN","PRC A315P",46, 0)
	8412	D MES^XPD UTL(" -> Adding new REVENU E SOURCE C ODE entrie s to file 347.3 ..."
	8413	)
	8414	"RTN","PRC A315P",47, 0)
	8415	S GBL="^R C(347.3,"
	8416	"RTN","PRC A315P",48, 0)
	8417	F I=1:1 D Q:RSCDAT A="END"
	8418	"RTN","PRC A315P",49, 0)
	8419	. S RSCDA TA=$P($T(N EWRSC+I)," ;",3,99)
	8420	"RTN","PRC A315P",50, 0)
	8421	. Q:RSCDA TA="END"
	8422	"RTN","PRC A315P",51, 0)
	8423	. ; do a lookup and continue if exists.
	8424	"RTN","PRC A315P",52, 0)
	8425	. S DIC=G BL,X=$P(RS CDATA,";") D ^DIC
	8426	"RTN","PRC A315P",53, 0)
	8427	. I +Y>0 S DIK=GBL, DA=+Y D ^D IK
	8428	"RTN","PRC A315P",54, 0)
	8429	. ; add e ntry
	8430	"RTN","PRC A315P",55, 0)
	8431	. S X=$P( RSCDATA,"; ")
	8432	"RTN","PRC A315P",56, 0)
	8433	. S DIC(" DR")=".02/ //"_$P(RSC DATA,";",2 )_";"
	8434	"RTN","PRC A315P",57, 0)
	8435	. S DIC(" DR")=DIC(" DR")_".03/ //0;"
	8436	"RTN","PRC A315P",58, 0)
	8437	. D FILE^ DICN
	8438	"RTN","PRC A315P",59, 0)
	8439	. I +Y=-1 D
	8440	"RTN","PRC A315P",60, 0)
	8441	. . D MES ^XPDUTL(" "_$ P(RSCDATA, ";")_" fai led to add !")
	8442	"RTN","PRC A315P",61, 0)
	8443	D MES^XPD UTL(" REVENUE SOURCE CO DES comple ted.")
	8444	"RTN","PRC A315P",62, 0)
	8445	Q
	8446	"RTN","PRC A315P",63, 0)
	8447	;
	8448	"RTN","PRC A315P",64, 0)
	8449	;Revenue Source Cod es (RSC#)
	8450	"RTN","PRC A315P",65, 0)
	8451	NEWRSC ;SO URCE CODE; NAME
	8452	"RTN","PRC A315P",66, 0)
	8453	;;8VZZ;HU MAN 3RD-PR TY OUTPATI ENT
	8454	"RTN","PRC A315P",67, 0)
	8455	;;8UZZ;HU MAN 3RD-PR TY INPATIE NT
	8456	"RTN","PRC A315P",68, 0)
	8457	;;841Z;IN ELI 3RD-P ARTY INPAT IENT
	8458	"RTN","PRC A315P",69, 0)
	8459	;;842Z;IN ELI 3RD-P ARTY OUTPA TIENT
	8460	"RTN","PRC A315P",70, 0)
	8461	;;END
	8462	"RTN","PRC A315P",71, 0)
	8463	;
	8464	"RTN","PRC A315P",72, 0)
	8465	;
	8466	"RTN","PRC A315P",73, 0)
	8467	;;ACCOUNT S RECEIVAB LE CATEGOR Y FILE (#4 30.2)
	8468	"RTN","PRC A315P",74, 0)
	8469	;;.01 CAT EGORY;1 AB BREVIATION ;6 CATEGOR Y NUMBER;7 ACCRUED
	8470	"RTN","PRC A315P",75, 0)
	8471	CT46 ;;EME RGENCY/HUM ANITARIAN REIMB.;HR; 251;48;T;1 213;1
	8472	"RTN","PRC A315P",76, 0)
	8473	CT47 ;;INE LIGIBLE HO SP. REIMB. ;IR;251;49 ;T;1213;0
	8474	"RTN","PRC ABD")
	8475	0^9^B17130 552
	8476	"RTN","PRC ABD",1,0)
	8477	PRCABD ;SF -ISC/RSD-D ISPLAY/PRI NT BILL ;1 2/15/95 1 0:54
	8478	"RTN","PRC ABD",2,0)
	8479	V ;;4.5;Ac counts Rec eivable; 29,57,104, 109,154,23 3,315;20 -MAR-95;Bu ild 2
	8480	"RTN","PRC ABD",3,0)
	8481	;Per VA D irective 6 402, this routine sh ould not b e modified .
	8482	"RTN","PRC ABD",4,0)
	8483	;
	8484	"RTN","PRC ABD",5,0)
	8485	DEV Q:'$D( PRCABT) K ZTSAVE S %ZIS="QM" D ^%ZIS Q: POP G EN: IO=IO(0)
	8486	"RTN","PRC ABD",6,0)
	8487	I $D(IO(" Q")) S ZTR TN=$S(PRCA BT=3:"EN^P RCABD",1:" ^PRCABP"_P RCABT),ZTD TH=$H,ZTSA
	8488	VE("D0")=" ",ZTSAVE(" PRCABT")=" ",ZTSAVE(" PRCADFM")= "" D ^%ZTL OAD G Q
	8489	"RTN","PRC ABD",7,0)
	8490	U IO
	8491	"RTN","PRC ABD",8,0)
	8492	EN Q:'$D(D 0) S PRCA D0=$G(^PRC A(430,D0,0 )),PRCAD10 =$G(^(100) ),PRCAD14= $G(^(104))
	8493	G Q:PRCAD 0=""!(PRCA D10="")
	8494	"RTN","PRC ABD",9,0)
	8495	S $P(PRCA DUL,"-",80 )="-" W @I OF,"BILL # : ",$P(PRC AD0,U,1),? 30,"DATE: " S Y=$P(P
	8496	RCAD0,U,10 ) D DT W ? 60,"TYPE: ",$P("1081 ^1080^1114 ","^",PRCA BT),!,"DEB TOR: ",?40
	8497	,"BILLING AGENCY: ", !
	8498	"RTN","PRC ABD",10,0)
	8499	S Y=+$P(P RCAD0,U,9) ,X=$S($D(^ RCD(340,Y, 0)):$P(^(0 ),U,1),1:" "),X(1)="" S:X]"" X(
	8500	1)=$S($D(@ ("^"_$P(X, ";",2)_+X_ ",0)")):$P (^(0),U,1) ,1:"")
	8501	"RTN","PRC ABD",11,0)
	8502	S PRCADB= $S($D(^RCD (340,+$P(P RCAD0,"^", 9),0)):$P( ^(0),"^"), 1:"") S X= $$DADD^RCA
	8503	MADD(PRCAD B) K PRCAD B S J=2 D ADD
	8504	"RTN","PRC ABD",12,0)
	8505	S Y=+$P(P RCAD10,U,7 ),X(6)=$P( $G(^RC(342 .1,+Y,0)), "^"),X=$$S ADD^RCFN01 (+Y_";RC(3
	8506	42.1,"),J= 7 D ADD F I=1:1:5 I $D(X(I))!( $D(X(I+5)) ) W !?1 W: $D(X(I)) X (I) W ?41
	8507	W:$D(X(I+5 )) X(I+5)
	8508	"RTN","PRC ABD",13,0)
	8509	;*** P ROBABLY WA NT TO ENTE R ACCT LIN E INFO HER E ***
	8510	"RTN","PRC ABD",14,0)
	8511	W !!,"CON TROL POINT :"
	8512	"RTN","PRC ABD",15,0)
	8513	W ?17,$P( $G(^PRCA(4 30,D0,11)) ,U)
	8514	"RTN","PRC ABD",16,0)
	8515	W ! W:PRC ABT=1 !?40 ,"AGENCY L OCATION CO DE: ",$P(P RCAD10,U,3 ) W !,"APP ROVING OFF
	8516	ICIAL: "
	8517	"RTN","PRC ABD",17,0)
	8518	I $P(PRCA D14,U,2)]" " S X=$P(P RCAD14,U,2 ),P=+PRCAD 14,DA=D0 D DE^PRCASI G(.X,P,DA_
	8519	+$P(PRCAD0 ,U,3)) W " /ES/ ",X," DATE: " S Y=$P(PR CAD14,U,3) D DT
	8520	"RTN","PRC ABD",18,0)
	8521	W ! F I=0 :0 S I=$O( ^PRCA(430, D0,2,I)) Q :'I I $D( ^(I,0)) S X=^(0) W ! ,"FY: ",$P
	8522	(X,U,1),?1 2,"APPR. S YMBOL: ",$ P($G(^PRCA (430,D0,11 )),U,17),? 50,"AMOUNT : ",$J($P(
	8523	X,U,2),10, 2)
	8524	"RTN","PRC ABD",19,0)
	8525	D DES(D0, PRCABT)
	8526	"RTN","PRC ABD",20,0)
	8527	;PRCA4.5 315 Print Beneficia ry Travel Notice
	8528	"RTN","PRC ABD",21,0)
	8529	D BENEPRT ^PRCABIL1
	8530	"RTN","PRC ABD",22,0)
	8531	Q D ^%ZISC K DA,DIWL ,DIWR,DIWF ,FLN,I,J,P ,PRCAD,PRC AD0,PRCAD1 0,PRCAD14, PRCADFM,PR
	8532	CADI,PRCAD I0,PRCADQ, PRCADUL,X, Y,Z,ZTDTH, ZTRTN,ZTSA VE,%ZIS Q
	8533	"RTN","PRC ABD",23,0)
	8534	DES(D0,PRC ABT) ;also entry fro m letter r outine
	8535	"RTN","PRC ABD",24,0)
	8536	NEW DIWF, DIWL,DIWR, FLN,PRCAD, PRCADI,PRC ADI0,PRCAD Q
	8537	"RTN","PRC ABD",25,0)
	8538	W !! D HD R S (PRCAD Q,PRCADI)= 0
	8539	"RTN","PRC ABD",26,0)
	8540	DESL S PRC ADI=$O(^PR CA(430,D0, 101,PRCADI )) G:'PRCA DI DESQ S PRCADI0=^( PRCADI,0),
	8541	PRCAD=0,DI WL=1,DIWR= 50,DIWF="" K ^UTILIT Y($J,"W"), FLN
	8542	"RTN","PRC ABD",27,0)
	8543	F S PRCA D=$O(^PRCA (430,D0,10 1,PRCADI,1 ,PRCAD)) Q :'PRCAD S X=$S($D(^ (PRCAD,0))
	8544	:^(0),1:"" ) D ^DIWP
	8545	"RTN","PRC ABD",28,0)
	8546	I $D(^UTI LITY($J,"W ",DIWL)) F I=0:0 S I =$O(^UTILI TY($J,"W", DIWL,I)) Q :'I S DIW
	8547	F=^(I,0) D :'$D(FLN) FLN Q:PRCA DQ I $D(F LN),DIWF'= "" W !,?11 ,DIWF
	8548	"RTN","PRC ABD",29,0)
	8549	I '$D(FLN ) D FLN
	8550	"RTN","PRC ABD",30,0)
	8551	K ^UTILIT Y($J,"W") W !! G:'PR CADQ DESL
	8552	"RTN","PRC ABD",31,0)
	8553	DESQ Q
	8554	"RTN","PRC ABD",32,0)
	8555	FLN ;first line of d etail afte r descript ion
	8556	"RTN","PRC ABD",33,0)
	8557	Q:$D(FLN) D ASK Q: PRCADQ S FLN=1
	8558	"RTN","PRC ABD",34,0)
	8559	W:PRCABT= 2 $P(PRCAD I0,U,7),?1 1 S Y=$P(P RCADI0,U,1 ) D DT
	8560	"RTN","PRC ABD",35,0)
	8561	W ?11 I $ L($G(DIWF) )<25 W DIW F S DIWF=" "
	8562	"RTN","PRC ABD",36,0)
	8563	W:$P(PRCA DI0,U,3)]" " ?37,$J($ S($P(PRCAD I0,U,3)?1" .".N:"0"_$ P(PRCADI0, U,3),1:$P(
	8564	PRCADI0,U, 3)),8)
	8565	"RTN","PRC ABD",37,0)
	8566	W:$P(PRCA DI0,U,4)]" " ?47,$J($ P(PRCADI0, U,4),12,4) W ?62,$S( $D(^PRCD(4 20.5,+$P(P
	8567	RCADI0,U,5 ),0)):$P(^ (0),U,1),1 :"")
	8568	"RTN","PRC ABD",38,0)
	8569	W ?65,$J( $P(PRCADI0 ,U,6),15,2 )
	8570	"RTN","PRC ABD",39,0)
	8571	Q
	8572	"RTN","PRC ABD",40,0)
	8573	ASK I $E(I OST,1,2)=" C-",($Y+4) >IOSL W !? 8,"ENTER ' ^' TO HALT : " R X:DT IME S:X["^
	8574	"!'$T PRCA DQ=1 Q:PRC ADQ W @IO F D HDR Q
	8575	"RTN","PRC ABD",41,0)
	8576	I $E(IOST ,1,2)'="C- ",($Y+4)>I OSL W @IOF D HDR
	8577	"RTN","PRC ABD",42,0)
	8578	Q
	8579	"RTN","PRC ABD",43,0)
	8580	HDR I PRCA BT=2 W !," ORDER NO." ,?11,"DATE ",?37,"QUA NTITY",?55 ,"COST",?6 1,"PER",?7
	8581	4,"AMOUNT"
	8582	"RTN","PRC ABD",44,0)
	8583	E W !," DATE",?11, "DESCRIPTI ON",?37,"Q UANTITY",? 55,"COST", ?61,"PER", ?74,"AMOUN
	8584	T"
	8585	"RTN","PRC ABD",45,0)
	8586	I '$D(PRC ADUL) S PR CADUL="",$ P(PRCADUL, "_",80)="_ "
	8587	"RTN","PRC ABD",46,0)
	8588	W !,PRCAD UL,! Q
	8589	"RTN","PRC ABD",47,0)
	8590	ADD F I=1: 1:4 S:I<4& ($P(X,U,I) ]"") X(J)= $P(X,U,I), J=J+1 I I= 4 S X(J)=$ P(X,U,4) S
	8591	:$P(X,U,5) '="" X(J)= X(J)_", "_ $P(X,U,5)_ " "_$P(X,U ,6)
	8592	"RTN","PRC ABD",48,0)
	8593	Q
	8594	"RTN","PRC ABD",49,0)
	8595	DT Q:Y="" W $$SLH^R CFN01(Y,"/ ")_" " Q
	8596	"RTN","PRC ABD",50,0)
	8597	EN1 ;PRINT /DISPLAY B ILL
	8598	"RTN","PRC ABD",51,0)
	8599	EN10 D SVC ^PRCABIL G EN1Q:'$D( PRCAP("S") ) S DIC("S ")="S Z0=$ S($D(^PRCA (430.3,+$P
	8600	(^(0),U,8) ,0)):$P(^( 0),U,3),1: 0) I Z0=20 5,$D(^PRCA (430,Y,100 )),+$P(^(1 00),U,2)="
	8601	_PRCAP("S" )
	8602	"RTN","PRC ABD",52,0)
	8603	D BILLN^P RCAUTL G E N1Q:'$D(PR CABN) S PR CABT=+^PRC A(430,PRCA BN,100) G EN1Q:'PRCA
	8604	BT S D0=PR CABN,PRCAD FM=1 D DEV ,EN1Q G EN 10
	8605	"RTN","PRC ABD",53,0)
	8606	EN1Q K D0, DIC,PRCA,P RCABN,PRCA DFM,PRCAP, PRCABT,PRC ATY,Z0,ZTS K Q
	8607	"RTN","PRC ABIL1")
	8608	0^8^B54411 126
	8609	"RTN","PRC ABIL1",1,0 )
	8610	PRCABIL1 ; SF-ISC/RSD - ENTER B ILL INFO ; 10/16/96 7:04 PM
	8611	"RTN","PRC ABIL1",2,0 )
	8612	V ;;4.5;Ac counts Rec eivable; 57,64,109, 147,220,27 6,315;20 -MAR-95;Bu ild 2
	8613	"RTN","PRC ABIL1",3,0 )
	8614	;Per VA D irective 6 402, this routine sh ould not b e modified .
	8615	"RTN","PRC ABIL1",4,0 )
	8616	;
	8617	"RTN","PRC ABIL1",5,0 )
	8618	EN1 ;ENTER NEW BILL
	8619	"RTN","PRC ABIL1",6,0 )
	8620	D ST Q:'% N CP
	8621	"RTN","PRC ABIL1",7,0 )
	8622	EN10 D EN^ PRCABIL2 G Q:'$D(PRC ABN) S $P( ^PRCA(430, PRCABN,0), "^",8)=$O( ^PRCA(430.
	8623	3,"AC",201 ,0)) D EN G EN10
	8624	"RTN","PRC ABIL1",8,0 )
	8625	EN2 ;EDIT BILL
	8626	"RTN","PRC ABIL1",9,0 )
	8627	EN20 D SVC ^PRCABIL Q :'$D(PRCAP ("S")) S DIC("S")=" S Z0=$S($D (^PRCA(430 .3,+$P(^(0
	8628	),U,8),0)) :$P(^(0),U ,3),1:0) I Z0>199,Z0 <210,'$P($ G(^PRCA(43 0,Y,3)),U, 3),+$P($G(
	8629	^(100)),U, 2)="_PRCAP ("S")
	8630	"RTN","PRC ABIL1",10, 0)
	8631	D BILLN^P RCAUTL G Q :'$D(PRCAB N) D EN G EN20
	8632	"RTN","PRC ABIL1",11, 0)
	8633	EN4 ;CANCE L BILL
	8634	"RTN","PRC ABIL1",12, 0)
	8635	EN40 D SVC ^PRCABIL Q :'$D(PRCAP ("S")) S DIC("S")=" S Z0=$S($D (^PRCA(430 .3,+$P(^(0
	8636	),U,8),0)) :$P(^(0),U ,3),1:0) I Z0>199,Z0 <210,$D(^P RCA(430,Y, 100)),+$P( ^(100),U,2
	8637	)="_PRCAP( "S")
	8638	"RTN","PRC ABIL1",13, 0)
	8639	D BILLN^P RCAUTL G Q :'$D(PRCAB N)
	8640	"RTN","PRC ABIL1",14, 0)
	8641	YN S %=2 W !," Sure you want to cancel this Bill" D YN^DICN
	8642	"RTN","PRC ABIL1",15, 0)
	8643	I %=0 W ! ,*7,"Answe r 'Yes' or 'No' " G YN
	8644	"RTN","PRC ABIL1",16, 0)
	8645	I %'=1 D Q G EN40
	8646	"RTN","PRC ABIL1",17, 0)
	8647	S $P(^PRC A(430,PRCA BN,0),"^", 14)=DT,$P( ^(0),"^",1 7)=DUZ,$P( ^(9),"^",6 )=$P(^(0),
	8648	"^",8),PRC A("STATUS" )=$O(^PRCA (430.3,"AC ",210,0)) D UPSTATS^ PRCAUT2 K PRCA("STAT
	8649	US") D Q G EN40
	8650	"RTN","PRC ABIL1",18, 0)
	8651	EN K PRCAD FM S DA=PR CABN D LCK G Q:'$D(D A)
	8652	"RTN","PRC ABIL1",19, 0)
	8653	S DIE="^P RCA(430,"
	8654	"RTN","PRC ABIL1",20, 0)
	8655	I $D(RCAM END) S X=+ ^PRCA(430, DA,100) I X?1N,X<4,X >0 G FORM
	8656	"RTN","PRC ABIL1",21, 0)
	8657	S DR="100 " D ^DIE G :X'?1N Q
	8658	"RTN","PRC ABIL1",22, 0)
	8659	FORM N PRC ACAT,PRCAF UND,PRCABE NE,PRCACA, PRCATYP,PR CAADD,PRCA NAD,PRCAAD 1D,PRCAAD2
	8660	D,PRCACD,P RCASTD
	8661	"RTN","PRC ABIL1",23, 0)
	8662	N PRCAZPD ,PRCAPHD,P RCANM,PRCA PH,PRCAADD 1,PRCAADD2 ,PRCACSZ,P RCACSZD,PR END
	8663	"RTN","PRC ABIL1",24, 0)
	8664	S PRCABEN E=0
	8665	"RTN","PRC ABIL1",25, 0)
	8666	S DR="[PR CA BILL "_ $P("1081^1 080^1114", "^",X)_"]" ,PRCABT=X D ^DIE
	8667	"RTN","PRC ABIL1",26, 0)
	8668	S:$D(DUZ) $P(^PRCA( 430,PRCABN ,9),U,8)=D UZ
	8669	"RTN","PRC ABIL1",27, 0)
	8670	S PRCACAT =$P(^PRCA( 430,PRCABN ,0),U,2)
	8671	"RTN","PRC ABIL1",28, 0)
	8672	;PRCA4.5 315 New P rompt for Beneficiar y Travel i f Category is VENDOR
	8673	"RTN","PRC ABIL1",29, 0)
	8674	I PRCACAT =17 D I $ G(PREND)=1 Q
	8675	"RTN","PRC ABIL1",30, 0)
	8676	.N Y,X
	8677	"RTN","PRC ABIL1",31, 0)
	8678	.W !!
	8679	"RTN","PRC ABIL1",32, 0)
	8680	.S DIR("A ")="IS THI S FOR VETE RANS BENEF ICIARY TRA VEL? "
	8681	"RTN","PRC ABIL1",33, 0)
	8682	.S DIR("? ")="Please answer Ye s or No."
	8683	"RTN","PRC ABIL1",34, 0)
	8684	.S DIR("B ")="NO",DI R(0)="YA^^ "
	8685	"RTN","PRC ABIL1",35, 0)
	8686	.D ^DIR K DIR
	8687	"RTN","PRC ABIL1",36, 0)
	8688	.I '$D(Y( 0)) S PREN D=1 Q
	8689	"RTN","PRC ABIL1",37, 0)
	8690	.I Y(0)=" YES" D
	8691	"RTN","PRC ABIL1",38, 0)
	8692	..S PRCAB ENE=1
	8693	"RTN","PRC ABIL1",39, 0)
	8694	..S PRCAC A=$O(^RC(3 42.1,"B"," AGENT CASH IER",0))
	8695	"RTN","PRC ABIL1",40, 0)
	8696	..S PRCAT YP=$P(^RC( 342.1,PRCA CA,0),U,2)
	8697	"RTN","PRC ABIL1",41, 0)
	8698	..S PRCAA DD=$$SADD^ RCFN01(PRC ATYP)
	8699	"RTN","PRC ABIL1",42, 0)
	8700	..I $G(PR CAADD)'="" D
	8701	"RTN","PRC ABIL1",43, 0)
	8702	...S PRCA NAD=$P(PRC AADD,U),PR CAAD1D=$P( PRCAADD,U, 2),PRCAAD2 D=$P(PRCAA DD,U,3),PR
	8703	CACD=$P(PR CAADD,U,4)
	8704	"RTN","PRC ABIL1",44, 0)
	8705	...S PRCA STD=$P(PRC AADD,U,5), PRCAZPD=$P (PRCAADD,U ,6),PRCAPH D=$P(PRCAA DD,U,7)
	8706	"RTN","PRC ABIL1",45, 0)
	8707	...S PRCA CSZD=PRCAC D_", "_PRC ASTD_" "_ PRCAZPD
	8708	"RTN","PRC ABIL1",46, 0)
	8709	..N Y,X
	8710	"RTN","PRC ABIL1",47, 0)
	8711	..S DIR(" A")="Enter Agent Cas hier Name: "
	8712	"RTN","PRC ABIL1",48, 0)
	8713	..I $G(PR CANAD)'="" S DIR("B" )=PRCANAD
	8714	"RTN","PRC ABIL1",49, 0)
	8715	..S DIR(" ?")="Pleas e enter Ag ent Cashie r Name."
	8716	"RTN","PRC ABIL1",50, 0)
	8717	..S DIR(0 )="FA^^"
	8718	"RTN","PRC ABIL1",51, 0)
	8719	..D ^DIR K DIR
	8720	"RTN","PRC ABIL1",52, 0)
	8721	..I $G(Y) ="^" S PRE ND=1 Q
	8722	"RTN","PRC ABIL1",53, 0)
	8723	..S PRCAN M=Y
	8724	"RTN","PRC ABIL1",54, 0)
	8725	..N Y,X
	8726	"RTN","PRC ABIL1",55, 0)
	8727	..S DIR(" A")="Enter Agent Cas hier Phone Number: "
	8728	"RTN","PRC ABIL1",56, 0)
	8729	..I $G(PR CAPHD)'="" S DIR("B" )=PRCAPHD
	8730	"RTN","PRC ABIL1",57, 0)
	8731	..S DIR(" ?")="Pleas e enter a phone numb er."
	8732	"RTN","PRC ABIL1",58, 0)
	8733	..S DIR(0 )="FA^^"
	8734	"RTN","PRC ABIL1",59, 0)
	8735	..D ^DIR K DIR
	8736	"RTN","PRC ABIL1",60, 0)
	8737	..I $G(Y) ="^" S PRE ND=1 Q
	8738	"RTN","PRC ABIL1",61, 0)
	8739	..S PRCAP H=Y
	8740	"RTN","PRC ABIL1",62, 0)
	8741	..N Y,X
	8742	"RTN","PRC ABIL1",63, 0)
	8743	..S DIR(" A")="Enter Agent Cas hier Addre ss Line 1: "
	8744	"RTN","PRC ABIL1",64, 0)
	8745	..I $G(PR CAAD1D)'=" " S DIR("B ")=PRCAAD1 D
	8746	"RTN","PRC ABIL1",65, 0)
	8747	..S DIR(" ?")="Pleas e enter Ad dress Line 1."
	8748	"RTN","PRC ABIL1",66, 0)
	8749	..S DIR(0 )="FA^^"
	8750	"RTN","PRC ABIL1",67, 0)
	8751	..D ^DIR K DIR
	8752	"RTN","PRC ABIL1",68, 0)
	8753	..I $G(Y) ="^" S PRE ND=1 Q
	8754	"RTN","PRC ABIL1",69, 0)
	8755	..S PRCAA DD1=Y
	8756	"RTN","PRC ABIL1",70, 0)
	8757	..N Y,X
	8758	"RTN","PRC ABIL1",71, 0)
	8759	..S DIR(" A")="Enter Agent Cas hier Addre ss Line 2: "
	8760	"RTN","PRC ABIL1",72, 0)
	8761	..I $G(PR CAAD2D)'=" " S DIR("B ")=PRCAAD2 D
	8762	"RTN","PRC ABIL1",73, 0)
	8763	..S DIR(" ?")="Pleas e enter Ad dress Line 2."
	8764	"RTN","PRC ABIL1",74, 0)
	8765	..S DIR(0 )="FA^^"
	8766	"RTN","PRC ABIL1",75, 0)
	8767	..D ^DIR K DIR
	8768	"RTN","PRC ABIL1",76, 0)
	8769	..I $G(Y) ="^" S PRE ND=1 Q
	8770	"RTN","PRC ABIL1",77, 0)
	8771	..S PRCAA DD2=Y
	8772	"RTN","PRC ABIL1",78, 0)
	8773	..N Y,X
	8774	"RTN","PRC ABIL1",79, 0)
	8775	..S DIR(" A")="Enter Agent Cas hier City, State ZI P: "
	8776	"RTN","PRC ABIL1",80, 0)
	8777	..I $G(PR CACSZD)'=" " S DIR("B ")=PRCACSZ D
	8778	"RTN","PRC ABIL1",81, 0)
	8779	..S DIR(" ?")="Pleas e enter Ci ty, State ZIP."
	8780	"RTN","PRC ABIL1",82, 0)
	8781	..S DIR(0 )="FA^^"
	8782	"RTN","PRC ABIL1",83, 0)
	8783	..D ^DIR K DIR
	8784	"RTN","PRC ABIL1",84, 0)
	8785	..I $G(Y) ="^" S PRE ND=1 Q
	8786	"RTN","PRC ABIL1",85, 0)
	8787	..S PRCAC SZ=Y
	8788	"RTN","PRC ABIL1",86, 0)
	8789	I PRCACAT >39,PRCACA T<45 D
	8790	"RTN","PRC ABIL1",87, 0)
	8791	.S X=PRCA CAT,PRCAFU ND=$S(X=40 :"05",X=41 :"06",X=42 :"07",X=43 :"08",1:"1 0"),PRCAFU
	8792	ND=5287_PR CAFUND
	8793	"RTN","PRC ABIL1",88, 0)
	8794	.S DR="25 9////"_"09 ;203////^S X=PRCAFUN D"
	8795	"RTN","PRC ABIL1",89, 0)
	8796	.;I PRCAF UND'=52870 7 S DR=DR_ ";258////1 "
	8797	"RTN","PRC ABIL1",90, 0)
	8798	.D ^DIE
	8799	"RTN","PRC ABIL1",91, 0)
	8800	.Q
	8801	"RTN","PRC ABIL1",92, 0)
	8802	I $P(^PRC A(430,PRCA BN,0),U,9) =""!('$D(^ (100))!('$ D(^(101))) ) D MESG W !,"Bill i
	8803	s incomple te and mus t be re-ed ited !",*7 G Q
	8804	"RTN","PRC ABIL1",93, 0)
	8805	D EN4^PRC ABIL S PRC AMT1=0,PRC AMTY=0,DIK ="^PRCA(43 0,PRCABN,2 ,"
	8806	"RTN","PRC ABIL1",94, 0)
	8807	F PRCAI=0 :0 S PRCAI =$O(^PRCA( 430,PRCABN ,2,PRCAI)) Q:'PRCAI I $D(^(PR CAI,0)) S
	8808	X=^(0) I $ P(X,"^",8) ]"" S PRCA MT1=PRCAMT 1+$P(X,"^" ,8),PRCAMT Y=PRCAMTY+ 1
	8809	"RTN","PRC ABIL1",95, 0)
	8810	I 'PRCAMT 1 W !!,"Fi scal Year Amount was not enter ed ! Bill is incomp lete",*7 G
	8811	Q
	8812	"RTN","PRC ABIL1",96, 0)
	8813	I PRCAMTY >1 W !!,"M ultiple Fi scal Years are not a llowed at this time !",!,"Bill
	8814	is incomp lete and m ust be re- edited.",* 7 G Q
	8815	"RTN","PRC ABIL1",97, 0)
	8816	;S DIE=DI K,DA(1)=PR CABN,DA=+$ O(^PRCA(43 0,PRCABN,2 ,0)),DR=". 01;7" S:'D A ^PRCA(43
	8817	0,PRCABN,2 ,0)="^430. 01" D ^DIE
	8818	"RTN","PRC ABIL1",98, 0)
	8819	I PRCAMT1 '=PRCAMT,P RCABT'=1 W !!,"Fisca l Year Amo unts do no t equal th e total bi
	8820	ll amount !",!,"Bill is incomp lete and m ust be re- edited !", *7 G Q
	8821	"RTN","PRC ABIL1",99, 0)
	8822	I PRCAMT1 '=PRCAMT,P RCABT=1 D ;
	8823	"RTN","PRC ABIL1",100 ,0)
	8824	. N DIE,D A,DR
	8825	"RTN","PRC ABIL1",101 ,0)
	8826	. S PRCAM T1=PRCAMT
	8827	"RTN","PRC ABIL1",102 ,0)
	8828	. S DIE=" ^PRCA(430, PRCABN,2,"
	8829	"RTN","PRC ABIL1",103 ,0)
	8830	. S DA(1) =PRCABN
	8831	"RTN","PRC ABIL1",104 ,0)
	8832	. S DA=+$ O(^PRCA(43 0,PRCABN,2 ,0))
	8833	"RTN","PRC ABIL1",105 ,0)
	8834	. S DR="1 ///"_PRCAM T1
	8835	"RTN","PRC ABIL1",106 ,0)
	8836	. QUIT:'D A
	8837	"RTN","PRC ABIL1",107 ,0)
	8838	. ;
	8839	"RTN","PRC ABIL1",108 ,0)
	8840	. DO ^DIE
	8841	"RTN","PRC ABIL1",109 ,0)
	8842	;
	8843	"RTN","PRC ABIL1",110 ,0)
	8844	S Y=$P(^P RCA(430,PR CABN,0),"^ ",9),Y=Y_" ^"_$P(^RCD (340,Y,0), "^",1)
	8845	"RTN","PRC ABIL1",111 ,0)
	8846	G:$P(Y,"; ",2)="DPT( "!($P(Y,"; ",2)="DIC( 36,") CONT
	8847	"RTN","PRC ABIL1",112 ,0)
	8848	S PRCANOD E=.11 S:$P (Y,";",2)= "DIC(4," P RCANODE=1 S PRCANODE ="^"_$P(Y, ";",2)_+$P
	8849	(Y,"^",2)_ ","_PRCANO DE_")",PRC ANODE=$G(@ PRCANODE)
	8850	"RTN","PRC ABIL1",113 ,0)
	8851	I $P(PRCA NODE,"^",1 )="" S DR= $P(Y,"^",2 ),%=1 W !, " (No Stre et Address ) Edit De
	8852	btor Addre ss: " D YN ^DICN,EN1^ RCAM(DR):% =1 K DIE,D R,DA
	8853	"RTN","PRC ABIL1",114 ,0)
	8854	CONT S Y=^ PRCA(430,P RCABN,0),$ P(Y,"^",3) =PRCAMT,PR CA("STATUS ")=$O(^PRC A(430.3,"A
	8855	C",205,0)) ,^PRCA(430 ,PRCABN,0) =Y,$P(^PRC A(430,PRCA BN,7),"^") =PRCAMT
	8856	"RTN","PRC ABIL1",115 ,0)
	8857	I '$D(RCA MEND) S DI E="^PRCA(4 30,",DA=PR CABN,DR="8 ////"_PRCA ("STATUS") _"" D ^DIE
	8858	K DIE,DR, DA
	8859	"RTN","PRC ABIL1",116 ,0)
	8860	DISP S %=1 ,PRCADFM=1 W !," D isplay/Pri nt Bill:"
	8861	"RTN","PRC ABIL1",117 ,0)
	8862	K IOP D Y N^DICN
	8863	"RTN","PRC ABIL1",118 ,0)
	8864	I %=0 W ! ,*7,"Answe r 'Yes' or 'No' " G DISP
	8865	"RTN","PRC ABIL1",119 ,0)
	8866	D ^PRCABD :%=1
	8867	"RTN","PRC ABIL1",120 ,0)
	8868	Q L -^PRCA (430,+$G(P RCABN),0)
	8869	"RTN","PRC ABIL1",121 ,0)
	8870	K %,%Y,A, B,C,D0,DA, DIC,DIE,DI K,DR,I,PRC A,PRCABC,P RCABN,PRCA BT,PRCADFM ,PRCAI,PRC
	8871	AKCT,PRCAN M,PRCARN,P RCATIME,PR CAMT,PRCAM TY,PRCANM, PRCANODE,P RCAMT1,PRC AMT2,PRCAQ
	8872	,PRCAP,PRC AT,PRCATY, PRCAX,X,Y, Z0,ZRTN,ZT SK Q
	8873	"RTN","PRC ABIL1",122 ,0)
	8874	LCK L +^PR CA(430,DA, 0):0 I Q
	8875	"RTN","PRC ABIL1",123 ,0)
	8876	W !,"ANOT HER USER I S EDITING THIS ENTRY !" K DA Q
	8877	"RTN","PRC ABIL1",124 ,0)
	8878	CP ;CONTRO L POINT LO OK-UP
	8879	"RTN","PRC ABIL1",125 ,0)
	8880	N DIC,PRC ,DIE,DA,DR ,X,Y,PRCSI P,PRCSI
	8881	"RTN","PRC ABIL1",126 ,0)
	8882	S PRC("SI TE")=$S($G (PRCA("SIT E")):PRCA( "SITE"),1: $$SITE^RCM SITE)
	8883	"RTN","PRC ABIL1",127 ,0)
	8884	;S PRC("S ITE")=$$SI TE^RCMSITE
	8885	"RTN","PRC ABIL1",128 ,0)
	8886	S DIC("B" )=$P($G(^P RCA(430,PR CABN,11)), U)
	8887	"RTN","PRC ABIL1",129 ,0)
	8888	D CP^PRCS UT I '$G(P RC("CP")) Q
	8889	"RTN","PRC ABIL1",130 ,0)
	8890	I PRC("CP ")<0 Q
	8891	"RTN","PRC ABIL1",131 ,0)
	8892	S $P(^PRC A(430,PRCA BN,11),U)= PRC("CP")
	8893	"RTN","PRC ABIL1",132 ,0)
	8894	Q
	8895	"RTN","PRC ABIL1",133 ,0)
	8896	BENEPRT ;P RCA4.531 5 Benefici ary Travel Notice of Rights an d Responsi bilities
	8897	"RTN","PRC ABIL1",134 ,0)
	8898	I $G(PRCA BENE) D
	8899	"RTN","PRC ABIL1",135 ,0)
	8900	.N LINE,B ENELTR,DIW F,DIWL,DIW R,IOSLSAVE ,PRNT
	8901	"RTN","PRC ABIL1",136 ,0)
	8902	.S BENELT R=$O(^RC(3 43,"B","BE NEFICIARY TRAVEL NOT ICE",0))
	8903	"RTN","PRC ABIL1",137 ,0)
	8904	.K ^UTILI TY($J) ;pr int main b ody text f rom 343
	8905	"RTN","PRC ABIL1",138 ,0)
	8906	.S ^UTILI TY($J,1)=" W "_IOF
	8907	"RTN","PRC ABIL1",139 ,0)
	8908	.S IOSLSA VE=IOSL,IO SL=140
	8909	"RTN","PRC ABIL1",140 ,0)
	8910	.U IO
	8911	"RTN","PRC ABIL1",141 ,0)
	8912	.W #
	8913	"RTN","PRC ABIL1",142 ,0)
	8914	.F LINE=0 :0 S LINE= $O(^RC(343 ,BENELTR,1 ,LINE)) Q: 'LINE S X =$G(^(LINE ,0)) I X]"
	8915	" W:($Y+2) >IOSL @IOF S DIWL=1, DIWR=80,DI WF="N" D ^ DIWP
	8916	"RTN","PRC ABIL1",143 ,0)
	8917	.D ^DIWW S:$G(PRNT) ="FL" PRNT =1 K ^UTIL ITY($J)
	8918	"RTN","PRC ABIL1",144 ,0)
	8919	.S IOSL=I OSLSAVE
	8920	"RTN","PRC ABIL1",145 ,0)
	8921	.W !,"Loc al Agent C ashier Con tact Infor mation"
	8922	"RTN","PRC ABIL1",146 ,0)
	8923	.W !," A gent Cashi er: ",$G(P RCANM)
	8924	"RTN","PRC ABIL1",147 ,0)
	8925	.W !," Office Pho ne: ",$G(P RCAPH)
	8926	"RTN","PRC ABIL1",148 ,0)
	8927	.W !,"Mai ling Addre ss: ",$G(P RCAADD1)
	8928	"RTN","PRC ABIL1",149 ,0)
	8929	.W !," ",$G(P RCAADD2)
	8930	"RTN","PRC ABIL1",150 ,0)
	8931	.W !," ",$G(P RCACSZ)
	8932	"RTN","PRC ABIL1",151 ,0)
	8933	Q
	8934	"RTN","PRC ABIL1",152 ,0)
	8935	;
	8936	"RTN","PRC ABIL1",153 ,0)
	8937	ST D CKSIT E^PRCAUDT S %=$D(PRC A("CKSITE" )) Q
	8938	"RTN","PRC ABIL1",154 ,0)
	8939	ST1 D SVC^ PRCABIL S %=$S($D(PR CAP("S")): 1,1:0) Q:%
	8940	"RTN","PRC ABIL1",155 ,0)
	8941	K PRCAP Q
	8942	"RTN","PRC ABIL1",156 ,0)
	8943	DIP D SVC^ PRCABIL Q: '$D(PRCAP( "S"))
	8944	"RTN","PRC ABIL1",157 ,0)
	8945	; PRCA4. 5276 - ad d '@' to B ILL NO. in the 'BY' paramter s o that pri ntout does
	8946	not show it as a so rting fiel d.
	8947	"RTN","PRC ABIL1",158 ,0)
	8948	S FR=PRCA P("S")_",? ,@",TO=PRC AP("S")_", ?",L=0,DIC ="^PRCA(43 0,",FLDS=" [PRCA BILL
	8949	LIST]",BY ="@INTERNA L(SERVICE) ,@BILL NO. ,FORM TYPE " D EN1^DI P K BY,DHD ,DIC,FLDS,
	8950	FR,L,PRCAP ,TO Q
	8951	"RTN","PRC ABIL1",159 ,0)
	8952	MESG I $P( ^PRCA(430, PRCABN,0), U,9)="" W !,?3,"Debt or (or Pay er) data i s missing.
	8953	"
	8954	"RTN","PRC ABIL1",160 ,0)
	8955	I '$D(^PR CA(430,PRC ABN,100)) W !,?3,"Se rvice (or Section) , Form type or Vouche
	8956	r number d ata is mis sing."
	8957	"RTN","PRC ABIL1",161 ,0)
	8958	I '$D(^PR CA(430,PRC ABN,101)) W !,?3,"Da te of Char ge data do es not exi st."
	8959	"RTN","PRC ABIL1",162 ,0)
	8960	W ! Q
	8961	"RTN","PRC APCL")
	8962	0^11^B4153 2110
	8963	"RTN","PRC APCL",1,0)
	8964	PRCAPCL ;W ASH-ISC@AL TOONA,PA/N YB-Print B ill Status Report ;8 /19/94 10 :21 AM
	8965	"RTN","PRC APCL",2,0)
	8966	V ;;4.5;Ac counts Rec eivable; 72,63,143, 154,315; Mar 20, 19 95;Build 2
	8967	"RTN","PRC APCL",3,0)
	8968	;Per VA D irective 6 402, this routine sh ould not b e modified .
	8969	"RTN","PRC APCL",4,0)
	8970	N BAL,BN, CAT,DEAD,D EBT,DIR,DI ROUT,DUOUT ,DP,DP2,HD R,IOP,N430
	8971	"RTN","PRC APCL",5,0)
	8972	N PAGE,PO P,PRCAE,PR CATOT,PRCA TOT2,PRCAT ,PRCAT2,PR CY,RCDOJ,T DT,ST,STT
	8973	"RTN","PRC APCL",6,0)
	8974	S (PAGE,P RCAT,PRCAT 2,PRCATOT, PRCATOT2,H DR)=0
	8975	"RTN","PRC APCL",7,0)
	8976	D NOW^%DT C S Y=% X ^DD("DD") S TDT=Y
	8977	"RTN","PRC APCL",8,0)
	8978	I $G(STAT )="ALL" S STT=0 F S STT=($O(^ PRCA(430.3 ,"AC",STT) )) Q:STT=" " D
	8979	"RTN","PRC APCL",9,0)
	8980	. I STT<1 00!(STT=10 7) Q
	8981	"RTN","PRC APCL",10,0 )
	8982	. S STAT( $O(^PRCA(4 30.3,"AC", STT,0)))=" "
	8983	"RTN","PRC APCL",11,0 )
	8984	. Q
	8985	"RTN","PRC APCL",12,0 )
	8986	S STAT=0 F S STAT= $O(STAT(ST AT)) Q:STA T=""!($D(D IROUT))!($ D(DUOUT)) D
	8987	"RTN","PRC APCL",13,0 )
	8988	. N NDE
	8989	"RTN","PRC APCL",14,0 )
	8990	. D HDR
	8991	"RTN","PRC APCL",15,0 )
	8992	. F PRCAE =0:0 S PRC AE=$O(^PRC A(430,"AC" ,STAT,PRCA E)),X="" Q :'PRCAE!($ D(DIROUT)!
	8993	($D(DUOUT) )) I $P($ G(^PRCA(43 0,PRCAE,10 0)),"^",2) [$G(SER),$ S($G(SER): +$G(^PRCA(
	8994	430,PRCAE, 100)),1:1) D Q:$D(D IROUT)!($D (DUOUT)) D PRNTL
	8995	"RTN","PRC APCL",16,0 )
	8996	.. I $Y+4 >IOSL D TO P,HDR
	8997	"RTN","PRC APCL",17,0 )
	8998	. I $Y+4> IOSL D TOP ,HDR Q:$D( DIROUT)!($ D(DUOUT))
	8999	"RTN","PRC APCL",18,0 )
	9000	. S DP1=$ S(+DAT>0:+ DAT,1:0)
	9001	"RTN","PRC APCL",19,0 )
	9002	. S DP2=$ S(+$P($G(D AT),"^",2) =0:"",1:+$ P($G(DAT), "^",2))
	9003	"RTN","PRC APCL",20,0 )
	9004	. S ST="" F S ST=$ O(^TMP($J, "PRCAE",ST )) Q:ST="" !($D(DIROU T)!($D(DUO UT))) D
	9005	"RTN","PRC APCL",21,0 )
	9006	.. I STAT =40 D STHD R
	9007	"RTN","PRC APCL",22,0 )
	9008	.. S DP=0 F S DP=$ O(^TMP($J, "PRCAE",ST ,DP)) Q:'D P!($D(DIRO UT)!($D(DU OUT))) D
	9009	"RTN","PRC APCL",23,0 )
	9010	... S BN= "" F S BN =$O(^TMP($ J,"PRCAE", ST,DP,BN)) Q:BN=""!( $D(DIROUT) !($D(DUOUT
	9011	))) D
	9012	"RTN","PRC APCL",24,0 )
	9013	.... S ND E=^TMP($J, "PRCAE",ST ,DP,BN)
	9014	"RTN","PRC APCL",25,0 )
	9015	.... S Y= DP X ^DD(" DD") S DP2 =Y K Y
	9016	"RTN","PRC APCL",26,0 )
	9017	.... S RC DOJ=$$REFS T^RCRCUTL( +$O(^PRCA( 430,"B",BN ,0)))
	9018	"RTN","PRC APCL",27,0 )
	9019	.... W $G (DP2),?15, $S(RCDOJ&$ G(BN):$G(B N)_"r",1:$ G(BN)),?30 ,$P(NDE,U, 2),?45,$P(
	9020	NDE,U,3)
	9021	"RTN","PRC APCL",28,0 )
	9022	.... W ?6 5,$J($P(ND E,U,4),9,2 ),!
	9023	"RTN","PRC APCL",29,0 )
	9024	.... S PR CATOT2=PRC ATOT2+$P(N DE,U,4),PR CAT2=PRCAT 2+1
	9025	"RTN","PRC APCL",30,0 )
	9026	.... S PR CATOT=PRCA TOT+$P(NDE ,U,4),PRCA T=PRCAT+1
	9027	"RTN","PRC APCL",31,0 )
	9028	.... I $Y +4>IOSL D TOP,HDR Q: $D(DIROUT) !($D(DUOUT )) I STAT =40 D STHD R
	9029	"RTN","PRC APCL",32,0 )
	9030	.... K ^T MP($J,"PRC AE",ST,DP, BN)
	9031	"RTN","PRC APCL",33,0 )
	9032	. I X'="^ " W !!!,"S UBTOTAL: " ,$J(PRCATO T2,10,2),! ,"SUBCOUNT : ",$J(PRC AT2,10),?3
	9033	0 Q:$D(DIR OUT)!($D(D UOUT))
	9034	"RTN","PRC APCL",34,0 )
	9035	. S (PRCA TOT2,PRCAT 2)=0
	9036	"RTN","PRC APCL",35,0 )
	9037	. Q:$D(DI ROUT)!($D( DUOUT))
	9038	"RTN","PRC APCL",36,0 )
	9039	. I $O(ST AT(STAT))= "" Q
	9040	"RTN","PRC APCL",37,0 )
	9041	. I $O(ST AT(STAT))' ="" W !! D TOP
	9042	"RTN","PRC APCL",38,0 )
	9043	I X'="^" W !!!,"TOT AL: ",$J(P RCATOT,10, 2),!,"COUN T: ",$J(PR CAT,10),!, " MEAN: ",
	9044	$J($S('PRC AT:0,1:PRC ATOT/PRCAT ),10,2),?3 0,"* -indi cates that patient i s deceased
	9045	",!,?30,"r -indicate s that bil l is refer red"
	9046	"RTN","PRC APCL",39,0 )
	9047	W:$E(IOST )="P" @IOF Q
	9048	"RTN","PRC APCL",40,0 )
	9049	TOP ;
	9050	"RTN","PRC APCL",41,0 )
	9051	I $E(IOST )="C" S X= "" S DIR(0 )="E" D ^D IR Q:$D(DI ROUT)!($D( DUOUT))
	9052	"RTN","PRC APCL",42,0 )
	9053	Q2 Q
	9054	"RTN","PRC APCL",43,0 )
	9055	PRNTL ;
	9056	"RTN","PRC APCL",44,0 )
	9057	N BAL,DEA D,DEBT,ST
	9058	"RTN","PRC APCL",45,0 )
	9059	S X=$S($D (^PRCA(430 ,PRCAE,0)) :^(0),1:"" ) G:X="" P Q
	9060	"RTN","PRC APCL",46,0 )
	9061	S BN=$P($ G(X),U),DP =$P($G(X), U,14),PRCY =$P($G(X), U,2) G:BN= "" PQ
	9062	"RTN","PRC APCL",47,0 )
	9063	S BEG=+DA T-1,END=+$ P(DAT,U,2)
	9064	"RTN","PRC APCL",48,0 )
	9065	S ST=999 I STAT=40 D SUST ;PR CA4.5315 /DRF Find suspended type
	9066	"RTN","PRC APCL",49,0 )
	9067	I BEG,DP' >BEG Q
	9068	"RTN","PRC APCL",50,0 )
	9069	I END,DP> END Q
	9070	"RTN","PRC APCL",51,0 )
	9071	I STAT=40 ,$G(PRSELS T)'="",PRS ELST'[("," _ST_",") Q ;PRCA4. 5315/DRF Quit if su
	9072	spended ty pe is not selected
	9073	"RTN","PRC APCL",52,0 )
	9074	S (CAT,PR CY)=$S(PRC Y="":PRCY, $D(^PRCA(4 30.2,PRCY, 0))#2:$P(^ (0),U),1:P RCY)
	9075	"RTN","PRC APCL",53,0 )
	9076	S PRCY=$S ($D(^RCD(3 40,+$P(X,U ,9),0)):$P (^(0),U),1 :"")
	9077	"RTN","PRC APCL",54,0 )
	9078	I PRCY["D PT" S DFN= +PRCY D DE M^VADPT S: +VADM(6) D EAD="*" D KVAR^VADPT K VA,VADM
	9079	"RTN","PRC APCL",55,0 )
	9080	I PRCY]"" S (DEBT,P RCY)=$S($D (@("^"_$P( PRCY,";",2 )_+PRCY_", 0)")):^(0) ,1:"")
	9081	"RTN","PRC APCL",56,0 )
	9082	S PRCY=$S ($D(^PRCA( 430,PRCAE, 7)):^(7),1 :"")
	9083	"RTN","PRC APCL",57,0 )
	9084	I 'PRCY,( STAT=$O(^P RCA(430.3, "AC",104,0 ))!((STAT= 20)&($G(^P RCA(430,PR CAE,100)))
	9085	))
	9086	"RTN","PRC APCL",58,0 )
	9087	S (BAL,PR CY)=$P(PRC Y,U)+$P(PR CY,U,2)+$P (PRCY,U,3) +$P(PRCY,U ,4)+$P(PRC Y,U,5)
	9088	"RTN","PRC APCL",59,0 )
	9089	I DP'="" S ^TMP($J, "PRCAE",ST ,DP,BN)=U_ $E(CAT,1,1 3)_U_$G(DE AD)_$E($P( $G(DEBT),U
	9090	),1,15)_U_ $G(BAL)_U_ $G(PRCATOT 2)_U_$G(PR CAT2)
	9091	"RTN","PRC APCL",60,0 )
	9092	I $G(SER) ,(STAT=31! (STAT=32)) S Y=$G(^P RCA(430,PR CAE,3)) D
	9093	"RTN","PRC APCL",61,0 )
	9094	. W:$P(Y, U)]"" !,"D ate: ",$E( $P(Y,U),4, 5),"/",$E( $P(Y,U),6, 7),"/",$E( $P(Y,U),2,
	9095	3)
	9096	"RTN","PRC APCL",62,0 )
	9097	. W:$P(Y, U,2)]"" " By: ",$P( $G(^VA(200 ,+$P(Y,U,2 ),0)),U)
	9098	"RTN","PRC APCL",63,0 )
	9099	. W:$P(Y, U,6)]"" " Reason: " ,$P(Y,U,6)
	9100	"RTN","PRC APCL",64,0 )
	9101	. Q
	9102	"RTN","PRC APCL",65,0 )
	9103	I $E(IOST )="",$Y+4> IOSL D TOP
	9104	"RTN","PRC APCL",66,0 )
	9105	PQ Q
	9106	"RTN","PRC APCL",67,0 )
	9107	HDR ;
	9108	"RTN","PRC APCL",68,0 )
	9109	I $E(IOST )="C"!PAGE W @IOF
	9110	"RTN","PRC APCL",69,0 )
	9111	S PAGE=PA GE+1
	9112	"RTN","PRC APCL",70,0 )
	9113	W !,"BILL STATUS LI STING REPO RT"
	9114	"RTN","PRC APCL",71,0 )
	9115	W ?40,$G( TDT),?72,$ G(PAGE)
	9116	"RTN","PRC APCL",72,0 )
	9117	W !,"Sort Criteria for Date L ast Update d Range: " _SC1_" to "_SC2
	9118	"RTN","PRC APCL",73,0 )
	9119	W !,"Date Last",!," Updated", ?15,"Bill no.",?30," Category"
	9120	"RTN","PRC APCL",74,0 )
	9121	W ?50,"De btor",?68, "Balance", !
	9122	"RTN","PRC APCL",75,0 )
	9123	S X="",$P (X,"-",IOM -1)="" W X ,!
	9124	"RTN","PRC APCL",76,0 )
	9125	W !,?5,"S tatus: ",$ P($S($D(^P RCA(430.3, STAT,0)):^ (0),1:""), U)
	9126	"RTN","PRC APCL",77,0 )
	9127	S HDR=1
	9128	"RTN","PRC APCL",78,0 )
	9129	W !!
	9130	"RTN","PRC APCL",79,0 )
	9131	Q
	9132	"RTN","PRC APCL",80,0 )
	9133	DT I Y X ^ DD("DD") S DP2=Y
	9134	"RTN","PRC APCL",81,0 )
	9135	Q
	9136	"RTN","PRC APCL",82,0 )
	9137	STAT(SER) W ! ;Bill Status Lis ting
	9138	"RTN","PRC APCL",83,0 )
	9139	N BEG,CH, DAT,END,I, PRSELST,PR SUS,SC1,SC 2,STAT,STT ,XX
	9140	"RTN","PRC APCL",84,0 )
	9141	K ^TMP($J )
	9142	"RTN","PRC APCL",85,0 )
	9143	S DAT=$$D ATE^RCEVUT L1("")
	9144	"RTN","PRC APCL",86,0 )
	9145	Q:$G(DAT) =-1
	9146	"RTN","PRC APCL",87,0 )
	9147	S BEG=+DA T,END=+$P( DAT,U,2)
	9148	"RTN","PRC APCL",88,0 )
	9149	S SC1=$S( BEG=0:"Fir st",1:BEG- 1) I +$G(S C1) S Y=SC 1+1 X ^DD( "DD") S SC 1=Y
	9150	"RTN","PRC APCL",89,0 )
	9151	S SC2=$S( END=0:"Las t",1:END) I +$G(SC2) S Y=SC2 X ^DD("DD") S SC2=Y
	9152	"RTN","PRC APCL",90,0 )
	9153	S XX=^DD( 433,90,0), XX=$P(XX," ^",3) F I= 1:1 S CH=$ P(XX,";",I ) Q:CH="" S PRSUS($
	9154	P(CH,":",1 ))=$P(CH," :",2)
	9155	"RTN","PRC APCL",91,0 )
	9156	D ST
	9157	"RTN","PRC APCL",92,0 )
	9158	Q:STAT="^ "
	9159	"RTN","PRC APCL",93,0 )
	9160	D TSK,Q1
	9161	"RTN","PRC APCL",94,0 )
	9162	Q
	9163	"RTN","PRC APCL",95,0 )
	9164	ST N DIC,X ,Y
	9165	"RTN","PRC APCL",96,0 )
	9166	S DIC="^P RCA(430.3, ",DIC(0)=" QEMZ"
	9167	"RTN","PRC APCL",97,0 )
	9168	S DIC("S" )="I $P(^( 0),""^"",3 )>100,($P( ^(0),""^"" ,3)'=107)"
	9169	"RTN","PRC APCL",98,0 )
	9170	S Y=0 W ! ,"STATUS: "_$S('$O(S TAT("")):" ALL// ",1: "")
	9171	"RTN","PRC APCL",99,0 )
	9172	R X:DTIME I '$T!(X= "^") S STA T="^" Q
	9173	"RTN","PRC APCL",100, 0)
	9174	I ((X="") !(X="ALL") ),'$O(STAT ("")) S (S TAT,X)="AL L" Q
	9175	"RTN","PRC APCL",101, 0)
	9176	I X="" Q
	9177	"RTN","PRC APCL",102, 0)
	9178	D ^DIC S STAT=+Y,SE R=$G(SER)
	9179	"RTN","PRC APCL",103, 0)
	9180	I X["?" W !!,"Enter 'ALL' for all statu s types.", ! G ST
	9181	"RTN","PRC APCL",104, 0)
	9182	I STAT'=" ALL",(+STA T>0) S STA T(+STAT)=" " D:STAT=4 0 SUSTYP G ST
	9183	"RTN","PRC APCL",105, 0)
	9184	G:+STAT<0 ST
	9185	"RTN","PRC APCL",106, 0)
	9186	Q
	9187	"RTN","PRC APCL",107, 0)
	9188	SUSTYP ;If SUSPENDED is chosen , prompt f or which s uspended b ills to di splay PRCA
	9189	4.5315/D RF
	9190	"RTN","PRC APCL",108, 0)
	9191	N X,CH,LA ST,PRPRT
	9192	"RTN","PRC APCL",109, 0)
	9193	S LAST=$O (PRSUS("") ,-1),PRSUS (LAST+1)=" ALL OF THE ABOVE"
	9194	"RTN","PRC APCL",110, 0)
	9195	S PRPRT=" Choose fro m SUSPENDE D TYPE:"
	9196	"RTN","PRC APCL",111, 0)
	9197	S PRSELST =$$MLTP0(P RPRT,.PRSU S,1)
	9198	"RTN","PRC APCL",112, 0)
	9199	Q
	9200	"RTN","PRC APCL",113, 0)
	9201	SUST ;Look for suspe nded type for a susp ended bill PRCA4.5 315/DRF
	9202	"RTN","PRC APCL",114, 0)
	9203	N TRANS
	9204	"RTN","PRC APCL",115, 0)
	9205	S TRANS=$ O(^PRCA(43 3,"C",PRCA E,""),-1)
	9206	"RTN","PRC APCL",116, 0)
	9207	S ST=$P($ G(^PRCA(43 3,TRANS,1) ),U,11)
	9208	"RTN","PRC APCL",117, 0)
	9209	I ST="" S ST="NONE"
	9210	"RTN","PRC APCL",118, 0)
	9211	Q
	9212	"RTN","PRC APCL",119, 0)
	9213	STHDR ;Dis play Suspe nded Type PRCA4.53 15/DRF
	9214	"RTN","PRC APCL",120, 0)
	9215	I 'HDR W !
	9216	"RTN","PRC APCL",121, 0)
	9217	W ?30,"Su spend Type : ",$S(ST= "NONE":ST, 1:PRSUS(ST )),!!
	9218	"RTN","PRC APCL",122, 0)
	9219	S HDR=0
	9220	"RTN","PRC APCL",123, 0)
	9221	Q
	9222	"RTN","PRC APCL",124, 0)
	9223	TSK ;
	9224	"RTN","PRC APCL",125, 0)
	9225	N POP,ZTS K
	9226	"RTN","PRC APCL",126, 0)
	9227	W *7,!,"R eport shou ld be QUEU ED it coul d take som e time to run!"
	9228	"RTN","PRC APCL",127, 0)
	9229	S POP=0,% ZIS="MQ" D ^%ZIS G:P OP Q1
	9230	"RTN","PRC APCL",128, 0)
	9231	I '$D(IO( "Q")) U IO D PRCAPCL U IO(0) G Q1
	9232	"RTN","PRC APCL",129, 0)
	9233	S ZTRTN=" ^PRCAPCL"
	9234	"RTN","PRC APCL",130, 0)
	9235	S (ZTSAVE ("BEG"),ZT SAVE("DAT" ),ZTSAVE(" END"),ZTSA VE("SER")) =""
	9236	"RTN","PRC APCL",131, 0)
	9237	S (ZTSAVE ("STAT"),Z TSAVE("STA T("),ZTSAV E("SC1"),Z TSAVE("SC2 "))=""
	9238	"RTN","PRC APCL",132, 0)
	9239	S (ZTSAVE ("PRSELST" ),ZTSAVE(" PRSUS("))= ""
	9240	"RTN","PRC APCL",133, 0)
	9241	S ZTDESC= "Bill Stat us Listing " D ^%ZTLO AD
	9242	"RTN","PRC APCL",134, 0)
	9243	Q1 D ^%ZIS C Q
	9244	"RTN","PRC APCL",135, 0)
	9245	;
	9246	"RTN","PRC APCL",136, 0)
	9247	;Choose m ultiple it ems from a list incl uding valu e 0 - PRCA 4.5315/D RF
	9248	"RTN","PRC APCL",137, 0)
	9249	MLTP0(PRPT ,OPT,ALL) ; Function for multi ple value selection
	9250	"RTN","PRC APCL",138, 0)
	9251	; Input: PRPT - Str ing to be prompted t o the user , before l isting opt ions
	9252	"RTN","PRC APCL",139, 0)
	9253	; OPT - Arr ay contain ing the po ssible ent ries (inde xed by cod e)
	9254	"RTN","PRC APCL",140, 0)
	9255	; Obs : Code mus t be seque ntial star ting with 0
	9256	"RTN","PRC APCL",141, 0)
	9257	; ALL - Fla g indicati ng if the last optio n is ALL O F THE ABOV E
	9258	"RTN","PRC APCL",142, 0)
	9259	;
	9260	"RTN","PRC APCL",143, 0)
	9261	; Output: MLTP - Us er selecti on, i.e. " 1,2,3," or "1," or N ULL (nothi ng
	9262	"RTN","PRC APCL",144, 0)
	9263	; w as selecte d)
	9264	"RTN","PRC APCL",145, 0)
	9265	;
	9266	"RTN","PRC APCL",146, 0)
	9267	N A,DIR,D IRUT,DTOUT ,DUOUT,DIR OUT,I,IX,L ST,MLTP
	9268	"RTN","PRC APCL",147, 0)
	9269	;
	9270	"RTN","PRC APCL",148, 0)
	9271	PRPT S MLT P="",ALL=+ $G(ALL)
	9272	"RTN","PRC APCL",149, 0)
	9273	S LST=$O( OPT(""),-1 )
	9274	"RTN","PRC APCL",150, 0)
	9275	S DIR(0)= "LO^0:"_LS T_"^K:+$P( X,""-"",2) >"_LST_" X "
	9276	"RTN","PRC APCL",151, 0)
	9277	S DIR("A" ,1)=$G(PRP T),DIR("A" ,2)=""
	9278	"RTN","PRC APCL",152, 0)
	9279	S A="",IX =3
	9280	"RTN","PRC APCL",153, 0)
	9281	F S A=$O (OPT(A)) Q:A="" D
	9282	"RTN","PRC APCL",154, 0)
	9283	. S DIR(" A",IX)=" "_A_" - " _$G(OPT(A) ),IX=IX+1
	9284	"RTN","PRC APCL",155, 0)
	9285	S DIR("A" ,IX)="",DI R("A")="Se lect",DIR( "B")=LST,D IR("T")=DT IME W !
	9286	"RTN","PRC APCL",156, 0)
	9287	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) S M LTP="" G Q T
	9288	"RTN","PRC APCL",157, 0)
	9289	S MLTP=Y K DIROUT,D TOUT,DUOUT ,DIRUT
	9290	"RTN","PRC APCL",158, 0)
	9291	S DIR(0)= "Y",DIR("A ",1)="You have selec ted",DIR(" A",2)=""
	9292	"RTN","PRC APCL",159, 0)
	9293	S A="",IX =3
	9294	"RTN","PRC APCL",160, 0)
	9295	F I=1:1:( $L(MLTP,", ")-1) D
	9296	"RTN","PRC APCL",161, 0)
	9297	. S DIR(" A",IX)=" "_$P(MLT P,",",I)_" - "_$G(OP T($P(MLTP, ",",I)))
	9298	"RTN","PRC APCL",162, 0)
	9299	. S IX=IX +1
	9300	"RTN","PRC APCL",163, 0)
	9301	S DIR("A" ,IX)=""
	9302	"RTN","PRC APCL",164, 0)
	9303	S DIR("A" )="Are you sure",DIR ("B")="NO" ,DIR("T")= DTIME W !
	9304	"RTN","PRC APCL",165, 0)
	9305	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) S M LTP="" G Q T
	9306	"RTN","PRC APCL",166, 0)
	9307	K DIROUT, DTOUT,DUOU T,DIRUT I 'Y K DIR G PRPT
	9308	"RTN","PRC APCL",167, 0)
	9309	I ALL,MLT P[LST S ML TP="" G QT
	9310	"RTN","PRC APCL",168, 0)
	9311	S MLTP=", "_MLTP
	9312	"RTN","PRC APCL",169, 0)
	9313	;
	9314	"RTN","PRC APCL",170, 0)
	9315	QT Q MLTP
	9316	"RTN","PRC AXP")
	9317	0^1^B23479 334
	9318	"RTN","PRC AXP",1,0)
	9319	PRCAXP ;WA SH-ISC@ALT OONA,PA/TJ K-PRINT RX -COPAY EXE MPTION REP ORT ;10/23 /93 10:01
	9320	AM
	9321	"RTN","PRC AXP",2,0)
	9322	V ;;4.5;Ac counts Rec eivable; 315;Mar 20, 1995;B uild 2
	9323	"RTN","PRC AXP",3,0)
	9324	;;Per VA Directive 6402, this routine s hould not be modifie d.
	9325	"RTN","PRC AXP",4,0)
	9326	NEW BEG,E ND,%DT,%ZI S,IOP,POP, Y,%
	9327	"RTN","PRC AXP",5,0)
	9328	BEG W ! D NOW^%DTC S %DT(0)=-% ,%DT="AEXP ",%DT("A") ="Start Da te: " D ^% DT G:Y<0 Q
	9329	S BEG=Y
	9330	"RTN","PRC AXP",6,0)
	9331	S %DT="AE X",%DT("A" )=" En d Date: ", %DT("B")=" T" D ^%DT G:Y<0 Q S END=Y
	9332	"RTN","PRC AXP",7,0)
	9333	W !!,"You will need a 132 col umn printe r for this report!", !
	9334	"RTN","PRC AXP",8,0)
	9335	W ! K IO( "Q") S %ZI S="MQ" D ^ %ZIS G:POP Q
	9336	"RTN","PRC AXP",9,0)
	9337	I $D(IO(" Q")) S ZTR TN="DQ^PRC AXP",ZTSAV E("BEG")=" ",ZTSAVE(" END")="" D ^%ZTLOAD
	9338	G Q
	9339	"RTN","PRC AXP",10,0)
	9340	U IO
	9341	"RTN","PRC AXP",11,0)
	9342	DQ ;ENTRY POINT FROM TASK MANA GER FOR PR INTING REP ORT
	9343	"RTN","PRC AXP",12,0)
	9344	NEW Y,TOD AY,PG,I,PR CA,PRCAHDR ,BEGPR,END PR,TRDATE, TRNO,T0,T1 ,BILL,TRAM T,OUT,PTNM
	9345	,DFN,CONTI NUE,ID,REC ,TTYPE,VA, PTOT,PGTOT ,TOT,LAST
	9346	"RTN","PRC AXP",13,0)
	9347	COMPUTE ;S ETS TEMPOR ARY GLOBAL FOR PRINT ING
	9348	"RTN","PRC AXP",14,0)
	9349	K ^TMP($J ) S TRDATE =BEG-1,(TO T("D"),TOT ("E"),TOT( "I"))=0,U= "^"
	9350	"RTN","PRC AXP",15,0)
	9351	F S TRDA TE=$O(^PRC A(433,"ACE ",TRDATE)) G PRINT:' TRDATE!($P (TRDATE,". ")>END) S
	9352	TRNO=0 D
	9353	"RTN","PRC AXP",16,0)
	9354	.F S TRN O=$O(^PRCA (433,"ACE" ,TRDATE,TR NO)) Q:'TR NO D
	9355	"RTN","PRC AXP",17,0)
	9356	..S T0=$G (^PRCA(433 ,TRNO,0)), T1=$G(^(1) ) Q:T0=""
	9357	"RTN","PRC AXP",18,0)
	9358	..S BLNO= $P(T0,U,2) ,TRAMT=$P( T1,U,5),TT YPE=$S($P( T1,U,2)=35 :"D",$P(T1 ,U,2)=1:"I
	9359	",1:"E"),E FDT=$P(T1, U,1) ;*31 5 START
	9360	"RTN","PRC AXP",19,0)
	9361	..;S DFN= $P(^PRCA(4 30,BLNO,0) ,U,9),BILL =$P(^(0),U )
	9362	"RTN","PRC AXP",20,0)
	9363	..S P0=$G (^PRCA(430 ,BLNO,0)), DFN=$P(P0, U,9),BILL= $P(P0,U),I BN=0
	9364	"RTN","PRC AXP",21,0)
	9365	..S DFN=$ P(^RCD(340 ,+DFN,0),U ) Q:'DFN!( DFN'["DPT( ") S DFN= +DFN
	9366	"RTN","PRC AXP",22,0)
	9367	..D DEM^V ADPT S PTN M=VADM(1), ID=$E(PTNM ,1)_VA("BI D") S DTH= $S(+VADM(6 ):"*",1:""
	9368	) D KVAR^V ADPT
	9369	"RTN","PRC AXP",23,0)
	9370	..D FNDBI L(TRNO,TTY PE)
	9371	"RTN","PRC AXP",24,0)
	9372	PRINT ;PRI NT REPORT
	9373	"RTN","PRC AXP",25,0)
	9374	S LAST=""
	9375	"RTN","PRC AXP",26,0)
	9376	S Y=BEG X ^DD("DD") S BEGPR=Y
	9377	"RTN","PRC AXP",27,0)
	9378	S Y=END X ^DD("DD") S ENDPR=Y
	9379	"RTN","PRC AXP",28,0)
	9380	S Y=DT X ^DD("DD") S TODAY=Y, PG=0 D HEA D
	9381	"RTN","PRC AXP",29,0)
	9382	I '$D(^TM P($J)) W ! !,"NO EXEM PTIONS FOR THIS TIME PERIOD" G Q
	9383	"RTN","PRC AXP",30,0)
	9384	S PTNM="" F S PTNM =$O(^TMP($ J,PTNM)) Q :PTNM=""!( $D(OUT)) D
	9385	"RTN","PRC AXP",31,0)
	9386	.S DFN=0 F S DFN=$ O(^TMP($J, PTNM,DFN)) Q:'DFN!($ D(OUT)) S CONTINUE= "",PTOT=0
	9387	D I PTOT W !,?115," ---------- ---",!,?11 5,$J(+PTOT ,13,2),!
	9388	"RTN","PRC AXP",32,0)
	9389	..S BILL= "" F S BI LL=$O(^TMP ($J,PTNM,D FN,BILL)) Q:BILL=""! ($D(OUT)) D
	9390	"RTN","PRC AXP",33,0)
	9391	...S TRNO =0 F S TR NO=$O(^TMP ($J,PTNM,D FN,BILL,TR NO)) Q:TRN O=""!($D(O UT)) D
	9392	;*315 STAR T
	9393	"RTN","PRC AXP",34,0)
	9394	....S CON TINUE=""
	9395	"RTN","PRC AXP",35,0)
	9396	....S RX= 0 F S RX= $O(^TMP($J ,PTNM,DFN, BILL,TRNO, RX)) Q:'RX !($D(OUT)) D
	9397	"RTN","PRC AXP",36,0)
	9398	.....S RE C=^TMP($J, PTNM,DFN,B ILL,TRNO,R X),TRAMT=$ P(REC,U,1) W ! W:$D( CONTINUE)
	9399	$P(REC,"^" ,4),$E(PTN M,1,25)," ",?28,$P(R EC,U,2),?3 5,BILL,?48 ,TRNO,?56, $P(REC,U,3
	9400	)
	9401	"RTN","PRC AXP",37,0)
	9402	.....W ?6 0,$S(RX=1: "",1:$P(RE C,U,5)) W ?70,$E($P( REC,U,6),1 ,17),?90,$ P(REC,U,7)
	9403	,?100,$P(R EC,U,8) I $D(CONTINU E),TRNO'=L AST W ?115 ,$J(TRAMT, 13,2)
	9404	"RTN","PRC AXP",38,0)
	9405	.....I $D (CONTINUE) ,TRNO'=LAS T S PTOT=P TOT+TRAMT, PGTOT=+$G( PGTOT)+TRA MT,TOT($S(
	9406	$P(REC,U,3 )]"":$P(RE C,U,3),1:" UNK"))=$G( TOT($S($P( REC,U,3)]" ":$P(REC,U ,3),1:"UNK
	9407	")))+REC ;*315 END
	9408	"RTN","PRC AXP",39,0)
	9409	.....K CO NTINUE S L AST=TRNO D HEAD:($Y+ 4)>IOSL
	9410	"RTN","PRC AXP",40,0)
	9411	G:$D(OUT) Q
	9412	"RTN","PRC AXP",41,0)
	9413	W !,"* -i ndicates p atient is deceased"
	9414	"RTN","PRC AXP",42,0)
	9415	D HEAD:($ Y+7)>IOSL
	9416	"RTN","PRC AXP",43,0)
	9417	W !!,"EXE MPTION TYP ES AND TOT ALS"
	9418	"RTN","PRC AXP",44,0)
	9419	W !!,"D=D ECREASE AD JUSTMENT " ,?35,$J(TO T("D"),13, 2),!,"E=IN TEREST/ADM IN EXEMPTI
	9420	ON ",?35,$ J(TOT("E") ,13,2),!," I=INCREASE ADJUSTMEN T FOR REFU ND ",?35,$ J(TOT("I")
	9421	,13,2)
	9422	"RTN","PRC AXP",45,0)
	9423	I $D(TOT( "UNK")) W !,"UNK=EXE MPTION TYP E UNKNOWN" ,?35,$J(TO T("UNK"),1 3,2)
	9424	"RTN","PRC AXP",46,0)
	9425	W !,?35," ---------- ---",!,?35 ,$J(PGTOT, 13,2)
	9426	"RTN","PRC AXP",47,0)
	9427	K BEG,END ,IO("Q") ; K ^TMP($J)
	9428	"RTN","PRC AXP",48,0)
	9429	Q D ^%ZISC Q
	9430	"RTN","PRC AXP",49,0)
	9431	;
	9432	"RTN","PRC AXP",50,0)
	9433	FNDBIL(TRN O,TTYPE) ;
	9434	"RTN","PRC AXP",51,0)
	9435	N FOUND,C NT,IBN,IB0 ,RR,RX,DRU G,FLDT,EDT ,EFFDT,IBA MT,IBAS,AR TRN
	9436	"RTN","PRC AXP",52,0)
	9437	S (IBN,FO UND,CNT,RX )=0,EDT=""
	9438	"RTN","PRC AXP",53,0)
	9439	F S IBN= $O(^IB("AB IL",BILL,I BN)) Q:IBN ="" D
	9440	"RTN","PRC AXP",54,0)
	9441	.S IB0=^I B(IBN,0),R R=$P(IB0,U ,4),EDT=$P (IB0,U,17) ,IBAMT=$P( IB0,U,7),A RTRN=$P(IB
	9442	0,U,12)
	9443	"RTN","PRC AXP",55,0)
	9444	.I EDT="" S EDT=EFD T
	9445	"RTN","PRC AXP",56,0)
	9446	.I EDT="" S EDT=TRD ATE
	9447	"RTN","PRC AXP",57,0)
	9448	.I ARTRN= TRNO S FOU ND=1 D DAT A Q
	9449	"RTN","PRC AXP",58,0)
	9450	.I 'FOUND ,ARTRN="" D DATA
	9451	"RTN","PRC AXP",59,0)
	9452	I CNT=0,R X=0 D
	9453	"RTN","PRC AXP",60,0)
	9454	.I EDT="" S EDT=EFD T
	9455	"RTN","PRC AXP",61,0)
	9456	.I EDT="" S EDT=TRD ATE
	9457	"RTN","PRC AXP",62,0)
	9458	.S EFFDT= $$FMTE^XLF DT(EDT,"2D Z")
	9459	"RTN","PRC AXP",63,0)
	9460	.D SET(1)
	9461	"RTN","PRC AXP",64,0)
	9462	Q
	9463	"RTN","PRC AXP",65,0)
	9464	;
	9465	"RTN","PRC AXP",66,0)
	9466	DATA ; SET UP DATA
	9467	"RTN","PRC AXP",67,0)
	9468	S CNT=CNT +1
	9469	"RTN","PRC AXP",68,0)
	9470	S RIEN=+$ P(RR,"52:" ,2),RFL=+$ P(RR,":",3 )
	9471	"RTN","PRC AXP",69,0)
	9472	S DRUG=$$ FILE^IBRXU TL(RIEN,6, "E"),RX=$$ FILE^IBRXU TL(RIEN,.0 1)
	9473	"RTN","PRC AXP",70,0)
	9474	I RFL>0 S FLDT=$$SU BFILE^IBRX UTL(RIEN,R FL,52,.01)
	9475	"RTN","PRC AXP",71,0)
	9476	I RFL=0 S FLDT=$$FI LE^IBRXUTL (RIEN,22)
	9477	"RTN","PRC AXP",72,0)
	9478	S EFFDT=$ $FMTE^XLFD T(EDT,"2DZ "),FLDT=$$ FMTE^XLFDT (FLDT,"2DZ ")
	9479	"RTN","PRC AXP",73,0)
	9480	I $D(^TMP ($J,PTNM,D FN,BILL,TR NO,RX)) Q
	9481	"RTN","PRC AXP",74,0)
	9482	D SET(RX)
	9483	"RTN","PRC AXP",75,0)
	9484	Q
	9485	"RTN","PRC AXP",76,0)
	9486	;
	9487	"RTN","PRC AXP",77,0)
	9488	SET(RX) ;
	9489	"RTN","PRC AXP",78,0)
	9490	S ^TMP($J ,PTNM,DFN, BILL,TRNO, RX)=TRAMT_ U_ID_U_TTY PE_U_DTH_U _$G(RX)_U_ $G(DRUG)_U
	9491	_$G(FLDT)_ U_$G(EFFDT )_U_$G(ART RN)_U_$G(I BAS)_U_$G( IBN) ;*31 5 END
	9492	"RTN","PRC AXP",79,0)
	9493	Q
	9494	"RTN","PRC AXP",80,0)
	9495	;
	9496	"RTN","PRC AXP",81,0)
	9497	HEAD ;PRIN TS HEADING
	9498	"RTN","PRC AXP",82,0)
	9499	I PG,$E(I OST,1,2)[" C-" D SCR Q:$D(OUT)
	9500	"RTN","PRC AXP",83,0)
	9501	W @IOF S PG=PG+1
	9502	"RTN","PRC AXP",84,0)
	9503	W !!,"Pg. "_PG,?130 -$L(TODAY) ,TODAY
	9504	"RTN","PRC AXP",85,0)
	9505	S PRCAHDR ="MEDICATI ON CO-PAY EXEMPTION REPORT",PR CA="",$P(P RCA,"*",(1 30-$L(PRCA
	9506	HDR))\2)=" *",PRCAHDR =PRCA_" "_ PRCAHDR_" "_PRCA
	9507	"RTN","PRC AXP",86,0)
	9508	W !,PRCAH DR,!,?53,B EGPR,"-",E NDPR
	9509	"RTN","PRC AXP",87,0)
	9510	W !,?35," BILL",?48, "TRAN.",?5 6,"EXP",?9 0,"FILL/", ?100,"EFFE CTIVE" ;* 315 START
	9511	"RTN","PRC AXP",88,0)
	9512	W !,"PATI ENT",?28," ID",?35,"N UMBER",?48 ,"NUMBER", ?56,"TYP", ?60,"RX",? 70,"DRUG N
	9513	AME",?90," REFL DT",? 102,"DATE" ,?120,"AMO UNT" ;*31 5 END
	9514	"RTN","PRC AXP",89,0)
	9515	S PRCA="" ,$P(PRCA," -",132)="" W !,PRCA
	9516	"RTN","PRC AXP",90,0)
	9517	S CONTINU E=""
	9518	"RTN","PRC AXP",91,0)
	9519	Q
	9520	"RTN","PRC AXP",92,0)
	9521	;
	9522	"RTN","PRC AXP",93,0)
	9523	SCR ;
	9524	"RTN","PRC AXP",94,0)
	9525	Q:$E(IOST ,1,2)'["C- "
	9526	"RTN","PRC AXP",95,0)
	9527	N DIR,YY, DIRUT,DUOU T,DTOUT,DI ROUT,X,Y
	9528	"RTN","PRC AXP",96,0)
	9529	F YY=$Y:1 :(IOSL-2) W !
	9530	"RTN","PRC AXP",97,0)
	9531	S DIR(0)= "E" D ^DIR I $D(DIRU T)!($D(DTO UT)) S OUT =1
	9532	"RTN","PRC AXP",98,0)
	9533	Q
	9534	"RTN","RCD PRTEX")
	9535	0^10^B2657 62
	9536	"RTN","RCD PRTEX",1,0 )
	9537	RCDPRTEX ; ALB/LMH
	9538	"RTN","RCD PRTEX",2,0 )
	9539	;;4.5;Acc ounts Rece ivable;1 51,169,276 ,284;Mar 20, 1995; Build 2
	9540	"RTN","RCD PRTEX",3,0 )
	9541	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	9542	"RTN","RCD PRTEX",4,0 )
	9543	;
	9544	"RTN","RCD PRTEX",5,0 )
	9545	;
	9546	"RTN","RCD PRTEX",6,0 )
	9547	Q
	9548	"RTN","RCD PRTEX",7,0 )
	9549	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ----------
	9550	----
	9551	"RTN","RCD PRTEX",8,0 )
	9552	; Entry P oint
	9553	"RTN","RCD PRTEX",9,0 )
	9554	; EN - Fo rmat and c reate the Claims Mat ching Repo rt for Exc el export.
	9555	"RTN","RCD PRTEX",10, 0)
	9556	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ----------
	9557	----
	9558	"RTN","RCD PRTEX",11, 0)
	9559	;
	9560	"RTN","RCD PRTEX",12, 0)
	9561	EN ;
	9562	"RTN","RCD PRTEX",13, 0)
	9563	;
	9564	"RTN","RCD PRTEX",14, 0)
	9565	Q:RCEXCEL =0!(RCEXCE L="")
	9566	"RTN","RCD PRTEX",15, 0)
	9567	;
	9568	"RTN","RCD PRTEX",16, 0)
	9569	PRINT(RCEX CEL)
	9570	"RTN","RCD PRTEX",17, 0)
	9571	; Entry p oint for p rinting th e report
	9572	"RTN","RCD PRTEX",18, 0)
	9573	; Input:
	9574	"RTN","RCD PRTEX",19, 0)
	9575	; RCEXCEL - 1 - CSV format, 0 otherwise
	9576	"RTN","RCD PRTEX",20, 0)
	9577	; ZTQUEUE - Defined if report was queue d
	9578	"RTN","RCD PRTEX",21, 0)
	9579	; undefin ed otherwi se
	9580	"RTN","RCD PRTEX",22, 0)
	9581	; ZSTOP - Defined a nd 1 if co mpilation was stoppe d
	9582	"RTN","RCD PRTEX",23, 0)
	9583	; 0 or un defined ot herwise
	9584	"RTN","RCD PRTEX",24, 0)
	9585	;
	9586	"RTN","RCD PRTEX",25, 0)
	9587	; Output: Report is printed i n text for mat for Ex cel (turn on logging )
	9588	"RTN","RCD PRTEX",26, 0)
	9589	;
	9590	"RTN","RCD PRTEX",27, 0)
	9591	;
	9592	"RTN","RCD PRTEX",28, 0)
	9593	K ^TMP("R CDPRTPB",$ J)
	9594	"RTN","RCD PRTEX",29, 0)
	9595	K ^TMP("I BRBT",$J)
	9596	"RTN","RCD PRTEX",30, 0)
	9597	K ^TMP("I BRBF",$J)
	9598	"RTN","RCD PRTEX",31, 0)
	9599	N DAT,RCB IL,RCBIL0, RCNAM,RCPA Y,RCPAY1,R CREC,RCREC 1,RCRECTDA ,RCSSN,RCT YP
	9600	"RTN","RCD PRTEX",32, 0)
	9601	D @($S(RC SORT=1:"PA T",RCSORT= 2:"BILL",R CSORT=3:"D ATE",RCSOR T=4:"REC", RCSORT=5:"
	9602	TYPE")_"^R CDPRTP0")
	9603	"RTN","RCD PRTEX",33, 0)
	9604	;
	9605	"RTN","RCD PRTEX",34, 0)
	9606	N CRT,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,RCST OP
	9607	"RTN","RCD PRTEX",35, 0)
	9608	N PAGE,SE PLINE,X,XX ,Y
	9609	"RTN","RCD PRTEX",36, 0)
	9610	S CRT=$S( IOST["C-": 1,1:0) ; 1 - Print t o Screen, 0 - Otherw ise
	9611	"RTN","RCD PRTEX",37, 0)
	9612	S:RCEXCEL IOSL=9999 99 ; Long screen len gth for Ex cel output
	9613	"RTN","RCD PRTEX",38, 0)
	9614	S PAGE=0, RCSTOP=0,$ P(SEPLINE, "-",81)=""
	9615	"RTN","RCD PRTEX",39, 0)
	9616	I '$D(^TM P("RCDPRTP B",$J)) D Q
	9617	"RTN","RCD PRTEX",40, 0)
	9618	. W @IOF, $C(13) ; N o data was compiled
	9619	"RTN","RCD PRTEX",41, 0)
	9620	. W !!?5, "No data f ound for t his report ."
	9621	"RTN","RCD PRTEX",42, 0)
	9622	. I CRT,' $D(ZTQUEUE D) D
	9623	"RTN","RCD PRTEX",43, 0)
	9624	. . D ^DI R
	9625	"RTN","RCD PRTEX",44, 0)
	9626	;
	9627	"RTN","RCD PRTEX",45, 0)
	9628	I $G(ZTST OP) D Q ; Compilatio n was halt ed
	9629	"RTN","RCD PRTEX",46, 0)
	9630	. D HDR(" ",CRT,.PAG E,.RCSTOP)
	9631	"RTN","RCD PRTEX",47, 0)
	9632	. W !!?5, "This repo rt was hal ted during compilati on by Task Manager Re quest."
	9633	"RTN","RCD PRTEX",48, 0)
	9634	. I CRT,' $D(ZTQUEUE D) D
	9635	"RTN","RCD PRTEX",49, 0)
	9636	. . D ^DI R
	9637	"RTN","RCD PRTEX",50, 0)
	9638	;
	9639	"RTN","RCD PRTEX",51, 0)
	9640	N RCPTID, RCPAT0,RNA ME,RBILL,R CPOST,RCNU M,BILLNUM, BILLFROM,B ILLTO,RXCO V
	9641	"RTN","RCD PRTEX",52, 0)
	9642	N RCIBFN, POSTDATE,R CTYPE,RCTP B0,DOB,RCB NUM,TPB,TP B1,AMT,FPC ,FPC1,CHGT YP,STATUS
	9643	"RTN","RCD PRTEX",53, 0)
	9644	N RCPTID1 ,RCBNUM1,R CH,AMT1,PA YOR,PST,FI LLFROM,FIL LTO,ONHOLD ,RCAMT,RCA MT1
	9645	"RTN","RCD PRTEX",54, 0)
	9646	N RCIBDAT ,STRING,FP C0,TMPSTR1 ,TMPSTR2,T PBDUP
	9647	"RTN","RCD PRTEX",55, 0)
	9648	D:RCEXCEL HDR("",CR T,.PAGE,.R CSTOP)
	9649	"RTN","RCD PRTEX",56, 0)
	9650	Q:RCSTOP
	9651	"RTN","RCD PRTEX",57, 0)
	9652	;
	9653	"RTN","RCD PRTEX",58, 0)
	9654	S RCPTID= ""
	9655	"RTN","RCD PRTEX",59, 0)
	9656	F S RCPT ID=$O(^TMP ("RCDPRTPB ",$J,RCPTI D)) Q:RCPT ID="" D
	9657	"RTN","RCD PRTEX",60, 0)
	9658	.S RCPAT0 =$G(^TMP(" RCDPRTPB", $J,RCPTID) )
	9659	"RTN","RCD PRTEX",61, 0)
	9660	.S RNAME= RCPTID
	9661	"RTN","RCD PRTEX",62, 0)
	9662	.S RNAME= $P(RCPTID, "^")
	9663	"RTN","RCD PRTEX",63, 0)
	9664	.S RCDEBT =$P(RCPTID ,U,2)
	9665	"RTN","RCD PRTEX",64, 0)
	9666	.S RCSSN= $$SSN^RCFN 01(RCDEBT)
	9667	"RTN","RCD PRTEX",65, 0)
	9668	.S DOB=$P (^TMP("RCD PRTPB",$J, RCPTID),U)
	9669	"RTN","RCD PRTEX",66, 0)
	9670	.S ELIG=$ P(^TMP("RC DPRTPB",$J ,RCPTID),U ,2)
	9671	"RTN","RCD PRTEX",67, 0)
	9672	.; Get th ird party bill numbe r
	9673	"RTN","RCD PRTEX",68, 0)
	9674	.S TPBDUP =0
	9675	"RTN","RCD PRTEX",69, 0)
	9676	.S RCBNUM =0
	9677	"RTN","RCD PRTEX",70, 0)
	9678	.F S RCB NUM=$O(^TM P("RCDPRTP B",$J,RCPT ID,RCBNUM) ) Q:'RCBNU M D
	9679	"RTN","RCD PRTEX",71, 0)
	9680	..S RBILL =RCBNUM ; bil l IFN
	9681	"RTN","RCD PRTEX",72, 0)
	9682	..S RCPOS T=$G(^TMP( "RCDPRTPB" ,$J,RCPTID ,RCBNUM)) ;POSTED DA TE
	9683	"RTN","RCD PRTEX",73, 0)
	9684	..S TPB=0 F S TPB= $O(^TMP("I BRBT",$J,R CBNUM,TPB) ) Q:'TPB D
	9685	"RTN","RCD PRTEX",74, 0)
	9686	...S BILL NUM=$P(RCT PB0,U,4) ; bill #
	9687	"RTN","RCD PRTEX",75, 0)
	9688	...S PST= $P(RCTPB0, U,5) ; P/S /T
	9689	"RTN","RCD PRTEX",76, 0)
	9690	...S BILL FROM=$P(RC TPB0,U) ; bill date from
	9691	"RTN","RCD PRTEX",77, 0)
	9692	...S BILL TO=$P(RCTP B0,U,2) ; bill date to
	9693	"RTN","RCD PRTEX",78, 0)
	9694	...S RXCO V=$S('$G(^ TMP("IBRBT ",$J,RBILL )):"NO",1: "YES") ;RX coverage Yes/No
	9695	"RTN","RCD PRTEX",79, 0)
	9696	...S RCIB FN=TPB
	9697	"RTN","RCD PRTEX",80, 0)
	9698	...S PAYO R=$P(RCTPB 0,U,7) ; p ayor
	9699	"RTN","RCD PRTEX",81, 0)
	9700	...S POST DATE=$G(^T MP("RCDPRT PB",$J,RNA ME,RCBNUM) ) ; posted date
	9701	"RTN","RCD PRTEX",82, 0)
	9702	...S RCAM T=$J($P($G (^PRCA(430 ,+TPB,0)), "^",3),5,2 ) ; amt bi lled
	9703	"RTN","RCD PRTEX",83, 0)
	9704	...S RCAM T1=$P($G(^ PRCA(430,+ TPB,7)),"^ ",7) ; amt paid
	9705	"RTN","RCD PRTEX",84, 0)
	9706	...S RCTY PE=$$TYP^I BRFN(TPB) ;Third par ty bill ty pe of care
	9707	"RTN","RCD PRTEX",85, 0)
	9708	...S RCTY PE=$S(RCTY PE="":-1,R CTYPE="PR" :"P",RCTYP E="PH":"R" ,1:RCTYPE)
	9709	"RTN","RCD PRTEX",86, 0)
	9710	...; Writ e third pa rty data t o scratch global
	9711	"RTN","RCD PRTEX",87, 0)
	9712	...I $D(R CBNUM),$D( ^TMP("IBRB F",$J,RCBN UM))=11 D
	9713	"RTN","RCD PRTEX",88, 0)
	9714	....I 'TP BDUP D
	9715	"RTN","RCD PRTEX",89, 0)
	9716	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=RN AME_"("_$E (RCSSN,6,9 )_")^"_DOB
	9717	_"^"_ELIG_ "^"
	9718	"RTN","RCD PRTEX",90, 0)
	9719	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9720	UM,TPB)_RX COV_"^"
	9721	"RTN","RCD PRTEX",91, 0)
	9722	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9723	UM,TPB)_"T hird Party Bill"_"^"
	9724	"RTN","RCD PRTEX",92, 0)
	9725	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9726	UM,TPB)_BI LLNUM_"^"
	9727	"RTN","RCD PRTEX",93, 0)
	9728	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9729	UM,TPB)_PS T_"^^"
	9730	"RTN","RCD PRTEX",94, 0)
	9731	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9732	UM,TPB)_$$ STAT(RCIBF N)_"^"
	9733	"RTN","RCD PRTEX",95, 0)
	9734	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9735	UM,TPB)_$$ DATE(BILLF ROM)_"^"
	9736	"RTN","RCD PRTEX",96, 0)
	9737	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9738	UM,TPB)_$$ DATE(BILLT O)_"^"
	9739	"RTN","RCD PRTEX",97, 0)
	9740	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9741	UM,TPB)_$$ DATE(POSTD ATE)_"^"
	9742	"RTN","RCD PRTEX",98, 0)
	9743	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9744	UM,TPB)_$J (RCAMT,5,2 )_"^"
	9745	"RTN","RCD PRTEX",99, 0)
	9746	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9747	UM,TPB)_RC AMT1_"^^"
	9748	"RTN","RCD PRTEX",100 ,0)
	9749	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9750	UM,TPB)_RC TYPE_"^^"
	9751	"RTN","RCD PRTEX",101 ,0)
	9752	.....S ^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN UM,TPB)=^T MP("IBRBT1 ",$J,RCPTI D,"T",RCBN
	9753	UM,TPB)_$P (PAYOR," " ,1,2)_"^"
	9754	"RTN","RCD PRTEX",102 ,0)
	9755	....;
	9756	"RTN","RCD PRTEX",103 ,0)
	9757	....; Get first par ty charges
	9758	"RTN","RCD PRTEX",104 ,0)
	9759	....S FPC =0 F S FP C=$O(^TMP( "IBRBF",$J ,TPB,FPC)) Q:'FPC D
	9760	"RTN","RCD PRTEX",105 ,0)
	9761	.....S FP C0=^TMP("I BRBF",$J,T PB,FPC) ; First part y node
	9762	"RTN","RCD PRTEX",106 ,0)
	9763	.....S BI LLNUM=$P($ G(^TMP("IB RBF",$J,TP B,FPC)),U, 4) ; Bill #
	9764	"RTN","RCD PRTEX",107 ,0)
	9765	.....S RC IBDAT=$G(^ TMP("IBRBF ",$J,TPB,F PC)) ; Fir st party d ata
	9766	"RTN","RCD PRTEX",108 ,0)
	9767	.....S RC IBFN=$P(RC IBDAT,"^", 4) I RCIBF N S RCIBFN =$O(^PRCA( 430,"B",RC IBFN,0))
	9768	"RTN","RCD PRTEX",109 ,0)
	9769	.....S FI LLFROM=$P( $G(^TMP("I BRBF",$J,T PB,FPC)),U ) ; Bill f rom
	9770	"RTN","RCD PRTEX",110 ,0)
	9771	.....S FI LLTO=$P($G (^TMP("IBR BF",$J,TPB ,FPC)),U,2 ) ; Bill t o
	9772	"RTN","RCD PRTEX",111 ,0)
	9773	.....S CH GTYP=$P($G (^TMP("IBR BF",$J,TPB ,FPC)),U,6 ) ; Action type
	9774	"RTN","RCD PRTEX",112 ,0)
	9775	.....S ST ATUS=$$STA T(RCIBFN) ; Status
	9776	"RTN","RCD PRTEX",113 ,0)
	9777	.....S ON HOLD=$P($G (TMP("IBRB F",$J,TPB, FPC)),U,7) ; # Days On Hold
	9778	"RTN","RCD PRTEX",114 ,0)
	9779	.....S AM T=$P($G(^T MP("IBRBF" ,$J,TPB,FP C)),U,5) ; Amount bi lled
	9780	"RTN","RCD PRTEX",115 ,0)
	9781	.....S RX COV=$S('$G (^TMP("IBR BT",$J,RBI LL)):"NO", 1:"YES") ; Rx covera ge
	9782	"RTN","RCD PRTEX",116 ,0)
	9783	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=RNAME _"("_$E(RC SSN,6,9)_" )^"_DOB_"^
	9784	"_ELIG_"^^ "
	9785	"RTN","RCD PRTEX",117 ,0)
	9786	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9787	)_"First P arty Charg e"_"^"
	9788	"RTN","RCD PRTEX",118 ,0)
	9789	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9790	)_BILLNUM_ "^"
	9791	"RTN","RCD PRTEX",119 ,0)
	9792	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9793	)_"^"
	9794	"RTN","RCD PRTEX",120 ,0)
	9795	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9796	)_CHGTYP_" ^"
	9797	"RTN","RCD PRTEX",121 ,0)
	9798	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9799	)_STATUS_" ^"
	9800	"RTN","RCD PRTEX",122 ,0)
	9801	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9802	)_$$DATE(F ILLFROM)_" ^"
	9803	"RTN","RCD PRTEX",123 ,0)
	9804	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9805	)_$$DATE(F ILLTO)_"^^ "
	9806	"RTN","RCD PRTEX",124 ,0)
	9807	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9808	)_AMT_"^^"
	9809	"RTN","RCD PRTEX",125 ,0)
	9810	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9811	)_$S($G(^P RCA(430,+R CIBFN,7)): +($P(^(7), "^")+$P(^( 7),"^",2)+ $P(^(7),"^ ",3)+$P(^(
	9812	7),"^",4)+ $P(^(7),"^ ",4)),1:0) _"^^"
	9813	"RTN","RCD PRTEX",126 ,0)
	9814	.....S ^T MP("IBRBF1 ",$J,RCPTI D,"F",TPB, FPC)=^TMP( "IBRBF1",$ J,RCPTID," F",TPB,FPC
	9815	)_ONHOLD_" ^"
	9816	"RTN","RCD PRTEX",127 ,0)
	9817	..S TPB=$ O(^TMP("IB RBT",$J,RC BNUM,0))
	9818	"RTN","RCD PRTEX",128 ,0)
	9819	..I $D(^T MP("IBRBT" ,$J,TPB)) S TPBDUP=1
	9820	"RTN","RCD PRTEX",129 ,0)
	9821	;
	9822	"RTN","RCD PRTEX",130 ,0)
	9823	; write d ata to scr een
	9824	"RTN","RCD PRTEX",131 ,0)
	9825	;
	9826	"RTN","RCD PRTEX",132 ,0)
	9827	S RCPTID1 =""
	9828	"RTN","RCD PRTEX",133 ,0)
	9829	F S RCPT ID1=$O(^TM P("IBRBT1" ,$J,RCPTID 1)) Q:RCPT ID1="" D
	9830	"RTN","RCD PRTEX",134 ,0)
	9831	.S RCBNUM 1=0 F S R CBNUM1=$O( ^TMP("IBRB T1",$J,RCP TID1,"T",R CBNUM1)) Q :'RCBNUM1
	9832	D
	9833	"RTN","RCD PRTEX",135 ,0)
	9834	..S TPB1= 0 F S TPB 1=$O(^TMP( "IBRBT1",$ J,RCPTID1, "T",RCBNUM 1,TPB1)) Q :'TPB1 D
	9835	"RTN","RCD PRTEX",136 ,0)
	9836	...W ^TMP ("IBRBT1", $J,RCPTID1 ,"T",RCBNU M1,TPB1),!
	9837	"RTN","RCD PRTEX",137 ,0)
	9838	.S (TMPST R1,TMPSTR2 )=""
	9839	"RTN","RCD PRTEX",138 ,0)
	9840	.S TPB1=0 F S TPB1 =$O(^TMP(" IBRBF1",$J ,RCPTID1," F",TPB1)) Q:'TPB1 D
	9841	"RTN","RCD PRTEX",139 ,0)
	9842	..S FPC1= 0 F S FPC 1=$O(^TMP( "IBRBF1",$ J,RCPTID1, "F",TPB1,F PC1)) Q:'F PC1 D
	9843	"RTN","RCD PRTEX",140 ,0)
	9844	...S TMPS TR1=^TMP(" IBRBF1",$J ,RCPTID1," F",TPB1,FP C1)
	9845	"RTN","RCD PRTEX",141 ,0)
	9846	...W:TMPS TR2'=TMPST R1 TMPSTR1 ,!
	9847	"RTN","RCD PRTEX",142 ,0)
	9848	...S TMPS TR2=TMPSTR 1
	9849	"RTN","RCD PRTEX",143 ,0)
	9850	;
	9851	"RTN","RCD PRTEX",144 ,0)
	9852	K DATESTR T,DATEEND, ^TMP("RCDP RTPB",$J), RCTYPE
	9853	"RTN","RCD PRTEX",145 ,0)
	9854	Q
	9855	"RTN","RCD PRTEX",146 ,0)
	9856	;
	9857	"RTN","RCD PRTEX",147 ,0)
	9858	STAT(RBILL ) ;AR Stat us
	9859	"RTN","RCD PRTEX",148 ,0)
	9860	I '$G(RCI BFN) Q ""
	9861	"RTN","RCD PRTEX",149 ,0)
	9862	N RCSTAT
	9863	"RTN","RCD PRTEX",150 ,0)
	9864	S RCSTAT= $P($G(^PRC A(430,+RCI BFN,0)),"^ ",8),RCSTA T=$P($G(^P RCA(430.3, +RCSTAT,0)
	9865	),"^",2)
	9866	"RTN","RCD PRTEX",151 ,0)
	9867	Q RCSTAT
	9868	"RTN","RCD PRTEX",152 ,0)
	9869	;
	9870	"RTN","RCD PRTEX",153 ,0)
	9871	DATE(X) ; Convert Fi leMan date to mm/dd/ yy
	9872	"RTN","RCD PRTEX",154 ,0)
	9873	Q $S($G(X ):$E(X,4,5 )_"/"_$E(X ,6,7)_"/"_ $E(X,2,3), 1:"")
	9874	"RTN","RCD PRTEX",155 ,0)
	9875	;
	9876	"RTN","RCD PRTEX",156 ,0)
	9877	HDR(RCLAIM ,CRT,PAGE, RCSTOP) ; Print the Report Hea der
	9878	"RTN","RCD PRTEX",157 ,0)
	9879	;
	9880	"RTN","RCD PRTEX",158 ,0)
	9881	; Input: RCLAIM - C laim info
	9882	"RTN","RCD PRTEX",159 ,0)
	9883	; CRT - 1 - Print t o screen, 0 otherwis e
	9884	"RTN","RCD PRTEX",160 ,0)
	9885	; RCSTOP - Stop fla g
	9886	"RTN","RCD PRTEX",161 ,0)
	9887	; ZTQUEUE D - Define d if repor t was queu ed
	9888	"RTN","RCD PRTEX",162 ,0)
	9889	; undefin ed otherwi se
	9890	"RTN","RCD PRTEX",163 ,0)
	9891	; Output: RCSTOP - 1 - user s topped pri nting, 0 o therwise
	9892	"RTN","RCD PRTEX",164 ,0)
	9893	; ZSTOP - Defined a nd 1 if a task manag er stop wa s received
	9894	"RTN","RCD PRTEX",165 ,0)
	9895	; 0 or un defined ot herwise
	9896	"RTN","RCD PRTEX",166 ,0)
	9897	;
	9898	"RTN","RCD PRTEX",167 ,0)
	9899	N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,VENID,X, Y,Z
	9900	"RTN","RCD PRTEX",168 ,0)
	9901	;
	9902	"RTN","RCD PRTEX",169 ,0)
	9903	; If scre en output or page# e xists, do a form fee d and left margin re set
	9904	"RTN","RCD PRTEX",170 ,0)
	9905	I PAGE!CR T D
	9906	"RTN","RCD PRTEX",171 ,0)
	9907	. W @IOF, $C(13)
	9908	"RTN","RCD PRTEX",172 ,0)
	9909	;
	9910	"RTN","RCD PRTEX",173 ,0)
	9911	S PAGE=PA GE+1 ; Inc rement Pag e #
	9912	"RTN","RCD PRTEX",174 ,0)
	9913	;
	9914	"RTN","RCD PRTEX",175 ,0)
	9915	; For Exc el CSV for mat, displ ay the col umn header s only
	9916	"RTN","RCD PRTEX",176 ,0)
	9917	I RCEXCEL D EXCELHD Q
	9918	"RTN","RCD PRTEX",177 ,0)
	9919	;
	9920	"RTN","RCD PRTEX",178 ,0)
	9921	; Check f or a TaskM anager sto p request
	9922	"RTN","RCD PRTEX",179 ,0)
	9923	I $D(ZTQU EUED),$$S^ %ZTLOAD() D Q
	9924	"RTN","RCD PRTEX",180 ,0)
	9925	. S (ZTST OP,RCSTOP) =1
	9926	"RTN","RCD PRTEX",181 ,0)
	9927	. W !!!?5 ,"* Repo rt Halted by TaskMan ager Reque st *"
	9928	"RTN","RCD PRTEX",182 ,0)
	9929	Q
	9930	"RTN","RCD PRTEX",183 ,0)
	9931	;
	9932	"RTN","RCD PRTEX",184 ,0)
	9933	EXCELHD ; Print an Excel CSV header rec ord
	9934	"RTN","RCD PRTEX",185 ,0)
	9935	;
	9936	"RTN","RCD PRTEX",186 ,0)
	9937	; Input: None
	9938	"RTN","RCD PRTEX",187 ,0)
	9939	; Output: Header li ne printed for CSV f ormat (exc el)
	9940	"RTN","RCD PRTEX",188 ,0)
	9941	; :
	9942	"RTN","RCD PRTEX",189 ,0)
	9943	N RCH
	9944	"RTN","RCD PRTEX",190 ,0)
	9945	S STRING= ""
	9946	"RTN","RCD PRTEX",191 ,0)
	9947	S RCH=$$C SV("","Pat ient")
	9948	"RTN","RCD PRTEX",192 ,0)
	9949	S RCH=$$C SV(RCH,"DO B")
	9950	"RTN","RCD PRTEX",193 ,0)
	9951	S RCH=$$C SV(RCH,"Pr im. Elig")
	9952	"RTN","RCD PRTEX",194 ,0)
	9953	S RCH=$$C SV(RCH,"RX Cvg")
	9954	"RTN","RCD PRTEX",195 ,0)
	9955	S RCH=$$C SV(RCH,"Bi ll Type")
	9956	"RTN","RCD PRTEX",196 ,0)
	9957	S RCH=$$C SV(RCH,"Bi ll#")
	9958	"RTN","RCD PRTEX",197 ,0)
	9959	S RCH=$$C SV(RCH,"P/ S/T")
	9960	"RTN","RCD PRTEX",198 ,0)
	9961	S RCH=$$C SV(RCH,"Ch g Type")
	9962	"RTN","RCD PRTEX",199 ,0)
	9963	S RCH=$$C SV(RCH,"St atus")
	9964	"RTN","RCD PRTEX",200 ,0)
	9965	S RCH=$$C SV(RCH,"Bi ll From")
	9966	"RTN","RCD PRTEX",201 ,0)
	9967	S RCH=$$C SV(RCH,"Bi ll To")
	9968	"RTN","RCD PRTEX",202 ,0)
	9969	S RCH=$$C SV(RCH,"Po sted")
	9970	"RTN","RCD PRTEX",203 ,0)
	9971	S RCH=$$C SV(RCH,"Am t Billed")
	9972	"RTN","RCD PRTEX",204 ,0)
	9973	S RCH=$$C SV(RCH,"Am t Pd")
	9974	"RTN","RCD PRTEX",205 ,0)
	9975	S RCH=$$C SV(RCH,"Ba l")
	9976	"RTN","RCD PRTEX",206 ,0)
	9977	S RCH=$$C SV(RCH,"Ca re Type")
	9978	"RTN","RCD PRTEX",207 ,0)
	9979	S RCH=$$C SV(RCH,"On Hold")
	9980	"RTN","RCD PRTEX",208 ,0)
	9981	S RCH=$$C SV(RCH,"Pa yor")
	9982	"RTN","RCD PRTEX",209 ,0)
	9983	W RCH
	9984	"RTN","RCD PRTEX",210 ,0)
	9985	W !
	9986	"RTN","RCD PRTEX",211 ,0)
	9987	Q
	9988	"RTN","RCD PRTEX",212 ,0)
	9989	;
	9990	"RTN","RCD PRTEX",213 ,0)
	9991	CSV(STRING ,DATA) ; B uild the E xcel data string for CSV forma t
	9992	"RTN","RCD PRTEX",214 ,0)
	9993	; Input: STRING - C urrent str ing being built or " "
	9994	"RTN","RCD PRTEX",215 ,0)
	9995	; DATA - New data t o be added to the st ring
	9996	"RTN","RCD PRTEX",216 ,0)
	9997	; Returns : STRING - Updated s tring with DATA adde d
	9998	"RTN","RCD PRTEX",217 ,0)
	9999	; Called From: EXCE LHD
	10000	"RTN","RCD PRTEX",218 ,0)
	10001	;
	10002	"RTN","RCD PRTEX",219 ,0)
	10003	S DATA="" _$TR(DATA, $C(94))
	10004	"RTN","RCD PRTEX",220 ,0)
	10005	S STRING= $S(STRING= "":DATA,1: STRING_"^" _DATA)
	10006	"RTN","RCD PRTEX",221 ,0)
	10007	Q STRING
	10008	"RTN","RCD PRTEX",222 ,0)
	10009	;
	10010	"RTN","RCD PRTP")
	10011	0^2^B12581 802
	10012	"RTN","RCD PRTP",1,0)
	10013	RCDPRTP ;ALB/LDB-C LAIMS MATC HING REPOR T ;1/11/01 2:03 PM
	10014	"RTN","RCD PRTP",2,0)
	10015	;;4.5;Acc ounts Rece ivable;1 51,186,315 ;Mar 20, 1995;Buil d 2
	10016	"RTN","RCD PRTP",3,0)
	10017	;
	10018	"RTN","RCD PRTP",4,0)
	10019	;
	10020	"RTN","RCD PRTP",5,0)
	10021	EN N DATEE ND,DATESTR T,DIC,DIR, DIRUT,POP, RCAN,RCBIL L,RCDEBT,R CDFN,RCPT, RCSORT,RCQ
	10022	UIT,%ZIS,Z TDESC,ZTSA VE,ZTRTN,Y
	10023	"RTN","RCD PRTP",6,0)
	10024	W !
	10025	"RTN","RCD PRTP",7,0)
	10026	K DIRUT S DIR(0)="S ^1:Patient ;2:Bill Nu mber;3:Pay ment dates ;4:Receipt Number;5:
	10027	Care Types ",DIR("A") ="Sort by" D ^DIR K DIR Q:$D(D IRUT)
	10028	"RTN","RCD PRTP",8,0)
	10029	S RCSORT= Y,RCQUIT=" "
	10030	"RTN","RCD PRTP",9,0)
	10031	D @RCSORT Q:RCQUIT W !
	10032	"RTN","RCD PRTP",10,0 )
	10033	K DIRUT S DIR(0)="Y ",DIR("A") ="Include cancelled bills",DIR ("B")="NO" D ^DIR K
	10034	DIR S RCAN =+Y Q:$D(D IRUT)
	10035	"RTN","RCD PRTP",11,0 )
	10036	;
	10037	"RTN","RCD PRTP",12,0 )
	10038	; select device
	10039	"RTN","RCD PRTP",13,0 )
	10040	I $$FORMA T^RCDPRTP0 (.RCEXCEL) I RCEXCEL G EXCEL
	10041	"RTN","RCD PRTP",14,0 )
	10042	W !!,"Thi s report r equires 13 2 columns. ",!
	10043	"RTN","RCD PRTP",15,0 )
	10044	W ! S %ZI S="Q" D ^% ZIS I POP Q
	10045	"RTN","RCD PRTP",16,0 )
	10046	I $D(IO(" Q")) D D ^%ZTLOAD K IO("Q"),Z TSK Q
	10047	"RTN","RCD PRTP",17,0 )
	10048	.S ZTDESC ="Claims M atching Re port",ZTRT N="DQ^RCDP RTP"
	10049	"RTN","RCD PRTP",18,0 )
	10050	.S ZTSAVE ("RCSORT") =""
	10051	"RTN","RCD PRTP",19,0 )
	10052	.I RCSORT =1 S ZTSAV E("RCDEBT" )="",ZTSAV E("RCDFN") ="",ZTSAVE ("DATE*")= ""
	10053	"RTN","RCD PRTP",20,0 )
	10054	.I RCSORT =2 S ZTSAV E("RCBILL" )="",ZTSAV E("RCDFN") ="",ZTSAVE ("RCDEBT") =""
	10055	"RTN","RCD PRTP",21,0 )
	10056	.I RCSORT =3 S ZTSAV E("DATE*") =""
	10057	"RTN","RCD PRTP",22,0 )
	10058	.I RCSORT =4 S ZTSAV E("RCPT")= ""
	10059	"RTN","RCD PRTP",23,0 )
	10060	.I RCSORT =5 S ZTSAV E("TYPE")= ""
	10061	"RTN","RCD PRTP",24,0 )
	10062	.S ZTSAVE ("RCAN")=" ",ZTSAVE(" ZTREQ")="@ "
	10063	"RTN","RCD PRTP",25,0 )
	10064	W !!,"<> please wa it <>"
	10065	"RTN","RCD PRTP",26,0 )
	10066	DQ ; queued r eport star ts here
	10067	"RTN","RCD PRTP",27,0 )
	10068	U IO
	10069	"RTN","RCD PRTP",28,0 )
	10070	K ^TMP("R CDPRTPB",$ J)
	10071	"RTN","RCD PRTP",29,0 )
	10072	K ^TMP("I BRBT",$J)
	10073	"RTN","RCD PRTP",30,0 )
	10074	K ^TMP("I BRBF",$J)
	10075	"RTN","RCD PRTP",31,0 )
	10076	N DAT,RCB IL,RCBIL0, RCNAM,RCPA Y,RCPAY1,R CREC,RCREC 1,RCRECTDA ,RCSSN,RCT YP
	10077	"RTN","RCD PRTP",32,0 )
	10078	D @($S(RC SORT=1:"PA T",RCSORT= 2:"BILL",R CSORT=3:"D ATE",RCSOR T=4:"REC", RCSORT=5:"
	10079	TYPE")_"^R CDPRTP0")
	10080	"RTN","RCD PRTP",33,0 )
	10081	D EN^RCDP RTP1
	10082	"RTN","RCD PRTP",34,0 )
	10083	K DATESTR T,DATEEND, ^TMP("RCDP RTPB",$J), RCTYPE
	10084	"RTN","RCD PRTP",35,0 )
	10085	D ^%ZISC
	10086	"RTN","RCD PRTP",36,0 )
	10087	Q
	10088	"RTN","RCD PRTP",37,0 )
	10089	;
	10090	"RTN","RCD PRTP",38,0 )
	10091	1 S DIC(0) ="QEAMZ",D IC=340,DIC ("S")="I ^ RCD(340,+Y ,0)[""DPT" "",DIC("A" )="Patient
	10092	name: " D ^DIC I Y< 0 S RCQUIT =1 Q
	10093	"RTN","RCD PRTP",39,0 )
	10094	S RCDEBT= +Y,RCDFN=+ $P(Y,"^",2 )
	10095	"RTN","RCD PRTP",40,0 )
	10096	D TYPEPIC ^RCDPRTP0( .RCTYPE)
	10097	"RTN","RCD PRTP",41,0 )
	10098	D DATESEL ^RCRJRTRA( "Payment")
	10099	"RTN","RCD PRTP",42,0 )
	10100	I '$G(DAT ESTRT)!('$ G(DATEEND) ) S RCQUIT =1
	10101	"RTN","RCD PRTP",43,0 )
	10102	Q
	10103	"RTN","RCD PRTP",44,0 )
	10104	;
	10105	"RTN","RCD PRTP",45,0 )
	10106	3 D DATESE L^RCRJRTRA ("Payment" )
	10107	"RTN","RCD PRTP",46,0 )
	10108	I '$G(DAT ESTRT)!('$ G(DATEEND) ) S RCQUIT =1
	10109	"RTN","RCD PRTP",47,0 )
	10110	Q
	10111	"RTN","RCD PRTP",48,0 )
	10112	;
	10113	"RTN","RCD PRTP",49,0 )
	10114	2 N DIC,DU OUT
	10115	"RTN","RCD PRTP",50,0 )
	10116	K ^TMP("I BRBF",$J)
	10117	"RTN","RCD PRTP",51,0 )
	10118	S DIC(0)= "QEAM",DIC =430,DIC(" S")="I $P( ^(0),U,2)= 9" D ^DIC I Y<0 S RC QUIT=1 Q
	10119	"RTN","RCD PRTP",52,0 )
	10120	S RCBILL= +Y,RCDFN=$ P($G(^PRCA (430,+RCBI LL,0)),"^" ,7) Q:'RCD FN
	10121	"RTN","RCD PRTP",53,0 )
	10122	S RCDEBT= $O(^RCD(34 0,"B",RCDF N_";DPT(", 0))
	10123	"RTN","RCD PRTP",54,0 )
	10124	I (RCDFN= "")!(RCDEB T="") W !, "This bill has no ma tching fir st party b ills." G 2
	10125	"RTN","RCD PRTP",55,0 )
	10126	D RELBILL ^IBRFN(RCB ILL)
	10127	"RTN","RCD PRTP",56,0 )
	10128	I '$O(^TM P("IBRBF", $J,RCBILL, 0)) W !,"T his bill h as no matc hing first party deb
	10129	ts." K ^TM P("IBRBF", $J) G 2
	10130	"RTN","RCD PRTP",57,0 )
	10131	K ^TMP("I BRBF",$J)
	10132	"RTN","RCD PRTP",58,0 )
	10133	Q
	10134	"RTN","RCD PRTP",59,0 )
	10135	;
	10136	"RTN","RCD PRTP",60,0 )
	10137	4 N DIC,X, Y
	10138	"RTN","RCD PRTP",61,0 )
	10139	S DIC(0)= "QEAM",DIC =344 D ^DI C I Y<0 S RCQUIT=1 Q
	10140	"RTN","RCD PRTP",62,0 )
	10141	S RCPT=$P (Y,"^",2)
	10142	"RTN","RCD PRTP",63,0 )
	10143	Q
	10144	"RTN","RCD PRTP",64,0 )
	10145	;
	10146	"RTN","RCD PRTP",65,0 )
	10147	5; Select care type - added in patch 315
	10148	"RTN","RCD PRTP",66,0 )
	10149	D TYPEPIC ^RCDPRTP0( .RCTYPE)
	10150	"RTN","RCD PRTP",67,0 )
	10151	D DATESEL ^RCRJRTRA( "Payment")
	10152	"RTN","RCD PRTP",68,0 )
	10153	I '$G(DAT ESTRT)!('$ G(DATEEND) ) S RCQUIT =1
	10154	"RTN","RCD PRTP",69,0 )
	10155	Q
	10156	"RTN","RCD PRTP",70,0 )
	10157	;
	10158	"RTN","RCD PRTP",71,0 )
	10159	EXCEL ;
	10160	"RTN","RCD PRTP",72,0 )
	10161	N DAT,RCB IL,RCBIL0, RCNAM,RCPA Y,RCPAY1,R CREC,RCREC 1,RCRECTDA ,RCSSN,RCT YP
	10162	"RTN","RCD PRTP",73,0 )
	10163	D @($S(RC SORT=1:"PA T",RCSORT= 2:"BILL",R CSORT=3:"D ATE",RCSOR T=4:"REC", RCSORT=5:"
	10164	TYPE")_"^R CDPRTP0")
	10165	"RTN","RCD PRTP",74,0 )
	10166	D DEVICE^ RCDPRTP0()
	10167	"RTN","RCD PRTP",75,0 )
	10168	K DATESTR T,DATEEND, RCEXCEL ,^ TMP("RCDPR TPB",$J),^ TMP("IBRBT ",$J)
	10169	"RTN","RCD PRTP",76,0 )
	10170	K ^TMP("I BRBT1",$J) ,^TMP("IBR BF",$J),^T MP("IBRBF1 ",$J),RCTY PE
	10171	"RTN","RCD PRTP",77,0 )
	10172	Q
	10173	"RTN","RCD PRTP",78,0 )
	10174	;
	10175	"RTN","RCD PRTP0")
	10176	0^3^B39492 559
	10177	"RTN","RCD PRTP0",1,0 )
	10178	RCDPRTP0 ; ALB/LDB - CLAIMS MAT CHING REPO RT ;5/24/0 0 10:48 AM
	10179	"RTN","RCD PRTP0",2,0 )
	10180	;;4.5;Acc ounts Rece ivable;1 51,315;M ar 20, 199 5;Build 2
	10181	"RTN","RCD PRTP0",3,0 )
	10182	;
	10183	"RTN","RCD PRTP0",4,0 )
	10184	;
	10185	"RTN","RCD PRTP0",5,0 )
	10186	PAT ; find patie nt bills
	10187	"RTN","RCD PRTP0",6,0 )
	10188	S RCNAM=$ $NAM^RCFN0 1(RCDEBT)
	10189	"RTN","RCD PRTP0",7,0 )
	10190	S RCSSN=$ $SSN^RCFN0 1(RCDEBT)
	10191	"RTN","RCD PRTP0",8,0 )
	10192	S RCBIL=0 F S RCBI L=$O(^PRCA (430,"E",R CDFN,RCBIL )) Q:'RCBI L D
	10193	"RTN","RCD PRTP0",9,0 )
	10194	.I $P($G( ^PRCA(430, +RCBIL,0)) ,"^",2)'=9 Q
	10195	"RTN","RCD PRTP0",10, 0)
	10196	.S RCPAY= 0 F S RCP AY=$O(^PRC A(433,"C", RCBIL,RCPA Y)) Q:'RCP AY D
	10197	"RTN","RCD PRTP0",11, 0)
	10198	..S RCPAY 1=$G(^PRCA (433,+RCPA Y,1)) Q:RC PAY1=""
	10199	"RTN","RCD PRTP0",12, 0)
	10200	..I "^2^3 4^"[("^"_$ P(RCPAY1," ^",2)_"^") ,($P(RCPAY 1,"^",9)'< DATESTRT), ($P(RCPAY1
	10201	,"^",9)<(D ATEEND_".9 99999")) D
	10202	"RTN","RCD PRTP0",13, 0)
	10203	...S DFN= RCDFN D DE M^VADPT,EL IG^VADPT
	10204	"RTN","RCD PRTP0",14, 0)
	10205	...S ^TMP ("RCDPRTPB ",$J,RCNAM )=$P($G(VA DM(3)),"^" ,2)_"^"_$P ($G(VAEL(1 )),"^",2)_
	10206	"^"_RCSSN
	10207	"RTN","RCD PRTP0",15, 0)
	10208	...S ^TMP ("RCDPRTPB ",$J,RCNAM ,RCBIL)=$P ($P(RCPAY1 ,"^",9),". ")
	10209	"RTN","RCD PRTP0",16, 0)
	10210	...K DFN, VA,VADM,VA EL,VAERR
	10211	"RTN","RCD PRTP0",17, 0)
	10212	...I RCEX CEL S RCBI LL=$G(RCBI L) D PROC^ RCDPRTP1
	10213	"RTN","RCD PRTP0",18, 0)
	10214	K RCDFN,R CDEBT
	10215	"RTN","RCD PRTP0",19, 0)
	10216	Q
	10217	"RTN","RCD PRTP0",20, 0)
	10218	;
	10219	"RTN","RCD PRTP0",21, 0)
	10220	DATE ; find third party bil ls by date of paymen ts
	10221	"RTN","RCD PRTP0",22, 0)
	10222	N RCDFN,R CDEBT
	10223	"RTN","RCD PRTP0",23, 0)
	10224	F RCTYP=2 ,34 S DAT= (DATESTRT- 1)_".99999 9" F S DA T=$O(^PRCA (433,"AT", RCTYP,DAT)
	10225	) Q:'DAT!( DAT>(DATEE ND_".99999 9")) D
	10226	"RTN","RCD PRTP0",24, 0)
	10227	.S RCPAY= 0 F S RCP AY=$O(^PRC A(433,"AT" ,RCTYP,DAT ,RCPAY)) Q :'RCPAY D
	10228	"RTN","RCD PRTP0",25, 0)
	10229	..S RCBIL =$P($G(^PR CA(433,+RC PAY,0)),"^ ",2)
	10230	"RTN","RCD PRTP0",26, 0)
	10231	..S RCBIL 0=$G(^PRCA (430,+RCBI L,0)) Q:RC BIL0=""
	10232	"RTN","RCD PRTP0",27, 0)
	10233	..Q:$P(RC BIL0,"^",2 )'=9
	10234	"RTN","RCD PRTP0",28, 0)
	10235	..S RCDFN =$P(RCBIL0 ,"^",7)
	10236	"RTN","RCD PRTP0",29, 0)
	10237	..S RCDEB T=$O(^RCD( 340,"B",RC DFN_";DPT( ",0)) Q:'R CDEBT
	10238	"RTN","RCD PRTP0",30, 0)
	10239	..S RCNAM =$$NAM^RCF N01(RCDEBT )
	10240	"RTN","RCD PRTP0",31, 0)
	10241	..S RCSSN =$$SSN^RCF N01(RCDEBT )
	10242	"RTN","RCD PRTP0",32, 0)
	10243	..S DFN=R CDFN D DEM ^VADPT,ELI G^VADPT
	10244	"RTN","RCD PRTP0",33, 0)
	10245	..S ^TMP( "RCDPRTPB" ,$J,RCNAM_ "^"_RCDEBT )=$P($G(VA DM(3)),"^" ,2)_"^"_$P ($G(VAEL(1
	10246	)),"^",2)_ "^"_RCSSN
	10247	"RTN","RCD PRTP0",34, 0)
	10248	..S ^TMP( "RCDPRTPB" ,$J,RCNAM_ "^"_RCDEBT ,RCBIL)=$P (DAT,".")
	10249	"RTN","RCD PRTP0",35, 0)
	10250	..I RCEXC EL S RCBIL L=$G(RCBIL ) D PROC^R CDPRTP1
	10251	"RTN","RCD PRTP0",36, 0)
	10252	..K DFN,V A,VADM,VAE L,VAERR
	10253	"RTN","RCD PRTP0",37, 0)
	10254	Q
	10255	"RTN","RCD PRTP0",38, 0)
	10256	;
	10257	"RTN","RCD PRTP0",39, 0)
	10258	TYPE ; find third party bil ls by care type
	10259	"RTN","RCD PRTP0",40, 0)
	10260	N RCDFN,R CDEBT,RCTY P
	10261	"RTN","RCD PRTP0",41, 0)
	10262	F RCTYP=2 ,34 S DAT= (DATESTRT- 1)_".99999 9" F S DA T=$O(^PRCA (433,"AT", RCTYP,DAT)
	10263	) Q:'DAT!( DAT>(DATEE ND_".99999 9")) D
	10264	"RTN","RCD PRTP0",42, 0)
	10265	.S RCPAY= 0 F S RCP AY=$O(^PRC A(433,"AT" ,RCTYP,DAT ,RCPAY)) Q :'RCPAY D
	10266	"RTN","RCD PRTP0",43, 0)
	10267	..S RCBIL =$P($G(^PR CA(433,+RC PAY,0)),"^ ",2)
	10268	"RTN","RCD PRTP0",44, 0)
	10269	..S RCBIL 0=$G(^PRCA (430,+RCBI L,0)) Q:RC BIL0=""
	10270	"RTN","RCD PRTP0",45, 0)
	10271	..Q:$P(RC BIL0,"^",2 )'=9
	10272	"RTN","RCD PRTP0",46, 0)
	10273	..S RCDFN =$P(RCBIL0 ,"^",7)
	10274	"RTN","RCD PRTP0",47, 0)
	10275	..S RCDEB T=$O(^RCD( 340,"B",RC DFN_";DPT( ",0)) Q:'R CDEBT
	10276	"RTN","RCD PRTP0",48, 0)
	10277	..S RCNAM =$$NAM^RCF N01(RCDEBT )
	10278	"RTN","RCD PRTP0",49, 0)
	10279	..S RCSSN =$$SSN^RCF N01(RCDEBT )
	10280	"RTN","RCD PRTP0",50, 0)
	10281	..S DFN=R CDFN D DEM ^VADPT,ELI G^VADPT
	10282	"RTN","RCD PRTP0",51, 0)
	10283	..S RCTYP E=$$TYP^IB RFN(RCBIL) ; added c are type - 315
	10284	"RTN","RCD PRTP0",52, 0)
	10285	..S RCTYP E=$S(RCTYP E="":-1,RC TYPE="PR": "P",RCTYPE ="PH":"R", 1:RCTYPE)
	10286	"RTN","RCD PRTP0",53, 0)
	10287	..I $D(RC TYPE(RCTYP E)) D Q:' RCTYPE
	10288	"RTN","RCD PRTP0",54, 0)
	10289	...S ^TMP ("RCDPRTPB ",$J,RCNAM _"^"_RCDEB T)=$P($G(V ADM(3)),"^ ",2)_"^"_$ P($G(VAEL(
	10290	1)),"^",2) _"^"_RCSSN
	10291	"RTN","RCD PRTP0",55, 0)
	10292	...S ^TMP ("RCDPRTPB ",$J,RCNAM _"^"_RCDEB T,RCBIL)=$ P(DAT,".")
	10293	"RTN","RCD PRTP0",56, 0)
	10294	...I RCEX CEL S RCBI LL=$G(RCBI L) D PROC^ RCDPRTP1
	10295	"RTN","RCD PRTP0",57, 0)
	10296	...K DFN, VA,VADM,VA EL,VAERR
	10297	"RTN","RCD PRTP0",58, 0)
	10298	Q
	10299	"RTN","RCD PRTP0",59, 0)
	10300	BILL ; set TMP ar ray
	10301	"RTN","RCD PRTP0",60, 0)
	10302	S RCNAM=$ $NAM^RCFN0 1(RCDEBT)
	10303	"RTN","RCD PRTP0",61, 0)
	10304	S RCSSN=$ $SSN^RCFN0 1(RCDEBT)
	10305	"RTN","RCD PRTP0",62, 0)
	10306	S DFN=+$G (^RCD(340, RCDEBT,0))
	10307	"RTN","RCD PRTP0",63, 0)
	10308	D DEM^VAD PT,ELIG^VA DPT
	10309	"RTN","RCD PRTP0",64, 0)
	10310	S RCTP=0 F S RCTP= $O(^PRCA(4 33,"C",RCB ILL,RCTP)) Q:'RCTP I "^2^34^" [("^"_$P($
	10311	G(^PRCA(43 3,+RCTP,1) ),"^",2)_" ^") S RCTP (0)=$P($P( $G(^PRCA(4 33,+RCTP,1 )),"^",9),
	10312	".")
	10313	"RTN","RCD PRTP0",65, 0)
	10314	S ^TMP("R CDPRTPB",$ J,RCNAM)=$ P($G(VADM( 3)),"^",2) _"^"_$P($G (VAEL(1)), "^",2)_"^"
	10315	_RCSSN
	10316	"RTN","RCD PRTP0",66, 0)
	10317	S ^TMP("R CDPRTPB",$ J,RCNAM,RC BILL)=RCTP
	10318	"RTN","RCD PRTP0",67, 0)
	10319	I RCEXCEL S RCBILL= $G(RCBIL) D PROC^RCD PRTP1
	10320	"RTN","RCD PRTP0",68, 0)
	10321	K DFN,VA, VADM,VAEL, VAERR,RCBI LL,RCTP
	10322	"RTN","RCD PRTP0",69, 0)
	10323	Q
	10324	"RTN","RCD PRTP0",70, 0)
	10325	;
	10326	"RTN","RCD PRTP0",71, 0)
	10327	REC ; find recei pt payment s
	10328	"RTN","RCD PRTP0",72, 0)
	10329	N RCDEBT, RCDFN,RCRE C1,RCPAY1, RCBIL,RCBI L0,RCDFN,R CDEBT,RCSS N
	10330	"RTN","RCD PRTP0",73, 0)
	10331	S RCREC1= 0 F S RCR EC1=$O(^PR CA(433,"AF ",RCPT,RCR EC1)) Q:'R CREC1 D
	10332	"RTN","RCD PRTP0",74, 0)
	10333	.S RCPAY1 =$G(^PRCA( 433,+RCREC 1,1)) Q:RC PAY1=""
	10334	"RTN","RCD PRTP0",75, 0)
	10335	.S RCBIL= 0 I "^2^34 ^"[("^"_$P (RCPAY1,"^ ",2)_"^") S RCBIL=$P ($G(^PRCA( 433,+RCREC
	10336	1,0)),"^", 2)
	10337	"RTN","RCD PRTP0",76, 0)
	10338	.Q:'RCBIL
	10339	"RTN","RCD PRTP0",77, 0)
	10340	.S RCBIL0 =$G(^PRCA( 430,+RCBIL ,0))
	10341	"RTN","RCD PRTP0",78, 0)
	10342	.Q:$P(RCB IL0,"^",2) '=9
	10343	"RTN","RCD PRTP0",79, 0)
	10344	.S RCDFN= $P(RCBIL0, "^",7) Q:' RCDFN
	10345	"RTN","RCD PRTP0",80, 0)
	10346	.S RCDEBT =$O(^RCD(3 40,"B",RCD FN_";DPT(" ,0)) Q:'RC DEBT
	10347	"RTN","RCD PRTP0",81, 0)
	10348	.S RCSSN= $$SSN^RCFN 01(RCDEBT)
	10349	"RTN","RCD PRTP0",82, 0)
	10350	.S RCNAM= $$NAM^RCFN 01(RCDEBT)
	10351	"RTN","RCD PRTP0",83, 0)
	10352	.S DFN=RC DFN D DEM^ VADPT,ELIG ^VADPT
	10353	"RTN","RCD PRTP0",84, 0)
	10354	.S ^TMP(" RCDPRTPB", $J,RCNAM_" ^"_RCDEBT) =$P($G(VAD M(3)),"^", 2)_"^"_$P( $G(VAEL(1)
	10355	),"^",2)_" ^"_RCSSN
	10356	"RTN","RCD PRTP0",85, 0)
	10357	.K DFN,VA ,VADM,VAEL ,VAERR
	10358	"RTN","RCD PRTP0",86, 0)
	10359	.S ^TMP(" RCDPRTPB", $J,RCNAM_" ^"_RCDEBT, RCBIL)=$P( $P($G(^PRC A(433,+RCR EC1,1)),"^
	10360	",9),".")
	10361	"RTN","RCD PRTP0",87, 0)
	10362	.I RCEXCE L S RCBILL =$G(RCBIL) D PROC^RC DPRTP1
	10363	"RTN","RCD PRTP0",88, 0)
	10364	Q
	10365	"RTN","RCD PRTP0",89, 0)
	10366	;
	10367	"RTN","RCD PRTP0",90, 0)
	10368	TYPEPIC(RC TYPE) ; fu nction for user sele ction of c are types
	10369	"RTN","RCD PRTP0",91, 0)
	10370	; RCTYPE is an outp ut array, pass by re ference
	10371	"RTN","RCD PRTP0",92, 0)
	10372	; RCTYPE( type)="" w here type can be (I) npatient, (O)utpatie nt,(P)rost hetics or
	10373	(R)x (Pres cription)
	10374	"RTN","RCD PRTP0",93, 0)
	10375	; Functio n value is 1 if at l east 1 car e type was selected, 0 otherwi se
	10376	"RTN","RCD PRTP0",94, 0)
	10377	; User ca n select o ne, all or a combina tion of ca re types.
	10378	"RTN","RCD PRTP0",95, 0)
	10379	;
	10380	"RTN","RCD PRTP0",96, 0)
	10381	N DIR,X,Y ,OK,DTOUT, DUOUT,DIRU T,DIROUT,R C
	10382	"RTN","RCD PRTP0",97, 0)
	10383	K RCTYPE
	10384	"RTN","RCD PRTP0",98, 0)
	10385	S OK=1 ; all OK def ault
	10386	"RTN","RCD PRTP0",99, 0)
	10387	F D Q:Y ="ALL"!$D( DIRUT)!(Y= "")
	10388	"RTN","RCD PRTP0",100 ,0)
	10389	. S DIR(0 )="SO"
	10390	"RTN","RCD PRTP0",101 ,0)
	10391	. S RC="; I:"_$$LJ^X LFSTR("Inp atient",15 )_$S($D(RC TYPE("I")) :"",1:"")
	10392	"RTN","RCD PRTP0",102 ,0)
	10393	. S RC=RC _";O:"_$$L J^XLFSTR(" Outpatient ",15)_$S($ D(RCTYPE(" O")):"",1: "")
	10394	"RTN","RCD PRTP0",103 ,0)
	10395	. S RC=RC _";P:"_$$L J^XLFSTR(" Prosthetic ",15)_$S($ D(RCTYPE(" P")):"",1: "")
	10396	"RTN","RCD PRTP0",104 ,0)
	10397	. S RC=RC _";R:"_$$L J^XLFSTR(" Prescripti on",15)_$S ($D(RCTYPE ("R")):"", 1:"")
	10398	"RTN","RCD PRTP0",105 ,0)
	10399	. S RC=RC _";A:All"
	10400	"RTN","RCD PRTP0",106 ,0)
	10401	. S $P(DI R(0),U,2)= RC
	10402	"RTN","RCD PRTP0",107 ,0)
	10403	. I '$D(R CTYPE) S D IR("A")="S elect a Ca re Type"
	10404	"RTN","RCD PRTP0",108 ,0)
	10405	. E S DI R("A")="Se lect anoth er Care Ty pe" K DIR( "B")
	10406	"RTN","RCD PRTP0",109 ,0)
	10407	. W ! D ^ DIR K DIR
	10408	"RTN","RCD PRTP0",110 ,0)
	10409	. I Y="AL L" D Q ; all types selected so set & q uit
	10410	"RTN","RCD PRTP0",111 ,0)
	10411	. . F X=" I","O","P" ,"R" S RCT YPE(X)=""
	10412	"RTN","RCD PRTP0",112 ,0)
	10413	. ;
	10414	"RTN","RCD PRTP0",113 ,0)
	10415	. I $D(DI RUT)!(Y="" ) Q
	10416	"RTN","RCD PRTP0",114 ,0)
	10417	. I $D(RC TYPE(Y)) K RCTYPE(Y) Q ; If a lready sel ected, tog gle off & quit
	10418	"RTN","RCD PRTP0",115 ,0)
	10419	. S RCTYP E(Y)="" ; Togg le back on
	10420	"RTN","RCD PRTP0",116 ,0)
	10421	. Q
	10422	"RTN","RCD PRTP0",117 ,0)
	10423	I $D(DUOU T)!$D(DTOU T) S OK=0 ; exit if "^" or tim e-out
	10424	"RTN","RCD PRTP0",118 ,0)
	10425	I '$D(RCT YPE) S OK= 0 W $C(7)
	10426	"RTN","RCD PRTP0",119 ,0)
	10427	Q OK
	10428	"RTN","RCD PRTP0",120 ,0)
	10429	FORMAT(RCE XCEL) ; ca pture the report for mat from t he user (n ormal or C SV output)
	10430	"RTN","RCD PRTP0",121 ,0)
	10431	; RCEXCEL =0 for nor mal output
	10432	"RTN","RCD PRTP0",122 ,0)
	10433	; RCEXCEL =1 (^ sepa rated valu es) for Ex cel output
	10434	"RTN","RCD PRTP0",123 ,0)
	10435	; pass pa rameter by reference
	10436	"RTN","RCD PRTP0",124 ,0)
	10437	;
	10438	"RTN","RCD PRTP0",125 ,0)
	10439	N RET,DIR ,X,Y,DTOUT ,DUOUT,DIR UT,DIROUT
	10440	"RTN","RCD PRTP0",126 ,0)
	10441	S RCEXCEL =0,RET=1
	10442	"RTN","RCD PRTP0",127 ,0)
	10443	S DIR("A" )="Do you want to ca pture the output in an Excel f ormat"
	10444	"RTN","RCD PRTP0",128 ,0)
	10445	S DIR("B" )="NO"
	10446	"RTN","RCD PRTP0",129 ,0)
	10447	S DIR(0)= "Y"
	10448	"RTN","RCD PRTP0",130 ,0)
	10449	S DIR("?" ,1)="If yo u want to capture th e output f rom this r eport in a ^-separat
	10450	ed"
	10451	"RTN","RCD PRTP0",131 ,0)
	10452	S DIR("?" ,2)="value s (Excel) format, th en answer YES here."
	10453	"RTN","RCD PRTP0",132 ,0)
	10454	S DIR("?" ,3)=" "
	10455	"RTN","RCD PRTP0",133 ,0)
	10456	S DIR("?" )="If you just want a normal r eport outp ut, then a nswer NO h ere."
	10457	"RTN","RCD PRTP0",134 ,0)
	10458	W ! D ^DI R K DIR
	10459	"RTN","RCD PRTP0",135 ,0)
	10460	I $D(DIRU T) S RET=0 W $C(7)
	10461	"RTN","RCD PRTP0",136 ,0)
	10462	S RCEXCEL =Y
	10463	"RTN","RCD PRTP0",137 ,0)
	10464	Q RCEXCEL
	10465	"RTN","RCD PRTP0",138 ,0)
	10466	;
	10467	"RTN","RCD PRTP0",139 ,0)
	10468	DEVICE() ; Device Se lection
	10469	"RTN","RCD PRTP0",140 ,0)
	10470	; RCEXCEL =0 for nor mal output
	10471	"RTN","RCD PRTP0",141 ,0)
	10472	; RCEXCEL =1 for Exc el ('^' se parated va lues)outpu t
	10473	"RTN","RCD PRTP0",142 ,0)
	10474	; pass pa rameter by reference
	10475	"RTN","RCD PRTP0",143 ,0)
	10476	;
	10477	"RTN","RCD PRTP0",144 ,0)
	10478	N ZTRTN,Z TDESC,ZTSA VE,POP,RET ,ZTSK,DIR, X,Y
	10479	"RTN","RCD PRTP0",145 ,0)
	10480	S RET=1
	10481	"RTN","RCD PRTP0",146 ,0)
	10482	I RCEXCEL D
	10483	"RTN","RCD PRTP0",147 ,0)
	10484	. W !!,"F or Excel o utput, tur n logging or capture on now."
	10485	"RTN","RCD PRTP0",148 ,0)
	10486	. W !,"To avoid und esired wra pping of t he data sa ved to the file,"
	10487	"RTN","RCD PRTP0",149 ,0)
	10488	. W !,"pl ease enter ""0;256;9 9999"" at the ""DEVI CE:"" prom pt.",!
	10489	"RTN","RCD PRTP0",150 ,0)
	10490	S ZTRTN=" PRINT^RCDP RTEX(RCEXC EL)"
	10491	"RTN","RCD PRTP0",151 ,0)
	10492	S ZTDESC= "Claims Ma tching Rep ort"
	10493	"RTN","RCD PRTP0",152 ,0)
	10494	S ZTSAVE( "RCTYPE(") =""
	10495	"RTN","RCD PRTP0",153 ,0)
	10496	S ZTSAVE( "RCBEG")=" "
	10497	"RTN","RCD PRTP0",154 ,0)
	10498	S ZTSAVE( "RCEND")=" "
	10499	"RTN","RCD PRTP0",155 ,0)
	10500	S ZTSAVE( "RCEXCEL") =""
	10501	"RTN","RCD PRTP0",156 ,0)
	10502	D EN^XUTM DEVQ(ZTRTN ,ZTDESC,.Z TSAVE,"M", 1)
	10503	"RTN","RCD PRTP0",157 ,0)
	10504	I POP S R ET=0
	10505	"RTN","RCD PRTP0",158 ,0)
	10506	I $G(ZTSK ) W !!,"Re port compi lation has started w ith task# ",ZTSK,"." ,!
	10507	"RTN","RCD PRTP0",159 ,0)
	10508	D ^DIR
	10509	"RTN","RCD PRTP0",160 ,0)
	10510	S DIR(0)= "E"
	10511	"RTN","RCD PRTP0",161 ,0)
	10512	Q RET
	10513	"RTN","RCD PRTP2")
	10514	0^4^B18058 028
	10515	"RTN","RCD PRTP2",1,0 )
	10516	RCDPRTP2 ; ALB/LDB - CLAIMS MAT CHING REPO RT ;1/26/0 1 3:16 PM
	10517	"RTN","RCD PRTP2",2,0 )
	10518	;;4.5;Acc ounts Rece ivable;1 51,276,303 ,315;Mar 20, 1995; Build 2
	10519	"RTN","RCD PRTP2",3,0 )
	10520	;;Per VA Directive 6402, this routine s hould not be modifie d.
	10521	"RTN","RCD PRTP2",4,0 )
	10522	;
	10523	"RTN","RCD PRTP2",5,0 )
	10524	; Referen ce to $$TY P^IBRFN su pported by DBIA# 203 1
	10525	"RTN","RCD PRTP2",6,0 )
	10526	;
	10527	"RTN","RCD PRTP2",7,0 )
	10528	PRINT1 ;
	10529	"RTN","RCD PRTP2",8,0 )
	10530	N REJECT, RCTYP
	10531	"RTN","RCD PRTP2",9,0 )
	10532	I $Y>(IOS L-2) D PAU SE Q:$G(RC Q) D HDR^ RCDPRTP1,H DR1
	10533	"RTN","RCD PRTP2",10, 0)
	10534	; PRCA4. 5276 - ge t EEOB ind icator '%' and attach it to the bill numb er when ap
	10535	plicable. Adjust rep ort tabs t o make roo m for EEOB indicator '%'.
	10536	"RTN","RCD PRTP2",11, 0)
	10537	N RC430 S RC430=+$O (^PRCA(430 ,"B",""_$P (RCIBDAT," ^",4)_"",0 ))
	10538	"RTN","RCD PRTP2",12, 0)
	10539	S RCEEOB= $$EEOB(RC4 30)
	10540	"RTN","RCD PRTP2",13, 0)
	10541	; #IA 606 0 for $$BI LLREJ^IBJT U6
	10542	"RTN","RCD PRTP2",14, 0)
	10543	S REJECT= $S($$BILLR EJ^IBJTU6( $P($P(RCIB DAT,"^",4) ,"-",2)):" c",1:" ") ;PRCA4.5
	10544	303 Add in dicator fo r rejects
	10545	"RTN","RCD PRTP2",15, 0)
	10546	W !,$S(RC TP=RCBILL: "",$D(RCT P(RCTP)):" ",1:" "), $G(RCEEOB) _REJECT_$P (RCIBDAT,"
	10547	^",4),?17, $P(RCIBDAT ,"^",5),?2 4
	10548	"RTN","RCD PRTP2",16, 0)
	10549	W $$STAT( RCTP),?31, $$DATE(+RC IBDAT),?42 ,$$DATE($P (RCIBDAT," ^",2))
	10550	"RTN","RCD PRTP2",17, 0)
	10551	S Y=$S($G (RCTP(RCTP )):RCTP(RC TP),$G(^TM P("RCDPRTP B",$J,RCNA M,RCBILL)) :^(RCBILL)
	10552	,1:"") I R CTP=RCBILL !($D(RCTP( RCTP))) W ?53,$$DATE (Y)
	10553	"RTN","RCD PRTP2",18, 0)
	10554	S RCAMT=$ P($G(^PRCA (430,+RCTP ,0)),"^",3 ),RCAMT1=$ P($G(^PRCA (430,+RCTP ,7)),"^",7
	10555	) W ?64,$J (RCAMT,9,2 )
	10556	"RTN","RCD PRTP2",19, 0)
	10557	W ?76,$J( RCAMT1,9,2 ) S RCAMT( 0)=RCAMT(0 )+RCAMT,RC AMT(1)=RCA MT(1)+RCAM T1
	10558	"RTN","RCD PRTP2",20, 0)
	10559	W ?88,$E( $P(RCIBDAT ,"^",7),1, 25)
	10560	"RTN","RCD PRTP2",21, 0)
	10561	; #IA 203 1 for $$TY P^IBRFN
	10562	"RTN","RCD PRTP2",22, 0)
	10563	S RCTYP=$ $TYP^IBRFN (RCTP) ; g et bill ty pe for an Accounts R eceivable
	10564	"RTN","RCD PRTP2",23, 0)
	10565	; Convert to single character care type s for:
	10566	"RTN","RCD PRTP2",24, 0)
	10567	; (I)npat ient, (O)u tpatient, (R)Prescri ption & (P )rosthetic s
	10568	"RTN","RCD PRTP2",25, 0)
	10569	S RCTYP=$ S(RCTYP="" :-1,RCTYP= "PR":"P",R CTYP="PH": "R",1:RCTY P)
	10570	"RTN","RCD PRTP2",26, 0)
	10571	W ?119,RC TYP
	10572	"RTN","RCD PRTP2",27, 0)
	10573	K RCTP(RC TP)
	10574	"RTN","RCD PRTP2",28, 0)
	10575	Q
	10576	"RTN","RCD PRTP2",29, 0)
	10577	;
	10578	"RTN","RCD PRTP2",30, 0)
	10579	PRINT2 ; Print the detail lin e for a fi rst party bill.
	10580	"RTN","RCD PRTP2",31, 0)
	10581	I $Y>(IOS L-2) D PAU SE Q:$G(RC Q) D HDR^ RCDPRTP1,H DR2
	10582	"RTN","RCD PRTP2",32, 0)
	10583	W !," ",$ P(RCIBDAT, "^",4),?14 ,$P(RCIBDA T,"^",6)
	10584	"RTN","RCD PRTP2",33, 0)
	10585	S RCIBFN= $P(RCIBDAT ,"^",4) I RCIBFN S R CIBFN=$O(^ PRCA(430," B",RCIBFN, 0))
	10586	"RTN","RCD PRTP2",34, 0)
	10587	; PRCA4. 5276 - ad just repor t tabs to make room for EEOB i ndicator ' %'.
	10588	"RTN","RCD PRTP2",35, 0)
	10589	W ?36,$$S TAT(RCIBFN ),?42,$$DA TE(+RCIBDA T),?54,$$D ATE($P(RCI BDAT,"^",2 ))
	10590	"RTN","RCD PRTP2",36, 0)
	10591	W ?66,$J( $P(RCIBDAT ,"^",5),9, 2),?78,$P( RCIBDAT,"^ ",7)
	10592	"RTN","RCD PRTP2",37, 0)
	10593	W ?87,$J( $S($G(^PRC A(430,+RCI BFN,7)):+( $P(^(7),"^ ")+$P(^(7) ,"^",2)+$P (^(7),"^",
	10594	3)+$P(^(7) ,"^",4)+$P (^(7),"^", 4)),1:0),9 ,2)
	10595	"RTN","RCD PRTP2",38, 0)
	10596	Q
	10597	"RTN","RCD PRTP2",39, 0)
	10598	;
	10599	"RTN","RCD PRTP2",40, 0)
	10600	;
	10601	"RTN","RCD PRTP2",41, 0)
	10602	PRINT3 ; P rint patie nt detail informatio n.
	10603	"RTN","RCD PRTP2",42, 0)
	10604	I $Y>(IOS L-5) D PAU SE Q:$G(RC Q) D HDR^ RCDPRTP1
	10605	"RTN","RCD PRTP2",43, 0)
	10606	S RCNAM1= ^TMP("RCDP RTPB",$J,R CNAM)
	10607	"RTN","RCD PRTP2",44, 0)
	10608	W !!,RCLI NE
	10609	"RTN","RCD PRTP2",45, 0)
	10610	W !,"NAME : ",$P(RCN AM,"^")," (",$E($P(R CNAM1,"^", 3),6,9)_") "
	10611	"RTN","RCD PRTP2",46, 0)
	10612	W !,"Prim . Elig: ", $P(RCNAM1, "^",2)
	10613	"RTN","RCD PRTP2",47, 0)
	10614	W ?44,"DO B: ",$P(RC NAM1,"^")
	10615	"RTN","RCD PRTP2",48, 0)
	10616	W ?61,"RX COVERAGE: ",$S('$G( ^TMP("IBRB T",$J,RCBI LL)):"NO", 1:"YES")
	10617	"RTN","RCD PRTP2",49, 0)
	10618	W !,RCLIN E
	10619	"RTN","RCD PRTP2",50, 0)
	10620	Q
	10621	"RTN","RCD PRTP2",51, 0)
	10622	;
	10623	"RTN","RCD PRTP2",52, 0)
	10624	HDR1 ;
	10625	"RTN","RCD PRTP2",53, 0)
	10626	W !!,"Thi rd Party B ills: * -> bill for which paym ent was po sted"
	10627	"RTN","RCD PRTP2",54, 0)
	10628	W !,"==== ========== ========== ====="
	10629	"RTN","RCD PRTP2",55, 0)
	10630	; PRCA4. 5276 - ad just repor t tabs to make room for EEOB i ndicator ' %'.
	10631	"RTN","RCD PRTP2",56, 0)
	10632	; PRCA4. 5315 - ad ded 1-char . care typ e (I)npati ent, (O)ut patient, ( R)x or (P)
	10633	rosthetics ) under ne w Type col umn
	10634	"RTN","RCD PRTP2",57, 0)
	10635	W !!,"Bil l #",?15," P/S/T",?22 ,"Status", ?30,"Bill From",?42, "Bill To", ?53,"Poste
	10636	d",?63,"Am t Billed", ?76,"Amt P aid",?88," Payor",?11 5,"Care Ty pe"
	10637	"RTN","RCD PRTP2",58, 0)
	10638	W !,"---- ---------" ,?15,"---- -",?22,"-- ----",?30, "--------- ",?42,"--- -----",?53
	10639	,"-------- ",?63,"--- -------",? 75,"------ ----",?88, "--------- ---------- ------",?1
	10640	15,"------ ---"
	10641	"RTN","RCD PRTP2",59, 0)
	10642	Q
	10643	"RTN","RCD PRTP2",60, 0)
	10644	;
	10645	"RTN","RCD PRTP2",61, 0)
	10646	HDR2 ;
	10647	"RTN","RCD PRTP2",62, 0)
	10648	W !!,"Ass ociated Fi rst Party Charges:"
	10649	"RTN","RCD PRTP2",63, 0)
	10650	W !,"==== ========== ========== ======="
	10651	"RTN","RCD PRTP2",64, 0)
	10652	W !," Bil l #",?14," Charge Typ e",?34,"St atus",?42, "From/Fill ",?54,"To/ Rel",?65,"
	10653	Amt Billed ",?78,"On Hold",?87, " Balance "
	10654	"RTN","RCD PRTP2",65, 0)
	10655	W !,"---- -------",? 14,"------ ---------- ",?34,"--- ---",?42," ---------" ,?54,"----
	10656	-----",?65 ,"-------- --",?78,"- ------",?8 7," ------ ----"
	10657	"RTN","RCD PRTP2",66, 0)
	10658	Q
	10659	"RTN","RCD PRTP2",67, 0)
	10660	;
	10661	"RTN","RCD PRTP2",68, 0)
	10662	STAT(RCIBF N) ;AR Sta tus
	10663	"RTN","RCD PRTP2",69, 0)
	10664	I '$G(RCI BFN) Q ""
	10665	"RTN","RCD PRTP2",70, 0)
	10666	N RCSTAT
	10667	"RTN","RCD PRTP2",71, 0)
	10668	S RCSTAT= $P($G(^PRC A(430,+RCI BFN,0)),"^ ",8),RCSTA T=$P($G(^P RCA(430.3, +RCSTAT,0)
	10669	),"^",2)
	10670	"RTN","RCD PRTP2",72, 0)
	10671	Q RCSTAT
	10672	"RTN","RCD PRTP2",73, 0)
	10673	;
	10674	"RTN","RCD PRTP2",74, 0)
	10675	DATE(X) ; Convert Fi leMan date to mm/dd/ yy
	10676	"RTN","RCD PRTP2",75, 0)
	10677	Q $S($G(X ):$E(X,4,5 )_"/"_$E(X ,6,7)_"/"_ $E(X,2,3), 1:"")
	10678	"RTN","RCD PRTP2",76, 0)
	10679	;
	10680	"RTN","RCD PRTP2",77, 0)
	10681	;
	10682	"RTN","RCD PRTP2",78, 0)
	10683	PAUSE ; Pa ge break.
	10684	"RTN","RCD PRTP2",79, 0)
	10685	I $E(IOST ,1,2)'="C- " Q
	10686	"RTN","RCD PRTP2",80, 0)
	10687	N RCX,DIR ,DIRUT,DUO UT,DTOUT,D IROUT,X,Y
	10688	"RTN","RCD PRTP2",81, 0)
	10689	I IOSL<10 0 F RCX=$Y :1:(IOSL-3 ) W !
	10690	"RTN","RCD PRTP2",82, 0)
	10691	S DIR(0)= "E" D ^DIR I $D(DIRU T)!($D(DUO UT)) S RCQ =1
	10692	"RTN","RCD PRTP2",83, 0)
	10693	Q
	10694	"RTN","RCD PRTP2",84, 0)
	10695	;
	10696	"RTN","RCD PRTP2",85, 0)
	10697	EEOB(RCBIL L) ; PRCA* 4.5*276 - get EEOB i ndicator f or a bill
	10698	"RTN","RCD PRTP2",86, 0)
	10699	; Interac tion with IB file #3 61.1 cover ed by IA # 4051.
	10700	"RTN","RCD PRTP2",87, 0)
	10701	; RCBILL is the IEN of the bi ll in file s #399/#43 0 and must be valid,
	10702	"RTN","RCD PRTP2",88, 0)
	10703	; Exclude an EOB ty pe of MRA when getti ng payment informati on. Return
	10704	"RTN","RCD PRTP2",89, 0)
	10705	; the EEO B indicato r '%' if p ayment act ivity was found.
	10706	"RTN","RCD PRTP2",90, 0)
	10707	;
	10708	"RTN","RCD PRTP2",91, 0)
	10709	N RCEEOB, RCVAL,Z
	10710	"RTN","RCD PRTP2",92, 0)
	10711	I $G(RCBI LL)=0 Q ""
	10712	"RTN","RCD PRTP2",93, 0)
	10713	I '$O(^IB M(361.1,"B ",RCBILL,0 )) Q "" ; no matchi ng entry f or bill
	10714	"RTN","RCD PRTP2",94, 0)
	10715	I $P($G(^ DGCR(399,R CBILL,0)), "^",13)=1 Q "" ;avo id 'ENTERE D/NOT REVI EWED' stat
	10716	us
	10717	"RTN","RCD PRTP2",95, 0)
	10718	; handle both singl e and mult iple bill entries in file #361 .1
	10719	"RTN","RCD PRTP2",96, 0)
	10720	S Z=0 F S Z=$O(^IB M(361.1,"B ",RCBILL,Z )) Q:'Z D Q:$G(RCE EOB)="%"
	10721	"RTN","RCD PRTP2",97, 0)
	10722	. S RCVAL =$G(^IBM(3 61.1,Z,0))
	10723	"RTN","RCD PRTP2",98, 0)
	10724	. S RCEEO B=$S($P(RC VAL,"^",4) =1:"",$P(R CVAL,"^",4 )=0:"%",1: "")
	10725	"RTN","RCD PRTP2",99, 0)
	10726	Q RCEEOB ; EEOB in dicator fo r 1st/3rd party paym ent on bil l
	10727	"RTN","RCM SITE")
	10728	0^7^B10167 680
	10729	"RTN","RCM SITE",1,0)
	10730	RCMSITE ;A LB/RRG - E DIT SITE P ARAMETERS ;Jul 02, 2 014@15:46: 14
	10731	"RTN","RCM SITE",2,0)
	10732	V ;;4.5;Ac counts Rec eivable;** 173,236,25 3,298,315* *;Mar 20, 1995;Build 2
	10733	"RTN","RCM SITE",3,0)
	10734	;Per VA D irective 6 402, this routine sh ould not b e modified .
	10735	"RTN","RCM SITE",4,0)
	10736	;
	10737	"RTN","RCM SITE",5,0)
	10738	BEG ;Start editing s ite paramt ers
	10739	"RTN","RCM SITE",6,0)
	10740	N DA,DIC, DIE,DLAYGO ,DR,X,Y
	10741	"RTN","RCM SITE",7,0)
	10742	; edit SI TE field ( #.01) in A R SITE PAR AMETER fil e (#342)
	10743	"RTN","RCM SITE",8,0)
	10744	S DIC="^R C(342,",DI C(0)="QEAM L",DLAYGO= 342 D ^DIC I Y>0 S D A=+Y,DR=.0 1,DIE="^RC
	10745	(342," D ^ DIE
	10746	"RTN","RCM SITE",9,0)
	10747	Q
	10748	"RTN","RCM SITE",10,0 )
	10749	;
	10750	"RTN","RCM SITE",11,0 )
	10751	ALC ;Edit ALC parame ter
	10752	"RTN","RCM SITE",12,0 )
	10753	NEW DIC,D R,DA,Y
	10754	"RTN","RCM SITE",13,0 )
	10755	S DIE="^R C(342,",DA =1,DR=".07 ;31" D ^DI E
	10756	"RTN","RCM SITE",14,0 )
	10757	Q
	10758	"RTN","RCM SITE",15,0 )
	10759	IRS ;Edit IRS OFFSET site para meters
	10760	"RTN","RCM SITE",16,0 )
	10761	NEW DIE,D R,DA,Y
	10762	"RTN","RCM SITE",17,0 )
	10763	I '$D(^RC (342,1,0)) D BEG G:' $D(^RC(342 ,1,0)) Q
	10764	"RTN","RCM SITE",18,0 )
	10765	S DA=1,DR ="[RCMS IR S]",DIE="^ RC(342," D ^DIE
	10766	"RTN","RCM SITE",19,0 )
	10767	Q Q
	10768	"RTN","RCM SITE",20,0 )
	10769	STAT ;Edit NOTIFICAT ION site p arameters
	10770	"RTN","RCM SITE",21,0 )
	10771	NEW DIE,D R,DA,Y
	10772	"RTN","RCM SITE",22,0 )
	10773	I '$D(^RC (342,1,0)) D BEG G:' $D(^RC(342 ,1,0)) Q1
	10774	"RTN","RCM SITE",23,0 )
	10775	S DA=1,DR ="[RCMS NO TIFICATION ]",DIE="^R C(342," D ^DIE
	10776	"RTN","RCM SITE",24,0 )
	10777	Q1 Q
	10778	"RTN","RCM SITE",25,0 )
	10779	GRP ;Edit AR Group P arameters
	10780	"RTN","RCM SITE",26,0 )
	10781	NEW DIE,D R,DA,Y
	10782	"RTN","RCM SITE",27,0 )
	10783	F W ! S DIC(0)="QE AML",DIC=" ^RC(342.1, ",DLAYGO=3 42.1 D ^DI C K DIC G: Y<0 Q3 S D
	10784	A=+Y,DIE=" ^RC(342.1, ",DR=$P($G (^RC(342.2 ,+$P(^RC(3 42.1,+Y,0) ,"^",2),1) ),"^") I D
	10785	R]"" D ^DI E
	10786	"RTN","RCM SITE",28,0 )
	10787	Q3 Q
	10788	"RTN","RCM SITE",29,0 )
	10789	DEA ;Deact ive an AR group
	10790	"RTN","RCM SITE",30,0 )
	10791	NEW DIE,D IC,DA,DR,Y ,GRP
	10792	"RTN","RCM SITE",31,0 )
	10793	S DIC="^R C(342.1,", DIC(0)="QE AM",DIC("S ")="I $P(^ (0),""^"", 2)'=7" D ^ DIC Q:Y<0
	10794	S GRP=+Y
	10795	"RTN","RCM SITE",32,0 )
	10796	W ! S DIR ("A")="Are you sure you want t o Deactive Group '"_ $P(^RC(342 .1,GRP,0),
	10797	"^")_"'",D IR(0)="Y", DIR("B")=" NO" D ^DIR K DIR
	10798	"RTN","RCM SITE",33,0 )
	10799	I 'Y W !! ,"* NO A CTION TAKE N *" Q
	10800	"RTN","RCM SITE",34,0 )
	10801	I Y S DIE ="^RC(342. 1,",DA=GRP ,DR=".02// //^S X=7" D ^DIE W ! !,"*** Gro up Deactiv
	10802	ated ***"
	10803	"RTN","RCM SITE",35,0 )
	10804	Q
	10805	"RTN","RCM SITE",36,0 )
	10806	SITE() ;Re turn site number
	10807	"RTN","RCM SITE",37,0 )
	10808	Q +$G(^DI C(4,+$P($G (^RC(342,1 ,0)),"^"), 99))
	10809	"RTN","RCM SITE",38,0 )
	10810	INT ;Print Inter/Adm in/Pen eff ective rep ort
	10811	"RTN","RCM SITE",39,0 )
	10812	NEW DIC,B Y,FR,TO,FL DS,L
	10813	"RTN","RCM SITE",40,0 )
	10814	S DIC="^R C(342,",BY =.01,(FR,T O)="",FLDS ="[RCMS IN T/ADM/PEN] ",L=0 D EN 1^DIP
	10815	"RTN","RCM SITE",41,0 )
	10816	Q
	10817	"RTN","RCM SITE",42,0 )
	10818	UPINT ;Upd ate Rate s ite parame ters
	10819	"RTN","RCM SITE",43,0 )
	10820	NEW DIE,D R,DA,Y,IOP
	10821	"RTN","RCM SITE",44,0 )
	10822	S IOP=ION D INT
	10823	"RTN","RCM SITE",45,0 )
	10824	I '$D(^XU SEC("PRCAF LATE CHAR GES",DUZ)) D BMES^XP DUTL("A Se curity Key is requir
	10825	ed to edit the Inter est/Admin and Penalt y Rates.") Q ;PRCA* 4.5*315 Ad ded Securi
	10826	ty Key
	10827	"RTN","RCM SITE",46,0 )
	10828	I '$D(^RC (342,1,0)) D BEG G:' $D(^RC(342 ,1,0)) Q4
	10829	"RTN","RCM SITE",47,0 )
	10830	F W ! S DA=1,DR="[ RCMS RATES ]",DIE="^R C(342," D ^DIE Q:$D( Y)
	10831	"RTN","RCM SITE",48,0 )
	10832	Q4 Q
	10833	"RTN","RCM SITE",49,0 )
	10834	;
	10835	"RTN","RCM SITE",50,0 )
	10836	EDILOCK() ; function , Update E DI Lockbox site para meters
	10837	"RTN","RCM SITE",51,0 )
	10838	; returns 1 on succ ess, else "^error me ssage"
	10839	"RTN","RCM SITE",52,0 )
	10840	N RSLT S RSLT=""
	10841	"RTN","RCM SITE",53,0 )
	10842	I '$D(^RC (342,1,0)) D BEG
	10843	"RTN","RCM SITE",54,0 )
	10844	S:'$D(^RC (342,1,0)) RSLT="^no site defi ned" ; ca n't contin ue
	10845	"RTN","RCM SITE",55,0 )
	10846	;
	10847	"RTN","RCM SITE",56,0 )
	10848	Q:RSLT]"" RSLT
	10849	"RTN","RCM SITE",57,0 )
	10850	;
	10851	"RTN","RCM SITE",58,0 )
	10852	N DA,DIE, DR,Y
	10853	"RTN","RCM SITE",59,0 )
	10854	S DA=1,DR ="[RCMS ED I LOCKBOX] ",DIE="^RC (342," D ^ DIE
	10855	"RTN","RCM SITE",60,0 )
	10856	S RSLT=$S ($D(Y):"^u ser aborte d",1:1) ; if Y rema ins from ^ DIE call
	10857	"RTN","RCM SITE",61,0 )
	10858	;
	10859	"RTN","RCM SITE",62,0 )
	10860	Q RSLT ; success
	10861	"RTN","RCM SITE",63,0 )
	10862	;
	10863	"RTN","RCM SITE",64,0 )
	10864	EDITRDDT ; Update # O F DAYS FOR RD ELIG C HG RPT sit e paramete r
	10865	"RTN","RCM SITE",65,0 )
	10866	;This is the number of days f or the Rat ed Disabil ity Eligib ility
	10867	"RTN","RCM SITE",66,0 )
	10868	;Change R eport to b e used whe n the repo rt is sche duled to b e run
	10869	"RTN","RCM SITE",67,0 )
	10870	;on a rec urring bas is. (Added for Hold Debt to DM C Project)
	10871	"RTN","RCM SITE",68,0 )
	10872	N DIE,DR, DA,Y
	10873	"RTN","RCM SITE",69,0 )
	10874	I '$D(^RC (342,1,0)) D BEG G:' $D(^RC(342 ,1,0)) Q6
	10875	"RTN","RCM SITE",70,0 )
	10876	S DA=1,DR ="8.01",DI E="^RC(342 ," D ^DIE
	10877	"RTN","RCM SITE",71,0 )
	10878	Q6 Q
	10879	"RTN","RCM SITE",72,0 )
	10880	;
	10881	"RTN","RCM SITE",73,0 )
	10882	GETRDDAY() ;Return # OF DAYS F OR RD ELIG CHG RPT s ite parame ter
	10883	"RTN","RCM SITE",74,0 )
	10884	Q $$GET1^ DIQ(342,1_ ",",8.01)
	10885	"RTN","RCM SITE",75,0 )
	10886	;
	10887	"RTN","RCM SITE",76,0 )
	10888	EDITRDAY ; Update NUM BER OF DAY S FOR DMC REPORTS si te paramet er.
	10889	"RTN","RCM SITE",77,0 )
	10890	;This is the number of days i n the past bills for episodes
	10891	"RTN","RCM SITE",78,0 )
	10892	;of care will be in cluded for the follo wing repor ts when sc heduled by
	10893	"RTN","RCM SITE",79,0 )
	10894	;IRM to b e run on a recurring basis:
	10895	"RTN","RCM SITE",80,0 )
	10896	; DMC D ebt Validi ty Report
	10897	"RTN","RCM SITE",81,0 )
	10898	; DMC D ebt Validi ty Managem ent Report
	10899	"RTN","RCM SITE",82,0 )
	10900	; Rated Disabilit y Eligibil ity Change Report
	10901	"RTN","RCM SITE",83,0 )
	10902	;The mini mum value for this f ield is 36 5 days (1 year) and the maximu m
	10903	"RTN","RCM SITE",84,0 )
	10904	;value is 3650 days (10 years ). If no v alue is ad ded in thi s field th e
	10905	"RTN","RCM SITE",85,0 )
	10906	;report w ill defaul t to 365 d ays. (Adde d for Hold Debt to D MC Project )
	10907	"RTN","RCM SITE",86,0 )
	10908	N DIE,DR, DA,Y
	10909	"RTN","RCM SITE",87,0 )
	10910	I '$D(^RC (342,1,0)) D BEG G:' $D(^RC(342 ,1,0)) Q7
	10911	"RTN","RCM SITE",88,0 )
	10912	S DA=1,DR ="8.02",DI E="^RC(342 ," D ^DIE
	10913	"RTN","RCM SITE",89,0 )
	10914	Q7 Q
	10915	"RTN","RCM SITE",90,0 )
	10916	;
	10917	"RTN","RCM SITE",91,0 )
	10918	GETRDAY() ;Return NU MBER OF DA YS FOR DMC REPORTS s ite parame ter
	10919	"RTN","RCM SITE",92,0 )
	10920	Q $$GET1^ DIQ(342,1_ ",",8.02)
	10921	"RTN","RCM SITE",93,0 )
	10922	;
	10923	"RTN","RCR JRCOR")
	10924	0^6^B66950 576
	10925	"RTN","RCR JRCOR",1,0 )
	10926	RCRJRCOR ; WISC/RFJ-a r data col lector sum mary repor t ;1 Mar 9 7
	10927	"RTN","RCR JRCOR",2,0 )
	10928	;;4.5;Acc ounts Rece ivable;6 8,96,139,1 03,156,170 ,174,191,2 20,138,239 ;Mar 20,
	10929	1995;Buil d 2
	10930	"RTN","RCR JRCOR",3,0 )
	10931	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
	10932	"RTN","RCR JRCOR",4,0 )
	10933	Q
	10934	"RTN","RCR JRCOR",5,0 )
	10935	;
	10936	"RTN","RCR JRCOR",6,0 )
	10937	;
	10938	"RTN","RCR JRCOR",7,0 )
	10939	SEND ; se nd data to ndb and d ata to FMS
	10940	"RTN","RCR JRCOR",8,0 )
	10941	N %,AMOUN T,DATEMOYR ,FUND,LINE ,RSC,SPACE ,TOTAL,TOT ALFUN,TOTA LTYP,TYPE, X,XMY,Y
	10942	"RTN","RCR JRCOR",9,0 )
	10943	;
	10944	"RTN","RCR JRCOR",10, 0)
	10945	; ------ ---- send to ndb --- -------
	10946	"RTN","RCR JRCOR",11, 0)
	10947	; data s tored in t mp($j,rcrj rcolndb)
	10948	"RTN","RCR JRCOR",12, 0)
	10949	I '$G(RCR JFAR1) D N DB(PRCASIT E,DATEBEG, DATEEND)
	10950	"RTN","RCR JRCOR",13, 0)
	10951	;
	10952	"RTN","RCR JRCOR",14, 0)
	10953	;
	10954	"RTN","RCR JRCOR",15, 0)
	10955	; ------ ---- send sv to fms ----------
	10956	"RTN","RCR JRCOR",16, 0)
	10957	; data s tored in t mp($j,rcrj rcolsv)
	10958	"RTN","RCR JRCOR",17, 0)
	10959	; rcrjfs v is a fla g set in t he routine rcrjrco f or retrans mission
	10960	"RTN","RCR JRCOR",18, 0)
	10961	; to pre vent accep ted fms do cuments fr om being r esent
	10962	"RTN","RCR JRCOR",19, 0)
	10963	I '$G(RCR JFSV) D ST ARTSV^RCXF MSSV(DATEE ND)
	10964	"RTN","RCR JRCOR",20, 0)
	10965	;
	10966	"RTN","RCR JRCOR",21, 0)
	10967	;
	10968	"RTN","RCR JRCOR",22, 0)
	10969	; ------ ---- send wr to fms ----------
	10970	"RTN","RCR JRCOR",23, 0)
	10971	; data s tored in t mp($j,rcrj rcolwr)
	10972	"RTN","RCR JRCOR",24, 0)
	10973	; rcrjfw r is a fla g set in t he routine rcrjrco f or retrans mission
	10974	"RTN","RCR JRCOR",25, 0)
	10975	; to pre vent accep ted fms do cuments fr om being r esent
	10976	"RTN","RCR JRCOR",26, 0)
	10977	I '$G(RCR JFWR) D ST ARTWR^RCXF MSWR(DATEE ND)
	10978	"RTN","RCR JRCOR",27, 0)
	10979	;
	10980	"RTN","RCR JRCOR",28, 0)
	10981	; ------ ---- send tr to fms ----------
	10982	"RTN","RCR JRCOR",29, 0)
	10983	N RCTRANS
	10984	"RTN","RCR JRCOR",30, 0)
	10985	; this c all return s rctrans array (see rcxfmstx for descri ption)
	10986	"RTN","RCR JRCOR",31, 0)
	10987	; rcrjft r is a fla g set in t he routine rcrjrco f or retrans mission
	10988	"RTN","RCR JRCOR",32, 0)
	10989	; to pre vent accep ted fms do cuments fr om being r esent
	10990	"RTN","RCR JRCOR",33, 0)
	10991	I '$G(RCR JFTR) D ST ARTTR^RCXF MSTX(DATEE ND)
	10992	"RTN","RCR JRCOR",34, 0)
	10993	;
	10994	"RTN","RCR JRCOR",35, 0)
	10995	; ------ ---- send oig extrac t -------- --
	10996	"RTN","RCR JRCOR",36, 0)
	10997	; data s tored in t mp(j,rcrjr oig)
	10998	"RTN","RCR JRCOR",37, 0)
	10999	; get no n-mccf bil ls for ext ract and u ser report
	11000	"RTN","RCR JRCOR",38, 0)
	11001	D NONMCCF ^RCRJROIG( DATEEND)
	11002	"RTN","RCR JRCOR",39, 0)
	11003	; rcrjfo ig is a fl ag set in the routin e rcrjrco for retran smission
	11004	"RTN","RCR JRCOR",40, 0)
	11005	; to pre vent the o ig extract from bein g resent
	11006	"RTN","RCR JRCOR",41, 0)
	11007	I '$G(RCR JFOIG) D O IG^RCRJROI G(DATEEND)
	11008	"RTN","RCR JRCOR",42, 0)
	11009	;
	11010	"RTN","RCR JRCOR",43, 0)
	11011	; genera te a mailm an message to the gr oup showin g the data
	11012	"RTN","RCR JRCOR",44, 0)
	11013	K ^TMP($J ,"RCRJRCOR MM")
	11014	"RTN","RCR JRCOR",45, 0)
	11015	S Y=$E(DA TEEND,1,5) _"00" D DD ^%DT S DAT EMOYR=Y
	11016	"RTN","RCR JRCOR",46, 0)
	11017	S LINE=0, SPACE="",$ P(SPACE," ",80)=""
	11018	"RTN","RCR JRCOR",47, 0)
	11019	D SET("Da ta has bee n collecte d for the month "_DA TEMOYR_". The data has been")
	11020	"RTN","RCR JRCOR",48, 0)
	11021	D SET("tr ansmitted to the fol lowing sys tems:")
	11022	"RTN","RCR JRCOR",49, 0)
	11023	D SET(" " )
	11024	"RTN","RCR JRCOR",50, 0)
	11025	;
	11026	"RTN","RCR JRCOR",51, 0)
	11027	I '$G(RCR JFAR1) D
	11028	"RTN","RCR JRCOR",52, 0)
	11029	. D SET ("NATIONAL DATABASE DATA")
	11030	"RTN","RCR JRCOR",53, 0)
	11031	. D SET ("-------- ---------- ----")
	11032	"RTN","RCR JRCOR",54, 0)
	11033	. D SET ("The data has been sent to th e National Database. For a de tail list"
	11034	)
	11035	"RTN","RCR JRCOR",55, 0)
	11036	. D SET ("of the d ata sent, please rev iew the Re turn Repor ts which a re sent")
	11037	"RTN","RCR JRCOR",56, 0)
	11038	. D SET ("from the National Database." )
	11039	"RTN","RCR JRCOR",57, 0)
	11040	. D SET (" ")
	11041	"RTN","RCR JRCOR",58, 0)
	11042	;
	11043	"RTN","RCR JRCOR",59, 0)
	11044	I '$G(RCR JFSV) D
	11045	"RTN","RCR JRCOR",60, 0)
	11046	. D SET ("FMS, STA NDARD VOUC HER (SV) D OCUMENT")
	11047	"RTN","RCR JRCOR",61, 0)
	11048	. D SET ("-------- ---------- ---------- -------")
	11049	"RTN","RCR JRCOR",62, 0)
	11050	. D SET ("The foll owing data has been transmitte d to FMS i n the SV d ocument:")
	11051	"RTN","RCR JRCOR",63, 0)
	11052	. D SET (" Revenu e Source C ode Type
	11053	Amount ")
	11054	"RTN","RCR JRCOR",64, 0)
	11055	. D SET (" ------ ---------- --- ----
	11056	------ ")
	11057	"RTN","RCR JRCOR",65, 0)
	11058	. S TOT AL=0
	11059	"RTN","RCR JRCOR",66, 0)
	11060	. S TYP E="" F S TYPE=$O(^T MP($J,"RCR JRCOLSV",T YPE)) Q:TY PE="" D
	11061	"RTN","RCR JRCOR",67, 0)
	11062	. . I TYPE=17!( TYPE=18) Q ; disp lay the Me dicare tot als later
	11063	"RTN","RCR JRCOR",68, 0)
	11064	. . S TOTALTYP= 0
	11065	"RTN","RCR JRCOR",69, 0)
	11066	. . S FUND="" F S FUND=$ O(^TMP($J, "RCRJRCOLS V",TYPE,FU ND)) Q:FUN D="" D
	11067	"RTN","RCR JRCOR",70, 0)
	11068	. . . S TOTAL FUN=0
	11069	"RTN","RCR JRCOR",71, 0)
	11070	. . . S RSC=" " F S RSC =$O(^TMP($ J,"RCRJRCO LSV",TYPE, FUND,RSC)) Q:RSC=""
	11071	S AMOUNT= ^(RSC) D
	11072	"RTN","RCR JRCOR",72, 0)
	11073	. . . . D S ET(" "_RS C_" "_$E($ $GETDESC^R CXFMSPR(RS C)_SPACE,1 ,54)_" "_
	11074	TYPE_$J(AM OUNT,13,2) )
	11075	"RTN","RCR JRCOR",73, 0)
	11076	. . . . S T OTALFUN=TO TALFUN+AMO UNT
	11077	"RTN","RCR JRCOR",74, 0)
	11078	. . . . S T OTALTYP=TO TALTYP+AMO UNT
	11079	"RTN","RCR JRCOR",75, 0)
	11080	. . . . S T OTAL=TOTAL +AMOUNT
	11081	"RTN","RCR JRCOR",76, 0)
	11082	. . . ;
	11083	"RTN","RCR JRCOR",77, 0)
	11084	. . . N RCFUN D S RCFUND =$S($E(DAT EEND,2,5)< "0410":$E( FUND,1,4)_ "."_$E(FUN
	11085	D,6),1:$E( FUND,1,4)_ "0"_$E(FUN D,6))
	11086	"RTN","RCR JRCOR",78, 0)
	11087	. . . I TYPE= 21 D SET($ E(" Sub-T otal by Fu nd "_RCFUN D_":"_SPAC
	11088	E,1,38)_$J (TOTALFUN, 12,2))
	11089	"RTN","RCR JRCOR",79, 0)
	11090	. . ;
	11091	"RTN","RCR JRCOR",80, 0)
	11092	. . D SET("
	11093	------ ----")
	11094	"RTN","RCR JRCOR",81, 0)
	11095	. . D SET(" TO TAL TYPE "
	11096	_TYPE_$J(T OTALTYP,13 ,2))
	11097	"RTN","RCR JRCOR",82, 0)
	11098	. . D SET(" ")
	11099	"RTN","RCR JRCOR",83, 0)
	11100	. ;
	11101	"RTN","RCR JRCOR",84, 0)
	11102	. ; Dis play Medic are totals and updat e the SV t otal
	11103	"RTN","RCR JRCOR",85, 0)
	11104	. S AMO UNT=+$G(^T MP($J,"RCR JRCOLSV",1 7)),TOTAL= TOTAL+AMOU NT
	11105	"RTN","RCR JRCOR",86, 0)
	11106	. D SET (" M edicare Co ntractual Adjustment TOTAL TYPE 17"_$
	11107	J(AMOUNT,1 3,2))
	11108	"RTN","RCR JRCOR",87, 0)
	11109	. S AMO UNT=+$G(^T MP($J,"RCR JRCOLSV",1 8)),TOTAL= TOTAL+AMOU NT
	11110	"RTN","RCR JRCOR",88, 0)
	11111	. D SET (" U nreimbursa ble Medica re Expense TOTAL TYPE 18"_$
	11112	J(AMOUNT,1 3,2))
	11113	"RTN","RCR JRCOR",89, 0)
	11114	. D SET (" ")
	11115	"RTN","RCR JRCOR",90, 0)
	11116	. ;
	11117	"RTN","RCR JRCOR",91, 0)
	11118	. D SET ("
	11119	---------- ")
	11120	"RTN","RCR JRCOR",92, 0)
	11121	. D SET (" T OTAL SV"_$
	11122	J(TOTAL,13 ,2))
	11123	"RTN","RCR JRCOR",93, 0)
	11124	. D SET (" ")
	11125	"RTN","RCR JRCOR",94, 0)
	11126	;
	11127	"RTN","RCR JRCOR",95, 0)
	11128	I '$G(RCR JFWR) D
	11129	"RTN","RCR JRCOR",96, 0)
	11130	. D SET ("FMS, WRI TEOFFS/CON TRACT ADJU STMENTS (W R) DOCUMEN T")
	11131	"RTN","RCR JRCOR",97, 0)
	11132	. D SET ("-------- ---------- ---------- ---------- ---------- -")
	11133	"RTN","RCR JRCOR",98, 0)
	11134	. D SET ("The foll owing data has been transmitte d to FMS i n the WR d ocument:")
	11135	"RTN","RCR JRCOR",99, 0)
	11136	. D SET (" Revenu e Source C ode Type
	11137	Amount ")
	11138	"RTN","RCR JRCOR",100 ,0)
	11139	. D SET (" ------ ---------- --- ----
	11140	------ ")
	11141	"RTN","RCR JRCOR",101 ,0)
	11142	. S TOT AL=0
	11143	"RTN","RCR JRCOR",102 ,0)
	11144	. S TYP E="" F S TYPE=$O(^T MP($J,"RCR JRCOLWR",T YPE)) Q:TY PE="" D
	11145	"RTN","RCR JRCOR",103 ,0)
	11146	. . S TOTALTYP= 0
	11147	"RTN","RCR JRCOR",104 ,0)
	11148	. . S FUND="" F S FUND=$ O(^TMP($J, "RCRJRCOLW R",TYPE,FU ND)) Q:FUN D="" D
	11149	"RTN","RCR JRCOR",105 ,0)
	11150	. . . S TOTAL FUN=0
	11151	"RTN","RCR JRCOR",106 ,0)
	11152	. . . S RSC=" " F S RSC =$O(^TMP($ J,"RCRJRCO LWR",TYPE, FUND,RSC)) Q:RSC=""
	11153	S AMOUNT= ^(RSC) D
	11154	"RTN","RCR JRCOR",107 ,0)
	11155	. . . . D S ET(" "_RS C_" "_$E($ $GETDESC^R CXFMSPR(RS C)_SPACE,1 ,54)_" "_
	11156	TYPE_$J(AM OUNT,13,2) )
	11157	"RTN","RCR JRCOR",108 ,0)
	11158	. . . . S T OTALFUN=TO TALFUN+AMO UNT
	11159	"RTN","RCR JRCOR",109 ,0)
	11160	. . . . S T OTALTYP=TO TALTYP+AMO UNT
	11161	"RTN","RCR JRCOR",110 ,0)
	11162	. . . . S T OTAL=TOTAL +AMOUNT
	11163	"RTN","RCR JRCOR",111 ,0)
	11164	. . . ;
	11165	"RTN","RCR JRCOR",112 ,0)
	11166	. . . N RCFUN D S RCFUND =$S($E(DAT EEND,2,5)< "0410":$E( FUND,1,4)_ "."_$E(FUN
	11167	D,6),1:$E( FUND,1,4)_ "0"_$E(FUN D,6))
	11168	"RTN","RCR JRCOR",113 ,0)
	11169	. . . I TYPE= 37 D SET($ E(" Sub-T otal by Fu nd "_RCFUN D_":"_SPAC
	11170	E,1,38)_$J (TOTALFUN, 12,2))
	11171	"RTN","RCR JRCOR",114 ,0)
	11172	. . ;
	11173	"RTN","RCR JRCOR",115 ,0)
	11174	. . D SET("
	11175	------ ----")
	11176	"RTN","RCR JRCOR",116 ,0)
	11177	. . D SET(" TO TAL TYPE "
	11178	_TYPE_$J(T OTALTYP,13 ,2))
	11179	"RTN","RCR JRCOR",117 ,0)
	11180	. . D SET(" ")
	11181	"RTN","RCR JRCOR",118 ,0)
	11182	. D SET ("
	11183	---------- ")
	11184	"RTN","RCR JRCOR",119 ,0)
	11185	. D SET (" T OTAL WR"_$
	11186	J(TOTAL,13 ,2))
	11187	"RTN","RCR JRCOR",120 ,0)
	11188	. D SET (" ")
	11189	"RTN","RCR JRCOR",121 ,0)
	11190	;
	11191	"RTN","RCR JRCOR",122 ,0)
	11192	I '$G(RCR JFTR) D
	11193	"RTN","RCR JRCOR",123 ,0)
	11194	. D SET ("FMS, TRA NSFER FROM MCCF TO H SIF (TR) D OCUMENT")
	11195	"RTN","RCR JRCOR",124 ,0)
	11196	. D SET ("-------- ---------- ---------- ---------- ---------- -")
	11197	"RTN","RCR JRCOR",125 ,0)
	11198	. D SET ("The foll owing data has been transmitte d to FMS i n the TR d ocument:")
	11199	"RTN","RCR JRCOR",126 ,0)
	11200	. D SET (" From F und Fro m RSC To Fund To RSC
	11201	Amount ")
	11202	"RTN","RCR JRCOR",127 ,0)
	11203	. D SET (" ------ --- --- ----- ------- ------
	11204	---------- ")
	11205	"RTN","RCR JRCOR",128 ,0)
	11206	. I $O( RCTRANS("" ))="" D SE T(" No Do llars to T ransfer.") Q
	11207	"RTN","RCR JRCOR",129 ,0)
	11208	. ;
	11209	"RTN","RCR JRCOR",130 ,0)
	11210	. S FUN D="" F S FUND=$O(RC TRANS(FUND )) Q:FUND= "" D
	11211	"RTN","RCR JRCOR",131 ,0)
	11212	. . S RSC="" F S RSC=$O( RCTRANS(FU ND,RSC)) Q :RSC="" D
	11213	"RTN","RCR JRCOR",132 ,0)
	11214	. . . ; rctr ans(fromfu nd,fromrsc ) = tofund ^ torsc ^ amount
	11215	"RTN","RCR JRCOR",133 ,0)
	11216	. . . S AMOUN T=RCTRANS( FUND,RSC)
	11217	"RTN","RCR JRCOR",134 ,0)
	11218	. . . D SET($ J(FUND,11) _$J(RSC,12 )_$J($P(AM OUNT,"^"), 14)_$J($P( AMOUNT,"^"
	11219	,2),10)_$J ($P(AMOUNT ,"^",3),31 ,2))
	11220	"RTN","RCR JRCOR",135 ,0)
	11221	;
	11222	"RTN","RCR JRCOR",136 ,0)
	11223	S XMY("G. RC AR DATA COLLECTOR ")=""
	11224	"RTN","RCR JRCOR",137 ,0)
	11225	S %=$$SEN DMSG("AR D ata Collec tor for "_ DATEMOYR_" Station " _PRCASITE, .XMY)
	11226	"RTN","RCR JRCOR",138 ,0)
	11227	K ^TMP($J ,"RCRJRCOR MM")
	11228	"RTN","RCR JRCOR",139 ,0)
	11229	;
	11230	"RTN","RCR JRCOR",140 ,0)
	11231	; send u sers detai l report
	11232	"RTN","RCR JRCOR",141 ,0)
	11233	;D USERRE PT^RCRJRCO U(DATEMOYR ) ;remove d from bac kround job p315 (FY1 6 HAPE RRE
	11234	PRCA4.5 315)
	11235	"RTN","RCR JRCOR",142 ,0)
	11236	Q
	11237	"RTN","RCR JRCOR",143 ,0)
	11238	;
	11239	"RTN","RCR JRCOR",144 ,0)
	11240	;
	11241	"RTN","RCR JRCOR",145 ,0)
	11242	NDB(PRCASI TE,DATEBEG ,DATEEND) ; send da ta to the national d atabase
	11243	"RTN","RCR JRCOR",146 ,0)
	11244	N %,BATCN AME,COUNT, CRITERIA,D ATA,LINE,X MY,X,Y
	11245	"RTN","RCR JRCOR",147 ,0)
	11246	K ^TMP($J ,"RCRJRCOR MM")
	11247	"RTN","RCR JRCOR",148 ,0)
	11248	S LINE=2, DATA="D$ "
	11249	"RTN","RCR JRCOR",149 ,0)
	11250	S CRITERI A="" F COU NT=1:1 S C RITERIA=$O (^TMP($J," RCRJRCOLND B",CRITERI A)) Q:CRIT
	11251	ERIA="" D
	11252	"RTN","RCR JRCOR",150 ,0)
	11253	. S DAT A=DATA_":" _COUNT_"/" _CRITERIA_ "/"_^TMP($ J,"RCRJRCO LNDB",CRIT ERIA)
	11254	"RTN","RCR JRCOR",151 ,0)
	11255	. I $L( DATA)>200 D SET(DATA ) S DATA=" D$ "
	11256	"RTN","RCR JRCOR",152 ,0)
	11257	I DATA'=" D$ " D SET (DATA)
	11258	"RTN","RCR JRCOR",153 ,0)
	11259	;
	11260	"RTN","RCR JRCOR",154 ,0)
	11261	; build the first two contro l lines in mail mess age
	11262	"RTN","RCR JRCOR",155 ,0)
	11263	S Y=DATEB EG D DD^%D T
	11264	"RTN","RCR JRCOR",156 ,0)
	11265	S BATCNAM E="AR1-"_$ E(Y,1,3)_$ E(DATEBEG, 6,7)_$TR($ P(Y,",",2) ," ")
	11266	"RTN","RCR JRCOR",157 ,0)
	11267	S Y=DATEE ND D DD^%D T
	11268	"RTN","RCR JRCOR",158 ,0)
	11269	S BATCNAM E=BATCNAME _"-"_$E(Y, 1,3)_$E(DA TEEND,6,7) _$TR($P(Y, ",",2)," " )
	11270	"RTN","RCR JRCOR",159 ,0)
	11271	S ^TMP($J ,"RCRJRCOR MM",1)="T$ "_PRCASIT E_"$"_BATC NAME_"$$$$ $*"
	11272	"RTN","RCR JRCOR",160 ,0)
	11273	; get en d time (in %)
	11274	"RTN","RCR JRCOR",161 ,0)
	11275	D NOW^%DT C
	11276	"RTN","RCR JRCOR",162 ,0)
	11277	S ^TMP($J ,"RCRJRCOR MM",2)="S$ "_STRTTIM E_"^"_%_"$ 0$"_(COUNT -1)
	11278	"RTN","RCR JRCOR",163 ,0)
	11279	;
	11280	"RTN","RCR JRCOR",164 ,0)
	11281	S XMY("S. PRQN DATA COLLECTION MONITOR@ D NS URL ")=""
	11282	"RTN","RCR JRCOR",165 ,0)
	11283	S %=$$SEN DMSG("AR1 "_$E(DATEE ND,4,5)_"/ "_$E(DATEE ND,2,3)_" NDB DATA F OR SITE "_
	11284	PRCASITE,. XMY)
	11285	"RTN","RCR JRCOR",166 ,0)
	11286	K ^TMP($J ,"RCRJRCOR MM")
	11287	"RTN","RCR JRCOR",167 ,0)
	11288	Q
	11289	"RTN","RCR JRCOR",168 ,0)
	11290	;
	11291	"RTN","RCR JRCOR",169 ,0)
	11292	;
	11293	"RTN","RCR JRCOR",170 ,0)
	11294	SUMMARY ; print sum mary repor t in mailm an bulleti n
	11295	"RTN","RCR JRCOR",171 ,0)
	11296	N %,BILLD A,CRITER2, CRITERIA,D ATA0,DFN,L INE,STAT,T OTAL,VA,XM Y
	11297	"RTN","RCR JRCOR",172 ,0)
	11298	K ^TMP($J ,"RCRJRCOR ") ; use d to ident ify test p atients
	11299	"RTN","RCR JRCOR",173 ,0)
	11300	K ^TMP($J ,"RCRJRCOR MM") ; use d to build mailman m essage
	11301	"RTN","RCR JRCOR",174 ,0)
	11302	;
	11303	"RTN","RCR JRCOR",175 ,0)
	11304	; print any test p atient bil ls which h ave not be en closed
	11305	"RTN","RCR JRCOR",176 ,0)
	11306	S BILLDA= 0 F S BIL LDA=$O(^TM P($J,"RCRJ RCOL","CRI T2",1,BILL DA)) Q:'BI LLDA I $D
	11307	(^(BILLDA, 1)) D
	11308	"RTN","RCR JRCOR",177 ,0)
	11309	. S DAT A0=$G(^PRC A(430,BILL DA,0)),STA T=$P(DATA0 ,"^",8)
	11310	"RTN","RCR JRCOR",178 ,0)
	11311	. I STA T'=16,STAT ='42 Q ; bill not c urrently o pen
	11312	"RTN","RCR JRCOR",179 ,0)
	11313	. S DFN =+$P(DATA0 ,"^",7) I 'DFN Q
	11314	"RTN","RCR JRCOR",180 ,0)
	11315	. D PID ^VADPT
	11316	"RTN","RCR JRCOR",181 ,0)
	11317	. I $E( $TR($G(VA( "PID")),"- "),1,5)="0 0000" S ^T MP($J,"RCR JRCOR","TE ST",BILLDA
	11318	)=""
	11319	"RTN","RCR JRCOR",182 ,0)
	11320	;
	11321	"RTN","RCR JRCOR",183 ,0)
	11322	I '$D(^TM P($J,"RCRJ RCOR","TES T")) Q
	11323	"RTN","RCR JRCOR",184 ,0)
	11324	;
	11325	"RTN","RCR JRCOR",185 ,0)
	11326	; print data
	11327	"RTN","RCR JRCOR",186 ,0)
	11328	S LINE=0
	11329	"RTN","RCR JRCOR",187 ,0)
	11330	D SET(" " )
	11331	"RTN","RCR JRCOR",188 ,0)
	11332	D SET("Th e followin g bills ar e active a nd linked to test pa tients:")
	11333	"RTN","RCR JRCOR",189 ,0)
	11334	S BILLDA= 0 F S BIL LDA=$O(^TM P($J,"RCRJ RCOR","TES T",BILLDA) ) Q:'BILLD A D SET("
	11335	"_$P($G( ^PRCA(430, BILLDA,0)) ,"^")_" (# ",BILLDA_" )")
	11336	"RTN","RCR JRCOR",190 ,0)
	11337	;
	11338	"RTN","RCR JRCOR",191 ,0)
	11339	S XMY("G. RC AR DATA COLLECTOR ")=""
	11340	"RTN","RCR JRCOR",192 ,0)
	11341	S %=$$SEN DMSG("MCCR DATA COLL ECTOR INFO RMATION",. XMY)
	11342	"RTN","RCR JRCOR",193 ,0)
	11343	K ^TMP($J ,"RCRJRCOR ")
	11344	"RTN","RCR JRCOR",194 ,0)
	11345	K ^TMP($J ,"RCRJRCOR MM")
	11346	"RTN","RCR JRCOR",195 ,0)
	11347	Q
	11348	"RTN","RCR JRCOR",196 ,0)
	11349	;
	11350	"RTN","RCR JRCOR",197 ,0)
	11351	;
	11352	"RTN","RCR JRCOR",198 ,0)
	11353	SET(DATA) ; store re port
	11354	"RTN","RCR JRCOR",199 ,0)
	11355	S LINE=LI NE+1,^TMP( $J,"RCRJRC ORMM",LINE )=DATA
	11356	"RTN","RCR JRCOR",200 ,0)
	11357	Q
	11358	"RTN","RCR JRCOR",201 ,0)
	11359	;
	11360	"RTN","RCR JRCOR",202 ,0)
	11361	;
	11362	"RTN","RCR JRCOR",203 ,0)
	11363	SENDMSG(XM SUB,XMY) ; send mes sage with subject an d recipien ts
	11364	"RTN","RCR JRCOR",204 ,0)
	11365	N %X,D0,D 1,D2,DIC,D ICR,DIW,X, XCNP,XMDIS PI,XMDUN,X MDUZ,XMTEX T,XMZ,ZTPA R
	11366	"RTN","RCR JRCOR",205 ,0)
	11367	S XMDUZ=" AR PACKAGE ",XMTEXT=" ^TMP($J,"" RCRJRCORMM "","
	11368	"RTN","RCR JRCOR",206 ,0)
	11369	D ^XMD
	11370	"RTN","RCR JRCOR",207 ,0)
	11371	Q +$G(XMZ )
	11372	"RTN","RCR JRCOU")
	11373	0^5^B31475 036
	11374	"RTN","RCR JRCOU",1,0 )
	11375	RCRJRCOU ; WISC/RFJ-a r data col lector sum mary repor t ;1 Mar 9 7
	11376	"RTN","RCR JRCOU",2,0 )
	11377	;;4.5;Acc ounts Rece ivable;1 03;Mar 2 0, 1995;Bu ild 2
	11378	"RTN","RCR JRCOU",3,0 )
	11379	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
	11380	"RTN","RCR JRCOU",4,0 )
	11381	Q
	11382	"RTN","RCR JRCOU",5,0 )
	11383	;
	11384	"RTN","RCR JRCOU",6,0 )
	11385	;ARDC det ailed repo rt - Modif ied to pri nt directl y as per H APE FY16 R RE - PRCA*
	11386	4.5*315
	11387	"RTN","RCR JRCOU",7,0 )
	11388	; This i s routine no longer generates a MailMan message!
	11389	"RTN","RCR JRCOU",8,0 )
	11390	; Called by VistA O ption - PR CA ARDC RE PORT (ARDC Det ail Report )
	11391	"RTN","RCR JRCOU",9,0 )
	11392	;
	11393	"RTN","RCR JRCOU",10, 0)
	11394	START ; E ntry point from the Option
	11395	"RTN","RCR JRCOU",11, 0)
	11396	N VAUTSTR ,VAUTB,VAU TNALL,VAUT NI,DIC,Y,S CREEN
	11397	"RTN","RCR JRCOU",12, 0)
	11398	;
	11399	"RTN","RCR JRCOU",13, 0)
	11400	W !!,"ARD C Detail R eport, ple ase select the statu s desired below",!!
	11401	"RTN","RCR JRCOU",14, 0)
	11402	;S SCREEN ="^16^18^3 2^38^40^42 ^",DIC="^P RCA(430.3, ",VAUTNI=2 ,VAUTSTR=" Status",VA
	11403	UTVB="VAUT C",DIC("S" )="I SCREE N[(U_Y_U)" D FIRST^V AUTOMA
	11404	"RTN","RCR JRCOU",15, 0)
	11405	S SCREEN= "^16^18^32 ^33^40^42^ ",DIC="^PR CA(430.3," ,VAUTNI=2, VAUTSTR="S tatus",VAU
	11406	TVB="VAUTC ",DIC("S") ="I SCREEN [(U_Y_U)" D FIRST^VA UTOMA
	11407	"RTN","RCR JRCOU",16, 0)
	11408	I VAUTC=1 F I=2:1:7 S VAUTC($ P(SCREEN,U ,I))=$P(^P RCA(430.3, $P(SCREEN, U,I),0),U)
	11409	;set arr ay equal t o the scre en if ALL was select ed
	11410	"RTN","RCR JRCOU",17, 0)
	11411	Q:'$D(VAU TC)
	11412	"RTN","RCR JRCOU",18, 0)
	11413	W !!,"Thi s report r equires 13 2 columns. ",!
	11414	"RTN","RCR JRCOU",19, 0)
	11415	W ! S %ZI S="Q" D ^% ZIS I POP Q
	11416	"RTN","RCR JRCOU",20, 0)
	11417	I $D(IO(" Q")) D D ^%ZTLOAD W :$D(ZTSK) !,*7,"REQU EST QUEUED ",!,"Task #: ",$G(ZT
	11418	SK) K ZTDE SC,ZTIO,ZT RTN,ZTSAVE G EXIT
	11419	"RTN","RCR JRCOU",21, 0)
	11420	.S ZTDESC ="ARDC Det ail Report ",ZTRTN="D Q^RCRJRCOU "
	11421	"RTN","RCR JRCOU",22, 0)
	11422	.S ZTSAVE ("VAUTC")= ""
	11423	"RTN","RCR JRCOU",23, 0)
	11424	.S ZTSAVE ("RCRET")= "",ZTSAVE( "ZTREQ")=" @"
	11425	"RTN","RCR JRCOU",24, 0)
	11426	W !!,"<> please wa it <>"
	11427	"RTN","RCR JRCOU",25, 0)
	11428	;
	11429	"RTN","RCR JRCOU",26, 0)
	11430	DQ ; gene rate user detailed r eport
	11431	"RTN","RCR JRCOU",27, 0)
	11432	N DATEEND ,DATE,BILL DA,DATA,RC LINE,RCSPA CE,REPTDAT A,Y,RCBILL N,RCDTAC,R CCAT,RCSTA
	11433	T,TRANTYP, RCTOT,RCPR IN,RCRSC,R CBILL,PRCA SITE
	11434	"RTN","RCR JRCOU",28, 0)
	11435	N STAT,BI LLDA,RCRSC ,DATA7,REC ORD,RCBAL, ARACTDT,DA TEMOYR,MRA TYPE,POP,R CFUND,RCOT
	11436	HER,TYPE
	11437	"RTN","RCR JRCOU",29, 0)
	11438	;
	11439	"RTN","RCR JRCOU",30, 0)
	11440	S DATEEND =$$LDATE^R CRJR(DT),D ATEMOYR=$E (DATEEND,1 ,5)_"00"
	11441	"RTN","RCR JRCOU",31, 0)
	11442	S DATE=0
	11443	"RTN","RCR JRCOU",32, 0)
	11444	S PRCASIT E=$$SITE^R CMSITE
	11445	"RTN","RCR JRCOU",33, 0)
	11446	S RCRET=$ NA(^TMP($J ,"RCRJRCOU ")) K @RCR ET ;TEMP GLOBAL FO R REPORT
	11447	"RTN","RCR JRCOU",34, 0)
	11448	;
	11449	"RTN","RCR JRCOU",35, 0)
	11450	S (RCLINE ,STAT)=0 F S STAT=$ O(VAUTC(ST AT)) Q:'ST AT D
	11451	"RTN","RCR JRCOU",36, 0)
	11452	. F S DA TE=$O(^PRC A(430,"ASD T",STAT,DA TE)) Q:'DA TE D
	11453	"RTN","RCR JRCOU",37, 0)
	11454	.. S BILL DA=0 F S BILLDA=$O( ^PRCA(430, "ASDT",STA T,DATE,BIL LDA)) Q:'B ILLDA D
	11455	"RTN","RCR JRCOU",38, 0)
	11456	... I $$A CCK^PRCAAC C(BILLDA), $P($G(^PRC A(430,BILL DA,0)),"^" ,2)'=26 D ;from CU
	11457	RRENT^RCRJ RCOC
	11458	"RTN","RCR JRCOU",39, 0)
	11459	.... S DA TA=$G(^PRC A(430,BILL DA,0)) Q:' DATA
	11460	"RTN","RCR JRCOU",40, 0)
	11461	.... S (T YPE,TRANTY P,RCRSC,RC FUND,RCPRI N)="",RCBA L=0
	11462	"RTN","RCR JRCOU",41, 0)
	11463	.... ; b ill number
	11464	"RTN","RCR JRCOU",42, 0)
	11465	.... S RC BILLN=$P($ P(DATA,"^" ),"-",2)
	11466	"RTN","RCR JRCOU",43, 0)
	11467	.... ; d ate activa ted
	11468	"RTN","RCR JRCOU",44, 0)
	11469	.... S RC DTAC=$$FMT E^XLFDT(DA TE,2)
	11470	"RTN","RCR JRCOU",45, 0)
	11471	.... ; c ategory
	11472	"RTN","RCR JRCOU",46, 0)
	11473	.... S RC CAT=$E($P( $G(^PRCA(4 30.2,+$P(D ATA,"^",2) ,0)),"^"), 1,18)
	11474	"RTN","RCR JRCOU",47, 0)
	11475	.... ; s tatus
	11476	"RTN","RCR JRCOU",48, 0)
	11477	.... S RC STAT=$E($P ($G(^PRCA( 430.3,+$P( DATA,"^",8 ),0)),"^") ,1,15)
	11478	"RTN","RCR JRCOU",49, 0)
	11479	.... S RE PTDATA=$$B ILLBAL^RCR JRCOB(BILL DA,DATEEND ) ; find s a bills balance an
	11480	d age - (a s per HDR^ RCDPTPLM)
	11481	"RTN","RCR JRCOU",50, 0)
	11482	.... S TY PE="SV21" I $$ACCK^P RCAACC(BIL LDA) S RCR SC=$$CALCR SC^RCXFMSU R(BILLDA)
	11483	; (as per CURRENT^RC RJRCOC)
	11484	"RTN","RCR JRCOU",51, 0)
	11485	.... I $E (RCRSC,1,2 )=86!($E(R CRSC,1,2)= "8S") S TY PE="2A"
	11486	"RTN","RCR JRCOU",52, 0)
	11487	.... ; G et AR Date Active fo r bill
	11488	"RTN","RCR JRCOU",53, 0)
	11489	.... S AR ACTDT=+$P( $P($G(^PRC A(430,BILL DA,6)),"^" ,21),".") ;
	11490	(a s per STAR T^RCRJRBD)
	11491	"RTN","RCR JRCOU",54, 0)
	11492	.... ; determine Receivable Type: 1=p re-MRA, 2= post-MRA M edicre, 3= post-MRA n
	11493	on-Medicar e
	11494	"RTN","RCR JRCOU",55, 0)
	11495	.... ; fms report type - TR ANTYP vari able
	11496	"RTN","RCR JRCOU",56, 0)
	11497	.... S MR ATYPE=$$MR ATYPE^IBCE MU2(BILLDA ,ARACTDT) ;
	11498	(a s per CURR ENT^RCRJRC OC)
	11499	"RTN","RCR JRCOU",57, 0)
	11500	.... ; s et TYPE to 2F for po st-MRA Med icare bill s or to 2L for post- MRA non-Me
	11501	dicare bil ls (for RH I receivab les only)
	11502	"RTN","RCR JRCOU",58, 0)
	11503	.... I $E (RCRSC,1,2 )=85!($E(R CRSC,1,2)= "8R"),MRAT YPE>1 S TY PE=$S(MRAT YPE=2:"2F"
	11504	,1:"2L")
	11505	"RTN","RCR JRCOU",59, 0)
	11506	.... I $E (RCRSC,1,2 )=86!($E(R CRSC,1,2)= "8S") S TY PE="SV21"
	11507	"RTN","RCR JRCOU",60, 0)
	11508	.... S TR ANTYP=$G(T YPE)
	11509	"RTN","RCR JRCOU",61, 0)
	11510	.... ; calculate principal and other (int + adm in) balanc e - calcu lations
	11511	(a s per NONM CCF^RCRJRO IG)
	11512	"RTN","RCR JRCOU",62, 0)
	11513	.... S DA TA7="",DAT A7=$G(^PRC A(430,BILL DA,7))
	11514	"RTN","RCR JRCOU",63, 0)
	11515	.... S RC PRIN=+$P(D ATA7,"^")
	11516	"RTN","RCR JRCOU",64, 0)
	11517	.... S RC OTHER=$P(D ATA7,"^",2 )+$P(DATA7 ,"^",3)+$P (DATA7,"^" ,4)+$P(DAT A7,"^",5)
	11518	"RTN","RCR JRCOU",65, 0)
	11519	.... ; in some b ills, the principal and other balance ma y cancel
	11520	"RTN","RCR JRCOU",66, 0)
	11521	.... ; each othe r. for ex ample prin cipal .08 + interest -.08 = 0
	11522	"RTN","RCR JRCOU",67, 0)
	11523	.... I (R CPRIN+RCOT HER)'>0 S RCPRIN=0
	11524	"RTN","RCR JRCOU",68, 0)
	11525	.... ; t otal
	11526	"RTN","RCR JRCOU",69, 0)
	11527	.... S RC TOT=$P(REP TDATA,"^") +$P(REPTDA TA,"^",2)
	11528	"RTN","RCR JRCOU",70, 0)
	11529	.... ; Ba lance=Tota l-Principa l (quit i f zero)
	11530	"RTN","RCR JRCOU",71, 0)
	11531	.... S RC BAL=RCTOT- RCPRIN Q:R CBAL<1 ;Q uit with t here is no balance d ue
	11532	"RTN","RCR JRCOU",72, 0)
	11533	.... S RC PRIN=$J(RC PRIN,11,2) ,RCBAL=$J( RCBAL,11,2 )
	11534	"RTN","RCR JRCOU",73, 0)
	11535	.... ;Rev enue Servi ce Code
	11536	"RTN","RCR JRCOU",74, 0)
	11537	.... S RC RSC="" I $ $ACCK^PRCA ACC(BILLDA ) S RCRSC= $$CALCRSC^ RCXFMSUR(B ILLDA) ;
	11538	(a s per CURR ENT^RCRJRC OC)
	11539	"RTN","RCR JRCOU",75, 0)
	11540	.... ;Fun d
	11541	"RTN","RCR JRCOU",76, 0)
	11542	.... S RC FUND=$$GET FUNDB^RCXF MSUF(BILLD A,1)
	11543	"RTN","RCR JRCOU",77, 0)
	11544	.... S RC LINE=RCLIN E+1 ;(rec ord counte r)
	11545	"RTN","RCR JRCOU",78, 0)
	11546	.... S @R CRET@(RCLI NE)=RCBILL N_U_RCDTAC _U_RCCAT_U _RCSTAT_U_ TRANTYP_U_ RCFUND_U_R
	11547	CRSC_U_RCP RIN_U_RCBA L
	11548	"RTN","RCR JRCOU",79, 0)
	11549	; end of gathering data
	11550	"RTN","RCR JRCOU",80, 0)
	11551	;
	11552	"RTN","RCR JRCOU",81, 0)
	11553	I RCLINE= 0 S PAGE=1 D HDR W ! !!,"The re port found no patien ts with a balance du
	11554	e for this report" G EXIT
	11555	"RTN","RCR JRCOU",82, 0)
	11556	;
	11557	"RTN","RCR JRCOU",83, 0)
	11558	D PRINT
	11559	"RTN","RCR JRCOU",84, 0)
	11560	;
	11561	"RTN","RCR JRCOU",85, 0)
	11562	EXIT ;comm om exit po int
	11563	"RTN","RCR JRCOU",86, 0)
	11564	D ^%ZISC
	11565	"RTN","RCR JRCOU",87, 0)
	11566	K ^TMP($J ,"RCRJRCOU ")
	11567	"RTN","RCR JRCOU",88, 0)
	11568	Q
	11569	"RTN","RCR JRCOU",89, 0)
	11570	;
	11571	"RTN","RCR JRCOU",90, 0)
	11572	HDR ;Set t he header
	11573	"RTN","RCR JRCOU",91, 0)
	11574	;
	11575	"RTN","RCR JRCOU",92, 0)
	11576	S PAGE=PA GE+1 U IO W @IOF
	11577	"RTN","RCR JRCOU",93, 0)
	11578	W ?50,"AR DC Detaile d Report", ?105,"Page :",PAGE,!
	11579	"RTN","RCR JRCOU",94, 0)
	11580	W "Bill#" ,?12,"AR C reate",?25 ,"AR Categ ory",?45," Bill",?62 ,"FMS",?71 ," Fund",?
	11581	82,"RSC",? 92,"Princi pal",?110, "Balance"
	11582	"RTN","RCR JRCOU",95, 0)
	11583	W !,?14," Date",?45 ,"Status", ?62,"Type" ,?72,"Numb er",?95,"A mount",!
	11584	"RTN","RCR JRCOU",96, 0)
	11585	N I F I=1 :1:120 W " -"
	11586	"RTN","RCR JRCOU",97, 0)
	11587	Q
	11588	"RTN","RCR JRCOU",98, 0)
	11589	;
	11590	"RTN","RCR JRCOU",99, 0)
	11591	PRINT ; pr int record s to scree n or print er 132 col umns
	11592	"RTN","RCR JRCOU",100 ,0)
	11593	N PAGE S PAGE=0,REC ORD=0
	11594	"RTN","RCR JRCOU",101 ,0)
	11595	F S RECO RD=$O(@RCR ET@(RECORD )) Q:'RECO RD D
	11596	"RTN","RCR JRCOU",102 ,0)
	11597	. I RECOR D=1 D HDR
	11598	"RTN","RCR JRCOU",103 ,0)
	11599	. I $Y+3> IOSL I ($E (IOST,1,2) ="C-")&(IO =IO(0)) S DIR(0)="E" D ^DIR K DIR G:$D(D
	11600	UOUT)!($D( DTOUT)) EX IT D HDR
	11601	"RTN","RCR JRCOU",104 ,0)
	11602	. W !,$P( @RCRET@(RE CORD),U),? 12,$P(@RCR ET@(RECORD ),U,2),?25 ,$P(@RCRET @(RECORD),
	11603	U,3),?45,$ P(@RCRET@( RECORD),U, 4),?62,$P( @RCRET@(RE CORD),U,5)
	11604	"RTN","RCR JRCOU",105 ,0)
	11605	. W ?72,$ P(@RCRET@( RECORD),U, 6),?82,$P( @RCRET@(RE CORD),U,7) ,?90,$P(@R CRET@(RECO
	11606	RD),U,8),? 106,$P(@RC RET@(RECOR D),U,9)
	11607	"RTN","RCR JRCOU",106 ,0)
	11608	Q
	11609	"RTN","RCR JRCOU",107 ,0)
	11610	;
	11611	"RTN","RCR JRCOU",108 ,0)
	11612	; Leaving old entry point in place as a precautio n
	11613	"RTN","RCR JRCOU",109 ,0)
	11614	USERREPT(D ATEMOYR) ; generate user deta iled repor t and send it to Mai lMan
	11615	"RTN","RCR JRCOU",110 ,0)
	11616	Q ;Previ ous entry point, no longer use d.
	11617	"RTN","RCR JRCOU",111 ,0)
	11618	;
	11619	"RTN","RCR JRCOU",112 ,0)
	11620	;END RCRJ RCOU
	11621	"RTN","RCT CSJR")
	11622	0^13^B1198 36361
	11623	"RTN","RCT CSJR",1,0)
	11624	RCTCSJR ;A LBANY/LEG- CS DEBT RE FERRAL REJ ECT REPORT ING ;07/15 /14 3:34 P M
	11625	"RTN","RCT CSJR",2,0)
	11626	;;4.5;Acc ounts Rece ivable;3 01;Mar 2 0, 1995;Bu ild 2
	11627	"RTN","RCT CSJR",3,0)
	11628	;;Per VA Directive 6402, this routine s hould not be modifie d.
	11629	"RTN","RCT CSJR",4,0)
	11630	;
	11631	"RTN","RCT CSJR",5,0)
	11632	Q
	11633	"RTN","RCT CSJR",6,0)
	11634	ECLIST ; p rints IAI Error Code s List
	11635	"RTN","RCT CSJR",7,0)
	11636	S DIC="^R C(348.5,", BY=.01
	11637	"RTN","RCT CSJR",8,0)
	11638	S (FR,TO) =""
	11639	"RTN","RCT CSJR",9,0)
	11640	S FLDS="[ TCS IAI ER ROR CODES LIST]"
	11641	"RTN","RCT CSJR",10,0 )
	11642	S DHD="TC S IAI ERRO R CODES LI ST"
	11643	"RTN","RCT CSJR",11,0 )
	11644	S DIOBEG= "W !!"
	11645	"RTN","RCT CSJR",12,0 )
	11646	D EN1^DIP
	11647	"RTN","RCT CSJR",13,0 )
	11648	Q
	11649	"RTN","RCT CSJR",14,0 )
	11650	;
	11651	"RTN","RCT CSJR",15,0 )
	11652	;
	11653	"RTN","RCT CSJR",16,0 )
	11654	RJRPT ; fo r CS REJEC T REPORT p rocessing
	11655	"RTN","RCT CSJR",17,0 )
	11656	D INIT
	11657	"RTN","RCT CSJR",18,0 )
	11658	S STOP=0
	11659	"RTN","RCT CSJR",19,0 )
	11660	D PROMPTS
	11661	"RTN","RCT CSJR",20,0 )
	11662	Q:STOP
	11663	"RTN","RCT CSJR",21,0 )
	11664	D HEADING
	11665	"RTN","RCT CSJR",22,0 )
	11666	D GETRECS
	11667	"RTN","RCT CSJR",23,0 )
	11668	D PRTRECS
	11669	"RTN","RCT CSJR",24,0 )
	11670	K %ZIS,AC TN,ASCDES, BILLID,BIL LIEN,BLNKS ,BY,CD,CDI EN,CDREC,C DSH,CHDR,C HDRS,CNTR,
	11671	COLDASH,CO LHDRS,COLW IDTH1
	11672	"RTN","RCT CSJR",25,0 )
	11673	K COLWIDT H2,COLWIDT H3,CWID,DA SH,DATA,DA TAITMS,DAT E,DEBTIDX, DEBTIEN,DE BTOR,DEBTR
	11674	EC,DEBTREF ,DEFAULT,D ESC,DHD,DI OBEG
	11675	"RTN","RCT CSJR",26,0 )
	11676	K DTFRM,D TFRMTO,DTF ROM,DTTO,E CDS,EXCEL, FIELD,FLDS ,FR,GROUPB D,HDTITLE, I,INCLUDE,
	11677	INDATE,L,L EV1,LEV2,L EV3,LEV4,L N
	11678	"RTN","RCT CSJR",27,0 )
	11679	K OUTDATE ,PAGE,POP, QUIT,RPTIT EMS,RPTREC ,RPTTYP,SE Q,SRC,SSN, STOP,STR,T O,TYP,UPDN
	11680	,RECW1,REC W2,EXCOLH
	11681	"RTN","RCT CSJR",28,0 )
	11682	Q
	11683	"RTN","RCT CSJR",29,0 )
	11684	;
	11685	"RTN","RCT CSJR",30,0 )
	11686	INIT ;
	11687	"RTN","RCT CSJR",31,0 )
	11688	K ^XTMP(" RCTCSJS",$ J)
	11689	"RTN","RCT CSJR",32,0 )
	11690	K REC
	11691	"RTN","RCT CSJR",33,0 )
	11692	;S DASH=" ",$P(DASH, "-",81)=""
	11693	"RTN","RCT CSJR",34,0 )
	11694	S DASH="" ,$P(DASH," -",78)="" ; (as per PRCA4.5 315)
	11695	"RTN","RCT CSJR",35,0 )
	11696	S BLNKS=" ",$P(BLNKS ," ",71)=" "
	11697	"RTN","RCT CSJR",36,0 )
	11698	S DATAITM S="DATE^SR C^ECD(1)^E CD(2)^ECD( 3)^ECD(4)^ ECD(5)^ECD (6)^ECD(7) ^ECD(8)^EC
	11699	D(9)^TYP^A CTN"
	11700	"RTN","RCT CSJR",37,0 )
	11701	S RPTITEM S="BILLID^ DEBTOR^SSN ^TYP^ACTN^ OUTDATE^SR C^ECDS"
	11702	"RTN","RCT CSJR",38,0 )
	11703	Q
	11704	"RTN","RCT CSJR",39,0 )
	11705	;
	11706	"RTN","RCT CSJR",40,0 )
	11707	GETRECS ;
	11708	"RTN","RCT CSJR",41,0 )
	11709	N PC
	11710	"RTN","RCT CSJR",42,0 )
	11711	S (DATE,D TFRM)=$P(D TFRMTO,U,2 )-1,DTTO=$ P(DTFRMTO, U,3)
	11712	"RTN","RCT CSJR",43,0 )
	11713	F S DATE =$O(^PRCA( 430,"AB",D ATE)),BILL IEN=0 Q:DA TE>DTTO!'D ATE D ;
	11714	"RTN","RCT CSJR",44,0 )
	11715	. ;S INDA TE=DATE,OU TDATE=$$UP PER^VALM1( $$FMTE^XLF DT(DATE))
	11716	"RTN","RCT CSJR",45,0 )
	11717	. S INDAT E=DATE,OUT DATE=$$FMT E^XLFDT(DA TE,2) ;St andardize dates (as per PRCA*4
	11718	.5*315)
	11719	"RTN","RCT CSJR",46,0 )
	11720	.;. F S SEQ=$O(^PR CA(430,"AB ",DATE,BIL LIEN,SEQ)) Q:SEQ="" D ;
	11721	"RTN","RCT CSJR",47,0 )
	11722	. ;S OUTD ATE=$P(OUT DATE,",")_ ","_$TR($P (OUTDATE," ,",2)," ", "")
	11723	"RTN","RCT CSJR",48,0 )
	11724	. F S BI LLIEN=$O(^ PRCA(430," AB",DATE,B ILLIEN)),S EQ=0 Q:BIL LIEN="" D ;
	11725	"RTN","RCT CSJR",49,0 )
	11726	.. S BILL ID=$P(^PRC A(430,BILL IEN,0),U)
	11727	"RTN","RCT CSJR",50,0 )
	11728	.. S DEBT IEN=$P(^PR CA(430,BIL LIEN,0),U, 9) ;33460
	11729	"RTN","RCT CSJR",51,0 )
	11730	.. S DEBT IDX=$P(^RC D(340,DEBT IEN,0),U) ;777706050 ;DPT(
	11731	"RTN","RCT CSJR",52,0 )
	11732	.. S DEBT REF="^"_$P (DEBTIDX," ;",2)_$P(D EBTIDX,";" )_",0)"
	11733	"RTN","RCT CSJR",53,0 )
	11734	.. S DEBT REC=@(DEBT REF)
	11735	"RTN","RCT CSJR",54,0 )
	11736	.. ;S DEB TOR=$E($P( DEBTREC,U) ,1,19),SSN =$P(DEBTRE C,U,9)
	11737	"RTN","RCT CSJR",55,0 )
	11738	.. S DEBT OR=$E($P(D EBTREC,U), 1,19),SSN= $E($P(DEBT REC,U,9),6 ,9) ;Last 4 of SSN
	11739	only (as p er PRCA4. 5315)
	11740	"RTN","RCT CSJR",56,0 )
	11741	.. F S S EQ=$O(^PRC A(430,"AB" ,DATE,BILL IEN,SEQ)) Q:SEQ="" D ;
	11742	"RTN","RCT CSJR",57,0 )
	11743	... S DAT A=$G(^PRCA (430,BILLI EN,18,SEQ, 0))
	11744	"RTN","RCT CSJR",58,0 )
	11745	... Q:'$L (DATA) ; in the eve nt the X-R EF is out of sync du e to test clearing
	11746	"RTN","RCT CSJR",59,0 )
	11747	... F PC= 2,12,13 S CD=$P(DATA ,U,PC),X=$ P(DATAITMS ,U,PC)_"=" ""_$S(CD=" ":CD,PC=2:
	11748	CD,PC=12:$ P($G(^RC(3 48.7,CD,0) ),U),PC=13 :$P($G(^RC (348.6,CD, 0)),U),1:" ")_"""",@X
	11749	"RTN","RCT CSJR",60,0 )
	11750	... K ECD
	11751	"RTN","RCT CSJR",61,0 )
	11752	... S ECD S=""
	11753	"RTN","RCT CSJR",62,0 )
	11754	... F PC= 3:1:11 S C D=$P(DATA, U,PC) Q:'$ L(CD) S C D=$S('$D(^ RC(348.5,C D,0)):CD,1
	11755	:$P(^RC(34 8.5,CD,0), U)) S X="S "_$P(DATA ITMS,U,PC) _"="""_CD_ """" D ;
	11756	"RTN","RCT CSJR",63,0 )
	11757	.... Q:'$ D(^RC(348. 5,$P(DATA, U,PC),0)) ; quits j ust in cas e bad erro r code got
	11758	thru
	11759	"RTN","RCT CSJR",64,0 )
	11760	.... X X
	11761	"RTN","RCT CSJR",65,0 )
	11762	.... S EC DS=ECDS_$S (PC>3:"^", 1:"")_ECD( PC-2)
	11763	"RTN","RCT CSJR",66,0 )
	11764	... ; ge ts record layout bas ed on RPTT YP and pla ces into R PTTYP sort ing sequen
	11765	ce
	11766	"RTN","RCT CSJR",67,0 )
	11767	... D @RP TTYP ;1=BI LL NO. 2= DEBTOR 3= REJECT DAT E
	11768	"RTN","RCT CSJR",68,0 )
	11769	... Q ;
	11770	"RTN","RCT CSJR",69,0 )
	11771	... ;
	11772	"RTN","RCT CSJR",70,0 )
	11773	S LEV1=""
	11774	"RTN","RCT CSJR",71,0 )
	11775	S CNTR=0
	11776	"RTN","RCT CSJR",72,0 )
	11777	K REC
	11778	"RTN","RCT CSJR",73,0 )
	11779	S UPDN=$S (ASCDES="D ":-1,1:1) ; determin es ASCendi ng or DeSC ending dir ection
	11780	"RTN","RCT CSJR",74,0 )
	11781	F S LEV1 =$O(^XTMP( "RCTCSJS", $J,"RPT",L EV1),UPDN) ,LEV2="" Q :LEV1="" D ;
	11782	"RTN","RCT CSJR",75,0 )
	11783	. F S LE V2=$O(^XTM P("RCTCSJS ",$J,"RPT" ,LEV1,LEV2 ),UPDN),LE V3="" Q:LE V2="" D
	11784	;
	11785	"RTN","RCT CSJR",76,0 )
	11786	.. F S L EV3=$O(^XT MP("RCTCSJ S",$J,"RPT ",LEV1,LEV 2,LEV3),UP DN),LEV4=" " Q:LEV3="
	11787	" D ;
	11788	"RTN","RCT CSJR",77,0 )
	11789	... F S LEV4=$O(^X TMP("RCTCS JS",$J,"RP T",LEV1,LE V2,LEV3,LE V4),UPDN) Q:LEV4=""
	11790	D ;
	11791	"RTN","RCT CSJR",78,0 )
	11792	.... S RP TREC=^XTMP ("RCTCSJS" ,$J,"RPT", LEV1,LEV2, LEV3,LEV4)
	11793	"RTN","RCT CSJR",79,0 )
	11794	.... S SR C=$E(RPTRE C,67)
	11795	"RTN","RCT CSJR",80,0 )
	11796	.... I IN CLUDE'="AL L",INCLUDE '=SRC Q ; unwanted source
	11797	"RTN","RCT CSJR",81,0 )
	11798	.... S CN TR=CNTR+1
	11799	"RTN","RCT CSJR",82,0 )
	11800	.... S RE C(CNTR)=$P (RPTREC,"^ ",1,$S(EXC EL:10,1:4) )
	11801	"RTN","RCT CSJR",83,0 )
	11802	.... I EX CEL S RECW 1=$E(REC(C NTR),1,70) ,RECW2=$TR ($E(REC(CN TR),71,999 ),"^","-")
	11803	,REC(CNTR) =RECW1_REC W2
	11804	"RTN","RCT CSJR",84,0 )
	11805	.... Q:EX CEL ; only need s single l ine string if in Exc el format
	11806	"RTN","RCT CSJR",85,0 )
	11807	.... S RE CW1=$E(REC (CNTR),1,7 0),RECW2=$ TR($E(REC( CNTR),71,9 99),"^","- "),REC(CNT
	11808	R)=RECW1_R ECW2
	11809	"RTN","RCT CSJR",86,0 )
	11810	.... I $L ($P(RPTREC ,"^",5,8)) D ;
	11811	"RTN","RCT CSJR",87,0 )
	11812	..... S C NTR=CNTR+1 ,REC(CNTR) =$E(BLNKS, 1,69)_$TR( $P(RPTREC, "^",5,8)," ^","-")
	11813	"RTN","RCT CSJR",88,0 )
	11814	.... I $L ($P(RPTREC ,"^",9)) D ;
	11815	"RTN","RCT CSJR",89,0 )
	11816	..... S C NTR=CNTR+1 ,REC(CNTR) =$E(BLNKS, 1,69)_$P(R PTREC,"^", 9)
	11817	"RTN","RCT CSJR",90,0 )
	11818	.... I GR OUPBD="D" D ;
	11819	"RTN","RCT CSJR",91,0 )
	11820	..... K E CD
	11821	"RTN","RCT CSJR",92,0 )
	11822	..... S E CDS=$E(RPT REC,70,100 )
	11823	"RTN","RCT CSJR",93,0 )
	11824	..... F I =1:1:9 S E CD(I)=$P(E CDS,"^",I) Q:'$L(ECD (I)) D ;
	11825	"RTN","RCT CSJR",94,0 )
	11826	...... S CD=$P(ECDS ,"^",I),CD IEN=$O(^RC (348.5,"B" ,CD,0))
	11827	"RTN","RCT CSJR",95,0 )
	11828	...... S CDREC="",C DREC1="" I CDIEN,$D( ^RC(348.5, CDIEN)) S CDREC=^RC( 348.5,CDIE
	11829	N,0),CDREC 1=^RC(348. 5,CDIEN,0)
	11830	"RTN","RCT CSJR",96,0 )
	11831	...... S (X,DESC)=" "_CD_" " _$P(CDREC, U,2)_"~"_C DREC1
	11832	"RTN","RCT CSJR",97,0 )
	11833	...... ; I $L(DESC )<60 S CNT R=CNTR+1,R EC(CNTR)=X
	11834	"RTN","RCT CSJR",98,0 )
	11835	...... ; I $L(DESC )>59 D ;
	11836	"RTN","RCT CSJR",99,0 )
	11837	...... ; F S STR =$E(X,1,59 ) D Q:'$L (X) ;
	11838	"RTN","RCT CSJR",100, 0)
	11839	...... ; I $L(X)<6 0 S CNTR=C NTR+1 S RE C(CNTR)=X, X="" Q ;
	11840	"RTN","RCT CSJR",101, 0)
	11841	...... I $L(DESC)<8 1 S CNTR=C NTR+1,REC( CNTR)=X
	11842	"RTN","RCT CSJR",102, 0)
	11843	...... ; splits li ne if > 80 chars
	11844	"RTN","RCT CSJR",103, 0)
	11845	...... I $L(DESC)>8 0 D ;
	11846	"RTN","RCT CSJR",104, 0)
	11847	....... F S STR=$E (X,1,80) D Q:'$L(X) ;
	11848	"RTN","RCT CSJR",105, 0)
	11849	........ I $L(X)<81 S CNTR=CN TR+1 S REC (CNTR)=X,X ="" Q
	11850	"RTN","RCT CSJR",106, 0)
	11851	........ F L=$L(STR ):-1:1 I $ F(STR," ", L) D Q ;
	11852	"RTN","RCT CSJR",107, 0)
	11853	......... S CNTR=CN TR+1
	11854	"RTN","RCT CSJR",108, 0)
	11855	......... S REC(CNT R)=$E(X,1, L),X=$E(X, L+1,999)
	11856	"RTN","RCT CSJR",109, 0)
	11857	......... I $L(X) S X=" " _X
	11858	"RTN","RCT CSJR",110, 0)
	11859	......... Q ;
	11860	"RTN","RCT CSJR",111, 0)
	11861	M ^XTMP(" RCTCSJS",$ J,"REC")=R EC
	11862	"RTN","RCT CSJR",112, 0)
	11863	Q
	11864	"RTN","RCT CSJR",113, 0)
	11865	;
	11866	"RTN","RCT CSJR",114, 0)
	11867	1 ; for re port by 1) Bill Numb er
	11868	"RTN","RCT CSJR",115, 0)
	11869	S QUIT=0
	11870	"RTN","RCT CSJR",116, 0)
	11871	I EXCEL S RPTREC=BI LLID_U_DEB TOR_U_SSN_ U_TYP_U_AC TN_U_OUTDA TE_U_SRC_U _ECDS
	11872	"RTN","RCT CSJR",117, 0)
	11873	I 'EXCEL D Q:QUIT ;
	11874	"RTN","RCT CSJR",118, 0)
	11875	. S RPTRE C=""
	11876	"RTN","RCT CSJR",119, 0)
	11877	. F PC=1: 1:7 D Q:Q UIT ;
	11878	"RTN","RCT CSJR",120, 0)
	11879	.. S FIEL D=$P(RPTIT EMS,U,PC)
	11880	"RTN","RCT CSJR",121, 0)
	11881	.. I PC=7 ,INCLUDE'= "ALL",@FIE LD'=INCLUD E S QUIT=1 Q ;
	11882	"RTN","RCT CSJR",122, 0)
	11883	.. S RPTR EC=RPTREC_ $E(@FIELD_ BLNKS,1,$P (COLWIDTH1 ,U,PC))
	11884	"RTN","RCT CSJR",123, 0)
	11885	. F PC=8 S RPTREC=R PTREC_@$P( RPTITEMS,U ,PC)
	11886	"RTN","RCT CSJR",124, 0)
	11887	S ^XTMP(" RCTCSJS",$ J,"RPT",BI LLID,INDAT E,DEBTOR,S EQ)=RPTREC
	11888	"RTN","RCT CSJR",125, 0)
	11889	Q
	11890	"RTN","RCT CSJR",126, 0)
	11891	2 ; for re port by 2) Debtor Na me
	11892	"RTN","RCT CSJR",127, 0)
	11893	S QUIT=0
	11894	"RTN","RCT CSJR",128, 0)
	11895	I EXCEL S RPTREC=DE BTOR_U_BIL LID_U_SSN_ U_TYP_U_AC TN_U_OUTDA TE_U_SRC_U _ECDS
	11896	"RTN","RCT CSJR",129, 0)
	11897	I 'EXCEL D Q:QUIT ;
	11898	"RTN","RCT CSJR",130, 0)
	11899	. S RPTRE C=""
	11900	"RTN","RCT CSJR",131, 0)
	11901	. F PC=2, 1,3:1:7 D Q:QUIT ;
	11902	"RTN","RCT CSJR",132, 0)
	11903	.. S FIEL D=$P(RPTIT EMS,U,PC)
	11904	"RTN","RCT CSJR",133, 0)
	11905	.. I PC=7 ,INCLUDE'= "ALL",@FIE LD'=INCLUD E S QUIT=1 Q ;
	11906	"RTN","RCT CSJR",134, 0)
	11907	.. S RPTR EC=RPTREC_ $E(@FIELD_ BLNKS,1,$P (COLWIDTH2 ,U,PC))
	11908	"RTN","RCT CSJR",135, 0)
	11909	. F PC=8 S RPTREC=R PTREC_@$P( RPTITEMS,U ,PC)
	11910	"RTN","RCT CSJR",136, 0)
	11911	S ^XTMP(" RCTCSJS",$ J,"RPT",DE BTOR,BILLI D,INDATE,S EQ)=RPTREC
	11912	"RTN","RCT CSJR",137, 0)
	11913	Q
	11914	"RTN","RCT CSJR",138, 0)
	11915	3 ; for re port by 3) CS Reject Date
	11916	"RTN","RCT CSJR",139, 0)
	11917	S QUIT=0
	11918	"RTN","RCT CSJR",140, 0)
	11919	I EXCEL S RPTREC=OU TDATE_U_BI LLID_U_DEB TOR_U_SSN_ U_TYP_U_AC TN_U_SRC_U _ECDS
	11920	"RTN","RCT CSJR",141, 0)
	11921	I 'EXCEL D Q:QUIT ;
	11922	"RTN","RCT CSJR",142, 0)
	11923	. S RPTRE C=""
	11924	"RTN","RCT CSJR",143, 0)
	11925	. F PC=6, 1:1:5,7 D Q:QUIT ;
	11926	"RTN","RCT CSJR",144, 0)
	11927	.. S FIEL D=$P(RPTIT EMS,U,PC)
	11928	"RTN","RCT CSJR",145, 0)
	11929	.. I PC=7 ,INCLUDE'= "ALL",@FIE LD'=INCLUD E S QUIT=1 Q ;
	11930	"RTN","RCT CSJR",146, 0)
	11931	.. S RPTR EC=RPTREC_ $E(@$P(RPT ITEMS,U,PC )_BLNKS,1, $P(COLWIDT H3,U,PC))
	11932	"RTN","RCT CSJR",147, 0)
	11933	. F PC=8 S RPTREC=R PTREC_@$P( RPTITEMS,U ,PC)
	11934	"RTN","RCT CSJR",148, 0)
	11935	S ^XTMP(" RCTCSJS",$ J,"RPT",IN DATE,BILLI D,DEBTOR,S EQ)=RPTREC
	11936	"RTN","RCT CSJR",149, 0)
	11937	Q
	11938	"RTN","RCT CSJR",150, 0)
	11939	PRTRECS ; prints rep ort
	11940	"RTN","RCT CSJR",151, 0)
	11941	S PAGE=0
	11942	"RTN","RCT CSJR",152, 0)
	11943	D HEADING
	11944	"RTN","RCT CSJR",153, 0)
	11945	D REJREPH
	11946	"RTN","RCT CSJR",154, 0)
	11947	S LN=0
	11948	"RTN","RCT CSJR",155, 0)
	11949	F LN=1:1 Q:'$D(^XTM P("RCTCSJS ",$J,"REC" ,LN)) D Q:$D(DIRUT )!$D(DUOUT )!$D(DTOUT
	11950	)
	11951	"RTN","RCT CSJR",156, 0)
	11952	. W ^XTMP ("RCTCSJS" ,$J,"REC", LN),!
	11953	"RTN","RCT CSJR",157, 0)
	11954	. ; ch eck for en d of page here, if n ecessary f orm feed a nd print h eader
	11955	"RTN","RCT CSJR",158, 0)
	11956	. I $Y+3> IOSL D
	11957	"RTN","RCT CSJR",159, 0)
	11958	.. I $E(I OST,1,2)=" C-" S DIR( 0)="E" K D IRUT D ^DI R Q:$D(DIR UT)!$D(DUO UT)!$D(DTO
	11959	UT)
	11960	"RTN","RCT CSJR",160, 0)
	11961	.. D REJR EPH
	11962	"RTN","RCT CSJR",161, 0)
	11963	. Q
	11964	"RTN","RCT CSJR",162, 0)
	11965	I $E(IOST ,1,2)="C-" R !!,"END OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @
	11966	IOF
	11967	"RTN","RCT CSJR",163, 0)
	11968	D ^%ZISC
	11969	"RTN","RCT CSJR",164, 0)
	11970	Q
	11971	"RTN","RCT CSJR",165, 0)
	11972	REJREPH ;
	11973	"RTN","RCT CSJR",166, 0)
	11974	U IO
	11975	"RTN","RCT CSJR",167, 0)
	11976	W @IOF
	11977	"RTN","RCT CSJR",168, 0)
	11978	S PAGE=PA GE+1
	11979	"RTN","RCT CSJR",169, 0)
	11980	W "PAGE " _PAGE,?10, HDTITLE,?6 8,$$FMTE^X LFDT(DT,2) ;$$UPPE R^VALM1($$ FMTE^XLFDT
	11981	(DT)) - S tandardize the date
	11982	"RTN","RCT CSJR",170, 0)
	11983	I EXCEL W !,$TR(CHD R," ",""), ! Q
	11984	"RTN","RCT CSJR",171, 0)
	11985	W !,DASH, !,CHDR,!,C DSH,! Q
	11986	"RTN","RCT CSJR",172, 0)
	11987	Q
	11988	"RTN","RCT CSJR",173, 0)
	11989	COLHDR ; s ets report line base d on type of report
	11990	"RTN","RCT CSJR",174, 0)
	11991	S CHDR=CH DR_$P(COLH DRS,U,PC)_ $S(EXCEL:" ^",1:"")
	11992	"RTN","RCT CSJR",175, 0)
	11993	S CDSH=CD SH_$P(COLD ASH,U,PC)_ $S(EXCEL:" ^",1:"")
	11994	"RTN","RCT CSJR",176, 0)
	11995	; S CWID =CWID_$P(C OLWIDTH,U, PC)
	11996	"RTN","RCT CSJR",177, 0)
	11997	Q
	11998	"RTN","RCT CSJR",178, 0)
	11999	HEADING ; compiles info for H eading and titles fo r cross-se rvicing re ject repor
	12000	t
	12001	"RTN","RCT CSJR",179, 0)
	12002	S HDTITLE ="DEBT REF ERRAL REJE CT REPORT (SORTED BY "_$P("BIL L NO.^DEBT OR^REJ DAT
	12003	E",U,RPTTY P)
	12004	"RTN","RCT CSJR",180, 0)
	12005	S HDTITLE =HDTITLE_" <"_$S(ASC DES="D":"D SC",1:"ASC ")_">)"
	12006	"RTN","RCT CSJR",181, 0)
	12007	;
	12008	"RTN","RCT CSJR",182, 0)
	12009	;S COLWID TH1="12^20 ^11^5^5^13 ^3^11"
	12010	"RTN","RCT CSJR",183, 0)
	12011	;S COLWID TH2="12^20 ^11^5^5^13 ^3^11"
	12012	"RTN","RCT CSJR",184, 0)
	12013	;S COLWID TH3="12^20 ^11^5^6^12 ^3^11"
	12014	"RTN","RCT CSJR",185, 0)
	12015	S COLWIDT H1="12^20^ 7^5^5^13^3 ^11" ;Cha nge SSN to last 4 on ly (as per PRCA4.5
	12016	315)
	12017	"RTN","RCT CSJR",186, 0)
	12018	S COLWIDT H2="12^20^ 7^5^5^13^3 ^11"
	12019	"RTN","RCT CSJR",187, 0)
	12020	S COLWIDT H3="12^20^ 7^5^6^12^3 ^11"
	12021	"RTN","RCT CSJR",188, 0)
	12022	;S EXCOLH ="BILL NO. ^DEBTOR^SS N^TYP ^ACT NCD ^REJEC T DATE ^SR C ^ERR COD ES"
	12023	"RTN","RCT CSJR",189, 0)
	12024	S COLHDRS ="BILL NO. ^DEBTO R ^SSN ^TYP ^AC TNCD ^REJE CT DATE ^S
	12025	RC ^ERR CO DES"
	12026	"RTN","RCT CSJR",190, 0)
	12027	S COLDASH ="-------- --- ^----- ---------- ---- ^---- - ^--- ^-- ---- ^---- ------- ^-
	12028	-- ^------ ---"
	12029	"RTN","RCT CSJR",191, 0)
	12030	S (CHDR,C DSH,CWID)= ""
	12031	"RTN","RCT CSJR",192, 0)
	12032	I RPTTYP= 1 S CWID=C OLWIDTH1,C HDR=$S(EXC EL:COLHDRS ,1:$TR(COL HDRS,"^"," ")),CDSH=$
	12033	S(EXCEL:CO LDASH,1:$T R(COLDASH, "^",""))
	12034	"RTN","RCT CSJR",193, 0)
	12035	I RPTTYP= 2 F PC=2,1 ,3:1:8 D C OLHDR
	12036	"RTN","RCT CSJR",194, 0)
	12037	I RPTTYP= 3 F PC=6,1 :1:5,7,8 D COLHDR
	12038	"RTN","RCT CSJR",195, 0)
	12039	;I EXCEL S CHDRS=$T R(CHDR," " ,""),CDSH= $TR(CDSH," ","")
	12040	"RTN","RCT CSJR",196, 0)
	12041	Q
	12042	"RTN","RCT CSJR",197, 0)
	12043	PROMPTS S U="^"
	12044	"RTN","RCT CSJR",198, 0)
	12045	S STOP=0
	12046	"RTN","RCT CSJR",199, 0)
	12047	S PROMPT= "* DEBT REFERRAL R EJECT REPO RT *"
	12048	"RTN","RCT CSJR",200, 0)
	12049	S DTFRMTO =$$DTFRMTO (PROMPT) I 'DTFRMTO S STOP=1 Q
	12050	"RTN","RCT CSJR",201, 0)
	12051	;
	12052	"RTN","RCT CSJR",202, 0)
	12053	S PROMPT= "Group Err or Codes: Brief or Detail"
	12054	"RTN","RCT CSJR",203, 0)
	12055	S DIR(0)= "SB^B:Brie f;D:Detail "
	12056	"RTN","RCT CSJR",204, 0)
	12057	S GROUPBD =$$SELECT( PROMPT,"B" ) I "BD"'[ GROUPBD S STOP=1 Q
	12058	"RTN","RCT CSJR",205, 0)
	12059	;
	12060	"RTN","RCT CSJR",206, 0)
	12061	S SET="S^ 1:Bill Num ber;2:Debt or Name;3: CS Reject Date"
	12062	"RTN","RCT CSJR",207, 0)
	12063	S RPTTYP= $$RPTTYP(" Select One of the Fo llowing:", SET) I 'RP TTYP S STO P=1 Q
	12064	"RTN","RCT CSJR",208, 0)
	12065	;
	12066	"RTN","RCT CSJR",209, 0)
	12067	S PROMPT= "Include O nly: AITC, DMC, TREA SURY or 'A LL'"
	12068	"RTN","RCT CSJR",210, 0)
	12069	S DIR(0)= "SB^A:AITC ;D:DMC;T:T REASURY;AL L:ALL"
	12070	"RTN","RCT CSJR",211, 0)
	12071	S DIR("L" )=PROMPT
	12072	"RTN","RCT CSJR",212, 0)
	12073	S INCLUDE =$$SELECT( PROMPT,"AL L") I "ADT "'[$E(INCL UDE) S STO P=1 Q
	12074	"RTN","RCT CSJR",213, 0)
	12075	;
	12076	"RTN","RCT CSJR",214, 0)
	12077	S PROMPT= "Sort ASCE NDING or D ESCENDING"
	12078	"RTN","RCT CSJR",215, 0)
	12079	S DIR(0)= "SB^A:ASCE NDING;D:DE SCENDING"
	12080	"RTN","RCT CSJR",216, 0)
	12081	S DIR("L" )=PROMPT
	12082	"RTN","RCT CSJR",217, 0)
	12083	S ASCDES= $$SELECT(P ROMPT,"A") I "AD"'[A SCDES S ST OP=1 Q
	12084	"RTN","RCT CSJR",218, 0)
	12085	;
	12086	"RTN","RCT CSJR",219, 0)
	12087	S EXCEL=0
	12088	"RTN","RCT CSJR",220, 0)
	12089	IF GROUPB D="B" D Q :STOP ;
	12090	"RTN","RCT CSJR",221, 0)
	12091	. S PROMP T="CAPTURE Report da ta to an E xcel Docum ent?"
	12092	"RTN","RCT CSJR",222, 0)
	12093	. S DIR(0 )="Y"
	12094	"RTN","RCT CSJR",223, 0)
	12095	. S DIR(" ?")="^D HE XC^RCTCSJR "
	12096	"RTN","RCT CSJR",224, 0)
	12097	. S EXCEL =$$SELECT( PROMPT,"NO ") I "01"' [EXCEL S S TOP=1 Q
	12098	"RTN","RCT CSJR",225, 0)
	12099	. I EXCEL =1 D EXCMS G^RCTCSJR ; Display Excel disp lay messag e
	12100	"RTN","RCT CSJR",226, 0)
	12101	;
	12102	"RTN","RCT CSJR",227, 0)
	12103	S %ZIS="A EQ" D ^%ZI S I POP S STOP=1 Q
	12104	"RTN","RCT CSJR",228, 0)
	12105	I $D(IO(" Q")) D Q ;
	12106	"RTN","RCT CSJR",229, 0)
	12107	.S ZTS AVE("DEBTO R")=""
	12108	"RTN","RCT CSJR",230, 0)
	12109	.S ZTR TN="PRTREC S^RCTCSJR" ,ZTDESC="C ROSS-SERVI CING BILL REPORT"
	12110	"RTN","RCT CSJR",231, 0)
	12111	.D ^%Z TLOAD,^%ZI SC
	12112	"RTN","RCT CSJR",232, 0)
	12113	.Q
	12114	"RTN","RCT CSJR",233, 0)
	12115	Q ; PROM PTS
	12116	"RTN","RCT CSJR",234, 0)
	12117	;
	12118	"RTN","RCT CSJR",235, 0)
	12119	SELECT(PRO MPT,DEFAUL T) ; promp ts for a s election
	12120	"RTN","RCT CSJR",236, 0)
	12121	;INPUT:
	12122	"RTN","RCT CSJR",237, 0)
	12123	; PROMP T - Messag e to displ ay prior t o promptin g for date s
	12124	"RTN","RCT CSJR",238, 0)
	12125	;OUTPUT:
	12126	"RTN","RCT CSJR",239, 0)
	12127	; 1^BE GDT^ENDDT - Data fou nd
	12128	"RTN","RCT CSJR",240, 0)
	12129	; 0 - User up arrowed or timed out
	12130	"RTN","RCT CSJR",241, 0)
	12131	;
	12132	"RTN","RCT CSJR",242, 0)
	12133	N Y,X,DTO UT,OUT,DIR UT,DUOUT,D IROUT ;BEG DT,ENDDT,
	12134	"RTN","RCT CSJR",243, 0)
	12135	S OUT=0
	12136	"RTN","RCT CSJR",244, 0)
	12137	W !
	12138	"RTN","RCT CSJR",245, 0)
	12139	S DIR("A" )=PROMPT
	12140	"RTN","RCT CSJR",246, 0)
	12141	S DIR("B" )=DEFAULT
	12142	"RTN","RCT CSJR",247, 0)
	12143	D ^DIR K DIR
	12144	"RTN","RCT CSJR",248, 0)
	12145	;Quit if user time out or did n't enter valid date
	12146	"RTN","RCT CSJR",249, 0)
	12147	Q:Y<0 OUT
	12148	"RTN","RCT CSJR",250, 0)
	12149	Q Y
	12150	"RTN","RCT CSJR",251, 0)
	12151	;
	12152	"RTN","RCT CSJR",252, 0)
	12153	RPTTYP(PRO MPT,SET) ; PRINT CROS S-SERVICIN G REPORT; print cros s-servicin g report,
	12154	prints sor ted indivi dual bills that make up a cros s-servicin g account
	12155	"RTN","RCT CSJR",253, 0)
	12156	N DIC,ZTS AVE,ZTDESC ,ZTRTN,RCS ORT
	12157	"RTN","RCT CSJR",254, 0)
	12158	S OUT=0
	12159	"RTN","RCT CSJR",255, 0)
	12160	W !
	12161	"RTN","RCT CSJR",256, 0)
	12162	S DIR(0)= SET ;"S^1: Bill Numbe r;2:Debtor Name;3:CS Reject Da te"
	12163	"RTN","RCT CSJR",257, 0)
	12164	S DIR("A" )="Sort by "
	12165	"RTN","RCT CSJR",258, 0)
	12166	S DIR("B" )=1 D ^DIR K DIR
	12167	"RTN","RCT CSJR",259, 0)
	12168	Q:Y<0 OUT
	12169	"RTN","RCT CSJR",260, 0)
	12170	Q Y
	12171	"RTN","RCT CSJR",261, 0)
	12172	;
	12173	"RTN","RCT CSJR",262, 0)
	12174	DTFRMTO(PR OMPT) ;Get from and to dates
	12175	"RTN","RCT CSJR",263, 0)
	12176	;INPUT:
	12177	"RTN","RCT CSJR",264, 0)
	12178	; PROMP T - Messag e to displ ay prior t o promptin g for date s
	12179	"RTN","RCT CSJR",265, 0)
	12180	;OUTPUT:
	12181	"RTN","RCT CSJR",266, 0)
	12182	; 1^BE GDT^ENDDT - Data fou nd
	12183	"RTN","RCT CSJR",267, 0)
	12184	; 0 - User up arrowed or timed out
	12185	"RTN","RCT CSJR",268, 0)
	12186	;
	12187	"RTN","RCT CSJR",269, 0)
	12188	N %DT,Y,X ,BEGDT,END DT,DTOUT,O UT,DIRUT,D UOUT,DIROU T
	12189	"RTN","RCT CSJR",270, 0)
	12190	S OUT=0
	12191	"RTN","RCT CSJR",271, 0)
	12192	W !,$G(PR OMPT)
	12193	"RTN","RCT CSJR",272, 0)
	12194	S %DT="AE X"
	12195	"RTN","RCT CSJR",273, 0)
	12196	S %DT("A" )="Date Ra nge: FROM: " ;Enter Beginning Date: "
	12197	"RTN","RCT CSJR",274, 0)
	12198	S %DT("B" )="T-7"
	12199	"RTN","RCT CSJR",275, 0)
	12200	W !
	12201	"RTN","RCT CSJR",276, 0)
	12202	D ^%DT
	12203	"RTN","RCT CSJR",277, 0)
	12204	K %DT
	12205	"RTN","RCT CSJR",278, 0)
	12206	Q:Y<0 OUT ;Quit if user time out or di dn't enter valid dat e
	12207	"RTN","RCT CSJR",279, 0)
	12208	S DTFROM= +Y
	12209	"RTN","RCT CSJR",280, 0)
	12210	S %DT="AE X"
	12211	"RTN","RCT CSJR",281, 0)
	12212	S %DT("A" )=" TO: ",%DT(" B")="T" ;" TODAY"
	12213	"RTN","RCT CSJR",282, 0)
	12214	D ^%DT
	12215	"RTN","RCT CSJR",283, 0)
	12216	K %DT
	12217	"RTN","RCT CSJR",284, 0)
	12218	;Quit if user time out or did n't enter valid date
	12219	"RTN","RCT CSJR",285, 0)
	12220	Q:Y<0 OUT
	12221	"RTN","RCT CSJR",286, 0)
	12222	S DTTO=+Y
	12223	"RTN","RCT CSJR",287, 0)
	12224	S OUT=1_U _DTFROM_U_ DTTO
	12225	"RTN","RCT CSJR",288, 0)
	12226	;Switch d ates if Be gin Date i s more rec ent than E nd Date
	12227	"RTN","RCT CSJR",289, 0)
	12228	S:DTFROM> DTTO OUT=1 _U_DTTO_U_ DTFROM
	12229	"RTN","RCT CSJR",290, 0)
	12230	Q OUT
	12231	"RTN","RCT CSJR",291, 0)
	12232	;
	12233	"RTN","RCT CSJR",292, 0)
	12234	HEXC ; - ' Do you wan t to captu re data to EXCEL' pr ompt
	12235	"RTN","RCT CSJR",293, 0)
	12236	W !!," Enter: 'Y' - To capture detail re port data to transfe r"
	12237	"RTN","RCT CSJR",294, 0)
	12238	W !," to an Exce l document "
	12239	"RTN","RCT CSJR",295, 0)
	12240	W !," '<CR>' - To skip th is option"
	12241	"RTN","RCT CSJR",296, 0)
	12242	W !," '^' - To quit th is option"
	12243	"RTN","RCT CSJR",297, 0)
	12244	Q
	12245	"RTN","RCT CSJR",298, 0)
	12246	;
	12247	"RTN","RCT CSJR",299, 0)
	12248	EXCMSG ; - Displays the messag e about ca pturing to an Excel file forma t
	12249	"RTN","RCT CSJR",300, 0)
	12250	;
	12251	"RTN","RCT CSJR",301, 0)
	12252	W !!?5,"T o capture as an Exce l format, it is reco mmended th at you que ue this"
	12253	"RTN","RCT CSJR",302, 0)
	12254	W !?5,"re port to a spool devi ce with ma rgins of 2 56 and pag e length o f 99999"
	12255	"RTN","RCT CSJR",303, 0)
	12256	W !?5,"(e .g. spooln ame;256;99 999). This should he lp avoid w rapping pr oblems."
	12257	"RTN","RCT CSJR",304, 0)
	12258	W !!?5,"A nother met hod would be to set up your te rminal to capture th e detail"
	12259	"RTN","RCT CSJR",305, 0)
	12260	W !?5,"re port data. On some t erminals, this can b e done by invoking ' Logging'"
	12261	"RTN","RCT CSJR",306, 0)
	12262	W !?5,"or clicking on the 'To ols' menu above, the n click on 'Capture Incoming "
	12263	"RTN","RCT CSJR",307, 0)
	12264	W !?5,"Da ta' to sav e to Deskt op. To avo id undesir ed wrappin g of the d ata saved"
	12265	"RTN","RCT CSJR",308, 0)
	12266	W !?5,"to the file, change th e DISPLAY screen wid th size to 132 and y ou can"
	12267	"RTN","RCT CSJR",309, 0)
	12268	W !?5,"en ter '0;256 ;99999' at the 'DEVI CE:' promp t.",!
	12269	"RTN","RCT CSJR",310, 0)
	12270	Q
	12271	"RTN","RCT CSJR",311, 0)
	12272	; ======= ========== ========== ========== ========== ========== ========== =====
	12273	"RTN","RCT CSP1")
	12274	0^12^B3819 81296
	12275	"RTN","RCT CSP1",1,0)
	12276	RCTCSP1 ;A LBANY/BDB- CROSS-SERV ICING TRAN SMISSION ; 03/15/14 3 :34 PM
	12277	"RTN","RCT CSP1",2,0)
	12278	;;4.5;Acc ounts Rece ivable;3 01;Mar 2 0, 1995;Bu ild 2
	12279	"RTN","RCT CSP1",3,0)
	12280	;;Per VA Directive 6402, this routine s hould not be modifie d.
	12281	"RTN","RCT CSP1",4,0)
	12282	;
	12283	"RTN","RCT CSP1",5,0)
	12284	Q
	12285	"RTN","RCT CSP1",6,0)
	12286	;
	12287	"RTN","RCT CSP1",7,0)
	12288	BILLREP ;c ross-servi cing bill report, pr ints indiv idual bill s that mak e up a cro
	12289	ss-servici ng account
	12290	"RTN","RCT CSP1",8,0)
	12291	N DIC,DEB TOR,ZTSAVE ,ZTDESC,ZT RTN,POP,DT FRMTO,PROM PT,EXCEL
	12292	"RTN","RCT CSP1",9,0)
	12293	S DIC=340 ,DIC(0)="A EQM",DIC(" S")="I $D( ^RCD(340," "TCSP"",+Y ))" D ^DIC
	12294	"RTN","RCT CSP1",10,0 )
	12295	Q:Y<1 S DEBTOR=+Y
	12296	"RTN","RCT CSP1",11,0 )
	12297	S DTFRMTO =$$DTFRMTO ^RCTCSP2 Q :'DTFRMTO ;Get date range as per PRCA4 .5315
	12298	"RTN","RCT CSP1",12,0 )
	12299	S EXCEL=0 ,PROMPT="C APTURE Rep ort data t o an Excel Document? ",DIR(0)=" Y",DIR("?"
	12300	)="^D HEXC ^RCTCSJR"
	12301	"RTN","RCT CSP1",13,0 )
	12302	S EXCEL=$ $SELECT^RC TCSJR(PROM PT,"NO") I "01"'[EXC EL S STOP= 1 Q
	12303	"RTN","RCT CSP1",14,0 )
	12304	I EXCEL=1 D EXCMSG^ RCTCSJR ; Display Ex cel displa y message
	12305	"RTN","RCT CSP1",15,0 )
	12306	K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")="" D ^%ZIS G: POP BILLRE PQ S IOP=I ON_";"_IOM
	12307	_";"_IOSL
	12308	"RTN","RCT CSP1",16,0 )
	12309	I $D(IO(" Q")) D G BILLREPQ
	12310	"RTN","RCT CSP1",17,0 )
	12311	.S ZTSAVE ("DEBTOR") ="",ZTSAVE ("DTFRMTO" )="",ZTSAV E("EXCEL") =""
	12312	"RTN","RCT CSP1",18,0 )
	12313	.S ZTRTN= "BILLREPP^ RCTCSP1",Z TDESC="CRO SS-SERVICI NG BILL RE PORT"
	12314	"RTN","RCT CSP1",19,0 )
	12315	.D ^%ZTLO AD,HOME^%Z IS
	12316	"RTN","RCT CSP1",20,0 )
	12317	.Q
	12318	"RTN","RCT CSP1",21,0 )
	12319	;
	12320	"RTN","RCT CSP1",22,0 )
	12321	BILLREPP ; Call to bu ild array of bills r eferred
	12322	"RTN","RCT CSP1",23,0 )
	12323	U IO
	12324	"RTN","RCT CSP1",24,0 )
	12325	N BILL,B7 ,B14,B15,B 16,D4,FND, BAMT,TAMT, DIRUT,TNM, TID,TDT,DA SH,CSTAT,P AGE,DASH,T
	12326	MP,I,DATE, DTFRM,DTTO
	12327	"RTN","RCT CSP1",25,0 )
	12328	K ^TMP("R CTCSP1",$J )
	12329	"RTN","RCT CSP1",26,0 )
	12330	S DASH="" ,$P(DASH," -",78)="" ;(as per PRCA4.53 15)
	12331	"RTN","RCT CSP1",27,0 )
	12332	S (DATE,D TFRM)=$P(D TFRMTO,U,2 )-1,DTTO=$ P(DTFRMTO, U,3),CURDT =0
	12333	"RTN","RCT CSP1",28,0 )
	12334	S (BAMT,T AMT,BILL,P AGE)=0
	12335	"RTN","RCT CSP1",29,0 )
	12336	F S DAT E=$O(^PRCA (430,"AB", DATE)),BIL L=0 Q:DATE =""!(DATE> DTTO)!($D( DIRUT)) D
	12337	"RTN","RCT CSP1",30,0 )
	12338	. F S BI LL=$O(^PRC A(430,"AB" ,DATE,BILL )) Q:BILL= "" D
	12339	"RTN","RCT CSP1",31,0 )
	12340	..;F S B ILL=$O(^PR CA(430,"C" ,DEBTOR,BI LL)) Q:('B ILL)!($D(D IRUT)) D
	12341	"RTN","RCT CSP1",32,0 )
	12342	..Q:$P($G (^PRCA(430 ,BILL,0)), U,9)'=DEBT OR
	12343	"RTN","RCT CSP1",33,0 )
	12344	..Q:'+$G( ^PRCA(430, BILL,15))
	12345	"RTN","RCT CSP1",34,0 )
	12346	..S B7=$G (^PRCA(430 ,BILL,7))
	12347	"RTN","RCT CSP1",35,0 )
	12348	..S BAMT= 0 F I=1:1: 5 S BAMT=B AMT+$P(B7, U,I)
	12349	"RTN","RCT CSP1",36,0 )
	12350	..S TAMT= TAMT+BAMT
	12351	"RTN","RCT CSP1",37,0 )
	12352	..S ^TMP( "RCTCSP1", $J,DEBTOR, BILL)=BAMT
	12353	"RTN","RCT CSP1",38,0 )
	12354	D BILLREP H
	12355	"RTN","RCT CSP1",39,0 )
	12356	S DEBTOR= "" F S DE BTOR=$O(^T MP("RCTCSP 1",$J,DEBT OR)) Q:'DE BTOR!($D(D IRUT)) D
	12357	"RTN","RCT CSP1",40,0 )
	12358	. S BILL= 0 F S BIL L=$O(^TMP( "RCTCSP1", $J,DEBTOR, BILL)) Q:' BILL D
	12359	"RTN","RCT CSP1",41,0 )
	12360	..;S (FND ,BILL)=0 F S BILL=$ O(^PRCA(43 0,"C",DEBT OR,BILL)) Q:('BILL)! ($D(DIRUT)
	12361	) D
	12362	"RTN","RCT CSP1",42,0 )
	12363	..Q:'+$G( ^PRCA(430, BILL,15))
	12364	"RTN","RCT CSP1",43,0 )
	12365	..S FND=1 W !,$P(^P RCA(430,BI LL,0),U) S CSTAT=$P( ^(0),U,8), B7=$G(^(7) ),B15=$G(^
	12366	(15)),B16= $G(^(16))
	12367	"RTN","RCT CSP1",44,0 )
	12368	..I 'EXCE L W ?10,$P (^PRCA(430 .3,CSTAT,0 ),U,2)
	12369	"RTN","RCT CSP1",45,0 )
	12370	..I EXCEL W U_$P(^P RCA(430.3, CSTAT,0),U ,2)
	12371	"RTN","RCT CSP1",46,0 )
	12372	..I 'EXCE L W ?14
	12373	"RTN","RCT CSP1",47,0 )
	12374	..I EXCEL W U
	12375	"RTN","RCT CSP1",48,0 )
	12376	..W $J($P (B16,U,9), 8,2)
	12377	"RTN","RCT CSP1",49,0 )
	12378	..S BAMT= ^TMP("RCTC SP1",$J,DE BTOR,BILL)
	12379	"RTN","RCT CSP1",50,0 )
	12380	..;S BAMT =0 F I=1:1 :5 S BAMT= BAMT+$P(B7 ,U,I)
	12381	"RTN","RCT CSP1",51,0 )
	12382	..I 'EXCE L W ?24
	12383	"RTN","RCT CSP1",52,0 )
	12384	..I EXCEL W U
	12385	"RTN","RCT CSP1",53,0 )
	12386	..W $J(BA MT,8,2)
	12387	"RTN","RCT CSP1",54,0 )
	12388	..;W $J($ P(B7,U,1), 10,2)
	12389	"RTN","RCT CSP1",55,0 )
	12390	..I 'EXCE L W $J($P( B7,U,1),8, 2),$J($P(B 7,U,2),7,2 ),$J($P(B7 ,U,3),7,2) ,$J($P(B7,
	12391	U,4),8,2) ;(as per PRCA4.53 15)
	12392	"RTN","RCT CSP1",56,0 )
	12393	..I EXCEL W $J($P(B 7,U,1),8,2 )_U_$J($P( B7,U,2),7, 2)_U_$J($P (B7,U,3),7 ,2)_U_$J($
	12394	P(B7,U,4), 8,2)
	12395	"RTN","RCT CSP1",57,0 )
	12396	..;S TMP= $$UPPER^VA LM1($$FMTE ^XLFDT($P( B15,U,1)))
	12397	"RTN","RCT CSP1",58,0 )
	12398	..S TMP=$ $FMTE^XLFD T($P(B15,U ,1),2) ;F ormat date to n/n/nn (as per PRCA4.53
	12399	15)
	12400	"RTN","RCT CSP1",59,0 )
	12401	..;W ?69, $P(TMP,", ",1)_","_$ P(TMP,", " ,2)
	12402	"RTN","RCT CSP1",60,0 )
	12403	..I 'EXCE L W ?64,TM P ;$P(TMP ,", ",1)_" ,"_$P(TMP, ", ",2) ;
	12404	"RTN","RCT CSP1",61,0 )
	12405	..I EXCEL W U_TMP
	12406	"RTN","RCT CSP1",62,0 )
	12407	..;check for end of page here , if neces sary form feed and p rint heade r
	12408	"RTN","RCT CSP1",63,0 )
	12409	..I ($Y+3 )>IOSL D
	12410	"RTN","RCT CSP1",64,0 )
	12411	...I $E(I OST,1,2)=" C-" S DIR( 0)="E" K D IRUT D ^DI R Q:$D(DIR UT)
	12412	"RTN","RCT CSP1",65,0 )
	12413	...D BILL REPH
	12414	"RTN","RCT CSP1",66,0 )
	12415	I $E(IOST ,1,2)="C-" R !!,"END OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @
	12416	IOF
	12417	"RTN","RCT CSP1",67,0 )
	12418	D:'$D(ZTQ UEUED) ^%Z ISC
	12419	"RTN","RCT CSP1",68,0 )
	12420	S:$D(ZTQU EUED) ZTRE Q="@"
	12421	"RTN","RCT CSP1",69,0 )
	12422	K IOP,%ZI S,ZTQUEUED
	12423	"RTN","RCT CSP1",70,0 )
	12424	BILLREPQ Q
	12425	"RTN","RCT CSP1",71,0 )
	12426	;
	12427	"RTN","RCT CSP1",72,0 )
	12428	BILLREPH ; header for cross-ser vicing bil l report
	12429	"RTN","RCT CSP1",73,0 )
	12430	W @IOF
	12431	"RTN","RCT CSP1",74,0 )
	12432	S PAGE=PA GE+1
	12433	"RTN","RCT CSP1",75,0 )
	12434	I 'EXCEL W "PAGE "_ PAGE,?24," CROSS-SERV ICING BILL REPORT",? 60,$$FMTE^ XLFDT(DT,2
	12435	),!,DASH
	12436	"RTN","RCT CSP1",76,0 )
	12437	I EXCEL W "PAGE "_P AGE_U_"CRO SS-SERVICI NG BILL RE PORT"_U_U_ $$FMTE^XLF DT(DT,2)
	12438	"RTN","RCT CSP1",77,0 )
	12439	N RCHDR,R CSSN
	12440	"RTN","RCT CSP1",78,0 )
	12441	S RCHDR=$ $ACCNTHDR^ RCDPAPLM(D EBTOR),RCS SN=$S($P(R CHDR,U,2)[ "P":$E($P( RCHDR,U,2)
	12442	,7,11),1:$ E($P(RCHDR ,U,2),6,9) ) ;Pseudo SSN shoul dn't be al lowed but we allowed
	12443	for it to print
	12444	"RTN","RCT CSP1",79,0 )
	12445	;W !!,"DE BTOR: ",$E ($P(RCHDR, U,1),1,18) ,?22,"SSN: ",$E($P(R CHDR,U,2), 2,$L($P(RC
	12446	HDR,U,2))- 1),?55,"CU RRENT CS D EBT: ",$J( TAMT,8,2)
	12447	"RTN","RCT CSP1",80,0 )
	12448	I 'EXCEL D Q
	12449	"RTN","RCT CSP1",81,0 )
	12450	. W !!,"D EBTOR: ",$ E($P(RCHDR ,U,1),1,18 ),?22,"SSN : ",RCSSN, ?45,"CURRE NT CS DEBT
	12451	: ",$J(TAM T,8,2),!,D ASH
	12452	"RTN","RCT CSP1",82,0 )
	12453	. W !,"BI LL NO.",?1 0,"ST",?14 ,"ORIG AMT ",?24,"CUR R AMT",?36 ,"PRIN",?4 4,"INT",?4
	12454	9,"ADMIN", ?57,"COURT ",?64,"CS REF DATE" ;(as per P RCA4.531 5)
	12455	"RTN","RCT CSP1",83,0 )
	12456	. W !,"-- -- ---",?1 0,"--",?14 ,"---- --- ",?24,"--- - ---",?36 ,"----",?4 4,"---",?4
	12457	9,"-----", ?57,"----- ",?64,"-- --- ----"
	12458	"RTN","RCT CSP1",84,0 )
	12459	W !,"DEBT OR: "_$E($ P(RCHDR,U, 1),1,18)_U _U_"SSN: " _RCSSN_U_U _U_"CURREN T CS DEBT:
	12460	"_$J(TAMT ,8,2)
	12461	"RTN","RCT CSP1",85,0 )
	12462	W !,"BILL NO."_U_"S T"_U_"ORIG AMT"_U_"C URR AMT"_U _"PRIN"_U_ "INT"_U_"A DMIN"_U_"C
	12463	OURT"_U_"C S REF DATE "
	12464	"RTN","RCT CSP1",86,0 )
	12465	Q
	12466	"RTN","RCT CSP1",87,0 )
	12467	;
	12468	"RTN","RCT CSP1",88,0 )
	12469	CSRPRT ;pr int cross- servicing report, pr ints sorte d individu al bills t hat make u
	12470	p a cross- servicing account
	12471	"RTN","RCT CSP1",89,0 )
	12472	;
	12473	"RTN","RCT CSP1",90,0 )
	12474	K ^TMP("R CTCSP1",$J )
	12475	"RTN","RCT CSP1",91,0 )
	12476	N DIC,RCS ORT,PAGE,D ASH,DTOUT, DUOUT,DIRO UT,RCIEN,R CDEBTOR,RC REFDT,RCSS N,RCORIG,R
	12477	CCAMT,RCRE FDT,RCBILL ,ITEM,DBTR ,SDT ;BY,FROM ,TO,FLDS,L
	12478	"RTN","RCT CSP1",92,0 )
	12479	S PAGE=0, DASH="",$P (DASH,"-", 81)=""
	12480	"RTN","RCT CSP1",93,0 )
	12481	W !
	12482	"RTN","RCT CSP1",94,0 )
	12483	S DIR(0)= "S^1:Bill Number;2:D ebtor Name ;3:CS Refe rred Date" ,DIR("A")= "Sort by"
	12484	D ^DIR K D IR
	12485	"RTN","RCT CSP1",95,0 )
	12486	S RCSORT= Y Q:($D(DT OUT)!$D(DU OUT)!$D(DI ROUT))
	12487	"RTN","RCT CSP1",96,0 )
	12488	; The fol lowing sec tions were rewritten to elimin ate using ^DIP - (as per PRCA*
	12489	4.5*315 re format dat es and SSN )
	12490	"RTN","RCT CSP1",97,0 )
	12491	S DTFRMTO =$$DTFRMTO ^RCTCSP2 Q :'DTFRMTO ;Get date range as per PRCA4 .5315
	12492	"RTN","RCT CSP1",98,0 )
	12493	S (DATE,D TFRM)=$P(D TFRMTO,U,2 )-1,DTTO=$ P(DTFRMTO, U,3),CURDT =0
	12494	"RTN","RCT CSP1",99,0 )
	12495	S EXCEL=0 ,PROMPT="C APTURE Rep ort data t o an Excel Document? ",DIR(0)=" Y",DIR("?"
	12496	)="^D HEXC ^RCTCSJR"
	12497	"RTN","RCT CSP1",100, 0)
	12498	S EXCEL=$ $SELECT^RC TCSJR(PROM PT,"NO") I "01"'[EXC EL S STOP= 1 Q
	12499	"RTN","RCT CSP1",101, 0)
	12500	I EXCEL=1 D EXCMSG^ RCTCSJR ; Display Ex cel displa y message
	12501	"RTN","RCT CSP1",102, 0)
	12502	K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")="" D ^%ZIS G: POP CSRPRT R S IOP=IO N_";"_IOM_
	12503	";"_IOSL
	12504	"RTN","RCT CSP1",103, 0)
	12505	I $D(IO(" Q")) D G BILLREPQ
	12506	"RTN","RCT CSP1",104, 0)
	12507	I $D(IO(" Q")) D G BILLREPQ
	12508	"RTN","RCT CSP1",105, 0)
	12509	.S ZTSAVE ("RCSORT") ="",ZTSAVE ("DTFRMTO" )="",ZTSAV E("EXCEL") =""
	12510	"RTN","RCT CSP1",106, 0)
	12511	.S ZTRTN= "CSRPRTR^R CTCSP1",ZT DESC="PRIN T CROSS-SE RVICING RE PORT"
	12512	"RTN","RCT CSP1",107, 0)
	12513	.D ^%ZTLO AD,HOME^%Z IS
	12514	"RTN","RCT CSP1",108, 0)
	12515	.Q
	12516	"RTN","RCT CSP1",109, 0)
	12517	CSRPRTR ;
	12518	"RTN","RCT CSP1",110, 0)
	12519	I RCSORT= 1 D
	12520	"RTN","RCT CSP1",111, 0)
	12521	. D CSRPR TH1^RCTCSP 1
	12522	"RTN","RCT CSP1",112, 0)
	12523	. S RCIEN ="" F S R CIEN=$O(^P RCA(430,"T CSP",RCIEN )) Q:RCIEN ="" D
	12524	"RTN","RCT CSP1",113, 0)
	12525	..Q:$P(^P RCA(430,RC IEN,15),U) <DTFRM!($P (^PRCA(430 ,RCIEN,15) ,U)>DTTO)
	12526	"RTN","RCT CSP1",114, 0)
	12527	..K LIST, MSG,RCLIST D GETS^DI Q(430,RCIE N_",",".01 ;9;161;169 ;151;11"," IE","LIST"
	12528	,"MSG") S RCLIST=$NA (LIST(430, RCIEN_",") )
	12529	"RTN","RCT CSP1",115, 0)
	12530	..S ^TMP( "RCTCSP1", $J,RCIEN,@ RCLIST@(.0 1,"E"))=@R CLIST@(.01 ,"E")_U_$E (@RCLIST@(
	12531	9,"E"),1,1 9)_U_$E(@R CLIST@(161 ,"I"),6,9) _U_$J(@RCL IST@(169," E"),8,2)_U _$$FMTE^XL
	12532	FDT(@RCLIS T@(151,"I" ),2)
	12533	"RTN","RCT CSP1",116, 0)
	12534	..S ^TMP( "RCTCSP1", $J,RCIEN,@ RCLIST@(.0 1,"E"))=^T MP("RCTCSP 1",$J,RCIE N,@RCLIST@
	12535	(.01,"E")) _U_$J(@RCL IST@(11,"E "),8,2)
	12536	"RTN","RCT CSP1",117, 0)
	12537	.S (NCIEN ,ITEM)="" F S NCIEN =$O(^TMP(" RCTCSP1",$ J,NCIEN)) Q:NCIEN="" F S ITE
	12538	M=$O(^TMP( "RCTCSP1", $J,NCIEN,I TEM)) Q:IT EM="" D
	12539	"RTN","RCT CSP1",118, 0)
	12540	..I 'EXCE L W !,$P(^ TMP("RCTCS P1",$J,NCI EN,ITEM),U ),?14,$P(^ TMP("RCTCS P1",$J,NCI
	12541	EN,ITEM),U ,2),?35,$P (^TMP("RCT CSP1",$J,N CIEN,ITEM) ,U,3),?40
	12542	"RTN","RCT CSP1",119, 0)
	12543	..I 'EXCE L W $P(^TM P("RCTCSP1 ",$J,NCIEN ,ITEM),U,4 ),?52,$P(^ TMP("RCTCS P1",$J,NCI
	12544	EN,ITEM),U ,5),?66,$P (^TMP("RCT CSP1",$J,N CIEN,ITEM) ,U,6) Q
	12545	"RTN","RCT CSP1",120, 0)
	12546	..I EXCEL W !,^TMP( "RCTCSP1", $J,NCIEN,I TEM)
	12547	"RTN","RCT CSP1",121, 0)
	12548	. ;S DIC= "^PRCA(430 ,",L=0,L(0 )=1,BY(0)= "^PRCA(430 ,""TCSP"", " S FLDS=" .01;L12,9;
	12549	L18,161;R1 0,169;R9,1 51;R12,11; R9",DHD="W ?0 D CSRP RTH1^RCTCS P1"
	12550	"RTN","RCT CSP1",122, 0)
	12551	. ;D EN1^ DIP
	12552	"RTN","RCT CSP1",123, 0)
	12553	.Q
	12554	"RTN","RCT CSP1",124, 0)
	12555	;
	12556	"RTN","RCT CSP1",125, 0)
	12557	I RCSORT= 2 D
	12558	"RTN","RCT CSP1",126, 0)
	12559	. D CSRPR TH2^RCTCSP 1
	12560	"RTN","RCT CSP1",127, 0)
	12561	. S RCIEN ="" F S R CIEN=$O(^P RCA(430,"T CSP",RCIEN )) Q:RCIEN ="" D
	12562	"RTN","RCT CSP1",128, 0)
	12563	..Q:$P(^P RCA(430,RC IEN,15),U) <DTFRM!($P (^PRCA(430 ,RCIEN,15) ,U)>DTTO)
	12564	"RTN","RCT CSP1",129, 0)
	12565	..K LIST, MSG,RCLIST D GETS^DI Q(430,RCIE N_",",".01 ;9;161;169 ;151;11"," IE","LIST"
	12566	,"MSG") S RCLIST=$NA (LIST(430, RCIEN_",") )
	12567	"RTN","RCT CSP1",130, 0)
	12568	..S ^TMP( "RCTCSP1", $J,RCIEN,@ RCLIST@(9, "E"))=$E(@ RCLIST@(9, "E"),1,19) _U_@RCLIST
	12569	@(.01,"E") _U_$E(@RCL IST@(161," I"),6,9)_U _$J(@RCLIS T@(169,"E" ),8,2)_U_$ $FMTE^XLFD
	12570	T(@RCLIST@ (151,"I"), 2)_U_$J(@R CLIST@(11, "E"),8,2)
	12571	"RTN","RCT CSP1",131, 0)
	12572	.S (DBTR, NCIEN)="" F S NCIEN =$O(^TMP(" RCTCSP1",$ J,NCIEN)) Q:NCIEN="" F S DBT
	12573	R=$O(^TMP( "RCTCSP1", $J,NCIEN,D BTR)) Q:DB TR="" D
	12574	"RTN","RCT CSP1",132, 0)
	12575	..I 'EXCE L W !,$P(^ TMP("RCTCS P1",$J,NCI EN,DBTR),U ),?21,$P(^ TMP("RCTCS P1",$J,NCI
	12576	EN,DBTR),U ,2),?35,$P (^TMP("RCT CSP1",$J,N CIEN,DBTR) ,U,3),?41, $P(^TMP("R CTCSP1",$J
	12577	,NCIEN,DBT R),U,4)
	12578	"RTN","RCT CSP1",133, 0)
	12579	..I 'EXCE L W ?52,$P (^TMP("RCT CSP1",$J,N CIEN,DBTR) ,U,5),?66, $P(^TMP("R CTCSP1",$J
	12580	,NCIEN,DBT R),U,6) Q
	12581	"RTN","RCT CSP1",134, 0)
	12582	..I EXCEL W !,^TMP( "RCTCSP1", $J,NCIEN,D BTR)
	12583	"RTN","RCT CSP1",135, 0)
	12584	.;S DIC= "^PRCA(430 ,",L=0,L(0 )=1,BY(0)= "^PRCA(430 ,""TCSP"", ",BY=9,(FR ,TO)="" S
	12585	FLDS="9;L1 8,.01;R12, 161;R10,16 9;R9,151;R 12,11;R9", DHD="W ?0 D CSRPRTH2 ^RCTCSP1"
	12586	"RTN","RCT CSP1",136, 0)
	12587	.;D EN1^D IP
	12588	"RTN","RCT CSP1",137, 0)
	12589	.Q
	12590	"RTN","RCT CSP1",138, 0)
	12591	;
	12592	"RTN","RCT CSP1",139, 0)
	12593	I RCSORT= 3 D
	12594	"RTN","RCT CSP1",140, 0)
	12595	.D CSRPRT H3^RCTCSP1
	12596	"RTN","RCT CSP1",141, 0)
	12597	.S RCIEN= "" F S RC IEN=$O(^PR CA(430,"TC SP",RCIEN) ) Q:RCIEN= "" D
	12598	"RTN","RCT CSP1",142, 0)
	12599	..Q:$P(^P RCA(430,RC IEN,15),U) <DTFRM!($P (^PRCA(430 ,RCIEN,15) ,U)>DTTO)
	12600	"RTN","RCT CSP1",143, 0)
	12601	..K LIST, MSG,RCLIST D GETS^DI Q(430,RCIE N_",",".01 ;9;161;169 ;151;11"," IE","LIST"
	12602	,"MSG") S RCLIST=$NA (LIST(430, RCIEN_",") )
	12603	"RTN","RCT CSP1",144, 0)
	12604	..S ^TMP( "RCTCSP1", $J,RCIEN,@ RCLIST@(15 1,"E"))=$$ FMTE^XLFDT (@RCLIST@( 151,"I"),2
	12605	)_U_$E(@RC LIST@(9,"E "),1,19)_U _@RCLIST@( .01,"E")_U _$E(@RCLIS T@(161,"E" ),6,9)_U_$
	12606	J(@RCLIST@ (169,"E"), 8,2)_U_$J( @RCLIST@(1 1,"E"),8,2 )
	12607	"RTN","RCT CSP1",145, 0)
	12608	.S (SDT,N CIEN)="" F S NCIEN= $O(^TMP("R CTCSP1",$J ,NCIEN)) Q :NCIEN="" F S SDT
	12609	=$O(^TMP(" RCTCSP1",$ J,NCIEN,SD T)) Q:SDT= "" D
	12610	"RTN","RCT CSP1",146, 0)
	12611	..I 'EXCE L W !,$P(^ TMP("RCTCS P1",$J,NCI EN,SDT),U) ,?12,$P(^T MP("RCTCSP 1",$J,NCIE
	12612	N,SDT),U,2 ),?34,$P(^ TMP("RCTCS P1",$J,NCI EN,SDT),U, 3),?49
	12613	"RTN","RCT CSP1",147, 0)
	12614	..I 'EXCE L W $P(^TM P("RCTCSP1 ",$J,NCIEN ,SDT),U,4) ,?56,$P(^T MP("RCTCSP 1",$J,NCIE
	12615	N,SDT),U,5 ),?66,$P(^ TMP("RCTCS P1",$J,NCI EN,SDT),U, 6) Q
	12616	"RTN","RCT CSP1",148, 0)
	12617	..I EXCEL W !,^TMP( "RCTCSP1", $J,NCIEN,S DT)
	12618	"RTN","RCT CSP1",149, 0)
	12619	.;S DIC=" ^PRCA(430, ",L=0,L(0) =1,BY(0)=" ^PRCA(430, ""TCSP""," ,BY=151,(F R,TO)="" S
	12620	FLDS="151 ;L12,9;L18 ,.01;R12,1 61;R10,169 ;R9,11;R9" ,DHD="W ?0 D CSRPRTH 3^RCTCSP1"
	12621	"RTN","RCT CSP1",150, 0)
	12622	.;D EN1^D IP
	12623	"RTN","RCT CSP1",151, 0)
	12624	.Q
	12625	"RTN","RCT CSP1",152, 0)
	12626	;K ^TMP(" RCTCSP1",$ J)
	12627	"RTN","RCT CSP1",153, 0)
	12628	Q
	12629	"RTN","RCT CSP1",154, 0)
	12630	;
	12631	"RTN","RCT CSP1",155, 0)
	12632	CSRPRTH1 ; header for cross-ser vicing pri nt report 1
	12633	"RTN","RCT CSP1",156, 0)
	12634	W @IOF
	12635	"RTN","RCT CSP1",157, 0)
	12636	S PAGE=PA GE+1,EXCEL =$G(EXCEL)
	12637	"RTN","RCT CSP1",158, 0)
	12638	I 'EXCEL D Q
	12639	"RTN","RCT CSP1",159, 0)
	12640	.W !,"PAG E "_PAGE,? 16,"BILLS AT CROSS-S ERVICING ( SORTED BY BILL NO.)" ,?68,$$FMT
	12641	E^XLFDT(DT ,2)
	12642	"RTN","RCT CSP1",160, 0)
	12643	.W !,DASH ,!
	12644	"RTN","RCT CSP1",161, 0)
	12645	.W !,"BIL L NO.",?14 ,"DEBTOR", ?35,"SSN", ?41,"ORIG AMT",?52," CS REF DAT E",?65," C
	12646	URR AMT" ; limited SSN to 4 c har - (as per PRCA4 .5315)
	12647	"RTN","RCT CSP1",162, 0)
	12648	.W !,"--- - ---",?14 ,"------", ?35,"---", ?41,"---- ---",?52," -- --- --- -",?65," -
	12649	--- ---",!
	12650	"RTN","RCT CSP1",163, 0)
	12651	;EXCEL FO RMAT
	12652	"RTN","RCT CSP1",164, 0)
	12653	W !,"PAGE "_PAGE_U_ U_"BILLS A T CROSS-SE RVICING (S ORTED BY B ILL NO.)"_ U_U_$$FMTE
	12654	^XLFDT(DT, 2)
	12655	"RTN","RCT CSP1",165, 0)
	12656	W !,"BILL NO."_U_"D EBTOR"_U_" SSN"_U_"OR IG AMT"_U_ "CS REF DA TE"_U_" CU RR AMT" ;
	12657	limited S SN to 4 ch ar - (as p er PRCA4. 5315)
	12658	"RTN","RCT CSP1",166, 0)
	12659	Q
	12660	"RTN","RCT CSP1",167, 0)
	12661	;
	12662	"RTN","RCT CSP1",168, 0)
	12663	CSRPRTH2 ; header for cross-ser vicing pri nt report 2
	12664	"RTN","RCT CSP1",169, 0)
	12665	W @IOF
	12666	"RTN","RCT CSP1",170, 0)
	12667	S PAGE=PA GE+1,EXCEL =$G(EXCEL)
	12668	"RTN","RCT CSP1",171, 0)
	12669	I 'EXCEL D Q
	12670	"RTN","RCT CSP1",172, 0)
	12671	.W !,"PAG E "_PAGE,? 16,"BILLS AT CROSS-S ERVICING ( SORTED BY DEBTOR)",? 68,$$UPPER
	12672	^VALM1($$F MTE^XLFDT( DT,"6Z"))
	12673	"RTN","RCT CSP1",173, 0)
	12674	.W !,DASH ,!
	12675	"RTN","RCT CSP1",174, 0)
	12676	.W !,"DEB TOR",?21," BILL NO.", ?35,"SSN", ?41,"ORIG AMT",?52," CS REF DAT E",?65," C
	12677	URR AMT" ;limited S SN to 4 ch ar - (as p er PRCA4. 5315)
	12678	"RTN","RCT CSP1",175, 0)
	12679	.W !,"--- ---",?21," ---- ---", ?35,"---", ?41,"---- ---",?52," -- --- --- -",?65," -
	12680	--- ---",!
	12681	"RTN","RCT CSP1",176, 0)
	12682	;EXCEL FO RMAT
	12683	"RTN","RCT CSP1",177, 0)
	12684	W !,"PAGE "_PAGE_U_ U_"BILLS A T CROSS-SE RVICING (S ORTED BY D EBTOR)"_U_ U_$$FMTE^X
	12685	LFDT(DT,2)
	12686	"RTN","RCT CSP1",178, 0)
	12687	W !,"DEBT OR"_U_"BIL L NO."_U_" SSN"_U_"OR IG AMT"_U_ "CS REF DA TE"_U_" CU RR AMT" ;
	12688	limited S SN to 4 ch ar - (as p er PRCA4. 5315)
	12689	"RTN","RCT CSP1",179, 0)
	12690	Q
	12691	"RTN","RCT CSP1",180, 0)
	12692	;
	12693	"RTN","RCT CSP1",181, 0)
	12694	CSRPRTH3 ; header for cross-ser vicing pri nt report 3
	12695	"RTN","RCT CSP1",182, 0)
	12696	W @IOF
	12697	"RTN","RCT CSP1",183, 0)
	12698	S PAGE=PA GE+1,EXCEL =$G(EXCEL)
	12699	"RTN","RCT CSP1",184, 0)
	12700	I 'EXCEL D Q
	12701	"RTN","RCT CSP1",185, 0)
	12702	.W !,"PAG E "_PAGE,? 11,"BILLS AT CROSS-S ERVICING ( SORTED BY CS REFERRE D DATE)",?
	12703	68,$$UPPER ^VALM1($$F MTE^XLFDT( DT,"6Z"))
	12704	"RTN","RCT CSP1",186, 0)
	12705	.W !,DASH ,!
	12706	"RTN","RCT CSP1",187, 0)
	12707	.W !,"CS REF DT",?1 2,"DEBTOR" ,?34,"BILL NO.",?49, "SSN",?56, "ORIG AMT" ,?65," CUR
	12708	R AMT" ;l imited SSN to 4 char - (as per PRCA4.5 315)
	12709	"RTN","RCT CSP1",188, 0)
	12710	.W !,"-- --- ----", ?12,"----- -",?34,"-- -- ---",?4 9,"---",?5 6,"---- -- -",?65," -
	12711	--- ---",!
	12712	"RTN","RCT CSP1",189, 0)
	12713	;EXCEL FO RMAT
	12714	"RTN","RCT CSP1",190, 0)
	12715	W !,"PAGE "_PAGE_U_ U_"BILLS A T CROSS-SE RVICING (S ORTED BY C S REFERRED DATE)"_U_
	12716	U_$$FMTE^X LFDT(DT,2)
	12717	"RTN","RCT CSP1",191, 0)
	12718	W !,"CS R EF DATE"_U _"DEBTOR"_ U_"BILL NO ."_U_"SSN" _U_"ORIG A MT"_U_" CU RR AMT" ;
	12719	limited S SN to 4 ch ar - (as p er PRCA4. 5315)
	12720	"RTN","RCT CSP1",192, 0)
	12721	Q
	12722	"RTN","RCT CSP1",193, 0)
	12723	;
	12724	"RTN","RCT CSP1",194, 0)
	12725	CSRCLRT ;c ross-servi cing recal l report, prints sor ted indivi dual bills that make
	12726	up a cros s-servicin g account
	12727	"RTN","RCT CSP1",195, 0)
	12728	N DIC,RCS ORT,PAGE,D ASH,DTOUT, DUOUT,DIRO UT,DHD,FLD S,L,BY,FR, TO,DIS,SSN ,PROMPT,EX
	12729	CEL,RCIEN, NRCIEN,BIL LN
	12730	"RTN","RCT CSP1",196, 0)
	12731	S PAGE=0, DASH="",$P (DASH,"-", 78)="",SSN =0000
	12732	"RTN","RCT CSP1",197, 0)
	12733	W !
	12734	"RTN","RCT CSP1",198, 0)
	12735	K ^TMP("R CTCSP1",$J )
	12736	"RTN","RCT CSP1",199, 0)
	12737	S DIR(0)= "S^1:Bill Number;2:D ebtor Name ",DIR("A") ="Sort by" D ^DIR K DIR
	12738	"RTN","RCT CSP1",200, 0)
	12739	S RCSORT= Y Q:($D(DT OUT)!$D(DU OUT)!$D(DI ROUT))
	12740	"RTN","RCT CSP1",201, 0)
	12741	S DTFRMTO =$$DTFRMTO ^RCTCSP2 Q :'DTFRMTO ;Get date range as per PRCA4 .5315
	12742	"RTN","RCT CSP1",202, 0)
	12743	S (DATE,D TFRM)=$P(D TFRMTO,U,2 )-1,DTTO=$ P(DTFRMTO, U,3),CURDT =0
	12744	"RTN","RCT CSP1",203, 0)
	12745	S EXCEL=0 ,PROMPT="C APTURE Rep ort data t o an Excel Document? ",DIR(0)=" Y",DIR("?"
	12746	)="^D HEXC ^RCTCSJR"
	12747	"RTN","RCT CSP1",204, 0)
	12748	S EXCEL=$ $SELECT^RC TCSJR(PROM PT,"NO") I "01"'[EXC EL S STOP= 1 Q
	12749	"RTN","RCT CSP1",205, 0)
	12750	I EXCEL=1 D EXCMSG^ RCTCSJR ; Display Ex cel displa y message
	12751	"RTN","RCT CSP1",206, 0)
	12752	S %ZIS=" AEQ" D ^%Z IS I POP S STOP=1 Q
	12753	"RTN","RCT CSP1",207, 0)
	12754	I $D(IO(" Q")) D Q ;
	12755	"RTN","RCT CSP1",208, 0)
	12756	.S ZTSAVE ("RCSORT") ="",ZTSAVE ("EXCEL")= ""
	12757	"RTN","RCT CSP1",209, 0)
	12758	.S ZTRTN= "PRTSORT^R CTCSP1",ZT DESC="CROS S-SERVICIN G BILL REP ORT"
	12759	"RTN","RCT CSP1",210, 0)
	12760	.D ^%ZTLO AD,^%ZISC
	12761	"RTN","RCT CSP1",211, 0)
	12762	.Q
	12763	"RTN","RCT CSP1",212, 0)
	12764	PRTSORT ;
	12765	"RTN","RCT CSP1",213, 0)
	12766	I RCSORT= 1 D ; rewrite fo r EXCEL an d faster p rocessing (as per PR
	12767	CA4.5315 )
	12768	"RTN","RCT CSP1",214, 0)
	12769	.D CSRCLH 1^RCTCSP1
	12770	"RTN","RCT CSP1",215, 0)
	12771	.S RCIEN= 0 F S RCI EN=$O(^PRC A(430,"TCS P",RCIEN)) Q:'RCIEN D
	12772	"RTN","RCT CSP1",216, 0)
	12773	..Q:+$P($ G(^RCD(340 ,+$P(^PRCA (430,RCIEN ,0),U,9),7 )),U,2) ;-- Need to fix thi
	12774	s screen
	12775	"RTN","RCT CSP1",217, 0)
	12776	..Q:$P(^P RCA(430,RC IEN,15),U) <DTFRM!($P (^PRCA(430 ,RCIEN,15) ,U)>DTTO)
	12777	"RTN","RCT CSP1",218, 0)
	12778	..K RCLIS T,LIST,MSG D GETS^DI Q(430,RCIE N_",",".01 ;9;155;151 ;153;154", "IE","LIST
	12779	","MSG") Q :$D(LIST)< 10 S RCLI ST=$NA(LIS T(430,RCIE N_","))
	12780	"RTN","RCT CSP1",219, 0)
	12781	..S DEBTO R=$P($G(^P RCA(430,RC IEN,0)),U, 9),SSN=$E( $$SSN^RCFN 01($P(^RCD (340,DEBTO
	12782	R,0),"^")) ,6,9)
	12783	"RTN","RCT CSP1",220, 0)
	12784	..S ^TMP( "RCTCSP1", $J,RCIEN,@ RCLIST@(.0 1,"I"))=@R CLIST@(.01 ,"E")_U_$E (@RCLIST@(
	12785	9,"E"),1,1 9)_U_SSN_U _$J(@RCLIS T@(155,"E" ),10,2)_U_ $$FMTE^XLF DT(@RCLIST @(153,"I")
	12786	,2)_U_@RCL IST@(154," I")_"-"_@R CLIST@(154 ,"E")
	12787	"RTN","RCT CSP1",221, 0)
	12788	.S (BILLN ,NRCIEN)=" " F S NCI EN=$O(^TMP ("RCTCSP1" ,$J,NRCIEN )) Q:NRCIE N="" F S
	12789	BILLN=$O( ^TMP("RCTC SP1",$J,NR CIEN,BILLN )) Q:BILLN ="" D
	12790	"RTN","RCT CSP1",222, 0)
	12791	..I 'EXCE L W !,$P(^ TMP("RCTCS P1",$J,NRC IEN,BILLN) ,U),?13,$P (^TMP("RCT CSP1",$J,N
	12792	RCIEN,BILL N),U,2),?3 4,$P(^TMP( "RCTCSP1", $J,NRCIEN, BILLN),U,3 ),?38
	12793	"RTN","RCT CSP1",223, 0)
	12794	..I 'EXCE L W $P(^TM P("RCTCSP1 ",$J,NRCIE N,BILLN),U ,4),?50,$P (^TMP("RCT CSP1",$J,N
	12795	RCIEN,BILL N),U,5),?6 2,$E($P(^T MP("RCTCSP 1",$J,NRCI EN,BILLN), U,6),1,18) Q
	12796	"RTN","RCT CSP1",224, 0)
	12797	..I EXCEL W !,^TMP( "RCTCSP1", $J,NRCIEN, BILLN)
	12798	"RTN","RCT CSP1",225, 0)
	12799	. I '$D(^ TMP("RCTCS P1",$J)) W !,"No rec ords found ",!!
	12800	"RTN","RCT CSP1",226, 0)
	12801	.; Change d the date field in [PRCA TCSP RECALLB] and [PRCA TCSP RECAL LD] -from
	12802	TCSP RECAL L EFF. DAT E;L8 to NU MDATE(TCSP RECALL EF F. DATE) -
	12803	"RTN","RCT CSP1",227, 0)
	12804	.;S DIC=" ^PRCA(430, ",DIS(0)=" I ($P($G(^ PRCA(430,D 0,15)),U,2 )>0)!((+$P ($G(^RCD(3
	12805	40,+$P(^PR CA(430,D0, 0),U,9),7) ),U,2))&$D (^PRCA(430 ,""TCSP"", D0)))",L=0 ,BY=.01,(F
	12806	R,TO)=""
	12807	"RTN","RCT CSP1",228, 0)
	12808	.;S FLDS= "[PRCA TCS P RECALLB] ",DHD="W ? 0 D CSRCLH 1^RCTCSP1"
	12809	"RTN","RCT CSP1",229, 0)
	12810	.;D EN1^D IP
	12811	"RTN","RCT CSP1",230, 0)
	12812	.Q
	12813	"RTN","RCT CSP1",231, 0)
	12814	;
	12815	"RTN","RCT CSP1",232, 0)
	12816	I RCSORT= 2 D ; rewrite for EXCEL and faster processin g (as per
	12817	PRCA4.53 15)
	12818	"RTN","RCT CSP1",233, 0)
	12819	.D CSRCLH 2^RCTCSP1
	12820	"RTN","RCT CSP1",234, 0)
	12821	.S RCIEN= 0 F S RCI EN=$O(^PRC A(430,"TCS P",RCIEN)) Q:'RCIEN D
	12822	"RTN","RCT CSP1",235, 0)
	12823	..Q:+$P($ G(^RCD(340 ,+$P(^PRCA (430,RCIEN ,0),U,9),7 )),U,2) ; -- Need t o fix this
	12824	screen
	12825	"RTN","RCT CSP1",236, 0)
	12826	..Q:$P(^P RCA(430,RC IEN,15),U) <DTFRM!($P (^PRCA(430 ,RCIEN,15) ,U)>DTTO)
	12827	"RTN","RCT CSP1",237, 0)
	12828	..K RCLIS T,LIST,MSG D GETS^DI Q(430,RCIE N_",",".01 ;9;155;151 ;153;154", "IE","LIST
	12829	","MSG") Q :$D(LIST)< 10 S RCLI ST=$NA(LIS T(430,RCIE N_","))
	12830	"RTN","RCT CSP1",238, 0)
	12831	..S DEBTO R=$P($G(^P RCA(430,RC IEN,0)),U, 9),SSN=$E( $$SSN^RCFN 01($P(^RCD (340,DEBTO
	12832	R,0),"^")) ,6,9)
	12833	"RTN","RCT CSP1",239, 0)
	12834	..S ^TMP( "RCTCSP1", $J,RCIEN,@ RCLIST@(9, "E"))=$E(@ RCLIST@(9, "E"),1,19) _U_$E(@RCL
	12835	IST@(.01," E"),1,19)_ U_SSN_U_$J (@RCLIST@( 155,"E"),1 0,2)_U_$$F MTE^XLFDT( @RCLIST@(1
	12836	53,"I"),2) _U_@RCLIST @(154,"I") _"-"_@RCLI ST@(154,"E ")
	12837	"RTN","RCT CSP1",240, 0)
	12838	.S (DBTR, NRCIEN)="" F S NRCI EN=$O(^TMP ("RCTCSP1" ,$J,NRCIEN )) Q:NRCIE N="" F S
	12839	DBTR=$O(^ TMP("RCTCS P1",$J,NRC IEN,DBTR)) Q:DBTR="" D
	12840	"RTN","RCT CSP1",241, 0)
	12841	..I 'EXCE L W !,$P(^ TMP("RCTCS P1",$J,NRC IEN,DBTR), U),?20,$P( ^TMP("RCTC SP1",$J,NR
	12842	CIEN,DBTR) ,U,2),?32, $P(^TMP("R CTCSP1",$J ,NRCIEN,DB TR),U,3),? 36
	12843	"RTN","RCT CSP1",242, 0)
	12844	..I 'EXCE L W $P(^TM P("RCTCSP1 ",$J,NRCIE N,DBTR),U, 4),?50,$P( ^TMP("RCTC SP1",$J,NR
	12845	CIEN,DBTR) ,U,5),?62, $E($P(^TMP ("RCTCSP1" ,$J,NRCIEN ,DBTR),U,6 ),1,18) Q
	12846	"RTN","RCT CSP1",243, 0)
	12847	..I EXCEL W !,^TMP( "RCTCSP1", $J,NRCIEN, DBTR)
	12848	"RTN","RCT CSP1",244, 0)
	12849	.I '$D(^T MP("RCTCSP 1",$J)) W !,"No reco rds found" ,!!
	12850	"RTN","RCT CSP1",245, 0)
	12851	.;S DIC=" ^PRCA(430, ",DIS(0)=" I ($P($G(^ PRCA(430,D 0,15)),U,2 )>0)!((+$P ($G(^RCD(3
	12852	40,+$P(^PR CA(430,D0, 0),U,9),7) ),U,2))&$D (^PRCA(430 ,""TCSP"", D0)))",L=0 ,BY=.01,(F
	12853	R,TO)=""
	12854	"RTN","RCT CSP1",246, 0)
	12855	.;S DIC=" ^PRCA(430, ",DIS(0)=" I ($P($G(^ PRCA(430,D 0,15)),U,2 )>0)!((+$P ($G(^RCD(3
	12856	40,+$P(^PR CA(430,D0, 0),U,9),7) ),U,2))&$D (^PRCA(430 ,""TCSP"", D0)))",L=0 ,BY=9,(FR,
	12857	TO)=""
	12858	"RTN","RCT CSP1",247, 0)
	12859	.;S FLDS= "[PRCA TCS P RECALLD] ",DHD="W ? 0 D CSRCLH 2^RCTCSP1"
	12860	"RTN","RCT CSP1",248, 0)
	12861	.;D EN1^D IP
	12862	"RTN","RCT CSP1",249, 0)
	12863	.Q
	12864	"RTN","RCT CSP1",250, 0)
	12865	K ^TMP("R CTCSP1",$J )
	12866	"RTN","RCT CSP1",251, 0)
	12867	I $E(IOST ,1,2)="C-" ,'EXCEL R !!,"END OF REPORT... PRESS RETU RN TO CONT INUE",X:DT
	12868	IME W @IOF
	12869	"RTN","RCT CSP1",252, 0)
	12870	D:'$D(ZTQ UEUED) ^%Z ISC
	12871	"RTN","RCT CSP1",253, 0)
	12872	S:$D(ZTQU EUED) ZTRE Q="@"
	12873	"RTN","RCT CSP1",254, 0)
	12874	K IOP,%ZI S,ZTQUEUED
	12875	"RTN","RCT CSP1",255, 0)
	12876	Q
	12877	"RTN","RCT CSP1",256, 0)
	12878	;
	12879	"RTN","RCT CSP1",257, 0)
	12880	CSRCLH1 ;h eader for cross-serv icing reca ll report 1
	12881	"RTN","RCT CSP1",258, 0)
	12882	W @IOF
	12883	"RTN","RCT CSP1",259, 0)
	12884	S PAGE=PA GE+1
	12885	"RTN","RCT CSP1",260, 0)
	12886	I 'EXCEL D Q
	12887	"RTN","RCT CSP1",261, 0)
	12888	.W !,"PAG E "_PAGE,? 12,"CROSS- SERVICING RECALL REP ORT (SORTE D BY BILL NUMBER)",?
	12889	68,$$FMTE^ XLFDT(DT,2 )
	12890	"RTN","RCT CSP1",262, 0)
	12891	.W !,DASH ,!
	12892	"RTN","RCT CSP1",263, 0)
	12893	.W !,"BIL L NO.",?13 ,"DEBTOR", ?34,"SSN", ?40,"RCLL AMT",?50," RECALL DT" ,?62,"RECA
	12894	LL RSN"
	12895	"RTN","RCT CSP1",264, 0)
	12896	.W !,"--- - ---",?13 ,"------", ?34,"---", ?38,"---- ---",?50," ------ --" ,?62,"----
	12897	-- ---",!
	12898	"RTN","RCT CSP1",265, 0)
	12899	;EXCEL FO RMAT
	12900	"RTN","RCT CSP1",266, 0)
	12901	W !,"PAGE "_PAGE_U_ U_"CROSS-S ERVICING R ECALL REPO RT (SORTED BY BILL N UMBER)"_U_
	12902	U_$$FMTE^X LFDT(DT,2)
	12903	"RTN","RCT CSP1",267, 0)
	12904	;W !,DASH ,!
	12905	"RTN","RCT CSP1",268, 0)
	12906	W !,"BILL NO."_U_"D EBTOR"_U_" SSN"_U_"RC LL AMT"_U_ "RECALL DT "_U_"RECAL L RSN"
	12907	"RTN","RCT CSP1",269, 0)
	12908	Q
	12909	"RTN","RCT CSP1",270, 0)
	12910	;
	12911	"RTN","RCT CSP1",271, 0)
	12912	CSRCLH2 ;h eader for cross-serv icing reca ll report 2
	12913	"RTN","RCT CSP1",272, 0)
	12914	I 'EXCEL W @IOF
	12915	"RTN","RCT CSP1",273, 0)
	12916	S PAGE=PA GE+1
	12917	"RTN","RCT CSP1",274, 0)
	12918	I 'EXCEL D Q
	12919	"RTN","RCT CSP1",275, 0)
	12920	.W !,"PAG E "_PAGE,? 14,"CROSS- SERVICING RECALL REP ORT (SORTE D BY DEBTO R)",?68,$$
	12921	FMTE^XLFDT (DT,2)
	12922	"RTN","RCT CSP1",276, 0)
	12923	.W !,DASH ,!
	12924	"RTN","RCT CSP1",277, 0)
	12925	.W !,"DEB TOR",?20," BILL NO.", ?32,"SSN", ?40,"RCLL AMT",?52," RECALL DT" ,?63,"RECA
	12926	LL RSN"
	12927	"RTN","RCT CSP1",278, 0)
	12928	.W !,"--- ---",?20," --------", ?32,"---", ?40,"---- ---",?52," ------ --" ,?63,"----
	12929	-- ---",!
	12930	"RTN","RCT CSP1",279, 0)
	12931	;EXCEL FO RMAT
	12932	"RTN","RCT CSP1",280, 0)
	12933	W !,"PAGE "_PAGE_U_ U_"CROSS-S ERVICING R ECALL REPO RT (SORTED BY DEBTOR )"_U_U_$$F
	12934	MTE^XLFDT( DT,2)
	12935	"RTN","RCT CSP1",281, 0)
	12936	W !,"DEBT OR"_U_"BIL L NO."_U_" SSN"_U_"RC LL AMT"_U_ "RECALL DT "_U_"RECAL L RSN"
	12937	"RTN","RCT CSP1",282, 0)
	12938	Q
	12939	"RTN","RCT CSP1",283, 0)
	12940	;
	12941	"RTN","RCT CSP1",284, 0)
	12942	HEADER ;
	12943	"RTN","RCT CSP1",285, 0)
	12944	;incremen t batch se quence num ber, build new heade r
	12945	"RTN","RCT CSP1",286, 0)
	12946	N RCMSG
	12947	"RTN","RCT CSP1",287, 0)
	12948	S SEQ=SEQ +1
	12949	"RTN","RCT CSP1",288, 0)
	12950	S CNTLID= $$JD()_$$R JZF(SEQ,4)
	12951	"RTN","RCT CSP1",289, 0)
	12952	K ^XTMP(" RCTCSPD",$ J,ACTION," BUILD",SEQ )
	12953	"RTN","RCT CSP1",290, 0)
	12954	;header i s record t ype H
	12955	"RTN","RCT CSP1",291, 0)
	12956	S RCMSG=" H"_CNTLID_ $$BLANK(14 )_"3636001 200"
	12957	"RTN","RCT CSP1",292, 0)
	12958	S RCMSG=R CMSG_$$BLA NK(450-$L( RCMSG))
	12959	"RTN","RCT CSP1",293, 0)
	12960	S REC=REC +1
	12961	"RTN","RCT CSP1",294, 0)
	12962	S ^XTMP(" RCTCSPD",$ J,SEQ,"BUI LD",REC)=$ E(RCMSG,1, 225)_$C(94 )
	12963	"RTN","RCT CSP1",295, 0)
	12964	S REC=REC +1
	12965	"RTN","RCT CSP1",296, 0)
	12966	S ^XTMP(" RCTCSPD",$ J,SEQ,"BUI LD",REC)=$ E(RCMSG,22 6,999)_$C( 126)
	12967	"RTN","RCT CSP1",297, 0)
	12968	Q
	12969	"RTN","RCT CSP1",298, 0)
	12970	;
	12971	"RTN","RCT CSP1",299, 0)
	12972	TRAILER ;
	12973	"RTN","RCT CSP1",300, 0)
	12974	;trailer is type Z record
	12975	"RTN","RCT CSP1",301, 0)
	12976	I REC=0 K ^XTMP("RC TCSPD",$J, SEQ,"BUILD ") Q ;del ete batch if no reco rds proces
	12977	sed
	12978	"RTN","RCT CSP1",302, 0)
	12979	N RCMSG
	12980	"RTN","RCT CSP1",303, 0)
	12981	S CNTLID= $$JD()_$$R JZF(SEQ,4)
	12982	"RTN","RCT CSP1",304, 0)
	12983	S RCMSG=" Z"_$$RJZF( RECC,8)_$$ AMOUNT(AMO UNT/100)_C NTLID_$$BL ANK(14)_"3 636001200"
	12984	"RTN","RCT CSP1",305, 0)
	12985	S RCMSG=R CMSG_$$BLA NK(450-$L( RCMSG))
	12986	"RTN","RCT CSP1",306, 0)
	12987	S REC=REC +1
	12988	"RTN","RCT CSP1",307, 0)
	12989	S ^XTMP(" RCTCSPD",$ J,SEQ,"BUI LD",REC)=$ E(RCMSG,1, 225)_$C(94 )
	12990	"RTN","RCT CSP1",308, 0)
	12991	S REC=REC +1
	12992	"RTN","RCT CSP1",309, 0)
	12993	S ^XTMP(" RCTCSPD",$ J,SEQ,"BUI LD",REC)=$ E(RCMSG,22 6,999)_$C( 126)
	12994	"RTN","RCT CSP1",310, 0)
	12995	S REC=0,R ECC=0,AMOU NT=0
	12996	"RTN","RCT CSP1",311, 0)
	12997	Q
	12998	"RTN","RCT CSP1",312, 0)
	12999	;
	13000	"RTN","RCT CSP1",313, 0)
	13001	REC5B ;
	13002	"RTN","RCT CSP1",314, 0)
	13003	; trnnum trans action num ber file # 433 pass i n
	13004	"RTN","RCT CSP1",315, 0)
	13005	; trntyp trans action typ e pointer to 430.3
	13006	"RTN","RCT CSP1",316, 0)
	13007	; trntyp a aia t ransaction type (ai o: dmc age ncy intern al offset, abal: dec
	13008	rease adju stment)
	13009	"RTN","RCT CSP1",317, 0)
	13010	N REC,KNU M,DEBTNR,D EBTORNB,TA MOUNT,TAMT PBAL,TAMTI BAL,TAMTAB AL,TAMTFBA L,TAMTCBAL
	13011	,AMTRFRRD, TRNTYP,TRN TYPA,TRANS NB
	13012	"RTN","RCT CSP1",318, 0)
	13013	N AMTPBAL ,AMTIBAL,A MTABAL,AMT FBAL,AMTCB AL,TRN3,TR NNUME
	13014	"RTN","RCT CSP1",319, 0)
	13015	S TRNTYPA ="AIO"
	13016	"RTN","RCT CSP1",320, 0)
	13017	S REC="C5 B"_ACTION_ "363600120 0"_"DM1D " _"L"
	13018	"RTN","RCT CSP1",321, 0)
	13019	S KNUM=$P ($P(B0,U,1 ),"-",2)
	13020	"RTN","RCT CSP1",322, 0)
	13021	S DEBTNR= $E(SITE,1, 3)_$$RJZF( KNUM,7)_$T R($J(BILL, 20)," ",0) ,REC=REC_D EBTNR
	13022	"RTN","RCT CSP1",323, 0)
	13023	S DEBTORN B=$E(SITE, 1,3)_$TR($ J(DEBTOR,1 2)," ",0)
	13024	"RTN","RCT CSP1",324, 0)
	13025	S REC=REC _DEBTORNB
	13026	"RTN","RCT CSP1",325, 0)
	13027	S TRNTYP= $P($G(^PRC A(433,TRNN UM,1)),U,2 ) I TRNTYP =35 S TRNT YPA="ABAL"
	13028	"RTN","RCT CSP1",326, 0)
	13029	S REC=REC _$$LJSF(TR NTYPA,9)
	13030	"RTN","RCT CSP1",327, 0)
	13031	S TRNNUME =$$RJZF(TR NNUM,10)
	13032	"RTN","RCT CSP1",328, 0)
	13033	S TRNNUME =$E(TRNNUM E,5,10) ;m ax is 9999 99
	13034	"RTN","RCT CSP1",329, 0)
	13035	I TRNNUME ="000000" S TRNNUME= "000001" ; min is 1
	13036	"RTN","RCT CSP1",330, 0)
	13037	S REC=REC _$$RJZF(TR NNUME,10)
	13038	"RTN","RCT CSP1",331, 0)
	13039	S REC=REC _$$DATE8(D T)
	13040	"RTN","RCT CSP1",332, 0)
	13041	S TRANSNB =$E(SITE,1 ,3)_$TR($J (TRNNUM,12 )," ",0)
	13042	"RTN","RCT CSP1",333, 0)
	13043	S REC=REC _TRANSNB
	13044	"RTN","RCT CSP1",334, 0)
	13045	S REC=REC _$$BLANK(9 )
	13046	"RTN","RCT CSP1",335, 0)
	13047	S TRN3=$G (^PRCA(433 ,TRNNUM,3) )
	13048	"RTN","RCT CSP1",336, 0)
	13049	S TAMTPBA L=$P(TRN3, U,1) ;tran saction pr inciple ba lance
	13050	"RTN","RCT CSP1",337, 0)
	13051	S TAMTIBA L=$P(TRN3, U,2) ;tran saction in terest bal ance
	13052	"RTN","RCT CSP1",338, 0)
	13053	S TAMTABA L=$P(TRN3, U,3) ;tran saction ad ministrati ve balance
	13054	"RTN","RCT CSP1",339, 0)
	13055	S TAMTFBA L=$P(TRN3, U,4) ;tran saction ma rshal fee
	13056	"RTN","RCT CSP1",340, 0)
	13057	S TAMTCBA L=$P(TRN3, U,5) ;tran saction co urt cost
	13058	"RTN","RCT CSP1",341, 0)
	13059	I (TAMTPB AL+TAMTIBA L+TAMTABAL +TAMTFBAL+ TAMTCBAL)= 0 S TAMTPB AL=TRNAMT
	13060	"RTN","RCT CSP1",342, 0)
	13061	S TAMOUNT =$S(+TAMTP BAL:"-",1: "0")_$E($$ AMOUNT(TAM TPBAL),2,1 4)
	13062	"RTN","RCT CSP1",343, 0)
	13063	S TAMOUNT =TAMOUNT_$ S(+TAMTIBA L:"-",1:"0 ")_$E($$AM OUNT(TAMTI BAL),2,14)
	13064	"RTN","RCT CSP1",344, 0)
	13065	S TAMOUNT =TAMOUNT_$ S(+TAMTABA L:"-",1:"0 ")_$E($$AM OUNT(TAMTA BAL),2,14)
	13066	"RTN","RCT CSP1",345, 0)
	13067	S TAMOUNT =TAMOUNT_$ S(+(TAMTFB AL+TAMTCBA L):"-",1:" 0")_$E($$A MOUNT(TAMT FBAL+TAMTC
	13068	BAL),2,14)
	13069	"RTN","RCT CSP1",346, 0)
	13070	S REC=REC _TAMOUNT
	13071	"RTN","RCT CSP1",347, 0)
	13072	S REC=REC _"-"_$E($$ AMOUNT(TRN AMT),2,14)
	13073	"RTN","RCT CSP1",348, 0)
	13074	S REC=REC _$$BLANK(4 50-$L(REC) )
	13075	"RTN","RCT CSP1",349, 0)
	13076	S AMTPBAL =$P(B7,U,1 ) ;princip le balance
	13077	"RTN","RCT CSP1",350, 0)
	13078	S AMTIBAL =$P(B7,U,2 ) ;interes t balance
	13079	"RTN","RCT CSP1",351, 0)
	13080	S AMTABAL =$P(B7,U,3 ) ;adminis trative ba lance
	13081	"RTN","RCT CSP1",352, 0)
	13082	S AMTFBAL =$P(B7,U,4 ) ;marshal fee
	13083	"RTN","RCT CSP1",353, 0)
	13084	S AMTCBAL =$P(B7,U,5 ) ;court c ost
	13085	"RTN","RCT CSP1",354, 0)
	13086	S AMTRFRR D=AMTPBAL+ AMTIBAL+AM TABAL+AMTF BAL+AMTCBA L
	13087	"RTN","RCT CSP1",355, 0)
	13088	I ACTION= "U" S $P(^ PRCA(430,B ILL,16),U, 10)=AMTRFR RD
	13089	"RTN","RCT CSP1",356, 0)
	13090	S ^XTMP(" RCTCSPD",$ J,BILL,ACT ION,"5B",T RNNUM)=REC
	13091	"RTN","RCT CSP1",357, 0)
	13092	S ^XTMP(" RCTCSPD",$ J,"BILL",A CTION,BILL )=$$TAXID( DEBTOR)_"^ -"_+$E(REC ,174,184)_
	13093	"."_$E(REC ,185,186)
	13094	"RTN","RCT CSP1",358, 0)
	13095	Q
	13096	"RTN","RCT CSP1",359, 0)
	13097	;
	13098	"RTN","RCT CSP1",360, 0)
	13099	DATE8(X) ; changes fi leman date into 8 di git date y yyymmdd
	13100	"RTN","RCT CSP1",361, 0)
	13101	I +X S X= X+17000000
	13102	"RTN","RCT CSP1",362, 0)
	13103	S X=$E(X, 1,8)
	13104	"RTN","RCT CSP1",363, 0)
	13105	Q X
	13106	"RTN","RCT CSP1",364, 0)
	13107	;
	13108	"RTN","RCT CSP1",365, 0)
	13109	AMOUNT(X) ;changes a mount to z ero filled , right ju stified
	13110	"RTN","RCT CSP1",366, 0)
	13111	S:X<0 X=- X
	13112	"RTN","RCT CSP1",367, 0)
	13113	S X=$TR($ J(X,0,2)," .")
	13114	"RTN","RCT CSP1",368, 0)
	13115	S X=$E("0 0000000000 0",1,14-$L (X))_X
	13116	"RTN","RCT CSP1",369, 0)
	13117	Q X
	13118	"RTN","RCT CSP1",370, 0)
	13119	;
	13120	"RTN","RCT CSP1",371, 0)
	13121	BLANK(X) ; returns 'x ' blank sp aces
	13122	"RTN","RCT CSP1",372, 0)
	13123	N BLANK
	13124	"RTN","RCT CSP1",373, 0)
	13125	S BLANK=" ",$P(BLANK ," ",X+1)= ""
	13126	"RTN","RCT CSP1",374, 0)
	13127	Q BLANK
	13128	"RTN","RCT CSP1",375, 0)
	13129	;
	13130	"RTN","RCT CSP1",376, 0)
	13131	RJZF(X,Y) ;right jus tify zero fill width Y
	13132	"RTN","RCT CSP1",377, 0)
	13133	S X=$E("0 0000000000 0",1,Y-$L( X))_X
	13134	"RTN","RCT CSP1",378, 0)
	13135	Q X
	13136	"RTN","RCT CSP1",379, 0)
	13137	;
	13138	"RTN","RCT CSP1",380, 0)
	13139	LJSF(X,Y) ;left just ified spac e filled
	13140	"RTN","RCT CSP1",381, 0)
	13141	S X=$E(X, 1,Y)
	13142	"RTN","RCT CSP1",382, 0)
	13143	S X=X_$$B LANK(Y-$L( X))
	13144	"RTN","RCT CSP1",383, 0)
	13145	Q X
	13146	"RTN","RCT CSP1",384, 0)
	13147	;
	13148	"RTN","RCT CSP1",385, 0)
	13149	TAXID(DEBT OR) ;compu tes TAXID to place o n document s
	13150	"RTN","RCT CSP1",386, 0)
	13151	N TAXID,D IC,DA,DR,D IQ
	13152	"RTN","RCT CSP1",387, 0)
	13153	S TAXID=$ $SSN^RCFN0 1(DEBTOR)
	13154	"RTN","RCT CSP1",388, 0)
	13155	S TAXID=$ $LJSF(TAXI D,9)
	13156	"RTN","RCT CSP1",389, 0)
	13157	Q TAXID
	13158	"RTN","RCT CSP1",390, 0)
	13159	;
	13160	"RTN","RCT CSP1",391, 0)
	13161	JD() ; ret urns today 's Julian date YDOY
	13162	"RTN","RCT CSP1",392, 0)
	13163	N XMDDD,X MNOW,XMDT
	13164	"RTN","RCT CSP1",393, 0)
	13165	S XMNOW=$ $NOW^XLFDT
	13166	"RTN","RCT CSP1",394, 0)
	13167	S XMDT=$E (XMNOW,1,7 )
	13168	"RTN","RCT CSP1",395, 0)
	13169	S XMDDD=$ $RJ^XLFSTR ($$FMDIFF^ XLFDT(XMDT ,$E(XMDT,1 ,3)_"0101" ,1)+1,3,"0 ")
	13170	"RTN","RCT CSP1",396, 0)
	13171	Q $E(DT,3 )_XMDDD
	13172	"RTN","RCT CSP1",397, 0)
	13173	;
	13174	"RTN","RCT CSP1",398, 0)
	13175	ADDR(RCDFN ) ; return s patient file addre ss
	13176	"RTN","RCT CSP1",399, 0)
	13177	N DFN,ADD RCS,STATEI EN,STATEAB ,VAPA
	13178	"RTN","RCT CSP1",400, 0)
	13179	S DFN=RCD FN
	13180	"RTN","RCT CSP1",401, 0)
	13181	D ADD^VAD PT
	13182	"RTN","RCT CSP1",402, 0)
	13183	S STATEIE N=+VAPA(5) ,STATEAB=$ $GET1^DIQ( 5,STATEIEN ,1)
	13184	"RTN","RCT CSP1",403, 0)
	13185	S ADDRCS= VAPA(1)_U_ VAPA(2)_U_ VAPA(4)_U_ STATEAB_U_ VAPA(6)_U_ VAPA(8)_U_ +VAPA(25)
	13186	"RTN","RCT CSP1",404, 0)
	13187	I $L(DEBT OR1)>0 I $ P(DEBTOR1, U,1,5)'?1" ^"."^" D
	13188	"RTN","RCT CSP1",405, 0)
	13189	.N ADDR34 0
	13190	"RTN","RCT CSP1",406, 0)
	13191	.S ADDR34 0=$P($$DAD D^RCAMADD( DEBTOR),U, 1,7)_"^"_1
	13192	"RTN","RCT CSP1",407, 0)
	13193	.S ADDR34 0=$P(ADDR3 40,U,1,2)_ "^"_$P(ADD R340,U,4,9 9)
	13194	"RTN","RCT CSP1",408, 0)
	13195	.I $P(ADD R340,U,6)= "" S $P(AD DR340,U,6) =$P(ADDRCS ,U,6)
	13196	"RTN","RCT CSP1",409, 0)
	13197	.S ADDRCS =ADDR340
	13198	"RTN","RCT CSP1",410, 0)
	13199	Q ADDRCS
	13200	"RTN","RCT CSP1",411, 0)
	13201	;
	13202	"RTN","RCT CSP1",412, 0)
	13203	DEM(RCDFN) ; returns patient f ile gender and dob
	13204	"RTN","RCT CSP1",413, 0)
	13205	N DFN,VAD M
	13206	"RTN","RCT CSP1",414, 0)
	13207	S DFN=RCD FN
	13208	"RTN","RCT CSP1",415, 0)
	13209	D DEM^VAD PT
	13210	"RTN","RCT CSP1",416, 0)
	13211	; return string s ex:m/f ^ d ob: yyyymm dd ^ ssn ^ deceased
	13212	"RTN","RCT CSP1",417, 0)
	13213	Q $P(VADM (5),U,1)_U _$P(VADM(3 ),U,1)_U_$ P(VADM(2), U,1)_U_VAD M(6)
	13214	"RTN","RCT CSP1",418, 0)
	13215	;
	13216	"RTN","RCT CSP1",419, 0)
	13217	COUNTRY(Z) ;
	13218	"RTN","RCT CSP1",420, 0)
	13219	N PRCACC
	13220	"RTN","RCT CSP1",421, 0)
	13221	;get trea sury count ry code
	13222	"RTN","RCT CSP1",422, 0)
	13223	I Z=1 S P RCACC="US" G COUNTRY Q
	13224	"RTN","RCT CSP1",423, 0)
	13225	I Z="" S PRCACC="US " G COUNTR YQ
	13226	"RTN","RCT CSP1",424, 0)
	13227	S PRCACC= $S(Z=4:"AF ",Z=5:"AL" ,Z=7:"DZ", Z=8:"AD",Z =9:"AO",Z= 180:"AI",Z =10:"AG",Z
	13228	=12:"AR",Z =18:"AM",Z =151:"AW", Z=13:"AU", Z=14:"AT", Z=11:"AZ", Z=15:"BS", Z=16:"BH",
	13229	Z=17:"BD", 1:" ") G: PRCACC'=" " COUNTRY Q
	13230	"RTN","RCT CSP1",425, 0)
	13231	S PRCACC= $S(Z=19:"B B",Z=36:"B Y",Z=20:"B E",Z=28:"B Z",Z=61:"B J",Z=21:"B M",Z=22:"B
	13232	T",Z=23:"B O",Z=24:"B A",Z=25:"B W",Z=27:"B R",Z=29:"I O",Z=32:"B N",Z=33:"B G",Z=223:"
	13233	Faso",Z=35 :"BI",1:" ") G:PRCA CC'=" " C OUNTRYQ
	13234	"RTN","RCT CSP1",426, 0)
	13235	S PRCACC= $S(Z=37:"K H",Z=38:"C M",Z=39:"C A",Z=40:"C V",Z=41:"K Y",Z=42:"C F",Z=44:"T
	13236	D",Z=45:"C L",Z=46:"C N",Z=50:"C O",Z=51:"K M",Z=53:"C G",Z=54:"C D",Z=55:"C K",Z=56:"C
	13237	R",Z=109:" CI",1:" " ) G:PRCACC '=" " COU NTRYQ
	13238	"RTN","RCT CSP1",427, 0)
	13239	S PRCACC= $S(Z=57:"H R",Z=58:"C U",Z=59:"C Y",Z=60:"C Z",Z=115:" KP",Z=62:" DK",Z=80:"
	13240	DJ",Z=63:" DM",Z=64:" DO",Z=172: "TP",Z=65: "EC",Z=220 :"EG",Z=66 :"SV",Z=67 :"GQ",Z=69
	13241	:"ER",Z=70 :"EE",1:" ") G:PRCA CC'=" " C OUNTRYQ
	13242	"RTN","RCT CSP1",428, 0)
	13243	S PRCACC= $S(Z=68:"E T",Z=72:"F K",Z=71:"F O",Z=74:"F J",Z=75:"F I",Z=76:"F R",Z=77:"G
	13244	F",Z=78:"P F",Z=79:"T F",Z=81:"G A",Z=83:"G M",Z=82:"G E",Z=84:"D E",Z=85:"G H",Z=86:"G
	13245	I",Z=221:" GB",1:" " ) G:PRCACC '=" " COU NTRYQ
	13246	"RTN","RCT CSP1",429, 0)
	13247	S PRCACC= $S(Z=88:"G R",Z=89:"G L",Z=90:"G D",Z=91:"G P",Z=92:"G T",Z=93:"G N",Z=171:"
	13248	GW",Z=94:" GY",Z=95:" HT",Z=98:" HN",Z=99:" HK",Z=100: "HU",Z=101 :"IS",Z=10 2:"IN",Z=1
	13249	03:"ID",1: " ") G:PR CACC'=" " COUNTRYQ
	13250	"RTN","RCT CSP1",430, 0)
	13251	S PRCACC= $S(Z=105:" IQ",Z=106: "IE",Z=107 :"IL",Z=10 8:"IT",Z=1 10:"JM",Z= 111:"JP",Z
	13252	=113:"JO", Z=112:"KZ" ,Z=114:"KE ",Z=87:"KI ",Z=116:"K R",Z=117:" KW",Z=118: "KG",Z=119
	13253	:"LA",Z=12 2:"LV",1:" ") G:PRC ACC'=" " COUNTRYQ
	13254	"RTN","RCT CSP1",431, 0)
	13255	S PRCACC= $S(Z=120:" LB",Z=121: "LS",Z=123 :"LR",Z=12 4:"LY",Z=1 25:"LI",Z= 126:"LT",Z
	13256	=127:"LU", Z=128:"MO" ,Z=129:"MG ",Z=130:"M W",Z=131:" MY",Z=132: "MV",Z=133 :"ML",Z=13
	13257	4:"MT",1:" ") G:PRC ACC'=" " COUNTRYQ
	13258	"RTN","RCT CSP1",432, 0)
	13259	S PRCACC= $S(Z=999:" MH",Z=135: "MQ",Z=136 :"MR",Z=13 7:"MU",Z=5 2:"YT",Z=1 38:"MX",Z=
	13260	161:"FM",Z =141:"MD", Z=139:"MC" ,Z=140:"MN ",Z=142:"M S",Z=143:" MA",Z=144: "MZ",Z=34:
	13261	"MM",Z=146 :"NA",1:" ") G:PRCA CC'=" " C OUNTRYQ
	13262	"RTN","RCT CSP1",433, 0)
	13263	S PRCACC= $S(Z=147:" NR",Z=148: "NP",Z=149 :"NL",Z=15 0:"AN",Z=1 52:"NC",Z= 154:"NZ",Z
	13264	=155:"NI", Z=156:"NE" ,Z=157:"NG ",Z=158:"N U",Z=159:" NF",Z=160: "NO",Z=145 :"OM",Z=16
	13265	2:"PK",1:" ") G:PRC ACC'=" " COUNTRYQ
	13266	"RTN","RCT CSP1",434, 0)
	13267	S PRCACC= $S(Z=999:" PW",Z=163: "PA",Z=164 :"PG",Z=16 5:"PY",Z=1 66:"PE",Z= 167:"PH",Z
	13268	=168:"PN", Z=169:"PL" ,Z=170:"PT ",Z=173:"Q A",Z=999:" RE",Z=175: "RO",Z=176 :"RU",Z=17
	13269	7:"RW",Z=1 78:"SH",1: " ") G:PR CACC'=" " COUNTRYQ
	13270	"RTN","RCT CSP1",435, 0)
	13271	S PRCACC= $S(Z=179:" KN",Z=181: "LC",Z=183 :"VC",Z=99 9:"WS",Z=1 84:"SM",Z= 185:"ST",Z
	13272	=186:"SA", Z=187:"SN" ,Z=188:"SC ",Z=189:"S L",Z=190:" SG",Z=191: "SK",Z=193 :"SI",Z=30
	13273	:"SB",1:" ") G:PRCA CC'=" " C OUNTRYQ
	13274	"RTN","RCT CSP1",436, 0)
	13275	S PRCACC= $S(Z=194:" SO",Z=195: "ZA",Z=197 :"ES",Z=43 :"LK",Z=19 9:"SD",Z=2 00:"SR",Z=
	13276	201:"SZ",Z =202:"SE", Z=203:"CH" ,Z=204:"SY ",Z=205:"T J",Z=222:" TZ",Z=182: "PM",Z=206
	13277	:"TH",Z=21 9:"MK",1:" ") G:PRC ACC'=" " COUNTRYQ
	13278	"RTN","RCT CSP1",437, 0)
	13279	S PRCACC= $S(Z=207:" TG",Z=208: "TK",Z=209 :"TO",Z=21 0:"TT",Z=2 12:"TN",Z= 213:"TR",Z
	13280	=214:"TM", Z=215:"TC" ,Z=216:"TV ",Z=217:"U G",Z=218:" UA",Z=211: "AE",Z=1:" US",Z=224:
	13281	"UY",1:" ") G:PRCAC C'=" " CO UNTRYQ
	13282	"RTN","RCT CSP1",438, 0)
	13283	S PRCACC= $S(Z=104:" IR",Z=225: "UZ",Z=153 :"VU",Z=97 :"VA",Z=22 6:"VE",Z=1 83:"VN",Z=
	13284	31:"VG",Z= 227:"WF",Z =228:"YE", Z=229:"YU" ,Z=230:"ZM ",Z=196:"Z W",1:" ") G:PRCACC'
	13285	=" " COUN TRYQ
	13286	"RTN","RCT CSP1",439, 0)
	13287	COUNTRYQ ;
	13288	"RTN","RCT CSP1",440, 0)
	13289	Q PRCACC
	13290	"RTN","RCT CSP1",441, 0)
	13291	;
	13292	"RTN","RCT CSP2")
	13293	0^14^B1229 06174
	13294	"RTN","RCT CSP2",1,0)
	13295	RCTCSP2 ;A LBANY/BDB- CROSS-SERV ICING TRAN SMISSION ; 03/15/14 3 :34 PM
	13296	"RTN","RCT CSP2",2,0)
	13297	;;4.5;Acc ounts Rece ivable;3 01,315;M ar 20, 199 5;Build 2
	13298	"RTN","RCT CSP2",3,0)
	13299	;;Per VA Directive 6402, this routine s hould not be modifie d.
	13300	"RTN","RCT CSP2",4,0)
	13301	;
	13302	"RTN","RCT CSP2",5,0)
	13303	Q
	13304	"RTN","RCT CSP2",6,0)
	13305	;
	13306	"RTN","RCT CSP2",7,0)
	13307	COMPILE ;
	13308	"RTN","RCT CSP2",8,0)
	13309	N RCMSG,B CNTR,REC,R ECC,AMOUNT ,RCNTR,ACT ION,SEQ
	13310	"RTN","RCT CSP2",9,0)
	13311	S BCNTR=0 ,REC=0,REC C=0,AMOUNT =0,SEQ=0
	13312	"RTN","RCT CSP2",10,0 )
	13313	F S BCNT R=$O(^XTMP ("RCTCSPD" ,$J,BCNTR) ) Q:+BCNTR '>0 D
	13314	"RTN","RCT CSP2",11,0 )
	13315	.I REC>50 D
	13316	"RTN","RCT CSP2",12,0 )
	13317	..D TRAIL ER^RCTCSP1
	13318	"RTN","RCT CSP2",13,0 )
	13319	..D AITCM SG
	13320	"RTN","RCT CSP2",14,0 )
	13321	..S REC=0 ,RECC=0
	13322	"RTN","RCT CSP2",15,0 )
	13323	..Q
	13324	"RTN","RCT CSP2",16,0 )
	13325	.S ACTION ="" F S A CTION=$O(^ XTMP("RCTC SPD",$J,BC NTR,ACTION )) Q:ACTIO N="" D
	13326	"RTN","RCT CSP2",17,0 )
	13327	..I REC=0 D HEADER^ RCTCSP1
	13328	"RTN","RCT CSP2",18,0 )
	13329	..F RCNTR =1,2,"2A", "2C",3 I $ D(^XTMP("R CTCSPD",$J ,BCNTR,ACT ION,RCNTR) ) D
	13330	"RTN","RCT CSP2",19,0 )
	13331	...S REC= REC+1
	13332	"RTN","RCT CSP2",20,0 )
	13333	...S RECC =RECC+1 ;r ecord coun t for 'c' records on trailer r ecord
	13334	"RTN","RCT CSP2",21,0 )
	13335	...S ^XTM P("RCTCSPD ",$J,SEQ," BUILD",REC )=$E(^XTMP ("RCTCSPD" ,$J,BCNTR, ACTION,RCN
	13336	TR),1,225) _$C(94)
	13337	"RTN","RCT CSP2",22,0 )
	13338	...S REC= REC+1
	13339	"RTN","RCT CSP2",23,0 )
	13340	...S ^XTM P("RCTCSPD ",$J,SEQ," BUILD",REC )=$E(^XTMP ("RCTCSPD" ,$J,BCNTR, ACTION,RCN
	13341	TR),226,99 9)_$C(126)
	13342	"RTN","RCT CSP2",24,0 )
	13343	...I $E(^ XTMP("RCTC SPD",$J,BC NTR,ACTION ,RCNTR),2) ="1" S AMO UNT=AMOUNT +$E(^(RCNT
	13344	R),91,104)
	13345	"RTN","RCT CSP2",25,0 )
	13346	...Q
	13347	"RTN","RCT CSP2",26,0 )
	13348	..I $D(^X TMP("RCTCS PD",$J,BCN TR,ACTION, "5B")) D
	13349	"RTN","RCT CSP2",27,0 )
	13350	...N TRNN UM
	13351	"RTN","RCT CSP2",28,0 )
	13352	...S TRNN UM=0
	13353	"RTN","RCT CSP2",29,0 )
	13354	...F S T RNNUM=$O(^ XTMP("RCTC SPD",$J,BC NTR,ACTION ,"5B",TRNN UM)) Q:TRN NUM'?1N.N
	13355	D
	13356	"RTN","RCT CSP2",30,0 )
	13357	....S REC =REC+1
	13358	"RTN","RCT CSP2",31,0 )
	13359	....S REC C=RECC+1 ; record cou nt for 'c' records o n trailer record
	13360	"RTN","RCT CSP2",32,0 )
	13361	....S ^XT MP("RCTCSP D",$J,SEQ, "BUILD",RE C)=$E(^XTM P("RCTCSPD ",$J,BCNTR ,ACTION,"5
	13362	B",TRNNUM) ,1,225)_$C (94)
	13363	"RTN","RCT CSP2",33,0 )
	13364	....S REC =REC+1
	13365	"RTN","RCT CSP2",34,0 )
	13366	....S ^XT MP("RCTCSP D",$J,SEQ, "BUILD",RE C)=$E(^XTM P("RCTCSPD ",$J,BCNTR ,ACTION,"5
	13367	B",TRNNUM) ,226,999)_ $C(126)
	13368	"RTN","RCT CSP2",35,0 )
	13369	....S AMO UNT=AMOUNT +$TR($E(^X TMP("RCTCS PD",$J,BCN TR,ACTION, "5B",TRNNU M),173,186
	13370	),"-")
	13371	"RTN","RCT CSP2",36,0 )
	13372	....Q
	13373	"RTN","RCT CSP2",37,0 )
	13374	...Q
	13375	"RTN","RCT CSP2",38,0 )
	13376	..Q
	13377	"RTN","RCT CSP2",39,0 )
	13378	.Q
	13379	"RTN","RCT CSP2",40,0 )
	13380	D TRAILER ^RCTCSP1
	13381	"RTN","RCT CSP2",41,0 )
	13382	D AITCMSG
	13383	"RTN","RCT CSP2",42,0 )
	13384	D USRMSG
	13385	"RTN","RCT CSP2",43,0 )
	13386	Q
	13387	"RTN","RCT CSP2",44,0 )
	13388	;
	13389	"RTN","RCT CSP2",45,0 )
	13390	RCLLCHK(BI LL) ;
	13391	"RTN","RCT CSP2",46,0 )
	13392	N TOTAL
	13393	"RTN","RCT CSP2",47,0 )
	13394	I $P(B15, U,7) Q 0 ; check stop tcsp refe rral flag
	13395	"RTN","RCT CSP2",48,0 )
	13396	I $P(B15, U,2),'$P(B 15,U,3) D ;recall b ill
	13397	"RTN","RCT CSP2",49,0 )
	13398	.N ACTION ,BILLCSL
	13399	"RTN","RCT CSP2",50,0 )
	13400	.S ACTION ="L"
	13401	"RTN","RCT CSP2",51,0 )
	13402	.S $P(^PR CA(430,BIL L,15),U,1) ="" ;clear the date referred
	13403	"RTN","RCT CSP2",52,0 )
	13404	.S $P(^PR CA(430,BIL L,15),U,3) =DT ;set t he recall date
	13405	"RTN","RCT CSP2",53,0 )
	13406	.S $P(^PR CA(430,BIL L,15),U,5) =$$GET1^DI Q(430,BILL ,11) ;set the recall amount to
	13407	the curre nt amount
	13408	"RTN","RCT CSP2",54,0 )
	13409	.S B15=^P RCA(430,BI LL,15)
	13410	"RTN","RCT CSP2",55,0 )
	13411	.S BILLCS L=BILL ;la st cs bill
	13412	"RTN","RCT CSP2",56,0 )
	13413	.D REC1^R CTCSPD
	13414	"RTN","RCT CSP2",57,0 )
	13415	.D RCLL^R CTCSPD4
	13416	"RTN","RCT CSP2",58,0 )
	13417	.K ^PRCA( 430,"TCSP" ,BILL) ;se t the bill to not se nt to cros s-servicin g
	13418	"RTN","RCT CSP2",59,0 )
	13419	;
	13420	"RTN","RCT CSP2",60,0 )
	13421	;recall b ill if tot al <$25
	13422	"RTN","RCT CSP2",61,0 )
	13423	S TOTAL=$ P(B7,U)+$P (B7,U,2)+$ P(B7,U,3)+ $P(B7,U,4) +$P(B7,U,5 )
	13424	"RTN","RCT CSP2",62,0 )
	13425	I TOTAL<2 5 D Q 0
	13426	"RTN","RCT CSP2",63,0 )
	13427	.N X1,X2, P366DT,X,P RCAEN,I,RE CALL
	13428	"RTN","RCT CSP2",64,0 )
	13429	.S RECALL =0
	13430	"RTN","RCT CSP2",65,0 )
	13431	.S X1=DT, X2=-366 D C^%DTC S P 366DT=X
	13432	"RTN","RCT CSP2",66,0 )
	13433	.S PRCAEN =0 F I=0:0 S PRCAEN= $O(^PRCA(4 33,"C",BIL L,PRCAEN)) Q:'PRCAEN S:$P($G(
	13434	^PRCA(433, PRCAEN,1)) ,U,1)>P366 DT RECALL= 1
	13435	"RTN","RCT CSP2",67,0 )
	13436	.I RECALL =0 D Q
	13437	"RTN","RCT CSP2",68,0 )
	13438	..S ACTIO N="L"
	13439	"RTN","RCT CSP2",69,0 )
	13440	..S $P(^P RCA(430,BI LL,15),U,1 )="" ;clea r the date referred
	13441	"RTN","RCT CSP2",70,0 )
	13442	..S $P(^P RCA(430,BI LL,15),U,2 )=1 ;set t he recall flag
	13443	"RTN","RCT CSP2",71,0 )
	13444	..S $P(^P RCA(430,BI LL,15),U,3 )=DT ;set the recall date
	13445	"RTN","RCT CSP2",72,0 )
	13446	..S $P(^P RCA(430,BI LL,15),U,4 )="07" ;se t the reca ll reason
	13447	"RTN","RCT CSP2",73,0 )
	13448	..S $P(^P RCA(430,BI LL,15),U,5 )=$P(^PRCA (430,BILL, 16),U,10) ;set the r ecall amou
	13449	nt to the current tc sp amount
	13450	"RTN","RCT CSP2",74,0 )
	13451	..S $P(^P RCA(430,BI LL,15),U,7 )=1 ;set t he stop fl ag
	13452	"RTN","RCT CSP2",75,0 )
	13453	..S $P(^P RCA(430,BI LL,15),U,8 )=DT ;set the stop d ate
	13454	"RTN","RCT CSP2",76,0 )
	13455	..S $P(^P RCA(430,BI LL,15),U,9 )="O" ;set the stop date
	13456	"RTN","RCT CSP2",77,0 )
	13457	..S $P(^P RCA(430,BI LL,15),U,1 0)="AUTORE CALL <$25" ;set the stop reaso n
	13458	"RTN","RCT CSP2",78,0 )
	13459	..S B15=^ PRCA(430,B ILL,15)
	13460	"RTN","RCT CSP2",79,0 )
	13461	..D REC1^ RCTCSPD
	13462	"RTN","RCT CSP2",80,0 )
	13463	..D RCLL^ RCTCSPD4
	13464	"RTN","RCT CSP2",81,0 )
	13465	..K ^PRCA (430,"TCSP ",BILL) ;s et the bil l to not s ent to cro ss-servici ng
	13466	"RTN","RCT CSP2",82,0 )
	13467	..S $P(^P RCA(430,BI LL,19),U,1 0)=1 ;stop interest admin calc
	13468	"RTN","RCT CSP2",83,0 )
	13469	..S B19=$ G(^PRCA(43 0,BILL,19) )
	13470	"RTN","RCT CSP2",84,0 )
	13471	..Q
	13472	"RTN","RCT CSP2",85,0 )
	13473	.Q
	13474	"RTN","RCT CSP2",86,0 )
	13475	Q 0
	13476	"RTN","RCT CSP2",87,0 )
	13477	;
	13478	"RTN","RCT CSP2",88,0 )
	13479	RCRPRT ;
	13480	pri nt reconci liation re port
	13481	"RTN","RCT CSP2",89,0 )
	13482	N ZTDESC, ZTRTN,POP, %ZIS,DTFRM TO,DTFRM,D TTO,PROMPT ,EXCEL
	13483	"RTN","RCT CSP2",90,0 )
	13484	W !
	13485	"RTN","RCT CSP2",91,0 )
	13486	S DTFRMTO =$$DTFRMTO Q:'DTFRMT O ;Get da te range a s per PRCA 4.5315
	13487	"RTN","RCT CSP2",92,0 )
	13488	S EXCEL=0 ,PROMPT="C APTURE Rep ort data t o an Excel Document? ",DIR(0)=" Y",DIR("?"
	13489	)="^D HEXC ^RCTCSJR"
	13490	"RTN","RCT CSP2",93,0 )
	13491	S EXCEL=$ $SELECT^RC TCSJR(PROM PT,"NO") I "01"'[EXC EL S STOP= 1 Q
	13492	"RTN","RCT CSP2",94,0 )
	13493	I EXCEL=1 D EXCMSG^ RCTCSJR ; Display Ex cel displa y message
	13494	"RTN","RCT CSP2",95,0 )
	13495	K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")="" D ^%ZIS Q: POP S IOP =ION_";"_I OM_";"_IOS
	13496	L
	13497	"RTN","RCT CSP2",96,0 )
	13498	I $D(IO(" Q")) D Q
	13499	"RTN","RCT CSP2",97,0 )
	13500	.S ZTSAVE ("DTFRMTO" )="",ZTSAV E("EXCEL") =""
	13501	"RTN","RCT CSP2",98,0 )
	13502	.S ZTRTN= "RCRPRTP^R CTCSP2",ZT DESC="RECO NCILIATION REPORT"
	13503	"RTN","RCT CSP2",99,0 )
	13504	.D ^%ZTLO AD,HOME^%Z IS
	13505	"RTN","RCT CSP2",100, 0)
	13506	.Q
	13507	"RTN","RCT CSP2",101, 0)
	13508	;
	13509	"RTN","RCT CSP2",102, 0)
	13510	RCRPRTP ;p rint recon ciliation report, ca ll to buil d array of bills ret urned
	13511	"RTN","RCT CSP2",103, 0)
	13512	U IO
	13513	"RTN","RCT CSP2",104, 0)
	13514	N DASH,PA GE,DBTR,DB TRN,RCOUT, CURDT,FND1
	13515	"RTN","RCT CSP2",105, 0)
	13516	K ^XTMP(" RCTCSPP",$ J)
	13517	"RTN","RCT CSP2",106, 0)
	13518	S ^XTMP(" RCTCSPP",0 )=$$FMADD^ XLFDT(DT,3 )_"^"_DT
	13519	"RTN","RCT CSP2",107, 0)
	13520	S (DATE,D TFRM)=$P(D TFRMTO,U,2 )-1,DTTO=$ P(DTFRMTO, U,3),CURDT =0
	13521	"RTN","RCT CSP2",108, 0)
	13522	;F S DBT R=$O(^PRCA (430,"C",D BTR)) Q:DB TR'?1N.N D
	13523	"RTN","RCT CSP2",109, 0)
	13524	S FND1=0
	13525	"RTN","RCT CSP2",110, 0)
	13526	F S DATE =$O(^PRCA( 430,"AB",D ATE)),BILL IEN=0 Q:DA TE=""!(DAT E>DTTO) D
	13527	"RTN","RCT CSP2",111, 0)
	13528	. F S BI LLIEN=$O(^ PRCA(430," AB",DATE,B ILLIEN)) Q :BILLIEN=" "!FND1 D
	13529	"RTN","RCT CSP2",112, 0)
	13530	..I +$P($ G(^PRCA(43 0,BILLIEN, 30)),U,1)= 0 Q ;Ret urned date is NULL
	13531	"RTN","RCT CSP2",113, 0)
	13532	..S DBTR= $P($G(^PRC A(430,BILL IEN,0)),U, 9),DBTRN=$ $GET1^DIQ( 430,BILLIE N,9)
	13533	"RTN","RCT CSP2",114, 0)
	13534	..Q:DBTRN ']""
	13535	"RTN","RCT CSP2",115, 0)
	13536	..S ^XTMP ("RCTCSPP" ,$J,DBTRN, DBTR)=""
	13537	"RTN","RCT CSP2",116, 0)
	13538	..S FND1= 1
	13539	"RTN","RCT CSP2",117, 0)
	13540	S PAGE=0, RCOUT=0
	13541	"RTN","RCT CSP2",118, 0)
	13542	S DASH="" ,$P(DASH," -",81)=""
	13543	"RTN","RCT CSP2",119, 0)
	13544	D RCRPRTH 2
	13545	"RTN","RCT CSP2",120, 0)
	13546	S DBTRN=0
	13547	"RTN","RCT CSP2",121, 0)
	13548	F S DBTR N=$O(^XTMP ("RCTCSPP" ,$J,DBTRN) ) Q:DBTRN= "" D Q:R COUT
	13549	"RTN","RCT CSP2",122, 0)
	13550	.S DBTR=$ O(^XTMP("R CTCSPP",$J ,DBTRN,0)) Q:'+DBTR
	13551	"RTN","RCT CSP2",123, 0)
	13552	.S BILL=0
	13553	"RTN","RCT CSP2",124, 0)
	13554	.F S BIL L=$O(^PRCA (430,"C",D BTR,BILL)) Q:BILL'?1 N.N D Q: RCOUT
	13555	"RTN","RCT CSP2",125, 0)
	13556	..N B0,B3 0
	13557	"RTN","RCT CSP2",126, 0)
	13558	..S B0=$G (^PRCA(430 ,BILL,0)), B30=$G(^PR CA(430,BIL L,30))
	13559	"RTN","RCT CSP2",127, 0)
	13560	..I +$P($ G(^PRCA(43 0,BILL,30) ),U,1)=0 Q
	13561	"RTN","RCT CSP2",128, 0)
	13562	..W $E($$ GET1^DIQ(4 30,BILL,9) ,1,28)
	13563	"RTN","RCT CSP2",129, 0)
	13564	..I 'EXCE L W ?30,$P (B0,U,1),? 45,$$FMTE^ XLFDT($$GE T1^DIQ(430 ,BILL,301, "I"),2),?6
	13565	0,$$FMTE^X LFDT($$GET 1^DIQ(430, BILL,305," I"),2) ;d ate type ( as per PRC A4.5315)
	13566	"RTN","RCT CSP2",130, 0)
	13567	..I EXCEL W U_$P(B0 ,U,1)_U_$$ FMTE^XLFDT ($$GET1^DI Q(430,BILL ,301,"I"), 2)_U_$$FMT
	13568	E^XLFDT($$ GET1^DIQ(4 30,BILL,30 5,"I"),2) ;date typ e (as per PRCA4.53 15)
	13569	"RTN","RCT CSP2",131, 0)
	13570	..I $P(B3 0,U,2)]"" D
	13571	"RTN","RCT CSP2",132, 0)
	13572	...I 'EXC EL W !,?6, $$GET1^DIQ (430.5,$P( B30,U,2),1 ),!
	13573	"RTN","RCT CSP2",133, 0)
	13574	...I EXCE L W U_$$GE T1^DIQ(430 .5,$P(B30, U,2),1),!
	13575	"RTN","RCT CSP2",134, 0)
	13576	..I 'EXCE L D
	13577	"RTN","RCT CSP2",135, 0)
	13578	...W:$P($ G(^PRCA(43 0,BILL,30) ),U,3)="Y" ?6,"COMPR OMISE, PLE ASE WRITE THIS BILL
	13579	OFF BY THE MANUAL PR OCESS.",!, ?6,"COMPRO MISED AMOU NT (NOT CO LLECTED): "_$J($P($G
	13580	(^PRCA(430 ,BILL,30)) ,U,4),9,2) ,!
	13581	"RTN","RCT CSP2",136, 0)
	13582	...W:+$P( $G(^PRCA(4 30,BILL,30 )),U,7) ?6 ,"DATE OF DEATH: "_ $$FMTE^XLF DT($P($G(^
	13583	PRCA(430,B ILL,30)),U ,7),2),! ;More cosi stent date type (as per PRCA4 .5315)
	13584	"RTN","RCT CSP2",137, 0)
	13585	...W:+$P( $G(^PRCA(4 30,BILL,30 )),U,6) ?6 ,"BANKRUPT CY DATE: "_$$FMTE^X LFDT($P($G
	13586	(^PRCA(430 ,BILL,30)) ,U,6),2),! ;More co sistent da te type (a s per PRCA 4.5315)
	13587	"RTN","RCT CSP2",138, 0)
	13588	...W:+$P( $G(^PRCA(4 30,BILL,30 )),U,8) ?6 ,"DATE OF DISSOLUTIO N: "_$$FM TE^XLFDT($
	13589	P($G(^PRCA (430,BILL, 30)),U,8), 2),! ;Mor e cosisten t date typ e (as per PRCA4.53
	13590	15)
	13591	"RTN","RCT CSP2",139, 0)
	13592	..I EXCEL D
	13593	"RTN","RCT CSP2",140, 0)
	13594	...W:$P($ G(^PRCA(43 0,BILL,30) ),U,3)="Y" U_"COMPRO MISE, PLEA SE WRITE T HIS BILL O
	13595	FF BY THE MANUAL PRO CESS.",!,U _"COMPROMI SED AMOUNT (NOT COLL ECTED): "_ $J($P($G(^
	13596	PRCA(430,B ILL,30)),U ,4),9,2),!
	13597	"RTN","RCT CSP2",141, 0)
	13598	...W:+$P( $G(^PRCA(4 30,BILL,30 )),U,7) U_ "DATE OF D EATH: "_$ $FMTE^XLFD T($P($G(^P
	13599	RCA(430,BI LL,30)),U, 7),2),!
	13600	"RTN","RCT CSP2",142, 0)
	13601	...W:+$P( $G(^PRCA(4 30,BILL,30 )),U,6) U_ "BANKRUPTC Y DATE: " _$$FMTE^XL FDT($P($G(
	13602	^PRCA(430, BILL,30)), U,6),2),!
	13603	"RTN","RCT CSP2",143, 0)
	13604	...W:+$P( $G(^PRCA(4 30,BILL,30 )),U,8) ?6 ,"DATE OF DISSOLUTIO N: "_$$FM TE^XLFDT($
	13605	P($G(^PRCA (430,BILL, 30)),U,8), 2),!
	13606	"RTN","RCT CSP2",144, 0)
	13607	..;check for end of page here , if neces sary form feed and p rint heade r
	13608	"RTN","RCT CSP2",145, 0)
	13609	..I 'EXCE L W ! I ($ Y+3)>IOSL D
	13610	"RTN","RCT CSP2",146, 0)
	13611	...I $E(I OST,1,2)=" C-" S DIR( 0)="E" K D IRUT D ^DI R K DIR I $D(DTOUT)! ($D(DUOUT)
	13612	) S RCOUT= 1 K X,Y,DI RUT,DTOUT, DUOUT,DIRO UT Q
	13613	"RTN","RCT CSP2",147, 0)
	13614	...D RCRP RTH2
	13615	"RTN","RCT CSP2",148, 0)
	13616	I $E(IOST ,1,2)="C-" R !!,"END OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @
	13617	IOF
	13618	"RTN","RCT CSP2",149, 0)
	13619	D:'$D(ZTQ UEUED) ^%Z ISC
	13620	"RTN","RCT CSP2",150, 0)
	13621	S:$D(ZTQU EUED) ZTRE Q="@"
	13622	"RTN","RCT CSP2",151, 0)
	13623	K ZTQUEUE D
	13624	"RTN","RCT CSP2",152, 0)
	13625	Q
	13626	"RTN","RCT CSP2",153, 0)
	13627	;
	13628	"RTN","RCT CSP2",154, 0)
	13629	RCRPRTH2 ; header for reconcili ation repo rt print r eport 2
	13630	"RTN","RCT CSP2",155, 0)
	13631	W @IOF
	13632	"RTN","RCT CSP2",156, 0)
	13633	S PAGE=PA GE+1
	13634	"RTN","RCT CSP2",157, 0)
	13635	;W "PAGE "_PAGE,?12 ,"BILLS RE TURNED FRO M CROSS-SE RVICING (S ORTED BY D EBTOR)",?6
	13636	8,$$UPPER^ VALM1($$FM TE^XLFDT(D T))
	13637	"RTN","RCT CSP2",158, 0)
	13638	I 'EXCEL D Q
	13639	"RTN","RCT CSP2",159, 0)
	13640	.W "PAGE "_PAGE,?12 ,"RECONCIL IATION REP ORT (SORTE D BY DEBTO R)",?60,$$ FMTE^XLFDT
	13641	(DT,2)
	13642	"RTN","RCT CSP2",160, 0)
	13643	.W !,DASH ,!
	13644	"RTN","RCT CSP2",161, 0)
	13645	.W !,"DEB TOR",?30," BILL NO.", ?45,"RETUR N DATE",?6 0,"CLOSE D ATE"
	13646	"RTN","RCT CSP2",162, 0)
	13647	.W !,"--- ---",?30," ---- ---", ?45,"----- - ----",?6 0,"----- - ---",!
	13648	"RTN","RCT CSP2",163, 0)
	13649	;EXCEL FO RMAT
	13650	"RTN","RCT CSP2",164, 0)
	13651	W "PAGE " _PAGE_U_U_ "RECONCILI ATION REPO RT (SORTED BY DEBTOR )"_U_U_$$F MTE^XLFDT(
	13652	DT,2)
	13653	"RTN","RCT CSP2",165, 0)
	13654	W !,"DEBT OR"_U_"BIL L NO."_U_" RETURN DAT E"_U_"CLOS E DATE"
	13655	"RTN","RCT CSP2",166, 0)
	13656	Q
	13657	"RTN","RCT CSP2",167, 0)
	13658	;
	13659	"RTN","RCT CSP2",168, 0)
	13660	AITCMSG ;
	13661	"RTN","RCT CSP2",169, 0)
	13662	N XMY,XMD UZ,XMSUB,X MTEXT,CNTL ID
	13663	"RTN","RCT CSP2",170, 0)
	13664	S CNTLID= $$JD^RCTCS P1()_$$RJZ F^RCTCSP1( SEQ,4)
	13665	"RTN","RCT CSP2",171, 0)
	13666	S XMDUZ=" AR PACKAGE "
	13667	"RTN","RCT CSP2",172, 0)
	13668	S XMY("XX X@Q-TXC URL ")=""
	13669	"RTN","RCT CSP2",173, 0)
	13670	S XMY("G. TCSP")=""
	13671	"RTN","RCT CSP2",174, 0)
	13672	S XMSUB=S ITE_"/CS T RANSMISSIO N/BATCH#: "_CNTLID
	13673	"RTN","RCT CSP2",175, 0)
	13674	S XMTEXT= "^XTMP(""R CTCSPD""," _$J_","""_ SEQ_""","" BUILD"","
	13675	"RTN","RCT CSP2",176, 0)
	13676	D ^XMD
	13677	"RTN","RCT CSP2",177, 0)
	13678	Q
	13679	"RTN","RCT CSP2",178, 0)
	13680	;
	13681	"RTN","RCT CSP2",179, 0)
	13682	USRMSG ;se nds mailma n message of documen ts sent to user
	13683	"RTN","RCT CSP2",180, 0)
	13684	N XMY,XMD UZ,XMSUB,X MTEXT,X,RC NT,RCDAT1, RCDAT2
	13685	"RTN","RCT CSP2",181, 0)
	13686	S ACTION= "" F S AC TION=$O(^X TMP("RCTCS PD",$J,"BI LL",ACTION )) Q:ACTIO N="" D
	13687	"RTN","RCT CSP2",182, 0)
	13688	.K ^XTMP( "RCTCSPD", $J,"BILL", "MSG")
	13689	"RTN","RCT CSP2",183, 0)
	13690	.S XMDUZ= "AR PACKAG E"
	13691	"RTN","RCT CSP2",184, 0)
	13692	.S XMY("G .TCSP")=""
	13693	"RTN","RCT CSP2",185, 0)
	13694	.S XMSUB= "CS "_$S(A CTION="A": "ADD REFER RAL",ACTIO N="U":"UPD ATES",ACTI ON="L":"RE
	13695	CALLS",ACT ION="B":"E XISTING DE BTOR",1:"U NKNOWN")_" SENT ON " _$E(DT,4,5 )_"/"_$E(D
	13696	T,6,7)_"/" _$E(DT,2,3 )_" BATCH ID: "_CNTL ID
	13697	"RTN","RCT CSP2",186, 0)
	13698	.S ^XTMP( "RCTCSPD", $J,"BILL", "MSG",1)=" Bill# TIN
	13699	TYPE AMOU NT"
	13700	"RTN","RCT CSP2",187, 0)
	13701	.S ^XTMP( "RCTCSPD", $J,"BILL", "MSG",2)=" ----- ---
	13702	---- ---- --"
	13703	"RTN","RCT CSP2",188, 0)
	13704	.S X=0,RC NT=2 F S X=$O(^XTMP ("RCTCSPD" ,$J,"BILL" ,ACTION,X) ) Q:X="" D
	13705	"RTN","RCT CSP2",189, 0)
	13706	..S RCNT= RCNT+1
	13707	"RTN","RCT CSP2",190, 0)
	13708	..S RCDAT 1=$P(^XTMP ("RCTCSPD" ,$J,"BILL" ,ACTION,X) ,U,1)
	13709	"RTN","RCT CSP2",191, 0)
	13710	..S RCDAT 2=$P(^XTMP ("RCTCSPD" ,$J,"BILL" ,ACTION,X) ,U,2)
	13711	"RTN","RCT CSP2",192, 0)
	13712	..S ^XTMP ("RCTCSPD" ,$J,"BILL" ,"MSG",RCN T)=$$RJZF( $P($G(^PRC A(430,X,0) ),U,1),7)_
	13713	$$BLANK(22 )_RCDAT1_" "_ACT ION_" "_$S(RC DAT2]"":RC DAT2,1:"")
	13714	"RTN","RCT CSP2",193, 0)
	13715	..Q
	13716	"RTN","RCT CSP2",194, 0)
	13717	.S ^XTMP( "RCTCSPD", $J,"BILL", "MSG",RCNT +1)="Total Bills: "_ (RCNT-2)
	13718	"RTN","RCT CSP2",195, 0)
	13719	.S XMTEXT ="^XTMP("" RCTCSPD"", "_$J_",""B ILL"",""MS G"","
	13720	"RTN","RCT CSP2",196, 0)
	13721	.D ^XMD
	13722	"RTN","RCT CSP2",197, 0)
	13723	.K ^XTMP( "RCTCSPD", $J,"BILL", "MSG")
	13724	"RTN","RCT CSP2",198, 0)
	13725	Q
	13726	"RTN","RCT CSP2",199, 0)
	13727	;
	13728	"RTN","RCT CSP2",200, 0)
	13729	THIRD ;sen ds mailman message t o user if no third l etter foun d
	13730	"RTN","RCT CSP2",201, 0)
	13731	Q:'$D(^XT MP("RCTCSP D",$J,"THI RD"))
	13732	"RTN","RCT CSP2",202, 0)
	13733	N XMY,XMD UZ,XMSUB,X MTEXT
	13734	"RTN","RCT CSP2",203, 0)
	13735	S XMDUZ=" AR PACKAGE "
	13736	"RTN","RCT CSP2",204, 0)
	13737	S XMY("G. TCSP")=""
	13738	"RTN","RCT CSP2",205, 0)
	13739	N TCT,TDE B,TDEB0,TB IL,TSP,FST
	13740	"RTN","RCT CSP2",206, 0)
	13741	S XMSUB=" TCSP QUALI FIED/NO 3R D LETTER S ENT ON "_$ E(DT,4,5)_ "/"_$E(DT, 6,7)_"/"_$
	13742	E(DT,2,3)
	13743	"RTN","RCT CSP2",207, 0)
	13744	S ^XTMP(" RCTCSPD",$ J,"THIRD", 1)="The fo llowing li st of debt or bills w ere not se
	13745	nt to TCSP ."
	13746	"RTN","RCT CSP2",208, 0)
	13747	S ^XTMP(" RCTCSPD",$ J,"THIRD", 2)="Please review de btor's acc ount to de termine wh
	13748	y the thir d"
	13749	"RTN","RCT CSP2",209, 0)
	13750	S ^XTMP(" RCTCSPD",$ J,"THIRD", 3)="notice letter ha s not been sent:"
	13751	"RTN","RCT CSP2",210, 0)
	13752	S ^XTMP(" RCTCSPD",$ J,"THIRD", 4)="Name B ill #"
	13753	"RTN","RCT CSP2",211, 0)
	13754	S ^XTMP(" RCTCSPD",$ J,"THIRD", 5)="---- - -----"
	13755	"RTN","RCT CSP2",212, 0)
	13756	S TCT=6,T SP=0,TDEB= ""
	13757	"RTN","RCT CSP2",213, 0)
	13758	F S TDEB =$O(^XTMP( "RCTCSPD", $J,"THIRD" ,TDEB)) Q: TDEB="" D
	13759	"RTN","RCT CSP2",214, 0)
	13760	.S FST=1, TBIL=""
	13761	"RTN","RCT CSP2",215, 0)
	13762	.I FST,TC T'=6 S ^XT MP("RCTCSP D",$J,"THI RD",TCT)=" ",TCT=TCT+ 1,TSP=TSP+ 1
	13763	"RTN","RCT CSP2",216, 0)
	13764	.F S TBI L=$O(^XTMP ("RCTCSPD" ,$J,"THIRD ",TDEB,TBI L)) Q:TBIL ="" D
	13765	"RTN","RCT CSP2",217, 0)
	13766	..S TDEB0 =$S(FST:TD EB,1:"")
	13767	"RTN","RCT CSP2",218, 0)
	13768	..S ^XTMP ("RCTCSPD" ,$J,"THIRD ",TCT)=TDE B0_$J(" ", 35-$L(TDEB 0))_TBIL
	13769	"RTN","RCT CSP2",219, 0)
	13770	..S TCT=T CT+1,FST=0
	13771	"RTN","RCT CSP2",220, 0)
	13772	S ^XTMP(" RCTCSPD",$ J,"THIRD", TCT)="Tota l records: "_(TCT-(6 +TSP))
	13773	"RTN","RCT CSP2",221, 0)
	13774	S XMTEXT= "^XTMP(""R CTCSPD""," _$J_",""TH IRD"","
	13775	"RTN","RCT CSP2",222, 0)
	13776	D ^XMD
	13777	"RTN","RCT CSP2",223, 0)
	13778	K ^XTMP(" RCTCSPD",$ J,"THIRD")
	13779	"RTN","RCT CSP2",224, 0)
	13780	THIRDQ Q
	13781	"RTN","RCT CSP2",225, 0)
	13782	;
	13783	"RTN","RCT CSP2",226, 0)
	13784	REC3 ;
	13785	"RTN","RCT CSP2",227, 0)
	13786	N REC,KNU M,DEBTNR,D EBTORNB
	13787	"RTN","RCT CSP2",228, 0)
	13788	S REC="C3 "_ACTION_ "363600120 0"_"DM1D "
	13789	"RTN","RCT CSP2",229, 0)
	13790	S KNUM=$P ($P(B0,U,1 ),"-",2)
	13791	"RTN","RCT CSP2",230, 0)
	13792	S DEBTNR= $E(SITE,1, 3)_$$LJZF( KNUM,7)_$T R($J(BILL, 20)," ",0) ,REC=REC_D EBTNR
	13793	"RTN","RCT CSP2",231, 0)
	13794	S DEBTORN B=$E(SITE, 1,3)_$TR($ J(DEBTOR,1 2)," ",0)
	13795	"RTN","RCT CSP2",232, 0)
	13796	S REC=REC _DEBTORNB
	13797	"RTN","RCT CSP2",233, 0)
	13798	S REC=REC _$S(ACTION ="L":"15", 1:" ")
	13799	"RTN","RCT CSP2",234, 0)
	13800	S REC=REC _"SLF"
	13801	"RTN","RCT CSP2",235, 0)
	13802	S REC=REC _$$BLANK(8 )
	13803	"RTN","RCT CSP2",236, 0)
	13804	S REC=REC _$$AMOUNT( 0)
	13805	"RTN","RCT CSP2",237, 0)
	13806	S REC=REC _$$BLANK(1 6)
	13807	"RTN","RCT CSP2",238, 0)
	13808	S REC=REC _"SLFIND"
	13809	"RTN","RCT CSP2",239, 0)
	13810	S REC=REC _$$BLANK(4 50-$L(REC) )
	13811	"RTN","RCT CSP2",240, 0)
	13812	S ^XTMP(" RCTCSPD",$ J,BILL,ACT ION,3)=REC
	13813	"RTN","RCT CSP2",241, 0)
	13814	S $P(^XTM P("RCTCSPD ",$J,"BILL ",ACTION,B ILL),U,1)= $$TAXID(DE BTOR)
	13815	"RTN","RCT CSP2",242, 0)
	13816	Q
	13817	"RTN","RCT CSP2",243, 0)
	13818	;
	13819	"RTN","RCT CSP2",244, 0)
	13820	DATE8(X) ; changes fi leman date into 8 di git date y yyymmdd
	13821	"RTN","RCT CSP2",245, 0)
	13822	I +X S X= X+17000000
	13823	"RTN","RCT CSP2",246, 0)
	13824	S X=$E(X, 1,8)
	13825	"RTN","RCT CSP2",247, 0)
	13826	Q X
	13827	"RTN","RCT CSP2",248, 0)
	13828	;
	13829	"RTN","RCT CSP2",249, 0)
	13830	AMOUNT(X) ;changes a mount to z ero filled , right ju stified
	13831	"RTN","RCT CSP2",250, 0)
	13832	S:X<0 X=- X
	13833	"RTN","RCT CSP2",251, 0)
	13834	S X=$TR($ J(X,0,2)," .")
	13835	"RTN","RCT CSP2",252, 0)
	13836	S X=$E("0 0000000000 0",1,14-$L (X))_X
	13837	"RTN","RCT CSP2",253, 0)
	13838	Q X
	13839	"RTN","RCT CSP2",254, 0)
	13840	;
	13841	"RTN","RCT CSP2",255, 0)
	13842	BLANK(X) ; returns 'x ' blank sp aces
	13843	"RTN","RCT CSP2",256, 0)
	13844	N BLANK
	13845	"RTN","RCT CSP2",257, 0)
	13846	S BLANK=" ",$P(BLANK ," ",X+1)= ""
	13847	"RTN","RCT CSP2",258, 0)
	13848	Q BLANK
	13849	"RTN","RCT CSP2",259, 0)
	13850	;
	13851	"RTN","RCT CSP2",260, 0)
	13852	RJZF(X,Y) ;right jus tify zero fill width Y
	13853	"RTN","RCT CSP2",261, 0)
	13854	S X=$E("0 0000000000 0",1,Y-$L( X))_X
	13855	"RTN","RCT CSP2",262, 0)
	13856	Q X
	13857	"RTN","RCT CSP2",263, 0)
	13858	;
	13859	"RTN","RCT CSP2",264, 0)
	13860	LJSF(X,Y) ;left just ified spac e filled
	13861	"RTN","RCT CSP2",265, 0)
	13862	S X=$E(X, 1,Y)
	13863	"RTN","RCT CSP2",266, 0)
	13864	S X=X_$$B LANK(Y-$L( X))
	13865	"RTN","RCT CSP2",267, 0)
	13866	Q X
	13867	"RTN","RCT CSP2",268, 0)
	13868	;
	13869	"RTN","RCT CSP2",269, 0)
	13870	LJZF(X,Y) ;x left ju stified, y zero fill ed
	13871	"RTN","RCT CSP2",270, 0)
	13872	S X=X_"00 00000000"
	13873	"RTN","RCT CSP2",271, 0)
	13874	S X=$E(X, X,Y)
	13875	"RTN","RCT CSP2",272, 0)
	13876	Q X
	13877	"RTN","RCT CSP2",273, 0)
	13878	;
	13879	"RTN","RCT CSP2",274, 0)
	13880	TAXID(DEBT OR) ;compu tes TAXID to place o n document s
	13881	"RTN","RCT CSP2",275, 0)
	13882	N TAXID,D IC,DA,DR,D IQ
	13883	"RTN","RCT CSP2",276, 0)
	13884	S TAXID=$ $SSN^RCFN0 1(DEBTOR)
	13885	"RTN","RCT CSP2",277, 0)
	13886	S TAXID=$ $LJSF(TAXI D,9)
	13887	"RTN","RCT CSP2",278, 0)
	13888	Q TAXID
	13889	"RTN","RCT CSP2",279, 0)
	13890	;
	13891	"RTN","RCT CSP2",280, 0)
	13892	DTFRMTO(PR OMPT) ;Get from and to dates (added as per PRCA4 .5315 to be able to
	13893	sort by d ates for r eports)
	13894	"RTN","RCT CSP2",281, 0)
	13895	;INPUT:
	13896	"RTN","RCT CSP2",282, 0)
	13897	; PROMP T - Messag e to displ ay prior t o promptin g for date s
	13898	"RTN","RCT CSP2",283, 0)
	13899	;OUTPUT:
	13900	"RTN","RCT CSP2",284, 0)
	13901	; 1^BE GDT^ENDDT - Data fou nd
	13902	"RTN","RCT CSP2",285, 0)
	13903	; 0 - User up arrowed or timed out
	13904	"RTN","RCT CSP2",286, 0)
	13905	;
	13906	"RTN","RCT CSP2",287, 0)
	13907	N %DT,Y,X ,BEGDT,END DT,DTOUT,O UT,DIRUT,D UOUT,DIROU T
	13908	"RTN","RCT CSP2",288, 0)
	13909	S OUT=0
	13910	"RTN","RCT CSP2",289, 0)
	13911	W !,$G(PR OMPT)
	13912	"RTN","RCT CSP2",290, 0)
	13913	S %DT="AE X"
	13914	"RTN","RCT CSP2",291, 0)
	13915	S %DT("A" )="Date Ra nge: FROM: " ;Enter Beginning Date: "
	13916	"RTN","RCT CSP2",292, 0)
	13917	S %DT("B" )="T-90"
	13918	"RTN","RCT CSP2",293, 0)
	13919	W !
	13920	"RTN","RCT CSP2",294, 0)
	13921	D ^%DT
	13922	"RTN","RCT CSP2",295, 0)
	13923	K %DT
	13924	"RTN","RCT CSP2",296, 0)
	13925	Q:Y<0 OUT ;Quit if user time out or di dn't enter valid dat e
	13926	"RTN","RCT CSP2",297, 0)
	13927	S DTFROM= +Y
	13928	"RTN","RCT CSP2",298, 0)
	13929	S %DT="AE X"
	13930	"RTN","RCT CSP2",299, 0)
	13931	S %DT("A" )=" TO: ",%DT(" B")="T" ;" TODAY"
	13932	"RTN","RCT CSP2",300, 0)
	13933	D ^%DT
	13934	"RTN","RCT CSP2",301, 0)
	13935	K %DT
	13936	"RTN","RCT CSP2",302, 0)
	13937	;Quit if user time out or did n't enter valid date
	13938	"RTN","RCT CSP2",303, 0)
	13939	Q:Y<0 OUT
	13940	"RTN","RCT CSP2",304, 0)
	13941	S DTTO=+Y
	13942	"RTN","RCT CSP2",305, 0)
	13943	S OUT=1_U _DTFROM_U_ DTTO
	13944	"RTN","RCT CSP2",306, 0)
	13945	;Switch d ates if Be gin Date i s more rec ent than E nd Date
	13946	"RTN","RCT CSP2",307, 0)
	13947	S:DTFROM> DTTO OUT=1 _U_DTTO_U_ DTFROM
	13948	"RTN","RCT CSP2",308, 0)
	13949	Q OUT
	13950	"RTN","RCT CSP2",309, 0)
	13951	;
	13952	"RTN","RCT CSP4")
	13953	0^15^B7571 7092
	13954	"RTN","RCT CSP4",1,0)
	13955	RCTCSP4 ;A LBANY/PAW- CS DEBT RE FERRAL STO P REACTIVA TE REPORTI NG ;07/15/ 14 3:34 PM
	13956	"RTN","RCT CSP4",2,0)
	13957	;;4.5;Acc ounts Rece ivable;3 15;Mar 2 0, 1995;Bu ild 2
	13958	"RTN","RCT CSP4",3,0)
	13959	;;Per VA Directive 6402, this routine s hould not be modifie d.
	13960	"RTN","RCT CSP4",4,0)
	13961	;
	13962	"RTN","RCT CSP4",5,0)
	13963	Q
	13964	"RTN","RCT CSP4",6,0)
	13965	;
	13966	"RTN","RCT CSP4",7,0)
	13967	EN ; for C ROSS SERVI CING STOP REACTIVATE REPORT pr ocessing
	13968	"RTN","RCT CSP4",8,0)
	13969	D INIT
	13970	"RTN","RCT CSP4",9,0)
	13971	S STOP=0
	13972	"RTN","RCT CSP4",10,0 )
	13973	D PROMPTS
	13974	"RTN","RCT CSP4",11,0 )
	13975	Q:STOP
	13976	"RTN","RCT CSP4",12,0 )
	13977	D HEADING
	13978	"RTN","RCT CSP4",13,0 )
	13979	D GETRECS
	13980	"RTN","RCT CSP4",14,0 )
	13981	D PRTRECS
	13982	"RTN","RCT CSP4",15,0 )
	13983	K %ZIS,AC TN,ASCDES, BILLID,BIL LIEN,BLNKS ,BY,CD,CDI EN,CDREC,C DSH,CHDR,C HDRS,CNTR,
	13984	COLDASH,CO LHDRS,COLW IDTH1
	13985	"RTN","RCT CSP4",16,0 )
	13986	K COLWIDT H2,COLWIDT H3,CWID,DA SH,DATA,DA TAITMS,DAT E,DEBTIDX, DEBTIEN,DE BTOR,DEBTR
	13987	EC,DEBTREF ,DEFAULT,D ESC,DHD,DI OBEG
	13988	"RTN","RCT CSP4",17,0 )
	13989	K DTFRM,D TFRMTO,DTF ROM,DTTO,E CDS,EXCEL, FIELD,FLDS ,FR,GROUPB D,HDTITLE, I,INCLUDE,
	13990	INDATE,L,L EV1,LEV2,L EV3,LEV4,L N
	13991	"RTN","RCT CSP4",18,0 )
	13992	K STPDATE ,OUT,PC,PA GE,POP,PRO MPT,QUIT,R CDTFROM,RC DTTO,RCRSN ,RCTRAN,RP TITEMS,RPT
	13993	REC,RPTTYP ,RCUSER,SE Q,SET,SRC
	13994	"RTN","RCT CSP4",19,0 )
	13995	K SSN,STO P,STR,TO,T YP,UPDN,RE C,RECW,REC W1,RECW2
	13996	"RTN","RCT CSP4",20,0 )
	13997	K ^XTMP(" RCTCSP4",$ J)
	13998	"RTN","RCT CSP4",21,0 )
	13999	Q
	14000	"RTN","RCT CSP4",22,0 )
	14001	;
	14002	"RTN","RCT CSP4",23,0 )
	14003	INIT ;
	14004	"RTN","RCT CSP4",24,0 )
	14005	K ^XTMP(" RCTCSP4",$ J)
	14006	"RTN","RCT CSP4",25,0 )
	14007	K REC
	14008	"RTN","RCT CSP4",26,0 )
	14009	S DASH="" ,$P(DASH," -",78)=""
	14010	"RTN","RCT CSP4",27,0 )
	14011	S BLNKS=" ",$P(BLNKS ," ",71)=" "
	14012	"RTN","RCT CSP4",28,0 )
	14013	S RPTITEM S="BILLID^ DEBTOR^SSN ^STPDATE^R CRSN^RCUSE R"
	14014	"RTN","RCT CSP4",29,0 )
	14015	Q
	14016	"RTN","RCT CSP4",30,0 )
	14017	;
	14018	"RTN","RCT CSP4",31,0 )
	14019	GETRECS ;
	14020	"RTN","RCT CSP4",32,0 )
	14021	N RCBILL, RCSTPDT
	14022	"RTN","RCT CSP4",33,0 )
	14023	S (RCDTFR OM)=$P(DTF RMTO,U,2)- 1,RCDTTO=$ P(DTFRMTO, U,3),RCBIL L=""
	14024	"RTN","RCT CSP4",34,0 )
	14025	F S RCBI LL=$O(^PRC A(430,"TCS P",RCBILL) ),BILLIEN= 0 Q:+RCBIL L=0 D
	14026	"RTN","RCT CSP4",35,0 )
	14027	. S RCSTP DT=$P($G(^ PRCA(430,R CBILL,15)) ,U,8)
	14028	"RTN","RCT CSP4",36,0 )
	14029	. I +RCST PDT=0 Q
	14030	"RTN","RCT CSP4",37,0 )
	14031	. I RCSTP DT>RCDTTO Q
	14032	"RTN","RCT CSP4",38,0 )
	14033	. I RCSTP DT<RCDTFRO M Q
	14034	"RTN","RCT CSP4",39,0 )
	14035	. S STPDA TE=$$FMTE^ XLFDT(RCST PDT,"5D")
	14036	"RTN","RCT CSP4",40,0 )
	14037	. S BILLI D=$P(^PRCA (430,RCBIL L,0),U)
	14038	"RTN","RCT CSP4",41,0 )
	14039	. S DEBTI EN=$P(^PRC A(430,RCBI LL,0),U,9)
	14040	"RTN","RCT CSP4",42,0 )
	14041	. S DEBTI DX=$P(^RCD (340,DEBTI EN,0),U)
	14042	"RTN","RCT CSP4",43,0 )
	14043	. S RCRSN =$P(^PRCA( 430,RCBILL ,15),U,9)
	14044	"RTN","RCT CSP4",44,0 )
	14045	. S RCUSE R="",RCTRA N=""
	14046	"RTN","RCT CSP4",45,0 )
	14047	. F S RC TRAN=$O(^P RCA(433,"C ",RCBILL,R CTRAN)) Q: RCTRAN="" D
	14048	"RTN","RCT CSP4",46,0 )
	14049	.. I $P($ G(^PRCA(43 3,RCTRAN,5 )),U,2)["C S Stop Pla ced" S RCU SER=$P(^PR CA(433,RCT
	14050	RAN,0),U,9 )
	14051	"RTN","RCT CSP4",47,0 )
	14052	.. S RCUS ER=$E($$GE T1^DIQ(200 ,RCUSER_", ",.01),1,1 5)
	14053	"RTN","RCT CSP4",48,0 )
	14054	. S DEBTR EF="^"_$P( DEBTIDX,"; ",2)_$P(DE BTIDX,";") _",0)"
	14055	"RTN","RCT CSP4",49,0 )
	14056	. S DEBTR EC=@(DEBTR EF)
	14057	"RTN","RCT CSP4",50,0 )
	14058	. S DEBTO R=$E($P(DE BTREC,U),1 ,19),SSN=$ E($P(DEBTR EC,U,4),4, 7)
	14059	"RTN","RCT CSP4",51,0 )
	14060	. ; gets record la yout based on RPTTY$ P and plac es into RP TTYP sorti ng sequenc
	14061	e
	14062	"RTN","RCT CSP4",52,0 )
	14063	. D @RPTT YP ;1=BILL NO. 2=DE BTOR 3=RE JECT DATE
	14064	"RTN","RCT CSP4",53,0 )
	14065	. Q
	14066	"RTN","RCT CSP4",54,0 )
	14067	S LEV1=""
	14068	"RTN","RCT CSP4",55,0 )
	14069	S CNTR=0
	14070	"RTN","RCT CSP4",56,0 )
	14071	K REC
	14072	"RTN","RCT CSP4",57,0 )
	14073	S UPDN=$S (ASCDES="D ":-1,1:1) ; determin es ASCendi ng or DeSC ending dir ection
	14074	"RTN","RCT CSP4",58,0 )
	14075	F S LEV1 =$O(^XTMP( "RCTCSP4", $J,"RPT",L EV1),UPDN) ,LEV2="" Q :LEV1="" D ;
	14076	"RTN","RCT CSP4",59,0 )
	14077	. F S LE V2=$O(^XTM P("RCTCSP4 ",$J,"RPT" ,LEV1,LEV2 ),UPDN),LE V3="" Q:LE V2="" D
	14078	;
	14079	"RTN","RCT CSP4",60,0 )
	14080	.. F S L EV3=$O(^XT MP("RCTCSP 4",$J,"RPT ",LEV1,LEV 2,LEV3),UP DN),LEV4=" " Q:LEV3="
	14081	" D ;
	14082	"RTN","RCT CSP4",61,0 )
	14083	... S RPT REC=^XTMP( "RCTCSP4", $J,"RPT",L EV1,LEV2,L EV3)
	14084	"RTN","RCT CSP4",62,0 )
	14085	... S CNT R=CNTR+1
	14086	"RTN","RCT CSP4",63,0 )
	14087	... S REC (CNTR)=$P( RPTREC,"^" ,1,$S(EXCE L:10,1:4))
	14088	"RTN","RCT CSP4",64,0 )
	14089	... I EXC EL S RECW1 =$E(REC(CN TR),1,70), RECW2=$TR( $E(REC(CNT R),71,999) ,"^","-"),
	14090	REC(CNTR)= RECW1_RECW 2
	14091	"RTN","RCT CSP4",65,0 )
	14092	... Q:EXC EL ; only needs single li ne string if in Exce l format
	14093	"RTN","RCT CSP4",66,0 )
	14094	... S REC W1=$E(REC( CNTR),1,70 ),RECW2=$T R($E(REC(C NTR),71,99 9),"^","-" ),REC(CNTR
	14095	)=RECW1_RE CW2
	14096	"RTN","RCT CSP4",67,0 )
	14097	... I $L( $P(RPTREC, "^",5,8)) D ;
	14098	"RTN","RCT CSP4",68,0 )
	14099	.... S CN TR=CNTR+1, REC(CNTR)= $E(BLNKS,1 ,69)_$TR($ P(RPTREC," ^",5,8),"^ ","-")
	14100	"RTN","RCT CSP4",69,0 )
	14101	... I $L( $P(RPTREC, "^",9)) D ;
	14102	"RTN","RCT CSP4",70,0 )
	14103	.... S CN TR=CNTR+1, REC(CNTR)= $E(BLNKS,1 ,69)_$P(RP TREC,"^",9 )
	14104	"RTN","RCT CSP4",71,0 )
	14105	M ^XTMP(" RCTCSP4",$ J,"REC")=R EC
	14106	"RTN","RCT CSP4",72,0 )
	14107	Q
	14108	"RTN","RCT CSP4",73,0 )
	14109	;
	14110	"RTN","RCT CSP4",74,0 )
	14111	1 ; for re port by 1) Bill Numb er
	14112	"RTN","RCT CSP4",75,0 )
	14113	S QUIT=0
	14114	"RTN","RCT CSP4",76,0 )
	14115	I EXCEL S RPTREC=BI LLID_U_DEB TOR_U_SSN_ U_STPDATE_ U_RCRSN_U_ RCUSER
	14116	"RTN","RCT CSP4",77,0 )
	14117	I 'EXCEL D Q:QUIT ;
	14118	"RTN","RCT CSP4",78,0 )
	14119	. S RPTRE C=""
	14120	"RTN","RCT CSP4",79,0 )
	14121	. F PC=1: 1:6 D Q:Q UIT ;
	14122	"RTN","RCT CSP4",80,0 )
	14123	.. S FIEL D=$P(RPTIT EMS,U,PC)
	14124	"RTN","RCT CSP4",81,0 )
	14125	.. S RPTR EC=RPTREC_ $E(@FIELD_ BLNKS,1,$P (COLWIDTH1 ,U,PC))
	14126	"RTN","RCT CSP4",82,0 )
	14127	S ^XTMP(" RCTCSP4",$ J,"RPT",BI LLID,RCSTP DT,DEBTOR) =RPTREC
	14128	"RTN","RCT CSP4",83,0 )
	14129	Q
	14130	"RTN","RCT CSP4",84,0 )
	14131	2 ; for re port by 2) Debtor Na me
	14132	"RTN","RCT CSP4",85,0 )
	14133	S QUIT=0
	14134	"RTN","RCT CSP4",86,0 )
	14135	I EXCEL S RPTREC=DE BTOR_U_BIL LID_U_SSN_ U_STPDATE_ U_RCRSN_U_ RCUSER
	14136	"RTN","RCT CSP4",87,0 )
	14137	I 'EXCEL D Q:QUIT ;
	14138	"RTN","RCT CSP4",88,0 )
	14139	. S RPTRE C=""
	14140	"RTN","RCT CSP4",89,0 )
	14141	. F PC=2, 1,3:1:6 D Q:QUIT ;
	14142	"RTN","RCT CSP4",90,0 )
	14143	.. S FIEL D=$P(RPTIT EMS,U,PC)
	14144	"RTN","RCT CSP4",91,0 )
	14145	.. S RPTR EC=RPTREC_ $E(@FIELD_ BLNKS,1,$P (COLWIDTH2 ,U,PC))
	14146	"RTN","RCT CSP4",92,0 )
	14147	S ^XTMP(" RCTCSP4",$ J,"RPT",DE BTOR,BILLI D,RCSTPDT) =RPTREC
	14148	"RTN","RCT CSP4",93,0 )
	14149	Q
	14150	"RTN","RCT CSP4",94,0 )
	14151	3 ; for re port by 3) CS Stop R eactivate Date
	14152	"RTN","RCT CSP4",95,0 )
	14153	S QUIT=0
	14154	"RTN","RCT CSP4",96,0 )
	14155	I EXCEL S RPTREC=ST PDATE_U_BI LLID_U_DEB TOR_U_SSN_ U_RCRSN_U_ RCUSER
	14156	"RTN","RCT CSP4",97,0 )
	14157	I 'EXCEL D Q:QUIT ;
	14158	"RTN","RCT CSP4",98,0 )
	14159	. S RPTRE C=""
	14160	"RTN","RCT CSP4",99,0 )
	14161	. F PC=4, 1:1:3,5,6 D Q:QUIT ;
	14162	"RTN","RCT CSP4",100, 0)
	14163	.. S FIEL D=$P(RPTIT EMS,U,PC)
	14164	"RTN","RCT CSP4",101, 0)
	14165	.. S RPTR EC=RPTREC_ $E(@$P(RPT ITEMS,U,PC )_BLNKS,1, $P(COLWIDT H3,U,PC))
	14166	"RTN","RCT CSP4",102, 0)
	14167	S ^XTMP(" RCTCSP4",$ J,"RPT",RC STPDT,BILL ID,DEBTOR) =RPTREC
	14168	"RTN","RCT CSP4",103, 0)
	14169	Q
	14170	"RTN","RCT CSP4",104, 0)
	14171	PRTRECS ; prints rep ort
	14172	"RTN","RCT CSP4",105, 0)
	14173	S PAGE=0
	14174	"RTN","RCT CSP4",106, 0)
	14175	D HEADING
	14176	"RTN","RCT CSP4",107, 0)
	14177	D REJREPH
	14178	"RTN","RCT CSP4",108, 0)
	14179	S LN=0
	14180	"RTN","RCT CSP4",109, 0)
	14181	F LN=1:1 Q:'$D(^XTM P("RCTCSP4 ",$J,"REC" ,LN)) D Q:$D(DIRUT )!$D(DUOUT )!$D(DTOUT
	14182	)
	14183	"RTN","RCT CSP4",110, 0)
	14184	. W ^XTMP ("RCTCSP4" ,$J,"REC", LN),!
	14185	"RTN","RCT CSP4",111, 0)
	14186	. ; ch eck for en d of page here, if n ecessary f orm feed a nd print h eader
	14187	"RTN","RCT CSP4",112, 0)
	14188	. I $Y+3> IOSL D
	14189	"RTN","RCT CSP4",113, 0)
	14190	.. I $E(I OST,1,2)=" C-" S DIR( 0)="E" K D IRUT D ^DI R Q:$D(DIR UT)!$D(DUO UT)!$D(DTO
	14191	UT)
	14192	"RTN","RCT CSP4",114, 0)
	14193	.. D REJR EPH
	14194	"RTN","RCT CSP4",115, 0)
	14195	. Q
	14196	"RTN","RCT CSP4",116, 0)
	14197	I $E(IOST ,1,2)="C-" R !!,"END OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @
	14198	IOF
	14199	"RTN","RCT CSP4",117, 0)
	14200	D ^%ZISC
	14201	"RTN","RCT CSP4",118, 0)
	14202	Q
	14203	"RTN","RCT CSP4",119, 0)
	14204	REJREPH ;
	14205	"RTN","RCT CSP4",120, 0)
	14206	U IO
	14207	"RTN","RCT CSP4",121, 0)
	14208	W @IOF
	14209	"RTN","RCT CSP4",122, 0)
	14210	S PAGE=PA GE+1
	14211	"RTN","RCT CSP4",123, 0)
	14212	W "PAGE " _PAGE,?10, HDTITLE,?6 3,$$UPPER^ VALM1($$FM TE^XLFDT(D T))
	14213	"RTN","RCT CSP4",124, 0)
	14214	W !,DASH, !,CHDR,!,C DSH,!
	14215	"RTN","RCT CSP4",125, 0)
	14216	Q
	14217	"RTN","RCT CSP4",126, 0)
	14218	COLHDR ; s ets report line base d on type of report
	14219	"RTN","RCT CSP4",127, 0)
	14220	S CHDR=CH DR_$P(COLH DRS,U,PC)_ $S(EXCEL:" ^",1:"")
	14221	"RTN","RCT CSP4",128, 0)
	14222	S CDSH=CD SH_$P(COLD ASH,U,PC)_ $S(EXCEL:" ^",1:"")
	14223	"RTN","RCT CSP4",129, 0)
	14224	Q
	14225	"RTN","RCT CSP4",130, 0)
	14226	HEADING ; compiles info for H eading and titles fo r cross-se rvicing st op reactiv
	14227	ate report
	14228	"RTN","RCT CSP4",131, 0)
	14229	S HDTITLE ="DEBT REF STOP REAC TIVATE RPT (SORT BY "_$P("BILL ^DEBTOR^ST OP DT",U,R
	14230	PTTYP)
	14231	"RTN","RCT CSP4",132, 0)
	14232	S HDTITLE =HDTITLE_" <"_$S(ASC DES="D":"D SC",1:"ASC ")_">)"
	14233	"RTN","RCT CSP4",133, 0)
	14234	;
	14235	"RTN","RCT CSP4",134, 0)
	14236	S COLWIDT H1="12^20^ 7^12^8^15"
	14237	"RTN","RCT CSP4",135, 0)
	14238	S COLWIDT H2="12^20^ 7^12^8^15"
	14239	"RTN","RCT CSP4",136, 0)
	14240	S COLWIDT H3="12^20^ 7^12^8^15"
	14241	"RTN","RCT CSP4",137, 0)
	14242	S COLHDRS ="BILL NUM BER ^DEBTO R NAME ^SSN ^STOP D ATE ^REA SON ^USER
	14243	ID"
	14244	"RTN","RCT CSP4",138, 0)
	14245	S COLDASH ="-------- --- ^----- ---------- ---- ^---- ^------ ---- ^--- --- ^----
	14246	---------- -"
	14247	"RTN","RCT CSP4",139, 0)
	14248	S (CHDR,C DSH,CWID)= ""
	14249	"RTN","RCT CSP4",140, 0)
	14250	I RPTTYP= 1 S CWID=C OLWIDTH1,C HDR=$S(EXC EL:COLHDRS ,1:$TR(COL HDRS,"^"," ")),CDSH=$
	14251	S(EXCEL:CO LDASH,1:$T R(COLDASH, "^",""))
	14252	"RTN","RCT CSP4",141, 0)
	14253	I RPTTYP= 2 F PC=2,1 ,3:1:6 D C OLHDR
	14254	"RTN","RCT CSP4",142, 0)
	14255	I RPTTYP= 3 F PC=4,1 :1:3,5,6 D COLHDR
	14256	"RTN","RCT CSP4",143, 0)
	14257	I EXCEL S CHDRS=$TR (CHDR," ", ""),CDSH=$ TR(CDSH," ","")
	14258	"RTN","RCT CSP4",144, 0)
	14259	Q
	14260	"RTN","RCT CSP4",145, 0)
	14261	PROMPTS ; Report pro mpts
	14262	"RTN","RCT CSP4",146, 0)
	14263	S STOP=0
	14264	"RTN","RCT CSP4",147, 0)
	14265	S PROMPT= "* DEBT REFERRAL S TOP REACTI VATE REPOR T *"
	14266	"RTN","RCT CSP4",148, 0)
	14267	S DTFRMTO =$$DTFRMTO (PROMPT) I 'DTFRMTO S STOP=1 Q
	14268	"RTN","RCT CSP4",149, 0)
	14269	;
	14270	"RTN","RCT CSP4",150, 0)
	14271	S SET="S^ 1:Bill Num ber;2:Debt or Name;3: CS Stop Da te"
	14272	"RTN","RCT CSP4",151, 0)
	14273	S RPTTYP= $$RPTTYP(" Select One of the Fo llowing:", SET) I 'RP TTYP S STO P=1 Q
	14274	"RTN","RCT CSP4",152, 0)
	14275	;
	14276	"RTN","RCT CSP4",153, 0)
	14277	S PROMPT= "Sort ASCE NDING or D ESCENDING"
	14278	"RTN","RCT CSP4",154, 0)
	14279	S DIR(0)= "SB^A:ASCE NDING;D:DE SCENDING"
	14280	"RTN","RCT CSP4",155, 0)
	14281	S DIR("L" )=PROMPT
	14282	"RTN","RCT CSP4",156, 0)
	14283	S ASCDES= $$SELECT(P ROMPT,"A") I "AD"'[A SCDES S ST OP=1 Q
	14284	"RTN","RCT CSP4",157, 0)
	14285	;
	14286	"RTN","RCT CSP4",158, 0)
	14287	S EXCEL=0
	14288	"RTN","RCT CSP4",159, 0)
	14289	S PROMPT= "CAPTURE R eport data to an Exc el Documen t?"
	14290	"RTN","RCT CSP4",160, 0)
	14291	S DIR(0)= "Y"
	14292	"RTN","RCT CSP4",161, 0)
	14293	S DIR("?" )="^D HEXC ^RCTCSJR"
	14294	"RTN","RCT CSP4",162, 0)
	14295	S EXCEL=$ $SELECT(PR OMPT,"NO") I "01"'[E XCEL S STO P=1 Q
	14296	"RTN","RCT CSP4",163, 0)
	14297	I EXCEL=1 D EXCMSG^ RCTCSJR ; Display Ex cel displa y message
	14298	"RTN","RCT CSP4",164, 0)
	14299	;
	14300	"RTN","RCT CSP4",165, 0)
	14301	S %ZIS="A EQ" D ^%ZI S I POP S STOP=1 Q
	14302	"RTN","RCT CSP4",166, 0)
	14303	I $D(IO(" Q")) D Q ;
	14304	"RTN","RCT CSP4",167, 0)
	14305	. S ZTSAV E("DEBTOR" )=""
	14306	"RTN","RCT CSP4",168, 0)
	14307	. S ZTRTN ="PRTRECS^ RCTCSJR",Z TDESC="CRO SS-SERVICI NG STOP RE ACTIVATE B ILL REPORT
	14308	"
	14309	"RTN","RCT CSP4",169, 0)
	14310	. D ^%ZTL OAD,^%ZISC
	14311	"RTN","RCT CSP4",170, 0)
	14312	. Q
	14313	"RTN","RCT CSP4",171, 0)
	14314	Q ; PROM PTS
	14315	"RTN","RCT CSP4",172, 0)
	14316	;
	14317	"RTN","RCT CSP4",173, 0)
	14318	SELECT(PRO MPT,DEFAUL T) ; promp ts for a s election
	14319	"RTN","RCT CSP4",174, 0)
	14320	;INPUT:
	14321	"RTN","RCT CSP4",175, 0)
	14322	; PROMP T - Messag e to displ ay prior t o promptin g for date s
	14323	"RTN","RCT CSP4",176, 0)
	14324	;OUTPUT:
	14325	"RTN","RCT CSP4",177, 0)
	14326	; 1^BE GDT^ENDDT - Data fou nd
	14327	"RTN","RCT CSP4",178, 0)
	14328	; 0 - User up arrowed or timed out
	14329	"RTN","RCT CSP4",179, 0)
	14330	;
	14331	"RTN","RCT CSP4",180, 0)
	14332	N Y,X,DTO UT,OUT,DIR UT,DUOUT,D IROUT ;BEG DT,ENDDT,
	14333	"RTN","RCT CSP4",181, 0)
	14334	S OUT=0
	14335	"RTN","RCT CSP4",182, 0)
	14336	W !
	14337	"RTN","RCT CSP4",183, 0)
	14338	S DIR("A" )=PROMPT
	14339	"RTN","RCT CSP4",184, 0)
	14340	S DIR("B" )=DEFAULT
	14341	"RTN","RCT CSP4",185, 0)
	14342	D ^DIR K DIR
	14343	"RTN","RCT CSP4",186, 0)
	14344	;Quit if user time out or did n't enter valid date
	14345	"RTN","RCT CSP4",187, 0)
	14346	Q:Y<0 OUT
	14347	"RTN","RCT CSP4",188, 0)
	14348	Q Y
	14349	"RTN","RCT CSP4",189, 0)
	14350	;
	14351	"RTN","RCT CSP4",190, 0)
	14352	RPTTYP(PRO MPT,SET) ; PRINT STOP REACTIVAT E REPORT; print repo rt, prints sorted in
	14353	dividual b ills that make up a cross-serv icing acco unt
	14354	"RTN","RCT CSP4",191, 0)
	14355	N DIC,ZTS AVE,ZTDESC ,ZTRTN,RCS ORT,X,Y
	14356	"RTN","RCT CSP4",192, 0)
	14357	S OUT=0
	14358	"RTN","RCT CSP4",193, 0)
	14359	W !
	14360	"RTN","RCT CSP4",194, 0)
	14361	S DIR(0)= SET ;"S^1: Bill Numbe r;2:Debtor Name;3:CS Stop Date "
	14362	"RTN","RCT CSP4",195, 0)
	14363	S DIR("A" )="Sort by "
	14364	"RTN","RCT CSP4",196, 0)
	14365	S DIR("B" )=1 D ^DIR K DIR
	14366	"RTN","RCT CSP4",197, 0)
	14367	Q:Y<0 OUT
	14368	"RTN","RCT CSP4",198, 0)
	14369	Q Y
	14370	"RTN","RCT CSP4",199, 0)
	14371	;
	14372	"RTN","RCT CSP4",200, 0)
	14373	DTFRMTO(PR OMPT) ;Get from and to dates
	14374	"RTN","RCT CSP4",201, 0)
	14375	;INPUT:
	14376	"RTN","RCT CSP4",202, 0)
	14377	; PROMP T - Messag e to displ ay prior t o promptin g for date s
	14378	"RTN","RCT CSP4",203, 0)
	14379	;OUTPUT:
	14380	"RTN","RCT CSP4",204, 0)
	14381	; 1^BE GDT^ENDDT - Data fou nd
	14382	"RTN","RCT CSP4",205, 0)
	14383	; 0 - User up arrowed or timed out
	14384	"RTN","RCT CSP4",206, 0)
	14385	;
	14386	"RTN","RCT CSP4",207, 0)
	14387	N %DT,Y,X ,BEGDT,END DT,DTOUT,O UT,DIRUT,D UOUT,DIROU T
	14388	"RTN","RCT CSP4",208, 0)
	14389	S OUT=0
	14390	"RTN","RCT CSP4",209, 0)
	14391	W !,$G(PR OMPT)
	14392	"RTN","RCT CSP4",210, 0)
	14393	S %DT="AE X"
	14394	"RTN","RCT CSP4",211, 0)
	14395	S %DT("A" )="Date Ra nge: FROM: " ;Enter Beginning Date: "
	14396	"RTN","RCT CSP4",212, 0)
	14397	S %DT("B" )="T-7"
	14398	"RTN","RCT CSP4",213, 0)
	14399	W !
	14400	"RTN","RCT CSP4",214, 0)
	14401	D ^%DT
	14402	"RTN","RCT CSP4",215, 0)
	14403	K %DT
	14404	"RTN","RCT CSP4",216, 0)
	14405	Q:Y<0 OUT ;Quit if user time out or di dn't enter valid dat e
	14406	"RTN","RCT CSP4",217, 0)
	14407	S DTFROM= +Y
	14408	"RTN","RCT CSP4",218, 0)
	14409	S %DT="AE X"
	14410	"RTN","RCT CSP4",219, 0)
	14411	S %DT("A" )=" TO: ",%DT(" B")="T" ;" TODAY"
	14412	"RTN","RCT CSP4",220, 0)
	14413	D ^%DT
	14414	"RTN","RCT CSP4",221, 0)
	14415	K %DT
	14416	"RTN","RCT CSP4",222, 0)
	14417	;Quit if user time out or did n't enter valid date
	14418	"RTN","RCT CSP4",223, 0)
	14419	Q:Y<0 OUT
	14420	"RTN","RCT CSP4",224, 0)
	14421	S DTTO=+Y
	14422	"RTN","RCT CSP4",225, 0)
	14423	S OUT=1_U _DTFROM_U_ DTTO
	14424	"RTN","RCT CSP4",226, 0)
	14425	;Switch d ates if Be gin Date i s more rec ent than E nd Date
	14426	"RTN","RCT CSP4",227, 0)
	14427	S:DTFROM> DTTO OUT=1 _U_DTTO_U_ DTFROM
	14428	"RTN","RCT CSP4",228, 0)
	14429	Q OUT
	14430	"RTN","RCT CSP4",229, 0)
	14431	;
	14432	"RTN","RCT CSP4",230, 0)
	14433	HEXC ; - ' Do you wan t to captu re data to EXCEL' pr ompt
	14434	"RTN","RCT CSP4",231, 0)
	14435	W !!," Enter: 'Y' - To capture detail re port data to transfe r"
	14436	"RTN","RCT CSP4",232, 0)
	14437	W !," to an Exce l document "
	14438	"RTN","RCT CSP4",233, 0)
	14439	W !," '<CR>' - To skip th is option"
	14440	"RTN","RCT CSP4",234, 0)
	14441	W !," '^' - To quit th is option"
	14442	"RTN","RCT CSP4",235, 0)
	14443	Q
	14444	"RTN","RCT CSP4",236, 0)
	14445	;
	14446	"RTN","RCT CSP4",237, 0)
	14447	EXCMSG ; - Displays the messag e about ca pturing to an Excel file forma t
	14448	"RTN","RCT CSP4",238, 0)
	14449	;
	14450	"RTN","RCT CSP4",239, 0)
	14451	W !!?5,"T o capture as an Exce l format, it is reco mmended th at you que ue this"
	14452	"RTN","RCT CSP4",240, 0)
	14453	W !?5,"re port to a spool devi ce with ma rgins of 2 56 and pag e length o f 99999"
	14454	"RTN","RCT CSP4",241, 0)
	14455	W !?5,"(e .g. spooln ame;256;99 999). This should he lp avoid w rapping pr oblems."
	14456	"RTN","RCT CSP4",242, 0)
	14457	W !!?5,"A nother met hod would be to set up your te rminal to capture th e detail"
	14458	"RTN","RCT CSP4",243, 0)
	14459	W !?5,"re port data. On some t erminals, this can b e done by invoking ' Logging'"
	14460	"RTN","RCT CSP4",244, 0)
	14461	W !?5,"or clicking on the 'To ols' menu above, the n click on 'Capture Incoming "
	14462	"RTN","RCT CSP4",245, 0)
	14463	W !?5,"Da ta' to sav e to Deskt op. To avo id undesir ed wrappin g of the d ata saved"
	14464	"RTN","RCT CSP4",246, 0)
	14465	W !?5,"to the file, change th e DISPLAY screen wid th size to 132 and y ou can"
	14466	"RTN","RCT CSP4",247, 0)
	14467	W !?5,"en ter '0;256 ;99999' at the 'DEVI CE:' promp t.",!
	14468	"RTN","RCT CSP4",248, 0)
	14469	Q
	14470	"RTN","RCT CSP4",249, 0)
	14471	; ======= ========== ========== ========== ========== ========== ========== =====
	14472	"RTN","RCT CSPU")
	14473	0^16^B5561 6924
	14474	"RTN","RCT CSPU",1,0)
	14475	RCTCSPU ;A LBANY/BDB- CROSS-SERV ICING UTIL ITIES ;03/ 15/14 3:34 PM
	14476	"RTN","RCT CSPU",2,0)
	14477	;;4.5;Acc ounts Rece ivable;3 01;Mar 2 0, 1995;Bu ild 2
	14478	"RTN","RCT CSPU",3,0)
	14479	;;Per VA Directive 6402, this routine s hould not be modifie d.
	14480	"RTN","RCT CSPU",4,0)
	14481	Q
	14482	"RTN","RCT CSPU",5,0)
	14483	;
	14484	"RTN","RCT CSPU",6,0)
	14485	;total am ount of bi lls for a debtor
	14486	"RTN","RCT CSPU",7,0)
	14487	TOTALB(DEB TOR) ;
	14488	"RTN","RCT CSPU",8,0)
	14489	N TOTAL,B ILL,B7
	14490	"RTN","RCT CSPU",9,0)
	14491	S TOTAL=0 ,BILL=0
	14492	"RTN","RCT CSPU",10,0 )
	14493	F S BILL =$O(^PRCA( 430,"C",DE BTOR,BILL) ) Q:BILL'? 1N.N D
	14494	"RTN","RCT CSPU",11,0 )
	14495	.Q:'$D(^P RCA(430,"T CSP",BILL) )
	14496	"RTN","RCT CSPU",12,0 )
	14497	.S B7=$G( ^PRCA(430, BILL,7))
	14498	"RTN","RCT CSPU",13,0 )
	14499	.S TOTAL= TOTAL+$P(B 7,U)+$P(B7 ,U,2)+$P(B 7,U,3)+$P( B7,U,4)+$P (B7,U,5)
	14500	"RTN","RCT CSPU",14,0 )
	14501	Q TOTAL
	14502	"RTN","RCT CSPU",15,0 )
	14503	;
	14504	"RTN","RCT CSPU",16,0 )
	14505	;stop TCS P referral on a bill
	14506	"RTN","RCT CSPU",17,0 )
	14507	STOP ;stop Cross-Ser vicing ref erral
	14508	"RTN","RCT CSPU",18,0 )
	14509	N DIC,DIE ,DA,DIR,Y, BILL,REASO N,COMMENT, EFFDT
	14510	"RTN","RCT CSPU",19,0 )
	14511	S DIC=430 ,DIC(0)="A EQM" D ^DI C Q:Y<0
	14512	"RTN","RCT CSPU",20,0 )
	14513	S BILL=+Y
	14514	"RTN","RCT CSPU",21,0 )
	14515	I $P($G(^ PRCA(430,B ILL,15)),U ,7) G DELS TOP
	14516	"RTN","RCT CSPU",22,0 )
	14517	W !,"Stop flag for Cross-Serv icing Refe rral set? : NO"
	14518	"RTN","RCT CSPU",23,0 )
	14519	S DIR(0)= "Y",DIR("B ")="NO",DI R("A")="Ar e you sure you want to stop th e Cross-Se
	14520	rvicing Re ferral for this bill " D ^DIR
	14521	"RTN","RCT CSPU",24,0 )
	14522	I 'Y W !, *7,"No act ion taken" Q
	14523	"RTN","RCT CSPU",25,0 )
	14524	;
	14525	"RTN","RCT CSPU",26,0 )
	14526	REASON ;as k referral reason
	14527	"RTN","RCT CSPU",27,0 )
	14528	K DIR S D IR("A")="E nter Stop Cross-Serv icing Reas on ",DA=BI LL,DIR(0)= "430,159"
	14529	D ^DIR
	14530	"RTN","RCT CSPU",28,0 )
	14531	Q:(Y="")! (Y=U)
	14532	"RTN","RCT CSPU",29,0 )
	14533	S REASON= Y I REASON ="O" D Q: COMMENT=U G REASON: COMMENT=""
	14534	"RTN","RCT CSPU",30,0 )
	14535	.S COM MENT="",DI R("A")="En ter Stop R eason Comm ent ",DA=B ILL,DIR(0) ="430,159.
	14536	1" D ^DIR S COMMENT= Y
	14537	"RTN","RCT CSPU",31,0 )
	14538	.I COM MENT="" W !,"A Reaso n of Other requires a comment to be ente red"
	14539	"RTN","RCT CSPU",32,0 )
	14540	.Q
	14541	"RTN","RCT CSPU",33,0 )
	14542	I REASON' ="O",$P($G (^PRCA(430 ,BILL,15)) ,U,10)'="" S $P(^(15 ),U,10)=""
	14543	"RTN","RCT CSPU",34,0 )
	14544	;
	14545	"RTN","RCT CSPU",35,0 )
	14546	;ask effe ctive date
	14547	"RTN","RCT CSPU",36,0 )
	14548	;
	14549	"RTN","RCT CSPU",37,0 )
	14550	S DIR(0)= "430,158", DA=BILL,DI R("A")="En ter Effect ive Date " D ^DIR G: Y=U STOPQ
	14551	S EFFDT=Y
	14552	"RTN","RCT CSPU",38,0 )
	14553	;
	14554	"RTN","RCT CSPU",39,0 )
	14555	STOPFILE ; set stop r eferral da ta in file 430
	14556	"RTN","RCT CSPU",40,0 )
	14557	S $P(^PRC A(430,BILL ,15),U,7,1 0)="1^"_EF FDT_U_REAS ON_U_$G(CO MMENT)
	14558	"RTN","RCT CSPU",41,0 )
	14559	;
	14560	"RTN","RCT CSPU",42,0 )
	14561	W !,"Stop Cross-Ser vicing Ref erral comp lete"
	14562	"RTN","RCT CSPU",43,0 )
	14563	G STOPQ
	14564	"RTN","RCT CSPU",44,0 )
	14565	;
	14566	"RTN","RCT CSPU",45,0 )
	14567	DELSTOP ;A llows Cros s-Servicin g Referral to be re- instituted for bill
	14568	"RTN","RCT CSPU",46,0 )
	14569	N I
	14570	"RTN","RCT CSPU",47,0 )
	14571	W !!,*7," Referral t o Cross-Se rvicing ha s already been stopp ed for thi s bill."
	14572	"RTN","RCT CSPU",48,0 )
	14573	W !,"Stop Cross-Ser vicing ref erral effe ctive date : ",$$GET1 ^DIQ(430,B ILL,158,"E
	14574	")
	14575	"RTN","RCT CSPU",49,0 )
	14576	W !,"Stop Cross-Ser vicing ref erral reas on : ",$$GET1 ^DIQ(430,B ILL,159,"E
	14577	")
	14578	"RTN","RCT CSPU",50,0 )
	14579	I $$GET1^ DIQ(430,BI LL,159,"E" )="OTHER" W !,"Stop Cross-Serv icing refe rral comme
	14580	nt : ",$$GET1^ DIQ(430,BI LL,159.1," E")
	14581	"RTN","RCT CSPU",51,0 )
	14582	S DIR(0)= "Y",DIR("A ")="Do you wish to r e-institut e Cross-Se rvicing Re ferral for
	14583	this bill ",DIR("B") ="NO" D ^D IR G EDSTO P:'Y
	14584	"RTN","RCT CSPU",52,0 )
	14585	;
	14586	"RTN","RCT CSPU",53,0 )
	14587	;reset fi le to allo w cross-se rvicing re ferral to be re-star ted
	14588	"RTN","RCT CSPU",54,0 )
	14589	F I=7:1:1 0 S $P(^PR CA(430,BIL L,15),U,I) =""
	14590	"RTN","RCT CSPU",55,0 )
	14591	W !!,"Bil l is now e ligible to be Referr ed to Cros s-Servicin g" G STOPQ
	14592	"RTN","RCT CSPU",56,0 )
	14593	;
	14594	"RTN","RCT CSPU",57,0 )
	14595	EDSTOP S D IR(0)="Y", DIR("A")=" Do you wis h to edit the Stop R eferral Da ta for thi
	14596	s bill",DI R("B")="NO " D ^DIR G REASON:Y
	14597	"RTN","RCT CSPU",58,0 )
	14598	STOPQ Q
	14599	"RTN","RCT CSPU",59,0 )
	14600	;
	14601	"RTN","RCT CSPU",60,0 )
	14602	;Set Cros s-Servicin g recall f or a bill
	14603	"RTN","RCT CSPU",61,0 )
	14604	RCLLSETB ; Set Cross- Servicing recall
	14605	"RTN","RCT CSPU",62,0 )
	14606	N DIC,DIE ,DA,DIR,Y, BILL,REASO N
	14607	"RTN","RCT CSPU",63,0 )
	14608	S DIC=430 ,DIC(0)="A EQM" D ^DI C Q:Y<0
	14609	"RTN","RCT CSPU",64,0 )
	14610	S BILL=+Y
	14611	"RTN","RCT CSPU",65,0 )
	14612	I $P($G(^ PRCA(430,B ILL,15)),U ,2) G DELS ETB
	14613	"RTN","RCT CSPU",66,0 )
	14614	S DIR(0)= "Y",DIR("B ")="NO",DI R("A")="Ar e you sure you want to set thi s bill to
	14615	be recalle d from Cro ss-Servici ng" D ^DIR
	14616	"RTN","RCT CSPU",67,0 )
	14617	I 'Y W !, *7,"No act ion taken" Q
	14618	"RTN","RCT CSPU",68,0 )
	14619	I '$D(^PR CA(430,"TC SP",BILL)) W !,*7,"N o action t aken. Bil l has not been refer
	14620	red to Cro ss-Servici ng." Q
	14621	"RTN","RCT CSPU",69,0 )
	14622	;
	14623	"RTN","RCT CSPU",70,0 )
	14624	RCRSB ;ask recall re ason
	14625	"RTN","RCT CSPU",71,0 )
	14626	K DIR S D IR(0)="S^0 1:DEBT REF ERRED IN E RROR;07:AG ENCY IS FO RGIVING DE BT;08:AGEN
	14627	CY CAN COL LECT THROU GH INTERNA L OFFSET" D ^DIR
	14628	"RTN","RCT CSPU",72,0 )
	14629	Q:(Y="")! (Y=U)
	14630	"RTN","RCT CSPU",73,0 )
	14631	;set reca ll data in file 430
	14632	"RTN","RCT CSPU",74,0 )
	14633	S REASON= Y
	14634	"RTN","RCT CSPU",75,0 )
	14635	S $P(^PRC A(430,BILL ,15),U,2,4 )="1^^"_RE ASON
	14636	"RTN","RCT CSPU",76,0 )
	14637	;
	14638	"RTN","RCT CSPU",77,0 )
	14639	W !,"Sett ing this b ill for Re call from Cross-Serv icing is c omplete"
	14640	"RTN","RCT CSPU",78,0 )
	14641	G SETBQ
	14642	"RTN","RCT CSPU",79,0 )
	14643	;
	14644	"RTN","RCT CSPU",80,0 )
	14645	DELSETB ;A llows Cros s-Servicin g Recall t o be delet ed for bil l
	14646	"RTN","RCT CSPU",81,0 )
	14647	W !!,*7," This bill has alread y been set for recal l from Cro ss-Servici ng."
	14648	"RTN","RCT CSPU",82,0 )
	14649	I +$P($G( ^PRCA(430, BILL,15)), U,3) W !!, "Not avail able for r eactivatio n. The Re
	14650	call reque st has alr eady been processed. " G SETBQ
	14651	"RTN","RCT CSPU",83,0 )
	14652	S DIR(0)= "Y",DIR("A ")="Do you wish to d elete the Cross-Serv icing Reca ll for thi
	14653	s bill",DI R("B")="NO " D ^DIR G EDSETB:'Y
	14654	"RTN","RCT CSPU",84,0 )
	14655	;
	14656	"RTN","RCT CSPU",85,0 )
	14657	;delete t he recall
	14658	"RTN","RCT CSPU",86,0 )
	14659	F I=2:1:5 S $P(^PRC A(430,BILL ,15),U,I)= ""
	14660	"RTN","RCT CSPU",87,0 )
	14661	W !!,"Rec all from C ross-Servi cing has b een delete d for this bill."
	14662	"RTN","RCT CSPU",88,0 )
	14663	G SETBQ
	14664	"RTN","RCT CSPU",89,0 )
	14665	;
	14666	"RTN","RCT CSPU",90,0 )
	14667	EDSETB S D IR(0)="Y", DIR("A")=" Do you wis h to edit the Recall data for this bill"
	14668	,DIR("B")= "NO" D ^DI R G RCRSB: Y
	14669	"RTN","RCT CSPU",91,0 )
	14670	SETBQ Q
	14671	"RTN","RCT CSPU",92,0 )
	14672	;
	14673	"RTN","RCT CSPU",93,0 )
	14674	;Set Cros s-Servicin g recall f or a debto r
	14675	"RTN","RCT CSPU",94,0 )
	14676	RCLLSETD ; Set Cross- Servicing debtor rec all
	14677	"RTN","RCT CSPU",95,0 )
	14678	N DIC,DIE ,DA,DIR,Y, DEBTOR,REA SON,BILL
	14679	"RTN","RCT CSPU",96,0 )
	14680	S DIC=340 ,DIC(0)="A EQM" D ^DI C Q:Y<0
	14681	"RTN","RCT CSPU",97,0 )
	14682	S DEBTOR= +Y
	14683	"RTN","RCT CSPU",98,0 )
	14684	I $P($G(^ RCD(340,DE BTOR,7)),U ,2),'$P($G (^RCD(340, DEBTOR,7)) ,U,3) G DE LSETD
	14685	"RTN","RCT CSPU",99,0 )
	14686	S DIR(0)= "Y",DIR("B ")="NO",DI R("A")="Ar e you sure you want to recall this debto
	14687	r and bill s from Cro ss-Servici ng" D ^DIR
	14688	"RTN","RCT CSPU",100, 0)
	14689	I 'Y W !, *7,"No act ion taken" Q
	14690	"RTN","RCT CSPU",101, 0)
	14691	I '$D(^RC D(340,"TCS P",DEBTOR) ) W !,*7," No action taken. De btor has n ot been re
	14692	ferred to Cross-Serv icing." Q
	14693	"RTN","RCT CSPU",102, 0)
	14694	;
	14695	"RTN","RCT CSPU",103, 0)
	14696	RCRSD ;ask debtor re call reaso n
	14697	"RTN","RCT CSPU",104, 0)
	14698	K DIR S D IR(0)="340 ,7.04" D ^ DIR
	14699	"RTN","RCT CSPU",105, 0)
	14700	Q:(Y="")! (Y=U)
	14701	"RTN","RCT CSPU",106, 0)
	14702	;set debt or recall data in fi le 340
	14703	"RTN","RCT CSPU",107, 0)
	14704	S REASON= Y
	14705	"RTN","RCT CSPU",108, 0)
	14706	S $P(^RCD (340,DEBTO R,7),U,2,4 )="1^^"_RE ASON
	14707	"RTN","RCT CSPU",109, 0)
	14708	;go throu gh debtor bills and set reason in the bi ll recall reason
	14709	"RTN","RCT CSPU",110, 0)
	14710	S BILL=0
	14711	"RTN","RCT CSPU",111, 0)
	14712	F S BILL =$O(^PRCA( 430,"C",DE BTOR,BILL) ) Q:BILL'? 1N.N D
	14713	"RTN","RCT CSPU",112, 0)
	14714	.I $D(^PR CA(430,"TC SP",BILL)) D Q ;bi ll previou sly sent t o TCSP
	14715	"RTN","RCT CSPU",113, 0)
	14716	..S $P(^P RCA(430,BI LL,15),U,4 )=REASON ; set the re call reaso n
	14717	"RTN","RCT CSPU",114, 0)
	14718	;
	14719	"RTN","RCT CSPU",115, 0)
	14720	W !,"Sett ing this d ebtor for Recall fro m Cross-Se rvicing is complete"
	14721	"RTN","RCT CSPU",116, 0)
	14722	G SETDQ
	14723	"RTN","RCT CSPU",117, 0)
	14724	;
	14725	"RTN","RCT CSPU",118, 0)
	14726	DELSETD ;A llows Cros s-Servicin g Recall t o be delet ed for deb tor
	14727	"RTN","RCT CSPU",119, 0)
	14728	W !!,*7," This debto r has alre ady been s et for rec all from C ross-Servi cing."
	14729	"RTN","RCT CSPU",120, 0)
	14730	S DIR(0)= "Y",DIR("A ")="Do you wish to d elete the Cross-Serv icing Reca ll for thi
	14731	s debtor", DIR("B")=" NO" D ^DIR G EDSETD: 'Y
	14732	"RTN","RCT CSPU",121, 0)
	14733	;
	14734	"RTN","RCT CSPU",122, 0)
	14735	;delete t he recall in file 34 0
	14736	"RTN","RCT CSPU",123, 0)
	14737	F I=2:1:4 S $P(^RCD (340,DEBTO R,7),U,I)= ""
	14738	"RTN","RCT CSPU",124, 0)
	14739	;go throu gh debtor bills and delete the reason in the bill recall rea son
	14740	"RTN","RCT CSPU",125, 0)
	14741	S BILL=0
	14742	"RTN","RCT CSPU",126, 0)
	14743	F S BILL =$O(^PRCA( 430,"C",DE BTOR,BILL) ) Q:BILL'? 1N.N D
	14744	"RTN","RCT CSPU",127, 0)
	14745	.I $D(^PR CA(430,"TC SP",BILL)) D Q ;bi ll previou sly sent t o TCSP
	14746	"RTN","RCT CSPU",128, 0)
	14747	..S $P(^P RCA(430,BI LL,15),U,4 )="" ;dele te the rec all reason
	14748	"RTN","RCT CSPU",129, 0)
	14749	;
	14750	"RTN","RCT CSPU",130, 0)
	14751	W !!,"Rec all from C ross-Servi cing has b een delete d for this debtor."
	14752	"RTN","RCT CSPU",131, 0)
	14753	G SETDQ
	14754	"RTN","RCT CSPU",132, 0)
	14755	;
	14756	"RTN","RCT CSPU",133, 0)
	14757	EDSETD S D IR(0)="Y", DIR("A")=" Do you wis h to edit the Recall data for this debto
	14758	r",DIR("B" )="NO" D ^ DIR G RCRS D:Y
	14759	"RTN","RCT CSPU",134, 0)
	14760	SETDQ Q
	14761	"RTN","RCT CSPU",135, 0)
	14762	;
	14763	"RTN","RCT CSPU",136, 0)
	14764	DECADJ(RCB ILLDA,RCTR ANDA) ;dec rease adju stment tra nsaction h istory for 5b cross-
	14765	servicing record
	14766	"RTN","RCT CSPU",137, 0)
	14767	;rcbillda - file 43 0 bill ien
	14768	"RTN","RCT CSPU",138, 0)
	14769	;rctranda - file 43 3 transact ion ien
	14770	"RTN","RCT CSPU",139, 0)
	14771	N DIC,DA, DIE,DR,Y,X
	14772	"RTN","RCT CSPU",140, 0)
	14773	I '$D(RCB ILLDA)!('$ D(RCTRANDA )) Q
	14774	"RTN","RCT CSPU",141, 0)
	14775	S X=RCTRA NDA
	14776	"RTN","RCT CSPU",142, 0)
	14777	S DIC="^P RCA(430,"_ RCBILLDA_" ,17,",DIC( 0)="L"
	14778	"RTN","RCT CSPU",143, 0)
	14779	I '$D(^PR CA(430,RCB ILLDA,17,0 )) S ^PRCA (430,RCBIL LDA,17,0)= "^430.0171 PA^0^0"
	14780	"RTN","RCT CSPU",144, 0)
	14781	S DIC("P" )=$P(^PRCA (430,RCBIL LDA,17,0), "^",2)
	14782	"RTN","RCT CSPU",145, 0)
	14783	S DA(1)=R CBILLDA
	14784	"RTN","RCT CSPU",146, 0)
	14785	D ^DIC I Y=-1 K DIC ,DA Q
	14786	"RTN","RCT CSPU",147, 0)
	14787	S DIE=DIC K DIC
	14788	"RTN","RCT CSPU",148, 0)
	14789	S DA=+Y
	14790	"RTN","RCT CSPU",149, 0)
	14791	S DR="1// //1" D ^DI E
	14792	"RTN","RCT CSPU",150, 0)
	14793	Q
	14794	"RTN","RCT CSPU",151, 0)
	14795	;
	14796	"RTN","RCT CSPU",152, 0)
	14797	;Set Cros s-Servicin g recall f or a case
	14798	"RTN","RCT CSPU",153, 0)
	14799	RCLLSETC ; Set Cross- Servicing recall for a case
	14800	"RTN","RCT CSPU",154, 0)
	14801	N DIC,DIE ,DA,DIR,Y, BILL,REASO N
	14802	"RTN","RCT CSPU",155, 0)
	14803	S DIC=430 ,DIC(0)="A EQM" D ^DI C Q:Y<0
	14804	"RTN","RCT CSPU",156, 0)
	14805	S BILL=+Y
	14806	"RTN","RCT CSPU",157, 0)
	14807	I $P($G(^ PRCA(430,B ILL,15)),U ,11) G DEL SETC
	14808	"RTN","RCT CSPU",158, 0)
	14809	S DIR(0)= "Y",DIR("B ")="NO",DI R("A")="Ar e you sure you want to set thi s case to
	14810	be recalle d from Cro ss-Servici ng" D ^DIR
	14811	"RTN","RCT CSPU",159, 0)
	14812	I 'Y W !, *7,"No act ion taken" Q
	14813	"RTN","RCT CSPU",160, 0)
	14814	I '$D(^PR CA(430,"TC SP",BILL)) W !,*7,"N o action t aken. Cas e has not been refer
	14815	red to Cro ss-Servici ng." Q
	14816	"RTN","RCT CSPU",161, 0)
	14817	;
	14818	"RTN","RCT CSPU",162, 0)
	14819	RCRSC ;set case reca ll reason
	14820	"RTN","RCT CSPU",163, 0)
	14821	;set reca ll data in file 430 for the bi ll and the case
	14822	"RTN","RCT CSPU",164, 0)
	14823	S REASON= 15
	14824	"RTN","RCT CSPU",165, 0)
	14825	S $P(^PRC A(430,BILL ,15),U,11, 13)="1^^"_ REASON
	14826	"RTN","RCT CSPU",166, 0)
	14827	S $P(^PRC A(430,BILL ,15),U,2,4 )="1^^"_RE ASON
	14828	"RTN","RCT CSPU",167, 0)
	14829	;
	14830	"RTN","RCT CSPU",168, 0)
	14831	W !,"Sett ing this c ase for Re call from Cross-Serv icing is c omplete"
	14832	"RTN","RCT CSPU",169, 0)
	14833	G SETCQ
	14834	"RTN","RCT CSPU",170, 0)
	14835	;
	14836	"RTN","RCT CSPU",171, 0)
	14837	DELSETC ;A llows Cros s-Servicin g Recall t o be delet ed for cas e
	14838	"RTN","RCT CSPU",172, 0)
	14839	W !!,*7," This case has alread y been set for recal l from Cro ss-Servici ng."
	14840	"RTN","RCT CSPU",173, 0)
	14841	S DIR(0)= "Y",DIR("A ")="Do you wish to d elete the Cross-Serv icing Reca ll for thi
	14842	s case",DI R("B")="NO " D ^DIR G SETCQ:'Y
	14843	"RTN","RCT CSPU",174, 0)
	14844	;
	14845	"RTN","RCT CSPU",175, 0)
	14846	;delete t he case re call
	14847	"RTN","RCT CSPU",176, 0)
	14848	F I=11:1: 13 S $P(^P RCA(430,BI LL,15),U,I )=""
	14849	"RTN","RCT CSPU",177, 0)
	14850	F I=2:1:5 S $P(^PRC A(430,BILL ,15),U,I)= ""
	14851	"RTN","RCT CSPU",178, 0)
	14852	W !!,"Rec all from C ross-Servi cing has b een delete d for this case."
	14853	"RTN","RCT CSPU",179, 0)
	14854	G SETCQ
	14855	"RTN","RCT CSPU",180, 0)
	14856	;
	14857	"RTN","RCT CSPU",181, 0)
	14858	SETCQ Q
	14859	"RTN","RCT CSPU",182, 0)
	14860	;
	14861	"VER")
	14862	8.0^22.0
	14863	INSTALL NAME
	14864	PSO7.046 3
	14865	"BLD",1018 9,0)
	14866	PSO7.046 3^OUTPATIE NT PHARMAC Y^0^317020 6^y
	14867	"BLD",1018 9,1,0)
	14868	^^253^253^ 3161212^
	14869	"BLD",1018 9,1,1,0)
	14870
	14871	"BLD",1018 9,1,2,0)
	14872	IMPORTANT INSTALLATI ON NOTE:
	14873	"BLD",1018 9,1,3,0)
	14874	---------- ---------- --------
	14875	"BLD",1018 9,1,4,0)
	14876	This patch is part o f a multi- package bu ild. There are three patches
	14877	"BLD",1018 9,1,5,0)
	14878	associated with the FY16 HAPE Revenue En hancement project - IB2.0568 ,
	14879	"BLD",1018 9,1,6,0)
	14880	PRCA4.53 15 and PSO 7.0463. All three patches ar e to be in stalled
	14881	"BLD",1018 9,1,7,0)
	14882	together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
	14883	"BLD",1018 9,1,8,0)
	14884
	14885	"BLD",1018 9,1,9,0)
	14886
	14887	"BLD",1018 9,1,10,0)
	14888	Descriptio n
	14889	"BLD",1018 9,1,11,0)
	14890	---------- -
	14891	"BLD",1018 9,1,12,0)
	14892	The Chief Business O ffice (CBO ) is reque sting syst em enhance ments to
	14893	"BLD",1018 9,1,13,0)
	14894	The Vetera ns Health Informatio n Systems and Techno logy Archi tecture
	14895	"BLD",1018 9,1,14,0)
	14896	(VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd
	14897	"BLD",1018 9,1,15,0)
	14898	Outpatient Pharmacy (PSO) soft ware modul es.
	14899	"BLD",1018 9,1,16,0)
	14900
	14901	"BLD",1018 9,1,17,0)
	14902	The missio n of the D epartment of Veteran s Affairs (VA), Offi ce of
	14903	"BLD",1018 9,1,18,0)
	14904	Informatio n & Techno logy (OI&T ), is to p rovide ben efits and services t o
	14905	"BLD",1018 9,1,19,0)
	14906	veterans o f the Unit ed States Armed Forc es. In mee ting these goals,
	14907	"BLD",1018 9,1,20,0)
	14908	OIT strive s to provi de high qu ality, eff ective, an d efficien t
	14909	"BLD",1018 9,1,21,0)
	14910	Informatio n Technolo gy (IT) se rvices to those resp onsible fo r providin g
	14911	"BLD",1018 9,1,22,0)
	14912	care to th e veterans at the po int-of-car e, as well as throug hout all
	14913	"BLD",1018 9,1,23,0)
	14914	the points of the ve terans' he alth care. The VA de pends on I nformation
	14915	"BLD",1018 9,1,24,0)
	14916	Management /Informati on Technol ogy (IM/IT ) systems to meet mi ssion
	14917	"BLD",1018 9,1,25,0)
	14918	goals.
	14919	"BLD",1018 9,1,26,0)
	14920
	14921	"BLD",1018 9,1,27,0)
	14922	The overal l FY16 HAP E Revenue Enhancemen t project has been f urther
	14923	"BLD",1018 9,1,28,0)
	14924	divided in to three s ub-project s:
	14925	"BLD",1018 9,1,29,0)
	14926
	14927	"BLD",1018 9,1,30,0)
	14928	NSR #20150 506
	14929	"BLD",1018 9,1,31,0)
	14930	The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the Chief
	14931	"BLD",1018 9,1,32,0)
	14932	Business O ffice (CBO ), bundles several N SRs with s imilar bus iness
	14933	"BLD",1018 9,1,33,0)
	14934	needs into a single requiremen ts documen t. Succes sfully add ressing
	14935	"BLD",1018 9,1,34,0)
	14936	the requir ements con tained wit hin this d ocument wi ll enable the
	14937	"BLD",1018 9,1,35,0)
	14938	Department of Vetera ns Affairs (VA) to a ppropriate ly bill ce rtain
	14939	"BLD",1018 9,1,36,0)
	14940	subsets of billable events by correcting , automati ng, or enh ancing
	14941	"BLD",1018 9,1,37,0)
	14942	current Ve terans Hea lth Inform ation Syst ems and Te chnology
	14943	"BLD",1018 9,1,38,0)
	14944	Architectu re (VistA) systems.
	14945	"BLD",1018 9,1,39,0)
	14946
	14947	"BLD",1018 9,1,40,0)
	14948	NSR #20150 507
	14949	"BLD",1018 9,1,41,0)
	14950	The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs, as
	14951	"BLD",1018 9,1,42,0)
	14952	well. This effort en ables the Department of Vetera ns Affairs (VA) to
	14953	"BLD",1018 9,1,43,0)
	14954	improve re venue oper ation func tionality related to repayment plans,
	14955	"BLD",1018 9,1,44,0)
	14956	late charg e capture, bill susp ension rea sons, the billing of
	14957	"BLD",1018 9,1,45,0)
	14958	deactivate d provider s, and the display o f appeal r ights and
	14959	"BLD",1018 9,1,46,0)
	14960	responsibi lities on the Vetera ns Benefic iary trave l Bill of Collection s
	14961	"BLD",1018 9,1,47,0)
	14962	form. Imp lementatio n of the p roposed en hancements will make a
	14963	"BLD",1018 9,1,48,0)
	14964	significan t positive impact on stakehold ers and ta rget users .
	14965	"BLD",1018 9,1,49,0)
	14966
	14967	"BLD",1018 9,1,50,0)
	14968	NSR #20150 505
	14969	"BLD",1018 9,1,51,0)
	14970	The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to
	14971	"BLD",1018 9,1,52,0)
	14972	improve tr acking and reporting of revenu e, and wil l support revenue
	14973	"BLD",1018 9,1,53,0)
	14974	reporting business r ules and g uidelines.
	14975	"BLD",1018 9,1,54,0)
	14976
	14977	"BLD",1018 9,1,55,0)
	14978
	14979	"BLD",1018 9,1,56,0)
	14980	PSO7.046 3 patch en hancements , pertinen t to the a bove NSRs, include:
	14981	"BLD",1018 9,1,57,0)
	14982
	14983	"BLD",1018 9,1,58,0)
	14984	1.) In the event of a Prescrip tion Reset Status/Ca ncel Charg es action,
	14985	"BLD",1018 9,1,59,0)
	14986	all automa tic prepay ment gener ation shal l be
	14987	"BLD",1018 9,1,60,0)
	14988	eliminated .
	14989	"BLD",1018 9,1,61,0)
	14990
	14991	"BLD",1018 9,1,62,0)
	14992	2.) All "c redit bala nces" that are autom atically g enerated i n the even t
	14993	"BLD",1018 9,1,63,0)
	14994	of a Presc ription Re set Status /Cancel Ch arges acti on exempti on to stop .
	14995	"BLD",1018 9,1,64,0)
	14996
	14997	"BLD",1018 9,1,65,0)
	14998	3.) A new on-demand List Manag er report will be ma de availab le for
	14999	"BLD",1018 9,1,66,0)
	15000	identifica tion of Pr escription resets.
	15001	"BLD",1018 9,1,67,0)
	15002
	15003	"BLD",1018 9,1,68,0)
	15004	4.) The ne w on-deman d report f or process ing Prescr iption Res ets will
	15005	"BLD",1018 9,1,69,0)
	15006	provide an option to generate a Summary Report and /or Detail ed Report.
	15007	"BLD",1018 9,1,70,0)
	15008
	15009	"BLD",1018 9,1,71,0)
	15010
	15011	"BLD",1018 9,1,72,0)
	15012
	15013	"BLD",1018 9,1,73,0)
	15014	Concurrent Developme nt / Depen dencies:
	15015	"BLD",1018 9,1,74,0)
	15016	---------- ---------- ---------- --------
	15017	"BLD",1018 9,1,75,0)
	15018	N/A
	15019	"BLD",1018 9,1,76,0)
	15020
	15021	"BLD",1018 9,1,77,0)
	15022
	15023	"BLD",1018 9,1,78,0)
	15024	Patch Comp onents:
	15025	"BLD",1018 9,1,79,0)
	15026	---------- -------
	15027	"BLD",1018 9,1,80,0)
	15028
	15029	"BLD",1018 9,1,81,0)
	15030	Files & Fi elds Assoc iated:
	15031	"BLD",1018 9,1,82,0)
	15032
	15033	"BLD",1018 9,1,83,0)
	15034	File Name (Number) Field Na me (Number ) New/ Modified/D eleted
	15035	"BLD",1018 9,1,84,0)
	15036	---------- -------- -------- ---------- - ---- ---------- ------
	15037	"BLD",1018 9,1,85,0)
	15038	N/A
	15039	"BLD",1018 9,1,86,0)
	15040
	15041	"BLD",1018 9,1,87,0)
	15042	Options As sociated:
	15043	"BLD",1018 9,1,88,0)
	15044
	15045	"BLD",1018 9,1,89,0)
	15046	Option Nam e Type New/ Modified/D eleted
	15047	"BLD",1018 9,1,90,0)
	15048	---------- - ---- ---- ---------- ------
	15049	"BLD",1018 9,1,91,0)
	15050	PSOCP RESE T COPAY ST ATUS LM ROUTINE NEW
	15051	"BLD",1018 9,1,92,0)
	15052
	15053	"BLD",1018 9,1,93,0)
	15054	Protocols Associated :
	15055	"BLD",1018 9,1,94,0)
	15056
	15057	"BLD",1018 9,1,95,0)
	15058	Protocol N ame New /Modified/ Deleted
	15059	"BLD",1018 9,1,96,0)
	15060	---------- --- --- ---------- -------
	15061	"BLD",1018 9,1,97,0)
	15062	PSO PATIEN T MED ACC PRO NEW
	15063	"BLD",1018 9,1,98,0)
	15064	PSO PATIEN T MED BILL PRO NEW
	15065	"BLD",1018 9,1,99,0)
	15066	PSO PATIEN T MED CANC EL NEW
	15067	"BLD",1018 9,1,100,0)
	15068	PSO PATIEN T MED EXPO RT NEW
	15069	"BLD",1018 9,1,101,0)
	15070	PSO PATIEN T MED PAT INQ NEW
	15071	"BLD",1018 9,1,102,0)
	15072	PSO PATIEN T MED RESE T NEW
	15073	"BLD",1018 9,1,103,0)
	15074	PSO PATIEN T MED TPJI NEW
	15075	"BLD",1018 9,1,104,0)
	15076	PSO PATIEN T MEDICATI ON MENU
	15077	"BLD",1018 9,1,105,0)
	15078
	15079	"BLD",1018 9,1,106,0)
	15080	Templates Associated :
	15081	"BLD",1018 9,1,107,0)
	15082
	15083	"BLD",1018 9,1,108,0)
	15084	Template N ame T ype File Name (Num ber) New/Mod/De l
	15085	"BLD",1018 9,1,109,0)
	15086	---------- --- - --- ---- ---------- ---- ---------- -
	15087	"BLD",1018 9,1,110,0)
	15088	PSO PATIEN T MEDICATI ON LIST L IST NEW
	15089	"BLD",1018 9,1,111,0)
	15090
	15091	"BLD",1018 9,1,112,0)
	15092	New Servic e Requests (NSRs):
	15093	"BLD",1018 9,1,113,0)
	15094	---------- ---------- --------
	15095	"BLD",1018 9,1,114,0)
	15096	20150505 - Revenue R eporting E nhancement s
	15097	"BLD",1018 9,1,115,0)
	15098	20150506 - Revenue E ligibility Enhanceme nts
	15099	"BLD",1018 9,1,116,0)
	15100	20150507 - Revenue O perations Enhancemen ts
	15101	"BLD",1018 9,1,117,0)
	15102
	15103	"BLD",1018 9,1,118,0)
	15104
	15105	"BLD",1018 9,1,119,0)
	15106	Patient Sa fety Issue s (PSIs):
	15107	"BLD",1018 9,1,120,0)
	15108	---------- ---------- ----------
	15109	"BLD",1018 9,1,121,0)
	15110	N/A
	15111	"BLD",1018 9,1,122,0)
	15112
	15113	"BLD",1018 9,1,123,0)
	15114
	15115	"BLD",1018 9,1,124,0)
	15116	Remedy Tic ket(s) & O verviews:
	15117	"BLD",1018 9,1,125,0)
	15118	---------- ---------- ---------
	15119	"BLD",1018 9,1,126,0)
	15120	N/A
	15121	"BLD",1018 9,1,127,0)
	15122
	15123	"BLD",1018 9,1,128,0)
	15124	Test Sites :
	15125	"BLD",1018 9,1,129,0)
	15126	----------
	15127	"BLD",1018 9,1,130,0)
	15128	Durham VAM C
	15129	"BLD",1018 9,1,131,0)
	15130
	15131	"BLD",1018 9,1,132,0)
	15132
	15133	"BLD",1018 9,1,133,0)
	15134	Software a nd Documen tation Ret rieval Ins tructions:
	15135	"BLD",1018 9,1,134,0)
	15136	---------- ---------- ---------- ---------- ---------- --
	15137	"BLD",1018 9,1,135,0)
	15138	Patches fo r this ins tallation are combin ed in host file
	15139	"BLD",1018 9,1,136,0)
	15140	IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
	15141	"BLD",1018 9,1,137,0)
	15142
	15143	"BLD",1018 9,1,138,0)
	15144	Installati on of this host file should be coordinat ed among t he package s
	15145	"BLD",1018 9,1,139,0)
	15146	affected s ince only one instal lation is necessary.
	15147	"BLD",1018 9,1,140,0)
	15148
	15149	"BLD",1018 9,1,141,0)
	15150	The patche s are:
	15151	"BLD",1018 9,1,142,0)
	15152
	15153	"BLD",1018 9,1,143,0)
	15154	IB2. 0568
	15155	"BLD",1018 9,1,144,0)
	15156	PRCA* 4.5*315
	15157	"BLD",1018 9,1,145,0)
	15158	PSO7 .0463
	15159	"BLD",1018 9,1,146,0)
	15160
	15161	"BLD",1018 9,1,147,0)
	15162
	15163	"BLD",1018 9,1,148,0)
	15164	Sites may retrieve t he KIDS bu ild in one of the fo llowing wa ys:
	15165	"BLD",1018 9,1,149,0)
	15166
	15167	"BLD",1018 9,1,150,0)
	15168	(1) The pr eferred me thod is to FTP the f iles from
	15169	"BLD",1018 9,1,151,0)
	15170	download. DNS . DNS which will transmit the files from the
	15171	"BLD",1018 9,1,152,0)
	15172	first avai lable FTP server.
	15173	"BLD",1018 9,1,153,0)
	15174
	15175	"BLD",1018 9,1,154,0)
	15176	(2) Sites may also e lect to re trieve the patch dir ectly from a specifi c
	15177	"BLD",1018 9,1,155,0)
	15178	server as follows:
	15179	"BLD",1018 9,1,156,0)
	15180
	15181	"BLD",1018 9,1,157,0)
	15182	OIFO FTP ADDRE SS DIRECTORY
	15183	"BLD",1018 9,1,158,0)
	15184	-------- ------ --------- ---------- ----- ---------- --------
	15185	"BLD",1018 9,1,159,0)
	15186	Albany ftp.fo-alb any. URL anonymous. software
	15187	"BLD",1018 9,1,160,0)
	15188	Hines ftp. DNS . URL anonymous. software
	15189	"BLD",1018 9,1,161,0)
	15190	Salt Lake City ftp.fo-slc . URL anonymous. software
	15191	"BLD",1018 9,1,162,0)
	15192
	15193	"BLD",1018 9,1,163,0)
	15194
	15195	"BLD",1018 9,1,164,0)
	15196	Sites may retrieve d ocumentati on directl y using Se cure File Transfer
	15197	"BLD",1018 9,1,165,0)
	15198	Protocol ( SFTP) from the ANONY MOUS.SOFTW ARE direct ory at the following
	15199	"BLD",1018 9,1,166,0)
	15200	OI Field O ffices:
	15201	"BLD",1018 9,1,167,0)
	15202
	15203	"BLD",1018 9,1,168,0)
	15204	Albany: fo-albany. URL
	15205	"BLD",1018 9,1,169,0)
	15206	Hines: DNS .U RL
	15207	"BLD",1018 9,1,170,0)
	15208	Salt Lake City: fo-slc. URL
	15209	"BLD",1018 9,1,171,0)
	15210
	15211	"BLD",1018 9,1,172,0)
	15212	Documentat ion can al so be foun d on the V A Software Documenta tion Libra ry
	15213	"BLD",1018 9,1,173,0)
	15214	at:
	15215	"BLD",1018 9,1,174,0)
	15216	http:// URL /
	15217	"BLD",1018 9,1,175,0)
	15218
	15219	"BLD",1018 9,1,176,0)
	15220	Title File Name FTP Mode
	15221	"BLD",1018 9,1,177,0)
	15222	---------- ---------- ---------- ---------- ---------- ---------- ---------
	15223	"BLD",1018 9,1,178,0)
	15224	Outpatient Pharmacy Technical Manual/Sec urity Guid e
	15225	"BLD",1018 9,1,179,0)
	15226	pso_7_tm.d oc Binary
	15227	"BLD",1018 9,1,180,0)
	15228	Outpatient Pharmacy Deployment , Installa tion,
	15229	"BLD",1018 9,1,181,0)
	15230	Back- Out, and R ollback Gu ide
	15231	"BLD",1018 9,1,182,0)
	15232	FY16Re venuePSOVI P_Deployme nt_Install ation_Guid e.doc
	15233	"BLD",1018 9,1,183,0)
	15234	Binary
	15235	"BLD",1018 9,1,184,0)
	15236
	15237	"BLD",1018 9,1,185,0)
	15238
	15239	"BLD",1018 9,1,186,0)
	15240
	15241	"BLD",1018 9,1,187,0)
	15242	Patch Inst allation:
	15243	"BLD",1018 9,1,188,0)
	15244
	15245	"BLD",1018 9,1,189,0)
	15246	Pre/Post I nstallatio n Overview :
	15247	"BLD",1018 9,1,190,0)
	15248	---------- ---------- ---------- -
	15249	"BLD",1018 9,1,191,0)
	15250	N/A
	15251	"BLD",1018 9,1,192,0)
	15252
	15253	"BLD",1018 9,1,193,0)
	15254	Pre-Instal lation Ins tructions:
	15255	"BLD",1018 9,1,194,0)
	15256	---------- ---------- ----------
	15257	"BLD",1018 9,1,195,0)
	15258	N/A
	15259	"BLD",1018 9,1,196,0)
	15260
	15261	"BLD",1018 9,1,197,0)
	15262	Installati on Instruc tions:
	15263	"BLD",1018 9,1,198,0)
	15264	---------- ---------- ------
	15265	"BLD",1018 9,1,199,0)
	15266	This proce ss will in stall new and update d routines and other
	15267	"BLD",1018 9,1,200,0)
	15268	components listed ab ove. There is a post -install r outine tha t will add
	15269	"BLD",1018 9,1,201,0)
	15270	entries to a number of files.
	15271	"BLD",1018 9,1,202,0)
	15272
	15273	"BLD",1018 9,1,203,0)
	15274	The patch will be re leased in conjunctio n with an Integrated Billing
	15275	"BLD",1018 9,1,204,0)
	15276	patch, IB* 4.5568, a nd an Outp atient Pha rmacy patc h, PSO7.0 *463.
	15277	"BLD",1018 9,1,205,0)
	15278
	15279	"BLD",1018 9,1,206,0)
	15280	****** ****** ** NOT E **** ****** ****
	15281	"BLD",1018 9,1,207,0)
	15282	IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS
	15283	"BLD",1018 9,1,208,0)
	15284	AN EDITE D ERROR WI LL OCCUR.
	15285	"BLD",1018 9,1,209,0)
	15286	The patc h should b e installe d when NO Outpatient
	15287	"BLD",1018 9,1,210,0)
	15288	Pharmacy users are on the sy stem.
	15289	"BLD",1018 9,1,211,0)
	15290	****** ****** ****** ****** ****** ****
	15291	"BLD",1018 9,1,212,0)
	15292
	15293	"BLD",1018 9,1,213,0)
	15294	Installat ion will t ake less t han 1 minu te.
	15295	"BLD",1018 9,1,214,0)
	15296
	15297	"BLD",1018 9,1,215,0)
	15298	Suggested time to i nstall: no n-peak req uirement h ours.
	15299	"BLD",1018 9,1,216,0)
	15300
	15301	"BLD",1018 9,1,217,0)
	15302
	15303	"BLD",1018 9,1,218,0)
	15304	1. Obtai n the file IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID
	15305	"BLD",1018 9,1,219,0)
	15306
	15307	"BLD",1018 9,1,220,0)
	15308	2. From the Kernel Installat ion & Dist ribution S ystem menu , select
	15309	"BLD",1018 9,1,221,0)
	15310	the I nstallatio n menu.
	15311	"BLD",1018 9,1,222,0)
	15312
	15313	"BLD",1018 9,1,223,0)
	15314	3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
	15315	"BLD",1018 9,1,224,0)
	15316	promp ted to Ent er a Host File name. You may need to ap pend a
	15317	"BLD",1018 9,1,225,0)
	15318	direc tory name.
	15319	"BLD",1018 9,1,226,0)
	15320
	15321	"BLD",1018 9,1,227,0)
	15322	4. From this menu, you may s elect to u se the fol lowing opt ions
	15323	"BLD",1018 9,1,228,0)
	15324	(when prompted for INSTAL L NAME, en ter IB2.0 568):
	15325	"BLD",1018 9,1,229,0)
	15326	a . Verify Checksums in Transpo rt Global - This opt ion will
	15327	"BLD",1018 9,1,230,0)
	15328	allow y ou to ensu re the int egrity of the routin es that
	15329	"BLD",1018 9,1,231,0)
	15330	are in the transp ort global .
	15331	"BLD",1018 9,1,232,0)
	15332	b . Print T ransport G lobal - Th is option will allow you to
	15333	"BLD",1018 9,1,233,0)
	15334	view th e componen ts of the KIDS build .
	15335	"BLD",1018 9,1,234,0)
	15336	c . Compare Transport Global to Current S ystem - Th is option
	15337	"BLD",1018 9,1,235,0)
	15338	will al low you to view all changes th at will be made when
	15339	"BLD",1018 9,1,236,0)
	15340	this pa tch is ins talled. I t compares all compo nents of
	15341	"BLD",1018 9,1,237,0)
	15342	this pa tch (routi nes, DD's, templates , etc.).
	15343	"BLD",1018 9,1,238,0)
	15344	d . Backup a Transpor t Global - This opti on will cr eate a
	15345	"BLD",1018 9,1,239,0)
	15346	backup message of any routi nes export ed with th is patch.
	15347	"BLD",1018 9,1,240,0)
	15348	It will not backu p any othe r changes such as DD 's or
	15349	"BLD",1018 9,1,241,0)
	15350	templat es.
	15351	"BLD",1018 9,1,242,0)
	15352
	15353	"BLD",1018 9,1,243,0)
	15354	5. When prompted " Want KIDS to INHIBIT LOGONs du ring the i nstall?
	15355	"BLD",1018 9,1,244,0)
	15356	NO//" respond N O.
	15357	"BLD",1018 9,1,245,0)
	15358
	15359	"BLD",1018 9,1,246,0)
	15360	6. When prompted " Want to DI SABLE Sche duled Opti ons, Menu Options,
	15361	"BLD",1018 9,1,247,0)
	15362	and P rotocols? NO//" resp ond NO.
	15363	"BLD",1018 9,1,248,0)
	15364
	15365	"BLD",1018 9,1,249,0)
	15366
	15367	"BLD",1018 9,1,250,0)
	15368
	15369	"BLD",1018 9,1,251,0)
	15370	Post-Insta llation In structions :
	15371	"BLD",1018 9,1,252,0)
	15372	---------- ---------- ---------- -
	15373	"BLD",1018 9,1,253,0)
	15374	There are no special tasks to perform af ter this p atch insta llation.
	15375	"BLD",1018 9,4,0)
	15376	^9.64PA^^
	15377	"BLD",1018 9,6.3)
	15378	2
	15379	"BLD",1018 9,"ABPKG")
	15380	n
	15381	"BLD",1018 9,"INID")
	15382	n^n^n
	15383	"BLD",1018 9,"KRN",0)
	15384	^9.67PA^77 9.2^20
	15385	"BLD",1018 9,"KRN",.4 ,0)
	15386	.4
	15387	"BLD",1018 9,"KRN",.4 01,0)
	15388	.401
	15389	"BLD",1018 9,"KRN",.4 02,0)
	15390	.402
	15391	"BLD",1018 9,"KRN",.4 03,0)
	15392	.403
	15393	"BLD",1018 9,"KRN",.5 ,0)
	15394	.5
	15395	"BLD",1018 9,"KRN",.8 4,0)
	15396	.84
	15397	"BLD",1018 9,"KRN",3. 6,0)
	15398	3.6
	15399	"BLD",1018 9,"KRN",3. 8,0)
	15400	3.8
	15401	"BLD",1018 9,"KRN",9. 2,0)
	15402	9.2
	15403	"BLD",1018 9,"KRN",9. 8,0)
	15404	9.8
	15405	"BLD",1018 9,"KRN",9. 8,"NM",0)
	15406	^9.68A^4^4
	15407	"BLD",1018 9,"KRN",9. 8,"NM",1,0 )
	15408	PSOCPB^^0^ B84712258
	15409	"BLD",1018 9,"KRN",9. 8,"NM",2,0 )
	15410	PSOCPF^^0^ B63370420
	15411	"BLD",1018 9,"KRN",9. 8,"NM",3,0 )
	15412	PSOCPF1^^0 ^B40079369
	15413	"BLD",1018 9,"KRN",9. 8,"NM",4,0 )
	15414	PSOCPF2^^0 ^B17984601
	15415	"BLD",1018 9,"KRN",9. 8,"NM","B" ,"PSOCPB", 1)
	15416
	15417	"BLD",1018 9,"KRN",9. 8,"NM","B" ,"PSOCPF", 2)
	15418
	15419	"BLD",1018 9,"KRN",9. 8,"NM","B" ,"PSOCPF1" ,3)
	15420
	15421	"BLD",1018 9,"KRN",9. 8,"NM","B" ,"PSOCPF2" ,4)
	15422
	15423	"BLD",1018 9,"KRN",19 ,0)
	15424	19
	15425	"BLD",1018 9,"KRN",19 ,"NM",0)
	15426	^9.68A^1^1
	15427	"BLD",1018 9,"KRN",19 ,"NM",1,0)
	15428	PSOCP RESE T COPAY ST ATUS LM^^0
	15429	"BLD",1018 9,"KRN",19 ,"NM","B", "PSOCP RES ET COPAY S TATUS LM", 1)
	15430
	15431	"BLD",1018 9,"KRN",19 .1,0)
	15432	19.1
	15433	"BLD",1018 9,"KRN",10 1,0)
	15434	101
	15435	"BLD",1018 9,"KRN",10 1,"NM",0)
	15436	^9.68A^8^8
	15437	"BLD",1018 9,"KRN",10 1,"NM",1,0 )
	15438	PSO PATIEN T MEDICATI ON MENU^^0
	15439	"BLD",1018 9,"KRN",10 1,"NM",2,0 )
	15440	PSO PATIEN T MED ACC PRO^^0
	15441	"BLD",1018 9,"KRN",10 1,"NM",3,0 )
	15442	PSO PATIEN T MED BILL PRO^^0
	15443	"BLD",1018 9,"KRN",10 1,"NM",4,0 )
	15444	PSO PATIEN T MED PAT INQ^^0
	15445	"BLD",1018 9,"KRN",10 1,"NM",5,0 )
	15446	PSO PATIEN T MED TPJI ^^0
	15447	"BLD",1018 9,"KRN",10 1,"NM",6,0 )
	15448	PSO PATIEN T MED CANC EL^^0
	15449	"BLD",1018 9,"KRN",10 1,"NM",7,0 )
	15450	PSO PATIEN T MED RESE T^^0
	15451	"BLD",1018 9,"KRN",10 1,"NM",8,0 )
	15452	PSO PATIEN T MED EXPO RT^^0
	15453	"BLD",1018 9,"KRN",10 1,"NM","B" ,"PSO PATI ENT MED AC C PRO",2)
	15454
	15455	"BLD",1018 9,"KRN",10 1,"NM","B" ,"PSO PATI ENT MED BI LL PRO",3)
	15456
	15457	"BLD",1018 9,"KRN",10 1,"NM","B" ,"PSO PATI ENT MED CA NCEL",6)
	15458
	15459	"BLD",1018 9,"KRN",10 1,"NM","B" ,"PSO PATI ENT MED EX PORT",8)
	15460
	15461	"BLD",1018 9,"KRN",10 1,"NM","B" ,"PSO PATI ENT MED PA T INQ",4)
	15462
	15463	"BLD",1018 9,"KRN",10 1,"NM","B" ,"PSO PATI ENT MED RE SET",7)
	15464
	15465	"BLD",1018 9,"KRN",10 1,"NM","B" ,"PSO PATI ENT MED TP JI",5)
	15466
	15467	"BLD",1018 9,"KRN",10 1,"NM","B" ,"PSO PATI ENT MEDICA TION MENU" ,1)
	15468
	15469	"BLD",1018 9,"KRN",40 9.61,0)
	15470	409.61
	15471	"BLD",1018 9,"KRN",40 9.61,"NM", 0)
	15472	^9.68A^1^1
	15473	"BLD",1018 9,"KRN",40 9.61,"NM", 1,0)
	15474	PSO PATIEN T MEDICATI ON LIST^^0
	15475	"BLD",1018 9,"KRN",40 9.61,"NM", "B","PSO P ATIENT MED ICATION LI ST",1)
	15476
	15477	"BLD",1018 9,"KRN",77 1,0)
	15478	771
	15479	"BLD",1018 9,"KRN",77 9.2,0)
	15480	779.2
	15481	"BLD",1018 9,"KRN",87 0,0)
	15482	870
	15483	"BLD",1018 9,"KRN",89 89.51,0)
	15484	8989.51
	15485	"BLD",1018 9,"KRN",89 89.52,0)
	15486	8989.52
	15487	"BLD",1018 9,"KRN",89 94,0)
	15488	8994
	15489	"BLD",1018 9,"KRN","B ",.4,.4)
	15490
	15491	"BLD",1018 9,"KRN","B ",.401,.40 1)
	15492
	15493	"BLD",1018 9,"KRN","B ",.402,.40 2)
	15494
	15495	"BLD",1018 9,"KRN","B ",.403,.40 3)
	15496
	15497	"BLD",1018 9,"KRN","B ",.5,.5)
	15498
	15499	"BLD",1018 9,"KRN","B ",.84,.84)
	15500
	15501	"BLD",1018 9,"KRN","B ",3.6,3.6)
	15502
	15503	"BLD",1018 9,"KRN","B ",3.8,3.8)
	15504
	15505	"BLD",1018 9,"KRN","B ",9.2,9.2)
	15506
	15507	"BLD",1018 9,"KRN","B ",9.8,9.8)
	15508
	15509	"BLD",1018 9,"KRN","B ",19,19)
	15510
	15511	"BLD",1018 9,"KRN","B ",19.1,19. 1)
	15512
	15513	"BLD",1018 9,"KRN","B ",101,101)
	15514
	15515	"BLD",1018 9,"KRN","B ",409.61,4 09.61)
	15516
	15517	"BLD",1018 9,"KRN","B ",771,771)
	15518
	15519	"BLD",1018 9,"KRN","B ",779.2,77 9.2)
	15520
	15521	"BLD",1018 9,"KRN","B ",870,870)
	15522
	15523	"BLD",1018 9,"KRN","B ",8989.51, 8989.51)
	15524
	15525	"BLD",1018 9,"KRN","B ",8989.52, 8989.52)
	15526
	15527	"BLD",1018 9,"KRN","B ",8994,899 4)
	15528
	15529	"BLD",1018 9,"QDEF")
	15530	^^^^NO^^^^ NO^^NO
	15531	"BLD",1018 9,"QUES",0 )
	15532	^9.62^^
	15533	"BLD",1018 9,"REQB",0 )
	15534	^9.611^^
	15535	"KRN",19,1 1652,-1)
	15536	0^1
	15537	"KRN",19,1 1652,0)
	15538	PSOCP RESE T COPAY ST ATUS LM^Re set Copay Status Lis t Manager^ ^R^^^^^^^^ OUTPATIENT
	15539	PHARMACY
	15540	"KRN",19,1 1652,1,0)
	15541	^^2^2^3160 901^
	15542	"KRN",19,1 1652,1,1,0 )
	15543	This list manager wi ll allow t he users t o reset ph armacy cop ay status and
	15544	"KRN",19,1 1652,1,2,0 )
	15545	to cancel copay char ges easier .
	15546	"KRN",19,1 1652,25)
	15547	EN^PSOCPF
	15548	"KRN",19,1 1652,"U")
	15549	RESET COPA Y STATUS L IST MANAGE
	15550	"KRN",101, 4763,-1)
	15551	0^1
	15552	"KRN",101, 4763,0)
	15553	PSO PATIEN T MEDICATI ON MENU^PS OCP MEDICA TION COPAY LM^^M^^^^ ^^^^OUTPAT IENT PHARM
	15554	ACY
	15555	"KRN",101, 4763,4)
	15556	26^3
	15557	"KRN",101, 4763,10,0)
	15558	^101.01PA^ 8^8
	15559	"KRN",101, 4763,10,1, 0)
	15560	4764^RE^11 ^^^Reset S tatus
	15561	"KRN",101, 4763,10,1, "^")
	15562	PSO PATIEN T MED RESE T
	15563	"KRN",101, 4763,10,2, 0)
	15564	4765^CA^12 ^^^Cancel Payment
	15565	"KRN",101, 4763,10,2, "^")
	15566	PSO PATIEN T MED CANC EL
	15567	"KRN",101, 4763,10,3, 0)
	15568	4766^EC^13 ^^^Excel R eport
	15569	"KRN",101, 4763,10,3, "^")
	15570	PSO PATIEN T MED EXPO RT
	15571	"KRN",101, 4763,10,4, 0)
	15572	4959^AP^21 ^^^Account Profile
	15573	"KRN",101, 4763,10,4, "^")
	15574	PSO PATIEN T MED ACC PRO
	15575	"KRN",101, 4763,10,6, 0)
	15576	4961^TP^32 ^^^Third P arty
	15577	"KRN",101, 4763,10,6, "^")
	15578	PSO PATIEN T MED TPJI
	15579	"KRN",101, 4763,10,7, 0)
	15580	4962^PI^23 ^^^Patient Inquiry
	15581	"KRN",101, 4763,10,7, "^")
	15582	PSO PATIEN T MED PAT INQ
	15583	"KRN",101, 4763,10,8, 0)
	15584	4963^BP^31 ^^^Bill Pr ofile
	15585	"KRN",101, 4763,10,8, "^")
	15586	PSO PATIEN T MED BILL PRO
	15587	"KRN",101, 4763,26)
	15588	D SHOW^VAL M
	15589	"KRN",101, 4763,28)
	15590	Select Act ion:
	15591	"KRN",101, 4763,99)
	15592	64299,5462 6
	15593	"KRN",101, 4764,-1)
	15594	0^7
	15595	"KRN",101, 4764,0)
	15596	PSO PATIEN T MED RESE T^PSO PATI ENT MED RE SET^^A^^^^ ^^^^OUTPAT IENT PHARM ACY
	15597	"KRN",101, 4764,20)
	15598	D RESET^PS OCPF1
	15599	"KRN",101, 4764,99)
	15600	64299,5462 6
	15601	"KRN",101, 4765,-1)
	15602	0^6
	15603	"KRN",101, 4765,0)
	15604	PSO PATIEN T MED CANC EL^PSO PAT IENT MED C ANCEL CHAR GE^^A^^^^^ ^^^
	15605	"KRN",101, 4765,20)
	15606	D CANCEL^P SOCPF1
	15607	"KRN",101, 4765,99)
	15608	64299,5462 6
	15609	"KRN",101, 4766,-1)
	15610	0^8
	15611	"KRN",101, 4766,0)
	15612	PSO PATIEN T MED EXPO RT^PSO PAT IENT MED E XCEL REPOR T^^A^^^^^^ ^^
	15613	"KRN",101, 4766,20)
	15614	D EXPORT^P SOCPF1
	15615	"KRN",101, 4766,99)
	15616	64299,5462 6
	15617	"KRN",101, 4959,-1)
	15618	0^2
	15619	"KRN",101, 4959,0)
	15620	PSO PATIEN T MED ACC PRO^PSO PA TIENT ACCO UNT PROFIL E^^A^^^^^^ ^^OUTPATIE NT PHARMAC
	15621	Y
	15622	"KRN",101, 4959,2,0)
	15623	^101.02A^^ 0
	15624	"KRN",101, 4959,20)
	15625	D PATACP^P SOCPF2
	15626	"KRN",101, 4959,99)
	15627	64299,5462 6
	15628	"KRN",101, 4961,-1)
	15629	0^5
	15630	"KRN",101, 4961,0)
	15631	PSO PATIEN T MED TPJI ^PSO PATIE NT MED TPJ I^^A^^^^^^ ^^OUTPATIE NT PHARMAC Y
	15632	"KRN",101, 4961,2,0)
	15633	^101.02A^^ 0
	15634	"KRN",101, 4961,20)
	15635	D TPJI^PSO CPF2
	15636	"KRN",101, 4961,99)
	15637	64299,5462 6
	15638	"KRN",101, 4962,-1)
	15639	0^4
	15640	"KRN",101, 4962,0)
	15641	PSO PATIEN T MED PAT INQ^PSO PA TIENT PATI ENT INQ^^A ^^^^^^^^OU TPATIENT P HARMACY
	15642	"KRN",101, 4962,2,0)
	15643	^101.02A^^ 0
	15644	"KRN",101, 4962,20)
	15645	D PATINQ^P SOCPF2
	15646	"KRN",101, 4962,99)
	15647	64299,5462 6
	15648	"KRN",101, 4963,-1)
	15649	0^3
	15650	"KRN",101, 4963,0)
	15651	PSO PATIEN T MED BILL PRO^PSO P ATIENT BIL L PROFILE^ ^A^^^^^^^^ OUTPATIENT PHARMACY
	15652	"KRN",101, 4963,20)
	15653	D BILPRO^P SOCPF2
	15654	"KRN",101, 4963,99)
	15655	64299,5462 6
	15656	"KRN",409. 61,717,-1)
	15657	0^1
	15658	"KRN",409. 61,717,0)
	15659	PSO PATIEN T MEDICATI ON LIST^1^ ^80^3^18^1 ^1^^PSO PA TIENT MEDI CATION MEN U^Patient
	15660	Medication s^1^^
	15661	"KRN",409. 61,717,1)
	15662	^PSO HIDDE N ACTIONS #4
	15663	"KRN",409. 61,717,"CO L",0)
	15664	^409.621^6 ^6
	15665	"KRN",409. 61,717,"CO L",1,0)
	15666	LINE^1^4^^ ^0
	15667	"KRN",409. 61,717,"CO L",2,0)
	15668	NAME^6^27^ Patient Na me^^0
	15669	"KRN",409. 61,717,"CO L",3,0)
	15670	PID^29^5^I D^^0
	15671	"KRN",409. 61,717,"CO L",4,0)
	15672	MED^36^26^ Medication ^^0
	15673	"KRN",409. 61,717,"CO L",5,0)
	15674	FLDT^54^8^ Fill DT^^0
	15675	"KRN",409. 61,717,"CO L",6,0)
	15676	STAT^63^15 ^Status^^0
	15677	"KRN",409. 61,717,"CO L","AIDENT ",0,1)
	15678
	15679	"KRN",409. 61,717,"CO L","AIDENT ",0,2)
	15680
	15681	"KRN",409. 61,717,"CO L","AIDENT ",0,3)
	15682
	15683	"KRN",409. 61,717,"CO L","AIDENT ",0,4)
	15684
	15685	"KRN",409. 61,717,"CO L","AIDENT ",0,5)
	15686
	15687	"KRN",409. 61,717,"CO L","AIDENT ",0,6)
	15688
	15689	"KRN",409. 61,717,"CO L","B","FL DT",5)
	15690
	15691	"KRN",409. 61,717,"CO L","B","LI NE",1)
	15692
	15693	"KRN",409. 61,717,"CO L","B","ME D",4)
	15694
	15695	"KRN",409. 61,717,"CO L","B","NA ME",2)
	15696
	15697	"KRN",409. 61,717,"CO L","B","PI D",3)
	15698
	15699	"KRN",409. 61,717,"CO L","B","ST AT",6)
	15700
	15701	"KRN",409. 61,717,"FN L")
	15702	D EXIT^PSO CPF
	15703	"KRN",409. 61,717,"HD R")
	15704	D HDR^PSOC PF
	15705	"KRN",409. 61,717,"HL P")
	15706	D HELP^PSO CPF
	15707	"KRN",409. 61,717,"IN IT")
	15708	D INIT^PSO CPF
	15709	"MBREQ")
	15710	0
	15711	"ORD",15,1 01)
	15712	101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
	15713	"ORD",15,1 01,0)
	15714	PROTOCOL
	15715	"ORD",17,4 09.61)
	15716	409.61;17; 1;;;;LME1^ XPDIA1;;;L MDEL^XPDIA 1
	15717	"ORD",17,4 09.61,0)
	15718	LIST TEMPL ATE
	15719	"ORD",18,1 9)
	15720	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
	15721	"ORD",18,1 9,0)
	15722	OPTION
	15723	"PKG",60,- 1)
	15724	1^1
	15725	"PKG",60,0 )
	15726	OUTPATIENT PHARMACY^ PSO^OUTPAT IENT LABEL S, PROFILE , INVENTOR Y, PRESCRI PTIONS
	15727	"PKG",60,2 0,0)
	15728	^9.402P^^
	15729	"PKG",60,2 2,0)
	15730	^9.49I^1^1
	15731	"PKG",60,2 2,1,0)
	15732	7.0^305111 9^2990416^ 1
	15733	"PKG",60,2 2,1,"PAH", 1,0)
	15734	463^317020 6
	15735	"PKG",60,2 2,1,"PAH", 1,1,0)
	15736	^^253^253^ 3170206
	15737	"PKG",60,2 2,1,"PAH", 1,1,1,0)
	15738
	15739	"PKG",60,2 2,1,"PAH", 1,1,2,0)
	15740	IMPORTANT INSTALLATI ON NOTE:
	15741	"PKG",60,2 2,1,"PAH", 1,1,3,0)
	15742	---------- ---------- --------
	15743	"PKG",60,2 2,1,"PAH", 1,1,4,0)
	15744	This patch is part o f a multi- package bu ild. There are three patches
	15745	"PKG",60,2 2,1,"PAH", 1,1,5,0)
	15746	associated with the FY16 HAPE Revenue En hancement project - IB2.0568 ,
	15747	"PKG",60,2 2,1,"PAH", 1,1,6,0)
	15748	PRCA4.53 15 and PSO 7.0463. All three patches ar e to be in stalled
	15749	"PKG",60,2 2,1,"PAH", 1,1,7,0)
	15750	together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
	15751	"PKG",60,2 2,1,"PAH", 1,1,8,0)
	15752
	15753	"PKG",60,2 2,1,"PAH", 1,1,9,0)
	15754
	15755	"PKG",60,2 2,1,"PAH", 1,1,10,0)
	15756	Descriptio n
	15757	"PKG",60,2 2,1,"PAH", 1,1,11,0)
	15758	---------- -
	15759	"PKG",60,2 2,1,"PAH", 1,1,12,0)
	15760	The Chief Business O ffice (CBO ) is reque sting syst em enhance ments to
	15761	"PKG",60,2 2,1,"PAH", 1,1,13,0)
	15762	The Vetera ns Health Informatio n Systems and Techno logy Archi tecture
	15763	"PKG",60,2 2,1,"PAH", 1,1,14,0)
	15764	(VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd
	15765	"PKG",60,2 2,1,"PAH", 1,1,15,0)
	15766	Outpatient Pharmacy (PSO) soft ware modul es.
	15767	"PKG",60,2 2,1,"PAH", 1,1,16,0)
	15768
	15769	"PKG",60,2 2,1,"PAH", 1,1,17,0)
	15770	The missio n of the D epartment of Veteran s Affairs (VA), Offi ce of
	15771	"PKG",60,2 2,1,"PAH", 1,1,18,0)
	15772	Informatio n & Techno logy (OI&T ), is to p rovide ben efits and services t o
	15773	"PKG",60,2 2,1,"PAH", 1,1,19,0)
	15774	veterans o f the Unit ed States Armed Forc es. In mee ting these goals,
	15775	"PKG",60,2 2,1,"PAH", 1,1,20,0)
	15776	OIT strive s to provi de high qu ality, eff ective, an d efficien t
	15777	"PKG",60,2 2,1,"PAH", 1,1,21,0)
	15778	Informatio n Technolo gy (IT) se rvices to those resp onsible fo r providin g
	15779	"PKG",60,2 2,1,"PAH", 1,1,22,0)
	15780	care to th e veterans at the po int-of-car e, as well as throug hout all
	15781	"PKG",60,2 2,1,"PAH", 1,1,23,0)
	15782	the points of the ve terans' he alth care. The VA de pends on I nformation
	15783	"PKG",60,2 2,1,"PAH", 1,1,24,0)
	15784	Management /Informati on Technol ogy (IM/IT ) systems to meet mi ssion
	15785	"PKG",60,2 2,1,"PAH", 1,1,25,0)
	15786	goals.
	15787	"PKG",60,2 2,1,"PAH", 1,1,26,0)
	15788
	15789	"PKG",60,2 2,1,"PAH", 1,1,27,0)
	15790	The overal l FY16 HAP E Revenue Enhancemen t project has been f urther
	15791	"PKG",60,2 2,1,"PAH", 1,1,28,0)
	15792	divided in to three s ub-project s:
	15793	"PKG",60,2 2,1,"PAH", 1,1,29,0)
	15794
	15795	"PKG",60,2 2,1,"PAH", 1,1,30,0)
	15796	NSR #20150 506
	15797	"PKG",60,2 2,1,"PAH", 1,1,31,0)
	15798	The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the Chief
	15799	"PKG",60,2 2,1,"PAH", 1,1,32,0)
	15800	Business O ffice (CBO ), bundles several N SRs with s imilar bus iness
	15801	"PKG",60,2 2,1,"PAH", 1,1,33,0)
	15802	needs into a single requiremen ts documen t. Succes sfully add ressing
	15803	"PKG",60,2 2,1,"PAH", 1,1,34,0)
	15804	the requir ements con tained wit hin this d ocument wi ll enable the
	15805	"PKG",60,2 2,1,"PAH", 1,1,35,0)
	15806	Department of Vetera ns Affairs (VA) to a ppropriate ly bill ce rtain
	15807	"PKG",60,2 2,1,"PAH", 1,1,36,0)
	15808	subsets of billable events by correcting , automati ng, or enh ancing
	15809	"PKG",60,2 2,1,"PAH", 1,1,37,0)
	15810	current Ve terans Hea lth Inform ation Syst ems and Te chnology
	15811	"PKG",60,2 2,1,"PAH", 1,1,38,0)
	15812	Architectu re (VistA) systems.
	15813	"PKG",60,2 2,1,"PAH", 1,1,39,0)
	15814
	15815	"PKG",60,2 2,1,"PAH", 1,1,40,0)
	15816	NSR #20150 507
	15817	"PKG",60,2 2,1,"PAH", 1,1,41,0)
	15818	The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs, as
	15819	"PKG",60,2 2,1,"PAH", 1,1,42,0)
	15820	well. This effort en ables the Department of Vetera ns Affairs (VA) to
	15821	"PKG",60,2 2,1,"PAH", 1,1,43,0)
	15822	improve re venue oper ation func tionality related to repayment plans,
	15823	"PKG",60,2 2,1,"PAH", 1,1,44,0)
	15824	late charg e capture, bill susp ension rea sons, the billing of
	15825	"PKG",60,2 2,1,"PAH", 1,1,45,0)
	15826	deactivate d provider s, and the display o f appeal r ights and
	15827	"PKG",60,2 2,1,"PAH", 1,1,46,0)
	15828	responsibi lities on the Vetera ns Benefic iary trave l Bill of Collection s
	15829	"PKG",60,2 2,1,"PAH", 1,1,47,0)
	15830	form. Imp lementatio n of the p roposed en hancements will make a
	15831	"PKG",60,2 2,1,"PAH", 1,1,48,0)
	15832	significan t positive impact on stakehold ers and ta rget users .
	15833	"PKG",60,2 2,1,"PAH", 1,1,49,0)
	15834
	15835	"PKG",60,2 2,1,"PAH", 1,1,50,0)
	15836	NSR #20150 505
	15837	"PKG",60,2 2,1,"PAH", 1,1,51,0)
	15838	The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to
	15839	"PKG",60,2 2,1,"PAH", 1,1,52,0)
	15840	improve tr acking and reporting of revenu e, and wil l support revenue
	15841	"PKG",60,2 2,1,"PAH", 1,1,53,0)
	15842	reporting business r ules and g uidelines.
	15843	"PKG",60,2 2,1,"PAH", 1,1,54,0)
	15844
	15845	"PKG",60,2 2,1,"PAH", 1,1,55,0)
	15846
	15847	"PKG",60,2 2,1,"PAH", 1,1,56,0)
	15848	PSO7.046 3 patch en hancements , pertinen t to the a bove NSRs, include:
	15849	"PKG",60,2 2,1,"PAH", 1,1,57,0)
	15850
	15851	"PKG",60,2 2,1,"PAH", 1,1,58,0)
	15852	1.) In the event of a Prescrip tion Reset Status/Ca ncel Charg es action,
	15853	"PKG",60,2 2,1,"PAH", 1,1,59,0)
	15854	all automa tic prepay ment gener ation shal l be
	15855	"PKG",60,2 2,1,"PAH", 1,1,60,0)
	15856	eliminated .
	15857	"PKG",60,2 2,1,"PAH", 1,1,61,0)
	15858
	15859	"PKG",60,2 2,1,"PAH", 1,1,62,0)
	15860	2.) All "c redit bala nces" that are autom atically g enerated i n the even t
	15861	"PKG",60,2 2,1,"PAH", 1,1,63,0)
	15862	of a Presc ription Re set Status /Cancel Ch arges acti on exempti on to stop .
	15863	"PKG",60,2 2,1,"PAH", 1,1,64,0)
	15864
	15865	"PKG",60,2 2,1,"PAH", 1,1,65,0)
	15866	3.) A new on-demand List Manag er report will be ma de availab le for
	15867	"PKG",60,2 2,1,"PAH", 1,1,66,0)
	15868	identifica tion of Pr escription resets.
	15869	"PKG",60,2 2,1,"PAH", 1,1,67,0)
	15870
	15871	"PKG",60,2 2,1,"PAH", 1,1,68,0)
	15872	4.) The ne w on-deman d report f or process ing Prescr iption Res ets will
	15873	"PKG",60,2 2,1,"PAH", 1,1,69,0)
	15874	provide an option to generate a Summary Report and /or Detail ed Report.
	15875	"PKG",60,2 2,1,"PAH", 1,1,70,0)
	15876
	15877	"PKG",60,2 2,1,"PAH", 1,1,71,0)
	15878
	15879	"PKG",60,2 2,1,"PAH", 1,1,72,0)
	15880
	15881	"PKG",60,2 2,1,"PAH", 1,1,73,0)
	15882	Concurrent Developme nt / Depen dencies:
	15883	"PKG",60,2 2,1,"PAH", 1,1,74,0)
	15884	---------- ---------- ---------- --------
	15885	"PKG",60,2 2,1,"PAH", 1,1,75,0)
	15886	N/A
	15887	"PKG",60,2 2,1,"PAH", 1,1,76,0)
	15888
	15889	"PKG",60,2 2,1,"PAH", 1,1,77,0)
	15890
	15891	"PKG",60,2 2,1,"PAH", 1,1,78,0)
	15892	Patch Comp onents:
	15893	"PKG",60,2 2,1,"PAH", 1,1,79,0)
	15894	---------- -------
	15895	"PKG",60,2 2,1,"PAH", 1,1,80,0)
	15896
	15897	"PKG",60,2 2,1,"PAH", 1,1,81,0)
	15898	Files & Fi elds Assoc iated:
	15899	"PKG",60,2 2,1,"PAH", 1,1,82,0)
	15900
	15901	"PKG",60,2 2,1,"PAH", 1,1,83,0)
	15902	File Name (Number) Field Na me (Number ) New/ Modified/D eleted
	15903	"PKG",60,2 2,1,"PAH", 1,1,84,0)
	15904	---------- -------- -------- ---------- - ---- ---------- ------
	15905	"PKG",60,2 2,1,"PAH", 1,1,85,0)
	15906	N/A
	15907	"PKG",60,2 2,1,"PAH", 1,1,86,0)
	15908
	15909	"PKG",60,2 2,1,"PAH", 1,1,87,0)
	15910	Options As sociated:
	15911	"PKG",60,2 2,1,"PAH", 1,1,88,0)
	15912
	15913	"PKG",60,2 2,1,"PAH", 1,1,89,0)
	15914	Option Nam e Type New/ Modified/D eleted
	15915	"PKG",60,2 2,1,"PAH", 1,1,90,0)
	15916	---------- - ---- ---- ---------- ------
	15917	"PKG",60,2 2,1,"PAH", 1,1,91,0)
	15918	PSOCP RESE T COPAY ST ATUS LM ROUTINE NEW
	15919	"PKG",60,2 2,1,"PAH", 1,1,92,0)
	15920
	15921	"PKG",60,2 2,1,"PAH", 1,1,93,0)
	15922	Protocols Associated :
	15923	"PKG",60,2 2,1,"PAH", 1,1,94,0)
	15924
	15925	"PKG",60,2 2,1,"PAH", 1,1,95,0)
	15926	Protocol N ame New /Modified/ Deleted
	15927	"PKG",60,2 2,1,"PAH", 1,1,96,0)
	15928	---------- --- --- ---------- -------
	15929	"PKG",60,2 2,1,"PAH", 1,1,97,0)
	15930	PSO PATIEN T MED ACC PRO NEW
	15931	"PKG",60,2 2,1,"PAH", 1,1,98,0)
	15932	PSO PATIEN T MED BILL PRO NEW
	15933	"PKG",60,2 2,1,"PAH", 1,1,99,0)
	15934	PSO PATIEN T MED CANC EL NEW
	15935	"PKG",60,2 2,1,"PAH", 1,1,100,0)
	15936	PSO PATIEN T MED EXPO RT NEW
	15937	"PKG",60,2 2,1,"PAH", 1,1,101,0)
	15938	PSO PATIEN T MED PAT INQ NEW
	15939	"PKG",60,2 2,1,"PAH", 1,1,102,0)
	15940	PSO PATIEN T MED RESE T NEW
	15941	"PKG",60,2 2,1,"PAH", 1,1,103,0)
	15942	PSO PATIEN T MED TPJI NEW
	15943	"PKG",60,2 2,1,"PAH", 1,1,104,0)
	15944	PSO PATIEN T MEDICATI ON MENU
	15945	"PKG",60,2 2,1,"PAH", 1,1,105,0)
	15946
	15947	"PKG",60,2 2,1,"PAH", 1,1,106,0)
	15948	Templates Associated :
	15949	"PKG",60,2 2,1,"PAH", 1,1,107,0)
	15950
	15951	"PKG",60,2 2,1,"PAH", 1,1,108,0)
	15952	Template N ame T ype File Name (Num ber) New/Mod/De l
	15953	"PKG",60,2 2,1,"PAH", 1,1,109,0)
	15954	---------- --- - --- ---- ---------- ---- ---------- -
	15955	"PKG",60,2 2,1,"PAH", 1,1,110,0)
	15956	PSO PATIEN T MEDICATI ON LIST L IST NEW
	15957	"PKG",60,2 2,1,"PAH", 1,1,111,0)
	15958
	15959	"PKG",60,2 2,1,"PAH", 1,1,112,0)
	15960	New Servic e Requests (NSRs):
	15961	"PKG",60,2 2,1,"PAH", 1,1,113,0)
	15962	---------- ---------- --------
	15963	"PKG",60,2 2,1,"PAH", 1,1,114,0)
	15964	20150505 - Revenue R eporting E nhancement s
	15965	"PKG",60,2 2,1,"PAH", 1,1,115,0)
	15966	20150506 - Revenue E ligibility Enhanceme nts
	15967	"PKG",60,2 2,1,"PAH", 1,1,116,0)
	15968	20150507 - Revenue O perations Enhancemen ts
	15969	"PKG",60,2 2,1,"PAH", 1,1,117,0)
	15970
	15971	"PKG",60,2 2,1,"PAH", 1,1,118,0)
	15972
	15973	"PKG",60,2 2,1,"PAH", 1,1,119,0)
	15974	Patient Sa fety Issue s (PSIs):
	15975	"PKG",60,2 2,1,"PAH", 1,1,120,0)
	15976	---------- ---------- ----------
	15977	"PKG",60,2 2,1,"PAH", 1,1,121,0)
	15978	N/A
	15979	"PKG",60,2 2,1,"PAH", 1,1,122,0)
	15980
	15981	"PKG",60,2 2,1,"PAH", 1,1,123,0)
	15982
	15983	"PKG",60,2 2,1,"PAH", 1,1,124,0)
	15984	Remedy Tic ket(s) & O verviews:
	15985	"PKG",60,2 2,1,"PAH", 1,1,125,0)
	15986	---------- ---------- ---------
	15987	"PKG",60,2 2,1,"PAH", 1,1,126,0)
	15988	N/A
	15989	"PKG",60,2 2,1,"PAH", 1,1,127,0)
	15990
	15991	"PKG",60,2 2,1,"PAH", 1,1,128,0)
	15992	Test Sites :
	15993	"PKG",60,2 2,1,"PAH", 1,1,129,0)
	15994	----------
	15995	"PKG",60,2 2,1,"PAH", 1,1,130,0)
	15996	Durham VAM C
	15997	"PKG",60,2 2,1,"PAH", 1,1,131,0)
	15998
	15999	"PKG",60,2 2,1,"PAH", 1,1,132,0)
	16000
	16001	"PKG",60,2 2,1,"PAH", 1,1,133,0)
	16002	Software a nd Documen tation Ret rieval Ins tructions:
	16003	"PKG",60,2 2,1,"PAH", 1,1,134,0)
	16004	---------- ---------- ---------- ---------- ---------- --
	16005	"PKG",60,2 2,1,"PAH", 1,1,135,0)
	16006	Patches fo r this ins tallation are combin ed in host file
	16007	"PKG",60,2 2,1,"PAH", 1,1,136,0)
	16008	IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
	16009	"PKG",60,2 2,1,"PAH", 1,1,137,0)
	16010
	16011	"PKG",60,2 2,1,"PAH", 1,1,138,0)
	16012	Installati on of this host file should be coordinat ed among t he package s
	16013	"PKG",60,2 2,1,"PAH", 1,1,139,0)
	16014	affected s ince only one instal lation is necessary.
	16015	"PKG",60,2 2,1,"PAH", 1,1,140,0)
	16016
	16017	"PKG",60,2 2,1,"PAH", 1,1,141,0)
	16018	The patche s are:
	16019	"PKG",60,2 2,1,"PAH", 1,1,142,0)
	16020
	16021	"PKG",60,2 2,1,"PAH", 1,1,143,0)
	16022	IB2. 0568
	16023	"PKG",60,2 2,1,"PAH", 1,1,144,0)
	16024	PRCA* 4.5*315
	16025	"PKG",60,2 2,1,"PAH", 1,1,145,0)
	16026	PSO7 .0463
	16027	"PKG",60,2 2,1,"PAH", 1,1,146,0)
	16028
	16029	"PKG",60,2 2,1,"PAH", 1,1,147,0)
	16030
	16031	"PKG",60,2 2,1,"PAH", 1,1,148,0)
	16032	Sites may retrieve t he KIDS bu ild in one of the fo llowing wa ys:
	16033	"PKG",60,2 2,1,"PAH", 1,1,149,0)
	16034
	16035	"PKG",60,2 2,1,"PAH", 1,1,150,0)
	16036	(1) The pr eferred me thod is to FTP the f iles from
	16037	"PKG",60,2 2,1,"PAH", 1,1,151,0)
	16038	download. DNS . DNS which will transmit the files from the
	16039	"PKG",60,2 2,1,"PAH", 1,1,152,0)
	16040	first avai lable FTP server.
	16041	"PKG",60,2 2,1,"PAH", 1,1,153,0)
	16042
	16043	"PKG",60,2 2,1,"PAH", 1,1,154,0)
	16044	(2) Sites may also e lect to re trieve the patch dir ectly from a specifi c
	16045	"PKG",60,2 2,1,"PAH", 1,1,155,0)
	16046	server as follows:
	16047	"PKG",60,2 2,1,"PAH", 1,1,156,0)
	16048
	16049	"PKG",60,2 2,1,"PAH", 1,1,157,0)
	16050	OIFO FTP ADDRE SS DIRECTORY
	16051	"PKG",60,2 2,1,"PAH", 1,1,158,0)
	16052	-------- ------ --------- ---------- ----- ---------- --------
	16053	"PKG",60,2 2,1,"PAH", 1,1,159,0)
	16054	Albany ftp.fo-alb any. URL anonymous. software
	16055	"PKG",60,2 2,1,"PAH", 1,1,160,0)
	16056	Hines ftp. DNS . URL anonymous. software
	16057	"PKG",60,2 2,1,"PAH", 1,1,161,0)
	16058	Salt Lake City ftp.fo-slc . URL anonymous. software
	16059	"PKG",60,2 2,1,"PAH", 1,1,162,0)
	16060
	16061	"PKG",60,2 2,1,"PAH", 1,1,163,0)
	16062
	16063	"PKG",60,2 2,1,"PAH", 1,1,164,0)
	16064	Sites may retrieve d ocumentati on directl y using Se cure File Transfer
	16065	"PKG",60,2 2,1,"PAH", 1,1,165,0)
	16066	Protocol ( SFTP) from the ANONY MOUS.SOFTW ARE direct ory at the following
	16067	"PKG",60,2 2,1,"PAH", 1,1,166,0)
	16068	OI Field O ffices:
	16069	"PKG",60,2 2,1,"PAH", 1,1,167,0)
	16070
	16071	"PKG",60,2 2,1,"PAH", 1,1,168,0)
	16072	Albany: fo-albany. URL
	16073	"PKG",60,2 2,1,"PAH", 1,1,169,0)
	16074	Hines: DNS .U RL
	16075	"PKG",60,2 2,1,"PAH", 1,1,170,0)
	16076	Salt Lake City: fo-slc. URL
	16077	"PKG",60,2 2,1,"PAH", 1,1,171,0)
	16078
	16079	"PKG",60,2 2,1,"PAH", 1,1,172,0)
	16080	Documentat ion can al so be foun d on the V A Software Documenta tion Libra ry
	16081	"PKG",60,2 2,1,"PAH", 1,1,173,0)
	16082	at:
	16083	"PKG",60,2 2,1,"PAH", 1,1,174,0)
	16084	http:// URL /
	16085	"PKG",60,2 2,1,"PAH", 1,1,175,0)
	16086
	16087	"PKG",60,2 2,1,"PAH", 1,1,176,0)
	16088	Title File Name FTP Mode
	16089	"PKG",60,2 2,1,"PAH", 1,1,177,0)
	16090	---------- ---------- ---------- ---------- ---------- ---------- ---------
	16091	"PKG",60,2 2,1,"PAH", 1,1,178,0)
	16092	Outpatient Pharmacy Technical Manual/Sec urity Guid e
	16093	"PKG",60,2 2,1,"PAH", 1,1,179,0)
	16094	pso_7_tm.d oc Binary
	16095	"PKG",60,2 2,1,"PAH", 1,1,180,0)
	16096	Outpatient Pharmacy Deployment , Installa tion,
	16097	"PKG",60,2 2,1,"PAH", 1,1,181,0)
	16098	Back- Out, and R ollback Gu ide
	16099	"PKG",60,2 2,1,"PAH", 1,1,182,0)
	16100	FY16Re venuePSOVI P_Deployme nt_Install ation_Guid e.doc
	16101	"PKG",60,2 2,1,"PAH", 1,1,183,0)
	16102	Binary
	16103	"PKG",60,2 2,1,"PAH", 1,1,184,0)
	16104
	16105	"PKG",60,2 2,1,"PAH", 1,1,185,0)
	16106
	16107	"PKG",60,2 2,1,"PAH", 1,1,186,0)
	16108
	16109	"PKG",60,2 2,1,"PAH", 1,1,187,0)
	16110	Patch Inst allation:
	16111	"PKG",60,2 2,1,"PAH", 1,1,188,0)
	16112
	16113	"PKG",60,2 2,1,"PAH", 1,1,189,0)
	16114	Pre/Post I nstallatio n Overview :
	16115	"PKG",60,2 2,1,"PAH", 1,1,190,0)
	16116	---------- ---------- ---------- -
	16117	"PKG",60,2 2,1,"PAH", 1,1,191,0)
	16118	N/A
	16119	"PKG",60,2 2,1,"PAH", 1,1,192,0)
	16120
	16121	"PKG",60,2 2,1,"PAH", 1,1,193,0)
	16122	Pre-Instal lation Ins tructions:
	16123	"PKG",60,2 2,1,"PAH", 1,1,194,0)
	16124	---------- ---------- ----------
	16125	"PKG",60,2 2,1,"PAH", 1,1,195,0)
	16126	N/A
	16127	"PKG",60,2 2,1,"PAH", 1,1,196,0)
	16128
	16129	"PKG",60,2 2,1,"PAH", 1,1,197,0)
	16130	Installati on Instruc tions:
	16131	"PKG",60,2 2,1,"PAH", 1,1,198,0)
	16132	---------- ---------- ------
	16133	"PKG",60,2 2,1,"PAH", 1,1,199,0)
	16134	This proce ss will in stall new and update d routines and other
	16135	"PKG",60,2 2,1,"PAH", 1,1,200,0)
	16136	components listed ab ove. There is a post -install r outine tha t will add
	16137	"PKG",60,2 2,1,"PAH", 1,1,201,0)
	16138	entries to a number of files.
	16139	"PKG",60,2 2,1,"PAH", 1,1,202,0)
	16140
	16141	"PKG",60,2 2,1,"PAH", 1,1,203,0)
	16142	The patch will be re leased in conjunctio n with an Integrated Billing
	16143	"PKG",60,2 2,1,"PAH", 1,1,204,0)
	16144	patch, IB* 4.5568, a nd an Outp atient Pha rmacy patc h, PSO7.0 *463.
	16145	"PKG",60,2 2,1,"PAH", 1,1,205,0)
	16146
	16147	"PKG",60,2 2,1,"PAH", 1,1,206,0)
	16148	****** ****** ** NOT E **** ****** ****
	16149	"PKG",60,2 2,1,"PAH", 1,1,207,0)
	16150	IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS
	16151	"PKG",60,2 2,1,"PAH", 1,1,208,0)
	16152	AN EDITE D ERROR WI LL OCCUR.
	16153	"PKG",60,2 2,1,"PAH", 1,1,209,0)
	16154	The patc h should b e installe d when NO Outpatient
	16155	"PKG",60,2 2,1,"PAH", 1,1,210,0)
	16156	Pharmacy users are on the sy stem.
	16157	"PKG",60,2 2,1,"PAH", 1,1,211,0)
	16158	****** ****** ****** ****** ****** ****
	16159	"PKG",60,2 2,1,"PAH", 1,1,212,0)
	16160
	16161	"PKG",60,2 2,1,"PAH", 1,1,213,0)
	16162	Installat ion will t ake less t han 1 minu te.
	16163	"PKG",60,2 2,1,"PAH", 1,1,214,0)
	16164
	16165	"PKG",60,2 2,1,"PAH", 1,1,215,0)
	16166	Suggested time to i nstall: no n-peak req uirement h ours.
	16167	"PKG",60,2 2,1,"PAH", 1,1,216,0)
	16168
	16169	"PKG",60,2 2,1,"PAH", 1,1,217,0)
	16170
	16171	"PKG",60,2 2,1,"PAH", 1,1,218,0)
	16172	1. Obtai n the file IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID
	16173	"PKG",60,2 2,1,"PAH", 1,1,219,0)
	16174
	16175	"PKG",60,2 2,1,"PAH", 1,1,220,0)
	16176	2. From the Kernel Installat ion & Dist ribution S ystem menu , select
	16177	"PKG",60,2 2,1,"PAH", 1,1,221,0)
	16178	the I nstallatio n menu.
	16179	"PKG",60,2 2,1,"PAH", 1,1,222,0)
	16180
	16181	"PKG",60,2 2,1,"PAH", 1,1,223,0)
	16182	3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
	16183	"PKG",60,2 2,1,"PAH", 1,1,224,0)
	16184	promp ted to Ent er a Host File name. You may need to ap pend a
	16185	"PKG",60,2 2,1,"PAH", 1,1,225,0)
	16186	direc tory name.
	16187	"PKG",60,2 2,1,"PAH", 1,1,226,0)
	16188
	16189	"PKG",60,2 2,1,"PAH", 1,1,227,0)
	16190	4. From this menu, you may s elect to u se the fol lowing opt ions
	16191	"PKG",60,2 2,1,"PAH", 1,1,228,0)
	16192	(when prompted for INSTAL L NAME, en ter IB2.0 568):
	16193	"PKG",60,2 2,1,"PAH", 1,1,229,0)
	16194	a . Verify Checksums in Transpo rt Global - This opt ion will
	16195	"PKG",60,2 2,1,"PAH", 1,1,230,0)
	16196	allow y ou to ensu re the int egrity of the routin es that
	16197	"PKG",60,2 2,1,"PAH", 1,1,231,0)
	16198	are in the transp ort global .
	16199	"PKG",60,2 2,1,"PAH", 1,1,232,0)
	16200	b . Print T ransport G lobal - Th is option will allow you to
	16201	"PKG",60,2 2,1,"PAH", 1,1,233,0)
	16202	view th e componen ts of the KIDS build .
	16203	"PKG",60,2 2,1,"PAH", 1,1,234,0)
	16204	c . Compare Transport Global to Current S ystem - Th is option
	16205	"PKG",60,2 2,1,"PAH", 1,1,235,0)
	16206	will al low you to view all changes th at will be made when
	16207	"PKG",60,2 2,1,"PAH", 1,1,236,0)
	16208	this pa tch is ins talled. I t compares all compo nents of
	16209	"PKG",60,2 2,1,"PAH", 1,1,237,0)
	16210	this pa tch (routi nes, DD's, templates , etc.).
	16211	"PKG",60,2 2,1,"PAH", 1,1,238,0)
	16212	d . Backup a Transpor t Global - This opti on will cr eate a
	16213	"PKG",60,2 2,1,"PAH", 1,1,239,0)
	16214	backup message of any routi nes export ed with th is patch.
	16215	"PKG",60,2 2,1,"PAH", 1,1,240,0)
	16216	It will not backu p any othe r changes such as DD 's or
	16217	"PKG",60,2 2,1,"PAH", 1,1,241,0)
	16218	templat es.
	16219	"PKG",60,2 2,1,"PAH", 1,1,242,0)
	16220
	16221	"PKG",60,2 2,1,"PAH", 1,1,243,0)
	16222	5. When prompted " Want KIDS to INHIBIT LOGONs du ring the i nstall?
	16223	"PKG",60,2 2,1,"PAH", 1,1,244,0)
	16224	NO//" respond N O.
	16225	"PKG",60,2 2,1,"PAH", 1,1,245,0)
	16226
	16227	"PKG",60,2 2,1,"PAH", 1,1,246,0)
	16228	6. When prompted " Want to DI SABLE Sche duled Opti ons, Menu Options,
	16229	"PKG",60,2 2,1,"PAH", 1,1,247,0)
	16230	and P rotocols? NO//" resp ond NO.
	16231	"PKG",60,2 2,1,"PAH", 1,1,248,0)
	16232
	16233	"PKG",60,2 2,1,"PAH", 1,1,249,0)
	16234
	16235	"PKG",60,2 2,1,"PAH", 1,1,250,0)
	16236
	16237	"PKG",60,2 2,1,"PAH", 1,1,251,0)
	16238	Post-Insta llation In structions :
	16239	"PKG",60,2 2,1,"PAH", 1,1,252,0)
	16240	---------- ---------- ---------- -
	16241	"PKG",60,2 2,1,"PAH", 1,1,253,0)
	16242	There are no special tasks to perform af ter this p atch insta llation.
	16243	"QUES","XP F1",0)
	16244	Y
	16245	"QUES","XP F1","??")
	16246	^D REP^XPD H
	16247	"QUES","XP F1","A")
	16248	Shall I wr ite over y our \|FLAG\| File
	16249	"QUES","XP F1","B")
	16250	YES
	16251	"QUES","XP F1","M")
	16252	D XPF1^XPD IQ
	16253	"QUES","XP F2",0)
	16254	Y
	16255	"QUES","XP F2","??")
	16256	^D DTA^XPD H
	16257	"QUES","XP F2","A")
	16258	Want my da ta \|FLAG\| yours
	16259	"QUES","XP F2","B")
	16260	YES
	16261	"QUES","XP F2","M")
	16262	D XPF2^XPD IQ
	16263	"QUES","XP I1",0)
	16264	YO
	16265	"QUES","XP I1","??")
	16266	^D INHIBIT ^XPDH
	16267	"QUES","XP I1","A")
	16268	Want KIDS to INHIBIT LOGONs du ring the i nstall
	16269	"QUES","XP I1","B")
	16270	NO
	16271	"QUES","XP I1","M")
	16272	D XPI1^XPD IQ
	16273	"QUES","XP M1",0)
	16274	PO^VA(200, :EM
	16275	"QUES","XP M1","??")
	16276	^D MG^XPDH
	16277	"QUES","XP M1","A")
	16278	Enter the Coordinato r for Mail Group '\|F LAG\|'
	16279	"QUES","XP M1","B")
	16280
	16281	"QUES","XP M1","M")
	16282	D XPM1^XPD IQ
	16283	"QUES","XP O1",0)
	16284	Y
	16285	"QUES","XP O1","??")
	16286	^D MENU^XP DH
	16287	"QUES","XP O1","A")
	16288	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	16289	"QUES","XP O1","B")
	16290	NO
	16291	"QUES","XP O1","M")
	16292	D XPO1^XPD IQ
	16293	"QUES","XP Z1",0)
	16294	Y
	16295	"QUES","XP Z1","??")
	16296	^D OPT^XPD H
	16297	"QUES","XP Z1","A")
	16298	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	16299	"QUES","XP Z1","B")
	16300	NO
	16301	"QUES","XP Z1","M")
	16302	D XPZ1^XPD IQ
	16303	"QUES","XP Z2",0)
	16304	Y
	16305	"QUES","XP Z2","??")
	16306	^D RTN^XPD H
	16307	"QUES","XP Z2","A")
	16308	Want to MO VE routine s to other CPUs
	16309	"QUES","XP Z2","B")
	16310	NO
	16311	"QUES","XP Z2","M")
	16312	D XPZ2^XPD IQ
	16313	"RTN")
	16314	4
	16315	"RTN","PSO CPB")
	16316	0^1^B84712 258
	16317	"RTN","PSO CPB",1,0)
	16318	PSOCPB ;BI R/BaB - ph armacy co- pay applic ation cont 'd ;1/30/0 7 9:08am
	16319	"RTN","PSO CPB",2,0)
	16320	;;7.0;OUT PATIENT PH ARMACY;7 2,71,85,18 5,143,219, 239,201,26 3,303,431, 463;DEC
	16321	1997;Build 2
	16322	"RTN","PSO CPB",3,0)
	16323	;;Per VA Directive 6402, this routine s hould not be modifie d.
	16324	"RTN","PSO CPB",4,0)
	16325	;
	16326	"RTN","PSO CPB",5,0)
	16327	;REF/IA
	16328	"RTN","PSO CPB",6,0)
	16329	;DIS^SDRO UT2/112
	16330	"RTN","PSO CPB",7,0)
	16331	;^IBARX/1 25
	16332	"RTN","PSO CPB",8,0)
	16333	;VADPT/10 061
	16334	"RTN","PSO CPB",9,0)
	16335	;SWSTAT^I BBAPI/4663
	16336	"RTN","PSO CPB",10,0)
	16337	COPAY ;
	16338	"RTN","PSO CPB",11,0)
	16339	;Called b y PSON52,P SORN52...R equires PS OCPAY,PSOB ILL,DEA=PS DEA,PSOFLA G
	16340	"RTN","PSO CPB",12,0)
	16341	;PSOFLAG= 1 NEW, PSO FLAG=0 REN EW
	16342	"RTN","PSO CPB",13,0)
	16343	S PSOSAVE =PSOCPAY ; Save orig inal statu s of PSOCP AY
	16344	"RTN","PSO CPB",14,0)
	16345	I '$G(PSO SCP)!('$G( PSOSCA)) D SCP^PSORN 52D ;CIDC -must ask sc if flag ged for it
	16346	in enroll ment
	16347	"RTN","PSO CPB",15,0)
	16348	I $G(PSOD RUG("DEA") )["S"!($G( PSODRUG("D EA"))["I") !($G(PSODR UG("DEA")) ["N") S PS
	16349	OCPAY=0
	16350	"RTN","PSO CPB",16,0)
	16351	G:+PSOBIL L'=2&('$G( PSOSCA)) C OPAY2
	16352	"RTN","PSO CPB",17,0)
	16353	D FULL^VA LM1
	16354	"RTN","PSO CPB",18,0)
	16355	I $G(PSOM ESOI)=1,$G (PSORXED) W !!,"The Pharmacy O rderable I tem has ch anged for
	16356	this order . Please r eview any" ,!,"existi ng SC or E nvironment al Indicat or default
	16357	s carefull y for appr opriatenes s.",! S PS OMESOI=2
	16358	"RTN","PSO CPB",19,0)
	16359	I $G(PSOM ESFI)=1 W !!,"The Ph armacy Ord erable Ite m has chan ged for th is order.
	16360	Please rev iew any",! ,"existing SC or Env ironmental Indicator defaults carefully
	16361	for approp riateness. ",! S PSOM ESFI=2
	16362	"RTN","PSO CPB",20,0)
	16363	S DFN=+$G (PSODFN) D CHKPAG^PS OMLLD2,DIS ^SDROUT2
	16364	"RTN","PSO CPB",21,0)
	16365	ASK ;
	16366	"RTN","PSO CPB",22,0)
	16367	N PSOUFLA G S PSOUFL AG=0
	16368	"RTN","PSO CPB",23,0)
	16369	K PSOCPZ( "DFLG"),PS ONEW("NEWC OPAY")
	16370	"RTN","PSO CPB",24,0)
	16371	W ! K DIR ,DTOUT,DIR UT,DUOUT
	16372	"RTN","PSO CPB",25,0)
	16373	I $G(PSOR X("SC"))=" SC"!($G(PS ORX("SC")) ="NSC")!($ G(PSOSCOTH )) D
	16374	"RTN","PSO CPB",26,0)
	16375	. W:PSOSC P<50&($G(P SODRUG("DE A"))'["S") &($G(PSODR UG("DEA")) '["I")&($G (PSODRUG("
	16376	DEA"))'["N ") !,"This Rx has be en flagged by the pr ovider as: "_$S($G(P SOSCOTH):"
	16377	NO COPAY", $G(PSORX(" SC"))="SC" :"NO COPAY ",1:"COPAY "),! I $G( PSOSCOTX) S PSOSCOTX
	16378	=2
	16379	"RTN","PSO CPB",27,0)
	16380	S DIR("A" )="Was tre atment for Service C onnected c ondition", DIR(0)="Y"
	16381	"RTN","PSO CPB",28,0)
	16382	S DIR("?" )="Enter ' Yes' if th is prescri ption is f or a Servi ce Connect ed conditi
	16383	on"
	16384	"RTN","PSO CPB",29,0)
	16385	I $G(PSOR X("SC"))]" "!($G(PSOR X(+$G(PSOR ENW("OIRXN ")),"SC")) '="") S DI R("B")=$S(
	16386	$G(PSORX(" SC"))="SC" :"YES",$G( PSORX("SC" ))="NSC":" NO",$G(PSO RX(+$G(PSO RENW("OIRX
	16387	N")),"SC") )=1:"YES", $G(PSORX(+ $G(PSORENW ("OIRXN")) ,"SC"))=0: "NO",1:"")
	16388	"RTN","PSO CPB",30,0)
	16389	I $G(PSON EWFF),$G(P SOFLAG) I $G(PSOANSQ D("SC"))=0 !($G(PSOAN SQD("SC")) =1) S DIR(
	16390	"B")=$S($G (PSOANSQD( "SC"))=1:" YES",1:"NO ")
	16391	"RTN","PSO CPB",31,0)
	16392	I $G(DIR( "B"))="YES "!($G(DIR( "B"))="NO" ) S PSOUFL AG=$G(DIR( "B"))
	16393	"RTN","PSO CPB",32,0)
	16394	I $G(DIR( "B"))="" K DIR("B")
	16395	"RTN","PSO CPB",33,0)
	16396	D ^DIR
	16397	"RTN","PSO CPB",34,0)
	16398	I $G(Y)=1 !($G(Y)=0) S PSOANSQ ("SC")=$G( Y) I $G(PS ONEWFF),$G (PSOFLAG) S PSOANSQD
	16399	("SC")=$G( Y)
	16400	"RTN","PSO CPB",35,0)
	16401	I PSOFLAG I Y["^"!( $D(DTOUT)) !($D(DUOUT )) S PSOCP Z("DFLG")= 1
	16402	"RTN","PSO CPB",36,0)
	16403	S:Y=0 Y=2
	16404	"RTN","PSO CPB",37,0)
	16405	S PSOANSR =+Y I 'PSO ANSR,'PSOF LAG D S $ P(PSOCPAY, "^")=$S($G (PSOUFLAG) ="NO":1,1:
	16406	0) W ! K D IR S DIR(0 )="E",DIR( "A")="Pres s Return t o continue " D ^DIR K DIR G COP
	16407	AY2
	16408	"RTN","PSO CPB",38,0)
	16409	.W !!,"Th is Renewal has been designated as "_$S($ G(PSOUFLAG )="YES":"S ERVICE CON
	16410	NECTED",1: "NON-SERVI CE CONNECT ED.")
	16411	"RTN","PSO CPB",39,0)
	16412	.W:PSOSCP <50&($G(PS ODRUG("DEA "))'["S")& ($G(PSODRU G("DEA"))' ["I")&($G( PSODRUG("D
	16413	EA"))'["N" ) !,"Pleas e use the 'Reset Cop ay Status/ Cancel Cha rges' opti on to make
	16414	correctio ns."
	16415	"RTN","PSO CPB",40,0)
	16416	.S PSOANS Q("SC")=$S ($G(PSOUFL AG)="YES": 1,1:0)
	16417	"RTN","PSO CPB",41,0)
	16418	I $G(PSOF LAG),$G(PS OCPZ("DFLG ")) G EXIT
	16419	"RTN","PSO CPB",42,0)
	16420	S:PSOANSR =1 PSOCPAY =0 S:PSOAN SR=2 $P(PS OCPAY,"^") =1
	16421	"RTN","PSO CPB",43,0)
	16422	COPAY2 ;
	16423	"RTN","PSO CPB",44,0)
	16424	N PSOPFS S PSOPFS=$ $SWSTAT^IB BAPI()
	16425	"RTN","PSO CPB",45,0)
	16426	I +PSOCPA Y=1,($P(PS OCPAY,"^", 2)=1)!($P( PSOCPAY,"^ ",2)=2) D
	16427	"RTN","PSO CPB",46,0)
	16428	.;set IB node in ^P SRX for co pay if xac tn type is 1 or 2
	16429	"RTN","PSO CPB",47,0)
	16430	.S PSONEW ("NEWCOPAY ")=$P($G(P SOCPAY),"^ ",2)_"^^"_ $S(+$G(PSO PFS):"",1: $P($G(PSOC
	16431	PAY),"^",2 ))
	16432	"RTN","PSO CPB",48,0)
	16433	EXIT ;
	16434	"RTN","PSO CPB",49,0)
	16435	S PSOCPAY =PSOSAVE ; Restore va l of PSOCP AY
	16436	"RTN","PSO CPB",50,0)
	16437	K PSOSAVE ,PSOANSR,D IR,DUOUT,D IRUT,DTOUT ,Y,X
	16438	"RTN","PSO CPB",51,0)
	16439	Q
	16440	"RTN","PSO CPB",52,0)
	16441	RESET ;RES ET COPAY S TATUS
	16442	"RTN","PSO CPB",53,0)
	16443	K PSOSUMM ,PSOPFS,PS OPFSA,PSOL FIL,PSOPFS G
	16444	"RTN","PSO CPB",54,0)
	16445	I '$D(PSO PAR) D ^PS OLSET G RE SET
	16446	"RTN","PSO CPB",55,0)
	16447	W ! S DIC ="^PSRX(", DIC(0)="AE QZ" D ^DIC K DIC G:Y <0 EXT S P SODA=+Y
	16448	"RTN","PSO CPB",56,0)
	16449	W !,?17," PATIENT: " ,$P($G(^DP T($P(^PSRX (PSODA,0), "^",2),0)) ,"^")
	16450	"RTN","PSO CPB",57,0)
	16451	D ICN^PSO DPT($P(^PS RX(PSODA,0 ),"^",2))
	16452	"RTN","PSO CPB",58,0)
	16453	S PSORXN= $P(^PSRX(P SODA,0),"^ "),PREA="R "
	16454	"RTN","PSO CPB",59,0)
	16455	S PCOPAY= $G(^PSRX(P SODA,"IB") )
	16456	"RTN","PSO CPB",60,0)
	16457	W !!,"Rx # ",PSORXN ," is a ", $S(+PCOPAY :"Copay",1 :"No Copay ")," presc ription"
	16458	"RTN","PSO CPB",61,0)
	16459	S PSOLFIL =$$LF^PSOP FSU1(PSODA ) D PFSA^P SOPFSU1(PS ODA,PSOLFI L,3) ;PSO CPC def PS
	16460	OPFSA=1 if OP SC/EI' s change.
	16461	"RTN","PSO CPB",62,0)
	16462	D EXEMCHK ^PSOCPC ; CHECK/CHAN GE EXEMPTI ON FLAGS
	16463	"RTN","PSO CPB",63,0)
	16464	S PSOIBQ= $G(^PSRX(P SODA,"IBQ" ))
	16465	"RTN","PSO CPB",64,0)
	16466	I '$G(^PS RX(PSODA," IB")),PSOI BQ'["1" D G ASKCAN
	16467	"RTN","PSO CPB",65,0)
	16468	. K DIR S DIR(0)="Y ",DIR("B") ="N",DIR(" A")="Do yo u want to reset the status to
	16469	COPAY" D ^ DIR K DIR
	16470	"RTN","PSO CPB",66,0)
	16471	. I Y'=1 Q
	16472	"RTN","PSO CPB",67,0)
	16473	. S DIC=" ^IBE(350.3 ,",DIC("S" )="I $P(^( 0),U,3)'=2 ",DIC(0)=" AEQMZ",DIC ("A")="Sel
	16474	ect Reason for Reset : " D ^DI C K DIC I Y'<0 S PSO RSN=+Y
	16475	"RTN","PSO CPB",68,0)
	16476	. S PREA= "R",PSOOLD ="No Copay ",PSONW="C opay",PSOC OMM="" D A CTLOG^PSOC PA
	16477	"RTN","PSO CPB",69,0)
	16478	. S PSI=0 ,PSOCOMM=" Copay stat us of this Rx has be en reset t o COPAY." D SETSUMM^
	16479	PSOCPC
	16480	"RTN","PSO CPB",70,0)
	16481	. S $P(^P SRX(PSODA, "IB"),"^") =1 ;Reset flag to CO PAY
	16482	"RTN","PSO CPB",71,0)
	16483	;
	16484	"RTN","PSO CPB",72,0)
	16485	I $G(^PSR X(PSODA,"I B")) D G ASKCAN
	16486	"RTN","PSO CPB",73,0)
	16487	. K DIR S DIR(0)="Y ",DIR("B") ="N",DIR(" A")="Do yo u want to reset the status to
	16488	NO COPAYME NT" D ^DIR K DIR
	16489	"RTN","PSO CPB",74,0)
	16490	. I Y'=1 Q
	16491	"RTN","PSO CPB",75,0)
	16492	. S DIC=" ^IBE(350.3 ,",DIC("S" )="I $P(^( 0),U,3)'=2 ",DIC(0)=" AEQMZ",DIC ("A")="Sel
	16493	ect Reason for Reset : " D ^DI C K DIC I Y'<0 S PSO RSN=+Y
	16494	"RTN","PSO CPB",76,0)
	16495	. S PREA= "R",PSOOLD ="Copay",P SONW="No C opay",PSOC OMM="" D A CTLOG^PSOC PA
	16496	"RTN","PSO CPB",77,0)
	16497	. S PSI=0 ,PSOCOMM=" Copay stat us of this Rx has be en reset t o NO COPAY ." D SETSU
	16498	MM^PSOCPC
	16499	"RTN","PSO CPB",78,0)
	16500	. S $P(^P SRX(PSODA, "IB"),"^") ="" ;Reset flag to N O COPAY
	16501	"RTN","PSO CPB",79,0)
	16502	ASKCAN D A SKCAN^PSOC PD
	16503	"RTN","PSO CPB",80,0)
	16504	I '$D(PSO SUMM) S PS I=0,PSOCOM M="No acti on taken" D SETSUMM^ PSOCPC
	16505	"RTN","PSO CPB",81,0)
	16506	D PRTSUMM
	16507	"RTN","PSO CPB",82,0)
	16508	;I $P($G( PSOPFS),"^ ",3)>0&(+$ G(PSOPFSA) ) D CHRG^P SOPFSU1(PS ODA,PSOLFI L,"CG",PSO
	16509	PFS) ;PSO 7.0463
	16510	"RTN","PSO CPB",83,0)
	16511	RESETE K P SODA,PSORX N,PSORSN,P SOREF,X,Y, PCOPAY,PRE A,PSOCOMM, PSI
	16512	"RTN","PSO CPB",84,0)
	16513	G RESET
	16514	"RTN","PSO CPB",85,0)
	16515	EXT K PSOD A,PSORXN,P SORSN,PSOR EF,X,Y,PCO PAY,PREA,P SOCOPAY
	16516	"RTN","PSO CPB",86,0)
	16517	Q
	16518	"RTN","PSO CPB",87,0)
	16519	BILLED ;Co llect IB n ums,cancel chrgs,res et flag.
	16520	"RTN","PSO CPB",88,0)
	16521	W !!,"* ****Cha rges are o n file for this Rx. *********"
	16522	"RTN","PSO CPB",89,0)
	16523	Q
	16524	"RTN","PSO CPB",90,0)
	16525	BILL2 ;
	16526	"RTN","PSO CPB",91,0)
	16527	N PSOPREV ; VAR FOR PREV CANC ELLED
	16528	"RTN","PSO CPB",92,0)
	16529	S PSOPREV =0
	16530	"RTN","PSO CPB",93,0)
	16531	S DIC="^I BE(350.3," ,DIC("S")= "I $P(^(0) ,U,3)'=2", DIC(0)="AE QMZ",DIC(" A")="Selec
	16532	t Reason f or Reset o r Charge C ancellatio n : " D ^D IC K DIC G ENDMSG:Y< 0 S PSORSN
	16533	=+Y
	16534	"RTN","PSO CPB",94,0)
	16535	S X=PSOPA R7_"^"_+$P (^PSRX(PSO DA,0),"^", 2)_"^^"_DU Z
	16536	"RTN","PSO CPB",95,0)
	16537	S SAVX=X
	16538	"RTN","PSO CPB",96,0)
	16539	I $D(PSOC AN) D:'$G( PSOPFS) I +$G(PSOPF S)!($G(PSO PFSG)) D P FS^PSOPFSU 1 G BILL2E
	16540	ND:'$D(PSO CAN)
	16541	"RTN","PSO CPB",97,0)
	16542	. N III S III="" F S III=$O( PSOCAN(III )) Q:III=" " I PSOCA N(III)["PF S" S PSOPF
	16543	SG=1 Q ;P FSS switch off, chec k for prev cots bill ing
	16544	"RTN","PSO CPB",98,0)
	16545	D POTBILL 2
	16546	"RTN","PSO CPB",99,0)
	16547	I '$D(PSO CAN) G BIL L2END
	16548	"RTN","PSO CPB",100,0 )
	16549	I $G(CANT YPE) D PRE VCAN I $O( X(""))="" Q
	16550	"RTN","PSO CPB",101,0 )
	16551	I '$G(CAN TYPE) S I= "" F S I= $O(PSOCAN( I)) Q:I="" S X($P(P SOCAN(I)," ^",1))=$P(
	16552	PSOCAN(I), "^",2)_"^" _PSORSN
	16553	"RTN","PSO CPB",102,0 )
	16554	D CANCEL^ IBARX
	16555	"RTN","PSO CPB",103,0 )
	16556	I $G(CANT YPE) D MSG
	16557	"RTN","PSO CPB",104,0 )
	16558	I '$D(Y) Q
	16559	"RTN","PSO CPB",105,0 )
	16560	I +Y=-1 Q
	16561	"RTN","PSO CPB",106,0 )
	16562	I $D(Y(PS ORXN)),+Y( PSORXN)'=- 1 S $P(^PS RX(PSODA," IB"),"^",2 )=+Y(PSORX N) K Y(PSO
	16563	RXN) S PRE A="C",PSOR EF=0,PSOOL D="",PSONW ="" D ACTL OG^PSOCPA I '$G(CANT YPE) D MSG
	16564	"RTN","PSO CPB",107,0 )
	16565	F PSOREF= 0:0 S PSOR EF=$O(Y(PS OREF)) Q:P SOREF="" I +Y(PSORE F)'=-1 S ^ PSRX(PSODA
	16566	,1,PSOREF, "IB")=+Y(P SOREF) S P REA="C",PS OOLD="",PS ONW="" D A CTLOG^PSOC PA I '$G(C
	16567	ANTYPE) D MSG
	16568	"RTN","PSO CPB",108,0 )
	16569	BILL2END K X,Y,SAVX, PSOREF,PSO CAN
	16570	"RTN","PSO CPB",109,0 )
	16571	Q
	16572	"RTN","PSO CPB",110,0 )
	16573	;
	16574	"RTN","PSO CPB",111,0 )
	16575	POTBILL2 ; see if any potential charges ( entries fr om file 35 4.71 -- bi lls that e
	16576	xceeded ca p prev) to be cancel led before cancellin g regular charges
	16577	"RTN","PSO CPB",112,0 )
	16578	N X,I
	16579	"RTN","PSO CPB",113,0 )
	16580	S X=SAVX
	16581	"RTN","PSO CPB",114,0 )
	16582	I $T(CANI BAM^IBARX) ="" Q
	16583	"RTN","PSO CPB",115,0 )
	16584	S I="" F S I=$O(PS OCAN(I)) Q :I="" I P SOCAN(I)[" ^CAP" S X( $P(PSOCAN( I),"^",1))
	16585	=$P(PSOCAN (I),"^",2) _"^"_PSORS N K PSOCAN (I)
	16586	"RTN","PSO CPB",116,0 )
	16587	I $O(X("" ))="" Q
	16588	"RTN","PSO CPB",117,0 )
	16589	S PSOPREV =1
	16590	"RTN","PSO CPB",118,0 )
	16591	D CANIBAM ^IBARX
	16592	"RTN","PSO CPB",119,0 )
	16593	I $D(X(PS ORXN)) S $ P(^PSRX(PS ODA,"IB"), "^",4)="" S PREA="C" ,PSOREF=0, PSOCOMM="P
	16594	otential c harge canc elled",PSO OLD="",PSO NW="" D AC TLOG^PSOCP A D POTMSG K X(PSORX
	16595	N)
	16596	"RTN","PSO CPB",120,0 )
	16597	F PSOREF= 0:0 S PSOR EF=$O(X(PS OREF)) Q:P SOREF="" Q:PSOREF>1 1 S $P(^P SRX(PSODA,
	16598	1,PSOREF," IB"),"^",2 )="" S PRE A="C",PSOC OMM="Poten tial charg e cancelle d",PSOOLD=
	16599	"",PSONW=" " D ACTLOG ^PSOCPA D POTMSG
	16600	"RTN","PSO CPB",121,0 )
	16601	K PSOREF, PREA,PSOCO MM
	16602	"RTN","PSO CPB",122,0 )
	16603	Q
	16604	"RTN","PSO CPB",123,0 )
	16605	REFILL S P SOREF=0
	16606	"RTN","PSO CPB",124,0 )
	16607	F S PSOR EF=$O(^PSR X(PSODA,1, PSOREF)) Q :PSOREF'?1 N.N D
	16608	"RTN","PSO CPB",125,0 )
	16609	. I $D(^P SRX(PSODA, 1,PSOREF," PFS")) S:$ P($G(^PSRX (PSODA,1,P SOREF,"PFS ")),"^",2)
	16610	X(PSOREF) ="^"_$G(PS ORSN) Q
	16611	"RTN","PSO CPB",126,0 )
	16612	. I $D(^P SRX(PSODA, 1,PSOREF," IB")),+^(" IB")>0 S X (PSOREF)=+ ^PSRX(PSOD A,1,PSOREF
	16613	,"IB")_"^" _$G(PSORSN )
	16614	"RTN","PSO CPB",127,0 )
	16615	S PSOREF= 0 F S PSO REF=$O(^PS RX(PSODA,1 ,PSOREF)) Q:PSOREF'? 1N.N I '$ D(X(PSOREF
	16616	)),+$P($G( ^PSRX(PSOD A,1,PSOREF ,"IB")),"^ ",2) S XX( PSOREF)=+$ P(^PSRX(PS ODA,1,PSOR
	16617	EF,"IB")," ^",2)_"^"_ $G(PSORSN) ; IF ONLY ENTRY FRO M 354.71 S AVE IT
	16618	"RTN","PSO CPB",128,0 )
	16619	Q
	16620	"RTN","PSO CPB",129,0 )
	16621	SETCP ;IF NOT COPAY MAKE ELIG CALL/SET F LAG FOR FU TURE
	16622	"RTN","PSO CPB",130,0 )
	16623	W ! S X=P SOPAR7_"^" _+$P(^PSRX (PSODA,0), "^",2)
	16624	"RTN","PSO CPB",131,0 )
	16625	D XTYPE^I BARX
	16626	"RTN","PSO CPB",132,0 )
	16627	I +Y=-1 W !!,"Error in proces sing Copay eligibili ty, no act ion taken. " Q
	16628	"RTN","PSO CPB",133,0 )
	16629	S (ACTYP, BL)="",(PS OBILL,PSOC PAY)=0
	16630	"RTN","PSO CPB",134,0 )
	16631	CP ;
	16632	"RTN","PSO CPB",135,0 )
	16633	S ACTYP=$ O(Y(ACTYP) ) G:'ACTYP CP1
	16634	"RTN","PSO CPB",136,0 )
	16635	F I=0:0 S BL=$O(Y(A CTYP,BL)) Q:BL="" I BL>0 S PS OBILL=BL,P SOCPAY=ACT YP
	16636	"RTN","PSO CPB",137,0 )
	16637	G CP
	16638	"RTN","PSO CPB",138,0 )
	16639	CP1 K ACTY P,BL,I
	16640	"RTN","PSO CPB",139,0 )
	16641	I (PSOBIL L'>0)!(PSO CPAY=0) G INELIG
	16642	"RTN","PSO CPB",140,0 )
	16643	S $P(^PSR X(PSODA,"I B"),"^")=P SOCPAY
	16644	"RTN","PSO CPB",141,0 )
	16645	W !,"COPA Y status o n this Rx has been r eset.",!," *** Future refills w ill be cla
	16646	ssified as COPAY."
	16647	"RTN","PSO CPB",142,0 )
	16648	S PREA="R ",PSOOLD=" No Copay", PSONW="Cop ay"
	16649	"RTN","PSO CPB",143,0 )
	16650	D ACTLOG^ PSOCPA
	16651	"RTN","PSO CPB",144,0 )
	16652	Q
	16653	"RTN","PSO CPB",145,0 )
	16654	INELIG W ! ,"This Rx does not m eet patien t eligibil ity requir ement for Copay.",!,
	16655	"**** St atus uncha nged * "
	16656	"RTN","PSO CPB",146,0 )
	16657	S Y=-1
	16658	"RTN","PSO CPB",147,0 )
	16659	Q
	16660	"RTN","PSO CPB",148,0 )
	16661	ENDMSG K X W !,"Unab le to proc ess CHARGE REMOVAL w ithout REA SON for Re set."
	16662	"RTN","PSO CPB",149,0 )
	16663	R !,"ENTE R a REASON now? (Y/ N) ",X:DTI ME Q:'$T
	16664	"RTN","PSO CPB",150,0 )
	16665	I ($E(X)[ "?")!("YyN n^"'[$E(X) ) W !,"Ent er YES to select REA SON and RE SET STATUS
	16666	." G ENDMS G
	16667	"RTN","PSO CPB",151,0 )
	16668	I "Yy"[$E (X) G BILL 2
	16669	"RTN","PSO CPB",152,0 )
	16670	Q
	16671	"RTN","PSO CPB",153,0 )
	16672	MSG ;
	16673	"RTN","PSO CPB",154,0 )
	16674	S PSI=0
	16675	"RTN","PSO CPB",155,0 )
	16676	I $G(CANT YPE) S PSO COMM="Rx # "_PSORXN_ " - All co pay charge s cancelle d" D SETSU
	16677	MM^PSOCPC K PSOCOMM Q
	16678	"RTN","PSO CPB",156,0 )
	16679	S PSOCOMM ="Rx # "_P SORXN_" - "_$S(PSORE F=0:"Origi nal fill", 1:"Refill "_PSOREF)_
	16680	" copay ch arge cance lled"
	16681	"RTN","PSO CPB",157,0 )
	16682	D SETSUMM ^PSOCPC
	16683	"RTN","PSO CPB",158,0 )
	16684	K PSOCOMM
	16685	"RTN","PSO CPB",159,0 )
	16686	Q
	16687	"RTN","PSO CPB",160,0 )
	16688	POTMSG ;
	16689	"RTN","PSO CPB",161,0 )
	16690	S PSI=0
	16691	"RTN","PSO CPB",162,0 )
	16692	I $G(CANT YPE) Q ; (MESSAGE W ILL GET SE T LATER)
	16693	"RTN","PSO CPB",163,0 )
	16694	S PSOCOMM ="Rx # "_P SORXN_" - "_$S(PSORE F=0:"Origi nal fill", 1:"Refill "_PSOREF)_
	16695	" potentia l copay ch arge cance lled"
	16696	"RTN","PSO CPB",164,0 )
	16697	D SETSUMM ^PSOCPC
	16698	"RTN","PSO CPB",165,0 )
	16699	K PSOCOMM
	16700	"RTN","PSO CPB",166,0 )
	16701	Q
	16702	"RTN","PSO CPB",167,0 )
	16703	MSGNOCAN ;
	16704	"RTN","PSO CPB",168,0 )
	16705	S PSI=0
	16706	"RTN","PSO CPB",169,0 )
	16707	S PSOCOMM ="Rx # "_P SORXN_" - All copay charges ha ve already been canc elled." D
	16708	SETSUMM^PS OCPC K PSO COMM
	16709	"RTN","PSO CPB",170,0 )
	16710	Q
	16711	"RTN","PSO CPB",171,0 )
	16712	;
	16713	"RTN","PSO CPB",172,0 )
	16714	PRTSUMM ; prt sum of actions i n reset/ca ncel
	16715	"RTN","PSO CPB",173,0 )
	16716	I '$D(PSO SUMM) Q
	16717	"RTN","PSO CPB",174,0 )
	16718	W !
	16719	"RTN","PSO CPB",175,0 )
	16720	S PSI=""
	16721	"RTN","PSO CPB",176,0 )
	16722	F S PSI= $O(PSOSUMM (PSI)) Q:P SI="" W ! ,PSOSUMM(P SI)
	16723	"RTN","PSO CPB",177,0 )
	16724	K PSOSUMM
	16725	"RTN","PSO CPB",178,0 )
	16726	Q
	16727	"RTN","PSO CPB",179,0 )
	16728	PREVCAN ; PREVIEW CA NCELS IF " ALL" IS SE LECTED
	16729	"RTN","PSO CPB",180,0 )
	16730	N I,PSOBI LL
	16731	"RTN","PSO CPB",181,0 )
	16732	S I="" F S I=$O(PS OCAN(I)) Q :I="" D I PSOBILL S X($P(PSO CAN(I),"^" ,1))=$P(PS
	16733	OCAN(I),"^ ",2)_"^"_P SORSN
	16734	"RTN","PSO CPB",182,0 )
	16735	. S PSOBI LL=1 I $T( STATUS^IBA RX)'="" I PSOCAN(I)' ["CAP" S P SOBILL=$$S TATUS^IBAR
	16736	X($P(PSOCA N(I),"^",2 )) S:PSOBI LL=2 PSOBI LL=0 ; PRE VIOUSLY CA NCELLED
	16737	"RTN","PSO CPB",183,0 )
	16738	I $O(X("" ))="" D
	16739	"RTN","PSO CPB",184,0 )
	16740	. I PSOPR EV D MSG Q
	16741	"RTN","PSO CPB",185,0 )
	16742	. D MSGNO CAN
	16743	"RTN","PSO CPB",186,0 )
	16744	Q
	16745	"RTN","PSO CPB",187,0 )
	16746	;
	16747	"RTN","PSO CPF")
	16748	0^2^B63370 420
	16749	"RTN","PSO CPF",1,0)
	16750	PSOCPF ;BI R/BAA - Ph armacy CO- PAY Applic ation Util ities for IB ;02/06/ 92
	16751	"RTN","PSO CPF",2,0)
	16752	;;7.0;OUT PATIENT PH ARMACY;4 63;DEC 1 997;Build 2
	16753	"RTN","PSO CPF",3,0)
	16754	;;Per VA Directive 6402, this routine s hould not be modifie d.
	16755	"RTN","PSO CPF",4,0)
	16756	;
	16757	"RTN","PSO CPF",5,0)
	16758	EN ; -- ma in entry p oint for H ELD CHARGE S LIST
	16759	"RTN","PSO CPF",6,0)
	16760	;
	16761	"RTN","PSO CPF",7,0)
	16762	; add cod e to do fi lters here
	16763	"RTN","PSO CPF",8,0)
	16764	N FILTERS
	16765	"RTN","PSO CPF",9,0)
	16766	I '$$FILT ER(.FILTER S) Q
	16767	"RTN","PSO CPF",10,0)
	16768	;
	16769	"RTN","PSO CPF",11,0)
	16770	; code to do sort
	16771	"RTN","PSO CPF",12,0)
	16772	D SORT
	16773	"RTN","PSO CPF",13,0)
	16774	;
	16775	"RTN","PSO CPF",14,0)
	16776	K XQORS,V ALMEVL D E N^VALM("PS O PATIENT MEDICATION LIST")
	16777	"RTN","PSO CPF",15,0)
	16778	D ^%ZISC
	16779	"RTN","PSO CPF",16,0)
	16780	Q
	16781	"RTN","PSO CPF",17,0)
	16782	;
	16783	"RTN","PSO CPF",18,0)
	16784	HDR ; -- h eader code
	16785	"RTN","PSO CPF",19,0)
	16786	;
	16787	"RTN","PSO CPF",20,0)
	16788	N BDATE,E DATE,MEDSA ,PATS,STAT
	16789	"RTN","PSO CPF",21,0)
	16790	S BDATE=$ P(FILTERS( 0),U,1),ED ATE=$P(FIL TERS(0),U, 2)
	16791	"RTN","PSO CPF",22,0)
	16792	S MEDS=$P (FILTERS(0 ),U,3),PAT =$P(FILTER S(0),U,4)
	16793	"RTN","PSO CPF",23,0)
	16794	S STATS=$ P(FILTERS( 0),U,5)
	16795	"RTN","PSO CPF",24,0)
	16796	;
	16797	"RTN","PSO CPF",25,0)
	16798	S VALM("T ITLE")=" P atient Med ications f or "_$E($P ($G(^DPT(P AT,0)),"^" ),1,20)_"
	16799	"_$E($G(^( 0)),1)_VA( "BID")
	16800	"RTN","PSO CPF",26,0)
	16801	Q
	16802	"RTN","PSO CPF",27,0)
	16803	;
	16804	"RTN","PSO CPF",28,0)
	16805	INIT ; -- init varia bles and l ist array
	16806	"RTN","PSO CPF",29,0)
	16807	; input - ^TMP($J," PSOCPF")
	16808	"RTN","PSO CPF",30,0)
	16809	; output - ^TMP("VA LMAR",$J)
	16810	"RTN","PSO CPF",31,0)
	16811	N BDATE,E DATE,INSTS ,PATS,IINS ,OLDH
	16812	"RTN","PSO CPF",32,0)
	16813	S BDATE=$ P(FILTERS( 0),U,1),ED ATE=$P(FIL TERS(0),U, 2)
	16814	"RTN","PSO CPF",33,0)
	16815	S MEDS=$P (FILTERS(0 ),U,3),PAT S=$P(FILTE RS(0),U,4)
	16816	"RTN","PSO CPF",34,0)
	16817	S STATS=$ P(FILTERS( 0),U,5)
	16818	"RTN","PSO CPF",35,0)
	16819	D BLD
	16820	"RTN","PSO CPF",36,0)
	16821	Q
	16822	"RTN","PSO CPF",37,0)
	16823	;
	16824	"RTN","PSO CPF",38,0)
	16825	SORT ; get the data
	16826	"RTN","PSO CPF",39,0)
	16827	N BDATE,E DATE,MEDS, PATS
	16828	"RTN","PSO CPF",40,0)
	16829	S BDATE=$ P(FILTERS( 0),U,1),ED ATE=$P(FIL TERS(0),U, 2)
	16830	"RTN","PSO CPF",41,0)
	16831	S MEDS=$P (FILTERS(0 ),U,3),PAT S=$P(FILTE RS(0),U,4)
	16832	"RTN","PSO CPF",42,0)
	16833	S RXS=$P( FILTERS(0) ,U,3),PATS =$P(FILTER S(0),U,4)
	16834	"RTN","PSO CPF",43,0)
	16835	S ^TMP($J ,"PSOCPFF" )=FILTERS( 0)
	16836	"RTN","PSO CPF",44,0)
	16837	;
	16838	"RTN","PSO CPF",45,0)
	16839	D SORT^PS OCPF1
	16840	"RTN","PSO CPF",46,0)
	16841	Q
	16842	"RTN","PSO CPF",47,0)
	16843	;
	16844	"RTN","PSO CPF",48,0)
	16845	BLD ; buil d data to display
	16846	"RTN","PSO CPF",49,0)
	16847	; build d isplay
	16848	"RTN","PSO CPF",50,0)
	16849	; ^TMP($J ,"PSOCPF", PTNM,RIEN, RFL)=PTNM_ U_PID_U_ME D_U_RIEN_U _RFL_U_ART RN_U_RX_U_
	16850	FILDT_U_BL NO_U_ARST1 _U_SC_U_SC P_U_MTSD_U _MTS_U_DFN _U_PBIL_U_ ARST_U_PRI EN
	16851	"RTN","PSO CPF",51,0)
	16852	K ^TMP($J ,"PSOCPFX" )
	16853	"RTN","PSO CPF",52,0)
	16854	K ^TMP("V ALMAR",$J)
	16855	"RTN","PSO CPF",53,0)
	16856	S NODATA= 0
	16857	"RTN","PSO CPF",54,0)
	16858	I '$D(^TM P($J,"PSOC PF")) D Q
	16859	"RTN","PSO CPF",55,0)
	16860	. S VCNT= 1,NODATA=1
	16861	"RTN","PSO CPF",56,0)
	16862	. S LINE= $$SETL("", "","",1,4)
	16863	"RTN","PSO CPF",57,0)
	16864	. S LINE= $$SETL(LIN E,"NO DATA FOUND FOR ENTERED C RITERIA"," ",5,50)
	16865	"RTN","PSO CPF",58,0)
	16866	. S VALMC NT=1
	16867	"RTN","PSO CPF",59,0)
	16868	. D SET^V ALM10(VALM CNT,LINE,V CNT)
	16869	"RTN","PSO CPF",60,0)
	16870	N RFL,VCN T,MED,NAME ,RFL,SC,SC P,FILDT,BL N,IBST1,MT S,RX,REC,V ALMY
	16871	"RTN","PSO CPF",61,0)
	16872	S VALMCNT =0
	16873	"RTN","PSO CPF",62,0)
	16874	S (RIEN,V CNT)=0,(NA ME,RFL)=""
	16875	"RTN","PSO CPF",63,0)
	16876	F S NAME =$O(^TMP($ J,"PSOCPF" ,NAME)) Q: NAME="" D
	16877	"RTN","PSO CPF",64,0)
	16878	. F S RI EN=$O(^TMP ($J,"PSOCP F",NAME,RI EN)) Q:RIE N="" D
	16879	"RTN","PSO CPF",65,0)
	16880	.. F S R FL=$O(^TMP ($J,"PSOCP F",NAME,RI EN,RFL)) Q :RFL="" D
	16881	"RTN","PSO CPF",66,0)
	16882	... S VCN T=VCNT+1
	16883	"RTN","PSO CPF",67,0)
	16884	... S LIN E=$$SETL(" ",VCNT,"", 1,4) ;line #
	16885	"RTN","PSO CPF",68,0)
	16886	... S REC =^TMP($J," PSOCPF",NA ME,RIEN,RF L),PID=$P( REC,U,2),A RST1=$P(RE C,U,10),PB
	16887	IL=$P(REC, U,16)
	16888	"RTN","PSO CPF",69,0)
	16889	... S MED =$P(REC,U, 3),RX=$P(R EC,U,7),BL N=$P(REC,U ,9),FILDT= $P(REC,U,8 ),DFN=$P(R
	16890	EC,U,15)
	16891	"RTN","PSO CPF",70,0)
	16892	... S PRI EN=$P(REC, U,18)
	16893	"RTN","PSO CPF",71,0)
	16894	... I $D( ^TMP($J,"P SOCPF",NAM E,PSODA,RF L,"C")) S ARST1="CAN CELLED BIL L"
	16895	"RTN","PSO CPF",72,0)
	16896	... S ^TM P($J,"PSOC PFX",VCNT) =NAME_U_DF N_U_MED_U_ RIEN_U_BLN _U_PRIEN
	16897	"RTN","PSO CPF",73,0)
	16898	... S LIN E=$$SETL(L INE,NAME," ",5,22)
	16899	"RTN","PSO CPF",74,0)
	16900	... S LIN E=$$SETL(L INE,PID,"" ,28,6)
	16901	"RTN","PSO CPF",75,0)
	16902	... S LIN E=$$SETL(L INE,MED,"" ,35,16)
	16903	"RTN","PSO CPF",76,0)
	16904	... S LIN E=$$SETL(L INE,$$FMTE ^XLFDT(FIL DT,"2DZ"), "",53,8)
	16905	"RTN","PSO CPF",77,0)
	16906	... S LIN E=$$SETL(L INE,ARST1, "",62,17)
	16907	"RTN","PSO CPF",78,0)
	16908	... S VAL MCNT=VALMC NT+1
	16909	"RTN","PSO CPF",79,0)
	16910	... D SET ^VALM10(VA LMCNT,LINE ,VCNT)
	16911	"RTN","PSO CPF",80,0)
	16912	... S RXO ="Rx#:"_RX
	16913	"RTN","PSO CPF",81,0)
	16914	... S BLN O="BIL#:"_ BLN
	16915	"RTN","PSO CPF",82,0)
	16916	... S SC= $P(REC,U,1 1),SCO=$S( SC=1:"YES" ,1:"NO"),S COO="SC:"_ SCO
	16917	"RTN","PSO CPF",83,0)
	16918	... S SCP =$P(REC,U, 12),SCPO=" SC%:"_+SCP
	16919	"RTN","PSO CPF",84,0)
	16920	... S LIN E=$$SETL(" ",SCOO,"", 5,8)
	16921	"RTN","PSO CPF",85,0)
	16922	... S LIN E=$$SETL(L INE,SCPO," ",14,8)
	16923	"RTN","PSO CPF",86,0)
	16924	... S LIN E=$$SETL(L INE,RXO,"" ,35,20)
	16925	"RTN","PSO CPF",87,0)
	16926	... S LIN E=$$SETL(L INE,BLNO," ",62,17)
	16927	"RTN","PSO CPF",88,0)
	16928	... S VAL MCNT=VALMC NT+1
	16929	"RTN","PSO CPF",89,0)
	16930	... D SET ^VALM10(VA LMCNT,LINE ,VCNT)
	16931	"RTN","PSO CPF",90,0)
	16932	... S MTS D=$$FMTE^X LFDT($P(RE C,U,13),"2 DZ"),MTO=" MT DT:"_MT SD
	16933	"RTN","PSO CPF",91,0)
	16934	... S MTS =$P(REC,U, 14),MTSO=" MTS:"_MTS
	16935	"RTN","PSO CPF",92,0)
	16936	... S LIN E=$$SETL(" ",MTSO,"", 5,20)
	16937	"RTN","PSO CPF",93,0)
	16938	... S LIN E=$$SETL(L INE,MTO,"" ,30,14)
	16939	"RTN","PSO CPF",94,0)
	16940	... S VAL MCNT=VALMC NT+1
	16941	"RTN","PSO CPF",95,0)
	16942	... D SET ^VALM10(VA LMCNT,LINE ,VCNT)
	16943	"RTN","PSO CPF",96,0)
	16944	... S LIN E=""
	16945	"RTN","PSO CPF",97,0)
	16946	... S VAL MCNT=VALMC NT+1
	16947	"RTN","PSO CPF",98,0)
	16948	... D SET ^VALM10(VA LMCNT,LINE ,VCNT)
	16949	"RTN","PSO CPF",99,0)
	16950	Q
	16951	"RTN","PSO CPF",100,0 )
	16952	;
	16953	"RTN","PSO CPF",101,0 )
	16954	SETL(LINE, DATA,LABEL ,COL,LNG) ; Creates a line of data to be set into the body
	16955	"RTN","PSO CPF",102,0 )
	16956	; of the worklist
	16957	"RTN","PSO CPF",103,0 )
	16958	; Input: LINE - Cur rent line being crea ted
	16959	"RTN","PSO CPF",104,0 )
	16960	; DATA - Informatio n to be ad ded to the end of th e current line
	16961	"RTN","PSO CPF",105,0 )
	16962	; LABEL - Label to describe t he informa tion being added
	16963	"RTN","PSO CPF",106,0 )
	16964	; COL - C olumn posi tion in li ne to add informatio n add
	16965	"RTN","PSO CPF",107,0 )
	16966	; LNG - M aximum len gth of dat a informat ion to inc lude on th e line
	16967	"RTN","PSO CPF",108,0 )
	16968	; Returns : Line upd ated with added info rmation
	16969	"RTN","PSO CPF",109,0 )
	16970	S LINE=LI NE_$J("",( COL-$L(LAB EL)-$L(LIN E)))_LABEL _$E(DATA,1 ,LNG)
	16971	"RTN","PSO CPF",110,0 )
	16972	Q LINE
	16973	"RTN","PSO CPF",111,0 )
	16974	;
	16975	"RTN","PSO CPF",112,0 )
	16976	HELP ; -- help code
	16977	"RTN","PSO CPF",113,0 )
	16978	S X="?" D DISP^XQOR M1 W !!
	16979	"RTN","PSO CPF",114,0 )
	16980	Q
	16981	"RTN","PSO CPF",115,0 )
	16982	;
	16983	"RTN","PSO CPF",116,0 )
	16984	EXIT ; -- exit code
	16985	"RTN","PSO CPF",117,0 )
	16986	K ^TMP($J ,"PSOCPF")
	16987	"RTN","PSO CPF",118,0 )
	16988	K ^TMP($J ,"PSOCPFX" )
	16989	"RTN","PSO CPF",119,0 )
	16990	;
	16991	"RTN","PSO CPF",120,0 )
	16992	D CLEAR^V ALM1,CLEAN ^VALM10
	16993	"RTN","PSO CPF",121,0 )
	16994	D ^%ZISC
	16995	"RTN","PSO CPF",122,0 )
	16996	Q
	16997	"RTN","PSO CPF",123,0 )
	16998	;
	16999	"RTN","PSO CPF",124,0 )
	17000	FILTER(FIL TERS) ; fi lter displ ay
	17001	"RTN","PSO CPF",125,0 )
	17002	; Sets an array of filters to determine which ent ris to inc lude in di splay
	17003	"RTN","PSO CPF",126,0 )
	17004	; Input: None
	17005	"RTN","PSO CPF",127,0 )
	17006	; Output:
	17007	"RTN","PSO CPF",128,0 )
	17008	; Returns : 0 if the user ente red '^' or timed out , 1 otherw ise
	17009	"RTN","PSO CPF",129,0 )
	17010	; FILTERS (0) = from date ^ to date ^ 0 (all) 1 (s elected) p rescriptio ns ^ patie
	17011	nt ^
	17012	"RTN","PSO CPF",130,0 )
	17013	; 0 (no) 1 (ye s) exclued canceled bills
	17014	"RTN","PSO CPF",131,0 )
	17015	; FILTERS (1,RX ien) = ""
	17016	"RTN","PSO CPF",132,0 )
	17017	N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,XX,Y,I BDATES
	17018	"RTN","PSO CPF",133,0 )
	17019	K FILTERS
	17020	"RTN","PSO CPF",134,0 )
	17021	;
	17022	"RTN","PSO CPF",135,0 )
	17023	S DIC(0)= "AEQMN",DI C="^DPT(", FIRST=1
	17024	"RTN","PSO CPF",136,0 )
	17025	S PAT=$$O NEPAT()
	17026	"RTN","PSO CPF",137,0 )
	17027	S PNAME=$ P(PAT,U,2)
	17028	"RTN","PSO CPF",138,0 )
	17029	S (DFN,PA T,$P(FILTE RS(0),U,4) )=$P(PAT,U ,1)
	17030	"RTN","PSO CPF",139,0 )
	17031	;
	17032	"RTN","PSO CPF",140,0 )
	17033	; get dat e range
	17034	"RTN","PSO CPF",141,0 )
	17035	S IBDATES ="Fill Dat es",IBDATE S=$$FMDATE S(IBDATES) I IBDATES =0 Q 0
	17036	"RTN","PSO CPF",142,0 )
	17037	S FILTERS (0)=IBDATE S
	17038	"RTN","PSO CPF",143,0 )
	17039	;
	17040	"RTN","PSO CPF",144,0 )
	17041	; Prescri ption filt er
	17042	"RTN","PSO CPF",145,0 )
	17043	D ADDRX
	17044	"RTN","PSO CPF",146,0 )
	17045	;
	17046	"RTN","PSO CPF",147,0 )
	17047	; Ask use r if they want to in clude canc elled clai ms
	17048	"RTN","PSO CPF",148,0 )
	17049	S DIR(0)= "Y",DIR("B ")="No",DI R("A")="Wo uld you li ke to excl ude cancel led bills"
	17050	"RTN","PSO CPF",149,0 )
	17051	W ! D ^DI R K DIR
	17052	"RTN","PSO CPF",150,0 )
	17053	S $P(FILT ERS(0),U,5 )=$S(Y="Y" :1,1:0)
	17054	"RTN","PSO CPF",151,0 )
	17055	S X=$$UP^ XLFSTR(X)
	17056	"RTN","PSO CPF",152,0 )
	17057	;
	17058	"RTN","PSO CPF",153,0 )
	17059	D SHOWFIL T(.FILTERS )
	17060	"RTN","PSO CPF",154,0 )
	17061	I X="^" Q 0
	17062	"RTN","PSO CPF",155,0 )
	17063	Q 1
	17064	"RTN","PSO CPF",156,0 )
	17065	;
	17066	"RTN","PSO CPF",157,0 )
	17067	ADDRX ;
	17068	"RTN","PSO CPF",158,0 )
	17069	; Prescri ption filt er
	17070	"RTN","PSO CPF",159,0 )
	17071	S DIR(0)= "S",DIR("A ")="Select (A)ll or ( S)elected Prescripti on(s):",DI R("B")="Al
	17072	l"
	17073	"RTN","PSO CPF",160,0 )
	17074	S DIR("?" ,1)="Enter 'A' to no t filter b y Prescrip tions."
	17075	"RTN","PSO CPF",161,0 )
	17076	S DIR("?" )="Enter ' S' to view entries f or selecte d Prescrip tion(s)."
	17077	"RTN","PSO CPF",162,0 )
	17078	S $P(DIR( 0),U,2)="A :All Presc riptions;S :Selected Prescripti ons"
	17079	"RTN","PSO CPF",163,0 )
	17080	W ! D ^DI R K DIR
	17081	"RTN","PSO CPF",164,0 )
	17082	I $G(DIRU T) Q 0
	17083	"RTN","PSO CPF",165,0 )
	17084	S X=$$UP^ XLFSTR(X)
	17085	"RTN","PSO CPF",166,0 )
	17086	S $P(FILT ERS(0),U,3 )=$S(Y="A" :0,1:1)
	17087	"RTN","PSO CPF",167,0 )
	17088	;
	17089	"RTN","PSO CPF",168,0 )
	17090	I $P(FILT ERS(0),U,3 )=1 D ASKR X(.FILTERS )
	17091	"RTN","PSO CPF",169,0 )
	17092	;
	17093	"RTN","PSO CPF",170,0 )
	17094	Q
	17095	"RTN","PSO CPF",171,0 )
	17096	;
	17097	"RTN","PSO CPF",172,0 )
	17098	FMDATES(PR OMPT) ; as k for date range
	17099	"RTN","PSO CPF",173,0 )
	17100	N %DT,X,Y ,DT1,DT2,I B0,IB1,IB2
	17101	"RTN","PSO CPF",174,0 )
	17102	S DT1="", IB1="Start with date entered: ",IB2="Go to date en tered: "
	17103	"RTN","PSO CPF",175,0 )
	17104	I $G(PROM PT)'="" S IB1="Start with "_PR OMPT_": ", IB2="Go to "_PROMPT_ ": "
	17105	"RTN","PSO CPF",176,0 )
	17106	S %DT="AE X",%DT("A" )=IB1 D ^% DT K %DT I Y<0!($P(Y ,".",1)'?7 N) G FMDQ
	17107	"RTN","PSO CPF",177,0 )
	17108	S (%DT(0) ,DT2)=$P(Y ,".",1) I DT2'>DT S %DT("B")=" Today"
	17109	"RTN","PSO CPF",178,0 )
	17110	S %DT="AE X",%DT("A" )=IB2 D ^% DT K %DT I Y<0!($P(Y ,".",1)'?7 N) G FMDQ
	17111	"RTN","PSO CPF",179,0 )
	17112	S DT1=DT2 _U_$P(Y,". ",1)
	17113	"RTN","PSO CPF",180,0 )
	17114	FMDQ Q DT1
	17115	"RTN","PSO CPF",181,0 )
	17116	;
	17117	"RTN","PSO CPF",182,0 )
	17118	ASKRX(FILT ERS) ; S ets a list of Prescr iption to be display ed
	17119	"RTN","PSO CPF",183,0 )
	17120	; Input: FILTERS - Current Array of f ilter sett ings
	17121	"RTN","PSO CPF",184,0 )
	17122	; Output: FILTERS - Updated Array of f ilter sett ings
	17123	"RTN","PSO CPF",185,0 )
	17124	N DIC,DIR ,DIRUT,DIV S,DUOUT,FI RST,PSOIEN S,PSOIENS2 ,IEN,N,X,X X,Y
	17125	"RTN","PSO CPF",186,0 )
	17126	S DIC=52, DIC(0)="AE QMN",FIRST =1
	17127	"RTN","PSO CPF",187,0 )
	17128	F D Q:+ IEN<1
	17129	"RTN","PSO CPF",188,0 )
	17130	. D ONERX (.DIC,.IEN ,.FIRST) ; O ne Prescri ption prom pt
	17131	"RTN","PSO CPF",189,0 )
	17132	. Q:+IEN< 1
	17133	"RTN","PSO CPF",190,0 )
	17134	. S PSOIE NS($P(IEN, U,2))=$P(I EN,U,1)
	17135	"RTN","PSO CPF",191,0 )
	17136	. S PSOIE NS2($P(IEN ,U,1))=$P( IEN,U,2)
	17137	"RTN","PSO CPF",192,0 )
	17138	I '$D(PSO IENS) S $P (FILTERS(0 ),U,3)=0 Q
	17139	"RTN","PSO CPF",193,0 )
	17140	;
	17141	"RTN","PSO CPF",194,0 )
	17142	; Set the filter no de respons es in alph abetical o rder
	17143	"RTN","PSO CPF",195,0 )
	17144	S XX=""
	17145	"RTN","PSO CPF",196,0 )
	17146	F D Q:X X=""
	17147	"RTN","PSO CPF",197,0 )
	17148	. S XX=$O (PSOIENS(X X))
	17149	"RTN","PSO CPF",198,0 )
	17150	. Q:XX=""
	17151	"RTN","PSO CPF",199,0 )
	17152	. S N=PSO IENS(XX)
	17153	"RTN","PSO CPF",200,0 )
	17154	. S FILTE RS(1,N)=XX
	17155	"RTN","PSO CPF",201,0 )
	17156	Q
	17157	"RTN","PSO CPF",202,0 )
	17158	;
	17159	"RTN","PSO CPF",203,0 )
	17160	ONERX(DIC, IEN,FIRST) ; Prompt s the user for a Med ication
	17161	"RTN","PSO CPF",204,0 )
	17162	; Input: DIC - Variable /Array of settings n eeded for ^DIC call
	17163	"RTN","PSO CPF",205,0 )
	17164	; FIRST - Set to 1 initially and then 0 for subs equent cal ls
	17165	"RTN","PSO CPF",206,0 )
	17166	; Output: FIRST - Set to 0
	17167	"RTN","PSO CPF",207,0 )
	17168	; IEN - IEN of t he selecte d Division
	17169	"RTN","PSO CPF",208,0 )
	17170	; null of no selecti on was mad e
	17171	"RTN","PSO CPF",209,0 )
	17172	S DIC("A" )=$S(FIRST :"Select a Prescript ion: ",1:" Select Ano ther Presc ription: "
	17173	)
	17174	"RTN","PSO CPF",210,0 )
	17175	D ^DIC
	17176	"RTN","PSO CPF",211,0 )
	17177	S FIRST=0 ,IEN=Y
	17178	"RTN","PSO CPF",212,0 )
	17179	Q
	17180	"RTN","PSO CPF",213,0 )
	17181	;
	17182	"RTN","PSO CPF",214,0 )
	17183	ONEPAT(DIC ,IEN,FIRST ) ; Promp ts the use r for a cl inic or wa rd
	17184	"RTN","PSO CPF",215,0 )
	17185	; Input: DIC - Variable /Array of settings n eeded for ^DIC call
	17186	"RTN","PSO CPF",216,0 )
	17187	; FIRST - Set to 1 initially and then 0 for subs equent cal ls
	17188	"RTN","PSO CPF",217,0 )
	17189	; Output: FIRST - Set to 0
	17190	"RTN","PSO CPF",218,0 )
	17191	; IEN - IEN of t he selecte d Patient
	17192	"RTN","PSO CPF",219,0 )
	17193	; null of no selecti on was mad e
	17194	"RTN","PSO CPF",220,0 )
	17195	N DPTNOFZ Y S DPTNOF ZY=1 ;Sup press PATI ENT file f uzzy looku ps
	17196	"RTN","PSO CPF",221,0 )
	17197	S DIC(0)= "AEQMN",DI C="^DPT("
	17198	"RTN","PSO CPF",222,0 )
	17199	S DIC("A" )="Select Patient: "
	17200	"RTN","PSO CPF",223,0 )
	17201	D ^DIC
	17202	"RTN","PSO CPF",224,0 )
	17203	Q Y
	17204	"RTN","PSO CPF",225,0 )
	17205	;
	17206	"RTN","PSO CPF",226,0 )
	17207	;
	17208	"RTN","PSO CPF",227,0 )
	17209	SHOWFILT(F ILTERS) ;EP
	17210	"RTN","PSO CPF",228,0 )
	17211	; Display s the curr ently sele cted filte r selectio ns for the
	17212	"RTN","PSO CPF",229,0 )
	17213	; Held Ch arges List Manager di splay
	17214	"RTN","PSO CPF",230,0 )
	17215	; Input: FILTERS( ) - Arra y of filte r settings . See FILT ERS for a detailed
	17216	"RTN","PSO CPF",231,0 )
	17217	; expl anation of the FILTE RS array
	17218	"RTN","PSO CPF",232,0 )
	17219	; Output: Current Filter set tings are displayed
	17220	"RTN","PSO CPF",233,0 )
	17221	;
	17222	"RTN","PSO CPF",234,0 )
	17223	N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,IEN,IX,L EN,XX,PFLG ,STDT
	17224	"RTN","PSO CPF",235,0 )
	17225	;
	17226	"RTN","PSO CPF",236,0 )
	17227	W !,"Sele cted Patie nt: ",PNAM E
	17228	"RTN","PSO CPF",237,0 )
	17229	;
	17230	"RTN","PSO CPF",238,0 )
	17231	S STDT=$P (FILTERS(0 ),U),ENDT= $P(FILTERS (0),U,2)
	17232	"RTN","PSO CPF",239,0 )
	17233	W !!!,"Sh ow From Da te: ",$S(S TDT=0:"Fir st",1:$$FM TE^XLFDT(S TDT,"2DZ") )
	17234	"RTN","PSO CPF",240,0 )
	17235	W !," Thru Date : ",$$FMTE ^XLFDT(END T,"2DZ")
	17236	"RTN","PSO CPF",241,0 )
	17237	W !,"Show All Presc riptions o r Selected Prescript ions: "
	17238	"RTN","PSO CPF",242,0 )
	17239	W $S($P(F ILTERS(0), U,3)=0:"Al l",1:"Sele cted")
	17240	"RTN","PSO CPF",243,0 )
	17241	;
	17242	"RTN","PSO CPF",244,0 )
	17243	; RX list (if any)
	17244	"RTN","PSO CPF",245,0 )
	17245	I ($P(FIL TERS(0),U, 3)=1) D
	17246	"RTN","PSO CPF",246,0 )
	17247	. S LINE= "Prescript ions to Di splay: "
	17248	"RTN","PSO CPF",247,0 )
	17249	. S IEN=0 ,PFLG=0
	17250	"RTN","PSO CPF",248,0 )
	17251	. F S IE N=$O(FILTE RS(1,IEN)) Q:IEN="" D
	17252	"RTN","PSO CPF",249,0 )
	17253	. . S XX= FILTERS(1, IEN)
	17254	"RTN","PSO CPF",250,0 )
	17255	. . S LIN E=LINE_$S( LINE="Pres criptions to Display : ":"",1:" , ")_XX
	17256	"RTN","PSO CPF",251,0 )
	17257	. W !,$$W RAP(.LINE, .PFLG,80)
	17258	"RTN","PSO CPF",252,0 )
	17259	. F I=0:0 Q:'PFLG W !,?22,$$ WRAP(.LINE ,.PFLG,58)
	17260	"RTN","PSO CPF",253,0 )
	17261	;
	17262	"RTN","PSO CPF",254,0 )
	17263	W !,"Excl ude Cancel ed Bills : "
	17264	"RTN","PSO CPF",255,0 )
	17265	W $S($P(F ILTERS(0), U,5)=0:"No ",1:"Yes")
	17266	"RTN","PSO CPF",256,0 )
	17267	;
	17268	"RTN","PSO CPF",257,0 )
	17269	K DIR
	17270	"RTN","PSO CPF",258,0 )
	17271	D PAUSE^V ALM1
	17272	"RTN","PSO CPF",259,0 )
	17273	Q
	17274	"RTN","PSO CPF",260,0 )
	17275	;
	17276	"RTN","PSO CPF",261,0 )
	17277	WRAP(STR,F LG,CL) ;
	17278	"RTN","PSO CPF",262,0 )
	17279	; STR - S TRING TO B E WRAPPED PASSED IN BY REFEREN CE SO IT C ONTAINS TH E REMAING
	17280	PORTION OF STRING
	17281	"RTN","PSO CPF",263,0 )
	17282	; FLG - F LAG TO IND ICATE WRAP PING NEEDS TO OCCUR
	17283	"RTN","PSO CPF",264,0 )
	17284	; CL - CO LUMN LENGT H
	17285	"RTN","PSO CPF",265,0 )
	17286	;
	17287	"RTN","PSO CPF",266,0 )
	17288	; NO WRAP PING REQUI RED
	17289	"RTN","PSO CPF",267,0 )
	17290	I $L(STR) '>CL S FLG =0 Q STR
	17291	"RTN","PSO CPF",268,0 )
	17292	S FLG=1
	17293	"RTN","PSO CPF",269,0 )
	17294	N A,B,C
	17295	"RTN","PSO CPF",270,0 )
	17296	; POSITIO N AFTER CO LUMN WIDTH BREAK IS A SPACE
	17297	"RTN","PSO CPF",271,0 )
	17298	I $E(STR, CL+1)=" " S B=$E(STR ,1,CL),STR =$E(STR,CL +2,999) Q B
	17299	"RTN","PSO CPF",272,0 )
	17300	S A=$E(ST R,1,CL)
	17301	"RTN","PSO CPF",273,0 )
	17302	; NO SPAC ES WITHIN COLUMN WIT H, JUST BR EAK AT COL UMN WIDTH
	17303	"RTN","PSO CPF",274,0 )
	17304	I $L(A," ")=1 S STR =$E(STR,CL +1,999) Q A
	17305	"RTN","PSO CPF",275,0 )
	17306	; BREAK O N LAST SEM ICOLON PIE CE WITHIN COLUMN WID TH
	17307	"RTN","PSO CPF",276,0 )
	17308	S C=$L(A, " ")
	17309	"RTN","PSO CPF",277,0 )
	17310	S B=$P(A, " ",1,C-1)
	17311	"RTN","PSO CPF",278,0 )
	17312	S STR=$P( A," ",C)_$ E(STR,CL+1 ,999)
	17313	"RTN","PSO CPF",279,0 )
	17314	Q B
	17315	"RTN","PSO CPF1")
	17316	0^3^B40079 369
	17317	"RTN","PSO CPF1",1,0)
	17318	PSOCPF1 ;B IR/BAA - P harmacy CO -PAY Appli cation Uti lities for IB ;02/06 /92
	17319	"RTN","PSO CPF1",2,0)
	17320	;;7.0;OUT PATIENT PH ARMACY;4 63;DEC 1 997;Build 2
	17321	"RTN","PSO CPF1",3,0)
	17322	;;Per VA Directive 6402, this routine s hould not be modifie d.
	17323	"RTN","PSO CPF1",4,0)
	17324	;
	17325	"RTN","PSO CPF1",5,0)
	17326	SORT ; get the data
	17327	"RTN","PSO CPF1",6,0)
	17328	N CNT,PTN M,PID,MED, RX,FILDT,F LN,IBST1,S C,SCP,MTSD ,MTS,RNB,D FN,MIEN
	17329	"RTN","PSO CPF1",7,0)
	17330	K ^TMP($J ,"PSOCPF")
	17331	"RTN","PSO CPF1",8,0)
	17332	S STAT=$O (^PRCA(430 .3,"B","CA NCELLED BI LL",0)),ST ATO="CANCE LLED BILL"
	17333	"RTN","PSO CPF1",9,0)
	17334	; compile data to d isplay her e
	17335	"RTN","PSO CPF1",10,0 )
	17336	S BDATE=$ P(FILTERS( 0),U,1),ED ATE=$P(FIL TERS(0),U, 2)
	17337	"RTN","PSO CPF1",11,0 )
	17338	S RXS=$P( FILTERS(0) ,U,3),PAT= $P(FILTERS (0),U,4)
	17339	"RTN","PSO CPF1",12,0 )
	17340	S STATS=$ P(FILTERS( 0),U,5)
	17341	"RTN","PSO CPF1",13,0 )
	17342	S FILDT=B DATE-.01,E ND=EDATE+. 9
	17343	"RTN","PSO CPF1",14,0 )
	17344	F S FILD T=$O(^PSRX ("AD",FILD T)) Q:FILD T>END Q:F ILDT="" D
	17345	"RTN","PSO CPF1",15,0 )
	17346	. S RIEN= 0 F S RIE N=$O(^PSRX ("AD",FILD T,RIEN)) Q :RIEN="" D
	17347	"RTN","PSO CPF1",16,0 )
	17348	.. S RFL= $O(^PSRX(" AD",FILDT, RIEN,""))
	17349	"RTN","PSO CPF1",17,0 )
	17350	.. I '$D( ^PSRX(RIEN ,0)) Q
	17351	"RTN","PSO CPF1",18,0 )
	17352	.. S DFN= $$GET1^DIQ (52,RIEN_" ,",2,"I") I DFN="" Q I '$D(^D PT(DFN,0)) Q
	17353	"RTN","PSO CPF1",19,0 )
	17354	.. I PAT' =DFN Q
	17355	"RTN","PSO CPF1",20,0 )
	17356	.. I RXS, '$D(FILTER S(1,RIEN)) Q
	17357	"RTN","PSO CPF1",21,0 )
	17358	.. D GETD ATA(RIEN)
	17359	"RTN","PSO CPF1",22,0 )
	17360	Q
	17361	"RTN","PSO CPF1",23,0 )
	17362	;
	17363	"RTN","PSO CPF1",24,0 )
	17364	GETDATA(RI EN) ;SET U P DATA FOR LIST MANA GER
	17365	"RTN","PSO CPF1",25,0 )
	17366	S RX=$$GE T1^DIQ(52, RIEN_",",. 01,"E")
	17367	"RTN","PSO CPF1",26,0 )
	17368	S DRG=$$G ET1^DIQ(52 ,RIEN_",", 6,"I"),MED =$$GET1^DI Q(52,RIEN_ ",",6,"O")
	17369	"RTN","PSO CPF1",27,0 )
	17370	I DRG="" Q
	17371	"RTN","PSO CPF1",28,0 )
	17372	D DEM^VAD PT S PTNM= VADM(1),PI D=$P(VADM( 2),U,1),PI D=$E(PTNM, 1)_$E(PID, 6,9)
	17373	"RTN","PSO CPF1",29,0 )
	17374	D ELIG^VA DPT S SC=$ P(VAEL(3), U,1),SCP=$ P(VAEL(3), U,2),MTS=$ P(VAEL(9), U,2)
	17375	"RTN","PSO CPF1",30,0 )
	17376	S MIEN="" S MIEN=$O (^DGMT(408 .31,"C",DF N,MIEN),-1 )
	17377	"RTN","PSO CPF1",31,0 )
	17378	S MREC=$S (MIEN'="": ^DGMT(408. 31,MIEN,0) ,1:""),MTS D=$P(MREC, U,1)
	17379	"RTN","PSO CPF1",32,0 )
	17380	I MTS="NO LONGER RE QUIRED" S MTSD=$P(MR EC,U,17)
	17381	"RTN","PSO CPF1",33,0 )
	17382	I RFL S I BN=$$GET1^ DIQ(52.1,R FL_","_RIE N,9,"I")
	17383	"RTN","PSO CPF1",34,0 )
	17384	I 'RFL S IBN=$$GET1 ^DIQ(52,RI EN_",",106 ,"I")
	17385	"RTN","PSO CPF1",35,0 )
	17386	I IBN="" S (PBIL,BL NO,ARTRN,P RIEN,ARST1 ,ARST)="" Q
	17387	"RTN","PSO CPF1",36,0 )
	17388	S (PBIL,A RST1,ARST, BLNO,ARTRN ,PBIL,PRIE N)=""
	17389	"RTN","PSO CPF1",37,0 )
	17390	S BLNO=$$ GET1^DIQ(3 50,IBN_"," ,.11,"I")
	17391	"RTN","PSO CPF1",38,0 )
	17392	S ARTRN=$ $GET1^DIQ( 350,IBN_", ",.12,"I")
	17393	"RTN","PSO CPF1",39,0 )
	17394	I ARTRN'= "" S (PBIL ,PRIEN)=$$ GET1^DIQ(4 33,ARTRN_" ,",.03,"I" )
	17395	"RTN","PSO CPF1",40,0 )
	17396	I BLNO="" ,PBIL'="" S BLNO=$$G ET1^DIQ(43 0,PBIL_"," ,.01)
	17397	"RTN","PSO CPF1",41,0 )
	17398	I PRIEN'= "" S ARST1 =$$GET1^DI Q(430,PRIE N_",",8,"O "),ARST=$$ GET1^DIQ(4 30,PRIEN_"
	17399	,",8,"I")
	17400	"RTN","PSO CPF1",42,0 )
	17401	;I STATS, '$D(FILTER S(3,+ARST) ) Q
	17402	"RTN","PSO CPF1",43,0 )
	17403	I 'STATS, ARST=STAT Q
	17404	"RTN","PSO CPF1",44,0 )
	17405	S ^TMP($J ,"PSOCPF", PTNM,RIEN, RFL)=PTNM_ U_PID_U_ME D_U_RIEN_U _RFL_U_ART RN_U_RX_U_
	17406	FILDT_U_BL NO_U_ARST1 _U_SC_U_SC P_U_MTSD_U _MTS_U_DFN _U_PBIL_U_ ARST_U_PRI EN_U_IBN
	17407	"RTN","PSO CPF1",45,0 )
	17408	Q
	17409	"RTN","PSO CPF1",46,0 )
	17410	;
	17411	"RTN","PSO CPF1",47,0 )
	17412	RESET ; RE SET COPAY STATUS
	17413	"RTN","PSO CPF1",48,0 )
	17414	;NAME_U_P ID_U_MED_U _RIEN_U_RF L_U_RX_U_D FN
	17415	"RTN","PSO CPF1",49,0 )
	17416	D FULL^VA LM1
	17417	"RTN","PSO CPF1",50,0 )
	17418	N I,J,IBX X,VALMY,EC NT,NAME,GO TPAT,RC,IB FR,IBTO
	17419	"RTN","PSO CPF1",51,0 )
	17420	D EN^VALM 2($G(XQORN OD(0)))
	17421	"RTN","PSO CPF1",52,0 )
	17422	I $D(VALM Y),'NODATA D
	17423	"RTN","PSO CPF1",53,0 )
	17424	. S IBXX= 0 F S IBX X=$O(VALMY (IBXX)) Q: 'IBXX D
	17425	"RTN","PSO CPF1",54,0 )
	17426	.. S RC=$ G(^TMP($J, "PSOCPFX", IBXX))
	17427	"RTN","PSO CPF1",55,0 )
	17428	.. S NAME =$P(RC,U,1 ),PSODA=$P (RC,U,4),M ED=$P(RC,U ,3),RFL=$P (RC,U,5),R X=$P(RC,U,
	17429	6),DFN=$P( RC,U,7)
	17430	"RTN","PSO CPF1",56,0 )
	17431	.. D STAT US(PSODA,R FL)
	17432	"RTN","PSO CPF1",57,0 )
	17433	D BLD^PSO CPF
	17434	"RTN","PSO CPF1",58,0 )
	17435	S VALMBCK ="R"
	17436	"RTN","PSO CPF1",59,0 )
	17437	Q
	17438	"RTN","PSO CPF1",60,0 )
	17439	;
	17440	"RTN","PSO CPF1",61,0 )
	17441	STATUS(PSO DA,RFL) ; PROCESS ST ATUS CHANG E
	17442	"RTN","PSO CPF1",62,0 )
	17443	I '$D(PSO PAR) D ^PS OLSET
	17444	"RTN","PSO CPF1",63,0 )
	17445	W !,?17," PATIENT: " ,NAME
	17446	"RTN","PSO CPF1",64,0 )
	17447	S PSORXN= $P(^PSRX(P SODA,0),"^ "),PREA="R "
	17448	"RTN","PSO CPF1",65,0 )
	17449	S PCOPAY= $G(^PSRX(P SODA,"IB") )
	17450	"RTN","PSO CPF1",66,0 )
	17451	W !!,"Rx # ",PSORXN ," is a ", $S(+PCOPAY :"Copay",1 :"No Copay ")," presc ription"
	17452	"RTN","PSO CPF1",67,0 )
	17453	D PFSA^PS OPFSU1(PSO DA,RFL,3) ;PSOCPC d ef PSOPFSA =1 if OP S C/EI's cha nge.
	17454	"RTN","PSO CPF1",68,0 )
	17455	D EXEMCHK ^PSOCPC ; CHECK/CHAN GE EXEMPTI ON FLAGS
	17456	"RTN","PSO CPF1",69,0 )
	17457	S PSOIBQ= $G(^PSRX(P SODA,"IBQ" ))
	17458	"RTN","PSO CPF1",70,0 )
	17459	;
	17460	"RTN","PSO CPF1",71,0 )
	17461	I '$G(^PS RX(PSODA," IB")),PSOI BQ'["1" D
	17462	"RTN","PSO CPF1",72,0 )
	17463	. K DIR S DIR(0)="Y ",DIR("B") ="N",DIR(" A")="Do yo u want to reset the status to
	17464	COPAY" D ^ DIR K DIR
	17465	"RTN","PSO CPF1",73,0 )
	17466	. I Y'=1 Q
	17467	"RTN","PSO CPF1",74,0 )
	17468	. S DIC=" ^IBE(350.3 ,",DIC("S" )="I $P(^( 0),U,3)'=2 ",DIC(0)=" AEQMZ",DIC ("A")="Sel
	17469	ect Reason for Reset : " D ^DI C K DIC I Y'<0 S PSO RSN=+Y
	17470	"RTN","PSO CPF1",75,0 )
	17471	. S PREA= "R",PSOOLD ="No Copay ",PSONW="C opay",PSOC OMM="" D A CTLOG^PSOC PA
	17472	"RTN","PSO CPF1",76,0 )
	17473	. S PSI=0 ,PSOCOMM=" Copay stat us of this Rx has be en reset t o COPAY." D SETSUMM^
	17474	PSOCPC
	17475	"RTN","PSO CPF1",77,0 )
	17476	. S $P(^P SRX(PSODA, "IB"),"^") =1 ;Reset flag to CO PAY
	17477	"RTN","PSO CPF1",78,0 )
	17478	;
	17479	"RTN","PSO CPF1",79,0 )
	17480	I $G(^PSR X(PSODA,"I B")) D
	17481	"RTN","PSO CPF1",80,0 )
	17482	. K DIR S DIR(0)="Y ",DIR("B") ="N",DIR(" A")="Do yo u want to reset the status to
	17483	NO COPAYME NT" D ^DIR K DIR
	17484	"RTN","PSO CPF1",81,0 )
	17485	. I Y'=1 Q
	17486	"RTN","PSO CPF1",82,0 )
	17487	. S DIC=" ^IBE(350.3 ,",DIC("S" )="I $P(^( 0),U,3)'=2 ",DIC(0)=" AEQMZ",DIC ("A")="Sel
	17488	ect Reason for Reset : " D ^DI C K DIC I Y'<0 S PSO RSN=+Y
	17489	"RTN","PSO CPF1",83,0 )
	17490	. S PREA= "R",PSOOLD ="Copay",P SONW="No C opay",PSOC OMM="" D A CTLOG^PSOC PA
	17491	"RTN","PSO CPF1",84,0 )
	17492	. S PSI=0 ,PSOCOMM=" Copay stat us of this Rx has be en reset t o NO COPAY ." D SETSU
	17493	MM^PSOCPC
	17494	"RTN","PSO CPF1",85,0 )
	17495	. S $P(^P SRX(PSODA, "IB"),"^") ="" ;Reset flag to N O COPAY
	17496	"RTN","PSO CPF1",86,0 )
	17497	Q
	17498	"RTN","PSO CPF1",87,0 )
	17499	;
	17500	"RTN","PSO CPF1",88,0 )
	17501	CANCEL ; C ANCEL COPA Y
	17502	"RTN","PSO CPF1",89,0 )
	17503	;NAME_U_P ID_U_MED_U _RIEN_U_RF L_U_RX_U_D FN
	17504	"RTN","PSO CPF1",90,0 )
	17505	D FULL^VA LM1
	17506	"RTN","PSO CPF1",91,0 )
	17507	N I,J,IBX X,VALMY,EC NT,NAME,GO TPAT,RC,IB FR,IBTO,PS OSUMM
	17508	"RTN","PSO CPF1",92,0 )
	17509	D EN^VALM 2($G(XQORN OD(0)))
	17510	"RTN","PSO CPF1",93,0 )
	17511	I '$D(PSO PAR) D ^PS OLSET
	17512	"RTN","PSO CPF1",94,0 )
	17513	I $D(VALM Y),'NODATA D
	17514	"RTN","PSO CPF1",95,0 )
	17515	. S IBXX= 0 F S IBX X=$O(VALMY (IBXX)) Q: 'IBXX D
	17516	"RTN","PSO CPF1",96,0 )
	17517	.. S RC=$ G(^TMP($J, "PSOCPFX", IBXX))
	17518	"RTN","PSO CPF1",97,0 )
	17519	.. S NAME =$P(RC,U,1 ),PSODA=$P (RC,U,4),M ED=$P(RC,U ,3),RFL=$P (RC,U,5),R X=$P(RC,U,
	17520	6),DFN=$P( RC,U,7)
	17521	"RTN","PSO CPF1",98,0 )
	17522	.. W !,?1 7,"PATIENT : ",$P($G( ^DPT($P(^P SRX(PSODA, 0),"^",2), 0)),"^")
	17523	"RTN","PSO CPF1",99,0 )
	17524	.. D ICN^ PSODPT($P( ^PSRX(PSOD A,0),"^",2 ))
	17525	"RTN","PSO CPF1",100, 0)
	17526	.. S PSOR XN=$P(^PSR X(PSODA,0) ,"^"),PREA ="R",PSOPA R7=$G(^PS( 59,PSOSITE ,"IB"))
	17527	"RTN","PSO CPF1",101, 0)
	17528	.. D ASKC AN^PSOCPD
	17529	"RTN","PSO CPF1",102, 0)
	17530	.. I $D(P SOSUMM)=1 S ^TMP($J, "PSOCPF",N AME,PSODA, RFL,"C")=" Cancelled"
	17531	"RTN","PSO CPF1",103, 0)
	17532	D BLD^PSO CPF
	17533	"RTN","PSO CPF1",104, 0)
	17534	S VALMBCK ="R"
	17535	"RTN","PSO CPF1",105, 0)
	17536	Q
	17537	"RTN","PSO CPF1",106, 0)
	17538	;
	17539	"RTN","PSO CPF1",107, 0)
	17540	EXPORT ; - - print ex cel spread sheet.
	17541	"RTN","PSO CPF1",108, 0)
	17542	I NODATA D BLD^PSOC PF S VALMB CK="R" Q
	17543	"RTN","PSO CPF1",109, 0)
	17544	S LCNT=0, PGC=0,IBQU IT=0
	17545	"RTN","PSO CPF1",110, 0)
	17546	D ^%ZISC
	17547	"RTN","PSO CPF1",111, 0)
	17548	D DEVICE( "EF")
	17549	"RTN","PSO CPF1",112, 0)
	17550	;
	17551	"RTN","PSO CPF1",113, 0)
	17552	D BLD^PSO CPF
	17553	"RTN","PSO CPF1",114, 0)
	17554	D PAUSE
	17555	"RTN","PSO CPF1",115, 0)
	17556	S VALMBCK ="R"
	17557	"RTN","PSO CPF1",116, 0)
	17558	Q
	17559	"RTN","PSO CPF1",117, 0)
	17560	;
	17561	"RTN","PSO CPF1",118, 0)
	17562	EXCEL(FILT ERS) ; pri nt the dat a in excel format
	17563	"RTN","PSO CPF1",119, 0)
	17564	;^TMP($J, "PSOCPF",P TNM,RIEN,R FL)=PTNM_U _PID_U_MED _U_RIEN_U_ RFL_U_RX_U _FILDT_U_B
	17565	LNO_U_IBST 1_U_SC_U_S CP_U_MTSD_ U_MTS_U_DF N_U_PBIL
	17566	"RTN","PSO CPF1",120, 0)
	17567	D CLEAR^V ALM1,FULL^ VALM1
	17568	"RTN","PSO CPF1",121, 0)
	17569	U IO
	17570	"RTN","PSO CPF1",122, 0)
	17571	N LINE,LC NT,PCE,REC ,OUT,NAME, XX,BCNT,CN T,NXT,ZZ,Z Z1,ZZ2,OUT
	17572	"RTN","PSO CPF1",123, 0)
	17573	S BDATE=$ $FMTE^XLFD T($P(FILTE RS,U,1),"2 DZ")
	17574	"RTN","PSO CPF1",124, 0)
	17575	S EDATE=$ $FMTE^XLFD T($P(FILTE RS,U,2),"2 DZ")
	17576	"RTN","PSO CPF1",125, 0)
	17577	D EXHDR
	17578	"RTN","PSO CPF1",126, 0)
	17579	S LCNT=0, NAME=""
	17580	"RTN","PSO CPF1",127, 0)
	17581	F S NAME =$O(^TMP($ J,"PSOCPF" ,NAME)) Q: NAME="" D
	17582	"RTN","PSO CPF1",128, 0)
	17583	. F S RI EN=$O(^TMP ($J,"PSOCP F",NAME,RI EN)) Q:RIE N="" D
	17584	"RTN","PSO CPF1",129, 0)
	17585	.. F S R FL=$O(^TMP ($J,"PSOCP F",NAME,RI EN,RFL)) Q :RFL="" D
	17586	"RTN","PSO CPF1",130, 0)
	17587	... S REC =^TMP($J," PSOCPF",NA ME,RIEN,RF L),LINE=$P (REC,U,1,3 )_U_$P(REC ,U,7,14)
	17588	"RTN","PSO CPF1",131, 0)
	17589	... W !,L INE
	17590	"RTN","PSO CPF1",132, 0)
	17591	W !,"END OF REPORT"
	17592	"RTN","PSO CPF1",133, 0)
	17593	Q
	17594	"RTN","PSO CPF1",134, 0)
	17595	;
	17596	"RTN","PSO CPF1",135, 0)
	17597	DEVICE(TYP E) ; Ask u ser to sel ect device
	17598	"RTN","PSO CPF1",136, 0)
	17599	;
	17600	"RTN","PSO CPF1",137, 0)
	17601	N %ZIS,CR T,MAXCNT,P OP
	17602	"RTN","PSO CPF1",138, 0)
	17603	S %ZIS="Q M" D ^%ZIS G:POP ENQ
	17604	"RTN","PSO CPF1",139, 0)
	17605	I $D(IO(" Q")) D G ENQ
	17606	"RTN","PSO CPF1",140, 0)
	17607	.S ZTDESC ="Medicati on List Ma nager Repo rt"
	17608	"RTN","PSO CPF1",141, 0)
	17609	.I TYPE=" EF" S ZTRT N="EXCEL^P SOCPF1"
	17610	"RTN","PSO CPF1",142, 0)
	17611	.F I="^TM P($J,""PSO CPF"",","F ILTERS" S ZTSAVE(I)= ""
	17612	"RTN","PSO CPF1",143, 0)
	17613	.D ^%ZTLO AD K IO("Q ") D HOME^ %ZIS
	17614	"RTN","PSO CPF1",144, 0)
	17615	.W !!,$S( $D(ZTSK):" This job h as been qu eued as ta sk #"_ZTSK _".",1:"Un able to qu
	17616	eue this j ob.")
	17617	"RTN","PSO CPF1",145, 0)
	17618	.K ZTSK,I O("Q")
	17619	"RTN","PSO CPF1",146, 0)
	17620	;
	17621	"RTN","PSO CPF1",147, 0)
	17622	I TYPE="E F" U IO D EXCEL(FILT ERS(0))
	17623	"RTN","PSO CPF1",148, 0)
	17624	;
	17625	"RTN","PSO CPF1",149, 0)
	17626	D ^%ZISC
	17627	"RTN","PSO CPF1",150, 0)
	17628	;
	17629	"RTN","PSO CPF1",151, 0)
	17630	I $D(ZTQU EUED) S ZT REQ="@"
	17631	"RTN","PSO CPF1",152, 0)
	17632	K ^TMP("I BOUT",$J)
	17633	"RTN","PSO CPF1",153, 0)
	17634	;
	17635	"RTN","PSO CPF1",154, 0)
	17636	ENQ Q
	17637	"RTN","PSO CPF1",155, 0)
	17638	;
	17639	"RTN","PSO CPF1",156, 0)
	17640	EXHDR ; -- excel hea der
	17641	"RTN","PSO CPF1",157, 0)
	17642	;^TMP($J, "PSOCPF",P TNM,RIEN,R FL)=PTNM_U _PID_U_MED _U_RIEN_U_ RFL_U_RX_U _FILDT_U_B
	17643	LNO_U_IBST 1_U_SC_U_S CP_U_MTSD_ U_MTS_U_DF N_U_IBST
	17644	"RTN","PSO CPF1",158, 0)
	17645	W !,"Medi cation Co- pay Exempt ion Report "
	17646	"RTN","PSO CPF1",159, 0)
	17647	W !,"From ",BDATE," TO ",EDAT E
	17648	"RTN","PSO CPF1",160, 0)
	17649	S HDR="Pa tient Name "_U_"ID"_U _"MEDICATI ON"_U_"RX" _U_"FILL D ATE"_U_"BI LL NO."_U_
	17650	"STATUS"_U _"SC"_U_"P ERCENT"_U_ "MEANS TES T"_U_"MEAN S DATE"
	17651	"RTN","PSO CPF1",161, 0)
	17652	W !,HDR
	17653	"RTN","PSO CPF1",162, 0)
	17654	Q
	17655	"RTN","PSO CPF1",163, 0)
	17656	;
	17657	"RTN","PSO CPF1",164, 0)
	17658	PAUSE ;pau se at end of screen if being d isplayed o n a termin al
	17659	"RTN","PSO CPF1",165, 0)
	17660	Q:$E(IOST ,1,2)'["C- " N DIR,D UOUT,DTOUT ,DIRUT W !
	17661	"RTN","PSO CPF1",166, 0)
	17662	S DIR(0)= "E" D ^DIR K DIR
	17663	"RTN","PSO CPF1",167, 0)
	17664	I $D(DUOU T)!($D(DIR UT)) S IBQ UIT=1
	17665	"RTN","PSO CPF1",168, 0)
	17666	Q
	17667	"RTN","PSO CPF2")
	17668	0^4^B17984 601
	17669	"RTN","PSO CPF2",1,0)
	17670	PSOCPF2 ;B IR/BAA - P harmacy CO -PAY Appli cation Uti lities for IB ;02/06 /92
	17671	"RTN","PSO CPF2",2,0)
	17672	;;7.0;OUT PATIENT PH ARMACY;4 63;DEC 1 997;Build 2
	17673	"RTN","PSO CPF2",3,0)
	17674	;;Per VA Directive 6402, this routine s hould not be modifie d.
	17675	"RTN","PSO CPF2",4,0)
	17676	;
	17677	"RTN","PSO CPF2",5,0)
	17678	Q
	17679	"RTN","PSO CPF2",6,0)
	17680	;S ^TMP($ J,"PSOCPFX ",VCNT)=NA ME_DFN_U_M ED_U_PBIL_ U_BLN_U_PR IEN
	17681	"RTN","PSO CPF2",7,0)
	17682	;
	17683	"RTN","PSO CPF2",8,0)
	17684	PATINS ; v iew patien t insuranc e
	17685	"RTN","PSO CPF2",9,0)
	17686	D FULL^VA LM1
	17687	"RTN","PSO CPF2",10,0 )
	17688	N I,J,IBX X,VALMY,EC NT,DFN,GOP AT
	17689	"RTN","PSO CPF2",11,0 )
	17690	D EN^VALM 2($G(XQORN OD(0)))
	17691	"RTN","PSO CPF2",12,0 )
	17692	I $D(VALM Y),'NODATA D
	17693	"RTN","PSO CPF2",13,0 )
	17694	.. S IBXX =0 F S IB XX=$O(VALM Y(IBXX)) Q :'IBXX D
	17695	"RTN","PSO CPF2",14,0 )
	17696	.. S REC= $G(^TMP($J ,"PSOCPFX" ,IBXX))
	17697	"RTN","PSO CPF2",15,0 )
	17698	.. S ^TMP ($J,"PATIN S")=$P(REC ,U,2)
	17699	"RTN","PSO CPF2",16,0 )
	17700	.. D EN^V ALM("IBCNS VIEW PAT INS")
	17701	"RTN","PSO CPF2",17,0 )
	17702	D BLD^PSO CPF
	17703	"RTN","PSO CPF2",18,0 )
	17704	S VALMBCK ="R"
	17705	"RTN","PSO CPF2",19,0 )
	17706	Q
	17707	"RTN","PSO CPF2",20,0 )
	17708	;
	17709	"RTN","PSO CPF2",21,0 )
	17710	PATACP ; l ook at ACC OUNT PROFI LE
	17711	"RTN","PSO CPF2",22,0 )
	17712	D FULL^VA LM1
	17713	"RTN","PSO CPF2",23,0 )
	17714	N IBXX,VA LMY,ECNT,N AME,RC,DFN ,CPY,PRCAT Y
	17715	"RTN","PSO CPF2",24,0 )
	17716	D EN^VALM 2($G(XQORN OD(0)))
	17717	"RTN","PSO CPF2",25,0 )
	17718	D CLEAR^V ALM1
	17719	"RTN","PSO CPF2",26,0 )
	17720	I $D(VALM Y),'NODATA D
	17721	"RTN","PSO CPF2",27,0 )
	17722	. S IBXX= 0 F S IBX X=$O(VALMY (IBXX)) Q: 'IBXX D
	17723	"RTN","PSO CPF2",28,0 )
	17724	.. S RC=$ G(^TMP($J, "PSOCPFX", IBXX))
	17725	"RTN","PSO CPF2",29,0 )
	17726	.. S DFN= $P(RC,U,2) ,NAME=$P(R C,U,1)
	17727	"RTN","PSO CPF2",30,0 )
	17728	.. N DIC, X,Y,DEBT,P RCADB,DA,P RCA,COUNT, OUT,SEL,BI LL,BAT,TRA N,DR,DXS,D TOUT,DIROU
	17729	T,DIRUT,DU OUT
	17730	"RTN","PSO CPF2",31,0 )
	17731	.. N DPTN OFZY,DPTNO FZK S (DPT NOFZY,DPTN OFZK)=1
	17732	"RTN","PSO CPF2",32,0 )
	17733	.. S COUN T=0,CPY=1
	17734	"RTN","PSO CPF2",33,0 )
	17735	.. S PRCA TY="ALL",X =NAME
	17736	"RTN","PSO CPF2",34,0 )
	17737	.. S X=$$ UPPER^VALM 1(X)
	17738	"RTN","PSO CPF2",35,0 )
	17739	.. S Y=$S ($O(^PRCA( 430,"B",X, 0)):$O(^(0 )),$O(^PRC A(430,"D", X,0)):$O(^ (0)),1:-1)
	17740	"RTN","PSO CPF2",36,0 )
	17741	.. I Y>0 S DEBT=$P( $G(^PRCA(4 30,Y,0))," ^",9) I DE BT S PRCAD B=$P($G(^R CD(340,DEB
	17742	T,0)),"^") ,^DISV(DUZ ,"^PRCA(43 0,")=Y,$P( DEBT,"^",2 )=$$NAM^RC FN01(DEBT) D COMP^PR
	17743	CAAPR,EN1^ PRCAATR(Y) Q
	17744	"RTN","PSO CPF2",37,0 )
	17745	.. S DIC= "^RCD(340, ",DIC(0)=" E" D ^DIC
	17746	"RTN","PSO CPF2",38,0 )
	17747	.. I Y<0 W !,"No en tries foun d for "_NA ME Q
	17748	"RTN","PSO CPF2",39,0 )
	17749	.. S ^DIS V(DUZ,"^RC D(340,")=+ Y
	17750	"RTN","PSO CPF2",40,0 )
	17751	.. S PRCA DB=$P(Y,"^ ",2),DEBT= +Y_"^"_$P( @("^"_$P(P RCADB,";", 2)_+PRCADB _",0)"),"^
	17752	")
	17753	"RTN","PSO CPF2",41,0 )
	17754	.. D COMP ^PRCAAPR,H DR^PRCAAPR 1,HDR2^PRC AAPR1,DIS^ PRCAAPR1
	17755	"RTN","PSO CPF2",42,0 )
	17756	.. D PAUS E^VALM1
	17757	"RTN","PSO CPF2",43,0 )
	17758	K ^TMP("P RCAAPR",$J )
	17759	"RTN","PSO CPF2",44,0 )
	17760	D BLD^PSO CPF
	17761	"RTN","PSO CPF2",45,0 )
	17762	S VALMBCK ="R"
	17763	"RTN","PSO CPF2",46,0 )
	17764	Q
	17765	"RTN","PSO CPF2",47,0 )
	17766	;
	17767	"RTN","PSO CPF2",48,0 )
	17768	BILPRO ; v iew BILL P ROFILE
	17769	"RTN","PSO CPF2",49,0 )
	17770	D FULL^VA LM1
	17771	"RTN","PSO CPF2",50,0 )
	17772	N I,J,IBX X,VALMY,EC NT,REC,RCB ILLDA
	17773	"RTN","PSO CPF2",51,0 )
	17774	D EN^VALM 2($G(XQORN OD(0)))
	17775	"RTN","PSO CPF2",52,0 )
	17776	I $D(VALM Y),'NODATA D
	17777	"RTN","PSO CPF2",53,0 )
	17778	. S IBXX= 0 F S IBX X=$O(VALMY (IBXX)) Q: 'IBXX D
	17779	"RTN","PSO CPF2",54,0 )
	17780	.. S REC= $G(^TMP($J ,"PSOCPFX" ,IBXX))
	17781	"RTN","PSO CPF2",55,0 )
	17782	.. S RCBI LLDA=$P(RE C,U,6)
	17783	"RTN","PSO CPF2",56,0 )
	17784	.. I RCBI LLDA="" Q
	17785	"RTN","PSO CPF2",57,0 )
	17786	.. D EN^V ALM("RCDP BILL PROFI LE")
	17787	"RTN","PSO CPF2",58,0 )
	17788	D BLD^PSO CPF
	17789	"RTN","PSO CPF2",59,0 )
	17790	S VALMBCK ="R"
	17791	"RTN","PSO CPF2",60,0 )
	17792	Q
	17793	"RTN","PSO CPF2",61,0 )
	17794	;
	17795	"RTN","PSO CPF2",62,0 )
	17796	TPJI ; vie w THIRD PA RTY JOIN I NQUIRY
	17797	"RTN","PSO CPF2",63,0 )
	17798	D FULL^VA LM1
	17799	"RTN","PSO CPF2",64,0 )
	17800	N I,J,IBX X,VALMY,EC NT,DFN,GOP AT
	17801	"RTN","PSO CPF2",65,0 )
	17802	D EN^VALM 2($G(XQORN OD(0)))
	17803	"RTN","PSO CPF2",66,0 )
	17804	I $D(VALM Y),'NODATA D
	17805	"RTN","PSO CPF2",67,0 )
	17806	. S IBXX= 0 F S IBX X=$O(VALMY (IBXX)) Q: 'IBXX D
	17807	"RTN","PSO CPF2",68,0 )
	17808	.. S REC= $G(^TMP($J ,"PSOCPFX" ,IBXX))
	17809	"RTN","PSO CPF2",69,0 )
	17810	.. S DFN= $P(REC,U,2 )
	17811	"RTN","PSO CPF2",70,0 )
	17812	.. D EN^I BJTLA
	17813	"RTN","PSO CPF2",71,0 )
	17814	D BLD^PSO CPF
	17815	"RTN","PSO CPF2",72,0 )
	17816	S VALMBCK ="R"
	17817	"RTN","PSO CPF2",73,0 )
	17818	Q
	17819	"RTN","PSO CPF2",74,0 )
	17820	;
	17821	"RTN","PSO CPF2",75,0 )
	17822	BILINQ ; v iew PATIEN T BILLING INQUIRY
	17823	"RTN","PSO CPF2",76,0 )
	17824	D FULL^VA LM1
	17825	"RTN","PSO CPF2",77,0 )
	17826	N I,J,IBX X,VALMY,EC NT,DFN,GOP AT
	17827	"RTN","PSO CPF2",78,0 )
	17828	D EN^VALM 2($G(XQORN OD(0)))
	17829	"RTN","PSO CPF2",79,0 )
	17830	I $D(VALM Y),'NODATA D
	17831	"RTN","PSO CPF2",80,0 )
	17832	. S IBXX= 0 F S IBX X=$O(VALMY (IBXX)) Q: 'IBXX D
	17833	"RTN","PSO CPF2",81,0 )
	17834	.. S REC= $G(^TMP($J ,"PSOCPFX" ,IBXX))
	17835	"RTN","PSO CPF2",82,0 )
	17836	.. S IBIL =$P(REC,U, 5),IBFULL= 0
	17837	"RTN","PSO CPF2",83,0 )
	17838	.. I IBIL ="" Q
	17839	"RTN","PSO CPF2",84,0 )
	17840	.. S IBIF N=$O(^DGCR (399,"B",$ P(IBIL,"-" ,2,3),0))
	17841	"RTN","PSO CPF2",85,0 )
	17842	.. D EN^I BOLK
	17843	"RTN","PSO CPF2",86,0 )
	17844	D BLD^PSO CPF
	17845	"RTN","PSO CPF2",87,0 )
	17846	S VALMBCK ="R"
	17847	"RTN","PSO CPF2",88,0 )
	17848	Q
	17849	"RTN","PSO CPF2",89,0 )
	17850	;
	17851	"RTN","PSO CPF2",90,0 )
	17852	PATINQ ; v iew PATIEN T INQUIRY
	17853	"RTN","PSO CPF2",91,0 )
	17854	D FULL^VA LM1
	17855	"RTN","PSO CPF2",92,0 )
	17856	N I,J,IBX X,VALMY,EC NT,DFN,GOP AT
	17857	"RTN","PSO CPF2",93,0 )
	17858	D EN^VALM 2($G(XQORN OD(0)))
	17859	"RTN","PSO CPF2",94,0 )
	17860	I $D(VALM Y),'NODATA D
	17861	"RTN","PSO CPF2",95,0 )
	17862	. S IBXX= 0 F S IBX X=$O(VALMY (IBXX)) Q: 'IBXX D
	17863	"RTN","PSO CPF2",96,0 )
	17864	.. S REC= $G(^TMP($J ,"PSOCPFX" ,IBXX))
	17865	"RTN","PSO CPF2",97,0 )
	17866	.. S DFN= $P(REC,U,2 )
	17867	"RTN","PSO CPF2",98,0 )
	17868	.. D EN^D GRPD
	17869	"RTN","PSO CPF2",99,0 )
	17870	D BLD^PSO CPF
	17871	"RTN","PSO CPF2",100, 0)
	17872	S VALMBCK ="R"
	17873	"RTN","PSO CPF2",101, 0)
	17874	Q
	17875	"RTN","PSO CPF2",102, 0)
	17876	;
	17877	"RTN","PSO CPF2",103, 0)
	17878	PAUSE ;pau se at end of screen if being d isplayed o n a termin al
	17879	"RTN","PSO CPF2",104, 0)
	17880	Q:$E(IOST ,1,2)'["C- " N DIR,D UOUT,DTOUT ,DIRUT W !
	17881	"RTN","PSO CPF2",105, 0)
	17882	S DIR(0)= "E" D ^DIR K DIR
	17883	"RTN","PSO CPF2",106, 0)
	17884	I $D(DUOU T)!($D(DIR UT)) S IBQ UIT=1
	17885	"RTN","PSO CPF2",107, 0)
	17886	Q
	17887	"RTN","PSO CPF2",108, 0)
	17888	;
	17889	"RTN","PSO CPF2",109, 0)
	17890	CP ; -- ch ange patie nt,date an d prescrip tions.
	17891	"RTN","PSO CPF2",110, 0)
	17892	N VALMQUI T,IBDFN
	17893	"RTN","PSO CPF2",111, 0)
	17894	D FULL^VA LM1
	17895	"RTN","PSO CPF2",112, 0)
	17896	S FILTERS (0)=^TMP($ J,"PSOCPFF ")
	17897	"RTN","PSO CPF2",113, 0)
	17898	S IBDFN=$ P(FILTERS( 0),U,4)
	17899	"RTN","PSO CPF2",114, 0)
	17900	S PAT=$$O NEPAT^PSOC PF()
	17901	"RTN","PSO CPF2",115, 0)
	17902	S (DFN,$P (FILTERS(0 ),U,4))=+P AT
	17903	"RTN","PSO CPF2",116, 0)
	17904	S SBDT=BD ATE,SEDT=E DATE
	17905	"RTN","PSO CPF2",117, 0)
	17906	S VALMB=B DATE D RAN GE^VALM11
	17907	"RTN","PSO CPF2",118, 0)
	17908	I $S('VAL MBEG:1,BDA TE'=VALMBE G:0,1:EDAT E=VALMEND) W !!,"Dat e range wa s not chan
	17909	ged." D PA USE^VALM1 S VALMBCK= "" G CPQ
	17910	"RTN","PSO CPF2",119, 0)
	17911	S $P(FILT ERS(0),U,1 )=VALMBEG, $P(FILTERS (0),U,2)=V ALMEND
	17912	"RTN","PSO CPF2",120, 0)
	17913	S ^TMP($J ,"PSOCPFF" )=FILTERS( 0)
	17914	"RTN","PSO CPF2",121, 0)
	17915	I $D(VALM QUIT) S (D FN,$P(FILT ERS(0),U,4 ))=IBDFN,$ P(FILTERS( 0),U,1)=SB DT,$P(FILT
	17916	ERS(0),U,2 )=SEDT
	17917	"RTN","PSO CPF2",122, 0)
	17918	S VALMBG= 1 D SORT^P SOCPF1,HDR ^PSOCPF,BL D^PSOCPF
	17919	"RTN","PSO CPF2",123, 0)
	17920	S VALMBCK ="R"
	17921	"RTN","PSO CPF2",124, 0)
	17922	CPQ
	17923	"VER")
	17924	8.0^22.0
	17925	END
	17926	END