1. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 1/23/2018 12:48:44 PM Eastern Standard 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-4-5315_PSO-7-463.zip	IB-2-568_TEST_v7.KID	Tue Jan 23 16:40:43 2018 UTC
2	IB-2-568_PRCA-4-5315_PSO-7-463.zip	IB-2-568_TEST_v7.KID	Tue Jan 23 17:32:54 2018 UTC

1.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	17	16480
Changed	16	32
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	Packman Ma il Message :
	2	========== ========== =
	3
	4	$END TXT
	5	$KID IB2. 0568
	6	INSTALL NAME
	7	IB2.0568
	8	"BLD",1019 0,0)
	9	IB2.0568 ^INTEGRATE D BILLING^ 0^3171024^ y
	10	"BLD",1019 0,1,0)
	11	^^313^313^ 3170411^^^
	12	"BLD",1019 0,1,1,0)
	13
	14	"BLD",1019 0,1,2,0)
	15	IMPORTANT INSTALLATI ON NOTE:
	16	"BLD",1019 0,1,3,0)
	17	---------- ---------- --------
	18	"BLD",1019 0,1,4,0)
	19	This patch is part o f a multi- package bu ild. There are three patches
	20	"BLD",1019 0,1,5,0)
	21	associated with the FY16 HAPE Revenue En hancement project -
	22	"BLD",1019 0,1,6,0)
	23	IB2.0568 ,PRCA4.5 315 and PS O7.0463. All three patches a re to be
	24	"BLD",1019 0,1,7,0)
	25	installed together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
	26	"BLD",1019 0,1,8,0)
	27
	28	"BLD",1019 0,1,9,0)
	29
	30	"BLD",1019 0,1,10,0)
	31	Descriptio n
	32	"BLD",1019 0,1,11,0)
	33	---------- -
	34	"BLD",1019 0,1,12,0)
	35	The Chief Business O ffice (CBO ) is reque sting syst em enhance ments to
	36	"BLD",1019 0,1,13,0)
	37	The Vetera ns Health Informatio n Systems and Techno logy Archi tecture
	38	"BLD",1019 0,1,14,0)
	39	(VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd
	40	"BLD",1019 0,1,15,0)
	41	Outpatient Pharmacy (PSO) soft ware modul es.
	42	"BLD",1019 0,1,16,0)
	43
	44	"BLD",1019 0,1,17,0)
	45	The missio n of the D epartment of Veteran s Affairs (VA), Offi ce of
	46	"BLD",1019 0,1,18,0)
	47	Informatio n & Techno logy (OI&T ), is to p rovide ben efits and services
	48	"BLD",1019 0,1,19,0)
	49	to veteran s of the U nited Stat es Armed F orces. In meeting th ese
	50	"BLD",1019 0,1,20,0)
	51	goals, OIT strives t o provide high quali ty, effect ive, and e fficient
	52	"BLD",1019 0,1,21,0)
	53	Informatio n Technolo gy (IT) se rvices to those resp onsible fo r
	54	"BLD",1019 0,1,22,0)
	55	providing care to th e veterans at the po int-of-car e, as well as
	56	"BLD",1019 0,1,23,0)
	57	throughout all the p oints of t he veteran s' health care. The VA depends
	58	"BLD",1019 0,1,24,0)
	59	on Informa tion Manag ement/Info rmation Te chnology ( IM/IT) sys tems to
	60	"BLD",1019 0,1,25,0)
	61	meet missi on goals.
	62	"BLD",1019 0,1,26,0)
	63
	64	"BLD",1019 0,1,27,0)
	65	The overal l FY16 HAP E Revenue Enhancemen t project has been f urther
	66	"BLD",1019 0,1,28,0)
	67	divided in to three s ub-project s:
	68	"BLD",1019 0,1,29,0)
	69
	70	"BLD",1019 0,1,30,0)
	71	NSR #20150 506
	72	"BLD",1019 0,1,31,0)
	73	The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the Chief
	74	"BLD",1019 0,1,32,0)
	75	Business O ffice (CBO ), bundles several N SRs with s imilar bus iness
	76	"BLD",1019 0,1,33,0)
	77	needs into a single requiremen ts documen t. Succes sfully add ressing
	78	"BLD",1019 0,1,34,0)
	79	the requir ements con tained wit hin this d ocument wi ll enable the
	80	"BLD",1019 0,1,35,0)
	81	Department of Vetera ns Affairs (VA) to a ppropriate ly bill ce rtain
	82	"BLD",1019 0,1,36,0)
	83	subsets of billable events by correcting , automati ng, or enh ancing
	84	"BLD",1019 0,1,37,0)
	85	current Ve terans Hea lth Inform ation Syst ems and Te chnology
	86	"BLD",1019 0,1,38,0)
	87	Architectu re (VistA) systems.
	88	"BLD",1019 0,1,39,0)
	89
	90	"BLD",1019 0,1,40,0)
	91	NSR #20150 507
	92	"BLD",1019 0,1,41,0)
	93	The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs,
	94	"BLD",1019 0,1,42,0)
	95	as well. T his effort enables t he Departm ent of Vet erans Affa irs (VA)
	96	"BLD",1019 0,1,43,0)
	97	to improve revenue o peration f unctionali ty related to repaym ent plans,
	98	"BLD",1019 0,1,44,0)
	99	late charg e capture, bill susp ension rea sons, the billing of
	100	"BLD",1019 0,1,45,0)
	101	deactivate d provider s, and the display o f appeal r ights and
	102	"BLD",1019 0,1,46,0)
	103	responsibi lities on the Vetera ns Benefic iary trave l Bill of Collection s
	104	"BLD",1019 0,1,47,0)
	105	form. Imp lementatio n of the p roposed en hancements will make a
	106	"BLD",1019 0,1,48,0)
	107	significan t positive impact on stakehold ers and ta rget users .
	108	"BLD",1019 0,1,49,0)
	109
	110	"BLD",1019 0,1,50,0)
	111	NSR #20150 505
	112	"BLD",1019 0,1,51,0)
	113	The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to
	114	"BLD",1019 0,1,52,0)
	115	improve tr acking and reporting of revenu e, and wil l support revenue
	116	"BLD",1019 0,1,53,0)
	117	reporting business r ules and g uidelines.
	118	"BLD",1019 0,1,54,0)
	119
	120	"BLD",1019 0,1,55,0)
	121
	122	"BLD",1019 0,1,56,0)
	123	IB2.0568 patch enh ancements, pertinent to the ab ove NSRs, include:
	124	"BLD",1019 0,1,57,0)
	125
	126	"BLD",1019 0,1,58,0)
	127	1.) When g enerating the RNB (R easons Not Billable) report, t he
	128	"BLD",1019 0,1,59,0)
	129	Integrated Billing s ystem shal l populate the charg es for all types
	130	"BLD",1019 0,1,60,0)
	131	of service s provided . Charges will not b e screened by any bi llable
	132	"BLD",1019 0,1,61,0)
	133	criteria b ut willind icate the full amoun t as if th e care was to be
	134	"BLD",1019 0,1,62,0)
	135	billed.
	136	"BLD",1019 0,1,63,0)
	137
	138	"BLD",1019 0,1,64,0)
	139	2.) The su b-option C laims Trac king Param eter Edit [IBT EDIT TRACKING
	140	"BLD",1019 0,1,65,0)
	141	PARAMETERS ], that cu rrently ha s no key, will be lo cked with a new
	142	"BLD",1019 0,1,66,0)
	143	Security K ey called IB PARAMET ER EDIT.
	144	"BLD",1019 0,1,67,0)
	145
	146	"BLD",1019 0,1,68,0)
	147	3.) The op tion MCCR Site Param eter Displ ay/Edit [I BJ MCCR SI TE
	148	"BLD",1019 0,1,69,0)
	149	PARAMETERS ], which i s currentl y locked w ith the IB SUPERVISO R Security
	150	"BLD",1019 0,1,70,0)
	151	Key, will be instead locked wi th the new key.
	152	"BLD",1019 0,1,71,0)
	153
	154	"BLD",1019 0,1,72,0)
	155	4.) The In tegrated B illing sys tem shall create cla ims tracki ng entries
	156	"BLD",1019 0,1,73,0)
	157	for previo usly unbil led Prosth etics/DME items when new billa ble
	158	"BLD",1019 0,1,74,0)
	159	insurance is entered into the patient's insurance file.
	160	"BLD",1019 0,1,75,0)
	161
	162	"BLD",1019 0,1,76,0)
	163	5.) A new coverage l imitation field shal l be creat ed in the insurance
	164	"BLD",1019 0,1,77,0)
	165	file for P rosthetics . Like th e other ex isting cov erage limi tation
	166	"BLD",1019 0,1,78,0)
	167	fields in the insura nce file ( Inpatient, Outpatien t, Pharmac y etc.),
	168	"BLD",1019 0,1,79,0)
	169	this field will have the follo wing optio ns:
	170	"BLD",1019 0,1,80,0)
	171	0= NOT COVERE D
	172	"BLD",1019 0,1,81,0)
	173	1= COVERED
	174	"BLD",1019 0,1,82,0)
	175	2= CONDITIONA LCOVERAGE
	176	"BLD",1019 0,1,83,0)
	177	Once selec ted, they will show in the pat ient insur ance file as Yes,
	178	"BLD",1019 0,1,84,0)
	179	No, or Con ditional.
	180	"BLD",1019 0,1,85,0)
	181
	182	"BLD",1019 0,1,86,0)
	183	6.) The sy stem shall automatic ally assig n an RNB [ NO PROSTHE TIC
	184	"BLD",1019 0,1,87,0)
	185	COVERAGE ( CV22)] for Prostheti cs/DME ite ms if the patient ha s no
	186	"BLD",1019 0,1,88,0)
	187	coverage f or Prosthe tics in hi s/her insu rance file .
	188	"BLD",1019 0,1,89,0)
	189
	190	"BLD",1019 0,1,90,0)
	191	7.) The sy stem shall have a ne w option t o add Pros thetics it ems to
	192	"BLD",1019 0,1,91,0)
	193	Manual and Nightly C laims Trac king.
	194	"BLD",1019 0,1,92,0)
	195
	196	"BLD",1019 0,1,93,0)
	197	8.) Users will be ab le to sele ct Suspend ed Type fr om the men u to
	198	"BLD",1019 0,1,94,0)
	199	display in the First Party Fol low- Up [I BJD FOLLOW -UP FIRST PARTY]
	200	"BLD",1019 0,1,95,0)
	201	report.
	202	"BLD",1019 0,1,96,0)
	203
	204	"BLD",1019 0,1,97,0)
	205	9.) First Party Foll ow- Up [IB JD FOLLOW- UP FIRST P ARTY] repo rt shall
	206	"BLD",1019 0,1,98,0)
	207	be modifie d to incor porate rea son for su spension.
	208	"BLD",1019 0,1,99,0)
	209
	210	"BLD",1019 0,1,100,0)
	211	10.) A new warning m essage wil l print to the scree n in the E nter/Edit
	212	"BLD",1019 0,1,101,0)
	213	Billing In formation option if an ATTENDI NG, REFERR ING or REN DERING
	214	"BLD",1019 0,1,102,0)
	215	Provider h as a PERSO N CLASS - NEW PERSON file (#20 0) - that was
	216	"BLD",1019 0,1,103,0)
	217	expirated at the tim e of the D ate of Ser vice.
	218	"BLD",1019 0,1,104,0)
	219
	220	"BLD",1019 0,1,105,0)
	221	11.) On th e Third Pa rty Joint Inquiry sc reen, one (1) charac ter space
	222	"BLD",1019 0,1,106,0)
	223	shall be a dded to th e "Type" f ield so th at it will accommoda te five
	224	"BLD",1019 0,1,107,0)
	225	characters (a one-ch aracter cl assificati on indicat or, a forw ard slash
	226	"BLD",1019 0,1,108,0)
	227	(/), a one -character component indicator , a forwar d slash (/ ), and a
	228	"BLD",1019 0,1,109,0)
	229	one-charac ter care t ype) ("X/X /X"). If a bill con tains pres criptions,
	230	"BLD",1019 0,1,110,0)
	231	then an "R " shall be concatena ted to the fifth cha racter sub -type
	232	"BLD",1019 0,1,111,0)
	233	position o f the "Typ e" field. If a bill contains p rosthetics , then a
	234	"BLD",1019 0,1,112,0)
	235	"P" shall be concate nated to f ifth chara cter sub-t ype positi on of the
	236	"BLD",1019 0,1,113,0)
	237	"Type" fie ld.The "Ty pe" field shall cont ain five ( 5) charact ers as
	238	"BLD",1019 0,1,114,0)
	239	follows:
	240	"BLD",1019 0,1,115,0)
	241	1. "I" for Inpatient or "O" fo r Outpatie nt,
	242	"BLD",1019 0,1,116,0)
	243	2. "/" for ward slash character
	244	"BLD",1019 0,1,117,0)
	245	3. "P" for Professio nal or "I" for Insti tutional
	246	"BLD",1019 0,1,118,0)
	247	4. "/" for ward slash character
	248	"BLD",1019 0,1,119,0)
	249	5. "P" for Prostheti cs or "R" for Prescr iptions
	250	"BLD",1019 0,1,120,0)
	251
	252	"BLD",1019 0,1,121,0)
	253	12.) Three new Third Party Ins urance Rat e Types sh all be cre ated in
	254	"BLD",1019 0,1,122,0)
	255	the VistA IB Suite f or the bil lers to ch oose from when billi ng for
	256	"BLD",1019 0,1,123,0)
	257	encounters . They are as follow s:
	258	"BLD",1019 0,1,124,0)
	259	HU MANITARIAN REIMB. IN S.
	260	"BLD",1019 0,1,125,0)
	261	DE NTAL REIMB . INS.
	262	"BLD",1019 0,1,126,0)
	263	IN ELIGIBLE R EIMB. INS.
	264	"BLD",1019 0,1,127,0)
	265
	266	"BLD",1019 0,1,128,0)
	267	13.) Each of the new rate type s above wi ll have th e 'Insurer ' as the
	268	"BLD",1019 0,1,129,0)
	269	responsibl e party.
	270	"BLD",1019 0,1,130,0)
	271
	272	"BLD",1019 0,1,131,0)
	273	14.) Bille rs (revenu e staff) s hould be a ble to ide ntify any remaining
	274	"BLD",1019 0,1,132,0)
	275	charges to the patie nt after t he Third P arty payme nts are re ceived for
	276	"BLD",1019 0,1,133,0)
	277	Emergency Humanitari an, Inelig ible and D ental serv ices so th ey can
	278	"BLD",1019 0,1,134,0)
	279	accomplish balance b illing.
	280	"BLD",1019 0,1,135,0)
	281
	282	"BLD",1019 0,1,136,0)
	283
	284	"BLD",1019 0,1,137,0)
	285
	286	"BLD",1019 0,1,138,0)
	287	Concurrent Developme nt / Depen dencies:
	288	"BLD",1019 0,1,139,0)
	289	---------- ---------- ---------- --------
	290	"BLD",1019 0,1,140,0)
	291	N/A
	292	"BLD",1019 0,1,141,0)
	293
	294	"BLD",1019 0,1,142,0)
	295
	296	"BLD",1019 0,1,143,0)
	297	Patch Comp onents:
	298	"BLD",1019 0,1,144,0)
	299	---------- -------
	300	"BLD",1019 0,1,145,0)
	301
	302	"BLD",1019 0,1,146,0)
	303	Files & Fi elds Assoc iated:
	304	"BLD",1019 0,1,147,0)
	305
	306	"BLD",1019 0,1,148,0)
	307	File Name (Number) Field Na me (Number ) New/ Modified/D eleted
	308	"BLD",1019 0,1,149,0)
	309	---------- -------- -------- ---------- - ---- ---------- ------
	310	"BLD",1019 0,1,150,0)
	311	N/A
	312	"BLD",1019 0,1,151,0)
	313
	314	"BLD",1019 0,1,152,0)
	315	Options As sociated:
	316	"BLD",1019 0,1,153,0)
	317
	318	"BLD",1019 0,1,154,0)
	319	Option Nam e Type New/ Modified/D eleted
	320	"BLD",1019 0,1,155,0)
	321	---------- - ---- ---- ---------- ------
	322	"BLD",1019 0,1,156,0)
	323	IBT SUP MA NUALLY QUE PRSTHTCS ROUTINE NEW
	324	"BLD",1019 0,1,157,0)
	325
	326	"BLD",1019 0,1,158,0)
	327	Protocols Associated :
	328	"BLD",1019 0,1,159,0)
	329
	330	"BLD",1019 0,1,160,0)
	331	Protocol N ame New /Modified/ Deleted
	332	"BLD",1019 0,1,161,0)
	333	---------- --- --- ---------- -------
	334	"BLD",1019 0,1,162,0)
	335	N/A
	336	"BLD",1019 0,1,163,0)
	337
	338	"BLD",1019 0,1,164,0)
	339	Templates Associated :
	340	"BLD",1019 0,1,165,0)
	341
	342	"BLD",1019 0,1,166,0)
	343	Template N ame T ype File Name (Num ber) New/Mod/De l
	344	"BLD",1019 0,1,167,0)
	345	---------- --- - --- ---- ---------- ---- ---------- -
	346	"BLD",1019 0,1,168,0)
	347	IBJT ACTIV E LIST L IST NEW
	348	"BLD",1019 0,1,169,0)
	349	IBJT INACT IVE LIST L IST NEW
	350	"BLD",1019 0,1,170,0)
	351
	352	"BLD",1019 0,1,171,0)
	353	New Servic e Requests (NSRs):
	354	"BLD",1019 0,1,172,0)
	355	---------- ---------- --------
	356	"BLD",1019 0,1,173,0)
	357	20150505 - Revenue R eporting E nhancement s
	358	"BLD",1019 0,1,174,0)
	359	20150506 - Revenue E ligibility Enhanceme nts
	360	"BLD",1019 0,1,175,0)
	361	20150507 - Revenue O perations Enhancemen ts
	362	"BLD",1019 0,1,176,0)
	363
	364	"BLD",1019 0,1,177,0)
	365
	366	"BLD",1019 0,1,178,0)
	367	Patient Sa fety Issue s (PSIs):
	368	"BLD",1019 0,1,179,0)
	369	---------- ---------- ----------
	370	"BLD",1019 0,1,180,0)
	371	N/A
	372	"BLD",1019 0,1,181,0)
	373
	374	"BLD",1019 0,1,182,0)
	375
	376	"BLD",1019 0,1,183,0)
	377	Remedy Tic ket(s) & O verviews:
	378	"BLD",1019 0,1,184,0)
	379	---------- ---------- ---------
	380	"BLD",1019 0,1,185,0)
	381	N/A
	382	"BLD",1019 0,1,186,0)
	383
	384	"BLD",1019 0,1,187,0)
	385	Test Sites :
	386	"BLD",1019 0,1,188,0)
	387	----------
	388	"BLD",1019 0,1,189,0)
	389	Durham VAM C
	390	"BLD",1019 0,1,190,0)
	391
	392	"BLD",1019 0,1,191,0)
	393
	394	"BLD",1019 0,1,192,0)
	395	Software a nd Documen tation Ret rieval Ins tructions:
	396	"BLD",1019 0,1,193,0)
	397	---------- ---------- ---------- ---------- ---------- --
	398	"BLD",1019 0,1,194,0)
	399	Patches fo r this ins tallation are combin ed in host file
	400	"BLD",1019 0,1,195,0)
	401	IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
	402	"BLD",1019 0,1,196,0)
	403
	404	"BLD",1019 0,1,197,0)
	405	Installati on of this host file should be coordinat ed among t he package s
	406	"BLD",1019 0,1,198,0)
	407	affected s ince only one instal lation is necessary.
	408	"BLD",1019 0,1,199,0)
	409
	410	"BLD",1019 0,1,200,0)
	411	The patche s are:
	412	"BLD",1019 0,1,201,0)
	413
	414	"BLD",1019 0,1,202,0)
	415	IB2. 0568
	416	"BLD",1019 0,1,203,0)
	417	PRCA* 4.5*315
	418	"BLD",1019 0,1,204,0)
	419	PSO7 .0463
	420	"BLD",1019 0,1,205,0)
	421
	422	"BLD",1019 0,1,206,0)
	423
	424	"BLD",1019 0,1,207,0)
	425	Sites may retrieve t he KIDS bu ild in one of the fo llowing wa ys:
	426	"BLD",1019 0,1,208,0)
	427
	428	"BLD",1019 0,1,209,0)
	429	(1) The pr eferred me thod is to FTP the f iles from
	430	"BLD",1019 0,1,210,0)
	431	URL which wil l transmit the files from the first
	432	"BLD",1019 0,1,211,0)
	433	available FTP server .
	434	"BLD",1019 0,1,212,0)
	435
	436	"BLD",1019 0,1,213,0)
	437	(2) Sites may also e lect to re trieve the patch dir ectly from a specifi c
	438	"BLD",1019 0,1,214,0)
	439	server as follows:
	440	"BLD",1019 0,1,215,0)
	441
	442	"BLD",1019 0,1,216,0)
	443	OIFO FTP ADDRE SS DIRECTORY
	444	"BLD",1019 0,1,217,0)
	445	-------- ------ --------- ---------- ----- ---------- --------
	446	"BLD",1019 0,1,218,0)
	447	Albany URL anonymous. software
	448	"BLD",1019 0,1,219,0)
	449	Hines URL anonymous. software
	450	"BLD",1019 0,1,220,0)
	451	Salt Lake City URL anonymous. software
	452	"BLD",1019 0,1,221,0)
	453
	454	"BLD",1019 0,1,222,0)
	455
	456	"BLD",1019 0,1,223,0)
	457	Sites may retrieve d ocumentati on directl y using Se cure File Transfer
	458	"BLD",1019 0,1,224,0)
	459	Protocol ( SFTP) from the ANONY MOUS.SOFTW ARE direct ory at the following
	460	"BLD",1019 0,1,225,0)
	461	OI Field O ffices:
	462	"BLD",1019 0,1,226,0)
	463
	464	"BLD",1019 0,1,227,0)
	465	Albany: URL
	466	"BLD",1019 0,1,228,0)
	467	Hines: URL
	468	"BLD",1019 0,1,229,0)
	469	Salt Lake City: URL
	470	"BLD",1019 0,1,230,0)
	471
	472	"BLD",1019 0,1,231,0)
	473	Documentat ion can al so be foun d on the V A Software Documenta tion
	474	"BLD",1019 0,1,232,0)
	475	Library at :
	476	"BLD",1019 0,1,233,0)
	477	http:// URL /
	478	"BLD",1019 0,1,234,0)
	479
	480	"BLD",1019 0,1,235,0)
	481	Title File Name FTP Mod e
	482	"BLD",1019 0,1,236,0)
	483	---------- ---------- ---------- ---------- ---------- ---------- ---------- -
	484	"BLD",1019 0,1,237,0)
	485	Integrated Billing U ser Guide ib_2_0_um .doc Binar y
	486	"BLD",1019 0,1,238,0)
	487	Integrated Billing T echnical M anual/Secu rity Guide ib_2_0_tm .doc Binar y
	488	"BLD",1019 0,1,239,0)
	489	Integrated Billing D eployment, Installat ion,
	490	"BLD",1019 0,1,240,0)
	491	Back- Out, and R ollback Gu ide
	492	"BLD",1019 0,1,241,0)
	493	FY16Re venueIBVIP _Deploymen t_Installa tion_Guide .doc Binar y
	494	"BLD",1019 0,1,242,0)
	495
	496	"BLD",1019 0,1,243,0)
	497
	498	"BLD",1019 0,1,244,0)
	499
	500	"BLD",1019 0,1,245,0)
	501	Patch Inst allation:
	502	"BLD",1019 0,1,246,0)
	503
	504	"BLD",1019 0,1,247,0)
	505	Pre/Post I nstallatio n Overview :
	506	"BLD",1019 0,1,248,0)
	507	---------- ---------- ---------- -
	508	"BLD",1019 0,1,249,0)
	509	The post i nstallatio n routine, IBY568PO, is not au tomaticall y deleted
	510	"BLD",1019 0,1,250,0)
	511	as part of the insta llation pr ocess. You may delet e it after
	512	"BLD",1019 0,1,251,0)
	513	installati on if you desire.
	514	"BLD",1019 0,1,252,0)
	515
	516	"BLD",1019 0,1,253,0)
	517	Pre-Instal lation Ins tructions:
	518	"BLD",1019 0,1,254,0)
	519	---------- ---------- ----------
	520	"BLD",1019 0,1,255,0)
	521	N/A
	522	"BLD",1019 0,1,256,0)
	523
	524	"BLD",1019 0,1,257,0)
	525	Installati on Instruc tions:
	526	"BLD",1019 0,1,258,0)
	527	---------- ---------- ------
	528	"BLD",1019 0,1,259,0)
	529	This proce ss will in stall new and update d routines and other
	530	"BLD",1019 0,1,260,0)
	531	components listed ab ove. There is a post -install r outine tha t will add
	532	"BLD",1019 0,1,261,0)
	533	entries to a number of files.
	534	"BLD",1019 0,1,262,0)
	535
	536	"BLD",1019 0,1,263,0)
	537	The patch will be re leased in conjunctio n with an Accounts R eceivable
	538	"BLD",1019 0,1,264,0)
	539	patch, PRC A4.5315 and an Out patient Ph armacy pat ch, PSO7. 0463.
	540	"BLD",1019 0,1,265,0)
	541
	542	"BLD",1019 0,1,266,0)
	543	****** ****** ** NOT E **** ****** ****
	544	"BLD",1019 0,1,267,0)
	545	IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS
	546	"BLD",1019 0,1,268,0)
	547	AN EDITE D ERROR WI LL OCCUR.
	548	"BLD",1019 0,1,269,0)
	549	The patc h should b e installe d when NO Outpatient
	550	"BLD",1019 0,1,270,0)
	551	Pharmacy users are on the sy stem.
	552	"BLD",1019 0,1,271,0)
	553	****** ****** ****** ****** ****** ****
	554	"BLD",1019 0,1,272,0)
	555
	556	"BLD",1019 0,1,273,0)
	557	Installat ion will t ake less t han 1 minu te.
	558	"BLD",1019 0,1,274,0)
	559
	560	"BLD",1019 0,1,275,0)
	561	Suggested time to i nstall: no n-peak req uirement h ours.
	562	"BLD",1019 0,1,276,0)
	563
	564	"BLD",1019 0,1,277,0)
	565
	566	"BLD",1019 0,1,278,0)
	567	1. Obtai n the file IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID.
	568	"BLD",1019 0,1,279,0)
	569
	570	"BLD",1019 0,1,280,0)
	571	2. From the Kernel Installat ion & Dist ribution S ystem menu , select
	572	"BLD",1019 0,1,281,0)
	573	the I nstallatio n menu.
	574	"BLD",1019 0,1,282,0)
	575
	576	"BLD",1019 0,1,283,0)
	577	3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
	578	"BLD",1019 0,1,284,0)
	579	promp ted to Ent er a Host File name. You may need to ap pend a
	580	"BLD",1019 0,1,285,0)
	581	direc tory name.
	582	"BLD",1019 0,1,286,0)
	583
	584	"BLD",1019 0,1,287,0)
	585	4. From this menu, you may s elect to u se the fol lowing opt ions
	586	"BLD",1019 0,1,288,0)
	587	(when prompted for INSTAL L NAME, en ter IB2.0 568):
	588	"BLD",1019 0,1,289,0)
	589	a . Verify Checksums in Transpo rt Global - This opt ion will
	590	"BLD",1019 0,1,290,0)
	591	allow y ou to ensu re the int egrity of the routin es that
	592	"BLD",1019 0,1,291,0)
	593	are in the transp ort global .
	594	"BLD",1019 0,1,292,0)
	595	b . Print T ransport G lobal - Th is option will allow you to
	596	"BLD",1019 0,1,293,0)
	597	view th e componen ts of the KIDS build .
	598	"BLD",1019 0,1,294,0)
	599	c . Compare Transport Global to Current S ystem - Th is option
	600	"BLD",1019 0,1,295,0)
	601	will al low you to view all changes th at will be made when
	602	"BLD",1019 0,1,296,0)
	603	this pa tch is ins talled. I t compares all compo nents of
	604	"BLD",1019 0,1,297,0)
	605	this pa tch (routi nes, DD's, templates , etc.).
	606	"BLD",1019 0,1,298,0)
	607	d . Backup a Transpor t Global - This opti on will cr eate a
	608	"BLD",1019 0,1,299,0)
	609	backup message of any routi nes export ed with th is patch.
	610	"BLD",1019 0,1,300,0)
	611	It will not backu p any othe r changes such as DD 's or
	612	"BLD",1019 0,1,301,0)
	613	templat es.
	614	"BLD",1019 0,1,302,0)
	615
	616	"BLD",1019 0,1,303,0)
	617	5. When prompted " Want KIDS to INHIBIT LOGONs du ring the i nstall?
	618	"BLD",1019 0,1,304,0)
	619	NO//" respond NO.
	620	"BLD",1019 0,1,305,0)
	621
	622	"BLD",1019 0,1,306,0)
	623	6. When prompted " Want to DI SABLE Sche duled Opti ons, Menu Options,
	624	"BLD",1019 0,1,307,0)
	625	and P rotocols? NO//" resp ond NO.
	626	"BLD",1019 0,1,308,0)
	627
	628	"BLD",1019 0,1,309,0)
	629
	630	"BLD",1019 0,1,310,0)
	631
	632	"BLD",1019 0,1,311,0)
	633	Post-Insta llation In structions :
	634	"BLD",1019 0,1,312,0)
	635	---------- ---------- ---------- -
	636	"BLD",1019 0,1,313,0)
	637	There are no special tasks to perform af ter this p atch insta llation.
	638	"BLD",1019 0,4,0)
	639	^9.64PA^^
	640	"BLD",1019 0,6.3)
	641	38
	642	"BLD",1019 0,"INI")
	643
	644	"BLD",1019 0,"INID")
	645	^n^
	646	"BLD",1019 0,"INIT")
	647	START^IBY5 68PO
	648	"BLD",1019 0,"KRN",0)
	649	^9.67PA^77 9.2^20
	650	"BLD",1019 0,"KRN",.4 ,0)
	651	.4
	652	"BLD",1019 0,"KRN",.4 01,0)
	653	.401
	654	"BLD",1019 0,"KRN",.4 02,0)
	655	.402
	656	"BLD",1019 0,"KRN",.4 03,0)
	657	.403
	658	"BLD",1019 0,"KRN",.5 ,0)
	659	.5
	660	"BLD",1019 0,"KRN",.8 4,0)
	661	.84
	662	"BLD",1019 0,"KRN",3. 6,0)
	663	3.6
	664	"BLD",1019 0,"KRN",3. 8,0)
	665	3.8
	666	"BLD",1019 0,"KRN",9. 2,0)
	667	9.2
	668	"BLD",1019 0,"KRN",9. 8,0)
	669	9.8
	670	"BLD",1019 0,"KRN",9. 8,"NM",0)
	671	^9.68A^23^ 16
	672	"BLD",1019 0,"KRN",9. 8,"NM",2,0 )
	673	IBJTLA1^^0 ^B13446872
	674	"BLD",1019 0,"KRN",9. 8,"NM",3,0 )
	675	IBTRE2^^0^ B41197504
	676	"BLD",1019 0,"KRN",9. 8,"NM",4,0 )
	677	IBTRE20^^0 ^B20245141
	678	"BLD",1019 0,"KRN",9. 8,"NM",5,0 )
	679	IBTRKR5^^0 ^B39018549
	680	"BLD",1019 0,"KRN",9. 8,"NM",6,0 )
	681	IBCBB11^^0 ^B12524867 8
	682	"BLD",1019 0,"KRN",9. 8,"NM",7,0 )
	683	IBJTLB1^^0 ^B13573050
	684	"BLD",1019 0,"KRN",9. 8,"NM",12, 0)
	685	IBECEA^^0^ B13522502
	686	"BLD",1019 0,"KRN",9. 8,"NM",14, 0)
	687	IBCNSBL2^^ 0^B3961914 5
	688	"BLD",1019 0,"KRN",9. 8,"NM",16, 0)
	689	IBJDF2^^0^ B68089735
	690	"BLD",1019 0,"KRN",9. 8,"NM",17, 0)
	691	IBJDF11^^0 ^B30038470
	692	"BLD",1019 0,"KRN",9. 8,"NM",18, 0)
	693	IBJDB21^^0 ^B12749625 8
	694	"BLD",1019 0,"KRN",9. 8,"NM",19, 0)
	695	IBJDF4^^0^ B42361959
	696	"BLD",1019 0,"KRN",9. 8,"NM",20, 0)
	697	IBJDF41^^0 ^B10300970 0
	698	"BLD",1019 0,"KRN",9. 8,"NM",21, 0)
	699	IBJDF42^^0 ^B54815099
	700	"BLD",1019 0,"KRN",9. 8,"NM",22, 0)
	701	IBJDF43^^0 ^B25235431
	702	"BLD",1019 0,"KRN",9. 8,"NM",23, 0)
	703	IBCAPP^^0^ B23176501
	704	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBCAPP", 23)
	705
	706	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBCBB11" ,6)
	707
	708	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBCNSBL2 ",14)
	709
	710	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBECEA", 12)
	711
	712	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDB21" ,18)
	713
	714	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF11" ,17)
	715
	716	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF2", 16)
	717
	718	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF4", 19)
	719
	720	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF41" ,20)
	721
	722	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF42" ,21)
	723
	724	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF43" ,22)
	725
	726	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJTLA1" ,2)
	727
	728	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJTLB1" ,7)
	729
	730	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBTRE2", 3)
	731
	732	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBTRE20" ,4)
	733
	734	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBTRKR5" ,5)
	735
	736	"BLD",1019 0,"KRN",19 ,0)
	737	19
	738	"BLD",1019 0,"KRN",19 ,"NM",0)
	739	^9.68A^8^8
	740	"BLD",1019 0,"KRN",19 ,"NM",1,0)
	741	IBT SUP MA NUALLY QUE PRSTHTCS^ ^0
	742	"BLD",1019 0,"KRN",19 ,"NM",2,0)
	743	IBT EDIT T RACKING PA RAMETERS^^ 4^
	744	"BLD",1019 0,"KRN",19 ,"NM",3,0)
	745	IBT SUP MA NUALLY QUE ENCTRS^^4 ^
	746	"BLD",1019 0,"KRN",19 ,"NM",4,0)
	747	IBT SUP MA NUALLY QUE RX FILLS^ ^4^
	748	"BLD",1019 0,"KRN",19 ,"NM",5,0)
	749	IBT SUPERV ISORS MENU ^^0
	750	"BLD",1019 0,"KRN",19 ,"NM",6,0)
	751	IBJ MCCR S ITE PARAME TERS^^0
	752	"BLD",1019 0,"KRN",19 ,"NM",7,0)
	753	IB AUTO BI LLER PARAM S^^0
	754	"BLD",1019 0,"KRN",19 ,"NM",8,0)
	755	IB EDIT SI TE PARAMET ERS^^0
	756	"BLD",1019 0,"KRN",19 ,"NM","B", "IB AUTO B ILLER PARA MS",7)
	757
	758	"BLD",1019 0,"KRN",19 ,"NM","B", "IB EDIT S ITE PARAME TERS",8)
	759
	760	"BLD",1019 0,"KRN",19 ,"NM","B", "IBJ MCCR SITE PARAM ETERS",6)
	761
	762	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT EDIT TRACKING P ARAMETERS" ,2)
	763
	764	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT SUP M ANUALLY QU E ENCTRS", 3)
	765
	766	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT SUP M ANUALLY QU E PRSTHTCS ",1)
	767
	768	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT SUP M ANUALLY QU E RX FILLS ",4)
	769
	770	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT SUPER VISORS MEN U",5)
	771
	772	"BLD",1019 0,"KRN",19 .1,0)
	773	19.1
	774	"BLD",1019 0,"KRN",19 .1,"NM",0)
	775	^9.68A^1^1
	776	"BLD",1019 0,"KRN",19 .1,"NM",1, 0)
	777	IB PARAMET ER EDIT^^0
	778	"BLD",1019 0,"KRN",19 .1,"NM","B ","IB PARA METER EDIT ",1)
	779
	780	"BLD",1019 0,"KRN",10 1,0)
	781	101
	782	"BLD",1019 0,"KRN",10 1,"NM",0)
	783	^9.68A^^
	784	"BLD",1019 0,"KRN",40 9.61,0)
	785	409.61
	786	"BLD",1019 0,"KRN",40 9.61,"NM", 0)
	787	^9.68A^2^2
	788	"BLD",1019 0,"KRN",40 9.61,"NM", 1,0)
	789	IBJT ACTIV E LIST^^0
	790	"BLD",1019 0,"KRN",40 9.61,"NM", 2,0)
	791	IBJT INACT IVE LIST^^ 0
	792	"BLD",1019 0,"KRN",40 9.61,"NM", "B","IBJT ACTIVE LIS T",1)
	793
	794	"BLD",1019 0,"KRN",40 9.61,"NM", "B","IBJT INACTIVE L IST",2)
	795
	796	"BLD",1019 0,"KRN",77 1,0)
	797	771
	798	"BLD",1019 0,"KRN",77 9.2,0)
	799	779.2
	800	"BLD",1019 0,"KRN",87 0,0)
	801	870
	802	"BLD",1019 0,"KRN",87 0,"NM",0)
	803	^9.68A^^
	804	"BLD",1019 0,"KRN",89 89.51,0)
	805	8989.51
	806	"BLD",1019 0,"KRN",89 89.52,0)
	807	8989.52
	808	"BLD",1019 0,"KRN",89 94,0)
	809	8994
	810	"BLD",1019 0,"KRN","B ",.4,.4)
	811
	812	"BLD",1019 0,"KRN","B ",.401,.40 1)
	813
	814	"BLD",1019 0,"KRN","B ",.402,.40 2)
	815
	816	"BLD",1019 0,"KRN","B ",.403,.40 3)
	817
	818	"BLD",1019 0,"KRN","B ",.5,.5)
	819
	820	"BLD",1019 0,"KRN","B ",.84,.84)
	821
	822	"BLD",1019 0,"KRN","B ",3.6,3.6)
	823
	824	"BLD",1019 0,"KRN","B ",3.8,3.8)
	825
	826	"BLD",1019 0,"KRN","B ",9.2,9.2)
	827
	828	"BLD",1019 0,"KRN","B ",9.8,9.8)
	829
	830	"BLD",1019 0,"KRN","B ",19,19)
	831
	832	"BLD",1019 0,"KRN","B ",19.1,19. 1)
	833
	834	"BLD",1019 0,"KRN","B ",101,101)
	835
	836	"BLD",1019 0,"KRN","B ",409.61,4 09.61)
	837
	838	"BLD",1019 0,"KRN","B ",771,771)
	839
	840	"BLD",1019 0,"KRN","B ",779.2,77 9.2)
	841
	842	"BLD",1019 0,"KRN","B ",870,870)
	843
	844	"BLD",1019 0,"KRN","B ",8989.51, 8989.51)
	845
	846	"BLD",1019 0,"KRN","B ",8989.52, 8989.52)
	847
	848	"BLD",1019 0,"KRN","B ",8994,899 4)
	849
	850	"BLD",1019 0,"QDEF")
	851	^^^^NO^^^^ NO^^NO
	852	"BLD",1019 0,"QUES",0 )
	853	^9.62^^
	854	"BLD",1019 0,"REQB",0 )
	855	^9.611^12^ 10
	856	"BLD",1019 0,"REQB",1 ,0)
	857	IB2.080^ 1
	858	"BLD",1019 0,"REQB",2 ,0)
	859	IB2.061^ 1
	860	"BLD",1019 0,"REQB",4 ,0)
	861	IB2.0153 ^1
	862	"BLD",1019 0,"REQB",5 ,0)
	863	IB2.0137 ^1
	864	"BLD",1019 0,"REQB",6 ,0)
	865	IB2.0183 ^1
	866	"BLD",1019 0,"REQB",7 ,0)
	867	IB2.0276 ^1
	868	"BLD",1019 0,"REQB",8 ,0)
	869	IB2.0451 ^1
	870	"BLD",1019 0,"REQB",1 0,0)
	871	IB2.0530 ^1
	872	"BLD",1019 0,"REQB",1 1,0)
	873	IB2.0550 ^1
	874	"BLD",1019 0,"REQB",1 2,0)
	875	IB2.0577 ^1
	876	"BLD",1019 0,"REQB"," B","IB2.0 137",5)
	877
	878	"BLD",1019 0,"REQB"," B","IB2.0 153",4)
	879
	880	"BLD",1019 0,"REQB"," B","IB2.0 183",6)
	881
	882	"BLD",1019 0,"REQB"," B","IB2.0 276",7)
	883
	884	"BLD",1019 0,"REQB"," B","IB2.0 451",8)
	885
	886	"BLD",1019 0,"REQB"," B","IB2.0 530",10)
	887
	888	"BLD",1019 0,"REQB"," B","IB2.0 550",11)
	889
	890	"BLD",1019 0,"REQB"," B","IB2.0 577",12)
	891
	892	"BLD",1019 0,"REQB"," B","IB2.0 61",2)
	893
	894	"BLD",1019 0,"REQB"," B","IB2.0 80",1)
	895
	896	"INIT")
	897	START^IBY5 68PO
	898	"KRN",19,2 314,-1)
	899	0^8
	900	"KRN",19,2 314,0)
	901	IB EDIT SI TE PARAMET ERS^Enter/ Edit IB Si te Paramet ers^^R^^IB PARAMETER EDIT^^^^^ ^INTEGRATE D BILLING
	902	"KRN",19,2 314,1,0)
	903	^19.06^3^3 ^3170328^^ ^^
	904	"KRN",19,2 314,1,1,0)
	905	This optio n allows e ntering an d editing of Integra ted Billin g Site
	906	"KRN",19,2 314,1,2,0)
	907	Parameter file. Mod ifying the site para meters can affect th e performa nce
	908	"KRN",19,2 314,1,3,0)
	909	of Integra ted Billin g's backgr ound filer .
	910	"KRN",19,2 314,15)
	911
	912	"KRN",19,2 314,20)
	913
	914	"KRN",19,2 314,25)
	915	EDIT^IBEFU TL
	916	"KRN",19,2 314,"U")
	917	ENTER/EDIT IB SITE P ARAMETERS
	918	"KRN",19,2 419,-1)
	919	0^5
	920	"KRN",19,2 419,0)
	921	IBT SUPERV ISORS MENU ^Superviso rs Menu (C laims Trac king)^^M^^ IB CLAIMS SUPERVISOR ^^^^^^INTE GRATED BIL LING
	922	"KRN",19,2 419,1,0)
	923	^19.06^3^3 ^3161101^^ ^^
	924	"KRN",19,2 419,1,1,0)
	925	This optio n contains the super visory opt ions for t he Claims tracking
	926	"KRN",19,2 419,1,2,0)
	927	module. S ite parame ters may b e edited. Table fil es may be
	928	"KRN",19,2 419,1,3,0)
	929	maintained . Backgro und jobs m ay be repe ated or re -queued.
	930	"KRN",19,2 419,10,0)
	931	^19.01IP^4 ^4
	932	"KRN",19,2 419,10,1,0 )
	933	2421^PE
	934	"KRN",19,2 419,10,1," ^")
	935	IBT EDIT T RACKING PA RAMETERS
	936	"KRN",19,2 419,10,2,0 )
	937	2434^RX
	938	"KRN",19,2 419,10,2," ^")
	939	IBT SUP MA NUALLY QUE RX FILLS
	940	"KRN",19,2 419,10,3,0 )
	941	2435^OE
	942	"KRN",19,2 419,10,3," ^")
	943	IBT SUP MA NUALLY QUE ENCTRS
	944	"KRN",19,2 419,10,4,0 )
	945	11784^PR
	946	"KRN",19,2 419,10,4," ^")
	947	IBT SUP MA NUALLY QUE PRSTHTCS
	948	"KRN",19,2 419,99)
	949	64371,4690 9
	950	"KRN",19,2 419,"U")
	951	SUPERVISOR S MENU (CL AIMS TRACK
	952	"KRN",19,2 421,-1)
	953	4^2
	954	"KRN",19,2 421,0)
	955	IBT EDIT T RACKING PA RAMETERS
	956	"KRN",19,2 434,-1)
	957	4^4
	958	"KRN",19,2 434,0)
	959	IBT SUP MA NUALLY QUE RX FILLS
	960	"KRN",19,2 435,-1)
	961	4^3
	962	"KRN",19,2 435,0)
	963	IBT SUP MA NUALLY QUE ENCTRS
	964	"KRN",19,2 445,-1)
	965	0^7
	966	"KRN",19,2 445,0)
	967	IB AUTO BI LLER PARAM S^Enter/Ed it Automat ed Billing Parameter s^^R^^IB P ARAMETER E DIT^^^^^^
	968	"KRN",19,2 445,1,0)
	969	^19.06^1^1 ^3170328^^
	970	"KRN",19,2 445,1,1,0)
	971	Enter and edit the p arameters controllin g Automate d Billing.
	972	"KRN",19,2 445,25)
	973	EDIT^IBCDE
	974	"KRN",19,2 445,"U")
	975	ENTER/EDIT AUTOMATED BILLING P
	976	"KRN",19,3 218,-1)
	977	0^6
	978	"KRN",19,3 218,0)
	979	IBJ MCCR S ITE PARAME TERS^MCCR Site Param eter Displ ay/Edit^^R ^^IB PARAM ETER EDIT^ ^^^^^INTEG RATED BILL ING^^
	980	"KRN",19,3 218,1,0)
	981	^19.06^1^1 ^3161215^^ ^^
	982	"KRN",19,3 218,1,1,0)
	983	This optio n allows t he user to view and edit MCCR site param eters.
	984	"KRN",19,3 218,20)
	985
	986	"KRN",19,3 218,25)
	987	IBJPM
	988	"KRN",19,3 218,"U")
	989	MCCR SITE PARAMETER DISPLAY/ED
	990	"KRN",19,1 1784,-1)
	991	0^1
	992	"KRN",19,1 1784,0)
	993	IBT SUP MA NUALLY QUE PRSTHTCS^ Manually A dd Prosthe tics to Cl aims Track ing^^R^^^^ ^^^^INTEGR ATED BILLI NG
	994	"KRN",19,1 1784,1,0)
	995	^^5^5^3161 101^
	996	"KRN",19,1 1784,1,1,0 )
	997	This optio n allows t he user to select a date range of prosth etics
	998	"KRN",19,1 1784,1,2,0 )
	999	encounters and tries to add th em to the Claims tra cking modu le.
	1000	"KRN",19,1 1784,1,3,0 )
	1001
	1002	"KRN",19,1 1784,1,4,0 )
	1003	The option will auto matically queue off a task to add prosth etics and
	1004	"KRN",19,1 1784,1,5,0 )
	1005	when compl ete send t he request ing user a mail mess age.
	1006	"KRN",19,1 1784,25)
	1007	EN^IBTRKR5
	1008	"KRN",19,1 1784,"U")
	1009	MANUALLY A DD PROSTHE TICS TO CL
	1010	"KRN",19.1 ,607,-1)
	1011	0^1
	1012	"KRN",19.1 ,607,0)
	1013	IB PARAMET ER EDIT^^
	1014	"KRN",409. 61,84,-1)
	1015	0^1
	1016	"KRN",409. 61,84,0)
	1017	IBJT ACTIV E LIST^1^^ 80^4^20^1^ 1^Active B ill^IBJT A CTIVE LIST SCREEN ME NU^Third P arty Activ e Bills^1^ ^1
	1018	"KRN",409. 61,84,1)
	1019	^VALM HIDD EN ACTIONS
	1020	"KRN",409. 61,84,"ARR AY")
	1021	^TMP("IBJ TLA",$J)
	1022	"KRN",409. 61,84,"COL ",0)
	1023	^409.621^1 4^14
	1024	"KRN",409. 61,84,"COL ",1,0)
	1025	NUMBER^1^3
	1026	"KRN",409. 61,84,"COL ",2,0)
	1027	BILL^4^9^ Bill #
	1028	"KRN",409. 61,84,"COL ",3,0)
	1029	HD^14^1
	1030	"KRN",409. 61,84,"COL ",4,0)
	1031	STFROM^15^ 8^From
	1032	"KRN",409. 61,84,"COL ",5,0)
	1033	STTO^24^8^ To
	1034	"KRN",409. 61,84,"COL ",6,0)
	1035	TYPE^37^5^ Type
	1036	"KRN",409. 61,84,"COL ",7,0)
	1037	ARST^42^4^ Stat
	1038	"KRN",409. 61,84,"COL ",8,0)
	1039	RATE^47^7^ Rate
	1040	"KRN",409. 61,84,"COL ",9,0)
	1041	CB^55^1
	1042	"KRN",409. 61,84,"COL ",10,0)
	1043	INSUR^56^7 ^Insurer
	1044	"KRN",409. 61,84,"COL ",11,0)
	1045	OAMT^64^8^ Orig Amt
	1046	"KRN",409. 61,84,"COL ",12,0)
	1047	CAMT^73^8^ Curr Amt
	1048	"KRN",409. 61,84,"COL ",13,0)
	1049	REFER^13^1
	1050	"KRN",409. 61,84,"COL ",14,0)
	1051	MT?^33^3^M T?
	1052	"KRN",409. 61,84,"COL ","B","ARS T",7)
	1053
	1054	"KRN",409. 61,84,"COL ","B","BIL L",2)
	1055
	1056	"KRN",409. 61,84,"COL ","B","CAM T",12)
	1057
	1058	"KRN",409. 61,84,"COL ","B","CB" ,9)
	1059
	1060	"KRN",409. 61,84,"COL ","B","HD" ,3)
	1061
	1062	"KRN",409. 61,84,"COL ","B","INS UR",10)
	1063
	1064	"KRN",409. 61,84,"COL ","B","MT? ",14)
	1065
	1066	"KRN",409. 61,84,"COL ","B","NUM BER",1)
	1067
	1068	"KRN",409. 61,84,"COL ","B","OAM T",11)
	1069
	1070	"KRN",409. 61,84,"COL ","B","RAT E",8)
	1071
	1072	"KRN",409. 61,84,"COL ","B","REF ER",13)
	1073
	1074	"KRN",409. 61,84,"COL ","B","STF ROM",4)
	1075
	1076	"KRN",409. 61,84,"COL ","B","STT O",5)
	1077
	1078	"KRN",409. 61,84,"COL ","B","TYP E",6)
	1079
	1080	"KRN",409. 61,84,"FNL ")
	1081	D EXIT^IBJ TLA
	1082	"KRN",409. 61,84,"HDR ")
	1083	D HDR^IBJT LA
	1084	"KRN",409. 61,84,"HLP ")
	1085	D HELP^IBJ TLA
	1086	"KRN",409. 61,84,"INI T")
	1087	D INIT^IBJ TLA
	1088	"KRN",409. 61,95,-1)
	1089	0^2
	1090	"KRN",409. 61,95,0)
	1091	IBJT INACT IVE LIST^1 ^^80^5^20^ 1^1^Inacti ve Bill^IB JT INACTIV E LIST SCR EEN MENU^I nactive Bi lls^1^^1
	1092	"KRN",409. 61,95,1)
	1093	^VALM HIDD EN ACTIONS
	1094	"KRN",409. 61,95,"ARR AY")
	1095	^TMP("IBJ TLB",$J)
	1096	"KRN",409. 61,95,"COL ",0)
	1097	^409.621^1 3^13
	1098	"KRN",409. 61,95,"COL ",1,0)
	1099	NUMBER^1^3
	1100	"KRN",409. 61,95,"COL ",2,0)
	1101	BILL^4^12^ Bill #
	1102	"KRN",409. 61,95,"COL ",3,0)
	1103	HD^17^1
	1104	"KRN",409. 61,95,"COL ",4,0)
	1105	STFROM^18^ 8^From
	1106	"KRN",409. 61,95,"COL ",5,0)
	1107	STTO^27^8^ To
	1108	"KRN",409. 61,95,"COL ",6,0)
	1109	TYPE^36^5^ Type
	1110	"KRN",409. 61,95,"COL ",7,0)
	1111	ARST^41^4^ Stat
	1112	"KRN",409. 61,95,"COL ",8,0)
	1113	RATE^46^7^ Rate
	1114	"KRN",409. 61,95,"COL ",9,0)
	1115	CB^54^1
	1116	"KRN",409. 61,95,"COL ",10,0)
	1117	INSUR^55^7 ^Insurer
	1118	"KRN",409. 61,95,"COL ",11,0)
	1119	OAMT^64^8^ Orig Amt
	1120	"KRN",409. 61,95,"COL ",12,0)
	1121	CAMT^73^8^ Curr Amt
	1122	"KRN",409. 61,95,"COL ",13,0)
	1123	REFER^16^1
	1124	"KRN",409. 61,95,"COL ","B","ARS T",7)
	1125
	1126	"KRN",409. 61,95,"COL ","B","BIL L",2)
	1127
	1128	"KRN",409. 61,95,"COL ","B","CAM T",12)
	1129
	1130	"KRN",409. 61,95,"COL ","B","CB" ,9)
	1131
	1132	"KRN",409. 61,95,"COL ","B","HD" ,3)
	1133
	1134	"KRN",409. 61,95,"COL ","B","INS UR",10)
	1135
	1136	"KRN",409. 61,95,"COL ","B","NUM BER",1)
	1137
	1138	"KRN",409. 61,95,"COL ","B","OAM T",11)
	1139
	1140	"KRN",409. 61,95,"COL ","B","RAT E",8)
	1141
	1142	"KRN",409. 61,95,"COL ","B","REF ER",13)
	1143
	1144	"KRN",409. 61,95,"COL ","B","STF ROM",4)
	1145
	1146	"KRN",409. 61,95,"COL ","B","STT O",5)
	1147
	1148	"KRN",409. 61,95,"COL ","B","TYP E",6)
	1149
	1150	"KRN",409. 61,95,"FNL ")
	1151	D EXIT^IBJ TLB
	1152	"KRN",409. 61,95,"HDR ")
	1153	D HDR^IBJT LB
	1154	"KRN",409. 61,95,"HLP ")
	1155	D HELP^IBJ TLB
	1156	"KRN",409. 61,95,"INI T")
	1157	D INIT^IBJ TLB
	1158	"MBREQ")
	1159	0
	1160	"ORD",3,19 .1)
	1161	19.1;3;;;K EY^XPDTA1; KEYF1^XPDI A1;KEYE1^X PDIA1;KEYF 2^XPDIA1;; KEYDEL^XPD IA1
	1162	"ORD",3,19 .1,0)
	1163	SECURITY K EY
	1164	"ORD",17,4 09.61)
	1165	409.61;17; 1;;;;LME1^ XPDIA1;;;L MDEL^XPDIA 1
	1166	"ORD",17,4 09.61,0)
	1167	LIST TEMPL ATE
	1168	"ORD",18,1 9)
	1169	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
	1170	"ORD",18,1 9,0)
	1171	OPTION
	1172	"PKG",49,- 1)
	1173	1^1
	1174	"PKG",49,0 )
	1175	INTEGRATED BILLING^I B^INTEGRAT ED BILLING
	1176	"PKG",49,2 0,0)
	1177	^9.402P^1^ 1
	1178	"PKG",49,2 0,1,0)
	1179	2^^IBAXDR
	1180	"PKG",49,2 0,1,1)
	1181
	1182	"PKG",49,2 0,"B",2,1)
	1183
	1184	"PKG",49,2 2,0)
	1185	^9.49I^1^1
	1186	"PKG",49,2 2,1,0)
	1187	2.0^305111 9^2960627
	1188	"PKG",49,2 2,1,"PAH", 1,0)
	1189	568^317102 4
	1190	"PKG",49,2 2,1,"PAH", 1,1,0)
	1191	^^313^313^ 3171024
	1192	"PKG",49,2 2,1,"PAH", 1,1,1,0)
	1193
	1194	"PKG",49,2 2,1,"PAH", 1,1,2,0)
	1195	IMPORTANT INSTALLATI ON NOTE:
	1196	"PKG",49,2 2,1,"PAH", 1,1,3,0)
	1197	---------- ---------- --------
	1198	"PKG",49,2 2,1,"PAH", 1,1,4,0)
	1199	This patch is part o f a multi- package bu ild. There are three patches
	1200	"PKG",49,2 2,1,"PAH", 1,1,5,0)
	1201	associated with the FY16 HAPE Revenue En hancement project -
	1202	"PKG",49,2 2,1,"PAH", 1,1,6,0)
	1203	IB2.0568 ,PRCA4.5 315 and PS O7.0463. All three patches a re to be
	1204	"PKG",49,2 2,1,"PAH", 1,1,7,0)
	1205	installed together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
	1206	"PKG",49,2 2,1,"PAH", 1,1,8,0)
	1207
	1208	"PKG",49,2 2,1,"PAH", 1,1,9,0)
	1209
	1210	"PKG",49,2 2,1,"PAH", 1,1,10,0)
	1211	Descriptio n
	1212	"PKG",49,2 2,1,"PAH", 1,1,11,0)
	1213	---------- -
	1214	"PKG",49,2 2,1,"PAH", 1,1,12,0)
	1215	The Chief Business O ffice (CBO ) is reque sting syst em enhance ments to
	1216	"PKG",49,2 2,1,"PAH", 1,1,13,0)
	1217	The Vetera ns Health Informatio n Systems and Techno logy Archi tecture
	1218	"PKG",49,2 2,1,"PAH", 1,1,14,0)
	1219	(VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd
	1220	"PKG",49,2 2,1,"PAH", 1,1,15,0)
	1221	Outpatient Pharmacy (PSO) soft ware modul es.
	1222	"PKG",49,2 2,1,"PAH", 1,1,16,0)
	1223
	1224	"PKG",49,2 2,1,"PAH", 1,1,17,0)
	1225	The missio n of the D epartment of Veteran s Affairs (VA), Offi ce of
	1226	"PKG",49,2 2,1,"PAH", 1,1,18,0)
	1227	Informatio n & Techno logy (OI&T ), is to p rovide ben efits and services
	1228	"PKG",49,2 2,1,"PAH", 1,1,19,0)
	1229	to veteran s of the U nited Stat es Armed F orces. In meeting th ese
	1230	"PKG",49,2 2,1,"PAH", 1,1,20,0)
	1231	goals, OIT strives t o provide high quali ty, effect ive, and e fficient
	1232	"PKG",49,2 2,1,"PAH", 1,1,21,0)
	1233	Informatio n Technolo gy (IT) se rvices to those resp onsible fo r
	1234	"PKG",49,2 2,1,"PAH", 1,1,22,0)
	1235	providing care to th e veterans at the po int-of-car e, as well as
	1236	"PKG",49,2 2,1,"PAH", 1,1,23,0)
	1237	throughout all the p oints of t he veteran s' health care. The VA depends
	1238	"PKG",49,2 2,1,"PAH", 1,1,24,0)
	1239	on Informa tion Manag ement/Info rmation Te chnology ( IM/IT) sys tems to
	1240	"PKG",49,2 2,1,"PAH", 1,1,25,0)
	1241	meet missi on goals.
	1242	"PKG",49,2 2,1,"PAH", 1,1,26,0)
	1243
	1244	"PKG",49,2 2,1,"PAH", 1,1,27,0)
	1245	The overal l FY16 HAP E Revenue Enhancemen t project has been f urther
	1246	"PKG",49,2 2,1,"PAH", 1,1,28,0)
	1247	divided in to three s ub-project s:
	1248	"PKG",49,2 2,1,"PAH", 1,1,29,0)
	1249
	1250	"PKG",49,2 2,1,"PAH", 1,1,30,0)
	1251	NSR #20150 506
	1252	"PKG",49,2 2,1,"PAH", 1,1,31,0)
	1253	The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the Chief
	1254	"PKG",49,2 2,1,"PAH", 1,1,32,0)
	1255	Business O ffice (CBO ), bundles several N SRs with s imilar bus iness
	1256	"PKG",49,2 2,1,"PAH", 1,1,33,0)
	1257	needs into a single requiremen ts documen t. Succes sfully add ressing
	1258	"PKG",49,2 2,1,"PAH", 1,1,34,0)
	1259	the requir ements con tained wit hin this d ocument wi ll enable the
	1260	"PKG",49,2 2,1,"PAH", 1,1,35,0)
	1261	Department of Vetera ns Affairs (VA) to a ppropriate ly bill ce rtain
	1262	"PKG",49,2 2,1,"PAH", 1,1,36,0)
	1263	subsets of billable events by correcting , automati ng, or enh ancing
	1264	"PKG",49,2 2,1,"PAH", 1,1,37,0)
	1265	current Ve terans Hea lth Inform ation Syst ems and Te chnology
	1266	"PKG",49,2 2,1,"PAH", 1,1,38,0)
	1267	Architectu re (VistA) systems.
	1268	"PKG",49,2 2,1,"PAH", 1,1,39,0)
	1269
	1270	"PKG",49,2 2,1,"PAH", 1,1,40,0)
	1271	NSR #20150 507
	1272	"PKG",49,2 2,1,"PAH", 1,1,41,0)
	1273	The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs,
	1274	"PKG",49,2 2,1,"PAH", 1,1,42,0)
	1275	as well. T his effort enables t he Departm ent of Vet erans Affa irs (VA)
	1276	"PKG",49,2 2,1,"PAH", 1,1,43,0)
	1277	to improve revenue o peration f unctionali ty related to repaym ent plans,
	1278	"PKG",49,2 2,1,"PAH", 1,1,44,0)
	1279	late charg e capture, bill susp ension rea sons, the billing of
	1280	"PKG",49,2 2,1,"PAH", 1,1,45,0)
	1281	deactivate d provider s, and the display o f appeal r ights and
	1282	"PKG",49,2 2,1,"PAH", 1,1,46,0)
	1283	responsibi lities on the Vetera ns Benefic iary trave l Bill of Collection s
	1284	"PKG",49,2 2,1,"PAH", 1,1,47,0)
	1285	form. Imp lementatio n of the p roposed en hancements will make a
	1286	"PKG",49,2 2,1,"PAH", 1,1,48,0)
	1287	significan t positive impact on stakehold ers and ta rget users .
	1288	"PKG",49,2 2,1,"PAH", 1,1,49,0)
	1289
	1290	"PKG",49,2 2,1,"PAH", 1,1,50,0)
	1291	NSR #20150 505
	1292	"PKG",49,2 2,1,"PAH", 1,1,51,0)
	1293	The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to
	1294	"PKG",49,2 2,1,"PAH", 1,1,52,0)
	1295	improve tr acking and reporting of revenu e, and wil l support revenue
	1296	"PKG",49,2 2,1,"PAH", 1,1,53,0)
	1297	reporting business r ules and g uidelines.
	1298	"PKG",49,2 2,1,"PAH", 1,1,54,0)
	1299
	1300	"PKG",49,2 2,1,"PAH", 1,1,55,0)
	1301
	1302	"PKG",49,2 2,1,"PAH", 1,1,56,0)
	1303	IB2.0568 patch enh ancements, pertinent to the ab ove NSRs, include:
	1304	"PKG",49,2 2,1,"PAH", 1,1,57,0)
	1305
	1306	"PKG",49,2 2,1,"PAH", 1,1,58,0)
	1307	1.) When g enerating the RNB (R easons Not Billable) report, t he
	1308	"PKG",49,2 2,1,"PAH", 1,1,59,0)
	1309	Integrated Billing s ystem shal l populate the charg es for all types
	1310	"PKG",49,2 2,1,"PAH", 1,1,60,0)
	1311	of service s provided . Charges will not b e screened by any bi llable
	1312	"PKG",49,2 2,1,"PAH", 1,1,61,0)
	1313	criteria b ut willind icate the full amoun t as if th e care was to be
	1314	"PKG",49,2 2,1,"PAH", 1,1,62,0)
	1315	billed.
	1316	"PKG",49,2 2,1,"PAH", 1,1,63,0)
	1317
	1318	"PKG",49,2 2,1,"PAH", 1,1,64,0)
	1319	2.) The su b-option C laims Trac king Param eter Edit [IBT EDIT TRACKING
	1320	"PKG",49,2 2,1,"PAH", 1,1,65,0)
	1321	PARAMETERS ], that cu rrently ha s no key, will be lo cked with a new
	1322	"PKG",49,2 2,1,"PAH", 1,1,66,0)
	1323	Security K ey called IB PARAMET ER EDIT.
	1324	"PKG",49,2 2,1,"PAH", 1,1,67,0)
	1325
	1326	"PKG",49,2 2,1,"PAH", 1,1,68,0)
	1327	3.) The op tion MCCR Site Param eter Displ ay/Edit [I BJ MCCR SI TE
	1328	"PKG",49,2 2,1,"PAH", 1,1,69,0)
	1329	PARAMETERS ], which i s currentl y locked w ith the IB SUPERVISO R Security
	1330	"PKG",49,2 2,1,"PAH", 1,1,70,0)
	1331	Key, will be instead locked wi th the new key.
	1332	"PKG",49,2 2,1,"PAH", 1,1,71,0)
	1333
	1334	"PKG",49,2 2,1,"PAH", 1,1,72,0)
	1335	4.) The In tegrated B illing sys tem shall create cla ims tracki ng entries
	1336	"PKG",49,2 2,1,"PAH", 1,1,73,0)
	1337	for previo usly unbil led Prosth etics/DME items when new billa ble
	1338	"PKG",49,2 2,1,"PAH", 1,1,74,0)
	1339	insurance is entered into the patient's insurance file.
	1340	"PKG",49,2 2,1,"PAH", 1,1,75,0)
	1341
	1342	"PKG",49,2 2,1,"PAH", 1,1,76,0)
	1343	5.) A new coverage l imitation field shal l be creat ed in the insurance
	1344	"PKG",49,2 2,1,"PAH", 1,1,77,0)
	1345	file for P rosthetics . Like th e other ex isting cov erage limi tation
	1346	"PKG",49,2 2,1,"PAH", 1,1,78,0)
	1347	fields in the insura nce file ( Inpatient, Outpatien t, Pharmac y etc.),
	1348	"PKG",49,2 2,1,"PAH", 1,1,79,0)
	1349	this field will have the follo wing optio ns:
	1350	"PKG",49,2 2,1,"PAH", 1,1,80,0)
	1351	0= NOT COVERE D
	1352	"PKG",49,2 2,1,"PAH", 1,1,81,0)
	1353	1= COVERED
	1354	"PKG",49,2 2,1,"PAH", 1,1,82,0)
	1355	2= CONDITIONA LCOVERAGE
	1356	"PKG",49,2 2,1,"PAH", 1,1,83,0)
	1357	Once selec ted, they will show in the pat ient insur ance file as Yes,
	1358	"PKG",49,2 2,1,"PAH", 1,1,84,0)
	1359	No, or Con ditional.
	1360	"PKG",49,2 2,1,"PAH", 1,1,85,0)
	1361
	1362	"PKG",49,2 2,1,"PAH", 1,1,86,0)
	1363	6.) The sy stem shall automatic ally assig n an RNB [ NO PROSTHE TIC
	1364	"PKG",49,2 2,1,"PAH", 1,1,87,0)
	1365	COVERAGE ( CV22)] for Prostheti cs/DME ite ms if the patient ha s no
	1366	"PKG",49,2 2,1,"PAH", 1,1,88,0)
	1367	coverage f or Prosthe tics in hi s/her insu rance file .
	1368	"PKG",49,2 2,1,"PAH", 1,1,89,0)
	1369
	1370	"PKG",49,2 2,1,"PAH", 1,1,90,0)
	1371	7.) The sy stem shall have a ne w option t o add Pros thetics it ems to
	1372	"PKG",49,2 2,1,"PAH", 1,1,91,0)
	1373	Manual and Nightly C laims Trac king.
	1374	"PKG",49,2 2,1,"PAH", 1,1,92,0)
	1375
	1376	"PKG",49,2 2,1,"PAH", 1,1,93,0)
	1377	8.) Users will be ab le to sele ct Suspend ed Type fr om the men u to
	1378	"PKG",49,2 2,1,"PAH", 1,1,94,0)
	1379	display in the First Party Fol low- Up [I BJD FOLLOW -UP FIRST PARTY]
	1380	"PKG",49,2 2,1,"PAH", 1,1,95,0)
	1381	report.
	1382	"PKG",49,2 2,1,"PAH", 1,1,96,0)
	1383
	1384	"PKG",49,2 2,1,"PAH", 1,1,97,0)
	1385	9.) First Party Foll ow- Up [IB JD FOLLOW- UP FIRST P ARTY] repo rt shall
	1386	"PKG",49,2 2,1,"PAH", 1,1,98,0)
	1387	be modifie d to incor porate rea son for su spension.
	1388	"PKG",49,2 2,1,"PAH", 1,1,99,0)
	1389
	1390	"PKG",49,2 2,1,"PAH", 1,1,100,0)
	1391	10.) A new warning m essage wil l print to the scree n in the E nter/Edit
	1392	"PKG",49,2 2,1,"PAH", 1,1,101,0)
	1393	Billing In formation option if an ATTENDI NG, REFERR ING or REN DERING
	1394	"PKG",49,2 2,1,"PAH", 1,1,102,0)
	1395	Provider h as a PERSO N CLASS - NEW PERSON file (#20 0) - that was
	1396	"PKG",49,2 2,1,"PAH", 1,1,103,0)
	1397	expirated at the tim e of the D ate of Ser vice.
	1398	"PKG",49,2 2,1,"PAH", 1,1,104,0)
	1399
	1400	"PKG",49,2 2,1,"PAH", 1,1,105,0)
	1401	11.) On th e Third Pa rty Joint Inquiry sc reen, one (1) charac ter space
	1402	"PKG",49,2 2,1,"PAH", 1,1,106,0)
	1403	shall be a dded to th e "Type" f ield so th at it will accommoda te five
	1404	"PKG",49,2 2,1,"PAH", 1,1,107,0)
	1405	characters (a one-ch aracter cl assificati on indicat or, a forw ard slash
	1406	"PKG",49,2 2,1,"PAH", 1,1,108,0)
	1407	(/), a one -character component indicator , a forwar d slash (/ ), and a
	1408	"PKG",49,2 2,1,"PAH", 1,1,109,0)
	1409	one-charac ter care t ype) ("X/X /X"). If a bill con tains pres criptions,
	1410	"PKG",49,2 2,1,"PAH", 1,1,110,0)
	1411	then an "R " shall be concatena ted to the fifth cha racter sub -type
	1412	"PKG",49,2 2,1,"PAH", 1,1,111,0)
	1413	position o f the "Typ e" field. If a bill contains p rosthetics , then a
	1414	"PKG",49,2 2,1,"PAH", 1,1,112,0)
	1415	"P" shall be concate nated to f ifth chara cter sub-t ype positi on of the
	1416	"PKG",49,2 2,1,"PAH", 1,1,113,0)
	1417	"Type" fie ld.The "Ty pe" field shall cont ain five ( 5) charact ers as
	1418	"PKG",49,2 2,1,"PAH", 1,1,114,0)
	1419	follows:
	1420	"PKG",49,2 2,1,"PAH", 1,1,115,0)
	1421	1. "I" for Inpatient or "O" fo r Outpatie nt,
	1422	"PKG",49,2 2,1,"PAH", 1,1,116,0)
	1423	2. "/" for ward slash character
	1424	"PKG",49,2 2,1,"PAH", 1,1,117,0)
	1425	3. "P" for Professio nal or "I" for Insti tutional
	1426	"PKG",49,2 2,1,"PAH", 1,1,118,0)
	1427	4. "/" for ward slash character
	1428	"PKG",49,2 2,1,"PAH", 1,1,119,0)
	1429	5. "P" for Prostheti cs or "R" for Prescr iptions
	1430	"PKG",49,2 2,1,"PAH", 1,1,120,0)
	1431
	1432	"PKG",49,2 2,1,"PAH", 1,1,121,0)
	1433	12.) Three new Third Party Ins urance Rat e Types sh all be cre ated in
	1434	"PKG",49,2 2,1,"PAH", 1,1,122,0)
	1435	the VistA IB Suite f or the bil lers to ch oose from when billi ng for
	1436	"PKG",49,2 2,1,"PAH", 1,1,123,0)
	1437	encounters . They are as follow s:
	1438	"PKG",49,2 2,1,"PAH", 1,1,124,0)
	1439	HU MANITARIAN REIMB. IN S.
	1440	"PKG",49,2 2,1,"PAH", 1,1,125,0)
	1441	DE NTAL REIMB . INS.
	1442	"PKG",49,2 2,1,"PAH", 1,1,126,0)
	1443	IN ELIGIBLE R EIMB. INS.
	1444	"PKG",49,2 2,1,"PAH", 1,1,127,0)
	1445
	1446	"PKG",49,2 2,1,"PAH", 1,1,128,0)
	1447	13.) Each of the new rate type s above wi ll have th e 'Insurer ' as the
	1448	"PKG",49,2 2,1,"PAH", 1,1,129,0)
	1449	responsibl e party.
	1450	"PKG",49,2 2,1,"PAH", 1,1,130,0)
	1451
	1452	"PKG",49,2 2,1,"PAH", 1,1,131,0)
	1453	14.) Bille rs (revenu e staff) s hould be a ble to ide ntify any remaining
	1454	"PKG",49,2 2,1,"PAH", 1,1,132,0)
	1455	charges to the patie nt after t he Third P arty payme nts are re ceived for
	1456	"PKG",49,2 2,1,"PAH", 1,1,133,0)
	1457	Emergency Humanitari an, Inelig ible and D ental serv ices so th ey can
	1458	"PKG",49,2 2,1,"PAH", 1,1,134,0)
	1459	accomplish balance b illing.
	1460	"PKG",49,2 2,1,"PAH", 1,1,135,0)
	1461
	1462	"PKG",49,2 2,1,"PAH", 1,1,136,0)
	1463
	1464	"PKG",49,2 2,1,"PAH", 1,1,137,0)
	1465
	1466	"PKG",49,2 2,1,"PAH", 1,1,138,0)
	1467	Concurrent Developme nt / Depen dencies:
	1468	"PKG",49,2 2,1,"PAH", 1,1,139,0)
	1469	---------- ---------- ---------- --------
	1470	"PKG",49,2 2,1,"PAH", 1,1,140,0)
	1471	N/A
	1472	"PKG",49,2 2,1,"PAH", 1,1,141,0)
	1473
	1474	"PKG",49,2 2,1,"PAH", 1,1,142,0)
	1475
	1476	"PKG",49,2 2,1,"PAH", 1,1,143,0)
	1477	Patch Comp onents:
	1478	"PKG",49,2 2,1,"PAH", 1,1,144,0)
	1479	---------- -------
	1480	"PKG",49,2 2,1,"PAH", 1,1,145,0)
	1481
	1482	"PKG",49,2 2,1,"PAH", 1,1,146,0)
	1483	Files & Fi elds Assoc iated:
	1484	"PKG",49,2 2,1,"PAH", 1,1,147,0)
	1485
	1486	"PKG",49,2 2,1,"PAH", 1,1,148,0)
	1487	File Name (Number) Field Na me (Number ) New/ Modified/D eleted
	1488	"PKG",49,2 2,1,"PAH", 1,1,149,0)
	1489	---------- -------- -------- ---------- - ---- ---------- ------
	1490	"PKG",49,2 2,1,"PAH", 1,1,150,0)
	1491	N/A
	1492	"PKG",49,2 2,1,"PAH", 1,1,151,0)
	1493
	1494	"PKG",49,2 2,1,"PAH", 1,1,152,0)
	1495	Options As sociated:
	1496	"PKG",49,2 2,1,"PAH", 1,1,153,0)
	1497
	1498	"PKG",49,2 2,1,"PAH", 1,1,154,0)
	1499	Option Nam e Type New/ Modified/D eleted
	1500	"PKG",49,2 2,1,"PAH", 1,1,155,0)
	1501	---------- - ---- ---- ---------- ------
	1502	"PKG",49,2 2,1,"PAH", 1,1,156,0)
	1503	IBT SUP MA NUALLY QUE PRSTHTCS ROUTINE NEW
	1504	"PKG",49,2 2,1,"PAH", 1,1,157,0)
	1505
	1506	"PKG",49,2 2,1,"PAH", 1,1,158,0)
	1507	Protocols Associated :
	1508	"PKG",49,2 2,1,"PAH", 1,1,159,0)
	1509
	1510	"PKG",49,2 2,1,"PAH", 1,1,160,0)
	1511	Protocol N ame New /Modified/ Deleted
	1512	"PKG",49,2 2,1,"PAH", 1,1,161,0)
	1513	---------- --- --- ---------- -------
	1514	"PKG",49,2 2,1,"PAH", 1,1,162,0)
	1515	N/A
	1516	"PKG",49,2 2,1,"PAH", 1,1,163,0)
	1517
	1518	"PKG",49,2 2,1,"PAH", 1,1,164,0)
	1519	Templates Associated :
	1520	"PKG",49,2 2,1,"PAH", 1,1,165,0)
	1521
	1522	"PKG",49,2 2,1,"PAH", 1,1,166,0)
	1523	Template N ame T ype File Name (Num ber) New/Mod/De l
	1524	"PKG",49,2 2,1,"PAH", 1,1,167,0)
	1525	---------- --- - --- ---- ---------- ---- ---------- -
	1526	"PKG",49,2 2,1,"PAH", 1,1,168,0)
	1527	IBJT ACTIV E LIST L IST NEW
	1528	"PKG",49,2 2,1,"PAH", 1,1,169,0)
	1529	IBJT INACT IVE LIST L IST NEW
	1530	"PKG",49,2 2,1,"PAH", 1,1,170,0)
	1531
	1532	"PKG",49,2 2,1,"PAH", 1,1,171,0)
	1533	New Servic e Requests (NSRs):
	1534	"PKG",49,2 2,1,"PAH", 1,1,172,0)
	1535	---------- ---------- --------
	1536	"PKG",49,2 2,1,"PAH", 1,1,173,0)
	1537	20150505 - Revenue R eporting E nhancement s
	1538	"PKG",49,2 2,1,"PAH", 1,1,174,0)
	1539	20150506 - Revenue E ligibility Enhanceme nts
	1540	"PKG",49,2 2,1,"PAH", 1,1,175,0)
	1541	20150507 - Revenue O perations Enhancemen ts
	1542	"PKG",49,2 2,1,"PAH", 1,1,176,0)
	1543
	1544	"PKG",49,2 2,1,"PAH", 1,1,177,0)
	1545
	1546	"PKG",49,2 2,1,"PAH", 1,1,178,0)
	1547	Patient Sa fety Issue s (PSIs):
	1548	"PKG",49,2 2,1,"PAH", 1,1,179,0)
	1549	---------- ---------- ----------
	1550	"PKG",49,2 2,1,"PAH", 1,1,180,0)
	1551	N/A
	1552	"PKG",49,2 2,1,"PAH", 1,1,181,0)
	1553
	1554	"PKG",49,2 2,1,"PAH", 1,1,182,0)
	1555
	1556	"PKG",49,2 2,1,"PAH", 1,1,183,0)
	1557	Remedy Tic ket(s) & O verviews:
	1558	"PKG",49,2 2,1,"PAH", 1,1,184,0)
	1559	---------- ---------- ---------
	1560	"PKG",49,2 2,1,"PAH", 1,1,185,0)
	1561	N/A
	1562	"PKG",49,2 2,1,"PAH", 1,1,186,0)
	1563
	1564	"PKG",49,2 2,1,"PAH", 1,1,187,0)
	1565	Test Sites :
	1566	"PKG",49,2 2,1,"PAH", 1,1,188,0)
	1567	----------
	1568	"PKG",49,2 2,1,"PAH", 1,1,189,0)
	1569	Durham VAM C
	1570	"PKG",49,2 2,1,"PAH", 1,1,190,0)
	1571
	1572	"PKG",49,2 2,1,"PAH", 1,1,191,0)
	1573
	1574	"PKG",49,2 2,1,"PAH", 1,1,192,0)
	1575	Software a nd Documen tation Ret rieval Ins tructions:
	1576	"PKG",49,2 2,1,"PAH", 1,1,193,0)
	1577	---------- ---------- ---------- ---------- ---------- --
	1578	"PKG",49,2 2,1,"PAH", 1,1,194,0)
	1579	Patches fo r this ins tallation are combin ed in host file
	1580	"PKG",49,2 2,1,"PAH", 1,1,195,0)
	1581	IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
	1582	"PKG",49,2 2,1,"PAH", 1,1,196,0)
	1583
	1584	"PKG",49,2 2,1,"PAH", 1,1,197,0)
	1585	Installati on of this host file should be coordinat ed among t he package s
	1586	"PKG",49,2 2,1,"PAH", 1,1,198,0)
	1587	affected s ince only one instal lation is necessary.
	1588	"PKG",49,2 2,1,"PAH", 1,1,199,0)
	1589
	1590	"PKG",49,2 2,1,"PAH", 1,1,200,0)
	1591	The patche s are:
	1592	"PKG",49,2 2,1,"PAH", 1,1,201,0)
	1593
	1594	"PKG",49,2 2,1,"PAH", 1,1,202,0)
	1595	IB2. 0568
	1596	"PKG",49,2 2,1,"PAH", 1,1,203,0)
	1597	PRCA* 4.5*315
	1598	"PKG",49,2 2,1,"PAH", 1,1,204,0)
	1599	PSO7 .0463
	1600	"PKG",49,2 2,1,"PAH", 1,1,205,0)
	1601
	1602	"PKG",49,2 2,1,"PAH", 1,1,206,0)
	1603
	1604	"PKG",49,2 2,1,"PAH", 1,1,207,0)
	1605	Sites may retrieve t he KIDS bu ild in one of the fo llowing wa ys:
	1606	"PKG",49,2 2,1,"PAH", 1,1,208,0)
	1607
	1608	"PKG",49,2 2,1,"PAH", 1,1,209,0)
	1609	(1) The pr eferred me thod is to FTP the f iles from
	1610	"PKG",49,2 2,1,"PAH", 1,1,210,0)
	1611	URL which wil l transmit the files from the first
	1612	"PKG",49,2 2,1,"PAH", 1,1,211,0)
	1613	available FTP server .
	1614	"PKG",49,2 2,1,"PAH", 1,1,212,0)
	1615
	1616	"PKG",49,2 2,1,"PAH", 1,1,213,0)
	1617	(2) Sites may also e lect to re trieve the patch dir ectly from a specifi c
	1618	"PKG",49,2 2,1,"PAH", 1,1,214,0)
	1619	server as follows:
	1620	"PKG",49,2 2,1,"PAH", 1,1,215,0)
	1621
	1622	"PKG",49,2 2,1,"PAH", 1,1,216,0)
	1623	OIFO FTP ADDRE SS DIRECTORY
	1624	"PKG",49,2 2,1,"PAH", 1,1,217,0)
	1625	-------- ------ --------- ---------- ----- ---------- --------
	1626	"PKG",49,2 2,1,"PAH", 1,1,218,0)
	1627	Albany URL anonymous. software
	1628	"PKG",49,2 2,1,"PAH", 1,1,219,0)
	1629	Hines URL anonymous. software
	1630	"PKG",49,2 2,1,"PAH", 1,1,220,0)
	1631	Salt Lake City URL anonymous. software
	1632	"PKG",49,2 2,1,"PAH", 1,1,221,0)
	1633
	1634	"PKG",49,2 2,1,"PAH", 1,1,222,0)
	1635
	1636	"PKG",49,2 2,1,"PAH", 1,1,223,0)
	1637	Sites may retrieve d ocumentati on directl y using Se cure File Transfer
	1638	"PKG",49,2 2,1,"PAH", 1,1,224,0)
	1639	Protocol ( SFTP) from the ANONY MOUS.SOFTW ARE direct ory at the following
	1640	"PKG",49,2 2,1,"PAH", 1,1,225,0)
	1641	OI Field O ffices:
	1642	"PKG",49,2 2,1,"PAH", 1,1,226,0)
	1643
	1644	"PKG",49,2 2,1,"PAH", 1,1,227,0)
	1645	Albany: URL
	1646	"PKG",49,2 2,1,"PAH", 1,1,228,0)
	1647	Hines: URL
	1648	"PKG",49,2 2,1,"PAH", 1,1,229,0)
	1649	Salt Lake City: URL
	1650	"PKG",49,2 2,1,"PAH", 1,1,230,0)
	1651
	1652	"PKG",49,2 2,1,"PAH", 1,1,231,0)
	1653	Documentat ion can al so be foun d on the V A Software Documenta tion
	1654	"PKG",49,2 2,1,"PAH", 1,1,232,0)
	1655	Library at :
	1656	"PKG",49,2 2,1,"PAH", 1,1,233,0)
	1657	http:// URL /
	1658	"PKG",49,2 2,1,"PAH", 1,1,234,0)
	1659
	1660	"PKG",49,2 2,1,"PAH", 1,1,235,0)
	1661	Title File Name FTP Mod e
	1662	"PKG",49,2 2,1,"PAH", 1,1,236,0)
	1663	---------- ---------- ---------- ---------- ---------- ---------- ---------- -
	1664	"PKG",49,2 2,1,"PAH", 1,1,237,0)
	1665	Integrated Billing U ser Guide ib_2_0_um .doc Binar y
	1666	"PKG",49,2 2,1,"PAH", 1,1,238,0)
	1667	Integrated Billing T echnical M anual/Secu rity Guide ib_2_0_tm .doc Binar y
	1668	"PKG",49,2 2,1,"PAH", 1,1,239,0)
	1669	Integrated Billing D eployment, Installat ion,
	1670	"PKG",49,2 2,1,"PAH", 1,1,240,0)
	1671	Back- Out, and R ollback Gu ide
	1672	"PKG",49,2 2,1,"PAH", 1,1,241,0)
	1673	FY16Re venueIBVIP _Deploymen t_Installa tion_Guide .doc Binar y
	1674	"PKG",49,2 2,1,"PAH", 1,1,242,0)
	1675
	1676	"PKG",49,2 2,1,"PAH", 1,1,243,0)
	1677
	1678	"PKG",49,2 2,1,"PAH", 1,1,244,0)
	1679
	1680	"PKG",49,2 2,1,"PAH", 1,1,245,0)
	1681	Patch Inst allation:
	1682	"PKG",49,2 2,1,"PAH", 1,1,246,0)
	1683
	1684	"PKG",49,2 2,1,"PAH", 1,1,247,0)
	1685	Pre/Post I nstallatio n Overview :
	1686	"PKG",49,2 2,1,"PAH", 1,1,248,0)
	1687	---------- ---------- ---------- -
	1688	"PKG",49,2 2,1,"PAH", 1,1,249,0)
	1689	The post i nstallatio n routine, IBY568PO, is not au tomaticall y deleted
	1690	"PKG",49,2 2,1,"PAH", 1,1,250,0)
	1691	as part of the insta llation pr ocess. You may delet e it after
	1692	"PKG",49,2 2,1,"PAH", 1,1,251,0)
	1693	installati on if you desire.
	1694	"PKG",49,2 2,1,"PAH", 1,1,252,0)
	1695
	1696	"PKG",49,2 2,1,"PAH", 1,1,253,0)
	1697	Pre-Instal lation Ins tructions:
	1698	"PKG",49,2 2,1,"PAH", 1,1,254,0)
	1699	---------- ---------- ----------
	1700	"PKG",49,2 2,1,"PAH", 1,1,255,0)
	1701	N/A
	1702	"PKG",49,2 2,1,"PAH", 1,1,256,0)
	1703
	1704	"PKG",49,2 2,1,"PAH", 1,1,257,0)
	1705	Installati on Instruc tions:
	1706	"PKG",49,2 2,1,"PAH", 1,1,258,0)
	1707	---------- ---------- ------
	1708	"PKG",49,2 2,1,"PAH", 1,1,259,0)
	1709	This proce ss will in stall new and update d routines and other
	1710	"PKG",49,2 2,1,"PAH", 1,1,260,0)
	1711	components listed ab ove. There is a post -install r outine tha t will add
	1712	"PKG",49,2 2,1,"PAH", 1,1,261,0)
	1713	entries to a number of files.
	1714	"PKG",49,2 2,1,"PAH", 1,1,262,0)
	1715
	1716	"PKG",49,2 2,1,"PAH", 1,1,263,0)
	1717	The patch will be re leased in conjunctio n with an Accounts R eceivable
	1718	"PKG",49,2 2,1,"PAH", 1,1,264,0)
	1719	patch, PRC A4.5315 and an Out patient Ph armacy pat ch, PSO7. 0463.
	1720	"PKG",49,2 2,1,"PAH", 1,1,265,0)
	1721
	1722	"PKG",49,2 2,1,"PAH", 1,1,266,0)
	1723	****** ****** ** NOT E **** ****** ****
	1724	"PKG",49,2 2,1,"PAH", 1,1,267,0)
	1725	IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS
	1726	"PKG",49,2 2,1,"PAH", 1,1,268,0)
	1727	AN EDITE D ERROR WI LL OCCUR.
	1728	"PKG",49,2 2,1,"PAH", 1,1,269,0)
	1729	The patc h should b e installe d when NO Outpatient
	1730	"PKG",49,2 2,1,"PAH", 1,1,270,0)
	1731	Pharmacy users are on the sy stem.
	1732	"PKG",49,2 2,1,"PAH", 1,1,271,0)
	1733	****** ****** ****** ****** ****** ****
	1734	"PKG",49,2 2,1,"PAH", 1,1,272,0)
	1735
	1736	"PKG",49,2 2,1,"PAH", 1,1,273,0)
	1737	Installat ion will t ake less t han 1 minu te.
	1738	"PKG",49,2 2,1,"PAH", 1,1,274,0)
	1739
	1740	"PKG",49,2 2,1,"PAH", 1,1,275,0)
	1741	Suggested time to i nstall: no n-peak req uirement h ours.
	1742	"PKG",49,2 2,1,"PAH", 1,1,276,0)
	1743
	1744	"PKG",49,2 2,1,"PAH", 1,1,277,0)
	1745
	1746	"PKG",49,2 2,1,"PAH", 1,1,278,0)
	1747	1. Obtai n the file IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID.
	1748	"PKG",49,2 2,1,"PAH", 1,1,279,0)
	1749
	1750	"PKG",49,2 2,1,"PAH", 1,1,280,0)
	1751	2. From the Kernel Installat ion & Dist ribution S ystem menu , select
	1752	"PKG",49,2 2,1,"PAH", 1,1,281,0)
	1753	the I nstallatio n menu.
	1754	"PKG",49,2 2,1,"PAH", 1,1,282,0)
	1755
	1756	"PKG",49,2 2,1,"PAH", 1,1,283,0)
	1757	3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
	1758	"PKG",49,2 2,1,"PAH", 1,1,284,0)
	1759	promp ted to Ent er a Host File name. You may need to ap pend a
	1760	"PKG",49,2 2,1,"PAH", 1,1,285,0)
	1761	direc tory name.
	1762	"PKG",49,2 2,1,"PAH", 1,1,286,0)
	1763
	1764	"PKG",49,2 2,1,"PAH", 1,1,287,0)
	1765	4. From this menu, you may s elect to u se the fol lowing opt ions
	1766	"PKG",49,2 2,1,"PAH", 1,1,288,0)
	1767	(when prompted for INSTAL L NAME, en ter IB2.0 568):
	1768	"PKG",49,2 2,1,"PAH", 1,1,289,0)
	1769	a . Verify Checksums in Transpo rt Global - This opt ion will
	1770	"PKG",49,2 2,1,"PAH", 1,1,290,0)
	1771	allow y ou to ensu re the int egrity of the routin es that
	1772	"PKG",49,2 2,1,"PAH", 1,1,291,0)
	1773	are in the transp ort global .
	1774	"PKG",49,2 2,1,"PAH", 1,1,292,0)
	1775	b . Print T ransport G lobal - Th is option will allow you to
	1776	"PKG",49,2 2,1,"PAH", 1,1,293,0)
	1777	view th e componen ts of the KIDS build .
	1778	"PKG",49,2 2,1,"PAH", 1,1,294,0)
	1779	c . Compare Transport Global to Current S ystem - Th is option
	1780	"PKG",49,2 2,1,"PAH", 1,1,295,0)
	1781	will al low you to view all changes th at will be made when
	1782	"PKG",49,2 2,1,"PAH", 1,1,296,0)
	1783	this pa tch is ins talled. I t compares all compo nents of
	1784	"PKG",49,2 2,1,"PAH", 1,1,297,0)
	1785	this pa tch (routi nes, DD's, templates , etc.).
	1786	"PKG",49,2 2,1,"PAH", 1,1,298,0)
	1787	d . Backup a Transpor t Global - This opti on will cr eate a
	1788	"PKG",49,2 2,1,"PAH", 1,1,299,0)
	1789	backup message of any routi nes export ed with th is patch.
	1790	"PKG",49,2 2,1,"PAH", 1,1,300,0)
	1791	It will not backu p any othe r changes such as DD 's or
	1792	"PKG",49,2 2,1,"PAH", 1,1,301,0)
	1793	templat es.
	1794	"PKG",49,2 2,1,"PAH", 1,1,302,0)
	1795
	1796	"PKG",49,2 2,1,"PAH", 1,1,303,0)
	1797	5. When prompted " Want KIDS to INHIBIT LOGONs du ring the i nstall?
	1798	"PKG",49,2 2,1,"PAH", 1,1,304,0)
	1799	NO//" respond NO.
	1800	"PKG",49,2 2,1,"PAH", 1,1,305,0)
	1801
	1802	"PKG",49,2 2,1,"PAH", 1,1,306,0)
	1803	6. When prompted " Want to DI SABLE Sche duled Opti ons, Menu Options,
	1804	"PKG",49,2 2,1,"PAH", 1,1,307,0)
	1805	and P rotocols? NO//" resp ond NO.
	1806	"PKG",49,2 2,1,"PAH", 1,1,308,0)
	1807
	1808	"PKG",49,2 2,1,"PAH", 1,1,309,0)
	1809
	1810	"PKG",49,2 2,1,"PAH", 1,1,310,0)
	1811
	1812	"PKG",49,2 2,1,"PAH", 1,1,311,0)
	1813	Post-Insta llation In structions :
	1814	"PKG",49,2 2,1,"PAH", 1,1,312,0)
	1815	---------- ---------- ---------- -
	1816	"PKG",49,2 2,1,"PAH", 1,1,313,0)
	1817	There are no special tasks to perform af ter this p atch insta llation.
	1818	"QUES","XP F1",0)
	1819	Y
	1820	"QUES","XP F1","??")
	1821	^D REP^XPD H
	1822	"QUES","XP F1","A")
	1823	Shall I wr ite over y our \|FLAG\| File
	1824	"QUES","XP F1","B")
	1825	YES
	1826	"QUES","XP F1","M")
	1827	D XPF1^XPD IQ
	1828	"QUES","XP F2",0)
	1829	Y
	1830	"QUES","XP F2","??")
	1831	^D DTA^XPD H
	1832	"QUES","XP F2","A")
	1833	Want my da ta \|FLAG\| yours
	1834	"QUES","XP F2","B")
	1835	YES
	1836	"QUES","XP F2","M")
	1837	D XPF2^XPD IQ
	1838	"QUES","XP I1",0)
	1839	YO
	1840	"QUES","XP I1","??")
	1841	^D INHIBIT ^XPDH
	1842	"QUES","XP I1","A")
	1843	Want KIDS to INHIBIT LOGONs du ring the i nstall
	1844	"QUES","XP I1","B")
	1845	NO
	1846	"QUES","XP I1","M")
	1847	D XPI1^XPD IQ
	1848	"QUES","XP M1",0)
	1849	PO^VA(200, :EM
	1850	"QUES","XP M1","??")
	1851	^D MG^XPDH
	1852	"QUES","XP M1","A")
	1853	Enter the Coordinato r for Mail Group '\|F LAG\|'
	1854	"QUES","XP M1","B")
	1855
	1856	"QUES","XP M1","M")
	1857	D XPM1^XPD IQ
	1858	"QUES","XP O1",0)
	1859	Y
	1860	"QUES","XP O1","??")
	1861	^D MENU^XP DH
	1862	"QUES","XP O1","A")
	1863	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	1864	"QUES","XP O1","B")
	1865	NO
	1866	"QUES","XP O1","M")
	1867	D XPO1^XPD IQ
	1868	"QUES","XP Z1",0)
	1869	Y
	1870	"QUES","XP Z1","??")
	1871	^D OPT^XPD H
	1872	"QUES","XP Z1","A")
	1873	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	1874	"QUES","XP Z1","B")
	1875	NO
	1876	"QUES","XP Z1","M")
	1877	D XPZ1^XPD IQ
	1878	"QUES","XP Z2",0)
	1879	Y
	1880	"QUES","XP Z2","??")
	1881	^D RTN^XPD H
	1882	"QUES","XP Z2","A")
	1883	Want to MO VE routine s to other CPUs
	1884	"QUES","XP Z2","B")
	1885	NO
	1886	"QUES","XP Z2","M")
	1887	D XPZ2^XPD IQ
	1888	"RTN")
	1889	17
	1890	"RTN","IBC APP")
	1891	0^23^B2317 6501^B2148 5583
	1892	"RTN","IBC APP",1,0)
	1893	IBCAPP ;AL B/WCJ - Cl aims Auto Processing Main Proc esser;27-A UG-10
	1894	"RTN","IBC APP",2,0)
	1895	;;2.0;INT EGRATED BI LLING;*43 2,447,568 *;21-MAR-9 4;Build 38
	1896	"RTN","IBC APP",3,0)
	1897	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	1898	"RTN","IBC APP",4,0)
	1899	G AWAY
	1900	"RTN","IBC APP",5,0)
	1901	AWAY Q
	1902	"RTN","IBC APP",6,0)
	1903	;
	1904	"RTN","IBC APP",7,0)
	1905	EN(IBIFN,I BORIG,IBPY MT,IBWLF) ;
	1906	"RTN","IBC APP",8,0)
	1907	; This is called fr om tag BUL L^IBCNSBL2 . It is t he startin g point fo r the clai ms auto-pr ocessing.
	1908	"RTN","IBC APP",9,0)
	1909	; Instead of sendin g a bullet in which s tarted a m anual proc ess, the b ulletin ro utine call s this rou tine
	1910	"RTN","IBC APP",10,0)
	1911	; which w ill evalua te the cla im and per form one o f three ac tions.
	1912	"RTN","IBC APP",11,0)
	1913	; 1) auto -process t he claim t o a subseq uent payer .
	1914	"RTN","IBC APP",12,0)
	1915	; 2) auto -print a c laim in ca se the pay er does no t want to receive se condary/te rtiary cla ims electr onically
	1916	"RTN","IBC APP",13,0)
	1917	; 3) put the claim on the new COB Manag ement work list.
	1918	"RTN","IBC APP",14,0)
	1919	;
	1920	"RTN","IBC APP",15,0)
	1921	; Input : IBIFN -- Poin ter to AR (file #430 ), or Clai m (file #3 99) (same internal n umber goes to files)
	1922	"RTN","IBC APP",16,0)
	1923	; IBORIG -- Orig inal amoun t of the c laim
	1924	"RTN","IBC APP",17,0)
	1925	; IBPYMT -- Tota l Amount p aid on the claim
	1926	"RTN","IBC APP",18,0)
	1927	; IBWLF -- 1 or 2 if it s hould go s traight to the work list or
	1928	"RTN","IBC APP",19,0)
	1929	; 0 if it should be evalua ted.
	1930	"RTN","IBC APP",20,0)
	1931	;
	1932	"RTN","IBC APP",21,0)
	1933	N IBREASO N,IBX,IBMR ANOT,IBERR MSG,IBEOB, IBINS,Z,IB ,IBF,IBFT, IBNCN,IBDV ,IBREG,IBN CN
	1934	"RTN","IBC APP",22,0)
	1935	S IBMRANO T=1
	1936	"RTN","IBC APP",23,0)
	1937	;
	1938	"RTN","IBC APP",24,0)
	1939	; A speci fic non-hu man user f or all reg 835 EOB f iling proc esses.
	1940	"RTN","IBC APP",25,0)
	1941	; Change the DUZ to be this u ser.
	1942	"RTN","IBC APP",26,0)
	1943	; * Int egration A greement 4 129 - Acti vated on 3 0-June-200 3 *
	1944	"RTN","IBC APP",27,0)
	1945	S IBREG=$ $IBREG()
	1946	"RTN","IBC APP",28,0)
	1947	I IBREG>0 NEW DUZ D DUZ^XUP(I BREG) ; I A#4129
	1948	"RTN","IBC APP",29,0)
	1949	;
	1950	"RTN","IBC APP",30,0)
	1951	; Check i f this is being forc ed to the work list.
	1952	"RTN","IBC APP",31,0)
	1953	;I $G(IBW LF) S IBRE ASON="IB81 3:CHAMPVA Center or TRICARE Fi scal Inter mediary or TRICARE S upplementa l policy." D PUTONWL (IBIFN,IBR EASON) G E NX ;IB2 432
	1954	"RTN","IBC APP",32,0)
	1955	I $G(IBWL F) D G EN X ;IB2 568
	1956	"RTN","IBC APP",33,0)
	1957	.I IBWLF= 2 S IBREAS ON="IB815: Balance bi ll this pa tient usin g the appr opriate co st-based r ate type." D PUTONWL (IBIFN,IBR EASON) Q
	1958	"RTN","IBC APP",34,0)
	1959	.I IBWLF= 1 S IBREAS ON="IB813: CHAMPVA Ce nter or TR ICARE Fisc al Interme diary or T RICARE Sup plemental policy." D PUTONWL(I BIFN,IBREA SON) Q
	1960	"RTN","IBC APP",35,0)
	1961	.Q
	1962	"RTN","IBC APP",36,0)
	1963	;
	1964	"RTN","IBC APP",37,0)
	1965	I IBPYMT' <IBORIG D WLCK^IBCNS BL2(IBIFN) Q ; no r eason to c ontinue if nothing e lse owed
	1966	"RTN","IBC APP",38,0)
	1967	;
	1968	"RTN","IBC APP",39,0)
	1969	; Make su re there i s another payer
	1970	"RTN","IBC APP",40,0)
	1971	I '$P($G( ^DGCR(399, IBIFN,"I"_ ($$COBN^IB CEF(IBIFN) +1))),U,1) D WLCK^IB CNSBL2(IBI FN) G ENX ;IB243 2
	1972	"RTN","IBC APP",41,0)
	1973	;
	1974	"RTN","IBC APP",42,0)
	1975	; stop if the subse quent clai m was alre ady create d
	1976	"RTN","IBC APP",43,0)
	1977	I +$P($G( ^DGCR(399, IBIFN,"M1" )),U,$$COB N^IBCEF(IB IFN)+5) D WLCK^IBCNS BL2(IBIFN) G ENX ;IB 2432
	1978	"RTN","IBC APP",44,0)
	1979	;
	1980	"RTN","IBC APP",45,0)
	1981	; stop if the subse quent paye r is Medic are. If t here is a non-Medica re tertiar y payer, f orce to wo rklist
	1982	"RTN","IBC APP",46,0)
	1983	I $$WNRBI LL^IBEFUNC (IBIFN,$$C OBN^IBCEF( IBIFN)+1) D Q
	1984	"RTN","IBC APP",47,0)
	1985	.I $D(^DG CR(399,IBI FN,"I3")), '$$WNRBILL ^IBEFUNC(I BIFN,3) D PUTONWL(IB IFN,"IB814 ") Q
	1986	"RTN","IBC APP",48,0)
	1987	.D WLCK^I BCNSBL2(IB IFN) Q
	1988	"RTN","IBC APP",49,0)
	1989	;
	1990	"RTN","IBC APP",50,0)
	1991	; check t he Commerc ial Auto P rocessing criteria
	1992	"RTN","IBC APP",51,0)
	1993	S IBX=$$C RIT^IBCAPP 1(IBIFN,.I BEOB)
	1994	"RTN","IBC APP",52,0)
	1995	;
	1996	"RTN","IBC APP",53,0)
	1997	; If it f ails the c riteria ch eck, put i t on the w ork list
	1998	"RTN","IBC APP",54,0)
	1999	I '+IBX D PUTONWL(I BIFN,$P(IB X,U,2)) G ENX ;IB* 2*432
	2000	"RTN","IBC APP",55,0)
	2001	;
	2002	"RTN","IBC APP",56,0)
	2003	; Auto Pr ocess this bad boy
	2004	"RTN","IBC APP",57,0)
	2005	;
	2006	"RTN","IBC APP",58,0)
	2007	; first c heck that if it's su pposed to be printed locally, the printe rs are def ined.
	2008	"RTN","IBC APP",59,0)
	2009	; if not, put on th e work lis t
	2010	"RTN","IBC APP",60,0)
	2011	; if they are, then fall thro ugh
	2012	"RTN","IBC APP",61,0)
	2013	S Z=$$COB N^IBCEF(IB IFN)+1
	2014	"RTN","IBC APP",62,0)
	2015	S IBINS=$ $POLICY^IB CEF(IBIFN, 1,Z)
	2016	"RTN","IBC APP",63,0)
	2017	S IBWLF=0
	2018	"RTN","IBC APP",64,0)
	2019	I $P($G(^ DIC(36,IBI NS,6)),U,9 )=1 D I I BWLF D PUT ONWL(IBIFN ,IBREASON) G ENX ; IB2432
	2020	"RTN","IBC APP",65,0)
	2021	.I $$EOBP RT^IBCAPR( )="" S IBW LF=1,IBREA SON="IB811 :Auto-prin ter not de fined in I B Site Par ameters" Q
	2022	"RTN","IBC APP",66,0)
	2023	.I $$MRAP RT^IBCAPR( )="" S IBW LF=1,IBREA SON="IB811 :Auto-prin ter not de fined in I B Site Par ameters" Q
	2024	"RTN","IBC APP",67,0)
	2025	.S IB=$$F T^IBCU3(IB IFN) ; for m type ien (2 or 3)
	2026	"RTN","IBC APP",68,0)
	2027	.I "^2^3^ "'[(U_IB_U ) S IBWLF= 1,IBREASON ="IB810:No Form Type defined" Q
	2028	"RTN","IBC APP",69,0)
	2029	.S IBFT=$ $FTN^IBCU3 (IB) ; for m type nam e
	2030	"RTN","IBC APP",70,0)
	2031	.S IBF=$P ($G(^IBE(3 53,+IB,2)) ,U,8)
	2032	"RTN","IBC APP",71,0)
	2033	.S:IBF="" IBF=IB ;F orces the use of the output fo rmatter to print bil ls
	2034	"RTN","IBC APP",72,0)
	2035	.; get de fault CMS or UB prin ter (based on claim form type)
	2036	"RTN","IBC APP",73,0)
	2037	.S IBDV=$ S(IB=2:$$C MS1500^IBC APR1(),1:$ $UB4PRT^IB CAPR1())
	2038	"RTN","IBC APP",74,0)
	2039	.I IBDV=" " S IBWLF= 1,IBREASON ="IB811:Au to-printer not defin ed in IB S ite Parame ters" Q
	2040	"RTN","IBC APP",75,0)
	2041	I $G(IBRE ASON)]"" D PUTONWL(I BIFN,IBREA SON) G ENX ;IB24 32
	2042	"RTN","IBC APP",76,0)
	2043	;
	2044	"RTN","IBC APP",77,0)
	2045	; create the new cl aim
	2046	"RTN","IBC APP",78,0)
	2047	S IBNCN=" " ; Init ialize New Claim Num ber
	2048	"RTN","IBC APP",79,0)
	2049	D AUTOCOB ^IBCEMQA(I BIFN,IBEOB ,.IBERRMSG ,IBMRANOT, .IBNCN)
	2050	"RTN","IBC APP",80,0)
	2051	;
	2052	"RTN","IBC APP",81,0)
	2053	; make su re everyth ing was co ol with cr eating the new claim .
	2054	"RTN","IBC APP",82,0)
	2055	I $G(IBER RMSG)]""!( '+$G(IBNCN )) S IBREA SON="IB812 :Failed AU TOCOB Gene ration" D PUTONWL(IB IFN,IBREAS ON) G ENX ;IB243 2
	2056	"RTN","IBC APP",83,0)
	2057	;
	2058	"RTN","IBC APP",84,0)
	2059	; If it's to be aut o printed, set force to local print flag on new cl aim
	2060	"RTN","IBC APP",85,0)
	2061	S IBINS=$ $POLICY^IB CEF(IBNCN, 1,$$COBN^I BCEF(IBNCN ))
	2062	"RTN","IBC APP",86,0)
	2063	; set fie ld 35 on o riginal cl aim to ind icate subs equent cla im was aut o-created IB2.0447
	2064	"RTN","IBC APP",87,0)
	2065	I $P($G(^ DIC(36,IBI NS,6)),U,9 )=1 D FORC EPRT(IBNCN ),AUTOPRC( $G(IBIFN), 2)
	2066	"RTN","IBC APP",88,0)
	2067	D:$P($G(^ DIC(36,IBI NS,6)),U,9 )'=1 AUTOP RC($G(IBIF N),3)
	2068	"RTN","IBC APP",89,0)
	2069	;
	2070	"RTN","IBC APP",90,0)
	2071	; authori ze the new claim
	2072	"RTN","IBC APP",91,0)
	2073	D AUTH^IB CEMQA(IBNC N,.IBERRMS G,IBMRANOT )
	2074	"RTN","IBC APP",92,0)
	2075	;
	2076	"RTN","IBC APP",93,0)
	2077	; If AUTH error occ urred, fil e the auto matic bill generatio n failure message
	2078	"RTN","IBC APP",94,0)
	2079	I $G(IBER RMSG)]"" D AUTOMSG^I BCESRV3(IB EOB,IBERRM SG) G ENX
	2080	"RTN","IBC APP",95,0)
	2081	;
	2082	"RTN","IBC APP",96,0)
	2083	; If loca l print, t hen print it
	2084	"RTN","IBC APP",97,0)
	2085	I $P($G(^ DIC(36,IBI NS,6)),U,9 )=1 D STFL P^IBCAPR1( IBNCN)
	2086	"RTN","IBC APP",98,0)
	2087	;
	2088	"RTN","IBC APP",99,0)
	2089	ENX ;Qui t and Clea nup of Mai n Entry Po int, added with IB2 432
	2090	"RTN","IBC APP",100,0 )
	2091	;
	2092	"RTN","IBC APP",101,0 )
	2093	; DBIA #1 0111: Allo ws FM read access of ^XMB(3.8, D0,0) usin g DIC.
	2094	"RTN","IBC APP",102,0 )
	2095	S DIC="^X MB(3.8,",D IC(0)="QM" ,X="IB DEV TEAM" D ^ DIC
	2096	"RTN","IBC APP",103,0 )
	2097	;
	2098	"RTN","IBC APP",104,0 )
	2099	Q
	2100	"RTN","IBC APP",105,0 )
	2101	;
	2102	"RTN","IBC APP",106,0 )
	2103	PUTONWL(IB IFN,IBREAS ON) ; Put a claim on the workl ist
	2104	"RTN","IBC APP",107,0 )
	2105	; IBIFN - internal claim numb er
	2106	"RTN","IBC APP",108,0 )
	2107	; IBREASO N - reason why this is being p ut on the worklist ( error code :text)
	2108	"RTN","IBC APP",109,0 )
	2109	;
	2110	"RTN","IBC APP",110,0 )
	2111	N DA,DIE, DR
	2112	"RTN","IBC APP",111,0 )
	2113	S DA=IBIF N
	2114	"RTN","IBC APP",112,0 )
	2115	S DIE="^D GCR(399,"
	2116	"RTN","IBC APP",113,0 )
	2117	S DR="35/ //1" ; place on t he worklis t
	2118	"RTN","IBC APP",114,0 )
	2119	S DR=DR_" ;"_"36///" _$P(IBREAS ON,":") ; why placed on worklist
	2120	"RTN","IBC APP",115,0 )
	2121	D ^DIE
	2122	"RTN","IBC APP",116,0 )
	2123	Q
	2124	"RTN","IBC APP",117,0 )
	2125	;
	2126	"RTN","IBC APP",118,0 )
	2127	AUTOPRC(IB IFN,IBAP) ; record t hat a clai m was auto -processed IB2.044 7
	2128	"RTN","IBC APP",119,0 )
	2129	; IBIFN - internal claim numb er
	2130	"RTN","IBC APP",120,0 )
	2131	; IBAP - 2 = AUTO L OCAL PRINT , 3 = AUTO EDI
	2132	"RTN","IBC APP",121,0 )
	2133	;
	2134	"RTN","IBC APP",122,0 )
	2135	N DA,DIE, DR
	2136	"RTN","IBC APP",123,0 )
	2137	Q:IBIFN=" "
	2138	"RTN","IBC APP",124,0 )
	2139	Q:IBAP=""
	2140	"RTN","IBC APP",125,0 )
	2141	S DA=IBIF N
	2142	"RTN","IBC APP",126,0 )
	2143	S DIE="^D GCR(399,"
	2144	"RTN","IBC APP",127,0 )
	2145	S DR="35/ //"_IBAP ; UPDATE AUTO-PROC ESS FIELD
	2146	"RTN","IBC APP",128,0 )
	2147	D ^DIE
	2148	"RTN","IBC APP",129,0 )
	2149	Q
	2150	"RTN","IBC APP",130,0 )
	2151	;
	2152	"RTN","IBC APP",131,0 )
	2153	FORCEPRT(I BIFN) ; se t force to local pri nt flag in claim
	2154	"RTN","IBC APP",132,0 )
	2155	; IBIFN - internal claim numb er
	2156	"RTN","IBC APP",133,0 )
	2157	;
	2158	"RTN","IBC APP",134,0 )
	2159	N DA,DIE, DR
	2160	"RTN","IBC APP",135,0 )
	2161	S DA=IBIF N
	2162	"RTN","IBC APP",136,0 )
	2163	S DIE="^D GCR(399,"
	2164	"RTN","IBC APP",137,0 )
	2165	S DR="27/ //1" ; Force Lo cal Print
	2166	"RTN","IBC APP",138,0 )
	2167	D ^DIE
	2168	"RTN","IBC APP",139,0 )
	2169	Q
	2170	"RTN","IBC APP",140,0 )
	2171	;
	2172	"RTN","IBC APP",141,0 )
	2173	IBREG() ; Returns IE N (Interna l Entry Nu mber) from file #200 for
	2174	"RTN","IBC APP",142,0 )
	2175	; the Bil l Authoriz er of acce ptable reg ular (non MRA) secon dary claim s,
	2176	"RTN","IBC APP",143,0 )
	2177	; namely, AUTHORIZE R,IB REG
	2178	"RTN","IBC APP",144,0 )
	2179	;
	2180	"RTN","IBC APP",145,0 )
	2181	; Output: -1 i f record n ot on file
	2182	"RTN","IBC APP",146,0 )
	2183	; IEN i f record i s on file
	2184	"RTN","IBC APP",147,0 )
	2185	;
	2186	"RTN","IBC APP",148,0 )
	2187	N DIC,X,Y
	2188	"RTN","IBC APP",149,0 )
	2189	S DIC(0)= "MO",DIC=" ^VA(200,", X="AUTHORI ZER,IB REG "
	2190	"RTN","IBC APP",150,0 )
	2191	; call FM lookup ut ility
	2192	"RTN","IBC APP",151,0 )
	2193	D ^DIC
	2194	"RTN","IBC APP",152,0 )
	2195	; if reco rd is alre ady on fil e, return IEN
	2196	"RTN","IBC APP",153,0 )
	2197	; else r eturn -1
	2198	"RTN","IBC APP",154,0 )
	2199	Q +Y
	2200	"RTN","IBC BB11")
	2201	0^6^B12524 8678^B1120 52327
	2202	"RTN","IBC BB11",1,0)
	2203	IBCBB11 ;A LB/AAS/OIF O-BP/PIJ - CONTINUAT ION OF EDI T CHECK RO UTINE ;12 Jun 2006 3:45 PM
	2204	"RTN","IBC BB11",2,0)
	2205	;;2.0;INT EGRATED BI LLING;51 ,343,363,3 71,395,392 ,401,384,4 00,436,432 ,516,550,5 77,568;2 1-MAR-94;B uild 38
	2206	"RTN","IBC BB11",3,0)
	2207	;Per VA D irective 6 402, this routine sh ould not b e modified .
	2208	"RTN","IBC BB11",4,0)
	2209	;
	2210	"RTN","IBC BB11",5,0)
	2211	WARN(IBDIS P) ; Set w arning in global
	2212	"RTN","IBC BB11",6,0)
	2213	; DISP = warning te xt to disp lay
	2214	"RTN","IBC BB11",7,0)
	2215	;
	2216	"RTN","IBC BB11",8,0)
	2217	N Z
	2218	"RTN","IBC BB11",9,0)
	2219	S Z=+$O(^ TMP($J,"BI LL-WARN"," "),-1)
	2220	"RTN","IBC BB11",10,0 )
	2221	I Z=0 S ^ TMP($J,"BI LL-WARN",1 )=$J("",5) _"Warnin gs:",Z=1
	2222	"RTN","IBC BB11",11,0 )
	2223	S Z=Z+1,^ TMP($J,"BI LL-WARN",Z )=$J("",5) _IBDISP
	2224	"RTN","IBC BB11",12,0 )
	2225	Q
	2226	"RTN","IBC BB11",13,0 )
	2227	;
	2228	"RTN","IBC BB11",14,0 )
	2229	MULTDIV(IB IFN,IBND0) ; Check f or multipl e division s on a bil l ien IBIF N
	2230	"RTN","IBC BB11",15,0 )
	2231	; IBND0 = 0-node of bill
	2232	"RTN","IBC BB11",16,0 )
	2233	;
	2234	"RTN","IBC BB11",17,0 )
	2235	; Functi on returns 1 if more than 1 di vision fou nd on bill
	2236	"RTN","IBC BB11",18,0 )
	2237	N Z,Z0,Z1 ,MULT
	2238	"RTN","IBC BB11",19,0 )
	2239	S MULT=0, Z1=$P(IBND 0,U,22)
	2240	"RTN","IBC BB11",20,0 )
	2241	I Z1 D
	2242	"RTN","IBC BB11",21,0 )
	2243	. S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"RC", Z)) Q:'Z S Z0=$P(^( Z,0),U,7) I Z0,Z0'=Z 1 S MULT=1 Q
	2244	"RTN","IBC BB11",22,0 )
	2245	. S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"CP", Z)) Q:'Z S Z0=$P(^( Z,0),U,6) I Z0,Z0'=Z 1 S MULT=2 Q
	2246	"RTN","IBC BB11",23,0 )
	2247	I 'Z1 S M ULT=3
	2248	"RTN","IBC BB11",24,0 )
	2249	Q MULT
	2250	"RTN","IBC BB11",25,0 )
	2251	;
	2252	"RTN","IBC BB11",26,0 )
	2253	;; PREGNA NCY DX COD ES: V22- V24, V27 -V28, 630*-677 *
	2254	"RTN","IBC BB11",27,0 )
	2255	;; FLU SH OTS PROCED URE CODES: 90724, G0 008, 90732 , G0009
	2256	"RTN","IBC BB11",28,0 )
	2257	;
	2258	"RTN","IBC BB11",29,0 )
	2259	NPICHK ; C heck for r equired NP Is
	2260	"RTN","IBC BB11",30,0 )
	2261	N IBNPIS, IBNONPI,IB NPIREQ,Z,I BNFI,IBTF, IBWC,IBXSA VE,IBPRV,I BLINE,IBPR VNT1,IBPRV NT2
	2262	"RTN","IBC BB11",31,0 )
	2263	;*** pij start IB2 0436 ***
	2264	"RTN","IBC BB11",32,0 )
	2265	N IBRATYP E,IBLEGAL
	2266	"RTN","IBC BB11",33,0 )
	2267	S (IBRATY PE,IBLEGAL )=""
	2268	"RTN","IBC BB11",34,0 )
	2269	S IBRATYP E=$P($G(^D GCR(399,IB IFN,0)),U, 7)
	2270	"RTN","IBC BB11",35,0 )
	2271	; Legal t ypes for t his use.
	2272	"RTN","IBC BB11",36,0 )
	2273	; 7=NO F AULT INS.
	2274	"RTN","IBC BB11",37,0 )
	2275	; 10=TORT FEASOR
	2276	"RTN","IBC BB11",38,0 )
	2277	; 11=WORK ERS' COMP.
	2278	"RTN","IBC BB11",39,0 )
	2279	S IBNFI=$ O(^DGCR(39 9.3,"B","N O FAULT IN S.",0)) S: 'IBNFI IBN FI=7
	2280	"RTN","IBC BB11",40,0 )
	2281	S IBTF=$O (^DGCR(399 .3,"B","TO RT FEASOR" ,0)) S:'IB TF IBTF=10
	2282	"RTN","IBC BB11",41,0 )
	2283	S IBWC=$O (^DGCR(399 .3,"B","WO RKERS' COM P.",0)) S: 'IBWC IBWC =11
	2284	"RTN","IBC BB11",42,0 )
	2285	;
	2286	"RTN","IBC BB11",43,0 )
	2287	I IBRATYP E=IBNFI!(I BRATYPE=IB TF)!(IBRAT YPE=IBWC) D
	2288	"RTN","IBC BB11",44,0 )
	2289	. ; One o f the lega l types - force loca l print
	2290	"RTN","IBC BB11",45,0 )
	2291	. S IBLEG AL=1
	2292	"RTN","IBC BB11",46,0 )
	2293	;* pij end *
	2294	"RTN","IBC BB11",47,0 )
	2295	S IBNPIRE Q=$$NPIREQ ^IBCEP81(D T) ; Chec k if NPI i s required
	2296	"RTN","IBC BB11",48,0 )
	2297	; Check p roviders
	2298	"RTN","IBC BB11",49,0 )
	2299	; IB2.0 432 change d the NPI check to t he new Pro vider Arra y
	2300	"RTN","IBC BB11",50,0 )
	2301	;S IBNPIS =$$PROVNPI ^IBCEF73A( IBIFN,.IBN ONPI)
	2302	"RTN","IBC BB11",51,0 )
	2303	D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1)
	2304	"RTN","IBC BB11",52,0 )
	2305	S IBPRV=" "
	2306	"RTN","IBC BB11",53,0 )
	2307	F S IBPR V=$O(IBXSA VE("PROVIN F",IBIFN," C",1,IBPRV )) Q:'IBPR V D
	2308	"RTN","IBC BB11",54,0 )
	2309	. I $P($G (IBXSAVE(" PROVINF",I BIFN,"C",1 ,IBPRV,0)) ,U,4)="" S IBNONPI(I BPRV)=""
	2310	"RTN","IBC BB11",55,0 )
	2311	S IBLINE= ""
	2312	"RTN","IBC BB11",56,0 )
	2313	F S IBLI NE=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE)) Q: 'IBLINE D
	2314	"RTN","IBC BB11",57,0 )
	2315	. S IBPRV =""
	2316	"RTN","IBC BB11",58,0 )
	2317	. F S IB PRV=$O(IBX SAVE("L-PR OV",IBIFN, IBLINE,"C" ,1,IBPRV)) Q:IBPRV=" " D
	2318	"RTN","IBC BB11",59,0 )
	2319	.. I $P($ G(IBXSAVE( "L-PROV",I BIFN,IBLIN E,"C",1,IB PRV,0)),U, 4)="" S IB NONPI(IBPR V)=""
	2320	"RTN","IBC BB11",60,0 )
	2321	I $D(IBNO NPI) S IBP RV="" F S IBPRV=$O( IBNONPI(IB PRV)) Q:'I BPRV D
	2322	"RTN","IBC BB11",61,0 )
	2323	. S IBER= IBER_"IB"_ (140+IBPRV )_";" Q ; If requir ed, set er ror IB25 16
	2324	"RTN","IBC BB11",62,0 )
	2325	; Check o rganizatio ns
	2326	"RTN","IBC BB11",63,0 )
	2327	S IBNONPI =""
	2328	"RTN","IBC BB11",64,0 )
	2329	S IBNPIS= $$ORGNPI^I BCEF73A(IB IFN,.IBNON PI)
	2330	"RTN","IBC BB11",65,0 )
	2331	I $L(IBNO NPI) F Z=1 :1:$L(IBNO NPI,U) D
	2332	"RTN","IBC BB11",66,0 )
	2333	. S IBER= IBER_$P("I B339;^IB34 0;^IB341;" ,U,$P(IBNO NPI,U,Z)) ; DEM;432 Added NPI errors.
	2334	"RTN","IBC BB11",67,0 )
	2335	Q
	2336	"RTN","IBC BB11",68,0 )
	2337	;
	2338	"RTN","IBC BB11",69,0 )
	2339	TAXCHK ; C heck for r equired ta xonomies
	2340	"RTN","IBC BB11",70,0 )
	2341	N IBDT,IB LINE,IBNOT AX,IBNOTAX 1,IBNOTAX2 ,IBPRV,IBT AXS,IBXSAV E,Z
	2342	"RTN","IBC BB11",71,0 )
	2343	;
	2344	"RTN","IBC BB11",72,0 )
	2345	; MRD;IB* 2.0*516 - This check is now mo ot; 'today ' is alway s on or
	2346	"RTN","IBC BB11",73,0 )
	2347	; after M ay 23, 200 8, so taxo nomy codes are alway s required
	2348	"RTN","IBC BB11",74,0 )
	2349	; for cer tain provi ders.
	2350	"RTN","IBC BB11",75,0 )
	2351	;S IBTAXR EQ=$$TAXRE Q^IBCEP81( DT) ; Che ck if taxo nomy is re quired
	2352	"RTN","IBC BB11",76,0 )
	2353	;
	2354	"RTN","IBC BB11",77,0 )
	2355	; Check p roviders
	2356	"RTN","IBC BB11",78,0 )
	2357	; IB2.0 432 change d the Taxo nomy check to the ne w Provider Array
	2358	"RTN","IBC BB11",79,0 )
	2359	;S IBTAXS =$$PROVTAX ^IBCEF73A( IBIFN,.IBN OTAX)
	2360	"RTN","IBC BB11",80,0 )
	2361	D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1)
	2362	"RTN","IBC BB11",81,0 )
	2363	S IBPRV=" "
	2364	"RTN","IBC BB11",82,0 )
	2365	F S IBPR V=$O(IBXSA VE("PROVIN F",IBIFN," C",1,IBPRV )) Q:'IBPR V D
	2366	"RTN","IBC BB11",83,0 )
	2367	. I $G(IB XSAVE("PRO VINF",IBIF N,"C",1,IB PRV,"TAXON OMY"))="" D
	2368	"RTN","IBC BB11",84,0 )
	2369	.. S IBNO TAX(IBPRV) =""
	2370	"RTN","IBC BB11",85,0 )
	2371	.. S IBNO TAX1=$P(IB XSAVE("PRO VINF",IBIF N,"C",1,IB PRV),";",1 ) ; New v ariables I BNOTAX1 an d IBNOTAX2 for IB2. 0568 - De activated Provider
	2372	"RTN","IBC BB11",86,0 )
	2373	.. S IBNO TAX2(IBPRV ,IBNOTAX1) =""
	2374	"RTN","IBC BB11",87,0 )
	2375	.. Q
	2376	"RTN","IBC BB11",88,0 )
	2377	. Q
	2378	"RTN","IBC BB11",89,0 )
	2379	;
	2380	"RTN","IBC BB11",90,0 )
	2381	S IBLINE= ""
	2382	"RTN","IBC BB11",91,0 )
	2383	F S IBLI NE=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE)) Q: 'IBLINE D
	2384	"RTN","IBC BB11",92,0 )
	2385	. S IBPRV =""
	2386	"RTN","IBC BB11",93,0 )
	2387	. F S IB PRV=$O(IBX SAVE("L-PR OV",IBIFN, IBLINE,"C" ,1,IBPRV)) Q:IBPRV=" " D
	2388	"RTN","IBC BB11",94,0 )
	2389	.. I $G(I BXSAVE("L- PROV",IBIF N,IBLINE," C",1,IBPRV ,"TAXONOMY "))="" D
	2390	"RTN","IBC BB11",95,0 )
	2391	... S IBN OTAX(IBPRV )=""
	2392	"RTN","IBC BB11",96,0 )
	2393	... S IBN OTAX1=$P(I BXSAVE("L- PROV",IBIF N,IBLINE," C",1,IBPRV ),";",1) ; New vari ables IBNO TAX1 and I BNOTAX2 fo r IB2.05 68 - Deact ivated Pro vider
	2394	"RTN","IBC BB11",97,0 )
	2395	... S IBN OTAX2(IBPR V,IBNOTAX1 )=""
	2396	"RTN","IBC BB11",98,0 )
	2397	... Q
	2398	"RTN","IBC BB11",99,0 )
	2399	.. Q
	2400	"RTN","IBC BB11",100, 0)
	2401	. Q
	2402	"RTN","IBC BB11",101, 0)
	2403	;
	2404	"RTN","IBC BB11",102, 0)
	2405	; IB251 = Referring provider taxonomy m issing.
	2406	"RTN","IBC BB11",103, 0)
	2407	; IB253 = Rendering provider taxonomy m issing.
	2408	"RTN","IBC BB11",104, 0)
	2409	; IB254 = Attending provider taxonomy m issing.
	2410	"RTN","IBC BB11",105, 0)
	2411	;
	2412	"RTN","IBC BB11",106, 0)
	2413	I $D(IBNO TAX) S IBP RV="" F S IBPRV=$O( IBNOTAX(IB PRV)) Q:'I BPRV D
	2414	"RTN","IBC BB11",107, 0)
	2415	. ; Only Referring, Rendering and Atten ding are c urrently s ent to the payer
	2416	"RTN","IBC BB11",108, 0)
	2417	. ;I IBTA XREQ,"134" [IBPRV S I BER=IBER_" IB"_(250+I BPRV)_";" Q ; MRD;I B2.0516 - Always r equired.
	2418	"RTN","IBC BB11",109, 0)
	2419	. I "134" [IBPRV D Q
	2420	"RTN","IBC BB11",110, 0)
	2421	.. S IBER =IBER_"IB" _(250+IBPR V)_";" ; I f required , set erro r
	2422	"RTN","IBC BB11",111, 0)
	2423	.. S IBPR VNT1=$O(IB NOTAX2(IBP RV,"")) ; New check for Deacti vated Prov ider IB2. 0568 next three lin es
	2424	"RTN","IBC BB11",112, 0)
	2425	.. S IBPR VNT2=$$SPE C^IBCEU(IB PRVNT1,IBE VDT)
	2426	"RTN","IBC BB11",113, 0)
	2427	.. I '$G( IBPRVNT2) D WARN($P( "Referring ^Operating ^Rendering ^Attending ^Supervisi ng^^^^Othe r",U,IBPRV )_" Provid er PERSON CLASS/taxo nomy was n ot active at DOS.") ; set war ning
	2428	"RTN","IBC BB11",114, 0)
	2429	. D WARN( "Taxonomy for the "_ $P("referr ing^operat ing^render ing^attend ing^superv ising^^^^o ther",U,IB PRV)_" pro vider has no value") ; Else, set warnin g
	2430	"RTN","IBC BB11",115, 0)
	2431	. Q
	2432	"RTN","IBC BB11",116, 0)
	2433	;
	2434	"RTN","IBC BB11",117, 0)
	2435	; Check o rganizatio ns. The f unction OR GTAX will set IBNOTA X to be a
	2436	"RTN","IBC BB11",118, 0)
	2437	; list of entities missing ta xonomy cod es, if any (n, n^m, n^m^p,
	2438	"RTN","IBC BB11",119, 0)
	2439	; where e ach 1 is s ervice fac ility, 2 i s non-VA s ervice fac ility and
	2440	"RTN","IBC BB11",120, 0)
	2441	; 3 is bi lling prov ider.
	2442	"RTN","IBC BB11",121, 0)
	2443	;
	2444	"RTN","IBC BB11",122, 0)
	2445	S IBNOTAX =""
	2446	"RTN","IBC BB11",123, 0)
	2447	S IBTAXS= $$ORGTAX^I BCEF73A(IB IFN,.IBNOT AX)
	2448	"RTN","IBC BB11",124, 0)
	2449	I $L(IBNO TAX) F Z=1 :1:$L(IBNO TAX,U) D
	2450	"RTN","IBC BB11",125, 0)
	2451	. ; IB167 = Billing Provider taxonomy m issing.
	2452	"RTN","IBC BB11",126, 0)
	2453	. ;I IBTA XREQ,$P(IB NOTAX,U,Z) =3 S IBER= IBER_"IB16 7;" Q ; M RD;IB2.0 516 - Alwa ys require d.
	2454	"RTN","IBC BB11",127, 0)
	2455	. I $P(IB NOTAX,U,Z) =3 S IBER= IBER_"IB16 7;" Q
	2456	"RTN","IBC BB11",128, 0)
	2457	. ; MRD;I B2.0516 - Remove w arning mes sage for m issing tax onomy code for lab o r facility .
	2458	"RTN","IBC BB11",129, 0)
	2459	. ; D WAR N("Taxonom y for the "_$P("Serv ice Facili ty^Non-VA Service Fa cility^Bil ling Provi der",U,$P( IBNOTAX,U, Z))_" has no value") ; Else, set warnin g
	2460	"RTN","IBC BB11",130, 0)
	2461	. Q
	2462	"RTN","IBC BB11",131, 0)
	2463	;
	2464	"RTN","IBC BB11",132, 0)
	2465	Q
	2466	"RTN","IBC BB11",133, 0)
	2467	;
	2468	"RTN","IBC BB11",134, 0)
	2469	VALNDC(IBI FN,IBDFN) ; IB2363 - validat e NDC# bet ween PRESC RIPTION fi le (#52)
	2470	"RTN","IBC BB11",135, 0)
	2471	; and IB BILL/CLAIM S PRESCRIP TION REFIL L file (#3 62.4)
	2472	"RTN","IBC BB11",136, 0)
	2473	; input - IBIFN = i nternal en try number of the bi lling reco rd in the BILL/CLAIM S file (#3 99)
	2474	"RTN","IBC BB11",137, 0)
	2475	; IBDFN = i nternal en try number of patien t record i n the PATI ENT file ( #2)
	2476	"RTN","IBC BB11",138, 0)
	2477	N IBX,IBR XCOL
	2478	"RTN","IBC BB11",139, 0)
	2479	; call pr ogram that determine s if NDC d ifferences exist
	2480	"RTN","IBC BB11",140, 0)
	2481	D VALNDC^ IBEFUNC3(I BIFN,IBDFN ,.IBRXCOL)
	2482	"RTN","IBC BB11",141, 0)
	2483	Q:'$D(IBR XCOL)
	2484	"RTN","IBC BB11",142, 0)
	2485	; at leas t one RX o n the IB r ecord has an NDC dis crepancy
	2486	"RTN","IBC BB11",143, 0)
	2487	S IBX=0 F S IBX=$O (IBRXCOL(I BX)) Q:'IB X D WARN( "NDC# on B ill does n ot equal t he NDC# on Rx "_IBRX COL(IBX))
	2488	"RTN","IBC BB11",144, 0)
	2489	Q
	2490	"RTN","IBC BB11",145, 0)
	2491	;
	2492	"RTN","IBC BB11",146, 0)
	2493	PRIIDCHK ; Check for required Pimarary I D (SSN/EIN )
	2494	"RTN","IBC BB11",147, 0)
	2495	; If the provider i s on the c laim, he m ust have o ne
	2496	"RTN","IBC BB11",148, 0)
	2497	;
	2498	"RTN","IBC BB11",149, 0)
	2499	N IBI,IBZ
	2500	"RTN","IBC BB11",150, 0)
	2501	I $$TXMT^ IBCEF4(IBI FN) D
	2502	"RTN","IBC BB11",151, 0)
	2503	. D F^IBC EF("N-ALL ATT/REND P ROV SSN/EI ","IBZ",,I BIFN)
	2504	"RTN","IBC BB11",152, 0)
	2505	. S IBI=" " F S IBI =$O(^DGCR( 399,IBIFN, "PRV","B", IBI)) Q:IB I="" D
	2506	"RTN","IBC BB11",153, 0)
	2507	.. I $P(I BZ,U,IBI)= "" S IBER= IBER_$S(IB I=1:"IB151 ;",IBI=2:" IB152;",IB I=3!(IBI=4 ):"IB321;" ,IBI=5:"IB 153;",IBI= 9:"IB154;" ,1:"")
	2508	"RTN","IBC BB11",154, 0)
	2509	Q
	2510	"RTN","IBC BB11",155, 0)
	2511	;
	2512	"RTN","IBC BB11",156, 0)
	2513	RXNPI(IBIF N) ; check for multi ple pharma cy npi's o n the same bill
	2514	"RTN","IBC BB11",157, 0)
	2515	N IBORG,I BRXNPI,IBX ,IBY
	2516	"RTN","IBC BB11",158, 0)
	2517	S IBORG=$ $RXSITE^IB CEF73A(IBI FN,.IBORG)
	2518	"RTN","IBC BB11",159, 0)
	2519	S IBX=0 F S IBX=$O (IBORG(IBX )) Q:'IBX S IBY=0 F S IBY=$O (IBORG(IBX ,IBY)) Q:' IBY S IBR XNPI(+IBOR G(IBX,IBY) )=""
	2520	"RTN","IBC BB11",160, 0)
	2521	S (IBX,IB Y)=0 F S IBX=$O(IBR XNPI(IBX)) Q:'IBX S IBY=IBY+1
	2522	"RTN","IBC BB11",161, 0)
	2523	I IBY>1 D WARN("Bil l has pres criptions resulting from "_IBY _" differe nt NPI loc ations")
	2524	"RTN","IBC BB11",162, 0)
	2525	Q
	2526	"RTN","IBC BB11",163, 0)
	2527	;
	2528	"RTN","IBC BB11",164, 0)
	2529	ROICHK(IBI FN,IBDFN,I BINS) ; IB 2.0384 - check pre scriptions that cont ain the
	2530	"RTN","IBC BB11",165, 0)
	2531	; SENSITI VE DIAGNOS IS DRUG fi eld #87 in the DRUG File #50 s et to 1 ag ainst
	2532	"RTN","IBC BB11",166, 0)
	2533	; the Cla ims Tracki ng ROI fil e (#356.25 ) to see i f an ROI i s on file
	2534	"RTN","IBC BB11",167, 0)
	2535	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2536	"RTN","IBC BB11",168, 0)
	2537	; IBDFN = I EN of the patient
	2538	"RTN","IBC BB11",169, 0)
	2539	; IBINS = I EN of the payer insu rance comp any (#36)
	2540	"RTN","IBC BB11",170, 0)
	2541	; OUTPUT - 0 = no e rror
	2542	"RTN","IBC BB11",171, 0)
	2543	; 1 = a pr escription is sensit ive and th ere is no ROI on fil e
	2544	"RTN","IBC BB11",172, 0)
	2545	;
	2546	"RTN","IBC BB11",173, 0)
	2547	N IBX,IBY 0,IBRXIEN, IBDT,IBDRU G,ROIQ
	2548	"RTN","IBC BB11",174, 0)
	2549	S ROIQ=0
	2550	"RTN","IBC BB11",175, 0)
	2551	S IBX=0 F S IBX=$O (^IBA(362. 4,"C",IBIF N,IBX)) Q: 'IBX D
	2552	"RTN","IBC BB11",176, 0)
	2553	.S IBY0=^ IBA(362.4, IBX,0),IBR XIEN=$P(IB Y0,U,5) I 'IBRXIEN Q
	2554	"RTN","IBC BB11",177, 0)
	2555	.S IBDT=$ P(IBY0,U,3 ),IBDRUG=$ P(IBY0,U,4 )
	2556	"RTN","IBC BB11",178, 0)
	2557	.D ZERO^I BRXUTL(IBD RUG)
	2558	"RTN","IBC BB11",179, 0)
	2559	.I $$SENS ^IBNCPDR(I BDRUG) D ; Sensitiv e Diagnosi s Drug - c heck for R OI
	2560	"RTN","IBC BB11",180, 0)
	2561	.. I $$RO I^IBNCPDR4 (IBDFN,IBD RUG,IBINS, IBDT) Q ; ROI is on file
	2562	"RTN","IBC BB11",181, 0)
	2563	.. D WARN ("ROI not on file fo r prescrip tion "_$$R XAPI1^IBNC PUT1(IBRXI EN,.01,"E" ))
	2564	"RTN","IBC BB11",182, 0)
	2565	.. S ROIQ =1
	2566	"RTN","IBC BB11",183, 0)
	2567	ROICHKQ ;
	2568	"RTN","IBC BB11",184, 0)
	2569	K ^TMP($J ,"IBDRUG")
	2570	"RTN","IBC BB11",185, 0)
	2571	Q ROIQ
	2572	"RTN","IBC BB11",186, 0)
	2573	;
	2574	"RTN","IBC BB11",187, 0)
	2575	AMBCK(IBIF N) ; IB 2.0432 - if ambula nce locati on defined , address must be de fined
	2576	"RTN","IBC BB11",188, 0)
	2577	; if ther e is anyth ing entere d in any o f the addr ess fields (either p /up or dro p/off fiel ds), than there need s to be:
	2578	"RTN","IBC BB11",189, 0)
	2579	; Address 1, State and ZIP un less the S tate is no t a US sta te or poss ession, th en zip cod e is not n eeded (CMS 1500 only)
	2580	"RTN","IBC BB11",190, 0)
	2581	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2582	"RTN","IBC BB11",191, 0)
	2583	; OUTPUT - 0 = no e rror
	2584	"RTN","IBC BB11",192, 0)
	2585	; 1 = Erro r
	2586	"RTN","IBC BB11",193, 0)
	2587	;
	2588	"RTN","IBC BB11",194, 0)
	2589	N IBPAMB, IBDAMB,IBA MBR,IBCK
	2590	"RTN","IBC BB11",195, 0)
	2591	S IBAMBR= 0
	2592	"RTN","IBC BB11",196, 0)
	2593	Q:$$INSPR F^IBCEF(IB IFN)'=0 IB AMBR
	2594	"RTN","IBC BB11",197, 0)
	2595	S IBPAMB= $G(^DGCR(3 99,IBIFN," U5")),IBDA MB=$G(^DGC R(399,IBIF N,"U6"))
	2596	"RTN","IBC BB11",198, 0)
	2597	S IBCK(5) =$$NOPUNCT ^IBCEF($P( IBPAMB,U,2 ,6),1),IBC K(6)=$$NOP UNCT^IBCEF ($P(IBDAMB ,U,1,6),1)
	2598	"RTN","IBC BB11",199, 0)
	2599	I IBCK(5) ="",IBCK(6 )="" Q IBA MBR
	2600	"RTN","IBC BB11",200, 0)
	2601	; at this point we know that at least o ne ambulan ce field h as data, s o check to see if al l have dat a
	2602	"RTN","IBC BB11",201, 0)
	2603	I IBCK(5) '="" F I=2 ,4,5 I $P( IBPAMB,U,I )="" S IBA MBR=1
	2604	"RTN","IBC BB11",202, 0)
	2605	I IBCK(6) '="" F I=1 ,2,4,5 I $ P(IBDAMB,U ,I)="" S I BAMBR=1
	2606	"RTN","IBC BB11",203, 0)
	2607	Q:IBAMBR= 1 IBAMBR
	2608	"RTN","IBC BB11",204, 0)
	2609	; now che ck zip cod e. OK to be null if state is not a US P osession
	2610	"RTN","IBC BB11",205, 0)
	2611	F I="IBPA MB","IBDAM B" I $P(I, U,5)'="",$ P($G(^DIC( 5,$P(I,U,5 ),0)),U,6) =1,$P(I,U, 6)="" S IB AMBR=1
	2612	"RTN","IBC BB11",206, 0)
	2613	Q IBAMBR
	2614	"RTN","IBC BB11",207, 0)
	2615	;
	2616	"RTN","IBC BB11",208, 0)
	2617	COBAMT(IBI FN) ; IB 2.0432 - IF there is a COB a mt. it mus t equal th e Total Cl aim Charge Amount
	2618	"RTN","IBC BB11",209, 0)
	2619	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2620	"RTN","IBC BB11",210, 0)
	2621	; OUTPUT - 0 = no e rror
	2622	"RTN","IBC BB11",211, 0)
	2623	; 1 = Erro r
	2624	"RTN","IBC BB11",212, 0)
	2625	;
	2626	"RTN","IBC BB11",213, 0)
	2627	Q:IBIFN=" " 0
	2628	"RTN","IBC BB11",214, 0)
	2629	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)="" 0
	2630	"RTN","IBC BB11",215, 0)
	2631	Q:+$P($G( ^DGCR(399, IBIFN,"U1" )),U)'=+$P ($G(^DGCR( 399,IBIFN, "U4")),U) 1
	2632	"RTN","IBC BB11",216, 0)
	2633	Q 0
	2634	"RTN","IBC BB11",217, 0)
	2635	;
	2636	"RTN","IBC BB11",218, 0)
	2637	COBMRA(IBI FN) ; IB 2.0432 - If there is a 'COB total non- covered am ount' (Fil e#399, Fie ld#260),
	2638	"RTN","IBC BB11",219, 0)
	2639	; Primary Insurance must be M edicare th at never w ent to Med icare, and this must be a 2nda ry or tert iary claim
	2640	"RTN","IBC BB11",220, 0)
	2641	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2642	"RTN","IBC BB11",221, 0)
	2643	; OUTPUT - 0 = no e rror
	2644	"RTN","IBC BB11",222, 0)
	2645	; 1 = Erro r
	2646	"RTN","IBC BB11",223, 0)
	2647	;
	2648	"RTN","IBC BB11",224, 0)
	2649	N IBP
	2650	"RTN","IBC BB11",225, 0)
	2651	Q:IBIFN=" " 0
	2652	"RTN","IBC BB11",226, 0)
	2653	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)="" 0
	2654	"RTN","IBC BB11",227, 0)
	2655	S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN
	2656	"RTN","IBC BB11",228, 0)
	2657	I $$WNRBI LL^IBEFUNC (IBIFN,1), $P($G(^DGC R(399,IBP, "S")),U,7) ="",$$COBN ^IBCEF(IBI FN)>1 Q 0
	2658	"RTN","IBC BB11",229, 0)
	2659	Q 1
	2660	"RTN","IBC BB11",230, 0)
	2661	;
	2662	"RTN","IBC BB11",231, 0)
	2663	COBSEC(IBI FN) ; IB 2.0432 - If there is NOT a ' COB total non-covere d amount' (File#399, Field#260 ),
	2664	"RTN","IBC BB11",232, 0)
	2665	; and Pri mary Insur ance is Me dicare tha t never we nt to Medi care, 2nda ry or tert iary claim cannot be set to tr ansmit
	2666	"RTN","IBC BB11",233, 0)
	2667	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2668	"RTN","IBC BB11",234, 0)
	2669	; OUTPUT - 0 = no e rror
	2670	"RTN","IBC BB11",235, 0)
	2671	; 1 = Erro r
	2672	"RTN","IBC BB11",236, 0)
	2673	;
	2674	"RTN","IBC BB11",237, 0)
	2675	N IBP
	2676	"RTN","IBC BB11",238, 0)
	2677	Q:IBIFN=" " 0
	2678	"RTN","IBC BB11",239, 0)
	2679	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)'="" 0
	2680	"RTN","IBC BB11",240, 0)
	2681	Q:$$COBN^ IBCEF(IBIF N)<2 0
	2682	"RTN","IBC BB11",241, 0)
	2683	S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN
	2684	"RTN","IBC BB11",242, 0)
	2685	I $$WNRBI LL^IBEFUNC (IBIFN,1), $P($G(^DGC R(399,IBP, "S")),U,7) ="",$P($G( ^DGCR(399, IBIFN,"TX" )),U,8)'=1 Q 1
	2686	"RTN","IBC BB11",243, 0)
	2687	Q 0
	2688	"RTN","IBC BB11",244, 0)
	2689	;
	2690	"RTN","IBC BB11",245, 0)
	2691	TMCK(IBIFN ) ; IB2. 0432 - At tachment C ontrol Num ber - REQU IRED when Transmissi on Method = BM, EL, EM, or FT
	2692	"RTN","IBC BB11",246, 0)
	2693	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2694	"RTN","IBC BB11",247, 0)
	2695	; OUTPUT - 0 = no e rror
	2696	"RTN","IBC BB11",248, 0)
	2697	; 1 = Erro r
	2698	"RTN","IBC BB11",249, 0)
	2699	;
	2700	"RTN","IBC BB11",250, 0)
	2701	N IBAC
	2702	"RTN","IBC BB11",251, 0)
	2703	Q:IBIFN=" " 0
	2704	"RTN","IBC BB11",252, 0)
	2705	F I=1,3 S IBAC(I)=$ P($G(^DGCR (399,IBIFN ,"U8")),U, I)
	2706	"RTN","IBC BB11",253, 0)
	2707	Q:IBAC(3) ="" 0
	2708	"RTN","IBC BB11",254, 0)
	2709	Q:IBAC(1) '="" 0
	2710	"RTN","IBC BB11",255, 0)
	2711	Q:IBAC(3) ="AA" 0
	2712	"RTN","IBC BB11",256, 0)
	2713	Q 1
	2714	"RTN","IBC BB11",257, 0)
	2715	;
	2716	"RTN","IBC BB11",258, 0)
	2717	ACCK(IBIFN ) ; IB2.0 432 If an y of the l oop info i s present, then Repo rt Type & Transmissi on Method req'd
	2718	"RTN","IBC BB11",259, 0)
	2719	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2720	"RTN","IBC BB11",260, 0)
	2721	; OUTPUT - 0 = no e rror
	2722	"RTN","IBC BB11",261, 0)
	2723	; 1 = Erro r
	2724	"RTN","IBC BB11",262, 0)
	2725	;
	2726	"RTN","IBC BB11",263, 0)
	2727	N IBAC
	2728	"RTN","IBC BB11",264, 0)
	2729	Q:IBIFN=" " 0
	2730	"RTN","IBC BB11",265, 0)
	2731	F I=1:1:3 S IBAC(I) =$P($G(^DG CR(399,IBI FN,"U8")), U,I)
	2732	"RTN","IBC BB11",266, 0)
	2733	; All fie lds null, no error
	2734	"RTN","IBC BB11",267, 0)
	2735	I IBAC(1) ="",IBAC(2 )="",IBAC( 3)="" Q 0
	2736	"RTN","IBC BB11",268, 0)
	2737	; Both re quired fie lds comple te, no err or
	2738	"RTN","IBC BB11",269, 0)
	2739	I IBAC(2) '="",IBAC( 3)'="" Q 0
	2740	"RTN","IBC BB11",270, 0)
	2741	; At this point, on e of the 2 required fields has data and one does n ot, so err or
	2742	"RTN","IBC BB11",271, 0)
	2743	Q 1
	2744	"RTN","IBC BB11",272, 0)
	2745	;
	2746	"RTN","IBC BB11",273, 0)
	2747	LNTMCK(IBI FN) ; DEM ;IB2.043 2 - (Line Level) Att achment Co ntrol Numb er - REQUI RED when T ransmissio n Method = BM, EL, E M, or FT
	2748	"RTN","IBC BB11",274, 0)
	2749	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2750	"RTN","IBC BB11",275, 0)
	2751	; OUTPUT - IBLNERR = 0 = no e rror
	2752	"RTN","IBC BB11",276, 0)
	2753	; IBLNERR = 1 = Erro r
	2754	"RTN","IBC BB11",277, 0)
	2755	;
	2756	"RTN","IBC BB11",278, 0)
	2757	N IBAC,IB PROCP,I,IB LNERR
	2758	"RTN","IBC BB11",279, 0)
	2759	S IBLNERR =0 ; DEM; 432 - Init ialize err or flag IB LNERR to ' 0' for no errors.
	2760	"RTN","IBC BB11",280, 0)
	2761	Q:IBIFN=" " IBLNERR
	2762	"RTN","IBC BB11",281, 0)
	2763	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR
	2764	"RTN","IBC BB11",282, 0)
	2765	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,0 ))#10) ; DEM;432 - Node '0' i s procedur e node.
	2766	"RTN","IBC BB11",283, 0)
	2767	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; DEM;432 - Node '1' i s line lev el Attachm ent Contro l fields.
	2768	"RTN","IBC BB11",284, 0)
	2769	. F I=1,3 S IBAC(I) =$P(^DGCR( 399,IBIFN, "CP",IBPRO CP,1),U,I)
	2770	"RTN","IBC BB11",285, 0)
	2771	. I IBAC( 3)="" S IB LNERR=0 Q
	2772	"RTN","IBC BB11",286, 0)
	2773	. I IBAC( 1)'="" S I BLNERR=0 Q
	2774	"RTN","IBC BB11",287, 0)
	2775	. I (IBAC (3)="AA") S IBLNERR= 0 Q
	2776	"RTN","IBC BB11",288, 0)
	2777	. S IBLNE RR=1
	2778	"RTN","IBC BB11",289, 0)
	2779	. Q
	2780	"RTN","IBC BB11",290, 0)
	2781	;
	2782	"RTN","IBC BB11",291, 0)
	2783	Q IBLNERR
	2784	"RTN","IBC BB11",292, 0)
	2785	;
	2786	"RTN","IBC BB11",293, 0)
	2787	LNACCK(IBI FN) ; DEM; IB2.0432 (Line Lev el) If any of the lo op info is present, then Repor t Type & T ransmissio n Method r eq'd
	2788	"RTN","IBC BB11",294, 0)
	2789	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2790	"RTN","IBC BB11",295, 0)
	2791	; OUTPUT - IBLNERR = 0 = no e rror
	2792	"RTN","IBC BB11",296, 0)
	2793	; IBLNERR = 1 = Erro r
	2794	"RTN","IBC BB11",297, 0)
	2795	;
	2796	"RTN","IBC BB11",298, 0)
	2797	N IBAC,IB PROCP,I,IB LNERR
	2798	"RTN","IBC BB11",299, 0)
	2799	S IBLNERR =0 ; DEM; 432 - Init ialize err or flag IB LNERR to ' 0' for no errors.
	2800	"RTN","IBC BB11",300, 0)
	2801	Q:IBIFN=" " IBLNERR
	2802	"RTN","IBC BB11",301, 0)
	2803	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR
	2804	"RTN","IBC BB11",302, 0)
	2805	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,0 ))#10) ; DEM;432 - Node '0' i s procedur e node.
	2806	"RTN","IBC BB11",303, 0)
	2807	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; DEM;432 - Node '1' i s line lev el Attachm ent Contro l fields.
	2808	"RTN","IBC BB11",304, 0)
	2809	. F I=1:1 :3 S IBAC( I)=$P(^DGC R(399,IBIF N,"CP",IBP ROCP,1),U, I)
	2810	"RTN","IBC BB11",305, 0)
	2811	. ; All f ields null , no error
	2812	"RTN","IBC BB11",306, 0)
	2813	. I IBAC( 1)="",IBAC (2)="",IBA C(3)="" S IBLNERR=0 Q
	2814	"RTN","IBC BB11",307, 0)
	2815	. ; Both required f ields comp lete, no e rror
	2816	"RTN","IBC BB11",308, 0)
	2817	. I IBAC( 2)'="",IBA C(3)'="" S IBLNERR=0 Q
	2818	"RTN","IBC BB11",309, 0)
	2819	. ; At th is point, one of the 2 require d fields h as data an d one does not, so e rror
	2820	"RTN","IBC BB11",310, 0)
	2821	. S IBLNE RR=1
	2822	"RTN","IBC BB11",311, 0)
	2823	. Q
	2824	"RTN","IBC BB11",312, 0)
	2825	;
	2826	"RTN","IBC BB11",313, 0)
	2827	Q IBLNERR
	2828	"RTN","IBC BB11",314, 0)
	2829	;
	2830	"RTN","IBC BB11",315, 0)
	2831	;vd/Begin ning of IB 2577 - V alidate Li ne Level f or NDC
	2832	"RTN","IBC BB11",316, 0)
	2833	LNNDCCK(IB IFN) ;IB2 577 (Line Level) Th e Units an d Units/Ba sis of Mea surement f ields are required i f the NDC field is p opulated.
	2834	"RTN","IBC BB11",317, 0)
	2835	; INPUT - IBIFN = IEN of the Bill/Clai ms file (# 399)
	2836	"RTN","IBC BB11",318, 0)
	2837	; OUTPUT - IBLNERR = 0 = no e rror
	2838	"RTN","IBC BB11",319, 0)
	2839	; IBLNERR = 1 = Erro r
	2840	"RTN","IBC BB11",320, 0)
	2841	;
	2842	"RTN","IBC BB11",321, 0)
	2843	N IBAC,IB PROCP,I,IB LNERR
	2844	"RTN","IBC BB11",322, 0)
	2845	S IBLNERR =0 ; IB2 577 - Ini tialize er ror flag I BLNERR to '0' for no errors.
	2846	"RTN","IBC BB11",323, 0)
	2847	Q:IBIFN=" " IBLNERR
	2848	"RTN","IBC BB11",324, 0)
	2849	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR
	2850	"RTN","IBC BB11",325, 0)
	2851	. Q:($$GE T1^DIQ(399 .0304,IBPR OCP_","_IB IFN_",","N DC","I")=" ") ; IB* 2*577 - No NDC Code
	2852	"RTN","IBC BB11",326, 0)
	2853	. ; If th ere is an NDC Code, then the U NITS and U NITS/BASIS OF MEASUR EMENT are Required.
	2854	"RTN","IBC BB11",327, 0)
	2855	. I $$GET 1^DIQ(399. 0304,IBPRO CP_","_IBI FN_",","UN ITS/BASIS OF MEASURE MENT","I") ="" S IBLN ERR=1 Q
	2856	"RTN","IBC BB11",328, 0)
	2857	. I $$GET 1^DIQ(399. 0304,IBPRO CP_","_IBI FN_",","UN ITS","I")= "" S IBLNE RR=1 Q ;U nits (Quan tity) is r equired if there is an NDC Cod e.
	2858	"RTN","IBC BB11",329, 0)
	2859	. Q
	2860	"RTN","IBC BB11",330, 0)
	2861	;
	2862	"RTN","IBC BB11",331, 0)
	2863	Q IBLNERR
	2864	"RTN","IBC BB11",332, 0)
	2865	;vd/End o f IB2577
	2866	"RTN","IBC NSBL2")
	2867	0^14^B3961 9145^B3317 3974
	2868	"RTN","IBC NSBL2",1,0 )
	2869	IBCNSBL2 ; ALB/CPM - 'BILL NEXT PAYOR' BU LLETIN ;08 -AUG-96
	2870	"RTN","IBC NSBL2",2,0 )
	2871	;;2.0;INT EGRATED BI LLING;*52 ,80,153,24 0,432,568 *;21-MAR-9 4;Build 38
	2872	"RTN","IBC NSBL2",3,0 )
	2873	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	2874	"RTN","IBC NSBL2",4,0 )
	2875	;
	2876	"RTN","IBC NSBL2",5,0 )
	2877	EOB(IBIFN, IBORIG,IBP YMT,IBTXT) ; determi ne if ther e may be a nother pay er for thi s claim th at should be billed
	2878	"RTN","IBC NSBL2",6,0 )
	2879	; in gene ral the EO B of the c urrent bil l is requi red to be sent with the next T P bill in the series
	2880	"RTN","IBC NSBL2",7,0 )
	2881	; if ther e is anoth er Third P arty Payer then retu rns true, if any oth er payer ( including patient) t hen set ar ray
	2882	"RTN","IBC NSBL2",8,0 )
	2883	;
	2884	"RTN","IBC NSBL2",9,0 )
	2885	; Input : IBIFN -- Poin ter to AR (file #430 ), or Clai m (file #3 99)
	2886	"RTN","IBC NSBL2",10, 0)
	2887	; IBORIG -- Orig inal amoun t of the c laim
	2888	"RTN","IBC NSBL2",11, 0)
	2889	; IBPYMT -- Tota l Amount p aid on the claim
	2890	"RTN","IBC NSBL2",12, 0)
	2891	;
	2892	"RTN","IBC NSBL2",13, 0)
	2893	; Output : IBTXT -- Array , pass by reference, if needed
	2894	"RTN","IBC NSBL2",14, 0)
	2895	; If a another pa yer (third party or patient) f or the cla im can be found,
	2896	"RTN","IBC NSBL2",15, 0)
	2897	; this array will contain t he text th at explain s who the next payer is
	2898	"RTN","IBC NSBL2",16, 0)
	2899	;
	2900	"RTN","IBC NSBL2",17, 0)
	2901	; Returns : 0 -- no ne ed to forw ard EOB (n o next Thi rd Party p ayer found or paymen t=>amount due)
	2902	"RTN","IBC NSBL2",18, 0)
	2903	; 'true^N ext payer' -- if th e EOB of t he bill ne eds to be forwarded for inclus ion in the next bill ,
	2904	"RTN","IBC NSBL2",19, 0)
	2905	; gener ally there must be a nother pay er for the bill that is
	2906	"RTN","IBC NSBL2",20, 0)
	2907	; third party, no n-patient, and payme nt was not the amoun t due
	2908	"RTN","IBC NSBL2",21, 0)
	2909	;
	2910	"RTN","IBC NSBL2",22, 0)
	2911	N X,IB,IB POL,IBCS,I BARCAT,IBS EC,IBRETUR N,IBSEQ,IB INS S IBRE TURN=0
	2912	"RTN","IBC NSBL2",23, 0)
	2913	I '$G(IBI FN) G EOBQ
	2914	"RTN","IBC NSBL2",24, 0)
	2915	I $G(^PRC A(430,IBIF N,0))="" G EOBQ
	2916	"RTN","IBC NSBL2",25, 0)
	2917	I '$G(IBO RIG) G EOB Q
	2918	"RTN","IBC NSBL2",26, 0)
	2919	I $G(IBPY MT)="" G E OBQ
	2920	"RTN","IBC NSBL2",27, 0)
	2921	;
	2922	"RTN","IBC NSBL2",28, 0)
	2923	S IB=$G(^ DGCR(399,I BIFN,0)) I IB="" G E OBQ
	2924	"RTN","IBC NSBL2",29, 0)
	2925	;
	2926	"RTN","IBC NSBL2",30, 0)
	2927	; - quit if there i s no remai ning balan ce on the bill
	2928	"RTN","IBC NSBL2",31, 0)
	2929	I IBPYMT' <IBORIG G EOBQ
	2930	"RTN","IBC NSBL2",32, 0)
	2931	;
	2932	"RTN","IBC NSBL2",33, 0)
	2933	S IBARCAT =$P($G(^DG CR(399.3,+ $P(IB,"^", 7),0)),"^" ,6) I 'IBA RCAT G EOB Q
	2934	"RTN","IBC NSBL2",34, 0)
	2935	;
	2936	"RTN","IBC NSBL2",35, 0)
	2937	; for Eme rgency/Hum anitarian Reimb. IB* 2.0*568
	2938	"RTN","IBC NSBL2",36, 0)
	2939	I IBARCAT =46 D G E OBQ
	2940	"RTN","IBC NSBL2",37, 0)
	2941	. S IBRET URN="2^Eme rgency/Hum anitarian Reimb."
	2942	"RTN","IBC NSBL2",38, 0)
	2943	. S IBTXT (14)="You should bal ance bill this patie nt using t he appropr iate cost- based rate type."
	2944	"RTN","IBC NSBL2",39, 0)
	2945	;
	2946	"RTN","IBC NSBL2",40, 0)
	2947	; for Ine ligible Ho sp. Reimb. IB2.056 8
	2948	"RTN","IBC NSBL2",41, 0)
	2949	I IBARCAT =47 D G E OBQ
	2950	"RTN","IBC NSBL2",42, 0)
	2951	. S IBRET URN="2^Ine ligible Ho sp. Reimb. "
	2952	"RTN","IBC NSBL2",43, 0)
	2953	. S IBTXT (14)="You should bal ance bill this patie nt using t he appropr iate cost- based rate type."
	2954	"RTN","IBC NSBL2",44, 0)
	2955	;
	2956	"RTN","IBC NSBL2",45, 0)
	2957	; - for C hampva thi rd party c laims, bil l the Cham pva Center next
	2958	"RTN","IBC NSBL2",46, 0)
	2959	I IBARCAT =28 D G E OBQ
	2960	"RTN","IBC NSBL2",47, 0)
	2961	. S IBTXT (14)="You should pre pare a cla im to be s ent to the CHAMPVA C enter.",IB RETURN="1^ CHAMPVA Ce nter"
	2962	"RTN","IBC NSBL2",48, 0)
	2963	;
	2964	"RTN","IBC NSBL2",49, 0)
	2965	; - for T ricare thi rd party c laims, nex t bill Tri care or th e patient
	2966	"RTN","IBC NSBL2",50, 0)
	2967	I IBARCAT =32 D G E OBQ
	2968	"RTN","IBC NSBL2",51, 0)
	2969	. ;
	2970	"RTN","IBC NSBL2",52, 0)
	2971	. ; - thi rd party b ill went t o Tricare Supplement al carrier , bill pat ient next
	2972	"RTN","IBC NSBL2",53, 0)
	2973	. S IBSEQ =$P($G(^DG CR(399,IBI FN,0)),U,2 1),IBSEQ=$ S(IBSEQ="P ":"I1",IBS EQ="S":"I2 ",IBSEQ="T ":"I3",1:- 1)
	2974	"RTN","IBC NSBL2",54, 0)
	2975	. S IBPOL =$G(^DGCR( 399,IBIFN, IBSEQ))
	2976	"RTN","IBC NSBL2",55, 0)
	2977	. S IBCS= $D(^IBE(35 5.1,"D","C S",+$P($G( ^IBA(355.3 ,+$P(IBPOL ,"^",18),0 )),"^",9)) )>0
	2978	"RTN","IBC NSBL2",56, 0)
	2979	. I IBCS D Q
	2980	"RTN","IBC NSBL2",57, 0)
	2981	.. S IBTX T(14)="Thi s claim wa s sent to the TRICAR E Suppleme ntal insur ance carri er."
	2982	"RTN","IBC NSBL2",58, 0)
	2983	.. S IBTX T(15)="You should se nd a copay ment charg e to the p atient."
	2984	"RTN","IBC NSBL2",59, 0)
	2985	. ;
	2986	"RTN","IBC NSBL2",60, 0)
	2987	. ; - oth erwise thi rd party b ill went t o patients Reimb. In s carrier, bill the tricare FI next
	2988	"RTN","IBC NSBL2",61, 0)
	2989	. S IBRET URN="1^TRI CARE Fisca l Intermed iary"
	2990	"RTN","IBC NSBL2",62, 0)
	2991	. S IBTXT (14)="You should pre pare a cla im to send to the TR ICARE Fisc al Interme diary."
	2992	"RTN","IBC NSBL2",63, 0)
	2993	;
	2994	"RTN","IBC NSBL2",64, 0)
	2995	; - for T ricare cla ims, bill the patien t or Trica re supplem ental poli cy
	2996	"RTN","IBC NSBL2",65, 0)
	2997	I IBARCAT =30 D G E OBQ
	2998	"RTN","IBC NSBL2",66, 0)
	2999	. ;
	3000	"RTN","IBC NSBL2",67, 0)
	3001	. ; - if the patien t has a Tr icare supp lemental p olicy, bil l it
	3002	"RTN","IBC NSBL2",68, 0)
	3003	. I $$CHP SUP(+$P(IB ,"^",2)) D Q
	3004	"RTN","IBC NSBL2",69, 0)
	3005	.. S IBRE TURN="1^TR ICARE Supp lemental p olicy"
	3006	"RTN","IBC NSBL2",70, 0)
	3007	.. S IBTX T(14)="The patient h as a TRICA RE Supplem ental poli cy."
	3008	"RTN","IBC NSBL2",71, 0)
	3009	.. S IBTX T(15)="You should pr epare a cl aim to be sent to th at carrier ."
	3010	"RTN","IBC NSBL2",72, 0)
	3011	. ;
	3012	"RTN","IBC NSBL2",73, 0)
	3013	. ; - oth erwise, bi ll the pat ient
	3014	"RTN","IBC NSBL2",74, 0)
	3015	. S IBTXT (14)="You should sen d a copaym ent charge to the pa tient."
	3016	"RTN","IBC NSBL2",75, 0)
	3017	;
	3018	"RTN","IBC NSBL2",76, 0)
	3019	; - all o ther bills : if ther e is a nex t payer in the serie s then a b ill needs to be crea ted for th at payer
	3020	"RTN","IBC NSBL2",77, 0)
	3021	S IBSEQ=$ P($G(^DGCR (399,IBIFN ,0)),U,21) ,IBSEQ=$S( IBSEQ="P": 2,IBSEQ="S ":3,1:"")
	3022	"RTN","IBC NSBL2",78, 0)
	3023	I +IBSEQ S IBINS=$P ($G(^DGCR( 399,IBIFN, "M")),U,IB SEQ) I +IB INS D
	3024	"RTN","IBC NSBL2",79, 0)
	3025	. S IBRET URN=+IBINS _U_$P($G(^ DIC(36,+IB INS,0)),U, 1)
	3026	"RTN","IBC NSBL2",80, 0)
	3027	. S IBTXT (14)="Ther e is a "_$ S(IBSEQ=2: "secondary ",1:"terti ary")_" pa yor associ ated with this claim ."
	3028	"RTN","IBC NSBL2",81, 0)
	3029	. S IBTXT (15)="You may need t o prepare a claim to be sent t o "_$P(IBR ETURN,U,2) _"."
	3030	"RTN","IBC NSBL2",82, 0)
	3031	;
	3032	"RTN","IBC NSBL2",83, 0)
	3033	EOBQ Q IBR ETURN
	3034	"RTN","IBC NSBL2",84, 0)
	3035	;
	3036	"RTN","IBC NSBL2",85, 0)
	3037	BULL(IBIFN ,IBORIG,IB PYMT) ; Ge nerate bul letin deta iling next payer for a claim, if any
	3038	"RTN","IBC NSBL2",86, 0)
	3039	;
	3040	"RTN","IBC NSBL2",87, 0)
	3041	; Input : IBIFN -- Poin ter to AR (file #430 ), or Clai m (file #3 99)
	3042	"RTN","IBC NSBL2",88, 0)
	3043	; IBORIG -- Orig inal amoun t of the c laim
	3044	"RTN","IBC NSBL2",89, 0)
	3045	; IBPYMT -- Tota l Amount p aid on the claim
	3046	"RTN","IBC NSBL2",90, 0)
	3047	;
	3048	"RTN","IBC NSBL2",91, 0)
	3049	; Output : Bullet in: Mail Group MEA NS TEST BI LLING MAIL GROUP: IB MEANS TES T (350.9,. 11)
	3050	"RTN","IBC NSBL2",92, 0)
	3051	; If a secondary payor for the claim can be fo und, a bul letin will be sent
	3052	"RTN","IBC NSBL2",93, 0)
	3053	; to t he billing unit to a lert them to forward the claim to that p ayor.
	3054	"RTN","IBC NSBL2",94, 0)
	3055	;
	3056	"RTN","IBC NSBL2",95, 0)
	3057	N X,IB,IB X,IBTXT,IB P,IBGRP,IB WLF ;WCJ; IB2.0432
	3058	"RTN","IBC NSBL2",96, 0)
	3059	;
	3060	"RTN","IBC NSBL2",97, 0)
	3061	S IBX=$$E OB($G(IBIF N),$G(IBOR IG),$G(IBP YMT),.IBTX T) I '$D(I BTXT) D WL CK(IBIFN) G BULLQ
	3062	"RTN","IBC NSBL2",98, 0)
	3063	;
	3064	"RTN","IBC NSBL2",99, 0)
	3065	; WCJ;IB* 2.0*432;Tr igger comm ercial aut o processi ng.
	3066	"RTN","IBC NSBL2",100 ,0)
	3067	; This wi ll replace the bulle tin when a ctivated.
	3068	"RTN","IBC NSBL2",101 ,0)
	3069	; (not us ing a mast er switch just yet s o it's aut omatically activated )
	3070	"RTN","IBC NSBL2",102 ,0)
	3071	;I $$GET1 ^DIQ(350.9 ,1,8.18) D G BULLQ
	3072	"RTN","IBC NSBL2",103 ,0)
	3073	; check i f these sh ould go di rectly to the workli st
	3074	"RTN","IBC NSBL2",104 ,0)
	3075	S IBWLF=$ S('IBX:1," .CHAMPVA C enter.TRIC ARE Fiscal Intermedi ary.TRICAR E Suppleme ntal polic y."[("."_$ P(IBX,U,2) _"."):1,". Ineligible Hosp. Rei mb..Emerge ncy/Humani tarian Rei mb.."[("." _$P(IBX,U, 2)_"."):2, 1:0)
	3076	"RTN","IBC NSBL2",105 ,0)
	3077	D EN^IBCA PP(IBIFN,I BORIG,IBPY MT,IBWLF)
	3078	"RTN","IBC NSBL2",106 ,0)
	3079	G BULLQ
	3080	"RTN","IBC NSBL2",107 ,0)
	3081	; WCJ;IB* 2.0*432;en d changes
	3082	"RTN","IBC NSBL2",108 ,0)
	3083	;
	3084	"RTN","IBC NSBL2",109 ,0)
	3085	S IB=$G(^ DGCR(399,I BIFN,0)) I IB="" G B ULLQ
	3086	"RTN","IBC NSBL2",110 ,0)
	3087	S IBP=$$P T^IBEFUNC( +$P(IB,"^" ,2))
	3088	"RTN","IBC NSBL2",111 ,0)
	3089	;
	3090	"RTN","IBC NSBL2",112 ,0)
	3091	; - creat e remainde r of bulle tin
	3092	"RTN","IBC NSBL2",113 ,0)
	3093	N XMDUZ,X MTEXT,XMY, XMSUB
	3094	"RTN","IBC NSBL2",114 ,0)
	3095	S XMSUB=" Notificati on of Subs equent Pay or"
	3096	"RTN","IBC NSBL2",115 ,0)
	3097	S XMDUZ=" INTEGRATED BILLING P ACKAGE",XM TEXT="IBTX T("
	3098	"RTN","IBC NSBL2",116 ,0)
	3099	K XMY S X MY(DUZ)=""
	3100	"RTN","IBC NSBL2",117 ,0)
	3101	;
	3102	"RTN","IBC NSBL2",118 ,0)
	3103	S IBTXT(1 )="A payme nt has bee n made on the follow ing claim, which has been iden tified"
	3104	"RTN","IBC NSBL2",119 ,0)
	3105	S IBTXT(2 )="as pote ntially ha ving a sub sequent pa yor:"
	3106	"RTN","IBC NSBL2",120 ,0)
	3107	S IBTXT(3 )=" "
	3108	"RTN","IBC NSBL2",121 ,0)
	3109	S IBTXT(4 )=" Bill Number: "_ $P($G(^PRC A(430,IBIF N,0)),"^")
	3110	"RTN","IBC NSBL2",122 ,0)
	3111	S IBTXT(5 )=" P atient: "_ $E($P(IBP, "^"),1,30) _" Pt. I d: "_$P(IB P,"^",2)
	3112	"RTN","IBC NSBL2",123 ,0)
	3113	S IBTXT(6 )=" Bil l Type: "_ $P($G(^DGC R(399.3,+$ P(IB,"^",7 ),0)),"^")
	3114	"RTN","IBC NSBL2",124 ,0)
	3115	S IBTXT(7 )=" Orig Amount: $" _$J(IBORIG ,0,2)
	3116	"RTN","IBC NSBL2",125 ,0)
	3117	S IBTXT(8 )=" Amoun t Paid: $" _$J(IBPYMT ,0,2)
	3118	"RTN","IBC NSBL2",126 ,0)
	3119	S IBTXT(9 )=" "
	3120	"RTN","IBC NSBL2",127 ,0)
	3121	;
	3122	"RTN","IBC NSBL2",128 ,0)
	3123	S IBX=$G( ^DGCR(399, IBIFN,0))
	3124	"RTN","IBC NSBL2",129 ,0)
	3125	S IBTXT(1 0)="Bill S equence: " _$$EXSET^I BEFUNC($P( IBX,U,21), 399,.21)
	3126	"RTN","IBC NSBL2",130 ,0)
	3127	S IBTXT(1 1)=" Bil l Payer: " _$E($P($G( ^DIC(36,+$ G(^DGCR(39 9,IBIFN,"M P")),0)),U ,1),1,20)
	3128	"RTN","IBC NSBL2",131 ,0)
	3129	;
	3130	"RTN","IBC NSBL2",132 ,0)
	3131	S IBX=$G( ^DGCR(399, IBIFN,"M") )
	3132	"RTN","IBC NSBL2",133 ,0)
	3133	I IBX S I BTXT(10)=I BTXT(10)_$ J("",(40-$ L(IBTXT(10 ))))_" Pr imary Carr ier: "_$E( $P($G(^DIC (36,+IBX,0 )),U,1),1, 20)
	3134	"RTN","IBC NSBL2",134 ,0)
	3135	I +$P(IBX ,U,2) S IB TXT(11)=IB TXT(11)_$J ("",(40-$L (IBTXT(11) )))_"Secon dary Carri er: "_$E($ P($G(^DIC( 36,+$P(IBX ,U,2),0)), U,1),1,20)
	3136	"RTN","IBC NSBL2",135 ,0)
	3137	I +$P(IBX ,U,3) S IB TXT(12)=$J ("",40)_" Tertiary C arrier: "_ $E($P($G(^ DIC(36,+$P (IBX,U,3), 0)),U,1),1 ,20)
	3138	"RTN","IBC NSBL2",136 ,0)
	3139	S IBTXT(1 3)=" "
	3140	"RTN","IBC NSBL2",137 ,0)
	3141	;
	3142	"RTN","IBC NSBL2",138 ,0)
	3143	; - send to the Mea ns Test bi lling mail group (for now)
	3144	"RTN","IBC NSBL2",139 ,0)
	3145	S IBGRP=$ P($G(^XMB( 3.8,+$P($G (^IBE(350. 9,1,0)),"^ ",11),0)), "^")
	3146	"RTN","IBC NSBL2",140 ,0)
	3147	I IBGRP]" " S XMY("G ."_IBGRP_" @"_^XMB("N ETNAME"))= ""
	3148	"RTN","IBC NSBL2",141 ,0)
	3149	;
	3150	"RTN","IBC NSBL2",142 ,0)
	3151	D ^XMD
	3152	"RTN","IBC NSBL2",143 ,0)
	3153	;
	3154	"RTN","IBC NSBL2",144 ,0)
	3155	BULLQ Q
	3156	"RTN","IBC NSBL2",145 ,0)
	3157	;
	3158	"RTN","IBC NSBL2",146 ,0)
	3159	;
	3160	"RTN","IBC NSBL2",147 ,0)
	3161	CHPSUP(DFN ) ; Does t he patient have a TR ICARE Supp lemental p olicy?
	3162	"RTN","IBC NSBL2",148 ,0)
	3163	; Input: DFN -- Pointer to the pat ient in fi le #2
	3164	"RTN","IBC NSBL2",149 ,0)
	3165	; Output: 0 - Has no TRICAR E Suppleme ntal polic y
	3166	"RTN","IBC NSBL2",150 ,0)
	3167	; 1 - Yes , patient has such a policy.
	3168	"RTN","IBC NSBL2",151 ,0)
	3169	;
	3170	"RTN","IBC NSBL2",152 ,0)
	3171	N X,IBINS ,IBCS
	3172	"RTN","IBC NSBL2",153 ,0)
	3173	D ALL^IBC NS1(DFN,"I BINS",1,DT )
	3174	"RTN","IBC NSBL2",154 ,0)
	3175	S (IBCS,X )=0 F S X =$O(IBINS( X)) Q:'X D Q:IBCS
	3176	"RTN","IBC NSBL2",155 ,0)
	3177	.I $D(^IB E(355.1,"D ","CS",+$P ($G(IBINS( X,355.3)), "^",9))) S IBCS=1
	3178	"RTN","IBC NSBL2",156 ,0)
	3179	Q IBCS
	3180	"RTN","IBC NSBL2",157 ,0)
	3181	;
	3182	"RTN","IBC NSBL2",158 ,0)
	3183	WLCK(IBIFN ) ; does t his claim need to be removed f rom the wo rklist?
	3184	"RTN","IBC NSBL2",159 ,0)
	3185	; IBIFN = claim ien , if colle cted/close d and NO s ubsequent payer, rem ove from w orklist if there
	3186	"RTN","IBC NSBL2",160 ,0)
	3187	;
	3188	"RTN","IBC NSBL2",161 ,0)
	3189	N X
	3190	"RTN","IBC NSBL2",162 ,0)
	3191	Q:$P($$BI LL^RCJIBFN 2(IBIFN),U ,2)'=22 ; AR statu s DBIA 145 2
	3192	"RTN","IBC NSBL2",163 ,0)
	3193	Q:'$D(^DG CR(399,"CA P",1,IBIFN )) ; not on worklis t
	3194	"RTN","IBC NSBL2",164 ,0)
	3195	S X=$$WLR MVF^IBCECO B1(IBIFN," RM",1)
	3196	"RTN","IBC NSBL2",165 ,0)
	3197	Q
	3198	"RTN","IBE CEA")
	3199	0^12^B1352 2502^B1079 2926
	3200	"RTN","IBE CEA",1,0)
	3201	IBECEA ;AL B/RLW - Ca ncel/Edit/ Add Patien t Charges ;12-JUN-92
	3202	"RTN","IBE CEA",2,0)
	3203	;;2.0;INT EGRATED BI LLING ;1 99,135,568 ;21-MAR- 94;Build 3 8
	3204	"RTN","IBE CEA",3,0)
	3205	;Per VA D irective 6 402, this routine sh ould not b e modified .
	3206	"RTN","IBE CEA",4,0)
	3207	;
	3208	"RTN","IBE CEA",5,0)
	3209	EN ; Cance l/Edit/Add Patient C harges -- invoke the List Mana ger.
	3210	"RTN","IBE CEA",6,0)
	3211	K XQORS,V ALMEVL
	3212	"RTN","IBE CEA",7,0)
	3213	EN1 ; Entr ypoint to avoid kill ing XQORS
	3214	"RTN","IBE CEA",8,0)
	3215	I '$$CHEC K^IBECEAU( 1) G ENQ
	3216	"RTN","IBE CEA",9,0)
	3217	D EN^VALM ("IB CHARG ES")
	3218	"RTN","IBE CEA",10,0)
	3219	ENQ K IBSI TE,IBFAC,I BSERV
	3220	"RTN","IBE CEA",11,0)
	3221	Q
	3222	"RTN","IBE CEA",12,0)
	3223	;
	3224	"RTN","IBE CEA",13,0)
	3225	EN1AR ; AR entry for charge ma intenance
	3226	"RTN","IBE CEA",14,0)
	3227	N DIR,X,Y
	3228	"RTN","IBE CEA",15,0)
	3229	D EN1
	3230	"RTN","IBE CEA",16,0)
	3231	S DIR(0)= "EA",DIR(" A")="PRESS RETURN TO CONTINUE. "
	3232	"RTN","IBE CEA",17,0)
	3233	W ! D ^DI R K DIR
	3234	"RTN","IBE CEA",18,0)
	3235	Q
	3236	"RTN","IBE CEA",19,0)
	3237	;
	3238	"RTN","IBE CEA",20,0)
	3239	INIT ; Lis t Manager (IB CHARGE S) main en try point.
	3240	"RTN","IBE CEA",21,0)
	3241	S IBJOB=4 ,IBWHER="I BECEA",IBD UZ=DUZ
	3242	"RTN","IBE CEA",22,0)
	3243	S IBACMAR ="^TMP(""I BACM"",$J) ",IBACMIDX ="^TMP(""I BACMIDX"", $J)",VALMI DX="^TMP(" "IBCMLIDX" ",$J)"
	3244	"RTN","IBE CEA",23,0)
	3245	I '$$SLPT S VALMQUI T="" D FNL G INITQ
	3246	"RTN","IBE CEA",24,0)
	3247	I $$SLDT S VALMQUIT ="" D FNL G INITQ
	3248	"RTN","IBE CEA",25,0)
	3249	I $$SLRX S VALMQUIT ="" D FNL G INITQ
	3250	"RTN","IBE CEA",26,0)
	3251	D ARRAY^I BECEA0
	3252	"RTN","IBE CEA",27,0)
	3253	INITQ Q
	3254	"RTN","IBE CEA",28,0)
	3255	;
	3256	"RTN","IBE CEA",29,0)
	3257	PAT ; 'Cha nge Patien t' protoco l entry ac tion.
	3258	"RTN","IBE CEA",30,0)
	3259	I $D(REC) S (GOTPAT ,DFN)=0 ;I B2.0568
	3260	"RTN","IBE CEA",31,0)
	3261	N IBDFN S IBDFN=DFN
	3262	"RTN","IBE CEA",32,0)
	3263	I '$$SLPT D MSG S D FN=IBDFN K REC,GOTPA T G PATQ ; IB2.0568
	3264	"RTN","IBE CEA",33,0)
	3265	DATE ; 'Ch ange Date' protocol entry acti on.
	3266	"RTN","IBE CEA",34,0)
	3267	N IBDT1,I BDT2,IBRXX X S IBDT1= IBABEG,IBD T2=IBAEND, IBRXXX=IBR X
	3268	"RTN","IBE CEA",35,0)
	3269	I $$SLDT D MSG S IB ABEG=IBDT1 ,IBAEND=IB DT2 S:$D(I BDFN) DFN= IBDFN G PA TQ
	3270	"RTN","IBE CEA",36,0)
	3271	I $$SLRX D MSG S IB ABEG=IBDT1 ,IBAEND=IB DT2,IBRX=I BRXXX S:$D (IBDFN) DF N=IBDFN G PATQ
	3272	"RTN","IBE CEA",37,0)
	3273	D ARRAY^I BECEA0,HDR S VALMBCK ="R"
	3274	"RTN","IBE CEA",38,0)
	3275	PATQ Q
	3276	"RTN","IBE CEA",39,0)
	3277	;
	3278	"RTN","IBE CEA",40,0)
	3279	MSG ; Quic k message display.
	3280	"RTN","IBE CEA",41,0)
	3281	N DIR,DIR UT,DUOUT,D TOUT,X,Y
	3282	"RTN","IBE CEA",42,0)
	3283	W !!,*7," No changes were made !",!
	3284	"RTN","IBE CEA",43,0)
	3285	S DIR(0)= "E" D ^DIR S VALMBCK =""
	3286	"RTN","IBE CEA",44,0)
	3287	Q
	3288	"RTN","IBE CEA",45,0)
	3289	;
	3290	"RTN","IBE CEA",46,0)
	3291	HDR ; Buil d screen h eader.
	3292	"RTN","IBE CEA",47,0)
	3293	S IBNAM=$ $PT^IBEFUN C(DFN)
	3294	"RTN","IBE CEA",48,0)
	3295	S VALMHDR (1)=$$SETS TR^VALM1($ $FDATE^VAL M1(IBABEG) _" THRU "_ $$FDATE^VA LM1(IBAEND ),"Cancel/ Edit/Add C harges",59 ,22)
	3296	"RTN","IBE CEA",49,0)
	3297	S VALMHDR (2)=$E("Pa tient: "_$ P(IBNAM,"^ "),1,25)_" "_$E(IBNA M)_$P(IBNA M,"^",3)
	3298	"RTN","IBE CEA",50,0)
	3299	Q
	3300	"RTN","IBE CEA",51,0)
	3301	;
	3302	"RTN","IBE CEA",52,0)
	3303	SLPT() ; S elect a pa tient.
	3304	"RTN","IBE CEA",53,0)
	3305	N DIC,X,Y
	3306	"RTN","IBE CEA",54,0)
	3307	I $G(GOTP AT) Q DFN ;IB2.05 68
	3308	"RTN","IBE CEA",55,0)
	3309	N DPTNOFZ Y S DPTNOF ZY=1 ;Sup press PATI ENT file f uzzy looku ps
	3310	"RTN","IBE CEA",56,0)
	3311	S DIC="^D PT(",DIC(0 )="AEMQ" D ^DIC S DF N=+Y
	3312	"RTN","IBE CEA",57,0)
	3313	Q Y>0
	3314	"RTN","IBE CEA",58,0)
	3315	;
	3316	"RTN","IBE CEA",59,0)
	3317	SLDT() ; S elect Char ge dates.
	3318	"RTN","IBE CEA",60,0)
	3319	N DIR,DIR UT,DUOUT,D TOUT,X,Y
	3320	"RTN","IBE CEA",61,0)
	3321	S DIR(0)= "DA^286010 1:NOW:EX", DIR("A")=" Search for CHARGES f rom: ",DIR ("B")=$$DA T2^IBOUTL( $$FMADD^XL FDT(DT,-36 5)) D ^DIR S IBABEG= +Y G:'Y SL DTQ
	3322	"RTN","IBE CEA",62,0)
	3323	S DIR(0)= "DA^"_+Y_" :NOW:EX",D IR("A")=" to: ",DIR( "B")=$$DAT 2^IBOUTL(D T) D ^DIR S IBAEND=+ Y+.999999
	3324	"RTN","IBE CEA",63,0)
	3325	SLDTQ Q $D (DIRUT)!($ D(DUOUT))
	3326	"RTN","IBE CEA",64,0)
	3327	;
	3328	"RTN","IBE CEA",65,0)
	3329	SLRX() ; I nclude Rx copay char ges?
	3330	"RTN","IBE CEA",66,0)
	3331	N DIR,DIR UT,DUOUT,D TOUT,X,Y
	3332	"RTN","IBE CEA",67,0)
	3333	S DIR(0)= "Y",DIR("A ")="Includ e RX COPAY charges", DIR("B")=" NO" D ^DIR S IBRX=Y
	3334	"RTN","IBE CEA",68,0)
	3335	Q $D(DIRU T)!($D(DUO UT))
	3336	"RTN","IBE CEA",69,0)
	3337	;
	3338	"RTN","IBE CEA",70,0)
	3339	RCFNL ;
	3340	"RTN","IBE CEA",71,0)
	3341	K:$D(IBAC MAR) @IBAC MAR,IBACMA R K:$D(IBA CMIDX) @IB ACMIDX,IBA CMIDX K:$D (VALMIDX) @VALMIDX,V ALMIDX
	3342	"RTN","IBE CEA",72,0)
	3343	K IBABEG, IBAEND,DFN ,IBAT,IBAX ,IBY,VA,IB RX,IBWHER, X,^TMP("IB ECEA",$J), ^TMP("IBCM LIDX",$J), IBSAVY,IBA RTYP,IBPRN T,IBDUZ,IB JOB,IBXA,I BNOW,IBLDT ,IBL,IBIL, IBNAM
	3344	"RTN","IBE CEA",73,0)
	3345	Q
	3346	"RTN","IBE CEA",74,0)
	3347	;
	3348	"RTN","IBE CEA",75,0)
	3349	FNL ; List Manager ( IB CHARGES ) exit act ion.
	3350	"RTN","IBE CEA",76,0)
	3351	K:$D(IBAC MAR) @IBAC MAR,IBACMA R K:$D(IBA CMIDX) @IB ACMIDX,IBA CMIDX K:$D (VALMIDX) @VALMIDX,V ALMIDX
	3352	"RTN","IBE CEA",77,0)
	3353	K IBABEG, IBAEND,DFN ,IBAT,IBAX ,IBY,VA,IB RX,IBWHER, X,^TMP("IB ECEA",$J), ^TMP("IBCM LIDX",$J), DFN,IBSAVY ,IBARTYP,I BPRNT,IBDU Z,IBJOB,IB XA,IBNOW,I BLDT,IBL,I BIL,IBNAM
	3354	"RTN","IBE CEA",78,0)
	3355	Q
	3356	"RTN","IBE CEA",79,0)
	3357	;
	3358	"RTN","IBE CEA",80,0)
	3359	EXIT Q
	3360	"RTN","IBJ DB21")
	3361	0^18^B1274 96258^B733 70335
	3362	"RTN","IBJ DB21",1,0)
	3363	IBJDB21 ;A LB/RB - RE ASONS NOT BILLABLE R EPORT (COM PILE) ;19- JUN-00
	3364	"RTN","IBJ DB21",2,0)
	3365	;;2.0;INT EGRATED BI LLING;12 3,159,185, 399,437,45 8,568;21 -MAR-94;Bu ild 38
	3366	"RTN","IBJ DB21",3,0)
	3367	;;Per VA Directive 6402, this routine s hould not be modifie d.
	3368	"RTN","IBJ DB21",4,0)
	3369	;;
	3370	"RTN","IBJ DB21",5,0)
	3371	EN ; - Ent ry point f rom IBJDB2 .
	3372	"RTN","IBJ DB21",6,0)
	3373	K ^TMP("I BJDB2",$J) ,IB,IBE,EN CTYP,EPIEN ,IBADMDT,R ELBILL
	3374	"RTN","IBJ DB21",7,0)
	3375	I '$G(IBX TRACT) D
	3376	"RTN","IBJ DB21",8,0)
	3377	. F X=1:1 :4 I IBSEL [X S IBE(X )=IBEPS(X) ; Set epi sodes for report.
	3378	"RTN","IBJ DB21",9,0)
	3379	;
	3380	"RTN","IBJ DB21",10,0 )
	3381	; - Print the heade r line for the Excel spreadshe et
	3382	"RTN","IBJ DB21",11,0 )
	3383	I $G(IBEX CEL) D PHD L
	3384	"RTN","IBJ DB21",12,0 )
	3385	;
	3386	"RTN","IBJ DB21",13,0 )
	3387	; - Compi le reason not billab le (RNB) d ata for ep isode.
	3388	"RTN","IBJ DB21",14,0 )
	3389	S IBRNB=0 F S IBRN B=$S(IBSRN B'="A":$O( IBSRNB(IBR NB)),1:$O( ^IBE(356.8 ,IBRNB))) Q:'IBRNB D
	3390	"RTN","IBJ DB21",15,0 )
	3391	.S IB0=0 F S IB0=$ O(^IBT(356 ,"AR",IBRN B,IB0)) Q: 'IB0 D
	3392	"RTN","IBJ DB21",16,0 )
	3393	..S IBN0= $G(^IBT(35 6,IB0,0)), IBN1=$G(^I BT(356,IB0 ,1)) Q:'IB N0!('IBN1)
	3394	"RTN","IBJ DB21",17,0 )
	3395	..S IBEP= +$P(IBN0,U ,18) I IBS EL'[IBEP Q ; Get ep isode.
	3396	"RTN","IBJ DB21",18,0 )
	3397	..S (IBRN B1,IBSORT1 )=$P($G(^I BE(356.8,I BRNB,0)),U )
	3398	"RTN","IBJ DB21",19,0 )
	3399	..;
	3400	"RTN","IBJ DB21",20,0 )
	3401	..; - Get valid dat e entered/ episode da te and amo unt for re port.
	3402	"RTN","IBJ DB21",21,0 )
	3403	..S IBEPD =+$P(IBN0, U,6)\1,IBD EN=+IBN1\1
	3404	"RTN","IBJ DB21",22,0 )
	3405	..S IBDT= $S($E(IBD) ="D":IBDEN ,1:IBEPD)
	3406	"RTN","IBJ DB21",23,0 )
	3407	..Q:IBDT< IBBDT!(IBD T>IBEDT)
	3408	"RTN","IBJ DB21",24,0 )
	3409	..S IBAMT =$$AMOUNT( IBEP,IB0)
	3410	"RTN","IBJ DB21",25,0 )
	3411	..I IBAMT <0 Q ;Qui t if amoun t is -1 *5 68
	3412	"RTN","IBJ DB21",26,0 )
	3413	..;
	3414	"RTN","IBJ DB21",27,0 )
	3415	..; - Get division, if necess ary.
	3416	"RTN","IBJ DB21",28,0 )
	3417	..I IBSD D Q:'VAUT D&('$D(VAU TD(IBDIV)) )
	3418	"RTN","IBJ DB21",29,0 )
	3419	...S IBDI V=$$DIV^IB JD1(IB0)
	3420	"RTN","IBJ DB21",30,0 )
	3421	..E S IB DIV=$S($G( IBEXCEL):+ $$PRIM^VAS ITE(),1:0)
	3422	"RTN","IBJ DB21",31,0 )
	3423	..;
	3424	"RTN","IBJ DB21",32,0 )
	3425	..; - Pro vider & Sp ecialty
	3426	"RTN","IBJ DB21",33,0 )
	3427	..S (IBPR V,IBSPC)=" ",IBQT=0
	3428	"RTN","IBJ DB21",34,0 )
	3429	..I IBEP= 1!(IBEP=2) D I IBQT Q
	3430	"RTN","IBJ DB21",35,0 )
	3431	...S IBPR SP=$$PRVSP C(IBEP,IB0 )
	3432	"RTN","IBJ DB21",36,0 )
	3433	...I IBSP RV'="A",'$ D(IBSPRV(+ IBPRSP)) S IBQT=1 Q
	3434	"RTN","IBJ DB21",37,0 )
	3435	...I IBEP =1,IBSISP' ="A",'$D(I BSISP(+$P( IBPRSP,U,3 ))) S IBQT =1 Q
	3436	"RTN","IBJ DB21",38,0 )
	3437	...I IBEP =2,IBSOSP' ="A",'$D(I BSOSP(+$P( IBPRSP,U,3 ))) S IBQT =1 Q
	3438	"RTN","IBJ DB21",39,0 )
	3439	...S IBPR V=$S($P(IB PRSP,U,2)' ="":$P(IBP RSP,U,2),1 :" UNKNO WN ")
	3440	"RTN","IBJ DB21",40,0 )
	3441	...S IBSP C=$S($P(IB PRSP,U,4)' ="":$P(IBP RSP,U,4),1 :" UNKNO WN ")
	3442	"RTN","IBJ DB21",41,0 )
	3443	..;
	3444	"RTN","IBJ DB21",42,0 )
	3445	..; - Get remaining data for detailed r eport.
	3446	"RTN","IBJ DB21",43,0 )
	3447	..S DFN=+ $P(IBN0,U, 2)
	3448	"RTN","IBJ DB21",44,0 )
	3449	..D DEM^V ADPT S IBP T=$E(VADM( 1),1,25),I BSSN=$P(VA DM(2),U)
	3450	"RTN","IBJ DB21",45,0 )
	3451	..S DIC=" ^VA(200,", DA=+$P(IBN 1,U,4),DR= ".01",DIQ= "IBCLK" D EN^DIQ1
	3452	"RTN","IBJ DB21",46,0 )
	3453	..S IBCLK =$E($G(IBC LK(200,DA, .01)),1,20 )
	3454	"RTN","IBJ DB21",47,0 )
	3455	..I ($P(I BN0,U,18)= 2)&($$EXTE RNAL^DILFD (356,.19," ",$P(IBN0, U,19))["72 HOUR RULE ") D
	3456	"RTN","IBJ DB21",48,0 )
	3457	...S IBAD MDT=$$ADMD T^IBTUTL5( DFN,$P(IBN 0,U,6))
	3458	"RTN","IBJ DB21",49,0 )
	3459	..E S IB ADMDT=""
	3460	"RTN","IBJ DB21",50,0 )
	3461	..S ENCTY P=$P(^IBE( 356.6,$P(I BN0,U,18), 0),U,3) S EPDT=$E($P (IBN0,U,6) ,1,7)
	3462	"RTN","IBJ DB21",51,0 )
	3463	..S EPIEN =$S(ENCTYP =3:$P(IBN0 ,U,8),ENCT YP=4:$P(IB N0,U,9),1: "")
	3464	"RTN","IBJ DB21",52,0 )
	3465	..S RELBI LL=$$RELBI L^IBTUTL5( EPIEN,EPDT ,DFN,ENCTY P)
	3466	"RTN","IBJ DB21",53,0 )
	3467	..;
	3468	"RTN","IBJ DB21",54,0 )
	3469	..; - Get totals fo r summary.
	3470	"RTN","IBJ DB21",55,0 )
	3471	..I '$D(I B(IBDIV,IB EP,IBRNB)) S IB(IBDI V,IBEP,IBR NB)="0^0"
	3472	"RTN","IBJ DB21",56,0 )
	3473	..S $P(IB (IBDIV,IBE P,IBRNB),U )=$P(IB(IB DIV,IBEP,I BRNB),U)+1
	3474	"RTN","IBJ DB21",57,0 )
	3475	..S $P(IB (IBDIV,IBE P,IBRNB),U ,2)=$P(IB( IBDIV,IBEP ,IBRNB),U, 2)+IBAMT
	3476	"RTN","IBJ DB21",58,0 )
	3477	..I IBRPT ="S" Q
	3478	"RTN","IBJ DB21",59,0 )
	3479	..;
	3480	"RTN","IBJ DB21",60,0 )
	3481	..S IBSOR T1=$S(IBSO RT="P":IBP RV,IBSORT= "S":IBSPC, 1:IBSORT1)
	3482	"RTN","IBJ DB21",61,0 )
	3483	..S:IBSOR T1="" IBSO RT1=" "
	3484	"RTN","IBJ DB21",62,0 )
	3485	..;
	3486	"RTN","IBJ DB21",63,0 )
	3487	..I $G(IB EXCEL) D Q
	3488	"RTN","IBJ DB21",64,0 )
	3489	...W !,$E ($P($G(^DG (40.8,IBDI V,0)),U),1 ,25),U
	3490	"RTN","IBJ DB21",65,0 )
	3491	...W $S(I BEP<4:$E(I BE(IBEP)), 1:"H"),U,I BPT,U,$E(I BSSN,6,10) ,U
	3492	"RTN","IBJ DB21",66,0 )
	3493	...W $E($ $INS^IBJD1 (+$P(IBN0, U,2),IBEPD ),1,25),U
	3494	"RTN","IBJ DB21",67,0 )
	3495	...W $$DT ^IBJD(IBEP D,1),U,$$D T^IBJD(IBD EN,1),U
	3496	"RTN","IBJ DB21",68,0 )
	3497	...W $$DT ^IBJD($P(I BN1,U,3),1 ),U,IBCLK, U,IBADMDT, U,$E(IBRNB 1,1,25),U
	3498	"RTN","IBJ DB21",69,0 )
	3499	...W $E(I BPRV,1,25) ,U,$E(IBSP C,1,25),U, IBAMT,U
	3500	"RTN","IBJ DB21",70,0 )
	3501	...I RELB ILL>0 F X= 2:1:$P(REL BILL,";",1 )+1 W $P(R ELBILL,";" ,X)_" "
	3502	"RTN","IBJ DB21",71,0 )
	3503	...I RELB ILL<0 W ""
	3504	"RTN","IBJ DB21",72,0 )
	3505	...W U,$P (IBN1,U,8)
	3506	"RTN","IBJ DB21",73,0 )
	3507	..;
	3508	"RTN","IBJ DB21",74,0 )
	3509	..S X=IBE PD_U_IBDEN _U_$P(IBN1 ,U,3)_U_IB CLK_U_IBRN B1
	3510	"RTN","IBJ DB21",75,0 )
	3511	..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
	3512	"RTN","IBJ DB21",76,0 )
	3513	..S ^TMP( "IBJDB2",$ J,IBDIV,IB EP,IBSORT1 ,IBPT_"@@" _$E(IBSSN, 6,10))=$$I NS^IBJD1(+ $P(IBN0,U, 2),IBEPD)
	3514	"RTN","IBJ DB21",77,0 )
	3515	..S ^TMP( "IBJDB2",$ J,IBDIV,IB EP,IBSORT1 ,IBPT_"@@" _$E(IBSSN, 6,10),+IBN 0)=X
	3516	"RTN","IBJ DB21",78,0 )
	3517	;
	3518	"RTN","IBJ DB21",79,0 )
	3519	I '$G(IBE XCEL) D EN ^IBJDB22 ; Print rep ort(s).
	3520	"RTN","IBJ DB21",80,0 )
	3521	;
	3522	"RTN","IBJ DB21",81,0 )
	3523	ENQ K ^TMP ("IBJDB2")
	3524	"RTN","IBJ DB21",82,0 )
	3525	K DA,DIC, DIQ,DR,IB, IB0,IBAMT, IBCLK,IBDE N,IBDIV,IB DT,IBE,IBE P,IBEPD,IB I
	3526	"RTN","IBJ DB21",83,0 )
	3527	K IBN0,IB N1,IBN2,IB PRSP,IBPRV ,IBPT,IBQT ,IBRNB,IBR NB1,IBSORT 1,IBSPC
	3528	"RTN","IBJ DB21",84,0 )
	3529	K IBSSN,V ADM,X1,X2
	3530	"RTN","IBJ DB21",85,0 )
	3531	Q
	3532	"RTN","IBJ DB21",86,0 )
	3533	;
	3534	"RTN","IBJ DB21",87,0 )
	3535	AMOUNT(EPS ,CLM) ; Re turn the A mount not billed
	3536	"RTN","IBJ DB21",88,0 )
	3537	; Input: EPS - Epis ode(1=Inpa tient,2=Ou tpatient,3 =Prosthet. ,4=Prescr. )
	3538	"RTN","IBJ DB21",89,0 )
	3539	; CLM - Poin ter to Cla im Trackin g File (#3 56)
	3540	"RTN","IBJ DB21",90,0 )
	3541	;Output: AMOUNT not billed
	3542	"RTN","IBJ DB21",91,0 )
	3543	;
	3544	"RTN","IBJ DB21",92,0 )
	3545	N ADM,ADM DT,AMOUNT, BLBS,BLDT, CPT,CPTLST ,DA,DR,DCH D,DFN,DIC, DIQ,DIV,DR G,SPCLTY
	3546	"RTN","IBJ DB21",93,0 )
	3547	N IBRX,EN C,ENCDT,EP DT,PFT,PRS T,PTF,RIMB ,VCPT,TTCS T,X
	3548	"RTN","IBJ DB21",94,0 )
	3549	;
	3550	"RTN","IBJ DB21",95,0 )
	3551	S AMOUNT= 0,X=$G(^IB T(356,CLM, 0))
	3552	"RTN","IBJ DB21",96,0 )
	3553	S ENC=+$P (X,U,4) ; Encoun ter (Po inter to # 409.68)
	3554	"RTN","IBJ DB21",97,0 )
	3555	S ADM=+$P (X,U,5) ; Admiss ion (Po inter to # 405)
	3556	"RTN","IBJ DB21",98,0 )
	3557	S PRST=+$ P(X,U,9) ; Prothe tics (Po inter to # 660)
	3558	"RTN","IBJ DB21",99,0 )
	3559	S EPDT=$P (X,U,6) ; Episod e Date (FM format)
	3560	"RTN","IBJ DB21",100, 0)
	3561	S IBRX=+$ P(X,U,8)
	3562	"RTN","IBJ DB21",101, 0)
	3563	;
	3564	"RTN","IBJ DB21",102, 0)
	3565	; - Assum es REIMBUR SABLE INS. as the RA TE TYPE
	3566	"RTN","IBJ DB21",103, 0)
	3567	S RIMB=$O (^DGCR(399 .3,"B","RE IMBURSABLE INS.",0)) I 'RIMB S RIMB=8
	3568	"RTN","IBJ DB21",104, 0)
	3569	;
	3570	"RTN","IBJ DB21",105, 0)
	3571	G @("AMT" _EPS)
	3572	"RTN","IBJ DB21",106, 0)
	3573	;
	3574	"RTN","IBJ DB21",107, 0)
	3575	AMT1 ; - I npatient C harges
	3576	"RTN","IBJ DB21",108, 0)
	3577	I 'ADM S AMOUNT=-1 G QAMT
	3578	"RTN","IBJ DB21",109, 0)
	3579	S X=$G(^D GPM(ADM,0) ) I X="" S AMOUNT=-1 G QAMT
	3580	"RTN","IBJ DB21",110, 0)
	3581	S PTF=$P( X,U,16) I 'PTF S AMO UNT=-1 G Q AMT
	3582	"RTN","IBJ DB21",111, 0)
	3583	S ADMDT=$ P(X,U)\1,D FN=+$P(X,U ,3)
	3584	"RTN","IBJ DB21",112, 0)
	3585	I $P(X,U, 17) S DCHD =$P($G(^DG PM(+$P(X,U ,17),0)),U )\1
	3586	"RTN","IBJ DB21",113, 0)
	3587	I '$G(DCH D) S DCHD= $$DT^XLFDT ()
	3588	"RTN","IBJ DB21",114, 0)
	3589	;
	3590	"RTN","IBJ DB21",115, 0)
	3591	K ^TMP($J ,"IBCRC-PT F"),^TMP($ J,"IBCRC-D IV"),^TMP( $J,"IBCRC- INDT")
	3592	"RTN","IBJ DB21",116, 0)
	3593	D PTF^IBC RBG(PTF) I '$D(^TMP( $J,"IBCRC- PTF")) S A MOUNT=-1 G QAMT ;*5 68
	3594	"RTN","IBJ DB21",117, 0)
	3595	D PTFDV^I BCRBG(PTF) I '$D(^TM P($J,"IBCR C-DIV")) S AMOUNT=-1 G QAMT ; *568
	3596	"RTN","IBJ DB21",118, 0)
	3597	D BSLOS^I BCRBG(ADMD T,DCHD,1,A DM,0) I '$ D(^TMP($J, "IBCRC-IND T")) S AMO UNT=-1 G Q AMT ;*568
	3598	"RTN","IBJ DB21",119, 0)
	3599	;
	3600	"RTN","IBJ DB21",120, 0)
	3601	S BLDT=""
	3602	"RTN","IBJ DB21",121, 0)
	3603	F S BLDT =$O(^TMP($ J,"IBCRC-I NDT",BLDT) ) Q:BLDT=" " D
	3604	"RTN","IBJ DB21",122, 0)
	3605	.S X=^TMP ($J,"IBCRC -INDT",BLD T)
	3606	"RTN","IBJ DB21",123, 0)
	3607	.S BLBS=$ P(X,U,2),D RG=$P(X,U, 4),DIV=$P( X,U,5),SPC LTY=$P(X,U ,6)
	3608	"RTN","IBJ DB21",124, 0)
	3609	.;
	3610	"RTN","IBJ DB21",125, 0)
	3611	.; - Tort Liable Ch arge (prio r to 09/01 /99)
	3612	"RTN","IBJ DB21",126, 0)
	3613	.I BLDT<2 990901 D Q
	3614	"RTN","IBJ DB21",127, 0)
	3615	..S AMOUN T=AMOUNT+$ $BICOST^IB CRCI(RIMB, 1,BLDT,"IN PATIENT BE DSECTION S TAY",BLBS)
	3616	"RTN","IBJ DB21",128, 0)
	3617	.;
	3618	"RTN","IBJ DB21",129, 0)
	3619	.; - Reas onable Cha rges (on 0 9/01/99 or later)
	3620	"RTN","IBJ DB21",130, 0)
	3621	.I $$NODR G^IBCRBG2( SPCLTY)["O bservation " Q
	3622	"RTN","IBJ DB21",131, 0)
	3623	.I $$NODR G^IBCRBG2( SPCLTY)["N ursing Hom e Care" D Q
	3624	"RTN","IBJ DB21",132, 0)
	3625	..S BLBS= $$MCCRUTL^ IBCRU1("SK ILLED NURS ING CARE", 25)
	3626	"RTN","IBJ DB21",133, 0)
	3627	..S AMOUN T=AMOUNT+$ $BICOST^IB CRCI(RIMB, 1,BLDT,"IN PATIENT BE DSECTION S TAY",BLBS, "",DIV,"", 1)
	3628	"RTN","IBJ DB21",134, 0)
	3629	.;
	3630	"RTN","IBJ DB21",135, 0)
	3631	.S BLBS=$ $BSUPD^IBC RBG2(+SPCL TY,BLDT,1)
	3632	"RTN","IBJ DB21",136, 0)
	3633	.S AMOUNT =AMOUNT+$$ BICOST^IBC RCI(RIMB,1 ,BLDT,"INP ATIENT DRG ",DRG,"",D IV,"",1,BL BS)
	3634	"RTN","IBJ DB21",137, 0)
	3635	;
	3636	"RTN","IBJ DB21",138, 0)
	3637	; - Add t he Profess ional Aver age Amount per Episo de (Reason .Chg only)
	3638	"RTN","IBJ DB21",139, 0)
	3639	I EPDT'<2 990901 S A MOUNT=AMOU NT+$$AVG(E PDT)
	3640	"RTN","IBJ DB21",140, 0)
	3641	;
	3642	"RTN","IBJ DB21",141, 0)
	3643	; - Subtr act the am ount bille d for this Episode
	3644	"RTN","IBJ DB21",142, 0)
	3645	S AMOUNT= AMOUNT-$$C LAMT(DFN,E PDT,1) I A MOUNT=0 S AMOUNT=-1 ;*568
	3646	"RTN","IBJ DB21",143, 0)
	3647	;
	3648	"RTN","IBJ DB21",144, 0)
	3649	K ^TMP($J ,"IBCRC-PT F"),^TMP($ J,"IBCRC-D IV"),^TMP( $J,"IBCRC- INDT")
	3650	"RTN","IBJ DB21",145, 0)
	3651	;
	3652	"RTN","IBJ DB21",146, 0)
	3653	G QAMT
	3654	"RTN","IBJ DB21",147, 0)
	3655	;
	3656	"RTN","IBJ DB21",148, 0)
	3657	AMT2 ; - O utpatient Charges
	3658	"RTN","IBJ DB21",149, 0)
	3659	S X=$$GET OE^SDOE(EN C),ENCDT=+ $P(X,U),DF N=+$P(X,U, 2),DIV=$P( X,U,11)
	3660	"RTN","IBJ DB21",150, 0)
	3661	;
	3662	"RTN","IBJ DB21",151, 0)
	3663	; - Tort Liable Cha rge (prior to 09/01/ 99)
	3664	"RTN","IBJ DB21",152, 0)
	3665	I ENCDT<2 990901 D G QAMT
	3666	"RTN","IBJ DB21",153, 0)
	3667	. S AMOUN T=+$$BICOS T^IBCRCI(R IMB,3,ENCD T,"OUTPATI ENT VISIT DATE")
	3668	"RTN","IBJ DB21",154, 0)
	3669	;
	3670	"RTN","IBJ DB21",155, 0)
	3671	S AMOUNT= $$OPT(ENC, EPDT) ;*5 68
	3672	"RTN","IBJ DB21",156, 0)
	3673	G QAMT ; *568
	3674	"RTN","IBJ DB21",157, 0)
	3675	;
	3676	"RTN","IBJ DB21",158, 0)
	3677	AMT3 ; Pro sthetic Ch arges
	3678	"RTN","IBJ DB21",159, 0)
	3679	N NTBLD
	3680	"RTN","IBJ DB21",160, 0)
	3681	S NTBLD=$ $PRSAMT^IB TUTL5(EPDT ,PRST) I N TBLD=0 S A MOUNT=-1 G QAMT ;*5 68
	3682	"RTN","IBJ DB21",161, 0)
	3683	S DIC="^R MPR(660,", DA=PRST,DR ="14",DIQ= "TTCST" D EN^DIQ1
	3684	"RTN","IBJ DB21",162, 0)
	3685	S AMOUNT= +$G(TTCST( 660,DA,14) )
	3686	"RTN","IBJ DB21",163, 0)
	3687	G QAMT
	3688	"RTN","IBJ DB21",164, 0)
	3689	;
	3690	"RTN","IBJ DB21",165, 0)
	3691	AMT4 ; - P rescriptio n Charges
	3692	"RTN","IBJ DB21",166, 0)
	3693	;
	3694	"RTN","IBJ DB21",167, 0)
	3695	; Protect Rx intern al entry # before RX AMT call s witches to RX number
	3696	"RTN","IBJ DB21",168, 0)
	3697	N IBRXIEN ,NTBLD S I BRXIEN=IBR X
	3698	"RTN","IBJ DB21",169, 0)
	3699	;
	3700	"RTN","IBJ DB21",170, 0)
	3701	; - Tort Liable Cha rge & Reas onable Cha rge (same source)
	3702	"RTN","IBJ DB21",171, 0)
	3703	S NTBLD=$ $RXAMT^IBT UTL5(EPDT, IBRX) I NT BLD=0 S AM OUNT=-1 G QAMT ;*56 8
	3704	"RTN","IBJ DB21",172, 0)
	3705	;
	3706	"RTN","IBJ DB21",173, 0)
	3707	; Patch 4 37 update to call ch arge maste r with eno ugh inform ation
	3708	"RTN","IBJ DB21",174, 0)
	3709	; to look up actual cost of pr escription
	3710	"RTN","IBJ DB21",175, 0)
	3711	;
	3712	"RTN","IBJ DB21",176, 0)
	3713	N IBBI,IB RSNEW
	3714	"RTN","IBJ DB21",177, 0)
	3715	;
	3716	"RTN","IBJ DB21",178, 0)
	3717	; check c harge mast er for the type of b illing--VA Cost or n ot
	3718	"RTN","IBJ DB21",179, 0)
	3719	S IBBI=$$ EVNTITM^IB CRU3(+RIMB ,3,"PRESCR IPTION FIL L",EPDT,.I BRSNEW)
	3720	"RTN","IBJ DB21",180, 0)
	3721	;
	3722	"RTN","IBJ DB21",181, 0)
	3723	S DFN=$$F ILE^IBRXUT L(IBRXIEN, 2)
	3724	"RTN","IBJ DB21",182, 0)
	3725	I $G(DFN) >0&(IBBI[" VA COST") D
	3726	"RTN","IBJ DB21",183, 0)
	3727	. N IBQT Y,IBCOST,I BRFNUM,IBS UBND,IBFEE ,IBRXNODE
	3728	"RTN","IBJ DB21",184, 0)
	3729	.; if th is is a re fill look up the ref ill info f or cost an d quantity
	3730	"RTN","IBJ DB21",185, 0)
	3731	. S IBRF NUM=$$RFLN UM^IBRXUTL (IBRXIEN,E PDT,"")
	3732	"RTN","IBJ DB21",186, 0)
	3733	. I IBRF NUM>0 D
	3734	"RTN","IBJ DB21",187, 0)
	3735	.. S I BSUBND=$$Z EROSUB^IBR XUTL(DFN,I BRXIEN,IBR FNUM)
	3736	"RTN","IBJ DB21",188, 0)
	3737	.. S I BQTY=$P($G (IBSUBND), U,4)
	3738	"RTN","IBJ DB21",189, 0)
	3739	.. S I BCOST=$P($ G(IBSUBND) ,U,11)
	3740	"RTN","IBJ DB21",190, 0)
	3741	.;
	3742	"RTN","IBJ DB21",191, 0)
	3743	.; if th is was an original f ill look u p zero nod e for Rx i nfo
	3744	"RTN","IBJ DB21",192, 0)
	3745	. E D
	3746	"RTN","IBJ DB21",193, 0)
	3747	.. S I BRXNODE=$$ RXZERO^IBR XUTL(DFN,I BRXIEN)
	3748	"RTN","IBJ DB21",194, 0)
	3749	.. S I BQTY=$P($G (IBRXNODE) ,U,7)
	3750	"RTN","IBJ DB21",195, 0)
	3751	.. S I BCOST=$P($ G(IBRXNODE ),U,17)
	3752	"RTN","IBJ DB21",196, 0)
	3753	.;
	3754	"RTN","IBJ DB21",197, 0)
	3755	. S IBRS NEW=+$O(IB RSNEW($P(I BBI,";"),0 ))
	3756	"RTN","IBJ DB21",198, 0)
	3757	. S AMOU NT=$J(+$$R ATECHG^IBC RCC(+IBRSN EW,IBQTY*I BCOST,EPDT ,.IBFEE),0 ,2)
	3758	"RTN","IBJ DB21",199, 0)
	3759	E D
	3760	"RTN","IBJ DB21",200, 0)
	3761	. S AMOU NT=+$$BICO ST^IBCRCI( RIMB,3,EPD T,"PRESCRI PTION FILL ")
	3762	"RTN","IBJ DB21",201, 0)
	3763	;
	3764	"RTN","IBJ DB21",202, 0)
	3765	;
	3766	"RTN","IBJ DB21",203, 0)
	3767	QAMT I AMO UNT=0 S AM OUNT=-1 ;* 568
	3768	"RTN","IBJ DB21",204, 0)
	3769	Q AMOUNT
	3770	"RTN","IBJ DB21",205, 0)
	3771	;
	3772	"RTN","IBJ DB21",206, 0)
	3773	CLAMT(DFN, EPDT,PT) ; Returns t he Total A mount of C laims for Patient/Ep isode
	3774	"RTN","IBJ DB21",207, 0)
	3775	;
	3776	"RTN","IBJ DB21",208, 0)
	3777	; Input: DFN - Poi nter to th e Patient File #2
	3778	"RTN","IBJ DB21",209, 0)
	3779	; EPDT - Epi sode Date
	3780	"RTN","IBJ DB21",210, 0)
	3781	; PT - 0=O utpatient, 1=Inpatie nt
	3782	"RTN","IBJ DB21",211, 0)
	3783	;
	3784	"RTN","IBJ DB21",212, 0)
	3785	N CLAMT,C LM,DAY,IBD ,X
	3786	"RTN","IBJ DB21",213, 0)
	3787	S CLAMT=0 ,DAY=EPDT- 1,CLM=""
	3788	"RTN","IBJ DB21",214, 0)
	3789	F S CLM= $O(^DGCR(3 99,"C",DFN ,CLM)) Q:' CLM D
	3790	"RTN","IBJ DB21",215, 0)
	3791	.S X=$G(^ DGCR(399,C LM,0))
	3792	"RTN","IBJ DB21",216, 0)
	3793	.I $P($P( X,U,3),"." )=$P(EPDT, ".") D
	3794	"RTN","IBJ DB21",217, 0)
	3795	..S IBD=$ $CKBIL^IBT UBOU(CLM,P T) Q:IBD=" "
	3796	"RTN","IBJ DB21",218, 0)
	3797	..I '$P(I BD,U,3) Q ; Not aut horized
	3798	"RTN","IBJ DB21",219, 0)
	3799	..S CLAMT =CLAMT+$G( ^DGCR(399, CLM,"U1"))
	3800	"RTN","IBJ DB21",220, 0)
	3801	;
	3802	"RTN","IBJ DB21",221, 0)
	3803	QCLAMT Q C LAMT
	3804	"RTN","IBJ DB21",222, 0)
	3805	;
	3806	"RTN","IBJ DB21",223, 0)
	3807	OPT(IBOE,I BDT) ; - H as the out patient en counter be en billed?
	3808	"RTN","IBJ DB21",224, 0)
	3809	; Input : IBOE=poi nter to ou tpatient e ncounter i n file #40 9.68
	3810	"RTN","IBJ DB21",225, 0)
	3811	; IBDT=eve nt date CL AIMS TRACK ING(#356)
	3812	"RTN","IBJ DB21",226, 0)
	3813	;
	3814	"RTN","IBJ DB21",227, 0)
	3815	; ; *P re-set var iables: DF N=patient IEN, RIMB= bill rate
	3816	"RTN","IBJ DB21",228, 0)
	3817	;
	3818	"RTN","IBJ DB21",229, 0)
	3819	;
	3820	"RTN","IBJ DB21",230, 0)
	3821	I '$G(DFN )!('$G(IBD T))!('$G(R IMB))!('$G (IBOE)) S IBRTN=0 G OPTQ
	3822	"RTN","IBJ DB21",231, 0)
	3823	N IBCN,IB CPT,IBCT,I BDATA,IBDA Y,IBDIV,IB XX,IBYD,IB YY,IBZ,IBM RA,IBCPTSU M,IBTCHRG, IBRTN,IBAU TH
	3824	"RTN","IBJ DB21",232, 0)
	3825	; - Check to be sur e the enco unter is b illable.
	3826	"RTN","IBJ DB21",233, 0)
	3827	I $$INPT^ IBAMTS1(DF N,IBDT\1_. 2359) S IB RTN=-1 G O PTQ ; Bec ame inpati ent same d ay.
	3828	"RTN","IBJ DB21",234, 0)
	3829	I $$ENCL^ IBAMTS2(IB OE)["1" S IBRTN=-1 G OPTQ ; " ao^ir^sc^s wa^mst^hnc ^cv^shad" encounter.
	3830	"RTN","IBJ DB21",235, 0)
	3831	;
	3832	"RTN","IBJ DB21",236, 0)
	3833	;
	3834	"RTN","IBJ DB21",237, 0)
	3835	; - Gathe r all proc edures ass ociated wi th the enc ounter.
	3836	"RTN","IBJ DB21",238, 0)
	3837	D GETCPT^ SDOE(IBOE, "IBYY") I '$G(IBYY) S IBRTN=-1 G OPTQ ; Check CPT qty.
	3838	"RTN","IBJ DB21",239, 0)
	3839	;
	3840	"RTN","IBJ DB21",240, 0)
	3841	; - Deter mine the e ncounter d ivision.
	3842	"RTN","IBJ DB21",241, 0)
	3843	S IBDIV=+ $P($$GETOE ^SDOE(IBOE ),U,11) S: 'IBDIV IBD IV=+$$PRIM ^VASITE()
	3844	"RTN","IBJ DB21",242, 0)
	3845	;
	3846	"RTN","IBJ DB21",243, 0)
	3847	; - Build array of all billab le encount er procedu res.
	3848	"RTN","IBJ DB21",244, 0)
	3849	S IBXX=0 F S IBXX= $O(IBYY(IB XX)) Q:'IB XX D
	3850	"RTN","IBJ DB21",245, 0)
	3851	. ;
	3852	"RTN","IBJ DB21",246, 0)
	3853	. ; - Get procedure pointer a nd code.
	3854	"RTN","IBJ DB21",247, 0)
	3855	. S IBZ=+ IBYY(IBXX) ,IBCN=$P($ $CPT^ICPTC OD(IBZ),"^ ",2)
	3856	"RTN","IBJ DB21",248, 0)
	3857	. ;
	3858	"RTN","IBJ DB21",249, 0)
	3859	. ; - Ign ore LAB se rvices for vets with Medicare Supplement al coverag e.
	3860	"RTN","IBJ DB21",250, 0)
	3861	. I IBCN> 79999,IBCN <90000 Q
	3862	"RTN","IBJ DB21",251, 0)
	3863	. ;
	3864	"RTN","IBJ DB21",252, 0)
	3865	. ; - Get the insti tutional/p rofessiona l charge c omponents.
	3866	"RTN","IBJ DB21",253, 0)
	3867	. S IBCPT (IBZ,1)=+$ $BICOST^IB CRCI(RIMB, 3,IBDT,"PR OCEDURE",I BZ,"",IBDI V,"",1)
	3868	"RTN","IBJ DB21",254, 0)
	3869	. S IBCPT (IBZ,2)=+$ $BICOST^IB CRCI(RIMB, 3,IBDT,"PR OCEDURE",I BZ,"",IBDI V,"",2)
	3870	"RTN","IBJ DB21",255, 0)
	3871	. ;
	3872	"RTN","IBJ DB21",256, 0)
	3873	. ; - Eli minate com ponents wi thout a ch arge.
	3874	"RTN","IBJ DB21",257, 0)
	3875	. S IBCPT SUM(IBZ)=+ $G(IBCPT(I BZ,1))+$G( IBCPT(IBZ, 2))
	3876	"RTN","IBJ DB21",258, 0)
	3877	. I 'IBCP T(IBZ,1) K IBCPT(IBZ ,1)
	3878	"RTN","IBJ DB21",259, 0)
	3879	. I 'IBCP T(IBZ,2) K IBCPT(IBZ ,2)
	3880	"RTN","IBJ DB21",260, 0)
	3881	;
	3882	"RTN","IBJ DB21",261, 0)
	3883	I '$D(IBC PT) S IBRT N=-1 G OPT Q ; Quit i f no billa ble proced ures remai n.
	3884	"RTN","IBJ DB21",262, 0)
	3885	;
	3886	"RTN","IBJ DB21",263, 0)
	3887	; - Look at all of the vet's bills for the day an d eliminat e
	3888	"RTN","IBJ DB21",264, 0)
	3889	; from the array those proc edures tha t have bee n billed.
	3890	"RTN","IBJ DB21",265, 0)
	3891	S IBXX=0 S IBDAY=$E (IBDT,1,7)
	3892	"RTN","IBJ DB21",266, 0)
	3893	F S IBXX =$O(^DGCR( 399,"AOPV" ,DFN,IBDAY ,IBXX)) Q: 'IBXX D
	3894	"RTN","IBJ DB21",267, 0)
	3895	. ;
	3896	"RTN","IBJ DB21",268, 0)
	3897	. ; - Per form gener al checks on the cla im.
	3898	"RTN","IBJ DB21",269, 0)
	3899	. S IBDAT A=$$CKBIL^ IBTUBOU(IB XX) Q:IBDA TA=""
	3900	"RTN","IBJ DB21",270, 0)
	3901	. S IBAUT H=$P($G(IB DATA),U,2)
	3902	"RTN","IBJ DB21",271, 0)
	3903	. I $G(IB AUTH)<2&($ G(IBAUTH)> 5) Q
	3904	"RTN","IBJ DB21",272, 0)
	3905	. ; - The episode h as been bi lled. Chec k the reve nue code m ultiple fo r
	3906	"RTN","IBJ DB21",273, 0)
	3907	. ; all procedure s billed o n the clai m.
	3908	"RTN","IBJ DB21",274, 0)
	3909	. S IBYY= 0
	3910	"RTN","IBJ DB21",275, 0)
	3911	. F S IB YY=$O(^DGC R(399,IBXX ,"RC",IBYY )) Q:'IBYY S IBYD=^ (IBYY,0) D
	3912	"RTN","IBJ DB21",276, 0)
	3913	. . ;
	3914	"RTN","IBJ DB21",277, 0)
	3915	. . ; - G et the pro cedure cod e,charge t ype and to tal charge s for the revenue co de.
	3916	"RTN","IBJ DB21",278, 0)
	3917	. . S IBZ =$P(IBYD,U ,6)
	3918	"RTN","IBJ DB21",279, 0)
	3919	. . S IBC T=$S($P(IB YD,U,12):$ P(IBYD,U,1 2),1:$P(IB DATA,U,4))
	3920	"RTN","IBJ DB21",280, 0)
	3921	. . S IBT CHRG=$P(IB YD,U,4)
	3922	"RTN","IBJ DB21",281, 0)
	3923	. . I 'IB Z!('IBCT) Q ; Can't determine code/char ge type fo r procedur e.
	3924	"RTN","IBJ DB21",282, 0)
	3925	. . ; Del ete proced ure from u nbilled pr ocedures a rray.
	3926	"RTN","IBJ DB21",283, 0)
	3927	. . I $G( IBTCHRG)'< $G(IBCPTSU M(IBZ)) K IBCPT(IBZ)
	3928	"RTN","IBJ DB21",284, 0)
	3929	. . I $D( IBCPT(IBZ, IBCT)) K I BCPT(IBZ,I BCT)
	3930	"RTN","IBJ DB21",285, 0)
	3931	;
	3932	"RTN","IBJ DB21",286, 0)
	3933	; - Again , quit if no billabl e procedur es remain.
	3934	"RTN","IBJ DB21",287, 0)
	3935	I '$D(IBC PT) S IBRT N=-1 G OPT Q
	3936	"RTN","IBJ DB21",288, 0)
	3937	; - If th ere are bi llable pro cedures re turn TOTAL AMOUNT
	3938	"RTN","IBJ DB21",289, 0)
	3939	I $D(IBCP T) S (IBZ, IBCT,IBRTN )=0
	3940	"RTN","IBJ DB21",290, 0)
	3941	F S IBZ= $O(IBCPT(I BZ)) Q:'IB Z D
	3942	"RTN","IBJ DB21",291, 0)
	3943	.F S IBC T=$O(IBCPT (IBZ,IBCT) ) Q:'IBCT D
	3944	"RTN","IBJ DB21",292, 0)
	3945	..S IBRTN =IBRTN+IBC PT(IBZ,IBC T)
	3946	"RTN","IBJ DB21",293, 0)
	3947	I IBRTN=0 S IBRTN=- 1
	3948	"RTN","IBJ DB21",294, 0)
	3949	;
	3950	"RTN","IBJ DB21",295, 0)
	3951	OPTQ K IBC PT Q IBRTN
	3952	"RTN","IBJ DB21",296, 0)
	3953	;
	3954	"RTN","IBJ DB21",297, 0)
	3955	AVG(EPDT) ; Returns the Averag e Amount o f Inpatien t Professi onal per
	3956	"RTN","IBJ DB21",298, 0)
	3957	; Number of Episodes for the pr evious 12 months
	3958	"RTN","IBJ DB21",299, 0)
	3959	N AVG,M,Z
	3960	"RTN","IBJ DB21",300, 0)
	3961	S AVG=0,M =EPDT\100* 100
	3962	"RTN","IBJ DB21",301, 0)
	3963	I '$D(^IB E(356.19,M ,1)) S M=$ O(^IBE(356 .19,M),-1) I 'M G QA VG
	3964	"RTN","IBJ DB21",302, 0)
	3965	S Z=$G(^I BE(356.19, M,1)) I $P (Z,U,12) S AVG=$P(Z, U,11)/$P(Z ,U,12)
	3966	"RTN","IBJ DB21",303, 0)
	3967	QAVG Q $J( AVG,0,2)
	3968	"RTN","IBJ DB21",304, 0)
	3969	;
	3970	"RTN","IBJ DB21",305, 0)
	3971	PRVSPC(EPS ,CLM) ; Re turn the P rovider an d the Spec ialty
	3972	"RTN","IBJ DB21",306, 0)
	3973	; Input: EPS - Epi sode(1 = I npatient O R 2 = Outp atient)
	3974	"RTN","IBJ DB21",307, 0)
	3975	; CLM - Poi nter to Cl aim Tracki ng File (# 356)
	3976	"RTN","IBJ DB21",308, 0)
	3977	; Output: Provider Code (Poin ter to #20 0) ^ Provi der Name ^
	3978	"RTN","IBJ DB21",309, 0)
	3979	; Specialty Code (Poi nter to #4 0.7 or #45 .7) ^ Spec ialty Name
	3980	"RTN","IBJ DB21",310, 0)
	3981	;
	3982	"RTN","IBJ DB21",311, 0)
	3983	N ADM,DFN ,ENC,PRI,P RS,PRV,PRV LST,SPC,ST P,X,VAIN,V AINDT
	3984	"RTN","IBJ DB21",312, 0)
	3985	;
	3986	"RTN","IBJ DB21",313, 0)
	3987	S X=$G(^I BT(356,CLM ,0))
	3988	"RTN","IBJ DB21",314, 0)
	3989	S DFN=$P( X,U,2),ENC =$P(X,U,4) ,ADM=$P(X, U,5),PRS=$ P(X,U,8)
	3990	"RTN","IBJ DB21",315, 0)
	3991	;
	3992	"RTN","IBJ DB21",316, 0)
	3993	S (PRV,SP C)="^"
	3994	"RTN","IBJ DB21",317, 0)
	3995	I EPS=1,A DM D G QP S ; Inpat ient
	3996	"RTN","IBJ DB21",318, 0)
	3997	.S X=$G(^ DGPM(ADM,0 )),VAINDT= $P(X,U)\1 I 'VAINDT Q
	3998	"RTN","IBJ DB21",319, 0)
	3999	.D INP^VA DPT S PRV= $G(VAIN(11 )),SPC=$G( VAIN(3))
	4000	"RTN","IBJ DB21",320, 0)
	4001	.S:PRV="" PRV="^" S :SPC="" SP C="^"
	4002	"RTN","IBJ DB21",321, 0)
	4003	;
	4004	"RTN","IBJ DB21",322, 0)
	4005	I EPS=2,E NC D G QP S ; Outpa tient
	4006	"RTN","IBJ DB21",323, 0)
	4007	.D GETPRV ^SDOE(ENC, "PRVLST")
	4008	"RTN","IBJ DB21",324, 0)
	4009	.S (X,PRI )=""
	4010	"RTN","IBJ DB21",325, 0)
	4011	.F S X=$ O(PRVLST(X ),-1) Q:X= ""!PRI D
	4012	"RTN","IBJ DB21",326, 0)
	4013	..N IBX S PRV=+PRVL ST(X)
	4014	"RTN","IBJ DB21",327, 0)
	4015	..I $P(PR VLST(X),U, 4)="P" S P RI=1 ; Pri mary provi der
	4016	"RTN","IBJ DB21",328, 0)
	4017	..I PRV S PRV=PRV_U _$P($G(^VA (200,+PRV, 0)),U)
	4018	"RTN","IBJ DB21",329, 0)
	4019	..S IBX=$ $GETOE^SDO E(ENC),STP =$P(IBX,U, 3)
	4020	"RTN","IBJ DB21",330, 0)
	4021	..I STP'= "" S SPC=S TP_U_$P($G (^DIC(40.7 ,STP,0)),U )
	4022	"RTN","IBJ DB21",331, 0)
	4023	;
	4024	"RTN","IBJ DB21",332, 0)
	4025	QPS Q (PRV _U_SPC)
	4026	"RTN","IBJ DB21",333, 0)
	4027	;
	4028	"RTN","IBJ DB21",334, 0)
	4029	PHDL ; - P rint the h eader line for the E xcel sprea dsheet
	4030	"RTN","IBJ DB21",335, 0)
	4031	N X
	4032	"RTN","IBJ DB21",336, 0)
	4033	S X="Divi sion^Svc^P atient^SSN ^Insurance ^Episode D t^Dt Enter ed^Dt Lst Edit^"
	4034	"RTN","IBJ DB21",337, 0)
	4035	S X=X_"Ls t Edited B y^Next Adm ission^RNB Cat^Provi der^Specia lty^Entry Amt^Relate d Bills^Co mments"
	4036	"RTN","IBJ DB21",338, 0)
	4037	W !,X
	4038	"RTN","IBJ DB21",339, 0)
	4039	Q
	4040	"RTN","IBJ DF11")
	4041	0^17^B3003 8470^B2960 5847
	4042	"RTN","IBJ DF11",1,0)
	4043	IBJDF11 ;A LB/CPM - T HIRD PARTY FOLLOW-UP REPORT (C OMPILE) ;0 9-JAN-97
	4044	"RTN","IBJ DF11",2,0)
	4045	;;2.0;INT EGRATED BI LLING;*69 ,80,118,12 8,204,205, 227,451,53 0,554,568 *;21-MAR-9 4;Build 38
	4046	"RTN","IBJ DF11",3,0)
	4047	;Per VA D irective 6 402, this routine sh ould not b e modified .
	4048	"RTN","IBJ DF11",4,0)
	4049	;
	4050	"RTN","IBJ DF11",5,0)
	4051	DQ ; - Tas ked entry point.
	4052	"RTN","IBJ DF11",6,0)
	4053	K ^TMP("I BJDF1",$J) S IBQ=0
	4054	"RTN","IBJ DF11",7,0)
	4055	;
	4056	"RTN","IBJ DF11",8,0)
	4057	; - Colle ct divisio ns when ru nning the job for al l division s.
	4058	"RTN","IBJ DF11",9,0)
	4059	I IBSD,VA UTD S J=0 F S J=$O( ^DG(40.8,J )) Q:'J S VAUTD(J)= ""
	4060	"RTN","IBJ DF11",10,0 )
	4061	;
	4062	"RTN","IBJ DF11",11,0 )
	4063	; - Find data requi red for th e report.
	4064	"RTN","IBJ DF11",12,0 )
	4065	S IBA=0 F S IBA=$O (^PRCA(430 ,"AC",16,I BA)) Q:'IB A D Q:IB Q
	4066	"RTN","IBJ DF11",13,0 )
	4067	.;
	4068	"RTN","IBJ DF11",14,0 )
	4069	.I IBA#10 0=0 S IBQ= $$STOP^IBO UTL("Third Party Fol low-Up Rep ort") Q:IB Q
	4070	"RTN","IBJ DF11",15,0 )
	4071	.;
	4072	"RTN","IBJ DF11",16,0 )
	4073	.S IBAR=$ G(^PRCA(43 0,IBA,0))
	4074	"RTN","IBJ DF11",17,0 )
	4075	.I $P(IBA R,U,2)'=9, $P(IBAR,U, 2)'=45,$P( IBAR,U,2)' =46,$P(IBA R,U,2)'=47 Q ; Not an RI bill . Add new rate type s 46,47
	4076	"RTN","IBJ DF11",18,0 )
	4077	.I '$D(^D GCR(399,IB A,0)) Q ; No corres ponding cl aim to thi s AR.
	4078	"RTN","IBJ DF11",19,0 )
	4079	.;
	4080	"RTN","IBJ DF11",20,0 )
	4081	.; - Dete rmine whet her bill i s inpatien t, outpati ent, or RX refill.
	4082	"RTN","IBJ DF11",21,0 )
	4083	.S IBTYP= $P($G(^DGC R(399,IBA, 0)),U,5),I BTYP=$S(IB TYP>2:2,1: 1)
	4084	"RTN","IBJ DF11",22,0 )
	4085	.S:$D(^IB A(362.4,"C ",IBA)) IB TYP=3
	4086	"RTN","IBJ DF11",23,0 )
	4087	.I $P(IBA R,U,2)=45 S IBTYP=4 ;IB2554 /DRF Look for Non-VA
	4088	"RTN","IBJ DF11",24,0 )
	4089	.I IBSEL' [IBTYP,IBS EL'[5 Q
	4090	"RTN","IBJ DF11",25,0 )
	4091	.;
	4092	"RTN","IBJ DF11",26,0 )
	4093	.; - Chec k the rece ivable age , if neces sary.
	4094	"RTN","IBJ DF11",27,0 )
	4095	.I IBSMN S:"Aa"[IBS DATE IBARD =$$ACT^IBJ DF2(IBA) S :"Dd"[IBSD ATE IBARD= $$DATE1^IB JDF2(IBA) Q:'IBARD S:IBARD IB ARD=$$FMDI FF^XLFDT(D T,IBARD) I IBARD<IBS MN!(IBARD> IBSMX) Q
	4096	"RTN","IBJ DF11",28,0 )
	4097	.;
	4098	"RTN","IBJ DF11",29,0 )
	4099	.; - Chec k the mini mum dollar amount, i f necessar y.
	4100	"RTN","IBJ DF11",30,0 )
	4101	.S IBWBA= +$G(^PRCA( 430,IBA,7) ) I IBSAM, IBWBA<IBSA M Q
	4102	"RTN","IBJ DF11",31,0 )
	4103	.;
	4104	"RTN","IBJ DF11",32,0 )
	4105	.; - Get division, if necessa ry.
	4106	"RTN","IBJ DF11",33,0 )
	4107	.I 'IBSD S IBDIV=0
	4108	"RTN","IBJ DF11",34,0 )
	4109	.E S IBD IV=$$DIV^I BJDF2(IBA) I 'IBDIV S IBDIV=+$ $PRIM^VASI TE()
	4110	"RTN","IBJ DF11",35,0 )
	4111	.I IBSD,' VAUTD Q:'$ D(VAUTD(IB DIV)) ; Not a sele cted divis ion.
	4112	"RTN","IBJ DF11",36,0 )
	4113	.;
	4114	"RTN","IBJ DF11",37,0 )
	4115	.; - Excl ude receiv ables refe rred to Re gional Cou nsel, if n ecessary.
	4116	"RTN","IBJ DF11",38,0 )
	4117	.S IBWRC= $G(^PRCA(4 30,IBA,6)) I 'IBSRC, $P(IBWRC,U ,4) Q
	4118	"RTN","IBJ DF11",39,0 )
	4119	.S IBWRC= $S('$P(IBW RC,U,4):"" ,$P(IBWRC, U,22):$P(I BWRC,U,22) ,1:$P(IBWR C,U,4))
	4120	"RTN","IBJ DF11",40,0 )
	4121	.;
	4122	"RTN","IBJ DF11",41,0 )
	4123	.; - Get the insura nce carrie r and excl ude claim, if necess ary.
	4124	"RTN","IBJ DF11",42,0 )
	4125	.S IBWIN= $$INS(IBA) I IBWIN=" " Q
	4126	"RTN","IBJ DF11",43,0 )
	4127	.;
	4128	"RTN","IBJ DF11",44,0 )
	4129	.; - Get the claim patient an d exclude claim, if necessary.
	4130	"RTN","IBJ DF11",45,0 )
	4131	.S IBWPT= $$PAT(IBA) I IBWPT=" " Q
	4132	"RTN","IBJ DF11",46,0 )
	4133	.;
	4134	"RTN","IBJ DF11",47,0 )
	4135	.; - Get remaining claim info rmation.
	4136	"RTN","IBJ DF11",48,0 )
	4137	.; IB2.0 451 - get 1st/3rd p arty payme nt EEOB in dicator fo r bill
	4138	"RTN","IBJ DF11",49,0 )
	4139	.S IBPFLA G=$$EEOB^I BOA31(IBA)
	4140	"RTN","IBJ DF11",50,0 )
	4141	.S IBWDP= $P(IBAR,U, 10)
	4142	"RTN","IBJ DF11",51,0 )
	4143	.;IB2.0 530 Add in dicator fo r rejects - External Bill # (. 01) value is passed in, not IE N
	4144	"RTN","IBJ DF11",52,0 )
	4145	.S IBWBN= $G(IBPFLAG )_$S(+$$BI LLREJ^IBJT U6($P($G(^ DGCR(399,I BA,0)),U)) :"c",1:"") _$P(IBAR,U ) ; flag b ill # when applicabl e
	4146	"RTN","IBJ DF11",53,0 )
	4147	.S IBBU=$ G(^DGCR(39 9,IBA,"U") ),IBWFR=+I BBU,IBWTO= $P(IBBU,U, 2)
	4148	"RTN","IBJ DF11",54,0 )
	4149	.S IBWSC= $$OTH($P(I BWPT,U,5), $P(IBWIN," @@",2),IBW FR),IBWOR= $P(IBAR,U, 3)
	4150	"RTN","IBJ DF11",55,0 )
	4151	.S IBWSI= $P($G(^DPT (+$P(IBWPT ,U,5),.312 ,+$P($G(^D GCR(399,IB A,"MP")),U ,2),0)),U, 2)
	4152	"RTN","IBJ DF11",56,0 )
	4153	.;
	4154	"RTN","IBJ DF11",57,0 )
	4155	.; - Set up main re port index .
	4156	"RTN","IBJ DF11",58,0 )
	4157	.F X=IBTY P,5 I IBSE L[X D
	4158	"RTN","IBJ DF11",59,0 )
	4159	..S ^TMP( "IBJDF1",$ J,IBDIV,X, IBWIN,$P(I BWPT,U)_"@ @"_$P(IBWP T,U,5),IBW DP_"@@"_IB WBN)=$P(IB WPT,U,2)_" ("_$P(IBW PT,U,4)_") "_U_$P(IBW PT,U,3)_U_ IBWSC_U_IB WFR_U_IBWT O_U_IBWOR_ U_IBWBA_"~ "_IBWRC_U_ IBWSI
	4160	"RTN","IBJ DF11",60,0 )
	4161	.;
	4162	"RTN","IBJ DF11",61,0 )
	4163	.; - Add bill comme nt history , if neces sary.
	4164	"RTN","IBJ DF11",62,0 )
	4165	.I IBSH D
	4166	"RTN","IBJ DF11",63,0 )
	4167	..S X=0 F S X=$O(^ PRCA(433," C",IBA,X)) Q:'X D
	4168	"RTN","IBJ DF11",64,0 )
	4169	...S Y=$G (^PRCA(433 ,X,1))
	4170	"RTN","IBJ DF11",65,0 )
	4171	...I $P(Y ,U,2)'=35, $P(Y,U,2)' =45 Q ; N ot a decre ase/commen t transact .
	4172	"RTN","IBJ DF11",66,0 )
	4173	...S DAT= $S(Y:+Y\1, 1:+$P(Y,U, 9)\1)
	4174	"RTN","IBJ DF11",67,0 )
	4175	...;
	4176	"RTN","IBJ DF11",68,0 )
	4177	...; - Ap pend brief and trans action com ments.
	4178	"RTN","IBJ DF11",69,0 )
	4179	...K COM, COM1 S COM (0)=DAT,X1 =0
	4180	"RTN","IBJ DF11",70,0 )
	4181	...S COM1 (1)=$P($G( ^PRCA(433, X,5)),U,2) ,COM1(2)=$ E($P($G(^( 8)),U,6),1 ,70)
	4182	"RTN","IBJ DF11",71,0 )
	4183	...S COM( 1)=COM1(1) _$S(COM1(1 )]""&(COM1 (2)]""):"\| ",1:"")_CO M1(2)
	4184	"RTN","IBJ DF11",72,0 )
	4185	...I COM( 1)]"" S CO M(1)=""_ COM(1)_" ",X1=1
	4186	"RTN","IBJ DF11",73,0 )
	4187	...;
	4188	"RTN","IBJ DF11",74,0 )
	4189	...; - Ge t main com ments.
	4190	"RTN","IBJ DF11",75,0 )
	4191	...S X2=0 F S X2=$ O(^PRCA(43 3,X,7,X2)) Q:'X2 S COM($S(X1: X2+1,1:X2) )=^(X2,0)
	4192	"RTN","IBJ DF11",76,0 )
	4193	...;
	4194	"RTN","IBJ DF11",77,0 )
	4195	...S X1=" " F S X1= $O(COM(X1) ) Q:X1="" F X2=IBTY P,4 I IBSE L[X2 D
	4196	"RTN","IBJ DF11",78,0 )
	4197	....S ^TM P("IBJDF1" ,$J,IBDIV, X2,IBWIN,$ P(IBWPT,U) _"@@"_$P(I BWPT,U,5), IBWDP_"@@" _IBWBN,X,X 1)=COM(X1)
	4198	"RTN","IBJ DF11",79,0 )
	4199	;
	4200	"RTN","IBJ DF11",80,0 )
	4201	I 'IBQ D EN^IBJDF12 ; Print t he report.
	4202	"RTN","IBJ DF11",81,0 )
	4203	;
	4204	"RTN","IBJ DF11",82,0 )
	4205	ENQ K ^TMP ("IBJDF1", $J)
	4206	"RTN","IBJ DF11",83,0 )
	4207	I $D(ZTQU EUED) S ZT REQ="@" G ENQ1
	4208	"RTN","IBJ DF11",84,0 )
	4209	;
	4210	"RTN","IBJ DF11",85,0 )
	4211	D ^%ZISC
	4212	"RTN","IBJ DF11",86,0 )
	4213	ENQ1 K IBA ,IBAR,IBAR D,IBBU,IBD IV,IBQ,IBI O,IBWRC,IB WPT,IBWDP, IBWIN,IBWB N
	4214	"RTN","IBJ DF11",87,0 )
	4215	K IBTYP,I BWSC,IBWSI ,IBWFR,IBW TO,IBWOR,I BWBA,COM,C OM1,DAT,VA UTD
	4216	"RTN","IBJ DF11",88,0 )
	4217	K X,X1,X2 ,Y,Z
	4218	"RTN","IBJ DF11",89,0 )
	4219	Q
	4220	"RTN","IBJ DF11",90,0 )
	4221	;
	4222	"RTN","IBJ DF11",91,0 )
	4223	INS(X) ; - Find the Insurance company an d decide t o include the claim.
	4224	"RTN","IBJ DF11",92,0 )
	4225	; Input: X=Pointer to the cl aim/AR in file #399/ #430
	4226	"RTN","IBJ DF11",93,0 )
	4227	; plus al l variable input in IBS*
	4228	"RTN","IBJ DF11",94,0 )
	4229	; Output: Y=Insuran ce Company name and pointer to file #36
	4230	"RTN","IBJ DF11",95,0 )
	4231	;
	4232	"RTN","IBJ DF11",96,0 )
	4233	N Y,Z,Z1 S Y=""
	4234	"RTN","IBJ DF11",97,0 )
	4235	I '$G(X) G INSQ
	4236	"RTN","IBJ DF11",98,0 )
	4237	S Z=+$G(^ DGCR(399,X ,"MP")),Z1 =$P($G(^DI C(36,Z,0)) ,U)
	4238	"RTN","IBJ DF11",99,0 )
	4239	I $G(IBSI ) G INSQ:' $D(IBSI(Z) ),INSC
	4240	"RTN","IBJ DF11",100, 0)
	4241	I IBSIF'= "@",'Z G I NSQ
	4242	"RTN","IBJ DF11",101, 0)
	4243	I $D(IBSI A) G:IBSIA ="ALL"&('Z ) INSQ G:I BSIA="NULL "&(Z) INSQ
	4244	"RTN","IBJ DF11",102, 0)
	4245	I Z1="" S Z1="UNKNO WN" G INSC
	4246	"RTN","IBJ DF11",103, 0)
	4247	I $G(IBSI A)="ALL" G INSC
	4248	"RTN","IBJ DF11",104, 0)
	4249	I IBSIF=" @",IBSIL=" zzzzz" G I NSC
	4250	"RTN","IBJ DF11",105, 0)
	4251	I IBSIF]Z 1!(Z1]IBSI L) G INSQ
	4252	"RTN","IBJ DF11",106, 0)
	4253	;
	4254	"RTN","IBJ DF11",107, 0)
	4255	INSC S Y=Z 1_"@@"_Z
	4256	"RTN","IBJ DF11",108, 0)
	4257	INSQ Q Y
	4258	"RTN","IBJ DF11",109, 0)
	4259	;
	4260	"RTN","IBJ DF11",110, 0)
	4261	PAT(X) ; - Find the claim pati ent and de cide to in clude the claim.
	4262	"RTN","IBJ DF11",111, 0)
	4263	; Input: X=Pointer to the cl aim/AR in file #399/ #430
	4264	"RTN","IBJ DF11",112, 0)
	4265	; plus al l variable input in IBS*
	4266	"RTN","IBJ DF11",113, 0)
	4267	; Output: Y=1^2^3^4 ^5, where
	4268	"RTN","IBJ DF11",114, 0)
	4269	; 1 => so rt key (na me or last four)
	4270	"RTN","IBJ DF11",115, 0)
	4271	; 2 => pa tient name
	4272	"RTN","IBJ DF11",116, 0)
	4273	; 3 => pa tient ssn
	4274	"RTN","IBJ DF11",117, 0)
	4275	; 4 => pa tient age
	4276	"RTN","IBJ DF11",118, 0)
	4277	; 5 => pa tient poin ter to fil e #2
	4278	"RTN","IBJ DF11",119, 0)
	4279	;
	4280	"RTN","IBJ DF11",120, 0)
	4281	N AGE,DFN ,DOB,KEY,Y ,Z S Y=""
	4282	"RTN","IBJ DF11",121, 0)
	4283	I '$G(X) G PATQ
	4284	"RTN","IBJ DF11",122, 0)
	4285	S DFN=+$P ($G(^DGCR( 399,X,0)), U,2),Z=$G( ^DPT(DFN,0 ))
	4286	"RTN","IBJ DF11",123, 0)
	4287	S KEY=$S( IBSN="N":$ P(Z,U),1:$ E($P(Z,U,9 ),6,9))
	4288	"RTN","IBJ DF11",124, 0)
	4289	;
	4290	"RTN","IBJ DF11",125, 0)
	4291	I IBSNF'= "@",'DFN G PATQ
	4292	"RTN","IBJ DF11",126, 0)
	4293	I $D(IBSN A) G:IBSNA ="ALL"&('D FN) PATQ G :IBSNA="NU LL"&(DFN) PATQ
	4294	"RTN","IBJ DF11",127, 0)
	4295	I KEY="" S Y="UNK^U NK^UNK^UNK ^UNK" G PA TQ
	4296	"RTN","IBJ DF11",128, 0)
	4297	I $G(IBSN A)="ALL" G PATC
	4298	"RTN","IBJ DF11",129, 0)
	4299	I IBSNF=" @",IBSNL=" zzzzz" G P ATC
	4300	"RTN","IBJ DF11",130, 0)
	4301	I IBSNF]K EY!(KEY]IB SNL) G PAT Q
	4302	"RTN","IBJ DF11",131, 0)
	4303	;
	4304	"RTN","IBJ DF11",132, 0)
	4305	PATC ; - F ind all pa tient data .
	4306	"RTN","IBJ DF11",133, 0)
	4307	S DOB=$P( Z,U,3)
	4308	"RTN","IBJ DF11",134, 0)
	4309	S AGE=$S( 'DOB:"UNK" ,1:$E(DT,1 ,3)-$E(DOB ,1,3)-($E( DT,4,7)<$E (DOB,4,7)) )
	4310	"RTN","IBJ DF11",135, 0)
	4311	S Y=KEY_U _$E($P(Z,U ),1,17)_U_ $P(Z,U,9)_ U_AGE_U_DF N
	4312	"RTN","IBJ DF11",136, 0)
	4313	PATQ Q Y
	4314	"RTN","IBJ DF11",137, 0)
	4315	;
	4316	"RTN","IBJ DF11",138, 0)
	4317	OTH(DFN,IN S,DS) ; - Find a pat ient's oth er valid i nsurance c arrier (if any).
	4318	"RTN","IBJ DF11",139, 0)
	4319	; Input: DFN=Point er to the patient in file #2
	4320	"RTN","IBJ DF11",140, 0)
	4321	; INS=Point er to the patient's primary ca rrier in f ile #36
	4322	"RTN","IBJ DF11",141, 0)
	4323	; DS=Date of service for valid ity check
	4324	"RTN","IBJ DF11",142, 0)
	4325	; Output: Valid ins urance car rier (1st 13 chars.) or null
	4326	"RTN","IBJ DF11",143, 0)
	4327	;
	4328	"RTN","IBJ DF11",144, 0)
	4329	N Y S Y=" " I '$G(DF N)!('$G(DS )) G OTHQ
	4330	"RTN","IBJ DF11",145, 0)
	4331	S Z=0 F S Z=$O(^DP T(DFN,.312 ,Z)) Q:'Z S X=$G(^( Z,0)) D:X Q:Y]""
	4332	"RTN","IBJ DF11",146, 0)
	4333	.I $G(INS ),+X=INS Q
	4334	"RTN","IBJ DF11",147, 0)
	4335	.S X1=$G( ^DIC(36,+X ,0)) I X1= "" Q
	4336	"RTN","IBJ DF11",148, 0)
	4337	.I $P(X1, U,2)'="N", $$CHK^IBCN S1(X,DS) S Y=$E($P(X 1,U),1,13)
	4338	"RTN","IBJ DF11",149, 0)
	4339	;
	4340	"RTN","IBJ DF11",150, 0)
	4341	OTHQ Q Y
	4342	"RTN","IBJ DF2")
	4343	0^16^B6808 9735^B6780 0970
	4344	"RTN","IBJ DF2",1,0)
	4345	IBJDF2 ;AL B/CPM - TH IRD PARTY FOLLOW-UP SUMMARY RE PORT ;03-J AN-97
	4346	"RTN","IBJ DF2",2,0)
	4347	;;2.0;INT EGRATED BI LLING;69 ,91,100,11 8,133,205, 554,568; 21-MAR-94; Build 38
	4348	"RTN","IBJ DF2",3,0)
	4349	;Per VA D irective 6 402, this routine sh ould not b e modified .
	4350	"RTN","IBJ DF2",4,0)
	4351	;
	4352	"RTN","IBJ DF2",5,0)
	4353	EN ; - Opt ion entry point.
	4354	"RTN","IBJ DF2",6,0)
	4355	;
	4356	"RTN","IBJ DF2",7,0)
	4357	W !!,"Thi s report p rovides a summary of all outst anding Thi rd Party r eceivables .",!
	4358	"RTN","IBJ DF2",8,0)
	4359	;
	4360	"RTN","IBJ DF2",9,0)
	4361	DATE ; - C hoose date to use fo r calculat ion
	4362	"RTN","IBJ DF2",10,0)
	4363	W !!,"Cal culate rep ort using (D)ATE OF CARE or (A )CTIVE IN AR (days): (A)CTIVE IN AR// " R X:DTIME
	4364	"RTN","IBJ DF2",11,0)
	4365	G:'$T!(X[ "^") ENQ S :X="" X="A " S X=$E(X )
	4366	"RTN","IBJ DF2",12,0)
	4367	I "ADad"' [X S IBOFF =99 D HELP ^IBJDF1H G DATE
	4368	"RTN","IBJ DF2",13,0)
	4369	W " ",$S ("Dd"[X:"D ATE OF CAR E",1:"(DAY S) ACTIVE IN AR")
	4370	"RTN","IBJ DF2",14,0)
	4371	S IBSDATE =$S("Dd"[X :"D",1:"A" )
	4372	"RTN","IBJ DF2",15,0)
	4373	;
	4374	"RTN","IBJ DF2",16,0)
	4375	; - Sort by divisio n.
	4376	"RTN","IBJ DF2",17,0)
	4377	S DIR(0)= "Y",DIR("B ")="NO"
	4378	"RTN","IBJ DF2",18,0)
	4379	S DIR("A" )="Do you wish to so rt this re port by di vision"
	4380	"RTN","IBJ DF2",19,0)
	4381	S DIR("?" )="^D DHLP ^IBJDF2"
	4382	"RTN","IBJ DF2",20,0)
	4383	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) G E NQ
	4384	"RTN","IBJ DF2",21,0)
	4385	S IBSORT= +Y K DIROU T,DTOUT,DU OUT,DIRUT
	4386	"RTN","IBJ DF2",22,0)
	4387	;
	4388	"RTN","IBJ DF2",23,0)
	4389	; - Issue prompt fo r division .
	4390	"RTN","IBJ DF2",24,0)
	4391	I IBSORT D PSDR^IBO DIV G:Y<0 ENQ
	4392	"RTN","IBJ DF2",25,0)
	4393	;
	4394	"RTN","IBJ DF2",26,0)
	4395	TYP ; - Se lect type of summari es to prin t.
	4396	"RTN","IBJ DF2",27,0)
	4397	; IB2.0 554 DRF 10 /19/2015 A dd Non-VA care
	4398	"RTN","IBJ DF2",28,0)
	4399	W !!,"Cho ose which type of su mmaries to print:",!
	4400	"RTN","IBJ DF2",29,0)
	4401	S DIR(0)= "LO^1:5^K: +$P(X,""-" ",2)>5 X"
	4402	"RTN","IBJ DF2",30,0)
	4403	S DIR("A" ,1)=" 1 - INPATI ENT RECEIV ABLES"
	4404	"RTN","IBJ DF2",31,0)
	4405	S DIR("A" ,2)=" 2 - OUTPAT IENT RECEI VABLES"
	4406	"RTN","IBJ DF2",32,0)
	4407	S DIR("A" ,3)=" 3 - PHARMA CY REFILL RECEIVABLE S"
	4408	"RTN","IBJ DF2",33,0)
	4409	S DIR("A" ,4)=" 4 - NON-VA CARE RECE IVABLES"
	4410	"RTN","IBJ DF2",34,0)
	4411	S DIR("A" ,5)=" 5 - ALL RE CEIVABLES"
	4412	"RTN","IBJ DF2",35,0)
	4413	S DIR("A" ,6)="",DIR ("A")="Sel ect",DIR(" B")=5
	4414	"RTN","IBJ DF2",36,0)
	4415	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) G E NQ
	4416	"RTN","IBJ DF2",37,0)
	4417	S IBSEL=Y K DIROUT, DTOUT,DUOU T,DIRUT
	4418	"RTN","IBJ DF2",38,0)
	4419	;
	4420	"RTN","IBJ DF2",39,0)
	4421	W !!,"Thi s report o nly requir es an 80 c olumn prin ter."
	4422	"RTN","IBJ DF2",40,0)
	4423	W !!,"Not e: This re port requi res a sear ch through all activ e receivab les."
	4424	"RTN","IBJ DF2",41,0)
	4425	W !?6,"Yo u should q ueue this report to run after normal bus iness hour s.",!
	4426	"RTN","IBJ DF2",42,0)
	4427	;
	4428	"RTN","IBJ DF2",43,0)
	4429	; - Selec t a device .
	4430	"RTN","IBJ DF2",44,0)
	4431	S %ZIS="Q M" D ^%ZIS G:POP ENQ
	4432	"RTN","IBJ DF2",45,0)
	4433	I $D(IO(" Q")) D G ENQ
	4434	"RTN","IBJ DF2",46,0)
	4435	.S ZTRTN= "DQ^IBJDF2 ",ZTDESC=" IB - FOLLO W-UP SUMMA RY REPORT"
	4436	"RTN","IBJ DF2",47,0)
	4437	.F I="IBS EL","IBSDA TE","IBSOR T","VAUTD" ,"VAUTD(" S ZTSAVE(I )=""
	4438	"RTN","IBJ DF2",48,0)
	4439	.D ^%ZTLO AD
	4440	"RTN","IBJ DF2",49,0)
	4441	.W !!,$S( $D(ZTSK):" This job h as been qu eued. The task numbe r is "_ZTS K_".",1:"U nable to q ueue this job.")
	4442	"RTN","IBJ DF2",50,0)
	4443	.K ZTSK,I O("Q") D H OME^%ZIS
	4444	"RTN","IBJ DF2",51,0)
	4445	;
	4446	"RTN","IBJ DF2",52,0)
	4447	U IO
	4448	"RTN","IBJ DF2",53,0)
	4449	;
	4450	"RTN","IBJ DF2",54,0)
	4451	DQ ; - Tas ked entry point.
	4452	"RTN","IBJ DF2",55,0)
	4453	;
	4454	"RTN","IBJ DF2",56,0)
	4455	I $G(IBXT RACT) D E^ IBJDE(9,1) ; Change extract st atus.
	4456	"RTN","IBJ DF2",57,0)
	4457	;
	4458	"RTN","IBJ DF2",58,0)
	4459	K IB F I= 1,2,3,4,5 I IBSEL[I D
	4460	"RTN","IBJ DF2",59,0)
	4461	.I 'IBSOR T D Q
	4462	"RTN","IBJ DF2",60,0)
	4463	..F J=1:1 :9 S IB(0, I,J)=""
	4464	"RTN","IBJ DF2",61,0)
	4465	.I 'VAUTD D Q
	4466	"RTN","IBJ DF2",62,0)
	4467	..S J=0 F S J=$O(V AUTD(J)) Q :'J F K=1 :1:9 S IB( J,I,K)=""
	4468	"RTN","IBJ DF2",63,0)
	4469	.S J=0 F S J=$O(^D G(40.8,J)) Q:'J F K =1:1:9 S I B(J,I,K)=" "
	4470	"RTN","IBJ DF2",64,0)
	4471	;
	4472	"RTN","IBJ DF2",65,0)
	4473	; - Find data requi red for th e report.
	4474	"RTN","IBJ DF2",66,0)
	4475	S (IBQ,IB A)=0 F S IBA=$O(^PR CA(430,"AC ",16,IBA)) Q:'IBA D Q:IBQ
	4476	"RTN","IBJ DF2",67,0)
	4477	.;
	4478	"RTN","IBJ DF2",68,0)
	4479	.I IBA#10 0=0 S IBQ= $$STOP^IBO UTL("Third Party Fol low-Up Sum mary Repor t") Q:IBQ
	4480	"RTN","IBJ DF2",69,0)
	4481	.;
	4482	"RTN","IBJ DF2",70,0)
	4483	.S IBAR=$ G(^PRCA(43 0,IBA,0))
	4484	"RTN","IBJ DF2",71,0)
	4485	.I $P(IBA R,U,2)'=9, $P(IBAR,U, 2)'=45,$P( IBAR,U,2)' =46,$P(IBA R,U,2)'=47 Q ; Not an RI bill .
	4486	"RTN","IBJ DF2",72,0)
	4487	.S:"Aa"[I BSDATE IBA RD=$$ACT(I BA) S:"Dd" [IBSDATE I BARD=$$DAT E1(IBA) I 'IBARD Q ; No activ ation date .
	4488	"RTN","IBJ DF2",73,0)
	4489	.I '$D(^D GCR(399,IB A,0)) Q ; No co rrespondin g claim to this AR.
	4490	"RTN","IBJ DF2",74,0)
	4491	.;
	4492	"RTN","IBJ DF2",75,0)
	4493	.; - Get division i f necessar y.
	4494	"RTN","IBJ DF2",76,0)
	4495	.I 'IBSOR T S IBDIV= 0
	4496	"RTN","IBJ DF2",77,0)
	4497	.E S IBD IV=$$DIV(I BA) I 'IBD IV S IBDIV =+$$PRIM^V ASITE()
	4498	"RTN","IBJ DF2",78,0)
	4499	.I IBSORT ,'VAUTD Q: '$D(VAUTD( IBDIV)) ; Not a sel ected divi sion.
	4500	"RTN","IBJ DF2",79,0)
	4501	.;
	4502	"RTN","IBJ DF2",80,0)
	4503	.; - Dete rmine whet her bill i s inpatien t, outpati ent, or RX refill.
	4504	"RTN","IBJ DF2",81,0)
	4505	.S IBTYP= $P($G(^DGC R(399,IBA, 0)),U,5),I BTYP=$S(IB TYP>2:2,1: 1)
	4506	"RTN","IBJ DF2",82,0)
	4507	.S:$D(^IB A(362.4,"C ",IBA)) IB TYP=3
	4508	"RTN","IBJ DF2",83,0)
	4509	.I $P(IBA R,U,2)=45 S IBTYP=4 ;IB2554 /DRF Look for Non-VA
	4510	"RTN","IBJ DF2",84,0)
	4511	.I IBSEL' [IBTYP,IBS EL'[5 Q
	4512	"RTN","IBJ DF2",85,0)
	4513	.;
	4514	"RTN","IBJ DF2",86,0)
	4515	.; - Hand le claims referred t o Regional Counsel.
	4516	"RTN","IBJ DF2",87,0)
	4517	.S IBOUT= +$G(^PRCA( 430,IBA,7) )
	4518	"RTN","IBJ DF2",88,0)
	4519	.I $P($G( ^PRCA(430, IBA,6)),U, 4) D Q
	4520	"RTN","IBJ DF2",89,0)
	4521	..F I=IBT YP,5 I IBS EL[I D
	4522	"RTN","IBJ DF2",90,0)
	4523	...S $P(I B(IBDIV,I, 8),U)=+IB( IBDIV,I,8) +1
	4524	"RTN","IBJ DF2",91,0)
	4525	...S $P(I B(IBDIV,I, 8),U,2)=$P (IB(IBDIV, I,8),U,2)+ IBOUT
	4526	"RTN","IBJ DF2",92,0)
	4527	.;
	4528	"RTN","IBJ DF2",93,0)
	4529	.; - Dete rmine age and outsta nding bala nce.
	4530	"RTN","IBJ DF2",94,0)
	4531	.S IBAGE= $$FMDIFF^X LFDT(DT,IB ARD),IBCAT =$$CAT(IBA GE)
	4532	"RTN","IBJ DF2",95,0)
	4533	.;
	4534	"RTN","IBJ DF2",96,0)
	4535	.F I=IBTY P,5 I IBSE L[I D
	4536	"RTN","IBJ DF2",97,0)
	4537	..S $P(IB (IBDIV,I,I BCAT),U)=+ IB(IBDIV,I ,IBCAT)+1
	4538	"RTN","IBJ DF2",98,0)
	4539	..S $P(IB (IBDIV,I,I BCAT),U,2) =$P(IB(IBD IV,I,IBCAT ),U,2)+IBO UT
	4540	"RTN","IBJ DF2",99,0)
	4541	;
	4542	"RTN","IBJ DF2",100,0 )
	4543	I IBQ G E NQ
	4544	"RTN","IBJ DF2",101,0 )
	4545	;
	4546	"RTN","IBJ DF2",102,0 )
	4547	; - Extra ct summary data.
	4548	"RTN","IBJ DF2",103,0 )
	4549	I $G(IBXT RACT) D G ENQ
	4550	"RTN","IBJ DF2",104,0 )
	4551	.F I=1:1: 8 D
	4552	"RTN","IBJ DF2",105,0 )
	4553	..F J=1,2 S $P(IB(0 ,4,9),U,J) =$P(IB(0,4 ,9),U,J)+$ P(IB(0,4,I ),U,J)
	4554	"RTN","IBJ DF2",106,0 )
	4555	.S I=0 F J=1:1:9 D
	4556	"RTN","IBJ DF2",107,0 )
	4557	..S I=I+1 ,IB(I)=+IB (0,4,J),I= I+1,IB(I)= $J(+$P(IB( 0,4,J),U,2 ),0,2)
	4558	"RTN","IBJ DF2",108,0 )
	4559	.D E^IBJD E(9,0)
	4560	"RTN","IBJ DF2",109,0 )
	4561	;
	4562	"RTN","IBJ DF2",110,0 )
	4563	; - Print the repor ts.
	4564	"RTN","IBJ DF2",111,0 )
	4565	S (IBPAG, IBQ)=0 D N OW^%DTC S IBRUN=$$DA T2^IBOUTL( %)
	4566	"RTN","IBJ DF2",112,0 )
	4567	I 'IBSORT D SUM(0) G ENQ
	4568	"RTN","IBJ DF2",113,0 )
	4569	;
	4570	"RTN","IBJ DF2",114,0 )
	4571	S IBDIV=0 F S IBDI V=$O(IB(IB DIV)) Q:'I BDIV D SU M(IBDIV) Q :IBQ
	4572	"RTN","IBJ DF2",115,0 )
	4573	;
	4574	"RTN","IBJ DF2",116,0 )
	4575	ENQ I $D(Z TQUEUED) S ZTREQ="@" G ENQ1
	4576	"RTN","IBJ DF2",117,0 )
	4577	;
	4578	"RTN","IBJ DF2",118,0 )
	4579	D ^%ZISC
	4580	"RTN","IBJ DF2",119,0 )
	4581	ENQ1 K IB, IBOFF,IBQ, IBSDATE,IB SEL,IBSORT ,IBTEXT,IB A,IBAR,IBA RD,IBDIV,I BAGE,IBOUT ,IBCAT,IBP AG,IBRUN
	4582	"RTN","IBJ DF2",120,0 )
	4583	K IBDH,IB TYP,IBTYPH ,%,%ZIS,DF N,I,J,K,PO P,VAUTD,X, Y,Z,ZTDESC ,ZTRTN,ZTS AVE
	4584	"RTN","IBJ DF2",121,0 )
	4585	K DIROUT, DTOUT,DUOU T,DIRUT
	4586	"RTN","IBJ DF2",122,0 )
	4587	Q
	4588	"RTN","IBJ DF2",123,0 )
	4589	;
	4590	"RTN","IBJ DF2",124,0 )
	4591	SUM(IBDIV) ; - Print the repor t.
	4592	"RTN","IBJ DF2",125,0 )
	4593	; Input: IBDIV=Poi nter to th e division in file # 40.8
	4594	"RTN","IBJ DF2",126,0 )
	4595	;
	4596	"RTN","IBJ DF2",127,0 )
	4597	S IBTYP=0 F S IBTY P=$O(IB(IB DIV,IBTYP) ) Q:'IBTYP D Q:IBQ
	4598	"RTN","IBJ DF2",128,0 )
	4599	.I $E(IOS T,1,2)="C- "!(IBPAG) W @IOF,*13
	4600	"RTN","IBJ DF2",129,0 )
	4601	.S IBPAG= IBPAG+1 I $E(IOST,1, 2)'="C-" W !?68,"Pag e: ",IBPAG
	4602	"RTN","IBJ DF2",130,0 )
	4603	.W !!?22, "THIRD PAR TY FOLLOW- UP SUMMARY REPORT"
	4604	"RTN","IBJ DF2",131,0 )
	4605	.S IBTYPH =$S(IBTYP= 1:"INPATIE NT",IBTYP= 2:"OUTPATI ENT",IBTYP =3:"RX REF ILL",IBTYP =4:"NON-VA ",1:"ALL R EIMBURSABL E")_" RECE IVABLES"_$ S(IBSDATE= "D":" ( da te of care )",1:" ( days in AR )")
	4606	"RTN","IBJ DF2",132,0 )
	4607	.W !?(80- $L(IBTYPH) )\2,IBTYPH
	4608	"RTN","IBJ DF2",133,0 )
	4609	.I IBDIV S IBDH="Di vision: "_ $P($G(^DG( 40.8,IBDIV ,0)),U) W !?(80-$L(I BDH)\2),IB DH
	4610	"RTN","IBJ DF2",134,0 )
	4611	.W !!?24, "Run Date: ",IBRUN,! ?24,$$DASH (31),!!
	4612	"RTN","IBJ DF2",135,0 )
	4613	.;
	4614	"RTN","IBJ DF2",136,0 )
	4615	.; - Calc ulate tota ls first.
	4616	"RTN","IBJ DF2",137,0 )
	4617	.F I=1:1: 8 F J=1,2 S $P(IB(IB DIV,IBTYP, 9),U,J)=$P (IB(IBDIV, IBTYP,9),U ,J)+$P(IB( IBDIV,IBTY P,I),U,J)
	4618	"RTN","IBJ DF2",138,0 )
	4619	.;
	4620	"RTN","IBJ DF2",139,0 )
	4621	.W "AR Ca tegory",?3 1,"# Recei vables",?5 2,"Total O utstanding Balance"
	4622	"RTN","IBJ DF2",140,0 )
	4623	.W !,"--- --------", ?31,"----- --------", ?52,"----- ---------- ---------- ",!
	4624	"RTN","IBJ DF2",141,0 )
	4625	.;
	4626	"RTN","IBJ DF2",142,0 )
	4627	.I 'IB(IB DIV,IBTYP, 9) W !,"Th ere are no active re ceivables" ,$S(IBDIV: " for this division" ,1:""),"." D PAUSE Q
	4628	"RTN","IBJ DF2",143,0 )
	4629	.;
	4630	"RTN","IBJ DF2",144,0 )
	4631	.; - Prim ary loop t o write re sults.
	4632	"RTN","IBJ DF2",145,0 )
	4633	.S Y=$P(I B(IBDIV,IB TYP,9),U,2 ) F I=1:1: 9 S X=$P($ T(CATN+I), ";;",2,99) D
	4634	"RTN","IBJ DF2",146,0 )
	4635	..W:I=9 ! W !,X,?30 ,$J(+IB(IB DIV,IBTYP, I),6)
	4636	"RTN","IBJ DF2",147,0 )
	4637	..W " (" ,$J(+IB(IB DIV,IBTYP, I)/+IB(IBD IV,IBTYP,9 )*100,0,$S (I=9:0,1:2 )),"%)"
	4638	"RTN","IBJ DF2",148,0 )
	4639	..S Z=$FN ($P(IB(IBD IV,IBTYP,I ),U,2),"," ,2)
	4640	"RTN","IBJ DF2",149,0 )
	4641	..W ?52,$ J($S(I=1!( I=9):"$",1 :"")_Z,15)
	4642	"RTN","IBJ DF2",150,0 )
	4643	..W " (" ,$J($S('Y: 0,1:$P(IB( IBDIV,IBTY P,I),U,2)/ Y*100),0,$ S(I=9:0,1: 2)),"%)"
	4644	"RTN","IBJ DF2",151,0 )
	4645	.;
	4646	"RTN","IBJ DF2",152,0 )
	4647	.D PAUSE
	4648	"RTN","IBJ DF2",153,0 )
	4649	;
	4650	"RTN","IBJ DF2",154,0 )
	4651	SUMQ Q
	4652	"RTN","IBJ DF2",155,0 )
	4653	;
	4654	"RTN","IBJ DF2",156,0 )
	4655	DASH(X) ; - Return a dashed li ne.
	4656	"RTN","IBJ DF2",157,0 )
	4657	Q $TR($J( "",X)," ", "=")
	4658	"RTN","IBJ DF2",158,0 )
	4659	;
	4660	"RTN","IBJ DF2",159,0 )
	4661	PAUSE ; - Page break .
	4662	"RTN","IBJ DF2",160,0 )
	4663	I $E(IOST ,1,2)'="C- " Q
	4664	"RTN","IBJ DF2",161,0 )
	4665	N IBX,DIR ,DIRUT,DUO UT,DTOUT,D IROUT,X,Y
	4666	"RTN","IBJ DF2",162,0 )
	4667	F IBX=$Y: 1:(IOSL-3) W !
	4668	"RTN","IBJ DF2",163,0 )
	4669	S DIR(0)= "E" D ^DIR I $D(DIRU T)!($D(DUO UT)) S IBQ =1
	4670	"RTN","IBJ DF2",164,0 )
	4671	Q
	4672	"RTN","IBJ DF2",165,0 )
	4673	;
	4674	"RTN","IBJ DF2",166,0 )
	4675	DHLP ; - ' Display Re gistration User' hel p.
	4676	"RTN","IBJ DF2",167,0 )
	4677	W !,"Ente r <CR> to summarize all receiv ables with out regard to divisi on,"
	4678	"RTN","IBJ DF2",168,0 )
	4679	W !,"or Y ES to sele ct those d ivisions f or which a separate report sho uld"
	4680	"RTN","IBJ DF2",169,0 )
	4681	W !,"be c reated."
	4682	"RTN","IBJ DF2",170,0 )
	4683	Q
	4684	"RTN","IBJ DF2",171,0 )
	4685	;
	4686	"RTN","IBJ DF2",172,0 )
	4687	CAT(X) ; - Determine category to place r eceivable.
	4688	"RTN","IBJ DF2",173,0 )
	4689	Q $S($G(X )<31:1,X<6 1:2,X<91:3 ,X<121:4,X <181:5,X<3 66:6,1:7)
	4690	"RTN","IBJ DF2",174,0 )
	4691	;
	4692	"RTN","IBJ DF2",175,0 )
	4693	ACT(X) ; - Determine the activ ation date for a rec eivable.
	4694	"RTN","IBJ DF2",176,0 )
	4695	N Y S Y=0 I '$G(X) G ACTQ
	4696	"RTN","IBJ DF2",177,0 )
	4697	S Y=$P($G (^PRCA(430 ,X,6)),U,2 1) I Y G A CTQ
	4698	"RTN","IBJ DF2",178,0 )
	4699	S Y=$P($G (^PRCA(430 ,X,9)),U,3 ) I Y G AC TQ
	4700	"RTN","IBJ DF2",179,0 )
	4701	S Y=$P($G (^PRCA(430 ,X,0)),U,1 0)
	4702	"RTN","IBJ DF2",180,0 )
	4703	ACTQ Q Y
	4704	"RTN","IBJ DF2",181,0 )
	4705	;
	4706	"RTN","IBJ DF2",182,0 )
	4707	DATE1(X) ; - Determi ne the Dat e of Care
	4708	"RTN","IBJ DF2",183,0 )
	4709	N Y S Y=0 I '$G(X) G DATEQ
	4710	"RTN","IBJ DF2",184,0 )
	4711	S Y=$P($G (^DGCR(399 ,X,"U")),U ,2) I Y G DATEQ
	4712	"RTN","IBJ DF2",185,0 )
	4713	DATEQ Q Y
	4714	"RTN","IBJ DF2",186,0 )
	4715	;
	4716	"RTN","IBJ DF2",187,0 )
	4717	DIV(IBX) ; - Determi ne the div ision for a claim.
	4718	"RTN","IBJ DF2",188,0 )
	4719	; Input: IBX=Point er to a cl aim in fil e #399
	4720	"RTN","IBJ DF2",189,0 )
	4721	; Output: IBY=Point er to a di vision in file #40.8 ,
	4722	"RTN","IBJ DF2",190,0 )
	4723	; or 0 if not det ermined
	4724	"RTN","IBJ DF2",191,0 )
	4725	;
	4726	"RTN","IBJ DF2",192,0 )
	4727	N DFN,IBA DM,IBEV,IB D,IBPTF,IB U,IBY,IBC, IBTY,VAIND T,VADMVT
	4728	"RTN","IBJ DF2",193,0 )
	4729	S IBY=0,I BC=$G(^DGC R(399,+$G( IBX),0)) I $P(IBC,U) ="" G DIVQ
	4730	"RTN","IBJ DF2",194,0 )
	4731	S DFN=+$P (IBC,U,2), IBEV=+$P(I BC,U,3)\1, IBTY=$P(IB C,U,5)
	4732	"RTN","IBJ DF2",195,0 )
	4733	;
	4734	"RTN","IBJ DF2",196,0 )
	4735	S IBY=+$P (IBC,U,22) I +IBY G DIVQ ; use bill defa ult divisi on if defi ned
	4736	"RTN","IBJ DF2",197,0 )
	4737	;
	4738	"RTN","IBJ DF2",198,0 )
	4739	; - For P harmacy or Prostheti cs claims, use the p rimary div ision.
	4740	"RTN","IBJ DF2",199,0 )
	4741	I $D(^IBA (362.4,"AI FN"_IBX))! $D(^IBA(36 2.5,"AIFN" _IBX)) D G DIVQ
	4742	"RTN","IBJ DF2",200,0 )
	4743	.S IBY=$$ PRIM^VASIT E(DT) S:IB Y'>0 IBY=0
	4744	"RTN","IBJ DF2",201,0 )
	4745	;
	4746	"RTN","IBJ DF2",202,0 )
	4747	; - Check all visit dates if outpatient claim.
	4748	"RTN","IBJ DF2",203,0 )
	4749	I IBTY>2 D G DIVQ
	4750	"RTN","IBJ DF2",204,0 )
	4751	.S IBY=$$ OPT(IBEV,D FN) Q:IBY
	4752	"RTN","IBJ DF2",205,0 )
	4753	.S IBD=0 F S IBD=$ O(^DGCR(39 9,IBX,"OP" ,IBD)) Q:' IBD S IBY =$$OPT(IBD ,DFN) Q:IB Y
	4754	"RTN","IBJ DF2",206,0 )
	4755	;
	4756	"RTN","IBJ DF2",207,0 )
	4757	; - Check inpatient claim.
	4758	"RTN","IBJ DF2",208,0 )
	4759	S IBPTF=+ $P(IBC,U,8 ),IBU=$G(^ DGCR(399,I BX,"U"))
	4760	"RTN","IBJ DF2",209,0 )
	4761	I IBPTF S IBADM=$O( ^DGPM("APT F",IBPTF,0 )) I IBADM S IBY=$$I NP(IBADM) G:IBY DIVQ
	4762	"RTN","IBJ DF2",210,0 )
	4763	S VAINDT= +IBU\1_.23 D ADM^VAD PT2 I VADM VT S IBY=$ $INP(VADMV T) G:IBY D IVQ
	4764	"RTN","IBJ DF2",211,0 )
	4765	S VAINDT= $S($P(IBEV ,".",2):IB EV,1:+IBEV \1_.23) D ADM^VADPT2 I VADMVT S IBY=$$IN P(VADMVT)
	4766	"RTN","IBJ DF2",212,0 )
	4767	;
	4768	"RTN","IBJ DF2",213,0 )
	4769	DIVQ ; - I f a divisi on cannot be determi ned, use t he primary division.
	4770	"RTN","IBJ DF2",214,0 )
	4771	I 'IBY S IBY=$$PRIM ^VASITE(DT ) S:IBY'>0 IBY=0
	4772	"RTN","IBJ DF2",215,0 )
	4773	Q IBY
	4774	"RTN","IBJ DF2",216,0 )
	4775	;
	4776	"RTN","IBJ DF2",217,0 )
	4777	INP(X) ; - Return di vision for a movemen t.
	4778	"RTN","IBJ DF2",218,0 )
	4779	Q +$P($G( ^DIC(42,+$ P($G(^DGPM (+$G(X),0) ),U,6),0)) ,U,11)
	4780	"RTN","IBJ DF2",219,0 )
	4781	;
	4782	"RTN","IBJ DF2",220,0 )
	4783	OPT(X,DFN) ; - Retur n division for a pat ient's out patient vi sit date.
	4784	"RTN","IBJ DF2",221,0 )
	4785	N IBFR,IB TO,IBY,IBY 1,IBZ,IBZE RR
	4786	"RTN","IBJ DF2",222,0 )
	4787	S IBY=0 I '$G(X) G OPTQ
	4788	"RTN","IBJ DF2",223,0 )
	4789	S IBFR=X, IBTO=X\1_" .99"
	4790	"RTN","IBJ DF2",224,0 )
	4791	F S IBZ= $$EXOE^SDO E(DFN,IBFR ,IBTO,,"IB ZERR") K I BZERR Q:'I BZ S IBY1 =$$SCE^IBS DU(IBZ) D Q:IBY
	4792	"RTN","IBJ DF2",225,0 )
	4793	.I $P(IBY 1,U,11) S IBY=$P(IBY 1,U,11) Q
	4794	"RTN","IBJ DF2",226,0 )
	4795	.S IBFR=I BY1+.00000 1
	4796	"RTN","IBJ DF2",227,0 )
	4797	OPTQ Q IBY
	4798	"RTN","IBJ DF2",228,0 )
	4799	;
	4800	"RTN","IBJ DF2",229,0 )
	4801	CATN ; - L ist of cat egory name s.
	4802	"RTN","IBJ DF2",230,0 )
	4803	;;Less th an 30 days old
	4804	"RTN","IBJ DF2",231,0 )
	4805	;;31-60 d ays
	4806	"RTN","IBJ DF2",232,0 )
	4807	;;61-90 d ays
	4808	"RTN","IBJ DF2",233,0 )
	4809	;;91-120 days
	4810	"RTN","IBJ DF2",234,0 )
	4811	;;121-180 days
	4812	"RTN","IBJ DF2",235,0 )
	4813	;;181-365 days
	4814	"RTN","IBJ DF2",236,0 )
	4815	;;Over 36 5 days
	4816	"RTN","IBJ DF2",237,0 )
	4817	;;Referre d to Regio nal Counse l
	4818	"RTN","IBJ DF2",238,0 )
	4819	;;Total T hird Party Receivabl es
	4820	"RTN","IBJ DF4")
	4821	0^19^B4236 1959^B2713 1031
	4822	"RTN","IBJ DF4",1,0)
	4823	IBJDF4 ;AL B/RB - FIR ST PARTY F OLLOW-UP R EPORT ;15- APR-00
	4824	"RTN","IBJ DF4",2,0)
	4825	;;2.0;INT EGRATED BI LLING;12 3,204,220, 568;21-M AR-94;Buil d 38
	4826	"RTN","IBJ DF4",3,0)
	4827	;Per VA D irective 6 402, this routine sh ould not b e modified .
	4828	"RTN","IBJ DF4",4,0)
	4829	;
	4830	"RTN","IBJ DF4",5,0)
	4831	EN ; - Opt ion entry point.
	4832	"RTN","IBJ DF4",6,0)
	4833	S IBEXCEL =0
	4834	"RTN","IBJ DF4",7,0)
	4835	N X,XX,I, CH,LAST
	4836	"RTN","IBJ DF4",8,0)
	4837	K IBSUS
	4838	"RTN","IBJ DF4",9,0)
	4839	S XX=^DD( 433,90,0), XX=$P(XX," ^",3) F I= 1:1 S CH=$ P(XX,";",I ) Q:CH="" S IBSUS($ P(CH,":",1 ))=$P(CH," :",2)
	4840	"RTN","IBJ DF4",10,0)
	4841	S LAST=$O (IBSUS("") ,-1),IBSUS (LAST+1)=" NONE"
	4842	"RTN","IBJ DF4",11,0)
	4843	S LAST=LA ST+2,IBSUS (LAST)="AL L OF THE A BOVE"
	4844	"RTN","IBJ DF4",12,0)
	4845	;
	4846	"RTN","IBJ DF4",13,0)
	4847	; - Selec t AR categ ories to p rint.
	4848	"RTN","IBJ DF4",14,0)
	4849	S IBPRT=" Choose whi ch type of receivabl es to prin t:"
	4850	"RTN","IBJ DF4",15,0)
	4851	K IBOPT
	4852	"RTN","IBJ DF4",16,0)
	4853	S IBOPT(1 )="EMERGEN CY/HUMANIT ARIAN"
	4854	"RTN","IBJ DF4",17,0)
	4855	S IBOPT(2 )="INELIGI BLE"
	4856	"RTN","IBJ DF4",18,0)
	4857	S IBOPT(3 )="C-MEANS TEST & RX COPAY"
	4858	"RTN","IBJ DF4",19,0)
	4859	S IBOPT(4 )="LONG TE RM CARE CO PAY"
	4860	"RTN","IBJ DF4",20,0)
	4861	S IBOPT(5 )="ALL OF THE ABOVE"
	4862	"RTN","IBJ DF4",21,0)
	4863	S IBSEL=$ $MLTP^IBJD (IBPRT,.IB OPT,1) I ' IBSEL G EN Q
	4864	"RTN","IBJ DF4",22,0)
	4865	;
	4866	"RTN","IBJ DF4",23,0)
	4867	STA ; - Ch oose bill status.
	4868	"RTN","IBJ DF4",24,0)
	4869	W !!,"Run report fo r (A)CTIVE ARs, (S)U SPENDED AR s, or (B)O TH: B// "
	4870	"RTN","IBJ DF4",25,0)
	4871	R X:DTIME G:'$T!(X[ "^") ENQ S :X="" X="B " S X=$E(X )
	4872	"RTN","IBJ DF4",26,0)
	4873	I "AaBbSs "'[X S IBO FF=1 D HEL P^IBJDF4H G STA
	4874	"RTN","IBJ DF4",27,0)
	4875	S IBSTA=$ S("Aa"[X:" A","Ss"[X: "S",1:"B")
	4876	"RTN","IBJ DF4",28,0)
	4877	W " ",$S (IBSTA="A" :"ACTIVE", IBSTA="S": "SUSPENDED ",1:"BOTH" )
	4878	"RTN","IBJ DF4",29,0)
	4879	;
	4880	"RTN","IBJ DF4",30,0)
	4881	SUSTYP ;If SUSPENDED is chosen , prompt f or which s uspended b ills to di splay IB2 .0568/DRF
	4882	"RTN","IBJ DF4",31,0)
	4883	I IBSTA=" S" D
	4884	"RTN","IBJ DF4",32,0)
	4885	. S IBPRT ="Choose w hich suspe nded types to print: "
	4886	"RTN","IBJ DF4",33,0)
	4887	. S IBSEL ST=$$MLTP0 (IBPRT,.IB SUS,1)
	4888	"RTN","IBJ DF4",34,0)
	4889	I IBSTA=" S",IBSELST ="" G ENQ
	4890	"RTN","IBJ DF4",35,0)
	4891	;
	4892	"RTN","IBJ DF4",36,0)
	4893	; - Selec t a detail ed or summ ary report .
	4894	"RTN","IBJ DF4",37,0)
	4895	D DS^IBJD G ENQ:IBR PT["^"
	4896	"RTN","IBJ DF4",38,0)
	4897	I IBRPT=" S" D G RC
	4898	"RTN","IBJ DF4",39,0)
	4899	. S IBSN= "N",IBSNA= "ALL",IBSN F="",IBSNL ="zzzzz",I BSMN="A"
	4900	"RTN","IBJ DF4",40,0)
	4901	;
	4902	"RTN","IBJ DF4",41,0)
	4903	; - Deter mine sorti ng (By nam e or Last 4 SSN)
	4904	"RTN","IBJ DF4",42,0)
	4905	S IBSN=$$ SNL^IBJD() G ENQ:IBS N="^"
	4906	"RTN","IBJ DF4",43,0)
	4907	;
	4908	"RTN","IBJ DF4",44,0)
	4909	; - Deter mine the r ange
	4910	"RTN","IBJ DF4",45,0)
	4911	S X=$$INT V^IBJD("PA TIENT "_$S (IBSN="N": "NAME",1:" LAST 4")) G ENQ:X="^ "
	4912	"RTN","IBJ DF4",46,0)
	4913	S IBSNF=$ P(X,"^",1) ,IBSNL=$P( X,"^",2),I BSNA=$P(X, "^",3)
	4914	"RTN","IBJ DF4",47,0)
	4915	;
	4916	"RTN","IBJ DF4",48,0)
	4917	AGE ; - De termine if the activ e receivab le must be within an age range .
	4918	"RTN","IBJ DF4",49,0)
	4919	W !!,"Inc lude (A)LL ",$S(IBST A="A":"act ive ",IBST A="S":"sus pended ",1 :""),"ARs or those w ithin an A GE (R)ANGE : ALL// "
	4920	"RTN","IBJ DF4",50,0)
	4921	R X:DTIME G:'$T!(X[ "^") ENQ S :X="" X="A " S X=$E(X )
	4922	"RTN","IBJ DF4",51,0)
	4923	I "ARar"' [X S IBOFF =9 D HELP^ IBJDF4H G AGE
	4924	"RTN","IBJ DF4",52,0)
	4925	S IBSMN=$ S("Rr"[X:" R",1:"A") W " ",$S( IBSMN="R": "RANGE",1: "ALL")
	4926	"RTN","IBJ DF4",53,0)
	4927	I IBSMN=" A" G AMT
	4928	"RTN","IBJ DF4",54,0)
	4929	;
	4930	"RTN","IBJ DF4",55,0)
	4931	; - Deter mine the a ctive rece ivable age range.
	4932	"RTN","IBJ DF4",56,0)
	4933	W !,"EXAM PLE Range: 31-60 day s"
	4934	"RTN","IBJ DF4",57,0)
	4935	S DIR(0)= "NA^1:9999 9"
	4936	"RTN","IBJ DF4",58,0)
	4937	S DIR("A" )="Enter t he minimum age of th e receivab le: "
	4938	"RTN","IBJ DF4",59,0)
	4939	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=16 D HELP^IBJ DF4H"
	4940	"RTN","IBJ DF4",60,0)
	4941	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4942	"RTN","IBJ DF4",61,0)
	4943	S IBSMN=+ Y W " ", IBSMN," DA YS" K DIRO UT,DTOUT,D UOUT,DIRUT
	4944	"RTN","IBJ DF4",62,0)
	4945	;
	4946	"RTN","IBJ DF4",63,0)
	4947	S DIR(0)= "NA^"_IBSM N_":99999"
	4948	"RTN","IBJ DF4",64,0)
	4949	S DIR("A" )="Enter t he maximum age of th e receivab le: "
	4950	"RTN","IBJ DF4",65,0)
	4951	S DIR("B" )=IBSMN,DI R("T")=DTI ME,DIR("?" )="^S IBOF F=21 D HEL P^IBJDF4H"
	4952	"RTN","IBJ DF4",66,0)
	4953	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4954	"RTN","IBJ DF4",67,0)
	4955	S IBSMX=+ Y W " ", IBSMX," DA YS" K DIRO UT,DTOUT,D UOUT,DIRUT
	4956	"RTN","IBJ DF4",68,0)
	4957	;
	4958	"RTN","IBJ DF4",69,0)
	4959	AMT ; - Pr int receiv ables with a minimum balance.
	4960	"RTN","IBJ DF4",70,0)
	4961	S DIR(0)= "Y",DIR("B ")="NO" W !
	4962	"RTN","IBJ DF4",71,0)
	4963	S DIR("A" )="Print r eceivables with a mi nimum bala nce"
	4964	"RTN","IBJ DF4",72,0)
	4965	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=26 D HELP^IBJ DF4H"
	4966	"RTN","IBJ DF4",73,0)
	4967	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4968	"RTN","IBJ DF4",74,0)
	4969	S IBSAM=+ Y K DIROUT ,DTOUT,DUO UT,DIRUT G :'IBSAM EX CEL
	4970	"RTN","IBJ DF4",75,0)
	4971	;
	4972	"RTN","IBJ DF4",76,0)
	4973	AMT1 ; - D etermine t he minimum balance a mount.
	4974	"RTN","IBJ DF4",77,0)
	4975	S DIR(0)= "NA^1:9999 999"
	4976	"RTN","IBJ DF4",78,0)
	4977	S DIR("A" )="Enter t he minimum balance a mount of t he receiva ble: "
	4978	"RTN","IBJ DF4",79,0)
	4979	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=33 D HELP^IBJ DF4H"
	4980	"RTN","IBJ DF4",80,0)
	4981	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4982	"RTN","IBJ DF4",81,0)
	4983	S IBSAM=+ Y K DIROUT ,DTOUT,DUO UT,DIRUT
	4984	"RTN","IBJ DF4",82,0)
	4985	;
	4986	"RTN","IBJ DF4",83,0)
	4987	EXCEL ; - Determine whether to gather da ta for Exc el report.
	4988	"RTN","IBJ DF4",84,0)
	4989	S IBEXCEL =$$EXCEL^I BJD() G EN Q:IBEXCEL= "^"
	4990	"RTN","IBJ DF4",85,0)
	4991	I IBEXCEL S IBSH=1, IBSH1="M" G RC
	4992	"RTN","IBJ DF4",86,0)
	4993	;
	4994	"RTN","IBJ DF4",87,0)
	4995	BCH ; - De termine wh ether to i nclude the bill comm ent histor y.
	4996	"RTN","IBJ DF4",88,0)
	4997	S DIR(0)= "Y",DIR("B ")="NO" W !
	4998	"RTN","IBJ DF4",89,0)
	4999	S DIR("A" )="Include the bill comment hi story with each rece ivable"
	5000	"RTN","IBJ DF4",90,0)
	5001	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=38 D HELP^IBJ DF4H"
	5002	"RTN","IBJ DF4",91,0)
	5003	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	5004	"RTN","IBJ DF4",92,0)
	5005	S IBSH=+Y K DIROUT, DTOUT,DUOU T,DIRUT G: 'IBSH RC
	5006	"RTN","IBJ DF4",93,0)
	5007	;
	5008	"RTN","IBJ DF4",94,0)
	5009	S DIR(0)= "SA^A:ALL; M:MOST REC ENT"
	5010	"RTN","IBJ DF4",95,0)
	5011	S DIR("A" )="Print ( A)LL comme nts or the (M)OST RE CENT comme nt: "
	5012	"RTN","IBJ DF4",96,0)
	5013	S DIR("B" )="ALL",DI R("T")=DTI ME,DIR("?" )="^S IBOF F=47 D HEL P^IBJDF4H"
	5014	"RTN","IBJ DF4",97,0)
	5015	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	5016	"RTN","IBJ DF4",98,0)
	5017	S IBSH1=Y K DIROUT, DTOUT,DUOU T,DIRUT G: IBSH1="A" RC
	5018	"RTN","IBJ DF4",99,0)
	5019	;
	5020	"RTN","IBJ DF4",100,0 )
	5021	S DIR(0)= "NAO^1:999 "
	5022	"RTN","IBJ DF4",101,0 )
	5023	S DIR("A" )="Minimum age of mo st recent bill comme nt (option al): "
	5024	"RTN","IBJ DF4",102,0 )
	5025	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=54 D HELP^IBJ DF4H"
	5026	"RTN","IBJ DF4",103,0 )
	5027	D ^DIR K DIR G:$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	5028	"RTN","IBJ DF4",104,0 )
	5029	S IBSH2=+ Y W:IBSH2 " days" K DIROUT,DTO UT,DUOUT
	5030	"RTN","IBJ DF4",105,0 )
	5031	;
	5032	"RTN","IBJ DF4",106,0 )
	5033	RC ; - Inc lude recei vables ref erred to R egional Co unsel?
	5034	"RTN","IBJ DF4",107,0 )
	5035	S DIR(0)= "Y",DIR("B ")="NO",DI R("T")=DTI ME W !
	5036	"RTN","IBJ DF4",108,0 )
	5037	S DIR("A" )="Include ARs refer red to Reg ional Coun sel"
	5038	"RTN","IBJ DF4",109,0 )
	5039	S DIR("?" )="^S IBOF F=61 D HEL P^IBJDF4H"
	5040	"RTN","IBJ DF4",110,0 )
	5041	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	5042	"RTN","IBJ DF4",111,0 )
	5043	S IBSRC=+ Y K DIROUT ,DTOUT,DUO UT,DIRUT
	5044	"RTN","IBJ DF4",112,0 )
	5045	;
	5046	"RTN","IBJ DF4",113,0 )
	5047	DEV ; - Se lect a dev ice.
	5048	"RTN","IBJ DF4",114,0 )
	5049	I '$G(IBE XCEL) D
	5050	"RTN","IBJ DF4",115,0 )
	5051	. W !!,"N ote: This report wil l search t hrough all "
	5052	"RTN","IBJ DF4",116,0 )
	5053	. W $S(IB STA="A":"a ctive",IBS TA="S":"su spended",1 :"active & suspended ")," recei vables."
	5054	"RTN","IBJ DF4",117,0 )
	5055	. W !?6," It is reco mmended th at you que ue it to r un after n ormal busi ness hours ."
	5056	"RTN","IBJ DF4",118,0 )
	5057	;
	5058	"RTN","IBJ DF4",119,0 )
	5059	I $G(IBEX CEL) D EXM SG^IBJD
	5060	"RTN","IBJ DF4",120,0 )
	5061	;
	5062	"RTN","IBJ DF4",121,0 )
	5063	W ! S %ZI S="QM" D ^ %ZIS G:POP ENQ
	5064	"RTN","IBJ DF4",122,0 )
	5065	I $D(IO(" Q")) D G ENQ
	5066	"RTN","IBJ DF4",123,0 )
	5067	.S ZTRTN= "DQ^IBJDF4 ",ZTDESC=" IB - FIRST PARTY FOL LOW-UP REP ORT"
	5068	"RTN","IBJ DF4",124,0 )
	5069	.S ZTSAVE ("IB*")="" D ^%ZTLOA D
	5070	"RTN","IBJ DF4",125,0 )
	5071	.I $G(ZTS K) W !!,"T his job ha s been que ued. The t ask no. is ",ZTSK,". "
	5072	"RTN","IBJ DF4",126,0 )
	5073	.E W !!, "Unable to queue thi s job."
	5074	"RTN","IBJ DF4",127,0 )
	5075	.K ZTSK,I O("Q") D H OME^%ZIS
	5076	"RTN","IBJ DF4",128,0 )
	5077	;
	5078	"RTN","IBJ DF4",129,0 )
	5079	U IO
	5080	"RTN","IBJ DF4",130,0 )
	5081	;
	5082	"RTN","IBJ DF4",131,0 )
	5083	; If call ed by the Extraction Module, c hange extr act status for the 5
	5084	"RTN","IBJ DF4",132,0 )
	5085	; reports : Emergenc y/Humanita rian, Inel igible rec eivables, C-Means Te st,
	5086	"RTN","IBJ DF4",133,0 )
	5087	; RX Copay /SC VET an d RX Copay /NSC VET
	5088	"RTN","IBJ DF4",134,0 )
	5089	DQ I $G(IB XTRACT) F I=12:1:16 D E^IBJDE( I,1)
	5090	"RTN","IBJ DF4",135,0 )
	5091	;
	5092	"RTN","IBJ DF4",136,0 )
	5093	D ST^IBJD F41 ; Co mpile and print the report.
	5094	"RTN","IBJ DF4",137,0 )
	5095	;
	5096	"RTN","IBJ DF4",138,0 )
	5097	ENQ K IBSE L,IBSN,IBS NF,IBSNL,I BOFF,IBSNA ,IBSH,IBSH 1,IBSH2,IB SAM,IBSRC, IBTEXT
	5098	"RTN","IBJ DF4",139,0 )
	5099	K IBI,IBO PT,IBPRT,I BSTA,IBEXC EL,IBRPT,I BSMN,IBSMX ,POP,DIROU T,DTOUT,DU OUT
	5100	"RTN","IBJ DF4",140,0 )
	5101	K DIRUT,% ZIS,ZTDESC ,ZTRTN,ZTS AVE,I,X,Y
	5102	"RTN","IBJ DF4",141,0 )
	5103	Q
	5104	"RTN","IBJ DF4",142,0 )
	5105	;
	5106	"RTN","IBJ DF4",143,0 )
	5107	MLTP0(PRPT ,OPT,ALL) ; Function for multi ple value selection
	5108	"RTN","IBJ DF4",144,0 )
	5109	; Input: PRPT - Str ing to be prompted t o the user , before l isting opt ions
	5110	"RTN","IBJ DF4",145,0 )
	5111	; OPT - Arr ay contain ing the po ssible ent ries (inde xed by cod e)
	5112	"RTN","IBJ DF4",146,0 )
	5113	; Obs : Code mus t be seque ntial star ting with 0
	5114	"RTN","IBJ DF4",147,0 )
	5115	; ALL - Fla g indicati ng if the last optio n is ALL O F THE ABOV E
	5116	"RTN","IBJ DF4",148,0 )
	5117	;
	5118	"RTN","IBJ DF4",149,0 )
	5119	; Output: MLTP - Us er selecti on, i.e. " ,1,2,3," o r "1," or NULL (noth ing
	5120	"RTN","IBJ DF4",150,0 )
	5121	; w as selecte d)
	5122	"RTN","IBJ DF4",151,0 )
	5123	;
	5124	"RTN","IBJ DF4",152,0 )
	5125	N A,DIR,D IRUT,DTOUT ,DUOUT,DIR OUT,I,IX,L ST,MLTP
	5126	"RTN","IBJ DF4",153,0 )
	5127	;
	5128	"RTN","IBJ DF4",154,0 )
	5129	PRPT S MLT P="",ALL=+ $G(ALL)
	5130	"RTN","IBJ DF4",155,0 )
	5131	S LST=$O( OPT(""),-1 )
	5132	"RTN","IBJ DF4",156,0 )
	5133	S DIR(0)= "LO^0:"_LS T_"^K:+$P( X,""-"",2) >"_LST_" X "
	5134	"RTN","IBJ DF4",157,0 )
	5135	S DIR("A" ,1)=$G(PRP T),DIR("A" ,2)=""
	5136	"RTN","IBJ DF4",158,0 )
	5137	S A="",IX =3
	5138	"RTN","IBJ DF4",159,0 )
	5139	F S A=$O (OPT(A)) Q:A="" D
	5140	"RTN","IBJ DF4",160,0 )
	5141	. S DIR(" A",IX)=" "_A_" - " _$G(OPT(A) ),IX=IX+1
	5142	"RTN","IBJ DF4",161,0 )
	5143	S DIR("A" ,IX)="",DI R("A")="Se lect",DIR( "B")=LST,D IR("T")=DT IME W !
	5144	"RTN","IBJ DF4",162,0 )
	5145	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) G Q T
	5146	"RTN","IBJ DF4",163,0 )
	5147	S MLTP=Y K DIROUT,D TOUT,DUOUT ,DIRUT
	5148	"RTN","IBJ DF4",164,0 )
	5149	;
	5150	"RTN","IBJ DF4",165,0 )
	5151	I ALL,MLT P[LST S ML TP=LST_","
	5152	"RTN","IBJ DF4",166,0 )
	5153	;
	5154	"RTN","IBJ DF4",167,0 )
	5155	S DIR(0)= "Y",DIR("A ",1)="You have selec ted",DIR(" A",2)=""
	5156	"RTN","IBJ DF4",168,0 )
	5157	S A="",IX =3
	5158	"RTN","IBJ DF4",169,0 )
	5159	F I=1:1:( $L(MLTP,", ")-1) D
	5160	"RTN","IBJ DF4",170,0 )
	5161	. S DIR(" A",IX)=" "_$P(MLT P,",",I)_" - "_$G(OP T($P(MLTP, ",",I)))
	5162	"RTN","IBJ DF4",171,0 )
	5163	. S IX=IX +1
	5164	"RTN","IBJ DF4",172,0 )
	5165	S DIR("A" ,IX)=""
	5166	"RTN","IBJ DF4",173,0 )
	5167	S DIR("A" )="Are you sure",DIR ("B")="NO" ,DIR("T")= DTIME W !
	5168	"RTN","IBJ DF4",174,0 )
	5169	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) S M LTP="" G Q T
	5170	"RTN","IBJ DF4",175,0 )
	5171	K DIROUT, DTOUT,DUOU T,DIRUT I 'Y K DIR G PRPT
	5172	"RTN","IBJ DF4",176,0 )
	5173	;
	5174	"RTN","IBJ DF4",177,0 )
	5175	I ALL,MLT P[LST D
	5176	"RTN","IBJ DF4",178,0 )
	5177	. S MLTP= "" F I=(LS T-1):-1:0 S MLTP=I_" ,"_MLTP
	5178	"RTN","IBJ DF4",179,0 )
	5179	;
	5180	"RTN","IBJ DF4",180,0 )
	5181	QT I MLTP' ="" S MLTP =","_MLTP
	5182	"RTN","IBJ DF4",181,0 )
	5183	Q MLTP
	5184	"RTN","IBJ DF41")
	5185	0^20^B1030 09700^B888 27246
	5186	"RTN","IBJ DF41",1,0)
	5187	IBJDF41 ;A LB/RB - FI RST PARTY FOLLOW-UP REPORT (CO MPILE) ;15 -APR-00
	5188	"RTN","IBJ DF41",2,0)
	5189	;;2.0;INT EGRATED BI LLING;12 3,159,204, 356,451,47 3,568;21 -MAR-94;Bu ild 38
	5190	"RTN","IBJ DF41",3,0)
	5191	;;Per VA Directive 6402, this routine s hould not be modifie d.
	5192	"RTN","IBJ DF41",4,0)
	5193	;
	5194	"RTN","IBJ DF41",5,0)
	5195	ST ; - Tas ked entry point.
	5196	"RTN","IBJ DF41",6,0)
	5197	K IB,IBCA T,^TMP("IB JDF4",$J)
	5198	"RTN","IBJ DF41",7,0)
	5199	S IBQ=0
	5200	"RTN","IBJ DF41",8,0)
	5201	;
	5202	"RTN","IBJ DF41",9,0)
	5203	; - Set s elected ca tegories f or report.
	5204	"RTN","IBJ DF41",10,0 )
	5205	I IBSEL[1 S IBCAT(2 )=1
	5206	"RTN","IBJ DF41",11,0 )
	5207	I IBSEL[2 S IBCAT(1 )=2
	5208	"RTN","IBJ DF41",12,0 )
	5209	I IBSEL[3 S IBCAT(1 8)=3 F X=2 2,23 S IBC AT(X)=4
	5210	"RTN","IBJ DF41",13,0 )
	5211	I IBSEL[4 F X=33:1: 39 S IBCAT (X)=5
	5212	"RTN","IBJ DF41",14,0 )
	5213	;
	5214	"RTN","IBJ DF41",15,0 )
	5215	; - Print the heade r line for the Excel spreadshe et
	5216	"RTN","IBJ DF41",16,0 )
	5217	I $G(IBEX CEL) D PHD L
	5218	"RTN","IBJ DF41",17,0 )
	5219	;
	5220	"RTN","IBJ DF41",18,0 )
	5221	; - Find data requi red for re port.
	5222	"RTN","IBJ DF41",19,0 )
	5223	F IB=16,1 9,40 D G: IBQ ENQ
	5224	"RTN","IBJ DF41",20,0 )
	5225	. I IBSTA ="A",IB'=1 6 Q ; Active A R's only.
	5226	"RTN","IBJ DF41",21,0 )
	5227	. I IBSTA ="S",IB=16 Q ; Suspende d AR's onl y.
	5228	"RTN","IBJ DF41",22,0 )
	5229	. I IB'=4 0 D
	5230	"RTN","IBJ DF41",23,0 )
	5231	. . S IBC AT=""
	5232	"RTN","IBJ DF41",24,0 )
	5233	. . F S IBCAT=$O(I BCAT(IBCAT )) Q:IBCAT ="" D
	5234	"RTN","IBJ DF41",25,0 )
	5235	. . . D I NIT^IBJDF4 3
	5236	"RTN","IBJ DF41",26,0 )
	5237	. S IBA=0
	5238	"RTN","IBJ DF41",27,0 )
	5239	. F S IB A=$O(^PRCA (430,"AC", IB,IBA)) Q :'IBA D Q:IBQ
	5240	"RTN","IBJ DF41",28,0 )
	5241	. . D PRO C
	5242	"RTN","IBJ DF41",29,0 )
	5243	;
	5244	"RTN","IBJ DF41",30,0 )
	5245	I 'IBQ,'$ G(IBEXCEL) D EN^IBJD F42 ; Prin t the repo rt.
	5246	"RTN","IBJ DF41",31,0 )
	5247	;
	5248	"RTN","IBJ DF41",32,0 )
	5249	ENQ K ^TMP ("IBJDF4", $J)
	5250	"RTN","IBJ DF41",33,0 )
	5251	I $D(ZTQU EUED) S ZT REQ="@" G ENQ1
	5252	"RTN","IBJ DF41",34,0 )
	5253	;
	5254	"RTN","IBJ DF41",35,0 )
	5255	D ^%ZISC
	5256	"RTN","IBJ DF41",36,0 )
	5257	ENQ1 K IB, IB0,IBA,IB A1,IBADM,I BAGE,IBAR, IBAR1,IBBA ,IBBN,IBBU ,IBC,IBCAT ,IBCAT1
	5258	"RTN","IBJ DF41",37,0 )
	5259	K IBELIG, IBEXCEL,IB FLG,IBAI,I BAIQ,IBIDX ,IBIO,IBIN T,IBN,IBPA ,IBPD,IBPA T
	5260	"RTN","IBJ DF41",38,0 )
	5261	K IBPT,IB Q,IBRFD,IB RFT,IBSRC, IBRP,IBVA, COM,COM1,D AT,DFN,X,X 1,X2,Y,Z
	5262	"RTN","IBJ DF41",39,0 )
	5263	Q
	5264	"RTN","IBJ DF41",40,0 )
	5265	;
	5266	"RTN","IBJ DF41",41,0 )
	5267	PROC ; - P rocess dat a for repo rt(s).
	5268	"RTN","IBJ DF41",42,0 )
	5269	I IBA#100 =0 D Q:IB Q
	5270	"RTN","IBJ DF41",43,0 )
	5271	. S IBQ=$ $STOP^IBOU TL("First Party Foll ow-Up Repo rt")
	5272	"RTN","IBJ DF41",44,0 )
	5273	S IBAR=$G (^PRCA(430 ,IBA,0)) I 'IBAR Q
	5274	"RTN","IBJ DF41",45,0 )
	5275	S IBCAT=+ $P(IBAR,U, 2) I '$D(I BCAT(IBCAT )) Q ; Ge t valid AR category.
	5276	"RTN","IBJ DF41",46,0 )
	5277	I '$$CLMA CT^IBJD(IB A,IBCAT) Q ; In valid IB c laim/actio n.
	5278	"RTN","IBJ DF41",47,0 )
	5279	S IBSUSTY P=""
	5280	"RTN","IBJ DF41",48,0 )
	5281	I IB=40 S IBSUSTYP= $$SUST(IBA )
	5282	"RTN","IBJ DF41",49,0 )
	5283	I IBSTA=" S",IBSELST '[(","_IBS USTYP_",") Q ; Fi lter by su spended ty pe IB256 8/DRF
	5284	"RTN","IBJ DF41",50,0 )
	5285	S IBPT=$$ PAT(IBA) I IBPT="" Q ; Ge t patient info.
	5286	"RTN","IBJ DF41",51,0 )
	5287	S DFN=$P( IBPT,U,2)
	5288	"RTN","IBJ DF41",52,0 )
	5289	S IBAGE=$ $FMDIFF^XL FDT(DT,+$P (IBAR,U,10 ))
	5290	"RTN","IBJ DF41",53,0 )
	5291	I IBSMN,I BAGE<IBSMN !(IBAGE>IB SMX) Q ; AR outside a ge range.
	5292	"RTN","IBJ DF41",54,0 )
	5293	S IBVA=$$ VA^IBJD1(D FN),IBBN=$ P(IBAR,U), IBPD=$P($$ PYMT^IBJD1 (IBA),U)
	5294	"RTN","IBJ DF41",55,0 )
	5295	S IBPAT=$ P(IBPT,U)_ "@@"_DFN
	5296	"RTN","IBJ DF41",56,0 )
	5297	;
	5298	"RTN","IBJ DF41",57,0 )
	5299	; - Check the AR ba lance amou nts, if ne cessary.
	5300	"RTN","IBJ DF41",58,0 )
	5301	S (IBADM, IBBA,IBINT ,IBPA)=0,I BN=$G(^PRC A(430,IBA, 7))
	5302	"RTN","IBJ DF41",59,0 )
	5303	F X=1:1:5 D
	5304	"RTN","IBJ DF41",60,0 )
	5305	. S IBBA= IBBA+$P(IB N,U,X)
	5306	"RTN","IBJ DF41",61,0 )
	5307	. S:X=1 I BPA=+IBN S :X=2 IBINT =$P(IBN,U, 2) S:X=3 I BADM=$P(IB N,U,3)
	5308	"RTN","IBJ DF41",62,0 )
	5309	;
	5310	"RTN","IBJ DF41",63,0 )
	5311	I '$G(IBE XCEL) D EN ^IBJDF43 I IBRPT="S" Q ; Ge t summary stats.
	5312	"RTN","IBJ DF41",64,0 )
	5313	;
	5314	"RTN","IBJ DF41",65,0 )
	5315	I IBSAM,I BBA<IBSAM Q
	5316	"RTN","IBJ DF41",66,0 )
	5317	;
	5318	"RTN","IBJ DF41",67,0 )
	5319	; - Check if AR was referred to R-Regio nal Counse l, D-DMC, or T-TOP
	5320	"RTN","IBJ DF41",68,0 )
	5321	; and e xclude, if necessary .
	5322	"RTN","IBJ DF41",69,0 )
	5323	S IB0=$S( IB=40:19,1 :IB),IBIDX =0,IBRFT=" "
	5324	"RTN","IBJ DF41",70,0 )
	5325	S IBAIQ=0 ,IBAI=$G(^ TMP("IBJDF 4",$J,IBPA T,0,"A"))
	5326	"RTN","IBJ DF41",71,0 )
	5327	S IBRFD=$ P($G(^PRCA (430,IBA,6 )),U,4)
	5328	"RTN","IBJ DF41",72,0 )
	5329	I IBRPT=" D",IBRFD D I IBAIQ Q ; Referred to RC
	5330	"RTN","IBJ DF41",73,0 )
	5331	. S IBRFT ="R" I IBA I'["R" S I BAI=IBAI_" R"
	5332	"RTN","IBJ DF41",74,0 )
	5333	. I 'IBSR C S IBAIQ= 1 Q
	5334	"RTN","IBJ DF41",75,0 )
	5335	. D SREF( "R",IBRFD, IB0,,.IBID X)
	5336	"RTN","IBJ DF41",76,0 )
	5337	S IBRFD=+ $G(^PRCA(4 30,IBA,12) )
	5338	"RTN","IBJ DF41",77,0 )
	5339	I IBRPT=" D",IBRFD D ; Referred to DMC
	5340	"RTN","IBJ DF41",78,0 )
	5341	. S IBRFT =IBRFT_"D" I IBAI'[" D" S IBAI= IBAI_"D"
	5342	"RTN","IBJ DF41",79,0 )
	5343	. D SREF( "D",IBRFD, IB0,,.IBID X)
	5344	"RTN","IBJ DF41",80,0 )
	5345	S IBRFD=+ $G(^PRCA(4 30,IBA,14) )
	5346	"RTN","IBJ DF41",81,0 )
	5347	I IBRPT=" D",IBRFD D ; Referred to TOP
	5348	"RTN","IBJ DF41",82,0 )
	5349	. S IBRFT =IBRFT_"T" I IBAI'[" T" S IBAI= IBAI_"T"
	5350	"RTN","IBJ DF41",83,0 )
	5351	. D SREF( "T",IBRFD, IB0,,.IBID X)
	5352	"RTN","IBJ DF41",84,0 )
	5353	;
	5354	"RTN","IBJ DF41",85,0 )
	5355	; - Check if AR is on P-Repay ment plan or F-Defau lted repay ment plan.
	5356	"RTN","IBJ DF41",86,0 )
	5357	; and e xclude if repayment plan is ac tive.
	5358	"RTN","IBJ DF41",87,0 )
	5359	S IBRP=$$ RP(IBA)
	5360	"RTN","IBJ DF41",88,0 )
	5361	I IBRP D
	5362	"RTN","IBJ DF41",89,0 )
	5363	. I IBRP= 2 S IBRFT= IBRFT_"F" I IBAI'[" F" S IBAI= IBAI_"F"
	5364	"RTN","IBJ DF41",90,0 )
	5365	. I IBRP= 1 S IBRFT= IBRFT_"P" I IBAI'["P "&(IBAI'[" F") S IBAI =IBAI_"P"
	5366	"RTN","IBJ DF41",91,0 )
	5367	. D SREF( "P",$P(IBR P,"^",2),I B0,$S(+IBR P=2:1,1:0) ,.IBIDX)
	5368	"RTN","IBJ DF41",92,0 )
	5369	;
	5370	"RTN","IBJ DF41",93,0 )
	5371	I IBIDX S IBFLG=1
	5372	"RTN","IBJ DF41",94,0 )
	5373	;
	5374	"RTN","IBJ DF41",95,0 )
	5375	; - Check if VA Emp loyee
	5376	"RTN","IBJ DF41",96,0 )
	5377	I $P(IBVA ,"^")["*", IBAI'["V" S IBAI=IBA I_"V"
	5378	"RTN","IBJ DF41",97,0 )
	5379	;
	5380	"RTN","IBJ DF41",98,0 )
	5381	I IBAI'=" " S ^TMP(" IBJDF4",$J ,IBPAT,0," A")=IBAI
	5382	"RTN","IBJ DF41",99,0 )
	5383	;
	5384	"RTN","IBJ DF41",100, 0)
	5385	; IB2.0 451 - Chec k for EEOB on associ ated 3rd p arty bills and attac h EOB indi cator '%' if applica ble
	5386	"RTN","IBJ DF41",101, 0)
	5387	S IBBN=$$ IBEEOBCK(I BBN,DFN)_I BBN ; Pas s AR BILL# , Pat ID
	5388	"RTN","IBJ DF41",102, 0)
	5389	;
	5390	"RTN","IBJ DF41",103, 0)
	5391	; - Set u p indexes for detail report.
	5392	"RTN","IBJ DF41",104, 0)
	5393	I $G(IBEX CEL) D Q
	5394	"RTN","IBJ DF41",105, 0)
	5395	. S IBEXC EL1=$P($G( ^PRCA(430. 2,IBCAT,0) ),U,2)_U_$ P(IBPT,U,3 )_U_$P(IBV A,U)_U_$P( IBPT,U,4)_ U_$$DT^IBJ D($P(IBPT, U,6),1)_U_ $$ELIG^IBJ DF42(+$P(I BPT,U,5))_ U
	5396	"RTN","IBJ DF41",106, 0)
	5397	. S IBEXC EL1=IBEXCE L1_$$GET1^ DIQ(2,DFN, .381)_U_$$ MTRX(DFN)_ U_IBBN_U_$ S(IB=16:"A ",1:"S")_U _$S("BS"[I BSTA:$$ABB R($G(IBSUS TYP)),1:"" )_U_IBRFT_ U_$$DT^IBJ D($P(IBAR, U,10),1)_U _$$DT^IBJD (IBPD,1)_U _IBBA_U_IB PA_U_IBINT _U_IBADM_U
	5398	"RTN","IBJ DF41",107, 0)
	5399	. I IBSH D COM
	5400	"RTN","IBJ DF41",108, 0)
	5401	. S IBD=0 I DAT!IBP D S IBD=$$ FMDIFF^XLF DT(DT,$S(' DAT:IBPD,1 :$G(DAT)))
	5402	"RTN","IBJ DF41",109, 0)
	5403	. S IBEXC EL1=IBEXCE L1_U_IBD
	5404	"RTN","IBJ DF41",110, 0)
	5405	. W !,IBE XCEL1 K IB D,IBEXCEL1
	5406	"RTN","IBJ DF41",111, 0)
	5407	;
	5408	"RTN","IBJ DF41",112, 0)
	5409	I '($D(^T MP("IBJDF4 ",$J,IBPAT ))#10) D
	5410	"RTN","IBJ DF41",113, 0)
	5411	. S ^TMP( "IBJDF4",$ J,IBPAT)=$ P(IBPT,U,3 ,5)_U_$$MT RX(DFN)_U_ $P(IBPT,U, 6)_"^"_$P( IBVA,"^",2 )_"^"_$$AC CBAL($P(IB PT,U,7))
	5412	"RTN","IBJ DF41",114, 0)
	5413	S ^TMP("I BJDF4",$J, IBPAT,IB0, IBCAT,IBBN )=IBPD_U_I BBA_U_IBPA _U_IBINT_U _IBADM_U_I BIDX_U_$S( $D(IBSUSTY P):IBSUSTY P,1:"")
	5414	"RTN","IBJ DF41",115, 0)
	5415	;
	5416	"RTN","IBJ DF41",116, 0)
	5417	I IBSH D COM
	5418	"RTN","IBJ DF41",117, 0)
	5419	Q
	5420	"RTN","IBJ DF41",118, 0)
	5421	;
	5422	"RTN","IBJ DF41",119, 0)
	5423	ACCBAL(DFN ) ; Calcul ates the A ccount Bal ance for t he Bill
	5424	"RTN","IBJ DF41",120, 0)
	5425	; Input: DFN - Pati ent/Debtor internal number
	5426	"RTN","IBJ DF41",121, 0)
	5427	; Output: BAL - Pat ient/Debto r Account Balance
	5428	"RTN","IBJ DF41",122, 0)
	5429	;
	5430	"RTN","IBJ DF41",123, 0)
	5431	N B0,B7,B AL,BILL,I
	5432	"RTN","IBJ DF41",124, 0)
	5433	S (BAL,BI LL)=0
	5434	"RTN","IBJ DF41",125, 0)
	5435	F S BILL =$O(^PRCA( 430,"C",DF N,BILL)) Q :BILL="" D
	5436	"RTN","IBJ DF41",126, 0)
	5437	. S B0=$G (^PRCA(430 ,BILL,0)) I $P(B0,"^ ",8)'=16 Q
	5438	"RTN","IBJ DF41",127, 0)
	5439	. S B7=$G (^PRCA(430 ,BILL,7))
	5440	"RTN","IBJ DF41",128, 0)
	5441	. F I=1:1 :5 S BAL=B AL+$P(B7," ^",I)
	5442	"RTN","IBJ DF41",129, 0)
	5443	Q BAL
	5444	"RTN","IBJ DF41",130, 0)
	5445	;
	5446	"RTN","IBJ DF41",131, 0)
	5447	PHDL ; - P rint the h eader line for the E xcel sprea dsheet
	5448	"RTN","IBJ DF41",132, 0)
	5449	N X
	5450	"RTN","IBJ DF41",133, 0)
	5451	S X="Cat^ Patient^VA Empl.?^SS N^Dt Death ^Prim.Elig .^Med.Elig .?^"
	5452	"RTN","IBJ DF41",134, 0)
	5453	S X=X_"Me ans Tst St s^Means Ts t Dt^RX Co pay Exemp. Sts^RX Cop ay Exemp.D t^"
	5454	"RTN","IBJ DF41",135, 0)
	5455	S X=X_"Bi ll #^Act/S usp^Reason ^Refer. to ^Dt Bill p rep.^Last Pymt Dt^" ;Added rea son IB25 68/DRF
	5456	"RTN","IBJ DF41",136, 0)
	5457	S X=X_"Cu rr.Bal.^Pr inc.Bal.^I nt.^Admin. ^Last Comm .Dt^Days L st Comm.^"
	5458	"RTN","IBJ DF41",137, 0)
	5459	W !,X
	5460	"RTN","IBJ DF41",138, 0)
	5461	Q
	5462	"RTN","IBJ DF41",139, 0)
	5463	;
	5464	"RTN","IBJ DF41",140, 0)
	5465	PAT(X) ; - Find the AR patient and decid e to inclu de the AR.
	5466	"RTN","IBJ DF41",141, 0)
	5467	; Inpu t: X=AR po inter to f ile #430 a nd pre-set variables IBS*
	5468	"RTN","IBJ DF41",142, 0)
	5469	; Outpu t: Y=Sort key (name or last 4) ^ Patient pointer t o file #2
	5470	"RTN","IBJ DF41",143, 0)
	5471	; ^ Nam e ^ SSN ^ Eligibilit ies ^ Date of death (if any)
	5472	"RTN","IBJ DF41",144, 0)
	5473	; ^ Deb tor pointe r to file #340
	5474	"RTN","IBJ DF41",145, 0)
	5475	N PAT,KEY ,DBTR,DFN, DEATH,NAME ,SSN,VAEL, VADM,X1,X2
	5476	"RTN","IBJ DF41",146, 0)
	5477	S PAT="" G:'$G(X) P ATQ
	5478	"RTN","IBJ DF41",147, 0)
	5479	S DBTR=+$ P($G(^PRCA (430,X,0)) ,U,9)
	5480	"RTN","IBJ DF41",148, 0)
	5481	S X1=$P($ G(^RCD(340 ,DBTR,0)), U) G:X1'[" DPT" PATQ
	5482	"RTN","IBJ DF41",149, 0)
	5483	S DFN=+X1 G:'DFN PA TQ D DEM^V ADPT
	5484	"RTN","IBJ DF41",150, 0)
	5485	S NAME=VA DM(1),SSN= $P(VADM(2) ,"^"),DEAT H=VADM(6)\ 1
	5486	"RTN","IBJ DF41",151, 0)
	5487	S KEY=$S( IBSN="N":N AME,1:$E(S SN,6,9))
	5488	"RTN","IBJ DF41",152, 0)
	5489	I KEY=""! (IBSNF'="@ "&('DFN)) G PATQ
	5490	"RTN","IBJ DF41",153, 0)
	5491	I $D(IBSN A) G:IBSNA ="ALL"&('D FN) PATQ G :IBSNA="NU LL"&(DFN) PATQ
	5492	"RTN","IBJ DF41",154, 0)
	5493	I $G(IBSN A)="ALL" G PATC
	5494	"RTN","IBJ DF41",155, 0)
	5495	I IBSNF=" @",IBSNL=" zzzzz" G P ATC
	5496	"RTN","IBJ DF41",156, 0)
	5497	I IBSNF'= KEY,IBSNF] KEY G PATQ
	5498	"RTN","IBJ DF41",157, 0)
	5499	I IBSNL'= KEY,KEY]IB SNL G PATQ
	5500	"RTN","IBJ DF41",158, 0)
	5501	;
	5502	"RTN","IBJ DF41",159, 0)
	5503	PATC ; - S et patient eligibili ties.
	5504	"RTN","IBJ DF41",160, 0)
	5505	D ELIG^VA DPT S X2=+ $G(VAEL(1) )_";"
	5506	"RTN","IBJ DF41",161, 0)
	5507	I +X2 S X 1=0 F S X 1=$O(VAEL( 1,X1)) Q:' X1 S X2=X 2_X1_";"
	5508	"RTN","IBJ DF41",162, 0)
	5509	;
	5510	"RTN","IBJ DF41",163, 0)
	5511	S PAT=KEY _U_DFN_U_$ E(NAME,1,2 6)_U_SSN_U _X2_U_DEAT H
	5512	"RTN","IBJ DF41",164, 0)
	5513	S PAT=PAT _U_DBTR
	5514	"RTN","IBJ DF41",165, 0)
	5515	PATQ Q PAT
	5516	"RTN","IBJ DF41",166, 0)
	5517	;
	5518	"RTN","IBJ DF41",167, 0)
	5519	RP(X) ; - Check if c laim/recei vable is u nder a rep ayment pla n.
	5520	"RTN","IBJ DF41",168, 0)
	5521	; Inpu t: X=Bill pointer to file #399 /#430
	5522	"RTN","IBJ DF41",169, 0)
	5523	; Outpu t: 0-Not o n repay pl an, 1-On r epay plan, 2-On defa ulted plan
	5524	"RTN","IBJ DF41",170, 0)
	5525	N Z
	5526	"RTN","IBJ DF41",171, 0)
	5527	S Z=$$REP DATA^RCBEC HGA(X,1) I Z="" Q 0
	5528	"RTN","IBJ DF41",172, 0)
	5529	I '$P(Z," ^",7) Q (" 1^"_$P(Z," ^"))
	5530	"RTN","IBJ DF41",173, 0)
	5531	Q ("2^"_$ P(Z,"^"))
	5532	"RTN","IBJ DF41",174, 0)
	5533	;
	5534	"RTN","IBJ DF41",175, 0)
	5535	MTRX(X) ; - Return p atient's m eans test and/or RX copay stat us and mos t recent
	5536	"RTN","IBJ DF41",176, 0)
	5537	; test dates for both.
	5538	"RTN","IBJ DF41",177, 0)
	5539	; Inpu t: X=Patie nt pointer to file # 2 and opt. variable IBEXCEL
	5540	"RTN","IBJ DF41",178, 0)
	5541	; Outpu t: Y=Means test stat us ^ Date ^ RX copay status ^ Date
	5542	"RTN","IBJ DF41",179, 0)
	5543	N MTST,RX ST,Y
	5544	"RTN","IBJ DF41",180, 0)
	5545	S Y="^^^" ,MTST=$$LS T^DGMTU(X) ,RXST=$$RX ST^IBARXEU (X)
	5546	"RTN","IBJ DF41",181, 0)
	5547	I '$G(IBE XCEL) D
	5548	"RTN","IBJ DF41",182, 0)
	5549	. S $P(Y, "^",1,2)=$ P(MTST,"^" ,3)_"^"_$$ DAT1^IBOUT L($P(MTST, "^",2))
	5550	"RTN","IBJ DF41",183, 0)
	5551	. S $P(Y, "^",3)=$S( 'RXST:"NON -EXEMPT",+ RXST=1:"EX EMPT",1:"" )
	5552	"RTN","IBJ DF41",184, 0)
	5553	. I $P(Y, "^",3)'="" S $P(Y,"^ ",4)=$$DAT 1^IBOUTL($ P(RXST,"^" ,5))
	5554	"RTN","IBJ DF41",185, 0)
	5555	I $G(IBEX CEL) D
	5556	"RTN","IBJ DF41",186, 0)
	5557	. S $P(Y, "^",1,2)=$ P(MTST,"^" ,4)_"^"_$$ DT^IBJD($P (MTST,"^", 2),1)
	5558	"RTN","IBJ DF41",187, 0)
	5559	. S $P(Y, "^",3)=$S( 'RXST:"M", +RXST=1:"E ",1:"")
	5560	"RTN","IBJ DF41",188, 0)
	5561	. I $P(Y, "^",3)'="" S $P(Y,"^ ",4)=$$DT^ IBJD($P(RX ST,"^",5), 1)
	5562	"RTN","IBJ DF41",189, 0)
	5563	Q Y
	5564	"RTN","IBJ DF41",190, 0)
	5565	;
	5566	"RTN","IBJ DF41",191, 0)
	5567	SREF(RFT,D AT,STS,DEF ,IDX) ; Se t the "ref erred to" informatio n on the
	5568	"RTN","IBJ DF41",192, 0)
	5569	; tem porary glo bal ^TMP
	5570	"RTN","IBJ DF41",193, 0)
	5571	;Input: R FT: "R": R C, "D": DM C, "T": TO P, "P": RE PAYMENT PL AN
	5572	"RTN","IBJ DF41",194, 0)
	5573	; D AT: Date i t was refe rred/estab lished
	5574	"RTN","IBJ DF41",195, 0)
	5575	; S TS: Receiv able statu s (16-Acti ve,19-Susp ended)
	5576	"RTN","IBJ DF41",196, 0)
	5577	; D EF: Repaym ent Plan i n Default? (1 - YES, 0 - NO)
	5578	"RTN","IBJ DF41",197, 0)
	5579	; I DX: Subscr ipt to be set in the Temporary global ^T MP
	5580	"RTN","IBJ DF41",198, 0)
	5581	;Output: IDX: Subsc ript set i n the Temp orary glob al ^TMP
	5582	"RTN","IBJ DF41",199, 0)
	5583	;
	5584	"RTN","IBJ DF41",200, 0)
	5585	N SREF,ID X1
	5586	"RTN","IBJ DF41",201, 0)
	5587	S DEF=+$G (DEF),IDX= +$G(IDX)
	5588	"RTN","IBJ DF41",202, 0)
	5589	I RFT="R" S SREF="R EFERRED TO RC"
	5590	"RTN","IBJ DF41",203, 0)
	5591	I RFT="D" S SREF="R EFERRED TO DMC"
	5592	"RTN","IBJ DF41",204, 0)
	5593	I RFT="T" S SREF="R EFERRED TO TOP"
	5594	"RTN","IBJ DF41",205, 0)
	5595	I RFT="P" D
	5596	"RTN","IBJ DF41",206, 0)
	5597	. S SREF= "REPAYMENT PLAN ESTA BLISHED"
	5598	"RTN","IBJ DF41",207, 0)
	5599	. I $G(DE F) S SREF= SREF_" (CU RRENTLY IN DEFAULT)"
	5600	"RTN","IBJ DF41",208, 0)
	5601	;
	5602	"RTN","IBJ DF41",209, 0)
	5603	I 'IDX S IDX=$O(^TM P("IBJDF4" ,$J,IBPAT, 0,"C",STS, ""),-1)+1
	5604	"RTN","IBJ DF41",210, 0)
	5605	S IDX1=$O (^TMP("IBJ DF4",$J,IB PAT,0,"C", STS,IDX,"" ),-1)+1
	5606	"RTN","IBJ DF41",211, 0)
	5607	S ^TMP("I BJDF4",$J, IBPAT,0,"C ",STS,IDX, IDX1)=DAT
	5608	"RTN","IBJ DF41",212, 0)
	5609	S ^TMP("I BJDF4",$J, IBPAT,0,"C ",STS,IDX, IDX1,1)=SR EF
	5610	"RTN","IBJ DF41",213, 0)
	5611	Q
	5612	"RTN","IBJ DF41",214, 0)
	5613	;
	5614	"RTN","IBJ DF41",215, 0)
	5615	COM ; - Ge t bill com ments.
	5616	"RTN","IBJ DF41",216, 0)
	5617	I 'IBIDX, '$G(IBEXCE L) D
	5618	"RTN","IBJ DF41",217, 0)
	5619	. S IBFLG =0,IBIDX=$ O(^TMP("IB JDF4",$J,I BPAT,0,"C" ,IB0,""),- 1)+1
	5620	"RTN","IBJ DF41",218, 0)
	5621	;
	5622	"RTN","IBJ DF41",219, 0)
	5623	S DAT=0,I BA1=$S(IBS H1="M":999 999999,1:0 )
	5624	"RTN","IBJ DF41",220, 0)
	5625	F S IBA1 =$S(IBSH1= "M":$O(^PR CA(433,"C" ,IBA,IBA1) ,-1),1:$O( ^PRCA(433, "C",IBA,IB A1))) Q:'I BA1 D I IBSH1="M", DAT Q
	5626	"RTN","IBJ DF41",221, 0)
	5627	. S IBC=$ G(^PRCA(43 3,IBA1,1)) Q:'IBC
	5628	"RTN","IBJ DF41",222, 0)
	5629	. I $G(IB SH2),$$FMD IFF^XLFDT( DT,+IBC)>I BSH2 Q ; Comment ag e not mini mum.
	5630	"RTN","IBJ DF41",223, 0)
	5631	. I $P(IB C,U,2)'=35 ,$P(IBC,U, 2)'=45 Q ; Not de crease/com ment trans act.
	5632	"RTN","IBJ DF41",224, 0)
	5633	. S DAT=$ S(IBC:+IBC \1,1:+$P(I BC,U,9)\1)
	5634	"RTN","IBJ DF41",225, 0)
	5635	. I $G(IB EXCEL),IBS H1="M" S I BEXCEL1=IB EXCEL1_$$D T^IBJD(DAT ,1) Q
	5636	"RTN","IBJ DF41",226, 0)
	5637	. ;
	5638	"RTN","IBJ DF41",227, 0)
	5639	. ; - App end brief and transa ction comm ents.
	5640	"RTN","IBJ DF41",228, 0)
	5641	. K COM,C OM1 S COM( 0)=DAT,X1= 0
	5642	"RTN","IBJ DF41",229, 0)
	5643	. S COM1( 1)=$P($G(^ PRCA(433,I BA1,5)),U, 2)
	5644	"RTN","IBJ DF41",230, 0)
	5645	. S COM1( 2)=$E($P($ G(^PRCA(43 3,IBA1,8)) ,U,6),1,70 )
	5646	"RTN","IBJ DF41",231, 0)
	5647	. S COM(1 )=COM1(1)_ $S(COM1(1) ]""&(COM1( 2)]""):"\|" ,1:"")_COM 1(2)
	5648	"RTN","IBJ DF41",232, 0)
	5649	. I COM(1 )]"" S COM (1)=""_C OM(1)_"" ,X1=1
	5650	"RTN","IBJ DF41",233, 0)
	5651	. ;
	5652	"RTN","IBJ DF41",234, 0)
	5653	. ; - Get main comm ents.
	5654	"RTN","IBJ DF41",235, 0)
	5655	. S X2=0
	5656	"RTN","IBJ DF41",236, 0)
	5657	. F S X2 =$O(^PRCA( 433,IBA1,7 ,X2)) Q:'X 2 D
	5658	"RTN","IBJ DF41",237, 0)
	5659	. . S COM ($S(X1:X2+ 1,1:X2))=^ PRCA(433,I BA1,7,X2,0 )
	5660	"RTN","IBJ DF41",238, 0)
	5661	. ;
	5662	"RTN","IBJ DF41",239, 0)
	5663	. I $G(IB EXCEL) Q
	5664	"RTN","IBJ DF41",240, 0)
	5665	. ;
	5666	"RTN","IBJ DF41",241, 0)
	5667	. S IBFLG =1,^TMP("I BJDF4",$J, IBPAT,0,"C ",IB0,IBID X,IBA1)=$G (COM(0)),X 1=0
	5668	"RTN","IBJ DF41",242, 0)
	5669	. F S X1 =$O(COM(X1 )) Q:X1="" D
	5670	"RTN","IBJ DF41",243, 0)
	5671	. . S ^TM P("IBJDF4" ,$J,IBPAT, 0,"C",IB0, IBIDX,IBA1 ,X1)=COM(X 1)
	5672	"RTN","IBJ DF41",244, 0)
	5673	;
	5674	"RTN","IBJ DF41",245, 0)
	5675	I '$G(IBE XCEL),IBFL G D
	5676	"RTN","IBJ DF41",246, 0)
	5677	. S $P(^T MP("IBJDF4 ",$J,IBPAT ,IB0,IBCAT ,IBBN),"^" ,6)=IBIDX
	5678	"RTN","IBJ DF41",247, 0)
	5679	Q
	5680	"RTN","IBJ DF41",248, 0)
	5681	; IB2.0 451 - Use Event Dat e to find an associa ted 3rd Pa rty bill w ith an ass ociated EE OB
	5682	"RTN","IBJ DF41",249, 0)
	5683	IBEEOBCK(I BBN,DFN) ; Passed AR Bill, Pat ient ID
	5684	"RTN","IBJ DF41",250, 0)
	5685	; Functio n will qui t as soon as a 3rd p arty bill is located that has an associa ted EEOB
	5686	"RTN","IBJ DF41",251, 0)
	5687	;
	5688	"RTN","IBJ DF41",252, 0)
	5689	; Find 3r d Party Bi lls with a n Event Da te
	5690	"RTN","IBJ DF41",253, 0)
	5691	N IBREF,I BEEOB,IBDT
	5692	"RTN","IBJ DF41",254, 0)
	5693	S IBEEOB= ""
	5694	"RTN","IBJ DF41",255, 0)
	5695	; Loop th rough Xref of ARbill (#430) to Action fi le (#350)
	5696	"RTN","IBJ DF41",256, 0)
	5697	I +$G(IBB N) S IBREF =0 F S IB REF=$O(^IB ("ABIL",IB BN,IBREF)) Q:'IBREF D Q:IBEE OB="%"
	5698	"RTN","IBJ DF41",257, 0)
	5699	. S IBDT= $P($G(^IB( IBREF,0)), "^",17) ;G et event D ate
	5700	"RTN","IBJ DF41",258, 0)
	5701	. I IBDT S IBEEOB=$ $TPEVDT(DF N,IBDT)
	5702	"RTN","IBJ DF41",259, 0)
	5703	. I IBDT S IBEEOB=$ $TPOPV(DFN ,IBDT)
	5704	"RTN","IBJ DF41",260, 0)
	5705	;
	5706	"RTN","IBJ DF41",261, 0)
	5707	Q IBEEOB
	5708	"RTN","IBJ DF41",262, 0)
	5709	;
	5710	"RTN","IBJ DF41",263, 0)
	5711	; IB2.0 451 - Trav erse all T HIRD PARTY bills for a patient with a sp ecific Eve nt Date (3 99,.03)
	5712	"RTN","IBJ DF41",264, 0)
	5713	TPEVDT(DFN ,EVDT) ;
	5714	"RTN","IBJ DF41",265, 0)
	5715	; Functio n will qui t as soon as a 3rd p arty bill is located that has an associa ted EEOB
	5716	"RTN","IBJ DF41",266, 0)
	5717	; IB2.0 473 - Use the 399,"A PDT" (by p atient) in dex instea d of the 3 99,"D" ind ex for eff iciency
	5718	"RTN","IBJ DF41",267, 0)
	5719	I '$G(DFN )!'$G(EVDT ) Q ""
	5720	"RTN","IBJ DF41",268, 0)
	5721	N IBIFN,I BEEOB
	5722	"RTN","IBJ DF41",269, 0)
	5723	S IBEEOB= "",IBIFN=" "
	5724	"RTN","IBJ DF41",270, 0)
	5725	F S IBIF N=$O(^DGCR (399,"APDT ",DFN,IBIF N),-1) Q:' IBIFN D Q:IBEEOB=" %"
	5726	"RTN","IBJ DF41",271, 0)
	5727	. I $D(^D GCR(399,"A PDT",DFN,I BIFN,99999 99-EVDT)) S IBEEOB=$ $EEOBCK(IB IFN)
	5728	"RTN","IBJ DF41",272, 0)
	5729	Q IBEEOB
	5730	"RTN","IBJ DF41",273, 0)
	5731	;
	5732	"RTN","IBJ DF41",274, 0)
	5733	; IB2.0 451 - Trav erse all T HIRD PARTY bills for a patient with any Opt Visit Dates same as Event Date (399, 43)
	5734	"RTN","IBJ DF41",275, 0)
	5735	TPOPV(DFN, EVDT) ;
	5736	"RTN","IBJ DF41",276, 0)
	5737	; Functio n will qui t as soon as a 3rd p arty bill is located that has an associa ted EEOB
	5738	"RTN","IBJ DF41",277, 0)
	5739	N IBIFN,I BEEOB
	5740	"RTN","IBJ DF41",278, 0)
	5741	S IBEEOB= ""
	5742	"RTN","IBJ DF41",279, 0)
	5743	I +$G(DFN ),+$G(EVDT ) S IBIFN= 0 F S IBI FN=$O(^DGC R(399,"AOP V",DFN,EVD T,IBIFN)) Q:'IBIFN D Q:IBEEO B="%"
	5744	"RTN","IBJ DF41",280, 0)
	5745	. ; attac h EOB indi cator '%' to bill # when appli cable
	5746	"RTN","IBJ DF41",281, 0)
	5747	. S IBEEO B=$$EEOBCK (IBIFN)
	5748	"RTN","IBJ DF41",282, 0)
	5749	Q IBEEOB
	5750	"RTN","IBJ DF41",283, 0)
	5751	;
	5752	"RTN","IBJ DF41",284, 0)
	5753	; IB2.0 451 - Chec k for EEOB indicator
	5754	"RTN","IBJ DF41",285, 0)
	5755	EEOBCK(IBB ILL) ;
	5756	"RTN","IBJ DF41",286, 0)
	5757	; Check f or 1st and 3rd party payment a ctivity on bill
	5758	"RTN","IBJ DF41",287, 0)
	5759	; IBBILL is the IEN for the b ill # in f iles #399/ #430 and m ust be val id,
	5760	"RTN","IBJ DF41",288, 0)
	5761	; check t he EOB typ e and excl ude it if it is an M RA. Otherw ise,
	5762	"RTN","IBJ DF41",289, 0)
	5763	; returns the EEOB indicator '%' if pay ment activ ity was fo und.
	5764	"RTN","IBJ DF41",290, 0)
	5765	; Access to file #3 61.1 cover ed by IA # 4051.
	5766	"RTN","IBJ DF41",291, 0)
	5767	; Access to file #3 99 covered by IA #38 20.
	5768	"RTN","IBJ DF41",292, 0)
	5769	N IBOUT,I BVAL,Z
	5770	"RTN","IBJ DF41",293, 0)
	5771	I $G(IBBI LL)=0 Q ""
	5772	"RTN","IBJ DF41",294, 0)
	5773	I '$O(^IB M(361.1,"B ",IBBILL,0 )) Q "" ; no entry here
	5774	"RTN","IBJ DF41",295, 0)
	5775	I $P($G(^ DGCR(399,I BBILL,0)), "^",13)=1 Q "" ;avo id 'ENTERE D/NOT REVI EWED' stat us
	5776	"RTN","IBJ DF41",296, 0)
	5777	; handle both singl e and mult iple bill entries in file #361 .1
	5778	"RTN","IBJ DF41",297, 0)
	5779	S Z=0 F S Z=$O(^IB M(361.1,"B ",IBBILL,Z )) Q:'Z D Q:$G(IBO UT)="%"
	5780	"RTN","IBJ DF41",298, 0)
	5781	. S IBVAL =$G(^IBM(3 61.1,Z,0))
	5782	"RTN","IBJ DF41",299, 0)
	5783	. S IBOUT =$S($P(IBV AL,"^",4)= 1:"",$P(IB VAL,"^",4) =0:"%",1:" ")
	5784	"RTN","IBJ DF41",300, 0)
	5785	Q IBOUT ; EOB indi cator for either 1st or 3rd pa rty paymen t on bill
	5786	"RTN","IBJ DF41",301, 0)
	5787	;
	5788	"RTN","IBJ DF41",302, 0)
	5789	;
	5790	"RTN","IBJ DF41",303, 0)
	5791	SUST(IBA) ;Look for suspended type for a suspended bill IB2 568/DRF
	5792	"RTN","IBJ DF41",304, 0)
	5793	N TRANS,S T
	5794	"RTN","IBJ DF41",305, 0)
	5795	S IBA=$G( IBA) I IBA ="" Q ""
	5796	"RTN","IBJ DF41",306, 0)
	5797	S ST=""
	5798	"RTN","IBJ DF41",307, 0)
	5799	S TRANS=$ O(^PRCA(43 3,"C",IBA, ""),-1)
	5800	"RTN","IBJ DF41",308, 0)
	5801	S ST=$P($ G(^PRCA(43 3,TRANS,1) ),U,11)
	5802	"RTN","IBJ DF41",309, 0)
	5803	I ST="" S ST=12 ;Ad ded option for NONE
	5804	"RTN","IBJ DF41",310, 0)
	5805	Q ST
	5806	"RTN","IBJ DF41",311, 0)
	5807	;
	5808	"RTN","IBJ DF41",312, 0)
	5809	;
	5810	"RTN","IBJ DF41",313, 0)
	5811	ABBR(SUSP) ;Return a bbreviatio n for susp ended bill types IB* 2*568/DRF
	5812	"RTN","IBJ DF41",314, 0)
	5813	S SUSP=$G (SUSP)
	5814	"RTN","IBJ DF41",315, 0)
	5815	I SUSP=0 Q "NonCoS"
	5816	"RTN","IBJ DF41",316, 0)
	5817	I SUSP=1 Q "IniCoS"
	5818	"RTN","IBJ DF41",317, 0)
	5819	I SUSP=2 Q "AplCoW"
	5820	"RTN","IBJ DF41",318, 0)
	5821	I SUSP=3 Q "AdminS"
	5822	"RTN","IBJ DF41",319, 0)
	5823	I SUSP=4 Q "Compro"
	5824	"RTN","IBJ DF41",320, 0)
	5825	I SUSP=5 Q "Termin"
	5826	"RTN","IBJ DF41",321, 0)
	5827	I SUSP=6 Q "BnkCh7"
	5828	"RTN","IBJ DF41",322, 0)
	5829	I SUSP=7 Q "BnkC13"
	5830	"RTN","IBJ DF41",323, 0)
	5831	I SUSP=8 Q "BnkOth"
	5832	"RTN","IBJ DF41",324, 0)
	5833	I SUSP=9 Q "Probat"
	5834	"RTN","IBJ DF41",325, 0)
	5835	I SUSP=10 Q "Choice "
	5836	"RTN","IBJ DF41",326, 0)
	5837	I SUSP=11 Q "Disput "
	5838	"RTN","IBJ DF41",327, 0)
	5839	I SUSP=12 Q "None"
	5840	"RTN","IBJ DF41",328, 0)
	5841	Q ""
	5842	"RTN","IBJ DF42")
	5843	0^21^B5481 5099^B5323 7550
	5844	"RTN","IBJ DF42",1,0)
	5845	IBJDF42 ;A LB/RB - FI RST PARTY FOLLOW-UP REPORT (PR INT);15-AP R-00
	5846	"RTN","IBJ DF42",2,0)
	5847	;;2.0;INT EGRATED BI LLING;*12 3,204,568 *;21-MAR-9 4;Build 38
	5848	"RTN","IBJ DF42",3,0)
	5849	;Per VA D irective 6 402, this routine sh ould not b e modified .
	5850	"RTN","IBJ DF42",4,0)
	5851	;
	5852	"RTN","IBJ DF42",5,0)
	5853	EN ; - Pri nt the Fol low-up rep ort.
	5854	"RTN","IBJ DF42",6,0)
	5855	;
	5856	"RTN","IBJ DF42",7,0)
	5857	S IBCT(1) ="INELIGIB LE",IBCT(2 )="EMERG/H UMAN.",IBC T(18)="C M EANS TEST"
	5858	"RTN","IBJ DF42",8,0)
	5859	S IBCT(22 )="RX COPA Y/SC",IBCT (23)="RX C OPAY/NSC"
	5860	"RTN","IBJ DF42",9,0)
	5861	S IBCT(33 )="ADHC LT C"
	5862	"RTN","IBJ DF42",10,0 )
	5863	S IBCT(34 )="DOM LTC "
	5864	"RTN","IBJ DF42",11,0 )
	5865	S IBCT(35 )="RESPITE INPT LTC"
	5866	"RTN","IBJ DF42",12,0 )
	5867	S IBCT(36 )="RESPITE OPT LTC"
	5868	"RTN","IBJ DF42",13,0 )
	5869	S IBCT(37 )="GERIATR IC INPT LT C"
	5870	"RTN","IBJ DF42",14,0 )
	5871	S IBCT(38 )="GERIATR IC OPT LTC "
	5872	"RTN","IBJ DF42",15,0 )
	5873	S IBCT(39 )="NURSING HOME LTC"
	5874	"RTN","IBJ DF42",16,0 )
	5875	;
	5876	"RTN","IBJ DF42",17,0 )
	5877	S IBQ=0 D NOW^%DTC S IBRUN=$$ DAT2^IBOUT L(%) G:IBR PT="S" SUM
	5878	"RTN","IBJ DF42",18,0 )
	5879	S IBPRTFL G=0 D DET D PAUSE:'I BPRTFLG I IBQ!'IBPRT FLG G ENQ
	5880	"RTN","IBJ DF42",19,0 )
	5881	;
	5882	"RTN","IBJ DF42",20,0 )
	5883	D PAUSE I IBQ G ENQ
	5884	"RTN","IBJ DF42",21,0 )
	5885	;
	5886	"RTN","IBJ DF42",22,0 )
	5887	SUM I 'IBQ D PRT^IBJ DF43 ; Pri nt summary .
	5888	"RTN","IBJ DF42",23,0 )
	5889	ENQ K IB0, IBAI,IBC,I BCAT,IBCD, IBC1,IBC2, IBCT,IBCNT ,IBN,IBP,I BPAG,IBQ,I BRUN,IBS
	5890	"RTN","IBJ DF42",24,0 )
	5891	K IBST,IB TOT,%,DFN, IBPRTFLG
	5892	"RTN","IBJ DF42",25,0 )
	5893	Q
	5894	"RTN","IBJ DF42",26,0 )
	5895	;
	5896	"RTN","IBJ DF42",27,0 )
	5897	DET ; - Pr int report for a spe cific cate gory.
	5898	"RTN","IBJ DF42",28,0 )
	5899	;
	5900	"RTN","IBJ DF42",29,0 )
	5901	D HDR1 G: IBQ DETQ
	5902	"RTN","IBJ DF42",30,0 )
	5903	S (IBPT,I B,IBCAT,IB 0)=""
	5904	"RTN","IBJ DF42",31,0 )
	5905	F S IBPT =$O(^TMP(" IBJDF4",$J ,IBPT)) Q: IBPT="" D Q:IBQ
	5906	"RTN","IBJ DF42",32,0 )
	5907	. I $O(^T MP("IBJDF4 ",$J,IBPT, 0))="" Q
	5908	"RTN","IBJ DF42",33,0 )
	5909	. S IBP=$ G(^TMP("IB JDF4",$J,I BPT))
	5910	"RTN","IBJ DF42",34,0 )
	5911	. I $Y>(I OSL-14) D PAUSE Q:IB Q D HDR1 Q:IBQ
	5912	"RTN","IBJ DF42",35,0 )
	5913	. D WPAT
	5914	"RTN","IBJ DF42",36,0 )
	5915	. F IB=16 ,19 D Q:I BQ
	5916	"RTN","IBJ DF42",37,0 )
	5917	. . I IBS TA="A",IB' =16 Q
	5918	"RTN","IBJ DF42",38,0 )
	5919	. . I IBS TA="S",IB= 16 Q
	5920	"RTN","IBJ DF42",39,0 )
	5921	. . I '$D (^TMP("IBJ DF4",$J,IB PT,IB)) D Q
	5922	"RTN","IBJ DF42",40,0 )
	5923	. . . I $ Y>(IOSL-5) D PAUSE Q :IBQ D HD R1,WPAT,HD R2 Q:IBQ
	5924	"RTN","IBJ DF42",41,0 )
	5925	. . . W ! ,"-> NO "_ $S(IB=16:" ACTIVE",1: "SUSPENDED ")_" BILLS ."
	5926	"RTN","IBJ DF42",42,0 )
	5927	. . I $Y> (IOSL-9) D PAUSE Q:I BQ D HDR1 ,WPAT Q:IB Q
	5928	"RTN","IBJ DF42",43,0 )
	5929	. . D HDR 2
	5930	"RTN","IBJ DF42",44,0 )
	5931	. . K IBF LG S IBTOT ="",IBCNT= 0
	5932	"RTN","IBJ DF42",45,0 )
	5933	. . F S IBCAT=$O(^ TMP("IBJDF 4",$J,IBPT ,IB,IBCAT) ) Q:IBCAT= "" D Q:I BQ
	5934	"RTN","IBJ DF42",46,0 )
	5935	. . . F S IB0=$O(^ TMP("IBJDF 4",$J,IBPT ,IB,IBCAT, IB0)) Q:IB 0="" D Q :IBQ
	5936	"RTN","IBJ DF42",47,0 )
	5937	. . . . S IBN=$G(^T MP("IBJDF4 ",$J,IBPT, IB,IBCAT,I B0))
	5938	"RTN","IBJ DF42",48,0 )
	5939	. . . . I $Y>(IOSL- 5) D PAUSE Q:IBQ D HDR1,WPAT, HDR2 Q:IBQ
	5940	"RTN","IBJ DF42",49,0 )
	5941	. . . . D WBIL Q:IB Q
	5942	"RTN","IBJ DF42",50,0 )
	5943	. . . . S IBCNT=IBC NT+1
	5944	"RTN","IBJ DF42",51,0 )
	5945	. . . I ' IBQ,$O(^TM P("IBJDF4" ,$J,IBPT,I B,IBCAT))= "" D
	5946	"RTN","IBJ DF42",52,0 )
	5947	. . . . D TOT W !
	5948	"RTN","IBJ DF42",53,0 )
	5949	. . ; - D isplay bil l comment history, i f selected .
	5950	"RTN","IBJ DF42",54,0 )
	5951	. . S IBP RTFLG=1
	5952	"RTN","IBJ DF42",55,0 )
	5953	. . D WCO M(IBPT,IB)
	5954	"RTN","IBJ DF42",56,0 )
	5955	;
	5956	"RTN","IBJ DF42",57,0 )
	5957	I 'IBPRTF LG D
	5958	"RTN","IBJ DF42",58,0 )
	5959	. W !!!!! !,"There a re no rece ivables fo r the para meters ent ered."
	5960	"RTN","IBJ DF42",59,0 )
	5961	;
	5962	"RTN","IBJ DF42",60,0 )
	5963	DETQ Q
	5964	"RTN","IBJ DF42",61,0 )
	5965	;
	5966	"RTN","IBJ DF42",62,0 )
	5967	WPAT ; - W rite patie nt data.
	5968	"RTN","IBJ DF42",63,0 )
	5969	N I,X
	5970	"RTN","IBJ DF42",64,0 )
	5971	S DFN=$P( IBPT,"@@", 2),IBAI=$G (^TMP("IBJ DF4",$J,IB PT,0,"A"))
	5972	"RTN","IBJ DF42",65,0 )
	5973	W !!,"Pat ient Name : ",$P (IBP,U) W: IBAI["V" " *"
	5974	"RTN","IBJ DF42",66,0 )
	5975	W ?63,"SS N: ",$$SSN ($P(IBP,U, 2)),!,"Mea ns Test St atus: ",$P (IBP,U,4)
	5976	"RTN","IBJ DF42",67,0 )
	5977	W:$P(IBP, U,5)'="" " ("_$P(IBP ,U,5)_")"
	5978	"RTN","IBJ DF42",68,0 )
	5979	W ?58,"Me dicaid: ", $$GET1^DIQ (2,DFN,.38 1)
	5980	"RTN","IBJ DF42",69,0 )
	5981	W !,"RX C opay Statu s : ",$P( IBP,U,6)
	5982	"RTN","IBJ DF42",70,0 )
	5983	W:$P(IBP, U,7)'="" " ("_$P(IBP ,U,7)_")"
	5984	"RTN","IBJ DF42",71,0 )
	5985	W:$P(IBP, U,8) ?53," Date of De ath: ",$$D AT1^IBOUTL ($P(IBP,U, 8))
	5986	"RTN","IBJ DF42",72,0 )
	5987	W !,"Elig ibilities : " S X =$$ELIG($P (IBP,U,3))
	5988	"RTN","IBJ DF42",73,0 )
	5989	F I=1:1 Q :X="" W ? 19,$E(X,1, 61) S X=$E (X,62,999) I X'="" W !
	5990	"RTN","IBJ DF42",74,0 )
	5991	S X=$$INF O(IBAI)
	5992	"RTN","IBJ DF42",75,0 )
	5993	I X'="" D
	5994	"RTN","IBJ DF42",76,0 )
	5995	. W !,"Ad ditional I nfo : "
	5996	"RTN","IBJ DF42",77,0 )
	5997	. F I=1:1 Q:X="" W ?19,$E(X, 1,61) S X= $E(X,62,99 9) I X'="" W !
	5998	"RTN","IBJ DF42",78,0 )
	5999	;
	6000	"RTN","IBJ DF42",79,0 )
	6001	Q
	6002	"RTN","IBJ DF42",80,0 )
	6003	;
	6004	"RTN","IBJ DF42",81,0 )
	6005	WBIL ; - W rite bill data.
	6006	"RTN","IBJ DF42",82,0 )
	6007	W ! W:'$D (IBFLG(IBC AT)) IBCT( IBCAT) W ? 13,IB0
	6008	"RTN","IBJ DF42",83,0 )
	6009	W:$P(IBN, "^",6) ?25 ,$J("("_$P (IBN,"^",6 )_")",4)
	6010	"RTN","IBJ DF42",84,0 )
	6011	W ?30,$$D AT1^IBOUTL (+IBN)
	6012	"RTN","IBJ DF42",85,0 )
	6013	W ?39,$J( $FN($P(IBN ,U,2),",", 2),10),?50 ,$J($FN($P (IBN,U,3), ",",2),10)
	6014	"RTN","IBJ DF42",86,0 )
	6015	W ?61,$J( $FN($P(IBN ,U,4),",", 2),9),?71, $J($FN($P( IBN,U,5)," ,",2),9)
	6016	"RTN","IBJ DF42",87,0 )
	6017	I "SB"[IB STA,$P(IBN ,U,7)]"" W ?82,IBSUS ($P(IBN,U, 7))
	6018	"RTN","IBJ DF42",88,0 )
	6019	S $P(IBTO T,"^")=$P( IBTOT,"^") +$P(IBN,U, 2)
	6020	"RTN","IBJ DF42",89,0 )
	6021	S $P(IBTO T,"^",2)=$ P(IBTOT,"^ ",2)+$P(IB N,U,3)
	6022	"RTN","IBJ DF42",90,0 )
	6023	S $P(IBTO T,"^",3)=$ P(IBTOT,"^ ",3)+$P(IB N,U,4)
	6024	"RTN","IBJ DF42",91,0 )
	6025	S $P(IBTO T,"^",4)=$ P(IBTOT,"^ ",4)+$P(IB N,U,5)
	6026	"RTN","IBJ DF42",92,0 )
	6027	S IBFLG(I BCAT)=""
	6028	"RTN","IBJ DF42",93,0 )
	6029	Q
	6030	"RTN","IBJ DF42",94,0 )
	6031	;
	6032	"RTN","IBJ DF42",95,0 )
	6033	WCOM(IBPT, IB) ; - Wr ite bill c omments.
	6034	"RTN","IBJ DF42",96,0 )
	6035	N CMDT,CO NT,DIWL,DI WR,IBIDX,I BTR,IBLN,I BX,X
	6036	"RTN","IBJ DF42",97,0 )
	6037	;
	6038	"RTN","IBJ DF42",98,0 )
	6039	S (IBIDX, IBTR,IBLN) ="",DIWL=1 ,DIWR=64 K ^UTILITY( $J,"W")
	6040	"RTN","IBJ DF42",99,0 )
	6041	F S IBID X=$O(^TMP( "IBJDF4",$ J,IBPT,0," C",IB,IBID X)) Q:IBID X="" D Q :IBQ
	6042	"RTN","IBJ DF42",100, 0)
	6043	. I $Y>(I OSL-6) D W CPB Q:IBQ
	6044	"RTN","IBJ DF42",101, 0)
	6045	. D WCD(I BIDX)
	6046	"RTN","IBJ DF42",102, 0)
	6047	. F S IB TR=$O(^TMP ("IBJDF4", $J,IBPT,0, "C",IB,IBI DX,IBTR)) Q:IBTR="" D Q:IBQ
	6048	"RTN","IBJ DF42",103, 0)
	6049	. . S CMD T=$G(^TMP( "IBJDF4",$ J,IBPT,0," C",IB,IBID X,IBTR))
	6050	"RTN","IBJ DF42",104, 0)
	6051	. . I $Y> (IOSL-4) D WCPB Q:IB Q
	6052	"RTN","IBJ DF42",105, 0)
	6053	. . S CON T=0 D WCD( ,1,)
	6054	"RTN","IBJ DF42",106, 0)
	6055	. . F S IBLN=$O(^T MP("IBJDF4 ",$J,IBPT, 0,"C",IB,I BIDX,IBTR, IBLN)) Q:I BLN="" D Q:IBQ
	6056	"RTN","IBJ DF42",107, 0)
	6057	. . . S I BX=$G(^TMP ("IBJDF4", $J,IBPT,0, "C",IB,IBI DX,IBTR,IB LN))
	6058	"RTN","IBJ DF42",108, 0)
	6059	. . . I $ E(IBX)=" " ,$L(IBX)>1 S $E(IBX) =""
	6060	"RTN","IBJ DF42",109, 0)
	6061	. . . S X =IBX D ^DI WP
	6062	"RTN","IBJ DF42",110, 0)
	6063	. . . I ' CONT,$L(IB X)<66 D WC TX
	6064	"RTN","IBJ DF42",111, 0)
	6065	. . . S C ONT=$L(IBX )>65
	6066	"RTN","IBJ DF42",112, 0)
	6067	. . . I ' $O(^TMP("I BJDF4",$J, IBPT,0,"C" ,IB,IBIDX, IBTR,IBLN) ) D
	6068	"RTN","IBJ DF42",113, 0)
	6069	. . . . D :$D(^UTILI TY($J,"W") ) WCTX
	6070	"RTN","IBJ DF42",114, 0)
	6071	K ^UTILIT Y($J,"W")
	6072	"RTN","IBJ DF42",115, 0)
	6073	Q
	6074	"RTN","IBJ DF42",116, 0)
	6075	;
	6076	"RTN","IBJ DF42",117, 0)
	6077	WCD(I,D,C) ; - Write the comme nt date.
	6078	"RTN","IBJ DF42",118, 0)
	6079	; Input: I - Index # "(I)"
	6080	"RTN","IBJ DF42",119, 0)
	6081	; D - Print the Date " - MM/DD/ YY"
	6082	"RTN","IBJ DF42",120, 0)
	6083	; C - Print the Cont. "(Continue d)"
	6084	"RTN","IBJ DF42",121, 0)
	6085	;
	6086	"RTN","IBJ DF42",122, 0)
	6087	W:$G(I) ! ,"(",I,")" W:$G(D) ? 3," - ",$$ DAT1^IBOUT L(CMDT),": "
	6088	"RTN","IBJ DF42",123, 0)
	6089	W:$G(C) " (Continued )",!
	6090	"RTN","IBJ DF42",124, 0)
	6091	Q
	6092	"RTN","IBJ DF42",125, 0)
	6093	;
	6094	"RTN","IBJ DF42",126, 0)
	6095	WCTX ; - W rite the c omment tex t.
	6096	"RTN","IBJ DF42",127, 0)
	6097	N LIN,WLI N,Z
	6098	"RTN","IBJ DF42",128, 0)
	6099	S LIN=""
	6100	"RTN","IBJ DF42",129, 0)
	6101	F S LIN= $O(^UTILIT Y($J,"W",1 ,LIN)) Q:L IN="" D Q:IBQ
	6102	"RTN","IBJ DF42",130, 0)
	6103	. S WLIN= $G(^UTILIT Y($J,"W",1 ,LIN,0)) Q :WLIN=""
	6104	"RTN","IBJ DF42",131, 0)
	6105	. W ?16,W LIN
	6106	"RTN","IBJ DF42",132, 0)
	6107	. I '$O(^ UTILITY($J ,"W",1,LIN )) W ! Q
	6108	"RTN","IBJ DF42",133, 0)
	6109	. I $Y>(I OSL-4) D W CPB,WCD(IB IDX,1,1) Q
	6110	"RTN","IBJ DF42",134, 0)
	6111	. W !
	6112	"RTN","IBJ DF42",135, 0)
	6113	K ^UTILIT Y($J,"W")
	6114	"RTN","IBJ DF42",136, 0)
	6115	Q
	6116	"RTN","IBJ DF42",137, 0)
	6117	;
	6118	"RTN","IBJ DF42",138, 0)
	6119	WCPB ; - P age Break in the mid dle of the Comments
	6120	"RTN","IBJ DF42",139, 0)
	6121	D PAUSE Q :IBQ D HD R1,WPAT W !!
	6122	"RTN","IBJ DF42",140, 0)
	6123	Q
	6124	"RTN","IBJ DF42",141, 0)
	6125	;
	6126	"RTN","IBJ DF42",142, 0)
	6127	HDR1 ; - W rite the r eport head er.
	6128	"RTN","IBJ DF42",143, 0)
	6129	N X,I
	6130	"RTN","IBJ DF42",144, 0)
	6131	W:'$G(IBP AG) ! I $E (IOST,1,2) ="C-"!$G(I BPAG) W @I OF,*13
	6132	"RTN","IBJ DF42",145, 0)
	6133	S IBPAG=$ G(IBPAG)+1 W "First Party Foll ow-Up Repo rt"
	6134	"RTN","IBJ DF42",146, 0)
	6135	W ?34,"Ru n Date: ", IBRUN,?71, "Page: ",$ J(IBPAG,3)
	6136	"RTN","IBJ DF42",147, 0)
	6137	S X="ALL "_$S(IBSTA '="S":"ACT IVE",1:"") _$S(IBSTA= "B":" AND ",1:"")
	6138	"RTN","IBJ DF42",148, 0)
	6139	S X=X_$S( IBSTA'="A" :"SUSPENDE D",1:"")_$ $TYPE(IBSE L)_" RECEI VABLES"
	6140	"RTN","IBJ DF42",149, 0)
	6141	I IBSMN'= "A" S X=X_ " OVER "_I BSMN_" AND UNDER "_I BSMX_" DAY S OLD"
	6142	"RTN","IBJ DF42",150, 0)
	6143	S X=X_" / BY "_$S(I BSN="N":"N AME",1:"LA ST 4 SSN")
	6144	"RTN","IBJ DF42",151, 0)
	6145	S X=X_" ( "_$S($G(IB SNA)="ALL" :"ALL",1:" From "_$S( IBSNF="":" FIRST",1:I BSNF)_" to "_$S(IBSN L="zzzzz": "LAST",1:I BSNL))_")"
	6146	"RTN","IBJ DF42",152, 0)
	6147	S X=X_" / "_$S('IBS AM:"NO ",1 :"")_"MINI MUM BALANC E"
	6148	"RTN","IBJ DF42",153, 0)
	6149	S X=X_$S( IBSAM:": $ "_$FN(IBSA M,",",2),1 :"")
	6150	"RTN","IBJ DF42",154, 0)
	6151	S X=X_" / "_$S('IBS H:"NO ",IB SH1="A":"A LL ",1:"ON LY ")_"COM MENTS"
	6152	"RTN","IBJ DF42",155, 0)
	6153	S X=X_$S( $G(IBSH2): " LESS THA N "_IBSH2_ " DAYS OLD ",1:"")
	6154	"RTN","IBJ DF42",156, 0)
	6155	S X=X_" / RECEIVABL ES REFERRE D TO RC "_ $S('IBSRC: "NOT ",1:" ")_"INCLUD ED"
	6156	"RTN","IBJ DF42",157, 0)
	6157	F I=1:1 W !,$E(X,1, 80) S X=$E (X,81,999) I X="" Q
	6158	"RTN","IBJ DF42",158, 0)
	6159	;
	6160	"RTN","IBJ DF42",159, 0)
	6161	S IBQ=$$S TOP^IBOUTL ("First Pa rty Follow -Up Report ")
	6162	"RTN","IBJ DF42",160, 0)
	6163	Q
	6164	"RTN","IBJ DF42",161, 0)
	6165	;
	6166	"RTN","IBJ DF42",162, 0)
	6167	TYPE(SEL) ; Returns a string w ith the ty pe of rece ivables (d escription )
	6168	"RTN","IBJ DF42",163, 0)
	6169	; selecte d or NULL if ALL rec eivable ty pe have be en selecte d.
	6170	"RTN","IBJ DF42",164, 0)
	6171	; SEL - U ser input for the pa rameter "T ype of Rec eivable"
	6172	"RTN","IBJ DF42",165, 0)
	6173	;
	6174	"RTN","IBJ DF42",166, 0)
	6175	N TYPE,I, X
	6176	"RTN","IBJ DF42",167, 0)
	6177	I SEL="1, 2,3," Q ""
	6178	"RTN","IBJ DF42",168, 0)
	6179	S TYPE="" ,X="EMERGE NCY/HUMANI TARIAN^INE LIGIBLE^C- MEANS TEST & RX COPA Y"
	6180	"RTN","IBJ DF42",169, 0)
	6181	F I=2:1:( $L(SEL,"," )-1) D
	6182	"RTN","IBJ DF42",170, 0)
	6183	. S TYPE= TYPE_$S(I= ($L(SEL,", ")-1)&(TYP E'=""):" A ND ",1:", ")
	6184	"RTN","IBJ DF42",171, 0)
	6185	. S TYPE= TYPE_$P(X, "^",+$P(SE L,",",I))
	6186	"RTN","IBJ DF42",172, 0)
	6187	S $E(TYPE ,1)=""
	6188	"RTN","IBJ DF42",173, 0)
	6189	;
	6190	"RTN","IBJ DF42",174, 0)
	6191	Q TYPE
	6192	"RTN","IBJ DF42",175, 0)
	6193	;
	6194	"RTN","IBJ DF42",176, 0)
	6195	HDR2 ; - W rite bill sub-header .
	6196	"RTN","IBJ DF42",177, 0)
	6197	W ! I IBS TA="B" W ! ,$S(IB=16: "ACTIVE",1 :"SUSPENDE D")
	6198	"RTN","IBJ DF42",178, 0)
	6199	W ! I IBS TA="B" W $ S(IB=16:"= =====",1:" =========" )
	6200	"RTN","IBJ DF42",179, 0)
	6201	W:IBSH ?2 6,"COM" W ?30,"Last" ,?40,"Curr ent",?51," Principal"
	6202	"RTN","IBJ DF42",180, 0)
	6203	W !,"Cate gory",?13, "Bill Numb er",?26,"R EF"
	6204	"RTN","IBJ DF42",181, 0)
	6205	W ?30,"Pa yment",?40 ,"Balance" ,?51,"Bala nce",?62," Interest", ?72,"Admin ."
	6206	"RTN","IBJ DF42",182, 0)
	6207	I "BS"[IB STA W ?82, "Suspended Type"
	6208	"RTN","IBJ DF42",183, 0)
	6209	W !,$$DAS H(96,1)
	6210	"RTN","IBJ DF42",184, 0)
	6211	Q
	6212	"RTN","IBJ DF42",185, 0)
	6213	;
	6214	"RTN","IBJ DF42",186, 0)
	6215	TOT ; - Wr ite balanc e total fo r patient.
	6216	"RTN","IBJ DF42",187, 0)
	6217	N I,J
	6218	"RTN","IBJ DF42",188, 0)
	6219	I IBCNT>1 W ! F I=4 0,51,62,72 W ?I,$E(" ---------" ,1,$S(I>60 :8,1:9))
	6220	"RTN","IBJ DF42",189, 0)
	6221	W:IBCNT'> 1 !
	6222	"RTN","IBJ DF42",190, 0)
	6223	W !,"Acco unt Balanc e: $"_$FN( $P(IBP,"^" ,10),",",2 )
	6224	"RTN","IBJ DF42",191, 0)
	6225	I IBCNT'> 1 Q
	6226	"RTN","IBJ DF42",192, 0)
	6227	S J=1 F I =39,50,60, 70 W ?I,$J ($FN($P(IB TOT,"^",J) ,",",2),10 ) S J=J+1
	6228	"RTN","IBJ DF42",193, 0)
	6229	Q
	6230	"RTN","IBJ DF42",194, 0)
	6231	;
	6232	"RTN","IBJ DF42",195, 0)
	6233	DASH(X,Y) ; - Return a dashed line.
	6234	"RTN","IBJ DF42",196, 0)
	6235	Q $TR($J( "",X)," ", $S(Y:"-",1 :"="))
	6236	"RTN","IBJ DF42",197, 0)
	6237	;
	6238	"RTN","IBJ DF42",198, 0)
	6239	ELIG(X) ; - Return e ligibility code name .
	6240	"RTN","IBJ DF42",199, 0)
	6241	; X - Eli gibility c odes separ ated by se mi-collon (;)
	6242	"RTN","IBJ DF42",200, 0)
	6243	;
	6244	"RTN","IBJ DF42",201, 0)
	6245	N ELIG,I
	6246	"RTN","IBJ DF42",202, 0)
	6247	S ELIG="" F I=1:1:$ L(X,";") D
	6248	"RTN","IBJ DF42",203, 0)
	6249	. I '$P(X ,";",I) Q
	6250	"RTN","IBJ DF42",204, 0)
	6251	. S ELIG= ELIG_", "_ $E($P($G(^ DIC(8,+$P( X,";",I),0 )),U),1,20 )
	6252	"RTN","IBJ DF42",205, 0)
	6253	S $E(ELIG ,1,2)=""
	6254	"RTN","IBJ DF42",206, 0)
	6255	;
	6256	"RTN","IBJ DF42",207, 0)
	6257	Q ELIG
	6258	"RTN","IBJ DF42",208, 0)
	6259	;
	6260	"RTN","IBJ DF42",209, 0)
	6261	INFO(X) ; - Return t he patient Additiona l Informat ion about the Patien t Accout
	6262	"RTN","IBJ DF42",210, 0)
	6263	; X - Fla gs represe nting the observatio ns
	6264	"RTN","IBJ DF42",211, 0)
	6265	;
	6266	"RTN","IBJ DF42",212, 0)
	6267	N INFO,I
	6268	"RTN","IBJ DF42",213, 0)
	6269	S INFO="" F I=1:1:$ L(X) D
	6270	"RTN","IBJ DF42",214, 0)
	6271	. I $E(X, I)="V" S I NFO=INFO_" , '*' - VA EMPLOYEE"
	6272	"RTN","IBJ DF42",215, 0)
	6273	. I $E(X, I)="R" S I NFO=INFO_" , REFERRED TO RC"
	6274	"RTN","IBJ DF42",216, 0)
	6275	. I $E(X, I)="D" S I NFO=INFO_" , REFERRED TO DMC"
	6276	"RTN","IBJ DF42",217, 0)
	6277	. I $E(X, I)="T" S I NFO=INFO_" , REFERRED TO TOP"
	6278	"RTN","IBJ DF42",218, 0)
	6279	. I $E(X, I)="P" S I NFO=INFO_" , UNDER RE PAYMENT PL AN"
	6280	"RTN","IBJ DF42",219, 0)
	6281	. I $E(X, I)="F" S I NFO=INFO_" , UNDER DE FAULTED RE PAYMENT PL AN"
	6282	"RTN","IBJ DF42",220, 0)
	6283	S $E(INFO ,1,2)=""
	6284	"RTN","IBJ DF42",221, 0)
	6285	;
	6286	"RTN","IBJ DF42",222, 0)
	6287	Q INFO
	6288	"RTN","IBJ DF42",223, 0)
	6289	;
	6290	"RTN","IBJ DF42",224, 0)
	6291	SSN(X) ; - Format th e SSN.
	6292	"RTN","IBJ DF42",225, 0)
	6293	Q $S(X]"" :$E(X,1,3) _"-"_$E(X, 4,5)_"-"_$ E(X,6,10), 1:"")
	6294	"RTN","IBJ DF42",226, 0)
	6295	;
	6296	"RTN","IBJ DF42",227, 0)
	6297	PAUSE ; - Page break .
	6298	"RTN","IBJ DF42",228, 0)
	6299	I $E(IOST ,1,2)'="C- " Q
	6300	"RTN","IBJ DF42",229, 0)
	6301	N IBX,DIR ,DIRUT,DUO UT,DTOUT,D IROUT,X,Y
	6302	"RTN","IBJ DF42",230, 0)
	6303	F IBX=$Y: 1:(IOSL-3) W !
	6304	"RTN","IBJ DF42",231, 0)
	6305	S DIR(0)= "E" D ^DIR S:$D(DIRU T)!($D(DUO UT)) IBQ=1
	6306	"RTN","IBJ DF42",232, 0)
	6307	Q
	6308	"RTN","IBJ DF43")
	6309	0^22^B2523 5431^B2346 9371
	6310	"RTN","IBJ DF43",1,0)
	6311	IBJDF43 ;A LB/RB - FI RST PARTY FOLLOW-UP REPORT (CO MPILE/PRIN T SUMMARY) ;15-APR-00
	6312	"RTN","IBJ DF43",2,0)
	6313	;;2.0;INT EGRATED BI LLING;12 3,568;21 -MAR-94;Bu ild 38
	6314	"RTN","IBJ DF43",3,0)
	6315	;Per VA D irective 6 402, this routine sh ould not b e modified .
	6316	"RTN","IBJ DF43",4,0)
	6317	;
	6318	"RTN","IBJ DF43",5,0)
	6319	INIT ; - I nitialize counters ( Called by IBJDF41)
	6320	"RTN","IBJ DF43",6,0)
	6321	; Pre-s et variabl es IB, IB( , IBCAT, I BSRC requi red.
	6322	"RTN","IBJ DF43",7,0)
	6323	N I,IB0 S IB0=$S(IB =40:19,1:I B)
	6324	"RTN","IBJ DF43",8,0)
	6325	;
	6326	"RTN","IBJ DF43",9,0)
	6327	I '$D(IB( IBCAT,IB0) ) D
	6328	"RTN","IBJ DF43",10,0 )
	6329	.I IBSTA= "A",IB0'=1 6 Q ; Act ive AR's o nly.
	6330	"RTN","IBJ DF43",11,0 )
	6331	.I IBSTA= "S",IB0=16 Q ; Susp ended AR's only.
	6332	"RTN","IBJ DF43",12,0 )
	6333	.F I=1:1: $S(IBSRC:8 ,1:7),9 S IB(IBCAT,I B0,I)=0
	6334	"RTN","IBJ DF43",13,0 )
	6335	Q
	6336	"RTN","IBJ DF43",14,0 )
	6337	;
	6338	"RTN","IBJ DF43",15,0 )
	6339	EN ; - Com pile entry point fro m IBJDF41.
	6340	"RTN","IBJ DF43",16,0 )
	6341	; Pre-s et variabl es IB, IB( , IBA, IBC AT, IBSRC required.
	6342	"RTN","IBJ DF43",17,0 )
	6343	N I,IB0,I BAGE,IBARD ,IBCAT1,IB OUT S IB0= $S(IB=40:1 9,1:IB)
	6344	"RTN","IBJ DF43",18,0 )
	6345	;
	6346	"RTN","IBJ DF43",19,0 )
	6347	; - Add t otals for summary.
	6348	"RTN","IBJ DF43",20,0 )
	6349	I IBSTA=" S" S IBSUS TYP=$$SUST ^IBJDF41(I BA) I IBSE LST'[(","_ IBSUSTYP_" ,") G ENQ ;Filter b y suspende d type IB* 2*568/DRF
	6350	"RTN","IBJ DF43",21,0 )
	6351	S IBARD=$ $ACT^IBJDF 2(IBA) G:' IBARD ENQ ; No activ ation date .
	6352	"RTN","IBJ DF43",22,0 )
	6353	S IBOUT=0 F I=1:1:5 S IBOUT=I BOUT+$P($G (^PRCA(430 ,IBA,7)),U ,I)
	6354	"RTN","IBJ DF43",23,0 )
	6355	;
	6356	"RTN","IBJ DF43",24,0 )
	6357	; - Handl e claims r eferred to Regional Counsel.
	6358	"RTN","IBJ DF43",25,0 )
	6359	I IBSRC,$ P($G(^PRCA (430,IBA,6 )),U,4) D G ENQ
	6360	"RTN","IBJ DF43",26,0 )
	6361	.S $P(IB( IBCAT,IB0, 8),U)=$P(I B(IBCAT,IB 0,8),U)+1
	6362	"RTN","IBJ DF43",27,0 )
	6363	.S $P(IB( IBCAT,IB0, 8),U,2)=$P (IB(IBCAT, IB0,8),U,2 )+IBOUT
	6364	"RTN","IBJ DF43",28,0 )
	6365	;
	6366	"RTN","IBJ DF43",29,0 )
	6367	I 'IBSRC, $P($G(^PRC A(430,IBA, 6)),U,4) G ENQ ;Fil ter by reg ional coun sel IB25 68/DRF
	6368	"RTN","IBJ DF43",30,0 )
	6369	S IBAGE=$ $FMDIFF^XL FDT(DT,IBA RD),IBCAT1 =$$CAT^IBJ DF2(IBAGE)
	6370	"RTN","IBJ DF43",31,0 )
	6371	S $P(IB(I BCAT,IB0,I BCAT1),U)= $P(IB(IBCA T,IB0,IBCA T1),U)+1
	6372	"RTN","IBJ DF43",32,0 )
	6373	S $P(IB(I BCAT,IB0,I BCAT1),U,2 )=$P(IB(IB CAT,IB0,IB CAT1),U,2) +IBOUT
	6374	"RTN","IBJ DF43",33,0 )
	6375	;
	6376	"RTN","IBJ DF43",34,0 )
	6377	ENQ K IBPR TFLG,IBPAG ,IBRUN,J,Z Q
	6378	"RTN","IBJ DF43",35,0 )
	6379	;
	6380	"RTN","IBJ DF43",36,0 )
	6381	PRT ; - Pr int entry point from IBJDF42.
	6382	"RTN","IBJ DF43",37,0 )
	6383	;
	6384	"RTN","IBJ DF43",38,0 )
	6385	; - Extra ct summary data.
	6386	"RTN","IBJ DF43",39,0 )
	6387	I $G(IBXT RACT) D EX TMO(.IB) G ENQ1
	6388	"RTN","IBJ DF43",40,0 )
	6389	;
	6390	"RTN","IBJ DF43",41,0 )
	6391	; - Print the summa ry report.
	6392	"RTN","IBJ DF43",42,0 )
	6393	D SUM
	6394	"RTN","IBJ DF43",43,0 )
	6395	;
	6396	"RTN","IBJ DF43",44,0 )
	6397	ENQ1 Q
	6398	"RTN","IBJ DF43",45,0 )
	6399	;
	6400	"RTN","IBJ DF43",46,0 )
	6401	EXTMO(IBS) ; Extract /transmit data to DM Extract M odule
	6402	"RTN","IBJ DF43",47,0 )
	6403	; IBS - A rray conta ining the summary in formation
	6404	"RTN","IBJ DF43",48,0 )
	6405	;
	6406	"RTN","IBJ DF43",49,0 )
	6407	N IB,IBCT ,IBI,IBJ,I BR,IBSQ,IB TP,IBZ
	6408	"RTN","IBJ DF43",50,0 )
	6409	;
	6410	"RTN","IBJ DF43",51,0 )
	6411	F IBI=1:1 :5 F IBJ=1 :1:18 S IB (IBI,IBJ)= $S(IBJ#2:0 ,1:"0.00")
	6412	"RTN","IBJ DF43",52,0 )
	6413	;
	6414	"RTN","IBJ DF43",53,0 )
	6415	S IBCT=""
	6416	"RTN","IBJ DF43",54,0 )
	6417	F S IBCT =$O(IBS(IB CT)) Q:IBC T="" D
	6418	"RTN","IBJ DF43",55,0 )
	6419	. S IBTP= 0
	6420	"RTN","IBJ DF43",56,0 )
	6421	. I IBCT= 2 S IBTP=1 ; Emergency/ Humatiatir an
	6422	"RTN","IBJ DF43",57,0 )
	6423	. I IBCT= 1 S IBTP=2 ; Ineligible
	6424	"RTN","IBJ DF43",58,0 )
	6425	. I IBCT= 18 S IBTP= 3 ; C - Means Test
	6426	"RTN","IBJ DF43",59,0 )
	6427	. I IBCT= 22 S IBTP= 4 ; RX CO-Paym ent/SC VET
	6428	"RTN","IBJ DF43",60,0 )
	6429	. I IBCT= 23 S IBTP= 5 ; RX CO-Paym ent/NSC VE T
	6430	"RTN","IBJ DF43",61,0 )
	6431	. S IBSQ= 1
	6432	"RTN","IBJ DF43",62,0 )
	6433	. F IBI=1 :1:8 D
	6434	"RTN","IBJ DF43",63,0 )
	6435	. . S IBZ =$G(IBS(IB CT,16,IBI) )
	6436	"RTN","IBJ DF43",64,0 )
	6437	. . S IB( IBTP,IBSQ) =+IBZ
	6438	"RTN","IBJ DF43",65,0 )
	6439	. . S IB( IBTP,IBSQ+ 1)=$FN(+$P (IBZ,"^",2 ),"",2)
	6440	"RTN","IBJ DF43",66,0 )
	6441	. . S IB( IBTP,17)=I B(IBTP,17) +IBZ
	6442	"RTN","IBJ DF43",67,0 )
	6443	. . S IB( IBTP,18)=I B(IBTP,18) +$P(IBZ,"^ ",2)
	6444	"RTN","IBJ DF43",68,0 )
	6445	. . S IBS Q=IBSQ+2
	6446	"RTN","IBJ DF43",69,0 )
	6447	. S IB(IB TP,18)=$FN (IB(IBTP,1 8),"",2)
	6448	"RTN","IBJ DF43",70,0 )
	6449	;
	6450	"RTN","IBJ DF43",71,0 )
	6451	F IBR=12: 1:16 D E^I BJDE(IBR,0 )
	6452	"RTN","IBJ DF43",72,0 )
	6453	Q
	6454	"RTN","IBJ DF43",73,0 )
	6455	;
	6456	"RTN","IBJ DF43",74,0 )
	6457	SUM ; - Pr int summar y for AR c ategory.
	6458	"RTN","IBJ DF43",75,0 )
	6459	; Input: IBCAT=AR c ategory po inter to f ile #430.2
	6460	"RTN","IBJ DF43",76,0 )
	6461	S IBS=$S( IBSRC:8,1: 7)
	6462	"RTN","IBJ DF43",77,0 )
	6463	S (IBCAT, IB,IBPRTFL G)=0
	6464	"RTN","IBJ DF43",78,0 )
	6465	F S IBCA T=$O(IB(IB CAT)) Q:'I BCAT D Q :IBQ
	6466	"RTN","IBJ DF43",79,0 )
	6467	. D HDR
	6468	"RTN","IBJ DF43",80,0 )
	6469	. F S IB =$O(IB(IBC AT,IB)) Q: 'IB D Q: IBQ
	6470	"RTN","IBJ DF43",81,0 )
	6471	. . ; - C alculate t otals firs t.
	6472	"RTN","IBJ DF43",82,0 )
	6473	. . F I=1 :1:IBS D Q:IBQ
	6474	"RTN","IBJ DF43",83,0 )
	6475	. . . F J =1,2 S $P( IB(IBCAT,I B,9),U,J)= $P(IB(IBCA T,IB,9),U, J)+$P(IB(I BCAT,IB,I) ,U,J)
	6476	"RTN","IBJ DF43",84,0 )
	6477	. . ;
	6478	"RTN","IBJ DF43",85,0 )
	6479	. . I $Y> (IOSL-16) D HDR Q:IB Q
	6480	"RTN","IBJ DF43",86,0 )
	6481	. . ;
	6482	"RTN","IBJ DF43",87,0 )
	6483	. . S X=$ S(IB=16:"A CTIVE ",1: "SUSPENDED ")
	6484	"RTN","IBJ DF43",88,0 )
	6485	. . S X=X _$P($G(^PR CA(430.2,I BCAT,0)),U )
	6486	"RTN","IBJ DF43",89,0 )
	6487	. . W !!! !?(80-$L(X )\2),X,!?( 80-$L(X)\2 ),$$DASH($ L(X)),!!
	6488	"RTN","IBJ DF43",90,0 )
	6489	. . ;
	6490	"RTN","IBJ DF43",91,0 )
	6491	. . W "AR Category" ,?31,"# Re ceivables" ,?52,"Tota l Outstand ing Balanc e",!
	6492	"RTN","IBJ DF43",92,0 )
	6493	. . W "-- ---------" ,?31,"---- ---------" ,?52,"---- ---------- ---------- -",!
	6494	"RTN","IBJ DF43",93,0 )
	6495	. . I 'IB (IBCAT,IB, 9) W !,"Th ere are no statistic s for this category. " D PAUSE Q
	6496	"RTN","IBJ DF43",94,0 )
	6497	. . ;
	6498	"RTN","IBJ DF43",95,0 )
	6499	. . ; - P rimary loo p to write results.
	6500	"RTN","IBJ DF43",96,0 )
	6501	. . S Y=$ P(IB(IBCAT ,IB,9),U,2 )
	6502	"RTN","IBJ DF43",97,0 )
	6503	. . F I=1 :1:IBS,9 S X=$P($T(C ATN+I),";; ",2,99) D
	6504	"RTN","IBJ DF43",98,0 )
	6505	. . . W:I =9 ! W !,X ,?30,$J(+I B(IBCAT,IB ,I),6)
	6506	"RTN","IBJ DF43",99,0 )
	6507	. . . W " (",$J(+I B(IBCAT,IB ,I)/+IB(IB CAT,IB,9)* 100,0,$S(I =9:0,1:2)) ,"%)"
	6508	"RTN","IBJ DF43",100, 0)
	6509	. . . S Z =$FN($P(IB (IBCAT,IB, I),U,2),", ",2)
	6510	"RTN","IBJ DF43",101, 0)
	6511	. . . W ? 52,$J($S(I =1!(I=9):" $",1:"")_Z ,15)
	6512	"RTN","IBJ DF43",102, 0)
	6513	. . . W " (",$J($S ('Y:0,1:$P (IB(IBCAT, IB,I),U,2) /Y*100),0, $S(I=9:0,1 :2)),"%)"
	6514	"RTN","IBJ DF43",103, 0)
	6515	. . ;
	6516	"RTN","IBJ DF43",104, 0)
	6517	. . S IBP RTFLG=1 D PAUSE
	6518	"RTN","IBJ DF43",105, 0)
	6519	;
	6520	"RTN","IBJ DF43",106, 0)
	6521	I 'IBPRTF LG D
	6522	"RTN","IBJ DF43",107, 0)
	6523	. W !!!!! !,"There a re no rece ivables fo r the para meters ent ered."
	6524	"RTN","IBJ DF43",108, 0)
	6525	;
	6526	"RTN","IBJ DF43",109, 0)
	6527	SUMQ Q
	6528	"RTN","IBJ DF43",110, 0)
	6529	;
	6530	"RTN","IBJ DF43",111, 0)
	6531	HDR ; - Wr ite the su mmary repo rt header.
	6532	"RTN","IBJ DF43",112, 0)
	6533	W:'$G(IBP AG) ! I $E (IOST,1,2) ="C-"!$G(I BPAG) W @I OF,*13
	6534	"RTN","IBJ DF43",113, 0)
	6535	S IBPAG=$ G(IBPAG)+1
	6536	"RTN","IBJ DF43",114, 0)
	6537	W "FIRST PARTY FOLL OW-UP SUMM ARY REPORT Run Dat e: ",IBRUN
	6538	"RTN","IBJ DF43",115, 0)
	6539	W ?71,"Pa ge: ",$J(I BPAG,3)
	6540	"RTN","IBJ DF43",116, 0)
	6541	S X=""
	6542	"RTN","IBJ DF43",117, 0)
	6543	I IBRPT=" D" D
	6544	"RTN","IBJ DF43",118, 0)
	6545	. I IBSMN '="A" D
	6546	"RTN","IBJ DF43",119, 0)
	6547	. . S X=" RECEIVAB LES OVER " _IBSMN_" A ND LESS TH AN "_IBSMX _" DAYS OL D "
	6548	"RTN","IBJ DF43",120, 0)
	6549	. I $G(IB SNA)'="ALL " D
	6550	"RTN","IBJ DF43",121, 0)
	6551	. . S X=X _"/ PATIEN TS FROM '" _$S(IBSNF= "":"FIRST" ,1:IBSNF)_ "' TO '"
	6552	"RTN","IBJ DF43",122, 0)
	6553	. . S X=X _$S(IBSNL= "zzzzz":"L AST",1:IBS NL)_"' "
	6554	"RTN","IBJ DF43",123, 0)
	6555	. I $G(IB SAM) S X=X _"/ MINIMU M BALANCE: $"_$FN(IB SAM,",",2) _" "
	6556	"RTN","IBJ DF43",124, 0)
	6557	S X=X_"/ RECEIVABLE S REFERRED TO RC "_$ S('IBSRC:" NOT ",1:"" )_"INCLUDE D"
	6558	"RTN","IBJ DF43",125, 0)
	6559	S $E(X,1, 2)=""
	6560	"RTN","IBJ DF43",126, 0)
	6561	F I=1:1 W !,$E(X,1, 80) S X=$E (X,81,999) I X="" Q
	6562	"RTN","IBJ DF43",127, 0)
	6563	;
	6564	"RTN","IBJ DF43",128, 0)
	6565	Q
	6566	"RTN","IBJ DF43",129, 0)
	6567	;
	6568	"RTN","IBJ DF43",130, 0)
	6569	DASH(X) ; - Return a dashed li ne.
	6570	"RTN","IBJ DF43",131, 0)
	6571	Q $TR($J( "",X)," ", "=")
	6572	"RTN","IBJ DF43",132, 0)
	6573	;
	6574	"RTN","IBJ DF43",133, 0)
	6575	PAUSE ; - Page break .
	6576	"RTN","IBJ DF43",134, 0)
	6577	I $E(IOST ,1,2)'="C- " Q
	6578	"RTN","IBJ DF43",135, 0)
	6579	N IBX,DIR ,DIRUT,DUO UT,DTOUT,D IROUT,X,Y
	6580	"RTN","IBJ DF43",136, 0)
	6581	F IBX=$Y: 1:(IOSL-3) W !
	6582	"RTN","IBJ DF43",137, 0)
	6583	S DIR(0)= "E" D ^DIR S:$D(DIRU T)!($D(DUO UT)) IBQ=1
	6584	"RTN","IBJ DF43",138, 0)
	6585	Q
	6586	"RTN","IBJ DF43",139, 0)
	6587	;
	6588	"RTN","IBJ DF43",140, 0)
	6589	CATN ; - L ist of cat egory name s.
	6590	"RTN","IBJ DF43",141, 0)
	6591	;;Less th an 30 days old
	6592	"RTN","IBJ DF43",142, 0)
	6593	;;31-60 d ays
	6594	"RTN","IBJ DF43",143, 0)
	6595	;;61-90 d ays
	6596	"RTN","IBJ DF43",144, 0)
	6597	;;91-120 days
	6598	"RTN","IBJ DF43",145, 0)
	6599	;;121-180 days
	6600	"RTN","IBJ DF43",146, 0)
	6601	;;181-365 days
	6602	"RTN","IBJ DF43",147, 0)
	6603	;;Over 36 5 days
	6604	"RTN","IBJ DF43",148, 0)
	6605	;;Referre d to Regio nal Counse l
	6606	"RTN","IBJ DF43",149, 0)
	6607	;;Total F irst Party Receivabl es
	6608	"RTN","IBJ TLA1")
	6609	0^2^B13446 872^B12051 503
	6610	"RTN","IBJ TLA1",1,0)
	6611	IBJTLA1 ;A LB/ARH - T PI ACTIVE BILLS LIST BUILD ;2/ 14/95
	6612	"RTN","IBJ TLA1",2,0)
	6613	;;2.0;INT EGRATED BI LLING;39 ,80,61,51, 153,137,18 3,276,451, 516,530,56 8;21-MAR -94;Build 38
	6614	"RTN","IBJ TLA1",3,0)
	6615	;;Per VA Directive 6402, this routine s hould not be modifie d.
	6616	"RTN","IBJ TLA1",4,0)
	6617	;
	6618	"RTN","IBJ TLA1",5,0)
	6619	BLDA ; bui ld active list for t hird party joint inq uiry activ e list
	6620	"RTN","IBJ TLA1",6,0)
	6621	N IBIFN,I BCNT S VAL MCNT=0,IBC NT=0
	6622	"RTN","IBJ TLA1",7,0)
	6623	S IBIFN=0 F S IBIF N=$O(^DGCR (399,"C",D FN,IBIFN)) Q:'IBIFN I $$ACTIV E^IBJTU4(I BIFN) W ". " D SCRN
	6624	"RTN","IBJ TLA1",8,0)
	6625	;
	6626	"RTN","IBJ TLA1",9,0)
	6627	I VALMCNT =0 D SET(" ",0),SET( "No Active Bills for this Pati ent",0)
	6628	"RTN","IBJ TLA1",10,0 )
	6629	;
	6630	"RTN","IBJ TLA1",11,0 )
	6631	Q
	6632	"RTN","IBJ TLA1",12,0 )
	6633	;
	6634	"RTN","IBJ TLA1",13,0 )
	6635	SCRN ; add bill to s creen list (IBIFN,DF N must be defined)
	6636	"RTN","IBJ TLA1",14,0 )
	6637	N X,IBY,I BD0,IBDU,I BDM,TYPE,R EJFLAG,IND FLG,IBTYP S X=""
	6638	"RTN","IBJ TLA1",15,0 )
	6639	S IBCNT=I BCNT+1,IBD 0=$G(^DGCR (399,+IBIF N,0)),IBDU =$G(^DGCR( 399,+IBIFN ,"U")),IBD M=$G(^DGCR (399,+IBIF N,"M"))
	6640	"RTN","IBJ TLA1",16,0 )
	6641	S IBY=IBC NT,X=$$SET FLD^VALM1( IBY,X,"NUM BER")
	6642	"RTN","IBJ TLA1",17,0 )
	6643	; IB2.0 451 - get EEOB indic ator for b ill # when applicabl e
	6644	"RTN","IBJ TLA1",18,0 )
	6645	S IBPFLAG =$$EEOB(+I BIFN)
	6646	"RTN","IBJ TLA1",19,0 )
	6647	S REJFLAG =+$$BILLRE J^IBJTU6($ P(IBD0,U)) ;IB2.05 30 Add ind icator for rejects
	6648	"RTN","IBJ TLA1",20,0 )
	6649	S INDFLG= $S($G(IBPF LAG)'="":" %",1:"")_$ S(REJFLAG: "c",1:"") S:INDFLG=" " INDFLG=" "
	6650	"RTN","IBJ TLA1",21,0 )
	6651	S IBY=IND FLG_$P(IBD 0,U,1)_$$E CME^IBTRE( IBIFN),X=$ $SETFLD^VA LM1(IBY,X, "BILL") ;a dd EEOB in dicator '% ' to bill number whe n applicab le
	6652	"RTN","IBJ TLA1",22,0 )
	6653	S IBY=$S( $$REF^IBJT U31(+IBIFN ):"r",1:"" ),X=$$SETF LD^VALM1(I BY,X,"REFE R")
	6654	"RTN","IBJ TLA1",23,0 )
	6655	S IBY=$S( $$IB^IBRUT L(+IBIFN,0 ):"*",1:"" ),X=$$SETF LD^VALM1(I BY,X,"HD")
	6656	"RTN","IBJ TLA1",24,0 )
	6657	S IBY=$$D ATE($P(IBD U,U,1)),X= $$SETFLD^V ALM1(IBY,X ,"STFROM")
	6658	"RTN","IBJ TLA1",25,0 )
	6659	S IBY=$$D ATE($P(IBD U,U,2)),X= $$SETFLD^V ALM1(IBY,X ,"STTO")
	6660	"RTN","IBJ TLA1",26,0 )
	6661	;
	6662	"RTN","IBJ TLA1",27,0 )
	6663	S IBY=$P( $$LST^DGMT U(DFN,$P(I BDU,U)),U, 4),IBY=$S( IBY="C":"Y ES",IBY="P ":"PEN",IB Y="R":"REQ ",IBY="G": "GMT",1:"N O"),X=$$SE TFLD^VALM1 (IBY,X,"MT ?")
	6664	"RTN","IBJ TLA1",28,0 )
	6665	;S IBY=$$ TYPE($P(IB D0,U,5))_$ $TF($P(IBD 0,U,6))_$S ($P(IBD0,U ,27)=1:"I" ,$P(IBD0,U ,27)=2:"P" ,1:""),X=$ $SETFLD^VA LM1(IBY,X, "TYPE") ; 516 - baa
	6666	"RTN","IBJ TLA1",29,0 )
	6667	S TYPE=$$ TYPE($P(IB D0,U,5)) I $E(TYPE,2 )="P" S TY PE=$E(TYPE ) ; 516 - baa
	6668	"RTN","IBJ TLA1",30,0 )
	6669	;S IBY=TY PE_"/"_$S( $P(IBD0,U, 27)=1:"I", $P(IBD0,U, 27)=2:"P", 1:""),X=$$ SETFLD^VAL M1(IBY,X," TYPE") ; 516 - baa
	6670	"RTN","IBJ TLA1",31,0 )
	6671	S IBY=TYP E_"/"_$S($ P(IBD0,U,2 7)=1:"I",$ P(IBD0,U,2 7)=2:"P",1 :" "),X=$$ SETFLD^VAL M1(IBY,X," TYPE") ; 5 68 - lmh r et space i f null
	6672	"RTN","IBJ TLA1",32,0 )
	6673	;
	6674	"RTN","IBJ TLA1",33,0 )
	6675	; Return care type for (I)npa t,(O)utpat , (R)x or (P)rosthet ics - add under TJPI screen TY PE column - 568
	6676	"RTN","IBJ TLA1",34,0 )
	6677	S IBTYP=$ $TYP^IBRFN (IBIFN)
	6678	"RTN","IBJ TLA1",35,0 )
	6679	S IBTYP=$ S(IBTYP="" :-1,IBTYP= "PR":"P",I BTYP="PH": "R",1:IBTY P)
	6680	"RTN","IBJ TLA1",36,0 )
	6681	S IBY=IBY _"/"_IBTYP ,X=$$SETFL D^VALM1(IB Y,X,"TYPE" )
	6682	"RTN","IBJ TLA1",37,0 )
	6683	;
	6684	"RTN","IBJ TLA1",38,0 )
	6685	S IBY=" " _$P($$ARST ATA^IBJTU4 (IBIFN),U, 2),X=$$SET FLD^VALM1( IBY,X,"ARS T")
	6686	"RTN","IBJ TLA1",39,0 )
	6687	;
	6688	"RTN","IBJ TLA1",40,0 )
	6689	S IBY=$P( $G(^DGCR(3 99.3,+$P(I BD0,U,7),0 )),U,4),X= $$SETFLD^V ALM1(IBY,X ,"RATE")
	6690	"RTN","IBJ TLA1",41,0 )
	6691	S IBY=$S( $$MINS^IBJ TU31(+IBIF N):"+",1:" "),X=$$SET FLD^VALM1( IBY,X,"CB" )
	6692	"RTN","IBJ TLA1",42,0 )
	6693	S IBY=+$G (^DGCR(399 ,+IBIFN,"M P"))
	6694	"RTN","IBJ TLA1",43,0 )
	6695	I 'IBY,$$ MCRWNR^IBE FUNC($$CUR R^IBCEF2(I BIFN)) S I BY=+$$CURR ^IBCEF2(IB IFN)
	6696	"RTN","IBJ TLA1",44,0 )
	6697	S IBY=$P( $G(^DIC(36 ,+IBY,0)), U,1)
	6698	"RTN","IBJ TLA1",45,0 )
	6699	S X=$$SET FLD^VALM1( IBY,X,"INS UR")
	6700	"RTN","IBJ TLA1",46,0 )
	6701	S IBY=$$B ILL^RCJIBF N2(IBIFN)
	6702	"RTN","IBJ TLA1",47,0 )
	6703	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,1),8,2) ,X,"OAMT")
	6704	"RTN","IBJ TLA1",48,0 )
	6705	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,3),8,2) ,X,"CAMT")
	6706	"RTN","IBJ TLA1",49,0 )
	6707	D SET(X,I BCNT)
	6708	"RTN","IBJ TLA1",50,0 )
	6709	Q
	6710	"RTN","IBJ TLA1",51,0 )
	6711	;
	6712	"RTN","IBJ TLA1",52,0 )
	6713	DATE(X) ; date in ex ternal for mat
	6714	"RTN","IBJ TLA1",53,0 )
	6715	N Y S Y=" " I X?7N.E S Y=$E(X, 4,5)_"/"_$ E(X,6,7)_" /"_$E(X,2, 3)
	6716	"RTN","IBJ TLA1",54,0 )
	6717	Q Y
	6718	"RTN","IBJ TLA1",55,0 )
	6719	;
	6720	"RTN","IBJ TLA1",56,0 )
	6721	TYPE(X) ; return abb reviated f orm of Bil l Classifi cation (39 9,.05)
	6722	"RTN","IBJ TLA1",57,0 )
	6723	Q $S(X=1: "IP",X=2:" IH",X=3:"O P",X=4:"OH ",1:"")
	6724	"RTN","IBJ TLA1",58,0 )
	6725	;
	6726	"RTN","IBJ TLA1",59,0 )
	6727	TF(X) ; re turn abbre viated for m of Timef rame of Bi ll (399,.0 6)
	6728	"RTN","IBJ TLA1",60,0 )
	6729	Q $S(X=2: "-F",X=3:" -C",X=4:"- L",X'=1:"- O",1:"")
	6730	"RTN","IBJ TLA1",61,0 )
	6731	;
	6732	"RTN","IBJ TLA1",62,0 )
	6733	SET(X,CNT) ; set up list manag er screen array
	6734	"RTN","IBJ TLA1",63,0 )
	6735	S VALMCNT =VALMCNT+1
	6736	"RTN","IBJ TLA1",64,0 )
	6737	S ^TMP("I BJTLA",$J, VALMCNT,0) =X Q:'CNT
	6738	"RTN","IBJ TLA1",65,0 )
	6739	S ^TMP("I BJTLA",$J, "IDX",VALM CNT,+CNT)= ""
	6740	"RTN","IBJ TLA1",66,0 )
	6741	S ^TMP("I BJTLAX",$J ,CNT)=VALM CNT_U_IBIF N
	6742	"RTN","IBJ TLA1",67,0 )
	6743	Q
	6744	"RTN","IBJ TLA1",68,0 )
	6745	;
	6746	"RTN","IBJ TLA1",69,0 )
	6747	EEOB(IBIFN ) ; get pa yment info rmation
	6748	"RTN","IBJ TLA1",70,0 )
	6749	; IB2.0 451 - find an EOB pa yment for a bill
	6750	"RTN","IBJ TLA1",71,0 )
	6751	; input i s the IEN for the bi ll # in fi le #399 an d must be valid,
	6752	"RTN","IBJ TLA1",72,0 )
	6753	; output is the EEO B indicato r '%' if a payment i s found in file #361 .1,
	6754	"RTN","IBJ TLA1",73,0 )
	6755	; exclude EOB type MRA (Medic are).
	6756	"RTN","IBJ TLA1",74,0 )
	6757	N IBPFLAG ,IBVAL,Z
	6758	"RTN","IBJ TLA1",75,0 )
	6759	I $G(IBIF N)=0 Q ""
	6760	"RTN","IBJ TLA1",76,0 )
	6761	I '$O(^IB M(361.1,"B ",IBIFN,0) ) Q "" ; no entry h ere
	6762	"RTN","IBJ TLA1",77,0 )
	6763	I $P($G(^ DGCR(399,I BIFN,0))," ^",13)=1 Q "" ;avoi d 'ENTERED /NOT REVIE WED' statu s
	6764	"RTN","IBJ TLA1",78,0 )
	6765	; handle both singl e and mult iple bill entries in file #361 .1
	6766	"RTN","IBJ TLA1",79,0 )
	6767	S Z=0 F S Z=$O(^IB M(361.1,"B ",IBIFN,Z) ) Q:'Z D Q:$G(IBPF LAG)="%"
	6768	"RTN","IBJ TLA1",80,0 )
	6769	. S IBVAL =$G(^IBM(3 61.1,Z,0))
	6770	"RTN","IBJ TLA1",81,0 )
	6771	. S IBPFL AG=$S($P(I BVAL,"^",4 )=1:"",$P( IBVAL,"^", 4)=0:"%",1 :"")
	6772	"RTN","IBJ TLA1",82,0 )
	6773	Q IBPFLAG ; EOB in dicator fo r either 1 st or 3rd payment on bill
	6774	"RTN","IBJ TLA1",83,0 )
	6775	;
	6776	"RTN","IBJ TLB1")
	6777	0^7^B13573 050^B12752 963
	6778	"RTN","IBJ TLB1",1,0)
	6779	IBJTLB1 ;A LB/ARH - T PI INACTIV E LIST BUI LD ;2/14/9 5
	6780	"RTN","IBJ TLB1",2,0)
	6781	;;2.0;INT EGRATED BI LLING;39 ,80,61,137 ,276,451,5 16,530,568 ;21-MAR- 94;Build 3 8
	6782	"RTN","IBJ TLB1",3,0)
	6783	;;Per VA Directive 6402, this routine s hould not be modifie d.
	6784	"RTN","IBJ TLB1",4,0)
	6785	;
	6786	"RTN","IBJ TLB1",5,0)
	6787	BLDA ; bui ld active list for t hird party joint inq uiry activ e list, DF N must be defined
	6788	"RTN","IBJ TLB1",6,0)
	6789	; first s earch star ts at dt a nd works b ackwards f or 6 month s of bills or IBMAXC NT bills, whichever is greater
	6790	"RTN","IBJ TLB1",7,0)
	6791	; all bil ls for a s ingle day are includ ed in the same searc h so even IBMAXCNT m ay be exce eded
	6792	"RTN","IBJ TLB1",8,0)
	6793	; if IBEN D is defin ed on entr y it is us ed as the end dt of the search , otherwis e DT is us ed
	6794	"RTN","IBJ TLB1",9,0)
	6795	; IBBEG i s left def ined on ex it, if it has a valu e then it is used by the Chang e Dates ac tion to de fine the n ext
	6796	"RTN","IBJ TLB1",10,0 )
	6797	; end dat e of the s earch, thi s results in each CD action de fault work ing backwa rds throug h the date range unt il
	6798	"RTN","IBJ TLB1",11,0 )
	6799	; no bill s are foun d and IBBE G is null then searc h restarts at DT, IB END is def ined so ca n tell if range chan ged
	6800	"RTN","IBJ TLB1",12,0 )
	6801	N IBIFN,I BCNT,IBBDT ,IBEDT,IBF IRST,IBLAS T,IBDT1,IB DT2,IBMAXC NT K IBHMS G
	6802	"RTN","IBJ TLB1",13,0 )
	6803	S IBEDT=$ S(+$G(IBEN D):IBEND,1 :DT),IBBDT =$$FMADD^X LFDT(IBEDT ,-180),IBM AXCNT=52
	6804	"RTN","IBJ TLB1",14,0 )
	6805	;
	6806	"RTN","IBJ TLB1",15,0 )
	6807	S (VALMCN T,IBCNT)=0 ,IBDT1=$S( IBEDT'="": -(IBEDT+.0 1),1:""),I BDT2=-IBBD T
	6808	"RTN","IBJ TLB1",16,0 )
	6809	S IBFIRST =IBBDT,IBL AST=-$O(^D GCR(399,"A PDS",DFN," "))
	6810	"RTN","IBJ TLB1",17,0 )
	6811	;
	6812	"RTN","IBJ TLB1",18,0 )
	6813	F S IBDT 1=$O(^DGCR (399,"APDS ",DFN,IBDT 1)) Q:'IBD T1!(IBDT1> IBDT2&(IBC NT'<IBMAXC NT)) S IB FIRST=-IBD T1 D
	6814	"RTN","IBJ TLB1",19,0 )
	6815	. S IBIFN =0 F S IB IFN=$O(^DG CR(399,"AP DS",DFN,IB DT1,IBIFN) ) Q:'IBIFN I '$$ACT IVE^IBJTU4 (IBIFN) D SCRN W "."
	6816	"RTN","IBJ TLB1",20,0 )
	6817	;
	6818	"RTN","IBJ TLB1",21,0 )
	6819	S IBBEG=$ S('IBDT1:" ",IBBDT>IB FIRST:IBFI RST,1:IBBD T),IBBDT=$ S(+IBBEG:$ $DATE(IBBE G),1:"BEGI N")
	6820	"RTN","IBJ TLB1",22,0 )
	6821	S IBEND=$ S(IBEDT="" !(IBLAST'> IBEDT):"", 1:IBEDT),I BEDT=$S(+I BEND:$$DAT E(IBEND),1 :"END")
	6822	"RTN","IBJ TLB1",23,0 )
	6823	;
	6824	"RTN","IBJ TLB1",24,0 )
	6825	I 'IBBEG, 'IBEND S I BHMSG="** All Inacti ve Bills * *"
	6826	"RTN","IBJ TLB1",25,0 )
	6827	I $G(IBHM SG)="" S I BHMSG=IBBD T_" - "_IB EDT
	6828	"RTN","IBJ TLB1",26,0 )
	6829	S IBHMSG= IBHMSG_" ("_VALMCN T_")"
	6830	"RTN","IBJ TLB1",27,0 )
	6831	;
	6832	"RTN","IBJ TLB1",28,0 )
	6833	I VALMCNT =0 D SET(" ",0),SET( "No Inacti ve Bills f or this Pa tient",0)
	6834	"RTN","IBJ TLB1",29,0 )
	6835	;
	6836	"RTN","IBJ TLB1",30,0 )
	6837	Q
	6838	"RTN","IBJ TLB1",31,0 )
	6839	;
	6840	"RTN","IBJ TLB1",32,0 )
	6841	SCRN ; add bill to s creen list (IBIFN,DF N must be defined)
	6842	"RTN","IBJ TLB1",33,0 )
	6843	N X,IBY,I BD0,IBDU,I BDM,TYPE,R EJFLAG,IND FLG S X=""
	6844	"RTN","IBJ TLB1",34,0 )
	6845	S IBCNT=I BCNT+1,IBD 0=$G(^DGCR (399,+IBIF N,0)),IBDU =$G(^DGCR( 399,+IBIFN ,"U")),IBD M=$G(^DGCR (399,+IBIF N,"M"))
	6846	"RTN","IBJ TLB1",35,0 )
	6847	S IBY=IBC NT,X=$$SET FLD^VALM1( IBY,X,"NUM BER")
	6848	"RTN","IBJ TLB1",36,0 )
	6849	; IB2.0 451 - get EEOB indic ator for b ill # when applicabl e
	6850	"RTN","IBJ TLB1",37,0 )
	6851	S IBPFLAG =$$EEOB^IB JTLA1(+IBI FN)
	6852	"RTN","IBJ TLB1",38,0 )
	6853	S REJFLAG =+$$BILLRE J^IBJTU6($ P(IBD0,U)) ;IB2.05 30 Add ind icator for rejects
	6854	"RTN","IBJ TLB1",39,0 )
	6855	S INDFLG= $S($G(IBPF LAG)'="":" %",1:"")_$ S(REJFLAG: "c",1:"") S:INDFLG=" " INDFLG=" "
	6856	"RTN","IBJ TLB1",40,0 )
	6857	S IBY=$P( IBD0,U,1)_ $$ECME^IBT RE(IBIFN), X=$$SETFLD ^VALM1(IBY ,X,"BILL")
	6858	"RTN","IBJ TLB1",41,0 )
	6859	S IBY=IND FLG_IBY,X= $$SETFLD^V ALM1(IBY,X ,"BILL")
	6860	"RTN","IBJ TLB1",42,0 )
	6861	S IBY=$S( $$REF^IBJT U31(+IBIFN ):"r",1:"" ),X=$$SETF LD^VALM1(I BY,X,"REFE R")
	6862	"RTN","IBJ TLB1",43,0 )
	6863	S IBY=$S( $$IB^IBRUT L(+IBIFN,0 ):"*",1:"" ),X=$$SETF LD^VALM1(I BY,X,"HD")
	6864	"RTN","IBJ TLB1",44,0 )
	6865	S IBY=$$D ATE($P(IBD U,U,1)),X= $$SETFLD^V ALM1(IBY,X ,"STFROM")
	6866	"RTN","IBJ TLB1",45,0 )
	6867	S IBY=$$D ATE($P(IBD U,U,2)),X= $$SETFLD^V ALM1(IBY,X ,"STTO")
	6868	"RTN","IBJ TLB1",46,0 )
	6869	;
	6870	"RTN","IBJ TLB1",47,0 )
	6871	;S IBY=$$ TYPE($P(IB D0,U,5))_$ $TF($P(IBD 0,U,6)),X= $$SETFLD^V ALM1(IBY,X ,"TYPE")
	6872	"RTN","IBJ TLB1",48,0 )
	6873	S TYPE=$$ TYPE($P(IB D0,U,5)) I $E(TYPE,2 )="P" S TY PE=$E(TYPE ) ; 516 - baa
	6874	"RTN","IBJ TLB1",49,0 )
	6875	;S IBY=TY PE_"/"_$S( $P(IBD0,U, 27)=1:"I", $P(IBD0,U, 27)=2:"P", 1:""),X=$$ SETFLD^VAL M1(IBY,X," TYPE") ; 516 - baa
	6876	"RTN","IBJ TLB1",50,0 )
	6877	S IBY=TYP E_"/"_$S($ P(IBD0,U,2 7)=1:"I",$ P(IBD0,U,2 7)=2:"P",1 :" "),X=$$ SETFLD^VAL M1(IBY,X," TYPE")
	6878	"RTN","IBJ TLB1",51,0 )
	6879	S IBTYP=$ $TYP^IBRFN (IBIFN)
	6880	"RTN","IBJ TLB1",52,0 )
	6881	S IBTYP=$ S(IBTYP="" :-1,IBTYP= "PR":"P",I BTYP="PH": "R",1:IBTY P)
	6882	"RTN","IBJ TLB1",53,0 )
	6883	S IBY=IBY _"/"_IBTYP ,X=$$SETFL D^VALM1(IB Y,X,"TYPE" )
	6884	"RTN","IBJ TLB1",54,0 )
	6885	S IBY=" " _$P($$ARST ATA^IBJTU4 (IBIFN),U, 2),X=$$SET FLD^VALM1( IBY,X,"ARS T")
	6886	"RTN","IBJ TLB1",55,0 )
	6887	;
	6888	"RTN","IBJ TLB1",56,0 )
	6889	S IBY=$P( $G(^DGCR(3 99.3,+$P(I BD0,U,7),0 )),U,4),X= $$SETFLD^V ALM1(IBY,X ,"RATE")
	6890	"RTN","IBJ TLB1",57,0 )
	6891	S IBY=$S( $$MINS^IBJ TU31(IBIFN ):"+",1:"" ),X=$$SETF LD^VALM1(I BY,X,"CB")
	6892	"RTN","IBJ TLB1",58,0 )
	6893	S IBY=+$G (^DGCR(399 ,+IBIFN,"M P"))
	6894	"RTN","IBJ TLB1",59,0 )
	6895	I 'IBY,$$ MCRWNR^IBE FUNC(+$$CU RR^IBCEF2( IBIFN)) S IBY=+$$CUR R^IBCEF2(I BIFN)
	6896	"RTN","IBJ TLB1",60,0 )
	6897	S IBY=$P( $G(^DIC(36 ,+IBY,0)), U,1),X=$$S ETFLD^VALM 1(IBY,X,"I NSUR")
	6898	"RTN","IBJ TLB1",61,0 )
	6899	S IBY=$$B ILL^RCJIBF N2(IBIFN)
	6900	"RTN","IBJ TLB1",62,0 )
	6901	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,1),8,2) ,X,"OAMT")
	6902	"RTN","IBJ TLB1",63,0 )
	6903	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,3),8,2) ,X,"CAMT")
	6904	"RTN","IBJ TLB1",64,0 )
	6905	D SET(X,I BCNT)
	6906	"RTN","IBJ TLB1",65,0 )
	6907	Q
	6908	"RTN","IBJ TLB1",66,0 )
	6909	;
	6910	"RTN","IBJ TLB1",67,0 )
	6911	DATE(X) ; date in ex ternal for mat
	6912	"RTN","IBJ TLB1",68,0 )
	6913	Q $E(X,4, 5)_"/"_$E( X,6,7)_"/" _$E(X,2,3)
	6914	"RTN","IBJ TLB1",69,0 )
	6915	;
	6916	"RTN","IBJ TLB1",70,0 )
	6917	TYPE(X) ; return abb reviated f orm of Bil l Classifi cation (39 9,.05)
	6918	"RTN","IBJ TLB1",71,0 )
	6919	; modifie d for 516 - baa
	6920	"RTN","IBJ TLB1",72,0 )
	6921	;Q $S(X=1 :"IP",X=2: "IH",X=3:" OP",X=4:"O H",1:"")
	6922	"RTN","IBJ TLB1",73,0 )
	6923	Q $S(X=1: "I",X=2:"I H",X=3:"O" ,X=4:"OH", 1:"")
	6924	"RTN","IBJ TLB1",74,0 )
	6925	;
	6926	"RTN","IBJ TLB1",75,0 )
	6927	TF(X) ; re turn abbre viated for m of Timef rame of Bi ll (399,.0 6)
	6928	"RTN","IBJ TLB1",76,0 )
	6929	Q $S(X=2: "-F",X=3:" -C",X=4:"- L",X'=1:"- O",1:"")
	6930	"RTN","IBJ TLB1",77,0 )
	6931	;
	6932	"RTN","IBJ TLB1",78,0 )
	6933	SET(X,CNT) ; set up list manag er screen array
	6934	"RTN","IBJ TLB1",79,0 )
	6935	S VALMCNT =VALMCNT+1
	6936	"RTN","IBJ TLB1",80,0 )
	6937	S ^TMP("I BJTLB",$J, VALMCNT,0) =X Q:'CNT
	6938	"RTN","IBJ TLB1",81,0 )
	6939	S ^TMP("I BJTLB",$J, "IDX",VALM CNT,+CNT)= ""
	6940	"RTN","IBJ TLB1",82,0 )
	6941	S ^TMP("I BJTLBX",$J ,CNT)=VALM CNT_U_IBIF N
	6942	"RTN","IBJ TLB1",83,0 )
	6943	Q
	6944	"RTN","IBT RE2")
	6945	0^3^B41197 504^B32981 505
	6946	"RTN","IBT RE2",1,0)
	6947	IBTRE2 ;AL B/AAS - CL AIMS TRACK ING - ACTI ONS ;27-JU N-93
	6948	"RTN","IBT RE2",2,0)
	6949	;;2.0;INT EGRATED BI LLING;23 ,121,249,3 12,315,568 ;21-MAR- 94;Build 3 8
	6950	"RTN","IBT RE2",3,0)
	6951	;;Per VA Directive 6402, this routine s hould not be modifie d.
	6952	"RTN","IBT RE2",4,0)
	6953	;
	6954	"RTN","IBT RE2",5,0)
	6955	% G EN^IBT RE
	6956	"RTN","IBT RE2",6,0)
	6957	;
	6958	"RTN","IBT RE2",7,0)
	6959	AT ; -- Ad d tracking entry
	6960	"RTN","IBT RE2",8,0)
	6961	I '$$PFSS WARN^IBBSH DWN() S VA LMBCK="R" Q ;IB2.031 2
	6962	"RTN","IBT RE2",9,0)
	6963	D FULL^VA LM1
	6964	"RTN","IBT RE2",10,0)
	6965	N X,Y,DIC ,DA,DR,DD, DO,DIR,DIR UT,DTOUT,D UOUT,IBETY P,IBQUIT,I BTDT,VAIN, VAINDT,IBT RN,IBTDTE
	6966	"RTN","IBT RE2",11,0)
	6967	;
	6968	"RTN","IBT RE2",12,0)
	6969	TEST S IBQ UIT=0
	6970	"RTN","IBT RE2",13,0)
	6971	S DIC(0)= "AEQMNZ",D IC="^IBE(3 56.6,",DIC ("S")="I $ P(^(0),U,3 )<3!($P(^( 0),U,3)=4) ",DIC("A") ="Select T racking Ty pe: " ;56 8
	6972	"RTN","IBT RE2",14,0)
	6973	D ^DIC K DIC S IBET YP=+Y I +Y <0 G ATQ
	6974	"RTN","IBT RE2",15,0)
	6975	W !
	6976	"RTN","IBT RE2",16,0)
	6977	;
	6978	"RTN","IBT RE2",17,0)
	6979	ADM I IBET YP=$O(^IBE (356.6,"AC ",1,0)) D I IBQUIT G ATQ
	6980	"RTN","IBT RE2",18,0)
	6981	.N DIR
	6982	"RTN","IBT RE2",19,0)
	6983	.S DIR("? ")=" "
	6984	"RTN","IBT RE2",20,0)
	6985	.S DIR("? ",1)=" Enter any Date!"
	6986	"RTN","IBT RE2",21,0)
	6987	.S DIR("? ",2)=" "
	6988	"RTN","IBT RE2",22,0)
	6989	.S DIR("? ",3)=" If the pat ient was a n inpatien t on that date the s ystem will use the"
	6990	"RTN","IBT RE2",23,0)
	6991	.S DIR("? ",4)=" correct ad mission da te. If yo u are trac king an ad missions a t another"
	6992	"RTN","IBT RE2",24,0)
	6993	.S DIR("? ",5)=" facility y ou may ent er that da te. Enter '??' to g et a list of the"
	6994	"RTN","IBT RE2",25,0)
	6995	.S DIR("? ",6)=" last 10 ad missions f or this pa tient."
	6996	"RTN","IBT RE2",26,0)
	6997	.S DIR("? ?")="^D LI STA^IBTRE2 0"
	6998	"RTN","IBT RE2",27,0)
	6999	.S DIR(0) ="DO^::AEX TP",DIR("A ")="Admiss ion Date"
	7000	"RTN","IBT RE2",28,0)
	7001	.D ^DIR K DIR S (IB TDT,VAINDT )=+Y I $P( VAINDT,"." ,2)="" S V AINDT=VAIN DT+.24
	7002	"RTN","IBT RE2",29,0)
	7003	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	7004	"RTN","IBT RE2",30,0)
	7005	.; -- che ck for val id admissi on
	7006	"RTN","IBT RE2",31,0)
	7007	.S VA200= "" D INP^V ADPT I VAI N(1)="" D ;look for one day a dmission
	7008	"RTN","IBT RE2",32,0)
	7009	..S IBX=+ $O(^(+$O(^ DGPM("ATID 1",DFN,999 9999-IBTDT )),0)),IBX =+$G(^DGPM (IBX,0))
	7010	"RTN","IBT RE2",33,0)
	7011	..I $E(IB X,1,7)=IBT DT S VAIND T=IBX D IN P^VADPT ;9 999999.999 9999
	7012	"RTN","IBT RE2",34,0)
	7013	..I VAIN( 1) W !!,"W ARNING: Th is appears to be a o ne day sta y."
	7014	"RTN","IBT RE2",35,0)
	7015	.I VAIN(1 )="" D
	7016	"RTN","IBT RE2",36,0)
	7017	..W !!,*7 ,"WARNING: Patient d oes not ap pear to be an inpati ent on thi s date!",!
	7018	"RTN","IBT RE2",37,0)
	7019	..I VAIN( 7)="" S VA IN(7)=IBTD T,Y=IBTDT D D^DIQ S $P(VAIN(7) ,"^",2)=Y
	7020	"RTN","IBT RE2",38,0)
	7021	.;
	7022	"RTN","IBT RE2",39,0)
	7023	.S DIR("? ")="No adm ission was found for this date , enter 'Y es' if you want to a dd this an yway, or ' No' if you do not wi sh to trac k this dat e."
	7024	"RTN","IBT RE2",40,0)
	7025	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Admissi on Date "_ $P(VAIN(7) ,"^",2),DI R("B")="NO "
	7026	"RTN","IBT RE2",41,0)
	7027	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	7028	"RTN","IBT RE2",42,0)
	7029	.I VAIN(1 ) D ADM^IB TUTL(VAIN( 1))
	7030	"RTN","IBT RE2",43,0)
	7031	.I 'VAIN( 1) D OTH^I BTUTL(DFN, IBETYP,IBT DT)
	7032	"RTN","IBT RE2",44,0)
	7033	.Q
	7034	"RTN","IBT RE2",45,0)
	7035	;
	7036	"RTN","IBT RE2",46,0)
	7037	OPT I IBET YP=$O(^IBE (356.6,"AC ",2,0)) D I IBQUIT G ATQ
	7038	"RTN","IBT RE2",47,0)
	7039	.;
	7040	"RTN","IBT RE2",48,0)
	7041	.N DIR,IB SD,IBARRAY
	7042	"RTN","IBT RE2",49,0)
	7043	.;get all possible scheduling data for patient
	7044	"RTN","IBT RE2",50,0)
	7045	.K ^TMP($ J,"SDAMA30 1")
	7046	"RTN","IBT RE2",51,0)
	7047	.S IBARRA Y(4)=DFN,I BARRAY("SO RT")="P",I BARRAY("FL DS")="1;2; 3;10;12",I BSD=$$SDAP I^SDAMA301 (.IBARRAY)
	7048	"RTN","IBT RE2",52,0)
	7049	.;
	7050	"RTN","IBT RE2",53,0)
	7051	.S DIR("? ")="Time i s Required ."
	7052	"RTN","IBT RE2",54,0)
	7053	.S DIR("? ",1)=" Enter the Outpatient Visit Dat e."
	7054	"RTN","IBT RE2",55,0)
	7055	.S DIR("? ",2)=" If no sche duled visi t is found you will be given a warning. Enter"
	7056	"RTN","IBT RE2",56,0)
	7057	.S DIR("? ",3)=" '??' to ge t a list o f schedule d visits b etween "_$ $DAT1^IBOU TL(IBTBDT) _" and "_$ $DAT1^IBOU TL(IBTEDT) _"."
	7058	"RTN","IBT RE2",57,0)
	7059	.I '$D(IB TASS) S DI R("?",4)=" Use th e change d ate range action to change lis ting of sc heduled Vi sits."
	7060	"RTN","IBT RE2",58,0)
	7061	.S DIR("? ?")="^D LI STO^IBTRE2 0"
	7062	"RTN","IBT RE2",59,0)
	7063	.S DIR(0) ="DO^::AEX TP",DIR("A ")="Outpat ient Visit Date"
	7064	"RTN","IBT RE2",60,0)
	7065	.D ^DIR K DIR S IBT DT=Y
	7066	"RTN","IBT RE2",61,0)
	7067	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	7068	"RTN","IBT RE2",62,0)
	7069	.;
	7070	"RTN","IBT RE2",63,0)
	7071	.; check scheduling and encou nters file for entri es
	7072	"RTN","IBT RE2",64,0)
	7073	.S X=$D(^ TMP($J,"SD AMA301",DF N,IBTDT))
	7074	"RTN","IBT RE2",65,0)
	7075	.;
	7076	"RTN","IBT RE2",66,0)
	7077	.I 'X,IBS D<0 W !!,* 7,"WARNING : Unable t o look up Visit info rmation fo r this Pat ient" X "N IBX S IBX =0 F S IB X=$O(^TMP( $J,""SDAMA 301"",IBX) ) W !?5,IB X,?10,$G(^ (IBX))"
	7078	"RTN","IBT RE2",67,0)
	7079	.;
	7080	"RTN","IBT RE2",68,0)
	7081	.I 'X,IBS D S Y=$O(^ TMP($J,"SD AMA301",DF N,$P(IBTDT ,"."))) I $P(IBTDT," .")=$P(Y," .") S IBTD T=Y,X=1
	7082	"RTN","IBT RE2",69,0)
	7083	.;
	7084	"RTN","IBT RE2",70,0)
	7085	.; if non say so
	7086	"RTN","IBT RE2",71,0)
	7087	.I 'X,IBS D'=-1 W !! ,*7,"WARNI NG: No Vis it informa tion for t his Patien t for this date.",!
	7088	"RTN","IBT RE2",72,0)
	7089	.;
	7090	"RTN","IBT RE2",73,0)
	7091	.; ask if okay to a dd entry.
	7092	"RTN","IBT RE2",74,0)
	7093	.S Y=IBTD T D D^DIQ S IBTDTE=Y
	7094	"RTN","IBT RE2",75,0)
	7095	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Visit D ate "_IBTD TE,DIR("B" )="NO"
	7096	"RTN","IBT RE2",76,0)
	7097	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	7098	"RTN","IBT RE2",77,0)
	7099	.D OPT^IB TUTL1(DFN, IBETYP,IBT DT,$P($G(^ TMP($J,"SD AMA301",DF N,IBTDT)), "^",12))
	7100	"RTN","IBT RE2",78,0)
	7101	.K ^TMP($ J,"SDAMA30 1")
	7102	"RTN","IBT RE2",79,0)
	7103	.Q
	7104	"RTN","IBT RE2",80,0)
	7105	;
	7106	"RTN","IBT RE2",81,0)
	7107	SCH I IBET YP=$O(^IBE (356.6,"AC ",5,0)) D I IBQUIT G ATQ
	7108	"RTN","IBT RE2",82,0)
	7109	.N DIR
	7110	"RTN","IBT RE2",83,0)
	7111	.S DIR("? ")=" "
	7112	"RTN","IBT RE2",84,0)
	7113	.S DIR("? ",1)=" Enter date of the sc heduled ad mission."
	7114	"RTN","IBT RE2",85,0)
	7115	.S DIR("? ",2)=" If you use the sched uled admis sion packa ge to sche dule admis sions"
	7116	"RTN","IBT RE2",86,0)
	7117	.S DIR("? ",3)=" you may en ter '??' t o get a li st of sche duled admi ssions bet ween"
	7118	"RTN","IBT RE2",87,0)
	7119	.S DIR("? ",4)=" "_$$DAT1^I BOUTL(IBTB DT)_" and "_$$DAT1^I BOUTL(IBTE DT)_". Us e the chan ge date ra nge action "
	7120	"RTN","IBT RE2",88,0)
	7121	.S DIR("? ",5)=" to change listing of scheduled admission s."
	7122	"RTN","IBT RE2",89,0)
	7123	.S DIR("? ",5)=" This shoul d be a fut ure schedu led admiss ion."
	7124	"RTN","IBT RE2",90,0)
	7125	.S DIR(0) ="DO^::AEX T",DIR("A" )="Schedul ed Admissi on Date"
	7126	"RTN","IBT RE2",91,0)
	7127	.S DIR("? ?")="^D LI STS^IBTRE2 0"
	7128	"RTN","IBT RE2",92,0)
	7129	.D ^DIR K DIR S IBT DT=+Y
	7130	"RTN","IBT RE2",93,0)
	7131	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	7132	"RTN","IBT RE2",94,0)
	7133	.; ask if okay to a dd entry.
	7134	"RTN","IBT RE2",95,0)
	7135	.D FINDS^ IBTRE20
	7136	"RTN","IBT RE2",96,0)
	7137	.S Y=IBTD T D D^DIQ S IBTDTE=Y
	7138	"RTN","IBT RE2",97,0)
	7139	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Schedul ed Adm. Da te "_IBTDT E,DIR("B") ="NO"
	7140	"RTN","IBT RE2",98,0)
	7141	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	7142	"RTN","IBT RE2",99,0)
	7143	.I IBTDT\ 1'>DT S VA INDT=IBTDT \1+.24 D I NP^VADPT I $G(VAIN(1 )) D Q
	7144	"RTN","IBT RE2",100,0 )
	7145	..W !!,"P atient an inpatient on this da te, using inpatient admission. "
	7146	"RTN","IBT RE2",101,0 )
	7147	..D ADM^I BTUTL(VAIN (1))
	7148	"RTN","IBT RE2",102,0 )
	7149	.D SCH^IB TUTL2(DFN, IBTDT)
	7150	"RTN","IBT RE2",103,0 )
	7151	.Q
	7152	"RTN","IBT RE2",104,0 )
	7153	;
	7154	"RTN","IBT RE2",105,0 )
	7155	PRO I IBET YP=$O(^IBE (356.6,"AC ",3,0)) D I IBQUIT G ATQ
	7156	"RTN","IBT RE2",106,0 )
	7157	.;
	7158	"RTN","IBT RE2",107,0 )
	7159	.N DIR,IB SD,IBARRAY ,C
	7160	"RTN","IBT RE2",108,0 )
	7161	.;get all possible scheduling data for patient
	7162	"RTN","IBT RE2",109,0 )
	7163	.S IBARRA Y(0)=DFN
	7164	"RTN","IBT RE2",110,0 )
	7165	.;
	7166	"RTN","IBT RE2",111,0 )
	7167	.D LISTP^ IBTRE20
	7168	"RTN","IBT RE2",112,0 )
	7169	.W !
	7170	"RTN","IBT RE2",113,0 )
	7171	.I C=0 S IBQUIT=1 Q
	7172	"RTN","IBT RE2",114,0 )
	7173	.S DIR("? ")="Prosth etics"
	7174	"RTN","IBT RE2",115,0 )
	7175	.S DIR(0) ="N",DIR(" A")="Prost hetics Ent ry"
	7176	"RTN","IBT RE2",116,0 )
	7177	.D ^DIR K DIR
	7178	"RTN","IBT RE2",117,0 )
	7179	.I $D(DIR UT) S IBQU IT=1 Q
	7180	"RTN","IBT RE2",118,0 )
	7181	.I Y>0 S RC=IBARRAY (Y),IBDEL= $P(RC,U,3) ,IBPRO=$P( RC,U,4),PI EN=$P(RC,U ,1),IBPR=$ P(RC,U,2), IBDELO=$P( RC,U,5)
	7182	"RTN","IBT RE2",119,0 )
	7183	.;
	7184	"RTN","IBT RE2",120,0 )
	7185	.; ask if okay to a dd entry.
	7186	"RTN","IBT RE2",121,0 )
	7187	.S Y=IBDE L D D^DIQ S IBTDTE=Y
	7188	"RTN","IBT RE2",122,0 )
	7189	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Prosthe tics "_IBP RO_" for " _IBDELO,DI R("B")="NO "
	7190	"RTN","IBT RE2",123,0 )
	7191	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	7192	"RTN","IBT RE2",124,0 )
	7193	.S PCOV=$ $PTCOV^IBC NSU3(DFN,I BDEL,"PROS THETICS")
	7194	"RTN","IBT RE2",125,0 )
	7195	.S IBMARK ="" I 'PCO V S IBMARK ="NO PROST HETIC COVE RAGE"
	7196	"RTN","IBT RE2",126,0 )
	7197	.D PRO^IB TUTL1(DFN, IBDEL,PIEN ,IBMARK)
	7198	"RTN","IBT RE2",127,0 )
	7199	.Q
	7200	"RTN","IBT RE2",128,0 )
	7201	;
	7202	"RTN","IBT RE2",129,0 )
	7203	I $G(IBQU IT) G ATQ
	7204	"RTN","IBT RE2",130,0 )
	7205	I $D(IBTA SS) Q ; l eave prema turely if from assig n reason
	7206	"RTN","IBT RE2",131,0 )
	7207	;
	7208	"RTN","IBT RE2",132,0 )
	7209	I $G(IBTR N) N IBTAT RK S IBTAT RK=1 D QE1 ^IBTRE1
	7210	"RTN","IBT RE2",133,0 )
	7211	;
	7212	"RTN","IBT RE2",134,0 )
	7213	D BLD^IBT RE
	7214	"RTN","IBT RE2",135,0 )
	7215	;
	7216	"RTN","IBT RE2",136,0 )
	7217	ATQ Q:$D(I BTASS)
	7218	"RTN","IBT RE2",137,0 )
	7219	I $G(IBQU IT) W !,"N othing Add ed",! D PA USE^VALM1
	7220	"RTN","IBT RE2",138,0 )
	7221	S VALMBCK ="R"
	7222	"RTN","IBT RE2",139,0 )
	7223	Q
	7224	"RTN","IBT RE20")
	7225	0^4^B20245 141^B13573 861
	7226	"RTN","IBT RE20",1,0)
	7227	IBTRE20 ;A LB/AAS - C LAIMS TRAC KING EXECU TABLE HELP ;13-OCT-9 3
	7228	"RTN","IBT RE20",2,0)
	7229	;;2.0;INT EGRATED BI LLING;40 ,91,249,56 8;21-MAR -94;Build 38
	7230	"RTN","IBT RE20",3,0)
	7231	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
	7232	"RTN","IBT RE20",4,0)
	7233	;
	7234	"RTN","IBT RE20",5,0)
	7235	;
	7236	"RTN","IBT RE20",6,0)
	7237	LISTA ; -- list inpa tient admi ssions for patient
	7238	"RTN","IBT RE20",7,0)
	7239	N C,I,J,N ,X,Y,IBX
	7240	"RTN","IBT RE20",8,0)
	7241	K ^TMP("I BM",$J)
	7242	"RTN","IBT RE20",9,0)
	7243	Q:'$D(DFN )
	7244	"RTN","IBT RE20",10,0 )
	7245	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 )) S D=^(0 ),C=C+1,^T MP("IBM",$ J,C)=N_"^" _D
	7246	"RTN","IBT RE20",11,0 )
	7247	;
	7248	"RTN","IBT RE20",12,0 )
	7249	I C=0 W ! !,"No Admi ssions to Choose Fro m." Q
	7250	"RTN","IBT RE20",13,0 )
	7251	;
	7252	"RTN","IBT RE20",14,0 )
	7253	W !!,"CHO OSE FROM:" F IBI=1:1 :10 Q:'$D( ^TMP("IBM" ,$J,IBI)) D WRA
	7254	"RTN","IBT RE20",15,0 )
	7255	K ^TMP("I BM",$J)
	7256	"RTN","IBT RE20",16,0 )
	7257	Q
	7258	"RTN","IBT RE20",17,0 )
	7259	;
	7260	"RTN","IBT RE20",18,0 )
	7261	WRA S IBX= $P(^TMP("I BM",$J,IBI ),"^",2,20 ),Y=+IBX X ^DD("DD")
	7262	"RTN","IBT RE20",19,0 )
	7263	W !," ",Y
	7264	"RTN","IBT RE20",20,0 )
	7265	W ?27,$S( '$D(^DG(40 5.1,+$P(IB X,"^",4),0 )):"",$P(^ (0),"^",7) ]"":$P(^(0 ),"^",7),1 :$E($P(^(0 ),"^",1),1 ,20))
	7266	"RTN","IBT RE20",21,0 )
	7267	;
	7268	"RTN","IBT RE20",22,0 )
	7269	W ?50,"TO : ",$E($P ($G(^DIC(4 2,+$P(IBX, "^",6),0)) ,"^"),1,17 )
	7270	"RTN","IBT RE20",23,0 )
	7271	I $D(^DG( 405.4,+$P( IBX,"^",7) ,0)) W " [ ",$E($P(^( 0),"^",1), 1,10),"]"
	7272	"RTN","IBT RE20",24,0 )
	7273	I $P(IBX, "^",18)=9 W !?23,"FR OM: ",$P( $G(^DIC(4, +$P(IBX,"^ ",5),0))," ^")
	7274	"RTN","IBT RE20",25,0 )
	7275	Q
	7276	"RTN","IBT RE20",26,0 )
	7277	;
	7278	"RTN","IBT RE20",27,0 )
	7279	LISTO ; -- list outp atient app ointments
	7280	"RTN","IBT RE20",28,0 )
	7281	N C,I,J,N ,X,Y,IBX,I BI,IBDT
	7282	"RTN","IBT RE20",29,0 )
	7283	; assumes ^TMP($J," SDAMA301", DFN,IBTDT) defined a nd IBSD(re sult from SD)
	7284	"RTN","IBT RE20",30,0 )
	7285	Q:'$D(DFN )
	7286	"RTN","IBT RE20",31,0 )
	7287	;
	7288	"RTN","IBT RE20",32,0 )
	7289	I IBSD<0 W !!,"Unab le to look -up Outpat ient Visit s to Choos e From." D Q
	7290	"RTN","IBT RE20",33,0 )
	7291	. N IBX F S IBX=$O (^TMP($J," SDAMA301", IBX)) Q:'I BX W !?5, IBX,?10,$G (^(IBX))
	7292	"RTN","IBT RE20",34,0 )
	7293	;
	7294	"RTN","IBT RE20",35,0 )
	7295	I IBSD=0 W !!,"No O utpatient Visits to Choose Fro m." Q
	7296	"RTN","IBT RE20",36,0 )
	7297	;
	7298	"RTN","IBT RE20",37,0 )
	7299	W !!,"CHO OSE FROM:" S IBI=0,I BDT=$G(IBT BDT) F S IBDT=$O(^T MP($J,"SDA MA301",DFN ,IBDT)),IB I=IBI+1 Q: 'IBDT!(IBI >12) D WR O
	7300	"RTN","IBT RE20",38,0 )
	7301	Q
	7302	"RTN","IBT RE20",39,0 )
	7303	;
	7304	"RTN","IBT RE20",40,0 )
	7305	WRO N IBSD D,Y
	7306	"RTN","IBT RE20",41,0 )
	7307	S Y=IBDT X ^DD("DD" ) W !," ",Y
	7308	"RTN","IBT RE20",42,0 )
	7309	S IBSDD=$ G(^TMP($J, "SDAMA301" ,DFN,IBDT) )
	7310	"RTN","IBT RE20",43,0 )
	7311	W ?27,"Cl inic: ",$P ($P(IBSDD, "^",2),";" ,2),?60," Type: ",$E ($P($P(IBS DD,"^",10) ,";",2),1, 12)
	7312	"RTN","IBT RE20",44,0 )
	7313	;
	7314	"RTN","IBT RE20",45,0 )
	7315	S IBSDD=$ P(IBSDD,"^ ",3) I $L( IBSDD),$P( IBSDD,";") '="R" W !, ?10," [Sta tus: ",$P( IBSDD,";", 2),"]"
	7316	"RTN","IBT RE20",46,0 )
	7317	Q
	7318	"RTN","IBT RE20",47,0 )
	7319	;
	7320	"RTN","IBT RE20",48,0 )
	7321	LISTS ; -- list sche duled admi ssions
	7322	"RTN","IBT RE20",49,0 )
	7323	N C,I,J,N ,X,Y,IBX,I BI
	7324	"RTN","IBT RE20",50,0 )
	7325	K ^TMP("I BM",$J)
	7326	"RTN","IBT RE20",51,0 )
	7327	Q:'$D(DFN )
	7328	"RTN","IBT RE20",52,0 )
	7329	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(^ DGS(41.1,+ I,0)) I $P (D,"^",2)' <IBTBDT,$P (D,"^",2)' >IBTEDT S C=C+1,^TMP ("IBM",$J, C)=I_"^"_D
	7330	"RTN","IBT RE20",53,0 )
	7331	;
	7332	"RTN","IBT RE20",54,0 )
	7333	I C=0 W ! !,"No Sche duled Admi ssions to Choose Fro m." Q
	7334	"RTN","IBT RE20",55,0 )
	7335	;
	7336	"RTN","IBT RE20",56,0 )
	7337	W !!,"CHO OSE FROM:" F IBI=1:1 :12 Q:'$D( ^TMP("IBM" ,$J,IBI)) D WRS
	7338	"RTN","IBT RE20",57,0 )
	7339	K ^TMP("I BM",$J)
	7340	"RTN","IBT RE20",58,0 )
	7341	Q
	7342	"RTN","IBT RE20",59,0 )
	7343	;
	7344	"RTN","IBT RE20",60,0 )
	7345	WRS S IBX= $P($G(^TMP ("IBM",$J, IBI)),"^", 2,20),Y=$P (IBX,"^",2 ) X ^DD("D D")
	7346	"RTN","IBT RE20",61,0 )
	7347	W !," ",Y
	7348	"RTN","IBT RE20",62,0 )
	7349	W ?27," S pec: ",$E( $P($G(^DIC (45.7,+$P( IBX,"^",9) ,0)),"^"), 1,25)
	7350	"RTN","IBT RE20",63,0 )
	7351	;
	7352	"RTN","IBT RE20",64,0 )
	7353	W ?58," T o: ",$E($P ($G(^DIC(4 2,+$P(IBX, "^",8),0)) ,"^"),1,16 )
	7354	"RTN","IBT RE20",65,0 )
	7355	Q
	7356	"RTN","IBT RE20",66,0 )
	7357	;
	7358	"RTN","IBT RE20",67,0 )
	7359	FINDS ; -- match a s cheduled a dmission
	7360	"RTN","IBT RE20",68,0 )
	7361	Q:'$D(DFN )
	7362	"RTN","IBT RE20",69,0 )
	7363	Q:'$D(IBT DT)
	7364	"RTN","IBT RE20",70,0 )
	7365	N I,J
	7366	"RTN","IBT RE20",71,0 )
	7367	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: IBTDT=J I $P(IBTDT, ".")=$P(J, ".") S IBT DT=J Q
	7368	"RTN","IBT RE20",72,0 )
	7369	Q
	7370	"RTN","IBT RE20",73,0 )
	7371	;
	7372	"RTN","IBT RE20",74,0 )
	7373	ID ; -- wr ite out id entifier f or entry, called by ^dd(356,0, "id","writ e")
	7374	"RTN","IBT RE20",75,0 )
	7375	N IBOE,IB OE0
	7376	"RTN","IBT RE20",76,0 )
	7377	S IBOE=$P (^(0),"^", 4),IBOE0=$ $SCE^IBSDU (+IBOE) I IBOE,$P(IB OE0,U,4) W ?58,"["_$ E($P($G(^S C(+$P(IBOE 0,U,4),0)) ,U),1,20), "]"
	7378	"RTN","IBT RE20",77,0 )
	7379	Q
	7380	"RTN","IBT RE20",78,0 )
	7381	;
	7382	"RTN","IBT RE20",79,0 )
	7383	PRINT ; pa tch 40, cu stom look up. Input : IBX -- 0th node in file # 356.
	7384	"RTN","IBT RE20",80,0 )
	7385	Q:$D(IBX) [0
	7386	"RTN","IBT RE20",81,0 )
	7387	N NAM,EPI S,EVENT,DI SPL,CLIN
	7388	"RTN","IBT RE20",82,0 )
	7389	S NAM=$E( $P($G(^DPT (+$P(IBX,U ,2),0)),U) ,1,22)
	7390	"RTN","IBT RE20",83,0 )
	7391	S EPIS=$P ($P(IBX,U, 6),".")
	7392	"RTN","IBT RE20",84,0 )
	7393	I EPIS S EPIS=$E(EP IS,4,5)_"- "_$E(EPIS, 6,7)_"-"_$ E(EPIS,2,3 )
	7394	"RTN","IBT RE20",85,0 )
	7395	S EVENT=$ E($P($G(^I BE(356.6,+ $P(IBX,U,1 8),0)),U), 1,5)
	7396	"RTN","IBT RE20",86,0 )
	7397	S DISPL=$ $EXPAND^IB TRE(356,.0 7,$P(IBX,U ,7))
	7398	"RTN","IBT RE20",87,0 )
	7399	S CLIN=+$ $SCE^IBSDU (+$P(IBX," ^",4),4)
	7400	"RTN","IBT RE20",88,0 )
	7401	I CLIN S DISPL="["_ $E($P($G(^ SC(CLIN,0) ),U),1,22) _"]"
	7402	"RTN","IBT RE20",89,0 )
	7403	W ?13,NAM ,?37,EPIS, ?47,EVENT, ?54,DISPL
	7404	"RTN","IBT RE20",90,0 )
	7405	Q
	7406	"RTN","IBT RE20",91,0 )
	7407	;
	7408	"RTN","IBT RE20",92,0 )
	7409	LISTP ; -- list inpa tient admi ssions for patient
	7410	"RTN","IBT RE20",93,0 )
	7411	N I,X,Y,P ,P1,P2,DDT ,DDTO,IBX
	7412	"RTN","IBT RE20",94,0 )
	7413	K ^TMP("I BPRO",$J)
	7414	"RTN","IBT RE20",95,0 )
	7415	Q:'$D(DFN )
	7416	"RTN","IBT RE20",96,0 )
	7417	S (I,C)=0
	7418	"RTN","IBT RE20",97,0 )
	7419	F S I=$O (^RMPR(660 ,"C",DFN,I )) Q:'I I $D(^RMPR( 660,I,0)) S D=^(0) D
	7420	"RTN","IBT RE20",98,0 )
	7421	.S SDT=$P (D,U,12) I SDT<IBTBD T!(SDT>IBT EDT) Q
	7422	"RTN","IBT RE20",99,0 )
	7423	.I $O(^IB T(356,"APR O",I,0)) Q
	7424	"RTN","IBT RE20",100, 0)
	7425	.S C=C+1, ^TMP("IBPR O",$J,C)=I _"^"_D
	7426	"RTN","IBT RE20",101, 0)
	7427	;
	7428	"RTN","IBT RE20",102, 0)
	7429	I C=0 W ! !,"No Pros thetics to Choose Fr om." Q
	7430	"RTN","IBT RE20",103, 0)
	7431	;
	7432	"RTN","IBT RE20",104, 0)
	7433	W !!,"CHO OSE FROM:" F IBI=1:1 :10 Q:'$D( ^TMP("IBPR O",$J,IBI) ) D WRP
	7434	"RTN","IBT RE20",105, 0)
	7435	K ^TMP("I BPRO",$J)
	7436	"RTN","IBT RE20",106, 0)
	7437	Q
	7438	"RTN","IBT RE20",107, 0)
	7439	;
	7440	"RTN","IBT RE20",108, 0)
	7441	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 MPR(661,P, 0),U,1),P2 =$P(^PRC(4 41,P1,0),U ,2)
	7442	"RTN","IBT RE20",109, 0)
	7443	S DDT=$P( IBX,U,13), DDTO=$$FMT E^XLFDT(DD T,"2DZ"),I BARRAY(IBI )=N_U_P_U_ DDT_U_P2_U _DDTO
	7444	"RTN","IBT RE20",110, 0)
	7445	S TP=$P(I BX,U,4),TY PE=$S(TP=" I":"INITIA L ISSUE",T P="R":"REP LACE",TP=" S":"SPARE" ,TP="X":"R EPAIR",1:" RENTAL")
	7446	"RTN","IBT RE20",111, 0)
	7447	W !," ", IBI,?10,$E (P2,1,25), ?40,TYPE,? 58,"DELIVE RED:",DDTO
	7448	"RTN","IBT RE20",112, 0)
	7449	;
	7450	"RTN","IBT RE20",113, 0)
	7451	Q
	7452	"RTN","IBT RKR5")
	7453	0^5^B39018 549^B35067 366
	7454	"RTN","IBT RKR5",1,0)
	7455	IBTRKR5 ;A LB/AAS - C LAIMS TRAC KING - ADD /TRACK PRO STHETICS ; 13-JAN-94
	7456	"RTN","IBT RKR5",2,0)
	7457	;;2.0;INT EGRATED BI LLING;13 ,260,312,3 39,389,474 ,498,568 ;21-MAR-94 ;Build 38
	7458	"RTN","IBT RKR5",3,0)
	7459	;;Per VA Directive 6402, this routine s hould not be modifie d.
	7460	"RTN","IBT RKR5",4,0)
	7461	;
	7462	"RTN","IBT RKR5",5,0)
	7463	% ; -- ent ry point f or nightly backgroun d job
	7464	"RTN","IBT RKR5",6,0)
	7465	N IBTSBDT ,IBTSEDT
	7466	"RTN","IBT RKR5",7,0)
	7467	S IBTSBDT =$$FMADD^X LFDT(DT,$S ($E(DT,6,7 )=10:-730, 1:-20))-.1 ;IB2.0 568
	7468	"RTN","IBT RKR5",8,0)
	7469	S IBTSEDT =$$FMADD^X LFDT(DT,-3 )+.9
	7470	"RTN","IBT RKR5",9,0)
	7471	D EN1
	7472	"RTN","IBT RKR5",10,0 )
	7473	Q
	7474	"RTN","IBT RKR5",11,0 )
	7475	;
	7476	"RTN","IBT RKR5",12,0 )
	7477	EN ; -- en try point to ask dat e range
	7478	"RTN","IBT RKR5",13,0 )
	7479	N IBSWINF O S IBSWIN FO=$$SWSTA T^IBBAPI() ; IB2.0312
	7480	"RTN","IBT RKR5",14,0 )
	7481	N IBBDT,I BEDT,IBTSB DT,IBTSEDT ,IBTALK
	7482	"RTN","IBT RKR5",15,0 )
	7483	S IBTALK= 1
	7484	"RTN","IBT RKR5",16,0 )
	7485	I '$P($G( ^IBE(350.9 ,1,6)),"^" ,4) W !!," I'm sorry, Tracking of Prosthe tics is cu rrently tu rned off." G ENQ
	7486	"RTN","IBT RKR5",17,0 )
	7487	W !!!,"Se lect the D ate Range of Prosthe tics to Ad d to Claim s Tracking .",!
	7488	"RTN","IBT RKR5",18,0 )
	7489	D DATE^IB OUTL
	7490	"RTN","IBT RKR5",19,0 )
	7491	I IBBDT<1 !(IBEDT<1) G ENQ
	7492	"RTN","IBT RKR5",20,0 )
	7493	S IBTSBDT =IBBDT,IBT SEDT=IBEDT
	7494	"RTN","IBT RKR5",21,0 )
	7495	;
	7496	"RTN","IBT RKR5",22,0 )
	7497	; -- chec k selected dates ; IB2.0312
	7498	"RTN","IBT RKR5",23,0 )
	7499	; Do NOT PROCESS on VistA if Start or E nd>=Switch Eff Dt ; CCR-930
	7500	"RTN","IBT RKR5",24,0 )
	7501	I +IBSWIN FO,((IBTSB DT+1)>$P(I BSWINFO,"^ ",2))!((IB TSEDT+1)>$ P(IBSWINFO ,"^",2)) D G EN
	7502	"RTN","IBT RKR5",25,0 )
	7503	.W !!,"T he Begin O R End Date CANNOT be on or aft er the PFS S Effectiv e date"
	7504	"RTN","IBT RKR5",26,0 )
	7505	.W ": ", $$FMTE^XLF DT($P(IBSW INFO,"^",2 ))
	7506	"RTN","IBT RKR5",27,0 )
	7507	;
	7508	"RTN","IBT RKR5",28,0 )
	7509	S IBTRKR= $G(^IBE(35 0.9,1,6))
	7510	"RTN","IBT RKR5",29,0 )
	7511	; start d ate can't be before parameters
	7512	"RTN","IBT RKR5",30,0 )
	7513	I +IBTRKR ,IBTSBDT<+ IBTRKR S I BTSBDT=IBT RKR W !!," Begin date is before Claims Tr acking Sta rt Date, c hanged to ",$$DAT1^I BOUTL(IBTS BDT)
	7514	"RTN","IBT RKR5",31,0 )
	7515	; -- end date into future
	7516	"RTN","IBT RKR5",32,0 )
	7517	I IBTSEDT >$$FMADD^X LFDT(DT,-3 ) W !!,"I' ll automat ically cha nge the en d date to 3 days pri or to the date queue d to run."
	7518	"RTN","IBT RKR5",33,0 )
	7519	;
	7520	"RTN","IBT RKR5",34,0 )
	7521	W !!,"Thi s should b e queued t o run afte r hours"
	7522	"RTN","IBT RKR5",35,0 )
	7523	W !!!,"I' m going to automatic ally queue this off and send y ou a"
	7524	"RTN","IBT RKR5",36,0 )
	7525	W !,"mail message w hen comple te.",!
	7526	"RTN","IBT RKR5",37,0 )
	7527	S ZTIO="" ,ZTRTN="EN 1^IBTRKR5" ,ZTSAVE("I B*")="",ZT DESC="IB - Add Prost hetics to Claims Tra cking"
	7528	"RTN","IBT RKR5",38,0 )
	7529	D ^%ZTLOA D I $G(ZTS K) K ZTSK W !,"Reque st Queued"
	7530	"RTN","IBT RKR5",39,0 )
	7531	ENQ K ZTSK ,ZTIO,ZTSA VE,ZTDESC, ZTRTN
	7532	"RTN","IBT RKR5",40,0 )
	7533	D HOME^%Z IS
	7534	"RTN","IBT RKR5",41,0 )
	7535	Q
	7536	"RTN","IBT RKR5",42,0 )
	7537	;
	7538	"RTN","IBT RKR5",43,0 )
	7539	EN1 ; -- a dd prostet hics to cl aims track ing file
	7540	"RTN","IBT RKR5",44,0 )
	7541	N I,J,X,Y ,IBTRKR,IB DT,DFN,IBD ATA,IBCNT, IBCNT1,IBC NT2,IBDTS, PROCOV
	7542	"RTN","IBT RKR5",45,0 )
	7543	N IBSWINF O S IBSWIN FO=$$SWSTA T^IBBAPI() ; IB2.0312
	7544	"RTN","IBT RKR5",46,0 )
	7545	;
	7546	"RTN","IBT RKR5",47,0 )
	7547	; -- chec k paramete rs
	7548	"RTN","IBT RKR5",48,0 )
	7549	S IBTRKR= $G(^IBE(35 0.9,1,6))
	7550	"RTN","IBT RKR5",49,0 )
	7551	G:'$P(IBT RKR,"^",5) EN1Q ; qu it if prot hetics tra cking off
	7552	"RTN","IBT RKR5",50,0 )
	7553	I +IBTRKR ,IBTSBDT<+ IBTRKR S I BTSBDT=IBT RKR ; star t date can 't be befo re paramet ers
	7554	"RTN","IBT RKR5",51,0 )
	7555	;
	7556	"RTN","IBT RKR5",52,0 )
	7557	; -- user s can queu e into fut ure, make sure dates not after date run
	7558	"RTN","IBT RKR5",53,0 )
	7559	I IBTSEDT >$$FMADD^X LFDT(DT,-3 ) S IBMESS ="(Selecte d end date of "_$$DA T1^IBOUTL( IBTSEDT)_" automatic ally chang ed to "_$$ DAT1^IBOUT L($$FMADD^ XLFDT(DT,- 3))_".)",I BTSEDT=$$F MADD^XLFDT (DT,-3)
	7560	"RTN","IBT RKR5",54,0 )
	7561	;
	7562	"RTN","IBT RKR5",55,0 )
	7563	;S IBPRTY P=$O(^IBE( 356.6,"AC" ,3,0)) ; t his is the event typ e pointer for prosth etics
	7564	"RTN","IBT RKR5",56,0 )
	7565	;
	7566	"RTN","IBT RKR5",57,0 )
	7567	; -- cnt= total cou nt, cnt1=c ount added nsc, cnt2 =count of pending
	7568	"RTN","IBT RKR5",58,0 )
	7569	S (IBCNT, IBCNT1,IBC NT2)=0
	7570	"RTN","IBT RKR5",59,0 )
	7571	S (IBDTS, IBDT)=IBTS BDT-.0001
	7572	"RTN","IBT RKR5",60,0 )
	7573	;
	7574	"RTN","IBT RKR5",61,0 )
	7575	; loop tw ice, once for shipmn et date (n ew search) , and once for
	7576	"RTN","IBT RKR5",62,0 )
	7577	; deliver y date (ol d search) for backwa rd compati bility.
	7578	"RTN","IBT RKR5",63,0 )
	7579	F S IBDT =$O(^RMPR( 660,"AF",I BDT)) Q:'I BDT!(IBDT> IBTSEDT) D
	7580	"RTN","IBT RKR5",64,0 )
	7581	.; Do NOT PROCES S on VistA if IBDT>= Switch Eff Date ; CCR-930
	7582	"RTN","IBT RKR5",65,0 )
	7583	.I +IB SWINFO,(IB DT+1)>$P(I BSWINFO,"^ ",2) Q ; IB2.0312
	7584	"RTN","IBT RKR5",66,0 )
	7585	.S IBD A=0 F S I BDA=$O(^RM PR(660,"AF ",IBDT,IBD A)) Q:'IBD A D PRCHK
	7586	"RTN","IBT RKR5",67,0 )
	7587	;
	7588	"RTN","IBT RKR5",68,0 )
	7589	; reset d ate and do old check
	7590	"RTN","IBT RKR5",69,0 )
	7591	S IBDT=IB DTS
	7592	"RTN","IBT RKR5",70,0 )
	7593	F S IBDT =$O(^RMPR( 660,"CT",I BDT)) Q:'I BDT!(IBDT> IBTSEDT) D
	7594	"RTN","IBT RKR5",71,0 )
	7595	.; Do NOT PROCES S on VistA if IBDT>= Switch Eff Date ; CCR-930
	7596	"RTN","IBT RKR5",72,0 )
	7597	.I +IB SWINFO,(IB DT+1)>$P(I BSWINFO,"^ ",2) Q ; IB2.0312
	7598	"RTN","IBT RKR5",73,0 )
	7599	.S IBD A="" F S IBDA=$O(^R MPR(660,"C T",IBDT,IB DA)) Q:'IB DA D PRCH K
	7600	"RTN","IBT RKR5",74,0 )
	7601	;
	7602	"RTN","IBT RKR5",75,0 )
	7603	I $G(IBTA LK) D BULL ;^IBTRKR5 1
	7604	"RTN","IBT RKR5",76,0 )
	7605	EN1Q I $D( ZTQUEUED) S ZTREQ="@ "
	7606	"RTN","IBT RKR5",77,0 )
	7607	Q
	7608	"RTN","IBT RKR5",78,0 )
	7609	;
	7610	"RTN","IBT RKR5",79,0 )
	7611	PRCHK ; -- check and add item
	7612	"RTN","IBT RKR5",80,0 )
	7613	N IBE,IBP ,IBDX,IBRM ARK,IBARR, IBT,IBINS
	7614	"RTN","IBT RKR5",81,0 )
	7615	S IBCNT=I BCNT+1,IBR MARK=""
	7616	"RTN","IBT RKR5",82,0 )
	7617	I '$D(ZTQ UEUED),($G (IBTALK)) W "."
	7618	"RTN","IBT RKR5",83,0 )
	7619	;
	7620	"RTN","IBT RKR5",84,0 )
	7621	S IBDATA= $G(^RMPR(6 60,+IBDA,0 )) Q:IBDAT A=""
	7622	"RTN","IBT RKR5",85,0 )
	7623	S DFN=$P( IBDATA,"^" ,2) Q:'DFN
	7624	"RTN","IBT RKR5",86,0 )
	7625	; quit if non billa ble PSAS H CPCS code is found
	7626	"RTN","IBT RKR5",87,0 )
	7627	S SCDATA= $G(^RMPR(6 60,+IBDA," BA1"))
	7628	"RTN","IBT RKR5",88,0 )
	7629	I $$IBPHP (IBDA) Q
	7630	"RTN","IBT RKR5",89,0 )
	7631	D CL^SDCO 21(DFN,IBD T,"",.IBAR R)
	7632	"RTN","IBT RKR5",90,0 )
	7633	;
	7634	"RTN","IBT RKR5",91,0 )
	7635	; -- chec ks copied from rmprb il v2.0 /f eb 2, 1994
	7636	"RTN","IBT RKR5",92,0 )
	7637	Q:'$D(^RM PR(660,+IB DA,"AM"))
	7638	"RTN","IBT RKR5",93,0 )
	7639	Q:$P(^RMP R(660,+IBD A,0),U,9)= ""!($P(^(0 ),U,12)="" )!($P(^(0) ,U,14)="V" )!($P(^(0) ,U,2)="")! ($P(^(0),U ,15)="*")
	7640	"RTN","IBT RKR5",94,0 )
	7641	;Q:($P(^R MPR(660,+I BDA,"AM"), U,3)=2)!($ P(^("AM"), U,3)=3)
	7642	"RTN","IBT RKR5",95,0 )
	7643	;
	7644	"RTN","IBT RKR5",96,0 )
	7645	;
	7646	"RTN","IBT RKR5",97,0 )
	7647	I $O(^IBT (356,"APRO ",IBDA,0)) G PRCHKQ ; already in claims tracking
	7648	"RTN","IBT RKR5",98,0 )
	7649	;
	7650	"RTN","IBT RKR5",99,0 )
	7651	; -- see if trackin g only ins ured and p t is insur ed
	7652	"RTN","IBT RKR5",100, 0)
	7653	I $P(IBTR KR,"^",5)= 1,'$$INSUR ED^IBCNS1( DFN,IBDT) G PRCHKQ ; patient n ot insured
	7654	"RTN","IBT RKR5",101, 0)
	7655	;
	7656	"RTN","IBT RKR5",102, 0)
	7657	; -- if c lasificati ons requir ed, check exemptions
	7658	"RTN","IBT RKR5",103, 0)
	7659	S SCR=0
	7660	"RTN","IBT RKR5",104, 0)
	7661	I '$D(IBA RR) G CLQ
	7662	"RTN","IBT RKR5",105, 0)
	7663	;IB2.05 68
	7664	"RTN","IBT RKR5",106, 0)
	7665	N IBSC
	7666	"RTN","IBT RKR5",107, 0)
	7667	F IBP=1:1 :4 S IBDX( IBP)=$G(^R MPR(660,+I BDA,"BA"_I BP)) D
	7668	"RTN","IBT RKR5",108, 0)
	7669	.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
	7670	"RTN","IBT RKR5",109, 0)
	7671	I 'SCR S IBRMARK="N EEDS SC DE TERMINATIO N" G CLQ ; no ICD no de in RMPR , use old method of determinin g status
	7672	"RTN","IBT RKR5",110, 0)
	7673	S IBRMARK =""
	7674	"RTN","IBT RKR5",111, 0)
	7675	S IBE=0 F S IBE=$O (IBARR(IBE )) Q:'IBE D Q:($L( $G(IBRMARK )))
	7676	"RTN","IBT RKR5",112, 0)
	7677	.F IBP=1: 1:4 Q:$L($ G(IBRMARK) ) D
	7678	"RTN","IBT RKR5",113, 0)
	7679	..S (SUB, REC)="" I IBSC(IBP) S SUB="CL" _IBSC(IBP) ,REC=$T(@S UB)
	7680	"RTN","IBT RKR5",114, 0)
	7681	..S IBRMA RK=$S(REC' ="":$P(REC ,";",3),1: "NEEDS SC DETERMINAT ION")
	7682	"RTN","IBT RKR5",115, 0)
	7683	;
	7684	"RTN","IBT RKR5",116, 0)
	7685	;
	7686	"RTN","IBT RKR5",117, 0)
	7687	CLQ ; -- o k to add t o tracking module
	7688	"RTN","IBT RKR5",118, 0)
	7689	S PROCOV= 0,SCR=+$G( SCR)
	7690	"RTN","IBT RKR5",119, 0)
	7691	S PROCOV= +$$PTCOV^I BCNSU3(DFN ,IBDT,"PRO STHETICS")
	7692	"RTN","IBT RKR5",120, 0)
	7693	I 'PROCOV ,IBRMARK=" NEEDS SC D ETERMINATI ON" S IBRM ARK="NO PR OSTHETIC C OVERAGE"
	7694	"RTN","IBT RKR5",121, 0)
	7695	I 'PROCOV ,IBRMARK=" " S IBRMAR K="NO PROS THETIC COV ERAGE"
	7696	"RTN","IBT RKR5",122, 0)
	7697	D PRO^IBT UTL1(DFN,I BDT,IBDA,$ G(IBRMARK) ) I '$D(ZT QUEUED),$G (IBTALK) W "+"
	7698	"RTN","IBT RKR5",123, 0)
	7699	I SCR=1 S IBCNT2=IB CNT2+1
	7700	"RTN","IBT RKR5",124, 0)
	7701	I SCR=0 S IBCNT1=IB CNT1+1
	7702	"RTN","IBT RKR5",125, 0)
	7703	K VAEL,VA ,IBDATA,DF N,X,Y
	7704	"RTN","IBT RKR5",126, 0)
	7705	PRCHKQ Q
	7706	"RTN","IBT RKR5",127, 0)
	7707	;
	7708	"RTN","IBT RKR5",128, 0)
	7709	IBPHP(IBDA ) ; non bi llable PSA S HCPCS co des
	7710	"RTN","IBT RKR5",129, 0)
	7711	; input-p atient ite m in #660
	7712	"RTN","IBT RKR5",130, 0)
	7713	; output- value if t he code wi th the fir st 2 chars in the st ring is fo und
	7714	"RTN","IBT RKR5",131, 0)
	7715	N IBPSAS, IBPIN S IB PIN=""
	7716	"RTN","IBT RKR5",132, 0)
	7717	S IBPSAS= ",BA,DI,DL ,EC,EV,FE, HI,HN,HS,N R,RE,SB,SI ,TH,TM,TR, VA,"
	7718	"RTN","IBT RKR5",133, 0)
	7719	; return the pointe r^descript ion^the co de (#661.1 ,.01)
	7720	"RTN","IBT RKR5",134, 0)
	7721	S IBPIN=$ $PIN^IBATU TL(+IBDA)
	7722	"RTN","IBT RKR5",135, 0)
	7723	S IBPIN=$ P(IBPIN,U, 3)
	7724	"RTN","IBT RKR5",136, 0)
	7725	S IBPIN=$ F(IBPSAS," ,"_$E(IBPI N,1,2)_"," )
	7726	"RTN","IBT RKR5",137, 0)
	7727	Q IBPIN
	7728	"RTN","IBT RKR5",138, 0)
	7729	;
	7730	"RTN","IBT RKR5",139, 0)
	7731	BULL ; -- send bulle tin
	7732	"RTN","IBT RKR5",140, 0)
	7733	;
	7734	"RTN","IBT RKR5",141, 0)
	7735	S XMSUB=" Prosthetic Items add ed to Clai ms Trackin g Complete "
	7736	"RTN","IBT RKR5",142, 0)
	7737	S IBT(1)= "The proce ss to auto matically add Prosth etic Items has succe ssfully co mpleted."
	7738	"RTN","IBT RKR5",143, 0)
	7739	S IBT(1.1 )=""
	7740	"RTN","IBT RKR5",144, 0)
	7741	S IBT(2)= " Start D ate: "_$$D AT1^IBOUTL (IBTSBDT)
	7742	"RTN","IBT RKR5",145, 0)
	7743	S IBT(3)= " End D ate: "_$$D AT1^IBOUTL (IBTSEDT)
	7744	"RTN","IBT RKR5",146, 0)
	7745	I $D(IBME SS) S IBT( 3.1)=IBMES S
	7746	"RTN","IBT RKR5",147, 0)
	7747	S IBT(4)= ""
	7748	"RTN","IBT RKR5",148, 0)
	7749	S IBT(5)= " Total Pr osthetics Items chec ked: "_$G( IBCNT)
	7750	"RTN","IBT RKR5",149, 0)
	7751	S IBT(6)= "Total NSC Prostheti c Items Ad ded: "_$G( IBCNT1)
	7752	"RTN","IBT RKR5",150, 0)
	7753	S IBT(7)= " Total SC Prostheti c Items Ad ded: "_$G( IBCNT2)
	7754	"RTN","IBT RKR5",151, 0)
	7755	S IBT(8)= ""
	7756	"RTN","IBT RKR5",152, 0)
	7757	S IBT(9)= "*The item s added as SC requir e determin ation and editing to be billed "
	7758	"RTN","IBT RKR5",153, 0)
	7759	D SEND^IB TRKR31
	7760	"RTN","IBT RKR5",154, 0)
	7761	BULLQ Q
	7762	"RTN","IBT RKR5",155, 0)
	7763	;
	7764	"RTN","IBT RKR5",156, 0)
	7765	CLTXT ; cl assificati on text fo r reason n ot billabl e
	7766	"RTN","IBT RKR5",157, 0)
	7767	CL2 ;;AGEN T ORANGE
	7768	"RTN","IBT RKR5",158, 0)
	7769	CL3 ;;IONI ZING RADIA TION
	7770	"RTN","IBT RKR5",159, 0)
	7771	CL4 ;;SC T REATMENT
	7772	"RTN","IBT RKR5",160, 0)
	7773	CL5 ;;SOUT HWEST ASIA
	7774	"RTN","IBT RKR5",161, 0)
	7775	CL6 ;;MILI TARY SEXUA L TRAUMA
	7776	"RTN","IBT RKR5",162, 0)
	7777	CL7 ;;HEAD /NECK CANC ER
	7778	"RTN","IBT RKR5",163, 0)
	7779	CL8 ;;COMB AT VETERAN
	7780	"RTN","IBY 568PO")
	7781	0^^B766103 84^n/a
	7782	"RTN","IBY 568PO",1,0 )
	7783	IBY568PO ; ALB/BAA - Post insta ll routine for patch 568; 5-AU G-16
	7784	"RTN","IBY 568PO",2,0 )
	7785	;;2.0;INT EGRATED BI LLING;56 8;21-MAR -94;Build 38
	7786	"RTN","IBY 568PO",3,0 )
	7787	;;Per VA Directive 6402, this routine s hould not be modifie d.
	7788	"RTN","IBY 568PO",4,0 )
	7789	;
	7790	"RTN","IBY 568PO",5,0 )
	7791	Q
	7792	"RTN","IBY 568PO",6,0 )
	7793	; This po st-install routine w ill create a new sec urity key
	7794	"RTN","IBY 568PO",7,0 )
	7795	; called IB PARAMET ER EDIT.
	7796	"RTN","IBY 568PO",8,0 )
	7797	; It will be added to two men u options/
	7798	"RTN","IBY 568PO",9,0 )
	7799	;
	7800	"RTN","IBY 568PO",10, 0)
	7801	; The new IB PARAME TER EDIT k ey will be used to l ock
	7802	"RTN","IBY 568PO",11, 0)
	7803	;
	7804	"RTN","IBY 568PO",12, 0)
	7805	; IB T EDIT TRA CKING PARA METERS
	7806	"RTN","IBY 568PO",13, 0)
	7807	; IB J MCCR SIT E PARAMETE RS
	7808	"RTN","IBY 568PO",14, 0)
	7809	;
	7810	"RTN","IBY 568PO",15, 0)
	7811	; This ro utine will add PROST HETICS to Plan Cover age Limita tions file
	7812	"RTN","IBY 568PO",16, 0)
	7813	;
	7814	"RTN","IBY 568PO",17, 0)
	7815	; This ro utine will add three new rate types and the rate s cheduals f or each.
	7816	"RTN","IBY 568PO",18, 0)
	7817	;
	7818	"RTN","IBY 568PO",19, 0)
	7819	; HU MANITARIAN REIMB. IN S.
	7820	"RTN","IBY 568PO",20, 0)
	7821	; IN ELIGIBLE R EIMB. INS.
	7822	"RTN","IBY 568PO",21, 0)
	7823	; DE NTAL REIMB . INS
	7824	"RTN","IBY 568PO",22, 0)
	7825	;
	7826	"RTN","IBY 568PO",23, 0)
	7827	;
	7828	"RTN","IBY 568PO",24, 0)
	7829	START ; CA LL SECTION S
	7830	"RTN","IBY 568PO",25, 0)
	7831	D MES^XPD UTL(" Sta rting post -install f or IB2.0 528")
	7832	"RTN","IBY 568PO",26, 0)
	7833	D RIDER
	7834	"RTN","IBY 568PO",27, 0)
	7835	D PLAN
	7836	"RTN","IBY 568PO",28, 0)
	7837	D ADDRT
	7838	"RTN","IBY 568PO",29, 0)
	7839	D ADDRS ; add Rate Schedules (363)
	7840	"RTN","IBY 568PO",30, 0)
	7841	D NEWIBER
	7842	"RTN","IBY 568PO",31, 0)
	7843	; Complet ion messag e
	7844	"RTN","IBY 568PO",32, 0)
	7845	D MES^XPD UTL(" Fin ished post -install f or IB2.0 568")
	7846	"RTN","IBY 568PO",33, 0)
	7847	Q
	7848	"RTN","IBY 568PO",34, 0)
	7849	;
	7850	"RTN","IBY 568PO",35, 0)
	7851	RIDER ; ad d Prostihe tic Insura nce Rider (355.6)
	7852	"RTN","IBY 568PO",36, 0)
	7853	N IBNAME, DD,DO,DLAY GO,DIC,X,Y ,IBDA,IBAR R,IBX
	7854	"RTN","IBY 568PO",37, 0)
	7855	D MES^XPD UTL(" ")
	7856	"RTN","IBY 568PO",38, 0)
	7857	;
	7858	"RTN","IBY 568PO",39, 0)
	7859	S IBNAME= "PROSTHETI CS COVERAG E"
	7860	"RTN","IBY 568PO",40, 0)
	7861	I $O(^IBE (355.6,"B" ,IBNAME,0) ) S IBX=" - "_IBNA ME_" Insur ance Rider (355.6) a lready exi sts, no ch ange" D ME S^XPDUTL(I BX) Q
	7862	"RTN","IBY 568PO",41, 0)
	7863	;
	7864	"RTN","IBY 568PO",42, 0)
	7865	K DD,DO S DLAYGO=35 5.6,DIC="^ IBE(355.6, ",DIC(0)=" L",X=IBNAM E D FILE^D ICN K DIC I Y<1 K X, Y Q
	7866	"RTN","IBY 568PO",43, 0)
	7867	S IBDA=+Y
	7868	"RTN","IBY 568PO",44, 0)
	7869	;
	7870	"RTN","IBY 568PO",45, 0)
	7871	S IBX=" * "_IBNAM E_" Insura nce Rider (355.6) ad ded" D MES ^XPDUTL(IB X)
	7872	"RTN","IBY 568PO",46, 0)
	7873	Q
	7874	"RTN","IBY 568PO",47, 0)
	7875	;
	7876	"RTN","IBY 568PO",48, 0)
	7877	PLAN ; add Prostheti cs to Plan Coverage Limitation s
	7878	"RTN","IBY 568PO",49, 0)
	7879	D MES^XPD UTL("Addin g PROSTHET ICS to Pla n Coverage Limitatio ns file... ")
	7880	"RTN","IBY 568PO",50, 0)
	7881	N IBA,IBN AME,IBRIDE R,IBRDA,IB X,DD,DO,DL AYGO,DIC,X ,Y,IBDA,DI E,DA,DR,IB FILE
	7882	"RTN","IBY 568PO",51, 0)
	7883	S IBFILE= " Plan Lim itation Ca tegory (#3 55.31) "
	7884	"RTN","IBY 568PO",52, 0)
	7885	;
	7886	"RTN","IBY 568PO",53, 0)
	7887	S IBNAME= "PROSTHETI CS",IBRIDE R="PROSTHE TICS COVER AGE"
	7888	"RTN","IBY 568PO",54, 0)
	7889	S IBRDA=$ O(^IBE(355 .6,"B",IBR IDER,0)) I 'IBRDA S IBX=" - "_IBNAME_I BFILE_"Not Added, Ri der Missin g" D MES^X PDUTL(IBX) Q
	7890	"RTN","IBY 568PO",55, 0)
	7891	;
	7892	"RTN","IBY 568PO",56, 0)
	7893	I $O(^IBE (355.31,"B ",IBNAME,0 )) S IBA=" >> "_IBNAM E_IBFILE_" exists, no change" D MES^XPDUT L(IBA) Q
	7894	"RTN","IBY 568PO",57, 0)
	7895	;
	7896	"RTN","IBY 568PO",58, 0)
	7897	K DD,DO S DLAYGO=35 5.31,DIC=" ^IBE(355.3 1,",DIC(0) ="L",X=IBN AME D FILE ^DICN K DI C S IBDA=+ Y I Y<1 K X,Y Q
	7898	"RTN","IBY 568PO",59, 0)
	7899	;
	7900	"RTN","IBY 568PO",60, 0)
	7901	S DIE="^I BE(355.31, ",DA=+IBDA ,DR=".02// /Prostheti cs coverag e" D ^DIE K DIE,DA,D R,X,Y
	7902	"RTN","IBY 568PO",61, 0)
	7903	;
	7904	"RTN","IBY 568PO",62, 0)
	7905	D MES^XPD UTL("Prost hetics Pla n added... ..")
	7906	"RTN","IBY 568PO",63, 0)
	7907	;
	7908	"RTN","IBY 568PO",64, 0)
	7909	Q
	7910	"RTN","IBY 568PO",65, 0)
	7911	;
	7912	"RTN","IBY 568PO",66, 0)
	7913	ADDRT ; Ad d Rate Typ es (399.3)
	7914	"RTN","IBY 568PO",67, 0)
	7915	N IBA,IBC NT,FLG,IBI ,REC,IBAR, DD,DO,DLAY GO,DIC,DIE ,DA,DR,X,Y ,RN
	7916	"RTN","IBY 568PO",68, 0)
	7917	S IBCNT=0
	7918	"RTN","IBY 568PO",69, 0)
	7919	;
	7920	"RTN","IBY 568PO",70, 0)
	7921	D MES^XPD UTL(" -> Adding new Rate T ype entrie s to file 399.3 ..." )
	7922	"RTN","IBY 568PO",71, 0)
	7923	;
	7924	"RTN","IBY 568PO",72, 0)
	7925	S C=";",( FLG,IBCNT) =0
	7926	"RTN","IBY 568PO",73, 0)
	7927	F RTNUM=1 9,20,21 D
	7928	"RTN","IBY 568PO",74, 0)
	7929	. S IBI=" RT"_RTNUM
	7930	"RTN","IBY 568PO",75, 0)
	7931	. S REC=$ P($T(@IBI) ,";",3,99)
	7932	"RTN","IBY 568PO",76, 0)
	7933	. S RTNAM =$P(REC,C, 1)
	7934	"RTN","IBY 568PO",77, 0)
	7935	. ; do a lookup and quit if e xists.
	7936	"RTN","IBY 568PO",78, 0)
	7937	. S DONE= $$NEW(RTNA M,RTNUM,RE C) Q:DONE= -1
	7938	"RTN","IBY 568PO",79, 0)
	7939	. ;
	7940	"RTN","IBY 568PO",80, 0)
	7941	. D MES^X PDUTL("New Rate Type "_RTNAM_" added") S FLG=1,IBC NT=IBCNT+1
	7942	"RTN","IBY 568PO",81, 0)
	7943	;
	7944	"RTN","IBY 568PO",82, 0)
	7945	RTQ I FLG S IBA(1)=" >> " _IBCNT_" R ate Types added (399 .3)..." D MES^XPDUTL (.IBA)
	7946	"RTN","IBY 568PO",83, 0)
	7947	Q
	7948	"RTN","IBY 568PO",84, 0)
	7949	;
	7950	"RTN","IBY 568PO",85, 0)
	7951	NEW(NAM,NU M,REC) ; c reate new rate type
	7952	"RTN","IBY 568PO",86, 0)
	7953	; see if entry exis ts
	7954	"RTN","IBY 568PO",87, 0)
	7955	N DD,DO,D LAYGO,DIC, DIE,DA,DR, X,Y,RN
	7956	"RTN","IBY 568PO",88, 0)
	7957	S X=NAM
	7958	"RTN","IBY 568PO",89, 0)
	7959	S DIC="^D GCR(399.3, " D ^DIC S OUT=+Y
	7960	"RTN","IBY 568PO",90, 0)
	7961	I OUT>0 D MES^XPDUT L(" "_NAM _" already exists.") Q OUT
	7962	"RTN","IBY 568PO",91, 0)
	7963	; add ent ry
	7964	"RTN","IBY 568PO",92, 0)
	7965	K DO
	7966	"RTN","IBY 568PO",93, 0)
	7967	S DIC(0)= "L",DLAYGO =399.3,DR= "",X=NAM,D A=NUM
	7968	"RTN","IBY 568PO",94, 0)
	7969	D FILE^DI CN I +Y=-1 D MES^XPD UTL(" "_NAM_" failed to add!") Q +Y
	7970	"RTN","IBY 568PO",95, 0)
	7971	S RN=+Y
	7972	"RTN","IBY 568PO",96, 0)
	7973	S DA=RN
	7974	"RTN","IBY 568PO",97, 0)
	7975	S DR=".02 ///"_$P(RE C,C,2)_";. 03///0"_"; .04///"_$P (REC,C,4)_ ";.05///"_ $P(REC,C,5 )_";.06/// "_$P(REC,C ,6)_";.07/ //"_$P(REC ,C,7)
	7976	"RTN","IBY 568PO",98, 0)
	7977	S DIE="^D GCR(399.3, "
	7978	"RTN","IBY 568PO",99, 0)
	7979	D ^DIE
	7980	"RTN","IBY 568PO",100 ,0)
	7981	S DIC(0)= "L",DLAYGO =399.3,DR= "",DA=RN
	7982	"RTN","IBY 568PO",101 ,0)
	7983	S DR=".08 ///"_$P(RE C,C,8)_";. 09///1;.1/ //"_$P(REC ,C,10)_";. 11///"_$P( REC,C,11)_ ";580950.1 ///1"
	7984	"RTN","IBY 568PO",102 ,0)
	7985	S DIE="^D GCR(399.3, "
	7986	"RTN","IBY 568PO",103 ,0)
	7987	D ^DIE
	7988	"RTN","IBY 568PO",104 ,0)
	7989	Q 1
	7990	"RTN","IBY 568PO",105 ,0)
	7991	;
	7992	"RTN","IBY 568PO",106 ,0)
	7993	ADDRS ; Ad d Rate Sch edules (36 3) for EME RGENCY/HUM ANITARIAN REIMB. & I NELIGIBLE HOSP. REIM B.
	7994	"RTN","IBY 568PO",107 ,0)
	7995	D MES^XPD UTL(" -> Adding new Rate S chedules t o file 363 ...")
	7996	"RTN","IBY 568PO",108 ,0)
	7997	N IBA,IBC NT,IBI,IBL N,IBFN,IBR T,IBBS,IBC NTCS,IBJ,I BLNCS,IBCS ,IBCSFN,IB VDT,DD,DO, DLAYGO,DIC ,DIE,DA,DR ,X,Y
	7998	"RTN","IBY 568PO",109 ,0)
	7999	S IBCNT=0
	8000	"RTN","IBY 568PO",110 ,0)
	8001	;
	8002	"RTN","IBY 568PO",111 ,0)
	8003	F IBI=1:1 S IBLN=$P ($T(RSF+IB I),";;",2) Q:IBLN="E ND" I $E( IBLN)?1A D
	8004	"RTN","IBY 568PO",112 ,0)
	8005	. ;Check for proble ms
	8006	"RTN","IBY 568PO",113 ,0)
	8007	. I $O(^I BE(363,"B" ,$P(IBLN,U ,1),0)) Q ;Already exists
	8008	"RTN","IBY 568PO",114 ,0)
	8009	. S IBBS= $P(IBLN,U, 4) I IBBS' ="" S IBBS =$$MCCRUTL (IBBS,13) Q:'IBBS ; Billable s ervice inv alid
	8010	"RTN","IBY 568PO",115 ,0)
	8011	. S IBRN= $P(IBLN,U, 1)
	8012	"RTN","IBY 568PO",116 ,0)
	8013	. S IBRT= $P(IBLN,U, 2),IBRT=$O (^DGCR(399 .3,"B",IBR T,0)) D Q :'IBRT
	8014	"RTN","IBY 568PO",117 ,0)
	8015	.. I 'IBR T D MSG(" Rate Ty pe "_$P(IB LN,U,2)_" not define d, RS "_$P (IBLN,U,1) _" not cre ated")
	8016	"RTN","IBY 568PO",118 ,0)
	8017	.. I +$P( $G(^DGCR(3 99.3,+IBRT ,0)),U,3) S IBRT=0 D MSG(" **** Rate Type "_$P(IBLN, U,2)_" not Active, R S "_$P(IBL N,U,1)_" n ot created ")
	8018	"RTN","IBY 568PO",119 ,0)
	8019	. ;No pro blems foun d, so crea te entry
	8020	"RTN","IBY 568PO",120 ,0)
	8021	. I IBRN= "HR-INPT" S IBNAME=" HMN-INPT"
	8022	"RTN","IBY 568PO",121 ,0)
	8023	. I IBRN= "HR-OPT" S IBNAME="H MN-OPT"
	8024	"RTN","IBY 568PO",122 ,0)
	8025	. I IBRN= "HR-RX" S IBNAME="HM N-RX"
	8026	"RTN","IBY 568PO",123 ,0)
	8027	. I IBRN= "HR-OPT DE NTAL" S IB NAME="DNTL -OPT DENTA L"
	8028	"RTN","IBY 568PO",124 ,0)
	8029	. I IBRN= "IR-INPT" S IBNAME=" INELIG-INP T"
	8030	"RTN","IBY 568PO",125 ,0)
	8031	. I IBRN= "IR-OPT" S IBNAME="I NELIG-OPT"
	8032	"RTN","IBY 568PO",126 ,0)
	8033	. I IBRN= "IR-RX" S IBNAME="IN ELIG-RX"
	8034	"RTN","IBY 568PO",127 ,0)
	8035	. N IBX,I BRSFN,IBRS 0 S IBRSFN =0
	8036	"RTN","IBY 568PO",128 ,0)
	8037	. F S IB RSFN=$O(^I BE(363,"B" ,IBNAME,IB RSFN)) Q: 'IBRSFN D
	8038	"RTN","IBY 568PO",129 ,0)
	8039	.. S IBRS 0=$G(^IBE( 363,IBRSFN ,0)),IBRS1 =$G(^IBE(3 63,IBNAME, 1))
	8040	"RTN","IBY 568PO",130 ,0)
	8041	.. I $P(I BRS0,U,1)= IBNAME D
	8042	"RTN","IBY 568PO",131 ,0)
	8043	... S IBV DT=$$FMTE^ XLFDT($P(I BRS0,U,5), "2DZ"),IND T=$$FMTE^X LFDT($P(IB RS0,U,6)," 2DZ")
	8044	"RTN","IBY 568PO",132 ,0)
	8045	... I IBN AME["RX" S IBDISP=$P (IBRS1,U,1 ),IBADMIN= $P(IBRS1,U ,2),IBADJS T=$G(^IBE( 363,IBNAME ,10))
	8046	"RTN","IBY 568PO",133 ,0)
	8047	... K DD, DO
	8048	"RTN","IBY 568PO",134 ,0)
	8049	... S DLA YGO=363,DI C="^IBE(36 3,",DIC(0) ="L",X=$P( IBLN,U,1)
	8050	"RTN","IBY 568PO",135 ,0)
	8051	... D FIL E^DICN K D IC,DINUM,D LAYGO
	8052	"RTN","IBY 568PO",136 ,0)
	8053	... I Y<1 K X,Y Q
	8054	"RTN","IBY 568PO",137 ,0)
	8055	... S IBF N=+Y,IBCNT =IBCNT+1
	8056	"RTN","IBY 568PO",138 ,0)
	8057	... S DR= ".02///"_I BRT_";.03/ //"_$P(IBL N,U,3) I + IBBS S DR= DR_";.04// /"_IBBS
	8058	"RTN","IBY 568PO",139 ,0)
	8059	... S DR= DR_";.05// /^S X=IBVD T;.06///^S X=INDT"
	8060	"RTN","IBY 568PO",140 ,0)
	8061	... I IBR N["RX",IBD ISP]"" S D R=DR_";1.0 1///"_IBDI SP
	8062	"RTN","IBY 568PO",141 ,0)
	8063	... I IBR N["RX",IBA DMIN]"" S DR=DR_";1. 02///"_IBA DMIN
	8064	"RTN","IBY 568PO",142 ,0)
	8065	... I IBR N["RX",IBA DJST]"" S DR=DR_";10 ///"_IBADJ ST
	8066	"RTN","IBY 568PO",143 ,0)
	8067	... S DIE ="^IBE(363 ,",DA=IBFN D ^DIE K DIE,DA,DR, X,Y
	8068	"RTN","IBY 568PO",144 ,0)
	8069	... S IBC NTCS=0
	8070	"RTN","IBY 568PO",145 ,0)
	8071	... ; add all Reaso nable Char ges Charge Sets
	8072	"RTN","IBY 568PO",146 ,0)
	8073	... S IBC NTCS=$$RSC S(IBFN,IBV DT,IBRSFN)
	8074	"RTN","IBY 568PO",147 ,0)
	8075	... D MES ^XPDUTL(" Tot al Charge Set"_$S(IB CNTCS=1:" ",1:"s ")_ IBCNTCS_" added to t he rate sc hedule.")
	8076	"RTN","IBY 568PO",148 ,0)
	8077	D MES^XPD UTL(" Rate Sc hedules co mpleted.")
	8078	"RTN","IBY 568PO",149 ,0)
	8079	Q ;ADDRS
	8080	"RTN","IBY 568PO",150 ,0)
	8081	;
	8082	"RTN","IBY 568PO",151 ,0)
	8083	;
	8084	"RTN","IBY 568PO",152 ,0)
	8085	RSCS(IBFN, IBVDT,IBCO PY) ; add existing C harge Sets to HR & I R
	8086	"RTN","IBY 568PO",153 ,0)
	8087	; copy th e Charge S ets from t he corresp onding RI RS (v2)
	8088	"RTN","IBY 568PO",154 ,0)
	8089	N IBCNT,I BNRS,IBRSN M,IBTY,IBC S,IBXFN,IB CSFN,IBCSN M,IBCSAA,I BNAME
	8090	"RTN","IBY 568PO",155 ,0)
	8091	S IBCNT=0
	8092	"RTN","IBY 568PO",156 ,0)
	8093	S IBNRS=$ G(^IBE(363 ,+$G(IBFN) ,0)),IBRSN M=$P(IBNRS ,"^",1)
	8094	"RTN","IBY 568PO",157 ,0)
	8095	S IBTY=$P (IBNRS,"^" ,3)
	8096	"RTN","IBY 568PO",158 ,0)
	8097	I 'IBCOPY G RSCSQ
	8098	"RTN","IBY 568PO",159 ,0)
	8099	I +$P($G( ^IBE(363,+ IBCOPY,0)) ,U,3)=IBTY D
	8100	"RTN","IBY 568PO",160 ,0)
	8101	. S IBXFN =0 F S IB XFN=$O(^IB E(363,IBCO PY,11,IBXF N)) Q:'IBX FN D
	8102	"RTN","IBY 568PO",161 ,0)
	8103	.. S IBCS =$G(^IBE(3 63,IBCOPY, 11,IBXFN,0 )),IBCSFN= +IBCS
	8104	"RTN","IBY 568PO",162 ,0)
	8105	.. I +$$R SCSFILE(IB FN,$P($G(^ IBE(363.1, IBCSFN,0)) ,U,1),$P(I BCS,U,2)) S IBCNT=IB CNT+1
	8106	"RTN","IBY 568PO",163 ,0)
	8107	RSCSQ Q IB CNT
	8108	"RTN","IBY 568PO",164 ,0)
	8109	;
	8110	"RTN","IBY 568PO",165 ,0)
	8111	;
	8112	"RTN","IBY 568PO",166 ,0)
	8113	RSCSFILE(I BFN,IBCSNM ,IBCSAA) ; Add Charg e Set to a Rate Sche dule
	8114	"RTN","IBY 568PO",167 ,0)
	8115	N IBX,DD, DO,DLAYGO, DIC,DA,DR, X,Y,IBCSFN S IBX=0
	8116	"RTN","IBY 568PO",168 ,0)
	8117	I $G(^IBE (363,+$G(I BFN),0))=" " G RSCSFQ
	8118	"RTN","IBY 568PO",169 ,0)
	8119	I $G(IBCS NM)="" G R SCSFQ
	8120	"RTN","IBY 568PO",170 ,0)
	8121	S IBCSFN= $O(^IBE(36 3.1,"B",IB CSNM,0)) I 'IBCSFN G RSCSFQ
	8122	"RTN","IBY 568PO",171 ,0)
	8123	I $O(^IBE (363,IBFN, 11,"B",IBC SFN,0)) G RSCSFQ
	8124	"RTN","IBY 568PO",172 ,0)
	8125	S DLAYGO= 363,DA(1)= +IBFN,DIC= "^IBE(363, "_DA(1)_", 11,",DIC(0 )="L"
	8126	"RTN","IBY 568PO",173 ,0)
	8127	S X=IBCSN M,DIC("DR" )=".02///" _$G(IBCSAA ),DIC("P") ="363.0011 P" D ^DIC S:+Y IBX=1
	8128	"RTN","IBY 568PO",174 ,0)
	8129	RSCSFQ Q I BX
	8130	"RTN","IBY 568PO",175 ,0)
	8131	;
	8132	"RTN","IBY 568PO",176 ,0)
	8133	;
	8134	"RTN","IBY 568PO",177 ,0)
	8135	NEWIBER ; set up new error for COB workl ist
	8136	"RTN","IBY 568PO",178 ,0)
	8137	N IBNAME, DD,DO,DLAY GO,DIC,X,Y ,IBDA,IBAR R,IBX
	8138	"RTN","IBY 568PO",179 ,0)
	8139	D MES^XPD UTL(" ")
	8140	"RTN","IBY 568PO",180 ,0)
	8141	;
	8142	"RTN","IBY 568PO",181 ,0)
	8143	S IBNAME= "IB815"
	8144	"RTN","IBY 568PO",182 ,0)
	8145	S IB02="B alance bil l this pat ient using the appro priate cos t-based ra te type."
	8146	"RTN","IBY 568PO",183 ,0)
	8147	S IB04="I NTEGRATED BILLING"
	8148	"RTN","IBY 568PO",184 ,0)
	8149	S IB05="D ISPLAY MES SAGE"
	8150	"RTN","IBY 568PO",185 ,0)
	8151	I $O(^IBE (350.8,"B" ,IBNAME,0) ) S IBX=" - "_IBNA ME_" IB Er ror (350.8 ) already exists, no change" D MES^XPDUT L(IBX) Q
	8152	"RTN","IBY 568PO",186 ,0)
	8153	;
	8154	"RTN","IBY 568PO",187 ,0)
	8155	K DD,DO S DLAYGO=35 0.8,DIC="^ IBE(350.8, ",DIC(0)=" L",X=IBNAM E D FILE^D ICN
	8156	"RTN","IBY 568PO",188 ,0)
	8157	K DIC I Y <1 K X,Y Q
	8158	"RTN","IBY 568PO",189 ,0)
	8159	S IBDA=+Y
	8160	"RTN","IBY 568PO",190 ,0)
	8161	S RN=+Y
	8162	"RTN","IBY 568PO",191 ,0)
	8163	S DA=RN
	8164	"RTN","IBY 568PO",192 ,0)
	8165	S DR=".02 ///"_IB02_ ";.03///"_ IBNAME_";. 04///"_IB0 4_";.05/// "_IB05
	8166	"RTN","IBY 568PO",193 ,0)
	8167	S DIE="^I BE(350.8,"
	8168	"RTN","IBY 568PO",194 ,0)
	8169	D ^DIE
	8170	"RTN","IBY 568PO",195 ,0)
	8171	;
	8172	"RTN","IBY 568PO",196 ,0)
	8173	S IBX=" * "_IBNAM E_" IB Err or (350.8) added" D MES^XPDUTL (IBX)
	8174	"RTN","IBY 568PO",197 ,0)
	8175	Q
	8176	"RTN","IBY 568PO",198 ,0)
	8177	;
	8178	"RTN","IBY 568PO",199 ,0)
	8179	;
	8180	"RTN","IBY 568PO",200 ,0)
	8181	MCCRUTL(X, P) ; retur ns IFN of item in 39 9.1 if Nam e is found and piece P is true
	8182	"RTN","IBY 568PO",201 ,0)
	8183	N IBX,IBY S IBY=""
	8184	"RTN","IBY 568PO",202 ,0)
	8185	I $G(X)'= "" S IBX=0 F S IBX= $O(^DGCR(3 99.1,"B",X ,IBX)) Q:' IBX I $P( $G(^DGCR(3 99.1,IBX,0 )),U,+$G(P )) S IBY=I BX
	8186	"RTN","IBY 568PO",203 ,0)
	8187	Q IBY
	8188	"RTN","IBY 568PO",204 ,0)
	8189	;
	8190	"RTN","IBY 568PO",205 ,0)
	8191	;
	8192	"RTN","IBY 568PO",206 ,0)
	8193	MSG(X) ;
	8194	"RTN","IBY 568PO",207 ,0)
	8195	N IBX S I BX=$O(IBA( 999999),-1 ) S:'IBX I BX=1 S IBX =IBX+1
	8196	"RTN","IBY 568PO",208 ,0)
	8197	S IBA(IBX )=$G(X)
	8198	"RTN","IBY 568PO",209 ,0)
	8199	Q ;MSG
	8200	"RTN","IBY 568PO",210 ,0)
	8201	;
	8202	"RTN","IBY 568PO",211 ,0)
	8203	RSDT(PRE) ;Copy the active RX charge sch edule from RI to FR
	8204	"RTN","IBY 568PO",212 ,0)
	8205	S IBCS=""
	8206	"RTN","IBY 568PO",213 ,0)
	8207	I PRE="HR " S IBCS=$ O(^IBE(363 ,"B","HMN- RX",""),-1 )
	8208	"RTN","IBY 568PO",214 ,0)
	8209	I PRE="IR " S IBCS=$ O(^IBE(363 ,"B","INEL IG-RX","") ,-1)
	8210	"RTN","IBY 568PO",215 ,0)
	8211	S IBCS0=$ G(^IBE(363 ,IBCS,0))
	8212	"RTN","IBY 568PO",216 ,0)
	8213	S IBDISP= $P($G(^IBE (363,IBCS, 1)),U,1),I BADMIN=$P( $G(^IBE(36 3,IBCS,1)) ,U,2)
	8214	"RTN","IBY 568PO",217 ,0)
	8215	S IBADJST =$G(^IBE(3 63,IBCS,10 ))
	8216	"RTN","IBY 568PO",218 ,0)
	8217	Q $P(IBCS 0,U,5)
	8218	"RTN","IBY 568PO",219 ,0)
	8219	;
	8220	"RTN","IBY 568PO",220 ,0)
	8221	;
	8222	"RTN","IBY 568PO",221 ,0)
	8223	NEWRT ;Rat e Type
	8224	"RTN","IBY 568PO",222 ,0)
	8225	RT19 ;;HUM ANITARIAN REIMB. INS .;HUMANITA RIAN REIMB . INS.;0;H UM REIM;1; EMERGENCY/ HUMANITARI AN REIMB.; i;1;0;1;28
	8226	"RTN","IBY 568PO",223 ,0)
	8227	RT20 ;;INE LIGIBLE RE IMB. INS.; INELIGIBLE REIMB. IN S.;0;INE R EIM;1;INEL IGIBLE HOS P. REIMB.; i;1;0;1;28
	8228	"RTN","IBY 568PO",224 ,0)
	8229	RT21 ;;DEN TAL REIMB. INS.;DENT AL REIMB. INS.;0;DEN REIM;1;EM ERGENCY/HU MANITARIAN REIMB.;i; 1;0;1;28
	8230	"RTN","IBY 568PO",225 ,0)
	8231	;;END
	8232	"RTN","IBY 568PO",226 ,0)
	8233	;
	8234	"RTN","IBY 568PO",227 ,0)
	8235	RSF ;Rate Schedules (363) for EMERGENCY/ HUMANITARI AN REIMB. & INELIGIB LE HOSP. R EIMB.
	8236	"RTN","IBY 568PO",228 ,0)
	8237	;;HR-INPT ^HUMANITAR IAN REIMB. INS.^1^IN PATIENT
	8238	"RTN","IBY 568PO",229 ,0)
	8239	;;HR-OPT^ HUMANITARI AN REIMB. INS.^3
	8240	"RTN","IBY 568PO",230 ,0)
	8241	;;HR-RX^H UMANITARIA N REIMB. I NS.^3
	8242	"RTN","IBY 568PO",231 ,0)
	8243	;;HR-OPT DENTAL^DEN TAL REIMB. INS.^3
	8244	"RTN","IBY 568PO",232 ,0)
	8245	;;IR-INPT ^INELIGIBL E REIMB. I NS.^1^INPA TIENT
	8246	"RTN","IBY 568PO",233 ,0)
	8247	;;IR-OPT^ INELIGIBLE REIMB. IN S.^3
	8248	"RTN","IBY 568PO",234 ,0)
	8249	;;IR-RX^I NELIGIBLE REIMB. INS .^3
	8250	"RTN","IBY 568PO",235 ,0)
	8251	;;END
	8252	"VER")
	8253	8.0^22.2
	8254	"BLD",1019 0,6)
	8255	7^
	8256	$END KID I B2.0568