2. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 5/24/2018 1:20:58 PM Central Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

2.1 Files compared

#	Location	File	Last Modified
1	PRCA_4.5_339_IB_2.568_Build 1_May_2018.zip	IB_2_568.KID	Thu May 24 14:49:30 2018 UTC
2	PRCA_4.5_339_IB_2.568_Build 1_May_2018.zip	IB_2_568.KID	Thu May 24 18:06:09 2018 UTC

2.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	9	15566
Changed	8	16
Inserted	0	0
Removed	0	0

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

2.4 Active regular expressions

No regular expressions were active.

2.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^3180221^ y
	10	"BLD",1019 0,4,0)
	11	^9.64PA^^
	12	"BLD",1019 0,6.3)
	13	40
	14	"BLD",1019 0,"ABPKG")
	15	n
	16	"BLD",1019 0,"INI")
	17
	18	"BLD",1019 0,"INID")
	19	^y^
	20	"BLD",1019 0,"INIT")
	21	START^IBY5 68PO
	22	"BLD",1019 0,"KRN",0)
	23	^9.67PA^77 9.2^20
	24	"BLD",1019 0,"KRN",.4 ,0)
	25	.4
	26	"BLD",1019 0,"KRN",.4 01,0)
	27	.401
	28	"BLD",1019 0,"KRN",.4 02,0)
	29	.402
	30	"BLD",1019 0,"KRN",.4 03,0)
	31	.403
	32	"BLD",1019 0,"KRN",.5 ,0)
	33	.5
	34	"BLD",1019 0,"KRN",.8 4,0)
	35	.84
	36	"BLD",1019 0,"KRN",3. 6,0)
	37	3.6
	38	"BLD",1019 0,"KRN",3. 8,0)
	39	3.8
	40	"BLD",1019 0,"KRN",9. 2,0)
	41	9.2
	42	"BLD",1019 0,"KRN",9. 8,0)
	43	9.8
	44	"BLD",1019 0,"KRN",9. 8,"NM",0)
	45	^9.68A^23^ 16
	46	"BLD",1019 0,"KRN",9. 8,"NM",2,0 )
	47	IBJTLA1^^0 ^B13446872
	48	"BLD",1019 0,"KRN",9. 8,"NM",3,0 )
	49	IBTRE2^^0^ B41874411
	50	"BLD",1019 0,"KRN",9. 8,"NM",4,0 )
	51	IBTRE20^^0 ^B20324155
	52	"BLD",1019 0,"KRN",9. 8,"NM",5,0 )
	53	IBTRKR5^^0 ^B38746753
	54	"BLD",1019 0,"KRN",9. 8,"NM",6,0 )
	55	IBCBB11^^0 ^B12544111 1
	56	"BLD",1019 0,"KRN",9. 8,"NM",7,0 )
	57	IBJTLB1^^0 ^B13573050
	58	"BLD",1019 0,"KRN",9. 8,"NM",12, 0)
	59	IBECEA^^0^ B13714935
	60	"BLD",1019 0,"KRN",9. 8,"NM",14, 0)
	61	IBCNSBL2^^ 0^B3959345 1
	62	"BLD",1019 0,"KRN",9. 8,"NM",16, 0)
	63	IBJDF2^^0^ B68533516
	64	"BLD",1019 0,"KRN",9. 8,"NM",17, 0)
	65	IBJDF11^^0 ^B30230903
	66	"BLD",1019 0,"KRN",9. 8,"NM",18, 0)
	67	IBJDB21^^0 ^B12749625 8
	68	"BLD",1019 0,"KRN",9. 8,"NM",19, 0)
	69	IBJDF4^^0^ B43681161
	70	"BLD",1019 0,"KRN",9. 8,"NM",20, 0)
	71	IBJDF41^^0 ^B10300970 0
	72	"BLD",1019 0,"KRN",9. 8,"NM",21, 0)
	73	IBJDF42^^0 ^B55007532
	74	"BLD",1019 0,"KRN",9. 8,"NM",22, 0)
	75	IBJDF43^^0 ^B25427864
	76	"BLD",1019 0,"KRN",9. 8,"NM",23, 0)
	77	IBCAPP^^0^ B23150807
	78	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBCAPP", 23)
	79
	80	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBCBB11" ,6)
	81
	82	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBCNSBL2 ",14)
	83
	84	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBECEA", 12)
	85
	86	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDB21" ,18)
	87
	88	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF11" ,17)
	89
	90	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF2", 16)
	91
	92	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF4", 19)
	93
	94	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF41" ,20)
	95
	96	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF42" ,21)
	97
	98	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJDF43" ,22)
	99
	100	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJTLA1" ,2)
	101
	102	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBJTLB1" ,7)
	103
	104	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBTRE2", 3)
	105
	106	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBTRE20" ,4)
	107
	108	"BLD",1019 0,"KRN",9. 8,"NM","B" ,"IBTRKR5" ,5)
	109
	110	"BLD",1019 0,"KRN",19 ,0)
	111	19
	112	"BLD",1019 0,"KRN",19 ,"NM",0)
	113	^9.68A^8^8
	114	"BLD",1019 0,"KRN",19 ,"NM",1,0)
	115	IBT SUP MA NUALLY QUE PRSTHTCS^ ^0
	116	"BLD",1019 0,"KRN",19 ,"NM",2,0)
	117	IBT EDIT T RACKING PA RAMETERS^^ 0^
	118	"BLD",1019 0,"KRN",19 ,"NM",3,0)
	119	IBT SUP MA NUALLY QUE ENCTRS^^4 ^
	120	"BLD",1019 0,"KRN",19 ,"NM",4,0)
	121	IBT SUP MA NUALLY QUE RX FILLS^ ^4^
	122	"BLD",1019 0,"KRN",19 ,"NM",5,0)
	123	IBT SUPERV ISORS MENU ^^0
	124	"BLD",1019 0,"KRN",19 ,"NM",6,0)
	125	IBJ MCCR S ITE PARAME TERS^^0
	126	"BLD",1019 0,"KRN",19 ,"NM",7,0)
	127	IB AUTO BI LLER PARAM S^^0
	128	"BLD",1019 0,"KRN",19 ,"NM",8,0)
	129	IB EDIT SI TE PARAMET ERS^^0
	130	"BLD",1019 0,"KRN",19 ,"NM","B", "IB AUTO B ILLER PARA MS",7)
	131
	132	"BLD",1019 0,"KRN",19 ,"NM","B", "IB EDIT S ITE PARAME TERS",8)
	133
	134	"BLD",1019 0,"KRN",19 ,"NM","B", "IBJ MCCR SITE PARAM ETERS",6)
	135
	136	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT EDIT TRACKING P ARAMETERS" ,2)
	137
	138	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT SUP M ANUALLY QU E ENCTRS", 3)
	139
	140	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT SUP M ANUALLY QU E PRSTHTCS ",1)
	141
	142	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT SUP M ANUALLY QU E RX FILLS ",4)
	143
	144	"BLD",1019 0,"KRN",19 ,"NM","B", "IBT SUPER VISORS MEN U",5)
	145
	146	"BLD",1019 0,"KRN",19 .1,0)
	147	19.1
	148	"BLD",1019 0,"KRN",19 .1,"NM",0)
	149	^9.68A^1^1
	150	"BLD",1019 0,"KRN",19 .1,"NM",1, 0)
	151	IB PARAMET ER EDIT^^0
	152	"BLD",1019 0,"KRN",19 .1,"NM","B ","IB PARA METER EDIT ",1)
	153
	154	"BLD",1019 0,"KRN",10 1,0)
	155	101
	156	"BLD",1019 0,"KRN",10 1,"NM",0)
	157	^9.68A^^
	158	"BLD",1019 0,"KRN",40 9.61,0)
	159	409.61
	160	"BLD",1019 0,"KRN",40 9.61,"NM", 0)
	161	^9.68A^2^2
	162	"BLD",1019 0,"KRN",40 9.61,"NM", 1,0)
	163	IBJT ACTIV E LIST^^0
	164	"BLD",1019 0,"KRN",40 9.61,"NM", 2,0)
	165	IBJT INACT IVE LIST^^ 0
	166	"BLD",1019 0,"KRN",40 9.61,"NM", "B","IBJT ACTIVE LIS T",1)
	167
	168	"BLD",1019 0,"KRN",40 9.61,"NM", "B","IBJT INACTIVE L IST",2)
	169
	170	"BLD",1019 0,"KRN",77 1,0)
	171	771
	172	"BLD",1019 0,"KRN",77 9.2,0)
	173	779.2
	174	"BLD",1019 0,"KRN",87 0,0)
	175	870
	176	"BLD",1019 0,"KRN",87 0,"NM",0)
	177	^9.68A^^
	178	"BLD",1019 0,"KRN",89 89.51,0)
	179	8989.51
	180	"BLD",1019 0,"KRN",89 89.52,0)
	181	8989.52
	182	"BLD",1019 0,"KRN",89 94,0)
	183	8994
	184	"BLD",1019 0,"KRN","B ",.4,.4)
	185
	186	"BLD",1019 0,"KRN","B ",.401,.40 1)
	187
	188	"BLD",1019 0,"KRN","B ",.402,.40 2)
	189
	190	"BLD",1019 0,"KRN","B ",.403,.40 3)
	191
	192	"BLD",1019 0,"KRN","B ",.5,.5)
	193
	194	"BLD",1019 0,"KRN","B ",.84,.84)
	195
	196	"BLD",1019 0,"KRN","B ",3.6,3.6)
	197
	198	"BLD",1019 0,"KRN","B ",3.8,3.8)
	199
	200	"BLD",1019 0,"KRN","B ",9.2,9.2)
	201
	202	"BLD",1019 0,"KRN","B ",9.8,9.8)
	203
	204	"BLD",1019 0,"KRN","B ",19,19)
	205
	206	"BLD",1019 0,"KRN","B ",19.1,19. 1)
	207
	208	"BLD",1019 0,"KRN","B ",101,101)
	209
	210	"BLD",1019 0,"KRN","B ",409.61,4 09.61)
	211
	212	"BLD",1019 0,"KRN","B ",771,771)
	213
	214	"BLD",1019 0,"KRN","B ",779.2,77 9.2)
	215
	216	"BLD",1019 0,"KRN","B ",870,870)
	217
	218	"BLD",1019 0,"KRN","B ",8989.51, 8989.51)
	219
	220	"BLD",1019 0,"KRN","B ",8989.52, 8989.52)
	221
	222	"BLD",1019 0,"KRN","B ",8994,899 4)
	223
	224	"BLD",1019 0,"QDEF")
	225	^^^^NO^^^^ NO^^NO
	226	"BLD",1019 0,"QUES",0 )
	227	^9.62^^
	228	"BLD",1019 0,"REQB",0 )
	229	^9.611^10^ 8
	230	"BLD",1019 0,"REQB",1 ,0)
	231	IB2.0135 ^2
	232	"BLD",1019 0,"REQB",2 ,0)
	233	IB2.0220 ^2
	234	"BLD",1019 0,"REQB",4 ,0)
	235	IB2.0447 ^2
	236	"BLD",1019 0,"REQB",5 ,0)
	237	IB2.0458 ^2
	238	"BLD",1019 0,"REQB",6 ,0)
	239	IB2.0473 ^2
	240	"BLD",1019 0,"REQB",7 ,0)
	241	IB2.0498 ^2
	242	"BLD",1019 0,"REQB",9 ,0)
	243	IB2.0577 ^2
	244	"BLD",1019 0,"REQB",1 0,0)
	245	IB2.0597 ^2
	246	"BLD",1019 0,"REQB"," B","IB2.0 135",1)
	247
	248	"BLD",1019 0,"REQB"," B","IB2.0 220",2)
	249
	250	"BLD",1019 0,"REQB"," B","IB2.0 447",4)
	251
	252	"BLD",1019 0,"REQB"," B","IB2.0 458",5)
	253
	254	"BLD",1019 0,"REQB"," B","IB2.0 473",6)
	255
	256	"BLD",1019 0,"REQB"," B","IB2.0 498",7)
	257
	258	"BLD",1019 0,"REQB"," B","IB2.0 577",9)
	259
	260	"BLD",1019 0,"REQB"," B","IB2.0 597",10)
	261
	262	"INIT")
	263	START^IBY5 68PO
	264	"KRN",19,2 314,-1)
	265	0^8
	266	"KRN",19,2 314,0)
	267	IB EDIT SI TE PARAMET ERS^Enter/ Edit IB Si te Paramet ers^^R^^IB PARAMETER EDIT^^^^^ ^INTEGRATE D
	268	BILLING
	269	"KRN",19,2 314,1,0)
	270	^19.06^3^3 ^3170328^^ ^^
	271	"KRN",19,2 314,1,1,0)
	272	This optio n allows e ntering an d editing of Integra ted Billin g Site
	273	"KRN",19,2 314,1,2,0)
	274	Parameter file. Mod ifying the site para meters can affect th e performa nce
	275	"KRN",19,2 314,1,3,0)
	276	of Integra ted Billin g's backgr ound filer .
	277	"KRN",19,2 314,15)
	278
	279	"KRN",19,2 314,20)
	280
	281	"KRN",19,2 314,25)
	282	EDIT^IBEFU TL
	283	"KRN",19,2 314,"U")
	284	ENTER/EDIT IB SITE P ARAMETERS
	285	"KRN",19,2 419,-1)
	286	0^5
	287	"KRN",19,2 419,0)
	288	IBT SUPERV ISORS MENU ^Superviso rs Menu (C laims Trac king)^^M^^ IB CLAIMS
	289	SUPERVISOR ^^^^^^INTE GRATED BIL LING
	290	"KRN",19,2 419,1,0)
	291	^19.06^3^3 ^3161101^^ ^^
	292	"KRN",19,2 419,1,1,0)
	293	This optio n contains the super visory opt ions for t he Claims tracking
	294	"KRN",19,2 419,1,2,0)
	295	module. S ite parame ters may b e edited. Table fil es may be
	296	"KRN",19,2 419,1,3,0)
	297	maintained . Backgro und jobs m ay be repe ated or re -queued.
	298	"KRN",19,2 419,10,0)
	299	^19.01IP^4 ^4
	300	"KRN",19,2 419,10,1,0 )
	301	2421^PE
	302	"KRN",19,2 419,10,1," ^")
	303	IBT EDIT T RACKING PA RAMETERS
	304	"KRN",19,2 419,10,2,0 )
	305	2434^RX
	306	"KRN",19,2 419,10,2," ^")
	307	IBT SUP MA NUALLY QUE RX FILLS
	308	"KRN",19,2 419,10,3,0 )
	309	2435^OE
	310	"KRN",19,2 419,10,3," ^")
	311	IBT SUP MA NUALLY QUE ENCTRS
	312	"KRN",19,2 419,10,4,0 )
	313	11784^PR
	314	"KRN",19,2 419,10,4," ^")
	315	IBT SUP MA NUALLY QUE PRSTHTCS
	316	"KRN",19,2 419,99)
	317	64371,4690 9
	318	"KRN",19,2 419,"U")
	319	SUPERVISOR S MENU (CL AIMS TRACK
	320	"KRN",19,2 421,-1)
	321	0^2
	322	"KRN",19,2 421,0)
	323	IBT EDIT T RACKING PA RAMETERS^C laims Trac king Param eter Edit^ ^R^^IB PAR AMETER
	324	EDIT^^^^^^ INTEGRATED BILLING
	325	"KRN",19,2 421,1,0)
	326	^19.06^2^2 ^3161215^^ ^^
	327	"KRN",19,2 421,1,1,0)
	328	This optio n allows e diting MCC R site par ameters th at affect the
	329	"KRN",19,2 421,1,2,0)
	330	Claims Tra cking Modu le.
	331	"KRN",19,2 421,25)
	332	IBTRP
	333	"KRN",19,2 421,"U")
	334	CLAIMS TRA CKING PARA METER EDIT
	335	"KRN",19,2 434,-1)
	336	4^4
	337	"KRN",19,2 434,0)
	338	IBT SUP MA NUALLY QUE RX FILLS
	339	"KRN",19,2 435,-1)
	340	4^3
	341	"KRN",19,2 435,0)
	342	IBT SUP MA NUALLY QUE ENCTRS
	343	"KRN",19,2 445,-1)
	344	0^7
	345	"KRN",19,2 445,0)
	346	IB AUTO BI LLER PARAM S^Enter/Ed it Automat ed Billing Parameter s^^R^^IB P ARAMETER E DIT^^^^^^
	347	"KRN",19,2 445,1,0)
	348	^19.06^1^1 ^3170328^^
	349	"KRN",19,2 445,1,1,0)
	350	Enter and edit the p arameters controllin g Automate d Billing.
	351	"KRN",19,2 445,25)
	352	EDIT^IBCDE
	353	"KRN",19,2 445,"U")
	354	ENTER/EDIT AUTOMATED BILLING P
	355	"KRN",19,3 218,-1)
	356	0^6
	357	"KRN",19,3 218,0)
	358	IBJ MCCR S ITE PARAME TERS^MCCR Site Param eter Displ ay/Edit^^R ^^IB PARAM ETER
	359	EDIT^^^^^^ INTEGRATED BILLING^^
	360	"KRN",19,3 218,1,0)
	361	^19.06^1^1 ^3161215^^ ^^
	362	"KRN",19,3 218,1,1,0)
	363	This optio n allows t he user to view and edit MCCR site param eters.
	364	"KRN",19,3 218,20)
	365
	366	"KRN",19,3 218,25)
	367	IBJPM
	368	"KRN",19,3 218,"U")
	369	MCCR SITE PARAMETER DISPLAY/ED
	370	"KRN",19,1 1784,-1)
	371	0^1
	372	"KRN",19,1 1784,0)
	373	IBT SUP MA NUALLY QUE PRSTHTCS^ Manually A dd Prosthe tics to Cl aims
	374	Tracking^^ R^^^^^^^^I NTEGRATED BILLING
	375	"KRN",19,1 1784,1,0)
	376	^^5^5^3161 101^
	377	"KRN",19,1 1784,1,1,0 )
	378	This optio n allows t he user to select a date range of prosth etics
	379	"KRN",19,1 1784,1,2,0 )
	380	encounters and tries to add th em to the Claims tra cking modu le.
	381	"KRN",19,1 1784,1,3,0 )
	382
	383	"KRN",19,1 1784,1,4,0 )
	384	The option will auto matically queue off a task to add prosth etics and
	385	"KRN",19,1 1784,1,5,0 )
	386	when compl ete send t he request ing user a mail mess age.
	387	"KRN",19,1 1784,25)
	388	EN^IBTRKR5
	389	"KRN",19,1 1784,"U")
	390	MANUALLY A DD PROSTHE TICS TO CL
	391	"KRN",19.1 ,607,-1)
	392	0^1
	393	"KRN",19.1 ,607,0)
	394	IB PARAMET ER EDIT^^
	395	"KRN",409. 61,84,-1)
	396	0^1
	397	"KRN",409. 61,84,0)
	398	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
	399	Bills^1^^1
	400	"KRN",409. 61,84,1)
	401	^VALM HIDD EN ACTIONS
	402	"KRN",409. 61,84,"ARR AY")
	403	^TMP("IBJ TLA",$J)
	404	"KRN",409. 61,84,"COL ",0)
	405	^409.621^1 4^14
	406	"KRN",409. 61,84,"COL ",1,0)
	407	NUMBER^1^3
	408	"KRN",409. 61,84,"COL ",2,0)
	409	BILL^4^9^ Bill #
	410	"KRN",409. 61,84,"COL ",3,0)
	411	HD^14^1
	412	"KRN",409. 61,84,"COL ",4,0)
	413	STFROM^15^ 8^From
	414	"KRN",409. 61,84,"COL ",5,0)
	415	STTO^24^8^ To
	416	"KRN",409. 61,84,"COL ",6,0)
	417	TYPE^37^5^ Type
	418	"KRN",409. 61,84,"COL ",7,0)
	419	ARST^42^4^ Stat
	420	"KRN",409. 61,84,"COL ",8,0)
	421	RATE^47^7^ Rate
	422	"KRN",409. 61,84,"COL ",9,0)
	423	CB^55^1
	424	"KRN",409. 61,84,"COL ",10,0)
	425	INSUR^56^7 ^Insurer
	426	"KRN",409. 61,84,"COL ",11,0)
	427	OAMT^64^8^ Orig Amt
	428	"KRN",409. 61,84,"COL ",12,0)
	429	CAMT^73^8^ Curr Amt
	430	"KRN",409. 61,84,"COL ",13,0)
	431	REFER^13^1
	432	"KRN",409. 61,84,"COL ",14,0)
	433	MT?^33^3^M T?
	434	"KRN",409. 61,84,"COL ","B","ARS T",7)
	435
	436	"KRN",409. 61,84,"COL ","B","BIL L",2)
	437
	438	"KRN",409. 61,84,"COL ","B","CAM T",12)
	439
	440	"KRN",409. 61,84,"COL ","B","CB" ,9)
	441
	442	"KRN",409. 61,84,"COL ","B","HD" ,3)
	443
	444	"KRN",409. 61,84,"COL ","B","INS UR",10)
	445
	446	"KRN",409. 61,84,"COL ","B","MT? ",14)
	447
	448	"KRN",409. 61,84,"COL ","B","NUM BER",1)
	449
	450	"KRN",409. 61,84,"COL ","B","OAM T",11)
	451
	452	"KRN",409. 61,84,"COL ","B","RAT E",8)
	453
	454	"KRN",409. 61,84,"COL ","B","REF ER",13)
	455
	456	"KRN",409. 61,84,"COL ","B","STF ROM",4)
	457
	458	"KRN",409. 61,84,"COL ","B","STT O",5)
	459
	460	"KRN",409. 61,84,"COL ","B","TYP E",6)
	461
	462	"KRN",409. 61,84,"FNL ")
	463	D EXIT^IBJ TLA
	464	"KRN",409. 61,84,"HDR ")
	465	D HDR^IBJT LA
	466	"KRN",409. 61,84,"HLP ")
	467	D HELP^IBJ TLA
	468	"KRN",409. 61,84,"INI T")
	469	D INIT^IBJ TLA
	470	"KRN",409. 61,95,-1)
	471	0^2
	472	"KRN",409. 61,95,0)
	473	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
	474	"KRN",409. 61,95,1)
	475	^VALM HIDD EN ACTIONS
	476	"KRN",409. 61,95,"ARR AY")
	477	^TMP("IBJ TLB",$J)
	478	"KRN",409. 61,95,"COL ",0)
	479	^409.621^1 3^13
	480	"KRN",409. 61,95,"COL ",1,0)
	481	NUMBER^1^3
	482	"KRN",409. 61,95,"COL ",2,0)
	483	BILL^4^12^ Bill #
	484	"KRN",409. 61,95,"COL ",3,0)
	485	HD^17^1
	486	"KRN",409. 61,95,"COL ",4,0)
	487	STFROM^18^ 8^From
	488	"KRN",409. 61,95,"COL ",5,0)
	489	STTO^27^8^ To
	490	"KRN",409. 61,95,"COL ",6,0)
	491	TYPE^36^5^ Type
	492	"KRN",409. 61,95,"COL ",7,0)
	493	ARST^41^4^ Stat
	494	"KRN",409. 61,95,"COL ",8,0)
	495	RATE^46^7^ Rate
	496	"KRN",409. 61,95,"COL ",9,0)
	497	CB^54^1
	498	"KRN",409. 61,95,"COL ",10,0)
	499	INSUR^55^7 ^Insurer
	500	"KRN",409. 61,95,"COL ",11,0)
	501	OAMT^64^8^ Orig Amt
	502	"KRN",409. 61,95,"COL ",12,0)
	503	CAMT^73^8^ Curr Amt
	504	"KRN",409. 61,95,"COL ",13,0)
	505	REFER^16^1
	506	"KRN",409. 61,95,"COL ","B","ARS T",7)
	507
	508	"KRN",409. 61,95,"COL ","B","BIL L",2)
	509
	510	"KRN",409. 61,95,"COL ","B","CAM T",12)
	511
	512	"KRN",409. 61,95,"COL ","B","CB" ,9)
	513
	514	"KRN",409. 61,95,"COL ","B","HD" ,3)
	515
	516	"KRN",409. 61,95,"COL ","B","INS UR",10)
	517
	518	"KRN",409. 61,95,"COL ","B","NUM BER",1)
	519
	520	"KRN",409. 61,95,"COL ","B","OAM T",11)
	521
	522	"KRN",409. 61,95,"COL ","B","RAT E",8)
	523
	524	"KRN",409. 61,95,"COL ","B","REF ER",13)
	525
	526	"KRN",409. 61,95,"COL ","B","STF ROM",4)
	527
	528	"KRN",409. 61,95,"COL ","B","STT O",5)
	529
	530	"KRN",409. 61,95,"COL ","B","TYP E",6)
	531
	532	"KRN",409. 61,95,"FNL ")
	533	D EXIT^IBJ TLB
	534	"KRN",409. 61,95,"HDR ")
	535	D HDR^IBJT LB
	536	"KRN",409. 61,95,"HLP ")
	537	D HELP^IBJ TLB
	538	"KRN",409. 61,95,"INI T")
	539	D INIT^IBJ TLB
	540	"MBREQ")
	541	0
	542	"ORD",3,19 .1)
	543	19.1;3;;;K EY^XPDTA1; KEYF1^XPDI A1;KEYE1^X PDIA1;KEYF 2^XPDIA1;; KEYDEL^XPD IA1
	544	"ORD",3,19 .1,0)
	545	SECURITY K EY
	546	"ORD",17,4 09.61)
	547	409.61;17; 1;;;;LME1^ XPDIA1;;;L MDEL^XPDIA 1
	548	"ORD",17,4 09.61,0)
	549	LIST TEMPL ATE
	550	"ORD",18,1 9)
	551	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
	552	"ORD",18,1 9,0)
	553	OPTION
	554	"PKG",49,- 1)
	555	1^1
	556	"PKG",49,0 )
	557	INTEGRATED BILLING^I B^INTEGRAT ED BILLING
	558	"PKG",49,2 0,0)
	559	^9.402P^1^ 1
	560	"PKG",49,2 0,1,0)
	561	2^^IBAXDR
	562	"PKG",49,2 0,1,1)
	563
	564	"PKG",49,2 0,"B",2,1)
	565
	566	"PKG",49,2 2,0)
	567	^9.49I^1^1
	568	"PKG",49,2 2,1,0)
	569	2.0^305111 9^2960627
	570	"PKG",49,2 2,1,"PAH", 1,0)
	571	568^318022 1
	572	"PKG",49,2 2,1,"PAH", 1,1,0)
	573	^^313^313^ 3171024
	574	"PKG",49,2 2,1,"PAH", 1,1,1,0)
	575
	576	"PKG",49,2 2,1,"PAH", 1,1,2,0)
	577	IMPORTANT INSTALLATI ON NOTE:
	578	"PKG",49,2 2,1,"PAH", 1,1,3,0)
	579	---------- ---------- --------
	580	"PKG",49,2 2,1,"PAH", 1,1,4,0)
	581	This patch is part o f a multi- package bu ild. There are three patches
	582	"PKG",49,2 2,1,"PAH", 1,1,5,0)
	583	associated with the FY16 HAPE Revenue En hancement project -
	584	"PKG",49,2 2,1,"PAH", 1,1,6,0)
	585	IB2.0568 ,PRCA4.5 315 and PS O7.0463. All three patches a re to be
	586	"PKG",49,2 2,1,"PAH", 1,1,7,0)
	587	installed together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
	588	"PKG",49,2 2,1,"PAH", 1,1,8,0)
	589
	590	"PKG",49,2 2,1,"PAH", 1,1,9,0)
	591
	592	"PKG",49,2 2,1,"PAH", 1,1,10,0)
	593	Descriptio n
	594	"PKG",49,2 2,1,"PAH", 1,1,11,0)
	595	---------- -
	596	"PKG",49,2 2,1,"PAH", 1,1,12,0)
	597	The Chief Business O ffice (CBO ) is reque sting syst em enhance ments to
	598	"PKG",49,2 2,1,"PAH", 1,1,13,0)
	599	The Vetera ns Health Informatio n Systems and Techno logy Archi tecture
	600	"PKG",49,2 2,1,"PAH", 1,1,14,0)
	601	(VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd
	602	"PKG",49,2 2,1,"PAH", 1,1,15,0)
	603	Outpatient Pharmacy (PSO) soft ware modul es.
	604	"PKG",49,2 2,1,"PAH", 1,1,16,0)
	605
	606	"PKG",49,2 2,1,"PAH", 1,1,17,0)
	607	The missio n of the D epartment of Veteran s Affairs (VA), Offi ce of
	608	"PKG",49,2 2,1,"PAH", 1,1,18,0)
	609	Informatio n & Techno logy (OI&T ), is to p rovide ben efits and services
	610	"PKG",49,2 2,1,"PAH", 1,1,19,0)
	611	to veteran s of the U nited Stat es Armed F orces. In meeting th ese
	612	"PKG",49,2 2,1,"PAH", 1,1,20,0)
	613	goals, OIT strives t o provide high quali ty, effect ive, and e fficient
	614	"PKG",49,2 2,1,"PAH", 1,1,21,0)
	615	Informatio n Technolo gy (IT) se rvices to those resp onsible fo r
	616	"PKG",49,2 2,1,"PAH", 1,1,22,0)
	617	providing care to th e veterans at the po int-of-car e, as well as
	618	"PKG",49,2 2,1,"PAH", 1,1,23,0)
	619	throughout all the p oints of t he veteran s' health care. The VA depends
	620	"PKG",49,2 2,1,"PAH", 1,1,24,0)
	621	on Informa tion Manag ement/Info rmation Te chnology ( IM/IT) sys tems to
	622	"PKG",49,2 2,1,"PAH", 1,1,25,0)
	623	meet missi on goals.
	624	"PKG",49,2 2,1,"PAH", 1,1,26,0)
	625
	626	"PKG",49,2 2,1,"PAH", 1,1,27,0)
	627	The overal l FY16 HAP E Revenue Enhancemen t project has been f urther
	628	"PKG",49,2 2,1,"PAH", 1,1,28,0)
	629	divided in to three s ub-project s:
	630	"PKG",49,2 2,1,"PAH", 1,1,29,0)
	631
	632	"PKG",49,2 2,1,"PAH", 1,1,30,0)
	633	NSR #20150 506
	634	"PKG",49,2 2,1,"PAH", 1,1,31,0)
	635	The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the Chief
	636	"PKG",49,2 2,1,"PAH", 1,1,32,0)
	637	Business O ffice (CBO ), bundles several N SRs with s imilar bus iness
	638	"PKG",49,2 2,1,"PAH", 1,1,33,0)
	639	needs into a single requiremen ts documen t. Succes sfully add ressing
	640	"PKG",49,2 2,1,"PAH", 1,1,34,0)
	641	the requir ements con tained wit hin this d ocument wi ll enable the
	642	"PKG",49,2 2,1,"PAH", 1,1,35,0)
	643	Department of Vetera ns Affairs (VA) to a ppropriate ly bill ce rtain
	644	"PKG",49,2 2,1,"PAH", 1,1,36,0)
	645	subsets of billable events by correcting , automati ng, or enh ancing
	646	"PKG",49,2 2,1,"PAH", 1,1,37,0)
	647	current Ve terans Hea lth Inform ation Syst ems and Te chnology
	648	"PKG",49,2 2,1,"PAH", 1,1,38,0)
	649	Architectu re (VistA) systems.
	650	"PKG",49,2 2,1,"PAH", 1,1,39,0)
	651
	652	"PKG",49,2 2,1,"PAH", 1,1,40,0)
	653	NSR #20150 507
	654	"PKG",49,2 2,1,"PAH", 1,1,41,0)
	655	The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs,
	656	"PKG",49,2 2,1,"PAH", 1,1,42,0)
	657	as well. T his effort enables t he Departm ent of Vet erans Affa irs (VA)
	658	"PKG",49,2 2,1,"PAH", 1,1,43,0)
	659	to improve revenue o peration f unctionali ty related to repaym ent plans,
	660	"PKG",49,2 2,1,"PAH", 1,1,44,0)
	661	late charg e capture, bill susp ension rea sons, the billing of
	662	"PKG",49,2 2,1,"PAH", 1,1,45,0)
	663	deactivate d provider s, and the display o f appeal r ights and
	664	"PKG",49,2 2,1,"PAH", 1,1,46,0)
	665	responsibi lities on the Vetera ns Benefic iary trave l Bill of Collection s
	666	"PKG",49,2 2,1,"PAH", 1,1,47,0)
	667	form. Imp lementatio n of the p roposed en hancements will make a
	668	"PKG",49,2 2,1,"PAH", 1,1,48,0)
	669	significan t positive impact on stakehold ers and ta rget users .
	670	"PKG",49,2 2,1,"PAH", 1,1,49,0)
	671
	672	"PKG",49,2 2,1,"PAH", 1,1,50,0)
	673	NSR #20150 505
	674	"PKG",49,2 2,1,"PAH", 1,1,51,0)
	675	The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to
	676	"PKG",49,2 2,1,"PAH", 1,1,52,0)
	677	improve tr acking and reporting of revenu e, and wil l support revenue
	678	"PKG",49,2 2,1,"PAH", 1,1,53,0)
	679	reporting business r ules and g uidelines.
	680	"PKG",49,2 2,1,"PAH", 1,1,54,0)
	681
	682	"PKG",49,2 2,1,"PAH", 1,1,55,0)
	683
	684	"PKG",49,2 2,1,"PAH", 1,1,56,0)
	685	IB2.0568 patch enh ancements, pertinent to the ab ove NSRs, include:
	686	"PKG",49,2 2,1,"PAH", 1,1,57,0)
	687
	688	"PKG",49,2 2,1,"PAH", 1,1,58,0)
	689	1.) When g enerating the RNB (R easons Not Billable) report, t he
	690	"PKG",49,2 2,1,"PAH", 1,1,59,0)
	691	Integrated Billing s ystem shal l populate the charg es for all types
	692	"PKG",49,2 2,1,"PAH", 1,1,60,0)
	693	of service s provided . Charges will not b e screened by any bi llable
	694	"PKG",49,2 2,1,"PAH", 1,1,61,0)
	695	criteria b ut willind icate the full amoun t as if th e care was to be
	696	"PKG",49,2 2,1,"PAH", 1,1,62,0)
	697	billed.
	698	"PKG",49,2 2,1,"PAH", 1,1,63,0)
	699
	700	"PKG",49,2 2,1,"PAH", 1,1,64,0)
	701	2.) The su b-option C laims Trac king Param eter Edit [IBT EDIT TRACKING
	702	"PKG",49,2 2,1,"PAH", 1,1,65,0)
	703	PARAMETERS ], that cu rrently ha s no key, will be lo cked with a new
	704	"PKG",49,2 2,1,"PAH", 1,1,66,0)
	705	Security K ey called IB PARAMET ER EDIT.
	706	"PKG",49,2 2,1,"PAH", 1,1,67,0)
	707
	708	"PKG",49,2 2,1,"PAH", 1,1,68,0)
	709	3.) The op tion MCCR Site Param eter Displ ay/Edit [I BJ MCCR SI TE
	710	"PKG",49,2 2,1,"PAH", 1,1,69,0)
	711	PARAMETERS ], which i s currentl y locked w ith the IB SUPERVISO R Security
	712	"PKG",49,2 2,1,"PAH", 1,1,70,0)
	713	Key, will be instead locked wi th the new key.
	714	"PKG",49,2 2,1,"PAH", 1,1,71,0)
	715
	716	"PKG",49,2 2,1,"PAH", 1,1,72,0)
	717	4.) The In tegrated B illing sys tem shall create cla ims tracki ng entries
	718	"PKG",49,2 2,1,"PAH", 1,1,73,0)
	719	for previo usly unbil led Prosth etics/DME items when new billa ble
	720	"PKG",49,2 2,1,"PAH", 1,1,74,0)
	721	insurance is entered into the patient's insurance file.
	722	"PKG",49,2 2,1,"PAH", 1,1,75,0)
	723
	724	"PKG",49,2 2,1,"PAH", 1,1,76,0)
	725	5.) A new coverage l imitation field shal l be creat ed in the insurance
	726	"PKG",49,2 2,1,"PAH", 1,1,77,0)
	727	file for P rosthetics . Like th e other ex isting cov erage limi tation
	728	"PKG",49,2 2,1,"PAH", 1,1,78,0)
	729	fields in the insura nce file ( Inpatient, Outpatien t, Pharmac y etc.),
	730	"PKG",49,2 2,1,"PAH", 1,1,79,0)
	731	this field will have the follo wing optio ns:
	732	"PKG",49,2 2,1,"PAH", 1,1,80,0)
	733	0= NOT COVERE D
	734	"PKG",49,2 2,1,"PAH", 1,1,81,0)
	735	1= COVERED
	736	"PKG",49,2 2,1,"PAH", 1,1,82,0)
	737	2= CONDITIONA LCOVERAGE
	738	"PKG",49,2 2,1,"PAH", 1,1,83,0)
	739	Once selec ted, they will show in the pat ient insur ance file as Yes,
	740	"PKG",49,2 2,1,"PAH", 1,1,84,0)
	741	No, or Con ditional.
	742	"PKG",49,2 2,1,"PAH", 1,1,85,0)
	743
	744	"PKG",49,2 2,1,"PAH", 1,1,86,0)
	745	6.) The sy stem shall automatic ally assig n an RNB [ NO PROSTHE TIC
	746	"PKG",49,2 2,1,"PAH", 1,1,87,0)
	747	COVERAGE ( CV22)] for Prostheti cs/DME ite ms if the patient ha s no
	748	"PKG",49,2 2,1,"PAH", 1,1,88,0)
	749	coverage f or Prosthe tics in hi s/her insu rance file .
	750	"PKG",49,2 2,1,"PAH", 1,1,89,0)
	751
	752	"PKG",49,2 2,1,"PAH", 1,1,90,0)
	753	7.) The sy stem shall have a ne w option t o add Pros thetics it ems to
	754	"PKG",49,2 2,1,"PAH", 1,1,91,0)
	755	Manual and Nightly C laims Trac king.
	756	"PKG",49,2 2,1,"PAH", 1,1,92,0)
	757
	758	"PKG",49,2 2,1,"PAH", 1,1,93,0)
	759	8.) Users will be ab le to sele ct Suspend ed Type fr om the men u to
	760	"PKG",49,2 2,1,"PAH", 1,1,94,0)
	761	display in the First Party Fol low- Up [I BJD FOLLOW -UP FIRST PARTY]
	762	"PKG",49,2 2,1,"PAH", 1,1,95,0)
	763	report.
	764	"PKG",49,2 2,1,"PAH", 1,1,96,0)
	765
	766	"PKG",49,2 2,1,"PAH", 1,1,97,0)
	767	9.) First Party Foll ow- Up [IB JD FOLLOW- UP FIRST P ARTY] repo rt shall
	768	"PKG",49,2 2,1,"PAH", 1,1,98,0)
	769	be modifie d to incor porate rea son for su spension.
	770	"PKG",49,2 2,1,"PAH", 1,1,99,0)
	771
	772	"PKG",49,2 2,1,"PAH", 1,1,100,0)
	773	10.) A new warning m essage wil l print to the scree n in the E nter/Edit
	774	"PKG",49,2 2,1,"PAH", 1,1,101,0)
	775	Billing In formation option if an ATTENDI NG, REFERR ING or REN DERING
	776	"PKG",49,2 2,1,"PAH", 1,1,102,0)
	777	Provider h as a PERSO N CLASS - NEW PERSON file (#20 0) - that was
	778	"PKG",49,2 2,1,"PAH", 1,1,103,0)
	779	expirated at the tim e of the D ate of Ser vice.
	780	"PKG",49,2 2,1,"PAH", 1,1,104,0)
	781
	782	"PKG",49,2 2,1,"PAH", 1,1,105,0)
	783	11.) On th e Third Pa rty Joint Inquiry sc reen, one (1) charac ter space
	784	"PKG",49,2 2,1,"PAH", 1,1,106,0)
	785	shall be a dded to th e "Type" f ield so th at it will accommoda te five
	786	"PKG",49,2 2,1,"PAH", 1,1,107,0)
	787	characters (a one-ch aracter cl assificati on indicat or, a forw ard slash
	788	"PKG",49,2 2,1,"PAH", 1,1,108,0)
	789	(/), a one -character component indicator , a forwar d slash (/ ), and a
	790	"PKG",49,2 2,1,"PAH", 1,1,109,0)
	791	one-charac ter care t ype) ("X/X /X"). If a bill con tains pres criptions,
	792	"PKG",49,2 2,1,"PAH", 1,1,110,0)
	793	then an "R " shall be concatena ted to the fifth cha racter sub -type
	794	"PKG",49,2 2,1,"PAH", 1,1,111,0)
	795	position o f the "Typ e" field. If a bill contains p rosthetics , then a
	796	"PKG",49,2 2,1,"PAH", 1,1,112,0)
	797	"P" shall be concate nated to f ifth chara cter sub-t ype positi on of the
	798	"PKG",49,2 2,1,"PAH", 1,1,113,0)
	799	"Type" fie ld.The "Ty pe" field shall cont ain five ( 5) charact ers as
	800	"PKG",49,2 2,1,"PAH", 1,1,114,0)
	801	follows:
	802	"PKG",49,2 2,1,"PAH", 1,1,115,0)
	803	1. "I" for Inpatient or "O" fo r Outpatie nt,
	804	"PKG",49,2 2,1,"PAH", 1,1,116,0)
	805	2. "/" for ward slash character
	806	"PKG",49,2 2,1,"PAH", 1,1,117,0)
	807	3. "P" for Professio nal or "I" for Insti tutional
	808	"PKG",49,2 2,1,"PAH", 1,1,118,0)
	809	4. "/" for ward slash character
	810	"PKG",49,2 2,1,"PAH", 1,1,119,0)
	811	5. "P" for Prostheti cs or "R" for Prescr iptions
	812	"PKG",49,2 2,1,"PAH", 1,1,120,0)
	813
	814	"PKG",49,2 2,1,"PAH", 1,1,121,0)
	815	12.) Three new Third Party Ins urance Rat e Types sh all be cre ated in
	816	"PKG",49,2 2,1,"PAH", 1,1,122,0)
	817	the VistA IB Suite f or the bil lers to ch oose from when billi ng for
	818	"PKG",49,2 2,1,"PAH", 1,1,123,0)
	819	encounters . They are as follow s:
	820	"PKG",49,2 2,1,"PAH", 1,1,124,0)
	821	HU MANITARIAN REIMB. IN S.
	822	"PKG",49,2 2,1,"PAH", 1,1,125,0)
	823	DE NTAL REIMB . INS.
	824	"PKG",49,2 2,1,"PAH", 1,1,126,0)
	825	IN ELIGIBLE R EIMB. INS.
	826	"PKG",49,2 2,1,"PAH", 1,1,127,0)
	827
	828	"PKG",49,2 2,1,"PAH", 1,1,128,0)
	829	13.) Each of the new rate type s above wi ll have th e 'Insurer ' as the
	830	"PKG",49,2 2,1,"PAH", 1,1,129,0)
	831	responsibl e party.
	832	"PKG",49,2 2,1,"PAH", 1,1,130,0)
	833
	834	"PKG",49,2 2,1,"PAH", 1,1,131,0)
	835	14.) Bille rs (revenu e staff) s hould be a ble to ide ntify any remaining
	836	"PKG",49,2 2,1,"PAH", 1,1,132,0)
	837	charges to the patie nt after t he Third P arty payme nts are re ceived for
	838	"PKG",49,2 2,1,"PAH", 1,1,133,0)
	839	Emergency Humanitari an, Inelig ible and D ental serv ices so th ey can
	840	"PKG",49,2 2,1,"PAH", 1,1,134,0)
	841	accomplish balance b illing.
	842	"PKG",49,2 2,1,"PAH", 1,1,135,0)
	843
	844	"PKG",49,2 2,1,"PAH", 1,1,136,0)
	845
	846	"PKG",49,2 2,1,"PAH", 1,1,137,0)
	847
	848	"PKG",49,2 2,1,"PAH", 1,1,138,0)
	849	Concurrent Developme nt / Depen dencies:
	850	"PKG",49,2 2,1,"PAH", 1,1,139,0)
	851	---------- ---------- ---------- --------
	852	"PKG",49,2 2,1,"PAH", 1,1,140,0)
	853	N/A
	854	"PKG",49,2 2,1,"PAH", 1,1,141,0)
	855
	856	"PKG",49,2 2,1,"PAH", 1,1,142,0)
	857
	858	"PKG",49,2 2,1,"PAH", 1,1,143,0)
	859	Patch Comp onents:
	860	"PKG",49,2 2,1,"PAH", 1,1,144,0)
	861	---------- -------
	862	"PKG",49,2 2,1,"PAH", 1,1,145,0)
	863
	864	"PKG",49,2 2,1,"PAH", 1,1,146,0)
	865	Files & Fi elds Assoc iated:
	866	"PKG",49,2 2,1,"PAH", 1,1,147,0)
	867
	868	"PKG",49,2 2,1,"PAH", 1,1,148,0)
	869	File Name (Number) Field Na me (Number ) New/ Modified/D eleted
	870	"PKG",49,2 2,1,"PAH", 1,1,149,0)
	871	---------- -------- -------- ---------- - ---- ---------- ------
	872	"PKG",49,2 2,1,"PAH", 1,1,150,0)
	873	N/A
	874	"PKG",49,2 2,1,"PAH", 1,1,151,0)
	875
	876	"PKG",49,2 2,1,"PAH", 1,1,152,0)
	877	Options As sociated:
	878	"PKG",49,2 2,1,"PAH", 1,1,153,0)
	879
	880	"PKG",49,2 2,1,"PAH", 1,1,154,0)
	881	Option Nam e Type New/ Modified/D eleted
	882	"PKG",49,2 2,1,"PAH", 1,1,155,0)
	883	---------- - ---- ---- ---------- ------
	884	"PKG",49,2 2,1,"PAH", 1,1,156,0)
	885	IBT SUP MA NUALLY QUE PRSTHTCS ROUTINE NEW
	886	"PKG",49,2 2,1,"PAH", 1,1,157,0)
	887
	888	"PKG",49,2 2,1,"PAH", 1,1,158,0)
	889	Protocols Associated :
	890	"PKG",49,2 2,1,"PAH", 1,1,159,0)
	891
	892	"PKG",49,2 2,1,"PAH", 1,1,160,0)
	893	Protocol N ame New /Modified/ Deleted
	894	"PKG",49,2 2,1,"PAH", 1,1,161,0)
	895	---------- --- --- ---------- -------
	896	"PKG",49,2 2,1,"PAH", 1,1,162,0)
	897	N/A
	898	"PKG",49,2 2,1,"PAH", 1,1,163,0)
	899
	900	"PKG",49,2 2,1,"PAH", 1,1,164,0)
	901	Templates Associated :
	902	"PKG",49,2 2,1,"PAH", 1,1,165,0)
	903
	904	"PKG",49,2 2,1,"PAH", 1,1,166,0)
	905	Template N ame T ype File Name (Num ber) New/Mod/De l
	906	"PKG",49,2 2,1,"PAH", 1,1,167,0)
	907	---------- --- - --- ---- ---------- ---- ---------- -
	908	"PKG",49,2 2,1,"PAH", 1,1,168,0)
	909	IBJT ACTIV E LIST L IST NEW
	910	"PKG",49,2 2,1,"PAH", 1,1,169,0)
	911	IBJT INACT IVE LIST L IST NEW
	912	"PKG",49,2 2,1,"PAH", 1,1,170,0)
	913
	914	"PKG",49,2 2,1,"PAH", 1,1,171,0)
	915	New Servic e Requests (NSRs):
	916	"PKG",49,2 2,1,"PAH", 1,1,172,0)
	917	---------- ---------- --------
	918	"PKG",49,2 2,1,"PAH", 1,1,173,0)
	919	20150505 - Revenue R eporting E nhancement s
	920	"PKG",49,2 2,1,"PAH", 1,1,174,0)
	921	20150506 - Revenue E ligibility Enhanceme nts
	922	"PKG",49,2 2,1,"PAH", 1,1,175,0)
	923	20150507 - Revenue O perations Enhancemen ts
	924	"PKG",49,2 2,1,"PAH", 1,1,176,0)
	925
	926	"PKG",49,2 2,1,"PAH", 1,1,177,0)
	927
	928	"PKG",49,2 2,1,"PAH", 1,1,178,0)
	929	Patient Sa fety Issue s (PSIs):
	930	"PKG",49,2 2,1,"PAH", 1,1,179,0)
	931	---------- ---------- ----------
	932	"PKG",49,2 2,1,"PAH", 1,1,180,0)
	933	N/A
	934	"PKG",49,2 2,1,"PAH", 1,1,181,0)
	935
	936	"PKG",49,2 2,1,"PAH", 1,1,182,0)
	937
	938	"PKG",49,2 2,1,"PAH", 1,1,183,0)
	939	Remedy Tic ket(s) & O verviews:
	940	"PKG",49,2 2,1,"PAH", 1,1,184,0)
	941	---------- ---------- ---------
	942	"PKG",49,2 2,1,"PAH", 1,1,185,0)
	943	N/A
	944	"PKG",49,2 2,1,"PAH", 1,1,186,0)
	945
	946	"PKG",49,2 2,1,"PAH", 1,1,187,0)
	947	Test Sites :
	948	"PKG",49,2 2,1,"PAH", 1,1,188,0)
	949	----------
	950	"PKG",49,2 2,1,"PAH", 1,1,189,0)
	951	Durham VAM C
	952	"PKG",49,2 2,1,"PAH", 1,1,190,0)
	953
	954	"PKG",49,2 2,1,"PAH", 1,1,191,0)
	955
	956	"PKG",49,2 2,1,"PAH", 1,1,192,0)
	957	Software a nd Documen tation Ret rieval Ins tructions:
	958	"PKG",49,2 2,1,"PAH", 1,1,193,0)
	959	---------- ---------- ---------- ---------- ---------- --
	960	"PKG",49,2 2,1,"PAH", 1,1,194,0)
	961	Patches fo r this ins tallation are combin ed in host file
	962	"PKG",49,2 2,1,"PAH", 1,1,195,0)
	963	IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
	964	"PKG",49,2 2,1,"PAH", 1,1,196,0)
	965
	966	"PKG",49,2 2,1,"PAH", 1,1,197,0)
	967	Installati on of this host file should be coordinat ed among t he package s
	968	"PKG",49,2 2,1,"PAH", 1,1,198,0)
	969	affected s ince only one instal lation is necessary.
	970	"PKG",49,2 2,1,"PAH", 1,1,199,0)
	971
	972	"PKG",49,2 2,1,"PAH", 1,1,200,0)
	973	The patche s are:
	974	"PKG",49,2 2,1,"PAH", 1,1,201,0)
	975
	976	"PKG",49,2 2,1,"PAH", 1,1,202,0)
	977	IB2. 0568
	978	"PKG",49,2 2,1,"PAH", 1,1,203,0)
	979	PRCA* 4.5*315
	980	"PKG",49,2 2,1,"PAH", 1,1,204,0)
	981	PSO7 .0463
	982	"PKG",49,2 2,1,"PAH", 1,1,205,0)
	983
	984	"PKG",49,2 2,1,"PAH", 1,1,206,0)
	985
	986	"PKG",49,2 2,1,"PAH", 1,1,207,0)
	987	Sites may retrieve t he KIDS bu ild in one of the fo llowing wa ys:
	988	"PKG",49,2 2,1,"PAH", 1,1,208,0)
	989
	990	"PKG",49,2 2,1,"PAH", 1,1,209,0)
	991	(1) The pr eferred me thod is to FTP the f iles from
	992	"PKG",49,2 2,1,"PAH", 1,1,210,0)
	993	download. DNS . URL which wil l transmit the files from the first
	994	"PKG",49,2 2,1,"PAH", 1,1,211,0)
	995	available FTP server .
	996	"PKG",49,2 2,1,"PAH", 1,1,212,0)
	997
	998	"PKG",49,2 2,1,"PAH", 1,1,213,0)
	999	(2) Sites may also e lect to re trieve the patch dir ectly from a specifi c
	1000	"PKG",49,2 2,1,"PAH", 1,1,214,0)
	1001	server as follows:
	1002	"PKG",49,2 2,1,"PAH", 1,1,215,0)
	1003
	1004	"PKG",49,2 2,1,"PAH", 1,1,216,0)
	1005	OIFO FTP ADDRE SS DIRECTORY
	1006	"PKG",49,2 2,1,"PAH", 1,1,217,0)
	1007	-------- ------ --------- ---------- ----- ---------- --------
	1008	"PKG",49,2 2,1,"PAH", 1,1,218,0)
	1009	Albany DNS . URL anonymous. software
	1010	"PKG",49,2 2,1,"PAH", 1,1,219,0)
	1011	Hines DNS . URL anonymous. software
	1012	"PKG",49,2 2,1,"PAH", 1,1,220,0)
	1013	Salt Lake City DNS . URL anonymous. software
	1014	"PKG",49,2 2,1,"PAH", 1,1,221,0)
	1015
	1016	"PKG",49,2 2,1,"PAH", 1,1,222,0)
	1017
	1018	"PKG",49,2 2,1,"PAH", 1,1,223,0)
	1019	Sites may retrieve d ocumentati on directl y using Se cure File Transfer
	1020	"PKG",49,2 2,1,"PAH", 1,1,224,0)
	1021	Protocol ( SFTP) from the ANONY MOUS.SOFTW ARE direct ory at the following
	1022	"PKG",49,2 2,1,"PAH", 1,1,225,0)
	1023	OI Field O ffices:
	1024	"PKG",49,2 2,1,"PAH", 1,1,226,0)
	1025
	1026	"PKG",49,2 2,1,"PAH", 1,1,227,0)
	1027	Albany: DNS.URL
	1028	"PKG",49,2 2,1,"PAH", 1,1,228,0)
	1029	Hines: DNS .U RL
	1030	"PKG",49,2 2,1,"PAH", 1,1,229,0)
	1031	Salt Lake City: DNS . URL
	1032	"PKG",49,2 2,1,"PAH", 1,1,230,0)
	1033
	1034	"PKG",49,2 2,1,"PAH", 1,1,231,0)
	1035	Documentat ion can al so be foun d on the V A Software Documenta tion
	1036	"PKG",49,2 2,1,"PAH", 1,1,232,0)
	1037	Library at :
	1038	"PKG",49,2 2,1,"PAH", 1,1,233,0)
	1039	http:// URL /
	1040	"PKG",49,2 2,1,"PAH", 1,1,234,0)
	1041
	1042	"PKG",49,2 2,1,"PAH", 1,1,235,0)
	1043	Title File Name FTP Mod e
	1044	"PKG",49,2 2,1,"PAH", 1,1,236,0)
	1045	---------- ---------- ---------- ---------- ---------- ---------- ---------- -
	1046	"PKG",49,2 2,1,"PAH", 1,1,237,0)
	1047	Integrated Billing U ser Guide ib_2_0_um .doc Binar y
	1048	"PKG",49,2 2,1,"PAH", 1,1,238,0)
	1049	Integrated Billing T echnical M anual/Secu rity Guide ib_2_0_tm .doc Binar y
	1050	"PKG",49,2 2,1,"PAH", 1,1,239,0)
	1051	Integrated Billing D eployment, Installat ion,
	1052	"PKG",49,2 2,1,"PAH", 1,1,240,0)
	1053	Back- Out, and R ollback Gu ide
	1054	"PKG",49,2 2,1,"PAH", 1,1,241,0)
	1055	FY16Re venueIBVIP _Deploymen t_Installa tion_Guide .doc Binar y
	1056	"PKG",49,2 2,1,"PAH", 1,1,242,0)
	1057
	1058	"PKG",49,2 2,1,"PAH", 1,1,243,0)
	1059
	1060	"PKG",49,2 2,1,"PAH", 1,1,244,0)
	1061
	1062	"PKG",49,2 2,1,"PAH", 1,1,245,0)
	1063	Patch Inst allation:
	1064	"PKG",49,2 2,1,"PAH", 1,1,246,0)
	1065
	1066	"PKG",49,2 2,1,"PAH", 1,1,247,0)
	1067	Pre/Post I nstallatio n Overview :
	1068	"PKG",49,2 2,1,"PAH", 1,1,248,0)
	1069	---------- ---------- ---------- -
	1070	"PKG",49,2 2,1,"PAH", 1,1,249,0)
	1071	The post i nstallatio n routine, IBY568PO, is not au tomaticall y deleted
	1072	"PKG",49,2 2,1,"PAH", 1,1,250,0)
	1073	as part of the insta llation pr ocess. You may delet e it after
	1074	"PKG",49,2 2,1,"PAH", 1,1,251,0)
	1075	installati on if you desire.
	1076	"PKG",49,2 2,1,"PAH", 1,1,252,0)
	1077
	1078	"PKG",49,2 2,1,"PAH", 1,1,253,0)
	1079	Pre-Instal lation Ins tructions:
	1080	"PKG",49,2 2,1,"PAH", 1,1,254,0)
	1081	---------- ---------- ----------
	1082	"PKG",49,2 2,1,"PAH", 1,1,255,0)
	1083	N/A
	1084	"PKG",49,2 2,1,"PAH", 1,1,256,0)
	1085
	1086	"PKG",49,2 2,1,"PAH", 1,1,257,0)
	1087	Installati on Instruc tions:
	1088	"PKG",49,2 2,1,"PAH", 1,1,258,0)
	1089	---------- ---------- ------
	1090	"PKG",49,2 2,1,"PAH", 1,1,259,0)
	1091	This proce ss will in stall new and update d routines and other
	1092	"PKG",49,2 2,1,"PAH", 1,1,260,0)
	1093	components listed ab ove. There is a post -install r outine tha t will add
	1094	"PKG",49,2 2,1,"PAH", 1,1,261,0)
	1095	entries to a number of files.
	1096	"PKG",49,2 2,1,"PAH", 1,1,262,0)
	1097
	1098	"PKG",49,2 2,1,"PAH", 1,1,263,0)
	1099	The patch will be re leased in conjunctio n with an Accounts R eceivable
	1100	"PKG",49,2 2,1,"PAH", 1,1,264,0)
	1101	patch, PRC A4.5315 and an Out patient Ph armacy pat ch, PSO7. 0463.
	1102	"PKG",49,2 2,1,"PAH", 1,1,265,0)
	1103
	1104	"PKG",49,2 2,1,"PAH", 1,1,266,0)
	1105	****** ****** ** NOT E **** ****** ****
	1106	"PKG",49,2 2,1,"PAH", 1,1,267,0)
	1107	IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS
	1108	"PKG",49,2 2,1,"PAH", 1,1,268,0)
	1109	AN EDITE D ERROR WI LL OCCUR.
	1110	"PKG",49,2 2,1,"PAH", 1,1,269,0)
	1111	The patc h should b e installe d when NO Outpatient
	1112	"PKG",49,2 2,1,"PAH", 1,1,270,0)
	1113	Pharmacy users are on the sy stem.
	1114	"PKG",49,2 2,1,"PAH", 1,1,271,0)
	1115	****** ****** ****** ****** ****** ****
	1116	"PKG",49,2 2,1,"PAH", 1,1,272,0)
	1117
	1118	"PKG",49,2 2,1,"PAH", 1,1,273,0)
	1119	Installat ion will t ake less t han 1 minu te.
	1120	"PKG",49,2 2,1,"PAH", 1,1,274,0)
	1121
	1122	"PKG",49,2 2,1,"PAH", 1,1,275,0)
	1123	Suggested time to i nstall: no n-peak req uirement h ours.
	1124	"PKG",49,2 2,1,"PAH", 1,1,276,0)
	1125
	1126	"PKG",49,2 2,1,"PAH", 1,1,277,0)
	1127
	1128	"PKG",49,2 2,1,"PAH", 1,1,278,0)
	1129	1. Obtai n the file IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID.
	1130	"PKG",49,2 2,1,"PAH", 1,1,279,0)
	1131
	1132	"PKG",49,2 2,1,"PAH", 1,1,280,0)
	1133	2. From the Kernel Installat ion & Dist ribution S ystem menu , select
	1134	"PKG",49,2 2,1,"PAH", 1,1,281,0)
	1135	the I nstallatio n menu.
	1136	"PKG",49,2 2,1,"PAH", 1,1,282,0)
	1137
	1138	"PKG",49,2 2,1,"PAH", 1,1,283,0)
	1139	3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
	1140	"PKG",49,2 2,1,"PAH", 1,1,284,0)
	1141	promp ted to Ent er a Host File name. You may need to ap pend a
	1142	"PKG",49,2 2,1,"PAH", 1,1,285,0)
	1143	direc tory name.
	1144	"PKG",49,2 2,1,"PAH", 1,1,286,0)
	1145
	1146	"PKG",49,2 2,1,"PAH", 1,1,287,0)
	1147	4. From this menu, you may s elect to u se the fol lowing opt ions
	1148	"PKG",49,2 2,1,"PAH", 1,1,288,0)
	1149	(when prompted for INSTAL L NAME, en ter IB2.0 568):
	1150	"PKG",49,2 2,1,"PAH", 1,1,289,0)
	1151	a . Verify Checksums in Transpo rt Global - This opt ion will
	1152	"PKG",49,2 2,1,"PAH", 1,1,290,0)
	1153	allow y ou to ensu re the int egrity of the routin es that
	1154	"PKG",49,2 2,1,"PAH", 1,1,291,0)
	1155	are in the transp ort global .
	1156	"PKG",49,2 2,1,"PAH", 1,1,292,0)
	1157	b . Print T ransport G lobal - Th is option will allow you to
	1158	"PKG",49,2 2,1,"PAH", 1,1,293,0)
	1159	view th e componen ts of the KIDS build .
	1160	"PKG",49,2 2,1,"PAH", 1,1,294,0)
	1161	c . Compare Transport Global to Current S ystem - Th is option
	1162	"PKG",49,2 2,1,"PAH", 1,1,295,0)
	1163	will al low you to view all changes th at will be made when
	1164	"PKG",49,2 2,1,"PAH", 1,1,296,0)
	1165	this pa tch is ins talled. I t compares all compo nents of
	1166	"PKG",49,2 2,1,"PAH", 1,1,297,0)
	1167	this pa tch (routi nes, DD's, templates , etc.).
	1168	"PKG",49,2 2,1,"PAH", 1,1,298,0)
	1169	d . Backup a Transpor t Global - This opti on will cr eate a
	1170	"PKG",49,2 2,1,"PAH", 1,1,299,0)
	1171	backup message of any routi nes export ed with th is patch.
	1172	"PKG",49,2 2,1,"PAH", 1,1,300,0)
	1173	It will not backu p any othe r changes such as DD 's or
	1174	"PKG",49,2 2,1,"PAH", 1,1,301,0)
	1175	templat es.
	1176	"PKG",49,2 2,1,"PAH", 1,1,302,0)
	1177
	1178	"PKG",49,2 2,1,"PAH", 1,1,303,0)
	1179	5. When prompted " Want KIDS to INHIBIT LOGONs du ring the i nstall?
	1180	"PKG",49,2 2,1,"PAH", 1,1,304,0)
	1181	NO//" respond NO.
	1182	"PKG",49,2 2,1,"PAH", 1,1,305,0)
	1183
	1184	"PKG",49,2 2,1,"PAH", 1,1,306,0)
	1185	6. When prompted " Want to DI SABLE Sche duled Opti ons, Menu Options,
	1186	"PKG",49,2 2,1,"PAH", 1,1,307,0)
	1187	and P rotocols? NO//" resp ond NO.
	1188	"PKG",49,2 2,1,"PAH", 1,1,308,0)
	1189
	1190	"PKG",49,2 2,1,"PAH", 1,1,309,0)
	1191
	1192	"PKG",49,2 2,1,"PAH", 1,1,310,0)
	1193
	1194	"PKG",49,2 2,1,"PAH", 1,1,311,0)
	1195	Post-Insta llation In structions :
	1196	"PKG",49,2 2,1,"PAH", 1,1,312,0)
	1197	---------- ---------- ---------- -
	1198	"PKG",49,2 2,1,"PAH", 1,1,313,0)
	1199	There are no special tasks to perform af ter this p atch insta llation.
	1200	"QUES","XP F1",0)
	1201	Y
	1202	"QUES","XP F1","??")
	1203	^D REP^XPD H
	1204	"QUES","XP F1","A")
	1205	Shall I wr ite over y our \|FLAG\| File
	1206	"QUES","XP F1","B")
	1207	YES
	1208	"QUES","XP F1","M")
	1209	D XPF1^XPD IQ
	1210	"QUES","XP F2",0)
	1211	Y
	1212	"QUES","XP F2","??")
	1213	^D DTA^XPD H
	1214	"QUES","XP F2","A")
	1215	Want my da ta \|FLAG\| yours
	1216	"QUES","XP F2","B")
	1217	YES
	1218	"QUES","XP F2","M")
	1219	D XPF2^XPD IQ
	1220	"QUES","XP I1",0)
	1221	YO
	1222	"QUES","XP I1","??")
	1223	^D INHIBIT ^XPDH
	1224	"QUES","XP I1","A")
	1225	Want KIDS to INHIBIT LOGONs du ring the i nstall
	1226	"QUES","XP I1","B")
	1227	NO
	1228	"QUES","XP I1","M")
	1229	D XPI1^XPD IQ
	1230	"QUES","XP M1",0)
	1231	PO^VA(200, :EM
	1232	"QUES","XP M1","??")
	1233	^D MG^XPDH
	1234	"QUES","XP M1","A")
	1235	Enter the Coordinato r for Mail Group '\|F LAG\|'
	1236	"QUES","XP M1","B")
	1237
	1238	"QUES","XP M1","M")
	1239	D XPM1^XPD IQ
	1240	"QUES","XP O1",0)
	1241	Y
	1242	"QUES","XP O1","??")
	1243	^D MENU^XP DH
	1244	"QUES","XP O1","A")
	1245	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	1246	"QUES","XP O1","B")
	1247	NO
	1248	"QUES","XP O1","M")
	1249	D XPO1^XPD IQ
	1250	"QUES","XP Z1",0)
	1251	Y
	1252	"QUES","XP Z1","??")
	1253	^D OPT^XPD H
	1254	"QUES","XP Z1","A")
	1255	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	1256	"QUES","XP Z1","B")
	1257	NO
	1258	"QUES","XP Z1","M")
	1259	D XPZ1^XPD IQ
	1260	"QUES","XP Z2",0)
	1261	Y
	1262	"QUES","XP Z2","??")
	1263	^D RTN^XPD H
	1264	"QUES","XP Z2","A")
	1265	Want to MO VE routine s to other CPUs
	1266	"QUES","XP Z2","B")
	1267	NO
	1268	"QUES","XP Z2","M")
	1269	D XPZ2^XPD IQ
	1270	"RTN")
	1271	17
	1272	"RTN","IBC APP")
	1273	0^23^B2315 0807^B2148 5583
	1274	"RTN","IBC APP",1,0)
	1275	IBCAPP ;AL B/WCJ - Cl aims Auto Processing Main Proc esser;27-A UG-10
	1276	"RTN","IBC APP",2,0)
	1277	;;2.0;INT EGRATED BI LLING;*43 2,447,568 *;21-MAR-9 4;Build 40
	1278	"RTN","IBC APP",3,0)
	1279	;;Per VA Directive 6402, this routine s hould not be modifie d.
	1280	"RTN","IBC APP",4,0)
	1281	G AWAY
	1282	"RTN","IBC APP",5,0)
	1283	AWAY Q
	1284	"RTN","IBC APP",6,0)
	1285	;
	1286	"RTN","IBC APP",7,0)
	1287	EN(IBIFN,I BORIG,IBPY MT,IBWLF) ;
	1288	"RTN","IBC APP",8,0)
	1289	; This is called fr om tag BUL L^IBCNSBL2 . It is t he startin g point fo r the clai ms auto-pr ocessing.
	1290	"RTN","IBC APP",9,0)
	1291	; 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
	1292	"RTN","IBC APP",10,0)
	1293	; which w ill evalua te the cla im and per form one o f three ac tions.
	1294	"RTN","IBC APP",11,0)
	1295	; 1) auto -process t he claim t o a subseq uent payer .
	1296	"RTN","IBC APP",12,0)
	1297	; 2) auto -print a c laim in ca se the pay er does no t want to receive se condary/te rtiary cla ims
	1298	electronic ally
	1299	"RTN","IBC APP",13,0)
	1300	; 3) put the claim on the new COB Manag ement work list.
	1301	"RTN","IBC APP",14,0)
	1302	;
	1303	"RTN","IBC APP",15,0)
	1304	; Input : IBIFN -- Poin ter to AR (file #430 ), or Clai m (file #3 99) (same internal n umber goes to files)
	1305	"RTN","IBC APP",16,0)
	1306	; IBORIG -- Orig inal amoun t of the c laim
	1307	"RTN","IBC APP",17,0)
	1308	; IBPYMT -- Tota l Amount p aid on the claim
	1309	"RTN","IBC APP",18,0)
	1310	; IBWLF -- 1 or 2 if it s hould go s traight to the work list or
	1311	"RTN","IBC APP",19,0)
	1312	; 0 if it should be evalua ted.
	1313	"RTN","IBC APP",20,0)
	1314	;
	1315	"RTN","IBC APP",21,0)
	1316	N IBREASO N,IBX,IBMR ANOT,IBERR MSG,IBEOB, IBINS,Z,IB ,IBF,IBFT, IBNCN,IBDV ,IBREG,IBN CN
	1317	"RTN","IBC APP",22,0)
	1318	S IBMRANO T=1
	1319	"RTN","IBC APP",23,0)
	1320	;
	1321	"RTN","IBC APP",24,0)
	1322	; A speci fic non-hu man user f or all reg 835 EOB f iling proc esses.
	1323	"RTN","IBC APP",25,0)
	1324	; Change the DUZ to be this u ser.
	1325	"RTN","IBC APP",26,0)
	1326	; * Int egration A greement 4 129 - Acti vated on 3 0-June-200 3 *
	1327	"RTN","IBC APP",27,0)
	1328	S IBREG=$ $IBREG()
	1329	"RTN","IBC APP",28,0)
	1330	I IBREG>0 NEW DUZ D DUZ^XUP(I BREG) ; I A#4129
	1331	"RTN","IBC APP",29,0)
	1332	;
	1333	"RTN","IBC APP",30,0)
	1334	; Check i f this is being forc ed to the work list.
	1335	"RTN","IBC APP",31,0)
	1336	;I $G(IBW LF) S IBRE ASON="IB81 3:CHAMPVA Center or TRICARE Fi scal Inter mediary or TRICARE
	1337	Supplement al policy. " D PUTONW L(IBIFN,IB REASON) G ENX ;IB* 2*432
	1338	"RTN","IBC APP",32,0)
	1339	I $G(IBWL F) D G EN X ;IB2 568
	1340	"RTN","IBC APP",33,0)
	1341	.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
	1342	PUTONWL(IB IFN,IBREAS ON) Q
	1343	"RTN","IBC APP",34,0)
	1344	.I IBWLF= 1 S IBREAS ON="IB813: CHAMPVA Ce nter or TR ICARE Fisc al Interme diary or T RICARE
	1345	Supplement al policy. " D PUTONW L(IBIFN,IB REASON) Q
	1346	"RTN","IBC APP",35,0)
	1347	.Q
	1348	"RTN","IBC APP",36,0)
	1349	;
	1350	"RTN","IBC APP",37,0)
	1351	I IBPYMT' <IBORIG D WLCK^IBCNS BL2(IBIFN) Q ; no r eason to c ontinue if nothing e lse owed
	1352	"RTN","IBC APP",38,0)
	1353	;
	1354	"RTN","IBC APP",39,0)
	1355	; Make su re there i s another payer
	1356	"RTN","IBC APP",40,0)
	1357	I '$P($G( ^DGCR(399, IBIFN,"I"_ ($$COBN^IB CEF(IBIFN) +1))),U,1) D WLCK^IB CNSBL2(IBI FN) G ENX
	1358	;IB2432
	1359	"RTN","IBC APP",41,0)
	1360	;
	1361	"RTN","IBC APP",42,0)
	1362	; stop if the subse quent clai m was alre ady create d
	1363	"RTN","IBC APP",43,0)
	1364	I +$P($G( ^DGCR(399, IBIFN,"M1" )),U,$$COB N^IBCEF(IB IFN)+5) D WLCK^IBCNS BL2(IBIFN) G ENX
	1365	;IB2432
	1366	"RTN","IBC APP",44,0)
	1367	;
	1368	"RTN","IBC APP",45,0)
	1369	; 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
	1370	"RTN","IBC APP",46,0)
	1371	I $$WNRBI LL^IBEFUNC (IBIFN,$$C OBN^IBCEF( IBIFN)+1) D Q
	1372	"RTN","IBC APP",47,0)
	1373	.I $D(^DG CR(399,IBI FN,"I3")), '$$WNRBILL ^IBEFUNC(I BIFN,3) D PUTONWL(IB IFN,"IB814 ") Q
	1374	"RTN","IBC APP",48,0)
	1375	.D WLCK^I BCNSBL2(IB IFN) Q
	1376	"RTN","IBC APP",49,0)
	1377	;
	1378	"RTN","IBC APP",50,0)
	1379	; check t he Commerc ial Auto P rocessing criteria
	1380	"RTN","IBC APP",51,0)
	1381	S IBX=$$C RIT^IBCAPP 1(IBIFN,.I BEOB)
	1382	"RTN","IBC APP",52,0)
	1383	;
	1384	"RTN","IBC APP",53,0)
	1385	; If it f ails the c riteria ch eck, put i t on the w ork list
	1386	"RTN","IBC APP",54,0)
	1387	I '+IBX D PUTONWL(I BIFN,$P(IB X,U,2)) G ENX ;IB* 2*432
	1388	"RTN","IBC APP",55,0)
	1389	;
	1390	"RTN","IBC APP",56,0)
	1391	; Auto Pr ocess this bad boy
	1392	"RTN","IBC APP",57,0)
	1393	;
	1394	"RTN","IBC APP",58,0)
	1395	; first c heck that if it's su pposed to be printed locally, the printe rs are def ined.
	1396	"RTN","IBC APP",59,0)
	1397	; if not, put on th e work lis t
	1398	"RTN","IBC APP",60,0)
	1399	; if they are, then fall thro ugh
	1400	"RTN","IBC APP",61,0)
	1401	S Z=$$COB N^IBCEF(IB IFN)+1
	1402	"RTN","IBC APP",62,0)
	1403	S IBINS=$ $POLICY^IB CEF(IBIFN, 1,Z)
	1404	"RTN","IBC APP",63,0)
	1405	S IBWLF=0
	1406	"RTN","IBC APP",64,0)
	1407	I $P($G(^ DIC(36,IBI NS,6)),U,9 )=1 D I I BWLF D PUT ONWL(IBIFN ,IBREASON) G ENX ; IB2432
	1408	"RTN","IBC APP",65,0)
	1409	.I $$EOBP RT^IBCAPR( )="" S IBW LF=1,IBREA SON="IB811 :Auto-prin ter not de fined in I B Site Par ameters"
	1410	Q
	1411	"RTN","IBC APP",66,0)
	1412	.I $$MRAP RT^IBCAPR( )="" S IBW LF=1,IBREA SON="IB811 :Auto-prin ter not de fined in I B Site Par ameters"
	1413	Q
	1414	"RTN","IBC APP",67,0)
	1415	.S IB=$$F T^IBCU3(IB IFN) ; for m type ien (2 or 3)
	1416	"RTN","IBC APP",68,0)
	1417	.I "^2^3^ "'[(U_IB_U ) S IBWLF= 1,IBREASON ="IB810:No Form Type defined" Q
	1418	"RTN","IBC APP",69,0)
	1419	.S IBFT=$ $FTN^IBCU3 (IB) ; for m type nam e
	1420	"RTN","IBC APP",70,0)
	1421	.S IBF=$P ($G(^IBE(3 53,+IB,2)) ,U,8)
	1422	"RTN","IBC APP",71,0)
	1423	.S:IBF="" IBF=IB ;F orces the use of the output fo rmatter to print bil ls
	1424	"RTN","IBC APP",72,0)
	1425	.; get de fault CMS or UB prin ter (based on claim form type)
	1426	"RTN","IBC APP",73,0)
	1427	.S IBDV=$ S(IB=2:$$C MS1500^IBC APR1(),1:$ $UB4PRT^IB CAPR1())
	1428	"RTN","IBC APP",74,0)
	1429	.I IBDV=" " S IBWLF= 1,IBREASON ="IB811:Au to-printer not defin ed in IB S ite Parame ters" Q
	1430	"RTN","IBC APP",75,0)
	1431	I $G(IBRE ASON)]"" D PUTONWL(I BIFN,IBREA SON) G ENX ;IB24 32
	1432	"RTN","IBC APP",76,0)
	1433	;
	1434	"RTN","IBC APP",77,0)
	1435	; create the new cl aim
	1436	"RTN","IBC APP",78,0)
	1437	S IBNCN=" " ; Init ialize New Claim Num ber
	1438	"RTN","IBC APP",79,0)
	1439	D AUTOCOB ^IBCEMQA(I BIFN,IBEOB ,.IBERRMSG ,IBMRANOT, .IBNCN)
	1440	"RTN","IBC APP",80,0)
	1441	;
	1442	"RTN","IBC APP",81,0)
	1443	; make su re everyth ing was co ol with cr eating the new claim .
	1444	"RTN","IBC APP",82,0)
	1445	I $G(IBER RMSG)]""!( '+$G(IBNCN )) S IBREA SON="IB812 :Failed AU TOCOB Gene ration" D
	1446	PUTONWL(IB IFN,IBREAS ON) G ENX ;IB243 2
	1447	"RTN","IBC APP",83,0)
	1448	;
	1449	"RTN","IBC APP",84,0)
	1450	; If it's to be aut o printed, set force to local print flag on new cl aim
	1451	"RTN","IBC APP",85,0)
	1452	S IBINS=$ $POLICY^IB CEF(IBNCN, 1,$$COBN^I BCEF(IBNCN ))
	1453	"RTN","IBC APP",86,0)
	1454	; set fie ld 35 on o riginal cl aim to ind icate subs equent cla im was aut o-created IB2.0447
	1455	"RTN","IBC APP",87,0)
	1456	I $P($G(^ DIC(36,IBI NS,6)),U,9 )=1 D FORC EPRT(IBNCN ),AUTOPRC( $G(IBIFN), 2)
	1457	"RTN","IBC APP",88,0)
	1458	D:$P($G(^ DIC(36,IBI NS,6)),U,9 )'=1 AUTOP RC($G(IBIF N),3)
	1459	"RTN","IBC APP",89,0)
	1460	;
	1461	"RTN","IBC APP",90,0)
	1462	; authori ze the new claim
	1463	"RTN","IBC APP",91,0)
	1464	D AUTH^IB CEMQA(IBNC N,.IBERRMS G,IBMRANOT )
	1465	"RTN","IBC APP",92,0)
	1466	;
	1467	"RTN","IBC APP",93,0)
	1468	; If AUTH error occ urred, fil e the auto matic bill generatio n failure message
	1469	"RTN","IBC APP",94,0)
	1470	I $G(IBER RMSG)]"" D AUTOMSG^I BCESRV3(IB EOB,IBERRM SG) G ENX
	1471	"RTN","IBC APP",95,0)
	1472	;
	1473	"RTN","IBC APP",96,0)
	1474	; If loca l print, t hen print it
	1475	"RTN","IBC APP",97,0)
	1476	I $P($G(^ DIC(36,IBI NS,6)),U,9 )=1 D STFL P^IBCAPR1( IBNCN)
	1477	"RTN","IBC APP",98,0)
	1478	;
	1479	"RTN","IBC APP",99,0)
	1480	ENX ;Qui t and Clea nup of Mai n Entry Po int, added with IB2 432
	1481	"RTN","IBC APP",100,0 )
	1482	;
	1483	"RTN","IBC APP",101,0 )
	1484	; DBIA #1 0111: Allo ws FM read access of ^XMB(3.8, D0,0) usin g DIC.
	1485	"RTN","IBC APP",102,0 )
	1486	S DIC="^X MB(3.8,",D IC(0)="QM" ,X="IB DEV TEAM" D ^ DIC
	1487	"RTN","IBC APP",103,0 )
	1488	;
	1489	"RTN","IBC APP",104,0 )
	1490	Q
	1491	"RTN","IBC APP",105,0 )
	1492	;
	1493	"RTN","IBC APP",106,0 )
	1494	PUTONWL(IB IFN,IBREAS ON) ; Put a claim on the workl ist
	1495	"RTN","IBC APP",107,0 )
	1496	; IBIFN - internal claim numb er
	1497	"RTN","IBC APP",108,0 )
	1498	; IBREASO N - reason why this is being p ut on the worklist ( error code :text)
	1499	"RTN","IBC APP",109,0 )
	1500	;
	1501	"RTN","IBC APP",110,0 )
	1502	N DA,DIE, DR
	1503	"RTN","IBC APP",111,0 )
	1504	S DA=IBIF N
	1505	"RTN","IBC APP",112,0 )
	1506	S DIE="^D GCR(399,"
	1507	"RTN","IBC APP",113,0 )
	1508	S DR="35/ //1" ; place on t he worklis t
	1509	"RTN","IBC APP",114,0 )
	1510	S DR=DR_" ;"_"36///" _$P(IBREAS ON,":") ; why placed on worklist
	1511	"RTN","IBC APP",115,0 )
	1512	D ^DIE
	1513	"RTN","IBC APP",116,0 )
	1514	Q
	1515	"RTN","IBC APP",117,0 )
	1516	;
	1517	"RTN","IBC APP",118,0 )
	1518	AUTOPRC(IB IFN,IBAP) ; record t hat a clai m was auto -processed IB2.044 7
	1519	"RTN","IBC APP",119,0 )
	1520	; IBIFN - internal claim numb er
	1521	"RTN","IBC APP",120,0 )
	1522	; IBAP - 2 = AUTO L OCAL PRINT , 3 = AUTO EDI
	1523	"RTN","IBC APP",121,0 )
	1524	;
	1525	"RTN","IBC APP",122,0 )
	1526	N DA,DIE, DR
	1527	"RTN","IBC APP",123,0 )
	1528	Q:IBIFN=" "
	1529	"RTN","IBC APP",124,0 )
	1530	Q:IBAP=""
	1531	"RTN","IBC APP",125,0 )
	1532	S DA=IBIF N
	1533	"RTN","IBC APP",126,0 )
	1534	S DIE="^D GCR(399,"
	1535	"RTN","IBC APP",127,0 )
	1536	S DR="35/ //"_IBAP ; UPDATE AUTO-PROC ESS FIELD
	1537	"RTN","IBC APP",128,0 )
	1538	D ^DIE
	1539	"RTN","IBC APP",129,0 )
	1540	Q
	1541	"RTN","IBC APP",130,0 )
	1542	;
	1543	"RTN","IBC APP",131,0 )
	1544	FORCEPRT(I BIFN) ; se t force to local pri nt flag in claim
	1545	"RTN","IBC APP",132,0 )
	1546	; IBIFN - internal claim numb er
	1547	"RTN","IBC APP",133,0 )
	1548	;
	1549	"RTN","IBC APP",134,0 )
	1550	N DA,DIE, DR
	1551	"RTN","IBC APP",135,0 )
	1552	S DA=IBIF N
	1553	"RTN","IBC APP",136,0 )
	1554	S DIE="^D GCR(399,"
	1555	"RTN","IBC APP",137,0 )
	1556	S DR="27/ //1" ; Force Lo cal Print
	1557	"RTN","IBC APP",138,0 )
	1558	D ^DIE
	1559	"RTN","IBC APP",139,0 )
	1560	Q
	1561	"RTN","IBC APP",140,0 )
	1562	;
	1563	"RTN","IBC APP",141,0 )
	1564	IBREG() ; Returns IE N (Interna l Entry Nu mber) from file #200 for
	1565	"RTN","IBC APP",142,0 )
	1566	; the Bil l Authoriz er of acce ptable reg ular (non MRA) secon dary claim s,
	1567	"RTN","IBC APP",143,0 )
	1568	; namely, AUTHORIZE R,IB REG
	1569	"RTN","IBC APP",144,0 )
	1570	;
	1571	"RTN","IBC APP",145,0 )
	1572	; Output: -1 i f record n ot on file
	1573	"RTN","IBC APP",146,0 )
	1574	; IEN i f record i s on file
	1575	"RTN","IBC APP",147,0 )
	1576	;
	1577	"RTN","IBC APP",148,0 )
	1578	N DIC,X,Y
	1579	"RTN","IBC APP",149,0 )
	1580	S DIC(0)= "MO",DIC=" ^VA(200,", X="AUTHORI ZER,IB REG "
	1581	"RTN","IBC APP",150,0 )
	1582	; call FM lookup ut ility
	1583	"RTN","IBC APP",151,0 )
	1584	D ^DIC
	1585	"RTN","IBC APP",152,0 )
	1586	; if reco rd is alre ady on fil e, return IEN
	1587	"RTN","IBC APP",153,0 )
	1588	; else r eturn -1
	1589	"RTN","IBC APP",154,0 )
	1590	Q +Y
	1591	"RTN","IBC BB11")
	1592	0^6^B12544 1111^B1120 52327
	1593	"RTN","IBC BB11",1,0)
	1594	IBCBB11 ;A LB/AAS/OIF O-BP/PIJ - CONTINUAT ION OF EDI T CHECK RO UTINE ;12 Jun 2006 3:45 PM
	1595	"RTN","IBC BB11",2,0)
	1596	;;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-
	1597	MAR-94;Bui ld 40
	1598	"RTN","IBC BB11",3,0)
	1599	;;Per VA Directive 6402, this routine s hould not be modifie d.
	1600	"RTN","IBC BB11",4,0)
	1601	;
	1602	"RTN","IBC BB11",5,0)
	1603	WARN(IBDIS P) ; Set w arning in global
	1604	"RTN","IBC BB11",6,0)
	1605	; DISP = warning te xt to disp lay
	1606	"RTN","IBC BB11",7,0)
	1607	;
	1608	"RTN","IBC BB11",8,0)
	1609	N Z
	1610	"RTN","IBC BB11",9,0)
	1611	S Z=+$O(^ TMP($J,"BI LL-WARN"," "),-1)
	1612	"RTN","IBC BB11",10,0 )
	1613	I Z=0 S ^ TMP($J,"BI LL-WARN",1 )=$J("",5) _"Warnin gs:",Z=1
	1614	"RTN","IBC BB11",11,0 )
	1615	S Z=Z+1,^ TMP($J,"BI LL-WARN",Z )=$J("",5) _IBDISP
	1616	"RTN","IBC BB11",12,0 )
	1617	Q
	1618	"RTN","IBC BB11",13,0 )
	1619	;
	1620	"RTN","IBC BB11",14,0 )
	1621	MULTDIV(IB IFN,IBND0) ; Check f or multipl e division s on a bil l ien IBIF N
	1622	"RTN","IBC BB11",15,0 )
	1623	; IBND0 = 0-node of bill
	1624	"RTN","IBC BB11",16,0 )
	1625	;
	1626	"RTN","IBC BB11",17,0 )
	1627	; Functi on returns 1 if more than 1 di vision fou nd on bill
	1628	"RTN","IBC BB11",18,0 )
	1629	N Z,Z0,Z1 ,MULT
	1630	"RTN","IBC BB11",19,0 )
	1631	S MULT=0, Z1=$P(IBND 0,U,22)
	1632	"RTN","IBC BB11",20,0 )
	1633	I Z1 D
	1634	"RTN","IBC BB11",21,0 )
	1635	. 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
	1636	"RTN","IBC BB11",22,0 )
	1637	. 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
	1638	"RTN","IBC BB11",23,0 )
	1639	I 'Z1 S M ULT=3
	1640	"RTN","IBC BB11",24,0 )
	1641	Q MULT
	1642	"RTN","IBC BB11",25,0 )
	1643	;
	1644	"RTN","IBC BB11",26,0 )
	1645	;; PREGNA NCY DX COD ES: V22- V24, V27 -V28, 630*-677 *
	1646	"RTN","IBC BB11",27,0 )
	1647	;; FLU SH OTS PROCED URE CODES: 90724, G0 008, 90732 , G0009
	1648	"RTN","IBC BB11",28,0 )
	1649	;
	1650	"RTN","IBC BB11",29,0 )
	1651	NPICHK ; C heck for r equired NP Is
	1652	"RTN","IBC BB11",30,0 )
	1653	N IBNPIS, IBNONPI,IB NPIREQ,Z,I BNFI,IBTF, IBWC,IBXSA VE,IBPRV,I BLINE,IBPR VNT1,IBPRV NT2
	1654	"RTN","IBC BB11",31,0 )
	1655	;*** pij start IB2 0436 ***
	1656	"RTN","IBC BB11",32,0 )
	1657	N IBRATYP E,IBLEGAL
	1658	"RTN","IBC BB11",33,0 )
	1659	S (IBRATY PE,IBLEGAL )=""
	1660	"RTN","IBC BB11",34,0 )
	1661	S IBRATYP E=$P($G(^D GCR(399,IB IFN,0)),U, 7)
	1662	"RTN","IBC BB11",35,0 )
	1663	; Legal t ypes for t his use.
	1664	"RTN","IBC BB11",36,0 )
	1665	; 7=NO F AULT INS.
	1666	"RTN","IBC BB11",37,0 )
	1667	; 10=TORT FEASOR
	1668	"RTN","IBC BB11",38,0 )
	1669	; 11=WORK ERS' COMP.
	1670	"RTN","IBC BB11",39,0 )
	1671	S IBNFI=$ O(^DGCR(39 9.3,"B","N O FAULT IN S.",0)) S: 'IBNFI IBN FI=7
	1672	"RTN","IBC BB11",40,0 )
	1673	S IBTF=$O (^DGCR(399 .3,"B","TO RT FEASOR" ,0)) S:'IB TF IBTF=10
	1674	"RTN","IBC BB11",41,0 )
	1675	S IBWC=$O (^DGCR(399 .3,"B","WO RKERS' COM P.",0)) S: 'IBWC IBWC =11
	1676	"RTN","IBC BB11",42,0 )
	1677	;
	1678	"RTN","IBC BB11",43,0 )
	1679	I IBRATYP E=IBNFI!(I BRATYPE=IB TF)!(IBRAT YPE=IBWC) D
	1680	"RTN","IBC BB11",44,0 )
	1681	. ; One o f the lega l types - force loca l print
	1682	"RTN","IBC BB11",45,0 )
	1683	. S IBLEG AL=1
	1684	"RTN","IBC BB11",46,0 )
	1685	;* pij end *
	1686	"RTN","IBC BB11",47,0 )
	1687	S IBNPIRE Q=$$NPIREQ ^IBCEP81(D T) ; Chec k if NPI i s required
	1688	"RTN","IBC BB11",48,0 )
	1689	; Check p roviders
	1690	"RTN","IBC BB11",49,0 )
	1691	; IB2.0 432 change d the NPI check to t he new Pro vider Arra y
	1692	"RTN","IBC BB11",50,0 )
	1693	;S IBNPIS =$$PROVNPI ^IBCEF73A( IBIFN,.IBN ONPI)
	1694	"RTN","IBC BB11",51,0 )
	1695	D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1)
	1696	"RTN","IBC BB11",52,0 )
	1697	S IBPRV=" "
	1698	"RTN","IBC BB11",53,0 )
	1699	F S IBPR V=$O(IBXSA VE("PROVIN F",IBIFN," C",1,IBPRV )) Q:'IBPR V D
	1700	"RTN","IBC BB11",54,0 )
	1701	. I $P($G (IBXSAVE(" PROVINF",I BIFN,"C",1 ,IBPRV,0)) ,U,4)="" S IBNONPI(I BPRV)=""
	1702	"RTN","IBC BB11",55,0 )
	1703	S IBLINE= ""
	1704	"RTN","IBC BB11",56,0 )
	1705	F S IBLI NE=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE)) Q: 'IBLINE D
	1706	"RTN","IBC BB11",57,0 )
	1707	. S IBPRV =""
	1708	"RTN","IBC BB11",58,0 )
	1709	. F S IB PRV=$O(IBX SAVE("L-PR OV",IBIFN, IBLINE,"C" ,1,IBPRV)) Q:IBPRV=" " D
	1710	"RTN","IBC BB11",59,0 )
	1711	.. I $P($ G(IBXSAVE( "L-PROV",I BIFN,IBLIN E,"C",1,IB PRV,0)),U, 4)="" S IB NONPI(IBPR V)=""
	1712	"RTN","IBC BB11",60,0 )
	1713	I $D(IBNO NPI) S IBP RV="" F S IBPRV=$O( IBNONPI(IB PRV)) Q:'I BPRV D
	1714	"RTN","IBC BB11",61,0 )
	1715	. S IBER= IBER_"IB"_ (140+IBPRV )_";" Q ; If requir ed, set er ror IB25 16
	1716	"RTN","IBC BB11",62,0 )
	1717	; Check o rganizatio ns
	1718	"RTN","IBC BB11",63,0 )
	1719	S IBNONPI =""
	1720	"RTN","IBC BB11",64,0 )
	1721	S IBNPIS= $$ORGNPI^I BCEF73A(IB IFN,.IBNON PI)
	1722	"RTN","IBC BB11",65,0 )
	1723	I $L(IBNO NPI) F Z=1 :1:$L(IBNO NPI,U) D
	1724	"RTN","IBC BB11",66,0 )
	1725	. S IBER= IBER_$P("I B339;^IB34 0;^IB341;" ,U,$P(IBNO NPI,U,Z)) ; DEM;432 Added NPI errors.
	1726	"RTN","IBC BB11",67,0 )
	1727	Q
	1728	"RTN","IBC BB11",68,0 )
	1729	;
	1730	"RTN","IBC BB11",69,0 )
	1731	TAXCHK ; C heck for r equired ta xonomies
	1732	"RTN","IBC BB11",70,0 )
	1733	N IBDT,IB LINE,IBNOT AX,IBNOTAX 1,IBNOTAX2 ,IBPRV,IBT AXS,IBXSAV E,Z
	1734	"RTN","IBC BB11",71,0 )
	1735	;
	1736	"RTN","IBC BB11",72,0 )
	1737	; MRD;IB* 2.0*516 - This check is now mo ot; 'today ' is alway s on or
	1738	"RTN","IBC BB11",73,0 )
	1739	; after M ay 23, 200 8, so taxo nomy codes are alway s required
	1740	"RTN","IBC BB11",74,0 )
	1741	; for cer tain provi ders.
	1742	"RTN","IBC BB11",75,0 )
	1743	;S IBTAXR EQ=$$TAXRE Q^IBCEP81( DT) ; Che ck if taxo nomy is re quired
	1744	"RTN","IBC BB11",76,0 )
	1745	;
	1746	"RTN","IBC BB11",77,0 )
	1747	; Check p roviders
	1748	"RTN","IBC BB11",78,0 )
	1749	; IB2.0 432 change d the Taxo nomy check to the ne w Provider Array
	1750	"RTN","IBC BB11",79,0 )
	1751	;S IBTAXS =$$PROVTAX ^IBCEF73A( IBIFN,.IBN OTAX)
	1752	"RTN","IBC BB11",80,0 )
	1753	D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1)
	1754	"RTN","IBC BB11",81,0 )
	1755	S IBPRV=" "
	1756	"RTN","IBC BB11",82,0 )
	1757	F S IBPR V=$O(IBXSA VE("PROVIN F",IBIFN," C",1,IBPRV )) Q:'IBPR V D
	1758	"RTN","IBC BB11",83,0 )
	1759	. I $G(IB XSAVE("PRO VINF",IBIF N,"C",1,IB PRV,"TAXON OMY"))="" D
	1760	"RTN","IBC BB11",84,0 )
	1761	.. S IBNO TAX(IBPRV) =""
	1762	"RTN","IBC BB11",85,0 )
	1763	.. S IBNO TAX1=$P(IB XSAVE("PRO VINF",IBIF N,"C",1,IB PRV),";",1 ) ; New v ariables I BNOTAX1 an d
	1764	IBNOTAX2 f or IB2.0 568 - Deac tivated Pr ovider
	1765	"RTN","IBC BB11",86,0 )
	1766	.. S IBNO TAX2(IBPRV ,IBNOTAX1) =""
	1767	"RTN","IBC BB11",87,0 )
	1768	.. Q
	1769	"RTN","IBC BB11",88,0 )
	1770	. Q
	1771	"RTN","IBC BB11",89,0 )
	1772	;
	1773	"RTN","IBC BB11",90,0 )
	1774	S IBLINE= ""
	1775	"RTN","IBC BB11",91,0 )
	1776	F S IBLI NE=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE)) Q: 'IBLINE D
	1777	"RTN","IBC BB11",92,0 )
	1778	. S IBPRV =""
	1779	"RTN","IBC BB11",93,0 )
	1780	. F S IB PRV=$O(IBX SAVE("L-PR OV",IBIFN, IBLINE,"C" ,1,IBPRV)) Q:IBPRV=" " D
	1781	"RTN","IBC BB11",94,0 )
	1782	.. I $G(I BXSAVE("L- PROV",IBIF N,IBLINE," C",1,IBPRV ,"TAXONOMY "))="" D
	1783	"RTN","IBC BB11",95,0 )
	1784	... S IBN OTAX(IBPRV )=""
	1785	"RTN","IBC BB11",96,0 )
	1786	... S IBN OTAX1=$P(I BXSAVE("L- PROV",IBIF N,IBLINE," C",1,IBPRV ),";",1) ; New vari ables IBNO TAX1 and
	1787	IBNOTAX2 f or IB2.0 568 - Deac tivated Pr ovider
	1788	"RTN","IBC BB11",97,0 )
	1789	... S IBN OTAX2(IBPR V,IBNOTAX1 )=""
	1790	"RTN","IBC BB11",98,0 )
	1791	... Q
	1792	"RTN","IBC BB11",99,0 )
	1793	.. Q
	1794	"RTN","IBC BB11",100, 0)
	1795	. Q
	1796	"RTN","IBC BB11",101, 0)
	1797	;
	1798	"RTN","IBC BB11",102, 0)
	1799	; IB251 = Referring provider taxonomy m issing.
	1800	"RTN","IBC BB11",103, 0)
	1801	; IB253 = Rendering provider taxonomy m issing.
	1802	"RTN","IBC BB11",104, 0)
	1803	; IB254 = Attending provider taxonomy m issing.
	1804	"RTN","IBC BB11",105, 0)
	1805	;
	1806	"RTN","IBC BB11",106, 0)
	1807	I $D(IBNO TAX) S IBP RV="" F S IBPRV=$O( IBNOTAX(IB PRV)) Q:'I BPRV D
	1808	"RTN","IBC BB11",107, 0)
	1809	. ; Only Referring, Rendering and Atten ding are c urrently s ent to the payer
	1810	"RTN","IBC BB11",108, 0)
	1811	. ;I IBTA XREQ,"134" [IBPRV S I BER=IBER_" IB"_(250+I BPRV)_";" Q ; MRD;I B2.0516 - Always r equired.
	1812	"RTN","IBC BB11",109, 0)
	1813	. I "134" [IBPRV D Q
	1814	"RTN","IBC BB11",110, 0)
	1815	.. S IBER =IBER_"IB" _(250+IBPR V)_";" ; I f required , set erro r
	1816	"RTN","IBC BB11",111, 0)
	1817	.. S IBPR VNT1=$O(IB NOTAX2(IBP RV,"")) ; New check for Deacti vated Prov ider IB2. 0568 next three
	1818	lines
	1819	"RTN","IBC BB11",112, 0)
	1820	.. S IBPR VNT2=$$SPE C^IBCEU(IB PRVNT1,IBE VDT)
	1821	"RTN","IBC BB11",113, 0)
	1822	.. I '$G( IBPRVNT2) D
	1823	WARN($P("R eferring^O perating^R endering^A ttending^S upervising ^^^^Other" ,U,IBPRV)_ " Provider
	1824	PERSON CLA SS/taxonom y was not active at DOS.") ; set warnin g
	1825	"RTN","IBC BB11",114, 0)
	1826	. D WARN( "Taxonomy for the
	1827	"_$P("refe rring^oper ating^rend ering^atte nding^supe rvising^^^ ^other",U, IBPRV)_" p rovider ha s no
	1828	value") ; Else, set warning
	1829	"RTN","IBC BB11",115, 0)
	1830	. Q
	1831	"RTN","IBC BB11",116, 0)
	1832	;
	1833	"RTN","IBC BB11",117, 0)
	1834	; Check o rganizatio ns. The f unction OR GTAX will set IBNOTA X to be a
	1835	"RTN","IBC BB11",118, 0)
	1836	; list of entities missing ta xonomy cod es, if any (n, n^m, n^m^p,
	1837	"RTN","IBC BB11",119, 0)
	1838	; where e ach 1 is s ervice fac ility, 2 i s non-VA s ervice fac ility and
	1839	"RTN","IBC BB11",120, 0)
	1840	; 3 is bi lling prov ider.
	1841	"RTN","IBC BB11",121, 0)
	1842	;
	1843	"RTN","IBC BB11",122, 0)
	1844	S IBNOTAX =""
	1845	"RTN","IBC BB11",123, 0)
	1846	S IBTAXS= $$ORGTAX^I BCEF73A(IB IFN,.IBNOT AX)
	1847	"RTN","IBC BB11",124, 0)
	1848	I $L(IBNO TAX) F Z=1 :1:$L(IBNO TAX,U) D
	1849	"RTN","IBC BB11",125, 0)
	1850	. ; IB167 = Billing Provider taxonomy m issing.
	1851	"RTN","IBC BB11",126, 0)
	1852	. ;I IBTA XREQ,$P(IB NOTAX,U,Z) =3 S IBER= IBER_"IB16 7;" Q ; M RD;IB2.0 516 - Alwa ys require d.
	1853	"RTN","IBC BB11",127, 0)
	1854	. I $P(IB NOTAX,U,Z) =3 S IBER= IBER_"IB16 7;" Q
	1855	"RTN","IBC BB11",128, 0)
	1856	. ; MRD;I B2.0516 - Remove w arning mes sage for m issing tax onomy code for lab o r facility .
	1857	"RTN","IBC BB11",129, 0)
	1858	. ; D WAR N("Taxonom y for the "_$P("Serv ice Facili ty^Non-VA Service Fa cility^Bil ling
	1859	Provider", U,$P(IBNOT AX,U,Z))_" has no va lue") ; E lse, set w arning
	1860	"RTN","IBC BB11",130, 0)
	1861	. Q
	1862	"RTN","IBC BB11",131, 0)
	1863	;
	1864	"RTN","IBC BB11",132, 0)
	1865	Q
	1866	"RTN","IBC BB11",133, 0)
	1867	;
	1868	"RTN","IBC BB11",134, 0)
	1869	VALNDC(IBI FN,IBDFN) ; IB2363 - validat e NDC# bet ween PRESC RIPTION fi le (#52)
	1870	"RTN","IBC BB11",135, 0)
	1871	; and IB BILL/CLAIM S PRESCRIP TION REFIL L file (#3 62.4)
	1872	"RTN","IBC BB11",136, 0)
	1873	; input - IBIFN = i nternal en try number of the bi lling reco rd in the BILL/CLAIM S file (#3 99)
	1874	"RTN","IBC BB11",137, 0)
	1875	; IBDFN = i nternal en try number of patien t record i n the PATI ENT file ( #2)
	1876	"RTN","IBC BB11",138, 0)
	1877	N IBX,IBR XCOL
	1878	"RTN","IBC BB11",139, 0)
	1879	; call pr ogram that determine s if NDC d ifferences exist
	1880	"RTN","IBC BB11",140, 0)
	1881	D VALNDC^ IBEFUNC3(I BIFN,IBDFN ,.IBRXCOL)
	1882	"RTN","IBC BB11",141, 0)
	1883	Q:'$D(IBR XCOL)
	1884	"RTN","IBC BB11",142, 0)
	1885	; at leas t one RX o n the IB r ecord has an NDC dis crepancy
	1886	"RTN","IBC BB11",143, 0)
	1887	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
	1888	"_IBRXCOL( IBX))
	1889	"RTN","IBC BB11",144, 0)
	1890	Q
	1891	"RTN","IBC BB11",145, 0)
	1892	;
	1893	"RTN","IBC BB11",146, 0)
	1894	PRIIDCHK ; Check for required Pimarary I D (SSN/EIN )
	1895	"RTN","IBC BB11",147, 0)
	1896	; If the provider i s on the c laim, he m ust have o ne
	1897	"RTN","IBC BB11",148, 0)
	1898	;
	1899	"RTN","IBC BB11",149, 0)
	1900	N IBI,IBZ
	1901	"RTN","IBC BB11",150, 0)
	1902	I $$TXMT^ IBCEF4(IBI FN) D
	1903	"RTN","IBC BB11",151, 0)
	1904	. D F^IBC EF("N-ALL ATT/REND P ROV SSN/EI ","IBZ",,I BIFN)
	1905	"RTN","IBC BB11",152, 0)
	1906	. S IBI=" " F S IBI =$O(^DGCR( 399,IBIFN, "PRV","B", IBI)) Q:IB I="" D
	1907	"RTN","IBC BB11",153, 0)
	1908	.. I $P(I BZ,U,IBI)= "" S
	1909	IBER=IBER_ $S(IBI=1:" IB151;",IB I=2:"IB152 ;",IBI=3!( IBI=4):"IB 321;",IBI= 5:"IB153;" ,IBI=9:"IB 154;",1:"" )
	1910	"RTN","IBC BB11",154, 0)
	1911	Q
	1912	"RTN","IBC BB11",155, 0)
	1913	;
	1914	"RTN","IBC BB11",156, 0)
	1915	RXNPI(IBIF N) ; check for multi ple pharma cy npi's o n the same bill
	1916	"RTN","IBC BB11",157, 0)
	1917	N IBORG,I BRXNPI,IBX ,IBY
	1918	"RTN","IBC BB11",158, 0)
	1919	S IBORG=$ $RXSITE^IB CEF73A(IBI FN,.IBORG)
	1920	"RTN","IBC BB11",159, 0)
	1921	S IBX=0 F S IBX=$O (IBORG(IBX )) Q:'IBX S IBY=0 F S IBY=$O (IBORG(IBX ,IBY)) Q:' IBY S
	1922	IBRXNPI(+I BORG(IBX,I BY))=""
	1923	"RTN","IBC BB11",160, 0)
	1924	S (IBX,IB Y)=0 F S IBX=$O(IBR XNPI(IBX)) Q:'IBX S IBY=IBY+1
	1925	"RTN","IBC BB11",161, 0)
	1926	I IBY>1 D WARN("Bil l has pres criptions resulting from "_IBY _" differe nt NPI loc ations")
	1927	"RTN","IBC BB11",162, 0)
	1928	Q
	1929	"RTN","IBC BB11",163, 0)
	1930	;
	1931	"RTN","IBC BB11",164, 0)
	1932	ROICHK(IBI FN,IBDFN,I BINS) ; IB 2.0384 - check pre scriptions that cont ain the
	1933	"RTN","IBC BB11",165, 0)
	1934	; SENSITI VE DIAGNOS IS DRUG fi eld #87 in the DRUG File #50 s et to 1 ag ainst
	1935	"RTN","IBC BB11",166, 0)
	1936	; the Cla ims Tracki ng ROI fil e (#356.25 ) to see i f an ROI i s on file
	1937	"RTN","IBC BB11",167, 0)
	1938	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	1939	"RTN","IBC BB11",168, 0)
	1940	; IBDFN = I EN of the patient
	1941	"RTN","IBC BB11",169, 0)
	1942	; IBINS = I EN of the payer insu rance comp any (#36)
	1943	"RTN","IBC BB11",170, 0)
	1944	; OUTPUT - 0 = no e rror
	1945	"RTN","IBC BB11",171, 0)
	1946	; 1 = a pr escription is sensit ive and th ere is no ROI on fil e
	1947	"RTN","IBC BB11",172, 0)
	1948	;
	1949	"RTN","IBC BB11",173, 0)
	1950	N IBX,IBY 0,IBRXIEN, IBDT,IBDRU G,ROIQ
	1951	"RTN","IBC BB11",174, 0)
	1952	S ROIQ=0
	1953	"RTN","IBC BB11",175, 0)
	1954	S IBX=0 F S IBX=$O (^IBA(362. 4,"C",IBIF N,IBX)) Q: 'IBX D
	1955	"RTN","IBC BB11",176, 0)
	1956	.S IBY0=^ IBA(362.4, IBX,0),IBR XIEN=$P(IB Y0,U,5) I 'IBRXIEN Q
	1957	"RTN","IBC BB11",177, 0)
	1958	.S IBDT=$ P(IBY0,U,3 ),IBDRUG=$ P(IBY0,U,4 )
	1959	"RTN","IBC BB11",178, 0)
	1960	.D ZERO^I BRXUTL(IBD RUG)
	1961	"RTN","IBC BB11",179, 0)
	1962	.I $$SENS ^IBNCPDR(I BDRUG) D ; Sensitiv e Diagnosi s Drug - c heck for R OI
	1963	"RTN","IBC BB11",180, 0)
	1964	.. I $$RO I^IBNCPDR4 (IBDFN,IBD RUG,IBINS, IBDT) Q ; ROI is on file
	1965	"RTN","IBC BB11",181, 0)
	1966	.. D WARN ("ROI not on file fo r prescrip tion "_$$R XAPI1^IBNC PUT1(IBRXI EN,.01,"E" ))
	1967	"RTN","IBC BB11",182, 0)
	1968	.. S ROIQ =1
	1969	"RTN","IBC BB11",183, 0)
	1970	ROICHKQ ;
	1971	"RTN","IBC BB11",184, 0)
	1972	K ^TMP($J ,"IBDRUG")
	1973	"RTN","IBC BB11",185, 0)
	1974	Q ROIQ
	1975	"RTN","IBC BB11",186, 0)
	1976	;
	1977	"RTN","IBC BB11",187, 0)
	1978	AMBCK(IBIF N) ; IB 2.0432 - if ambula nce locati on defined , address must be de fined
	1979	"RTN","IBC BB11",188, 0)
	1980	; 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
	1981	needs to b e:
	1982	"RTN","IBC BB11",189, 0)
	1983	; 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
	1984	(CMS1500 o nly)
	1985	"RTN","IBC BB11",190, 0)
	1986	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	1987	"RTN","IBC BB11",191, 0)
	1988	; OUTPUT - 0 = no e rror
	1989	"RTN","IBC BB11",192, 0)
	1990	; 1 = Erro r
	1991	"RTN","IBC BB11",193, 0)
	1992	;
	1993	"RTN","IBC BB11",194, 0)
	1994	N IBPAMB, IBDAMB,IBA MBR,IBCK
	1995	"RTN","IBC BB11",195, 0)
	1996	S IBAMBR= 0
	1997	"RTN","IBC BB11",196, 0)
	1998	Q:$$INSPR F^IBCEF(IB IFN)'=0 IB AMBR
	1999	"RTN","IBC BB11",197, 0)
	2000	S IBPAMB= $G(^DGCR(3 99,IBIFN," U5")),IBDA MB=$G(^DGC R(399,IBIF N,"U6"))
	2001	"RTN","IBC BB11",198, 0)
	2002	S IBCK(5) =$$NOPUNCT ^IBCEF($P( IBPAMB,U,2 ,6),1),IBC K(6)=$$NOP UNCT^IBCEF ($P(IBDAMB ,U,1,6),1)
	2003	"RTN","IBC BB11",199, 0)
	2004	I IBCK(5) ="",IBCK(6 )="" Q IBA MBR
	2005	"RTN","IBC BB11",200, 0)
	2006	; 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
	2007	"RTN","IBC BB11",201, 0)
	2008	I IBCK(5) '="" F I=2 ,4,5 I $P( IBPAMB,U,I )="" S IBA MBR=1
	2009	"RTN","IBC BB11",202, 0)
	2010	I IBCK(6) '="" F I=1 ,2,4,5 I $ P(IBDAMB,U ,I)="" S I BAMBR=1
	2011	"RTN","IBC BB11",203, 0)
	2012	Q:IBAMBR= 1 IBAMBR
	2013	"RTN","IBC BB11",204, 0)
	2014	; now che ck zip cod e. OK to be null if state is not a US P osession
	2015	"RTN","IBC BB11",205, 0)
	2016	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
	2017	"RTN","IBC BB11",206, 0)
	2018	Q IBAMBR
	2019	"RTN","IBC BB11",207, 0)
	2020	;
	2021	"RTN","IBC BB11",208, 0)
	2022	COBAMT(IBI FN) ; IB 2.0432 - IF there is a COB a mt. it mus t equal th e Total Cl aim Charge Amount
	2023	"RTN","IBC BB11",209, 0)
	2024	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2025	"RTN","IBC BB11",210, 0)
	2026	; OUTPUT - 0 = no e rror
	2027	"RTN","IBC BB11",211, 0)
	2028	; 1 = Erro r
	2029	"RTN","IBC BB11",212, 0)
	2030	;
	2031	"RTN","IBC BB11",213, 0)
	2032	Q:IBIFN=" " 0
	2033	"RTN","IBC BB11",214, 0)
	2034	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)="" 0
	2035	"RTN","IBC BB11",215, 0)
	2036	Q:+$P($G( ^DGCR(399, IBIFN,"U1" )),U)'=+$P ($G(^DGCR( 399,IBIFN, "U4")),U) 1
	2037	"RTN","IBC BB11",216, 0)
	2038	Q 0
	2039	"RTN","IBC BB11",217, 0)
	2040	;
	2041	"RTN","IBC BB11",218, 0)
	2042	COBMRA(IBI FN) ; IB 2.0432 - If there is a 'COB total non- covered am ount' (Fil e#399, Fie ld#260),
	2043	"RTN","IBC BB11",219, 0)
	2044	; Primary Insurance must be M edicare th at never w ent to Med icare, and this must be a 2nda ry or
	2045	tertiary c laim
	2046	"RTN","IBC BB11",220, 0)
	2047	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2048	"RTN","IBC BB11",221, 0)
	2049	; OUTPUT - 0 = no e rror
	2050	"RTN","IBC BB11",222, 0)
	2051	; 1 = Erro r
	2052	"RTN","IBC BB11",223, 0)
	2053	;
	2054	"RTN","IBC BB11",224, 0)
	2055	N IBP
	2056	"RTN","IBC BB11",225, 0)
	2057	Q:IBIFN=" " 0
	2058	"RTN","IBC BB11",226, 0)
	2059	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)="" 0
	2060	"RTN","IBC BB11",227, 0)
	2061	S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN
	2062	"RTN","IBC BB11",228, 0)
	2063	I $$WNRBI LL^IBEFUNC (IBIFN,1), $P($G(^DGC R(399,IBP, "S")),U,7) ="",$$COBN ^IBCEF(IBI FN)>1 Q 0
	2064	"RTN","IBC BB11",229, 0)
	2065	Q 1
	2066	"RTN","IBC BB11",230, 0)
	2067	;
	2068	"RTN","IBC BB11",231, 0)
	2069	COBSEC(IBI FN) ; IB 2.0432 - If there is NOT a ' COB total non-covere d amount' (File#399, Field#260 ),
	2070	"RTN","IBC BB11",232, 0)
	2071	; 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
	2072	to transmi t
	2073	"RTN","IBC BB11",233, 0)
	2074	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2075	"RTN","IBC BB11",234, 0)
	2076	; OUTPUT - 0 = no e rror
	2077	"RTN","IBC BB11",235, 0)
	2078	; 1 = Erro r
	2079	"RTN","IBC BB11",236, 0)
	2080	;
	2081	"RTN","IBC BB11",237, 0)
	2082	N IBP
	2083	"RTN","IBC BB11",238, 0)
	2084	Q:IBIFN=" " 0
	2085	"RTN","IBC BB11",239, 0)
	2086	Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)'="" 0
	2087	"RTN","IBC BB11",240, 0)
	2088	Q:$$COBN^ IBCEF(IBIF N)<2 0
	2089	"RTN","IBC BB11",241, 0)
	2090	S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN
	2091	"RTN","IBC BB11",242, 0)
	2092	I
	2093	$$WNRBILL^ IBEFUNC(IB IFN,1),$P( $G(^DGCR(3 99,IBP,"S" )),U,7)="" ,$P($G(^DG CR(399,IBI FN,"TX")), U,8)'=
	2094	1 Q 1
	2095	"RTN","IBC BB11",243, 0)
	2096	Q 0
	2097	"RTN","IBC BB11",244, 0)
	2098	;
	2099	"RTN","IBC BB11",245, 0)
	2100	TMCK(IBIFN ) ; IB2. 0432 - At tachment C ontrol Num ber - REQU IRED when Transmissi on Method = BM,
	2101	EL, EM, or FT
	2102	"RTN","IBC BB11",246, 0)
	2103	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2104	"RTN","IBC BB11",247, 0)
	2105	; OUTPUT - 0 = no e rror
	2106	"RTN","IBC BB11",248, 0)
	2107	; 1 = Erro r
	2108	"RTN","IBC BB11",249, 0)
	2109	;
	2110	"RTN","IBC BB11",250, 0)
	2111	N IBAC
	2112	"RTN","IBC BB11",251, 0)
	2113	Q:IBIFN=" " 0
	2114	"RTN","IBC BB11",252, 0)
	2115	F I=1,3 S IBAC(I)=$ P($G(^DGCR (399,IBIFN ,"U8")),U, I)
	2116	"RTN","IBC BB11",253, 0)
	2117	Q:IBAC(3) ="" 0
	2118	"RTN","IBC BB11",254, 0)
	2119	Q:IBAC(1) '="" 0
	2120	"RTN","IBC BB11",255, 0)
	2121	Q:IBAC(3) ="AA" 0
	2122	"RTN","IBC BB11",256, 0)
	2123	Q 1
	2124	"RTN","IBC BB11",257, 0)
	2125	;
	2126	"RTN","IBC BB11",258, 0)
	2127	ACCK(IBIFN ) ; IB2.0 432 If an y of the l oop info i s present, then Repo rt Type & Transmissi on Method
	2128	req'd
	2129	"RTN","IBC BB11",259, 0)
	2130	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2131	"RTN","IBC BB11",260, 0)
	2132	; OUTPUT - 0 = no e rror
	2133	"RTN","IBC BB11",261, 0)
	2134	; 1 = Erro r
	2135	"RTN","IBC BB11",262, 0)
	2136	;
	2137	"RTN","IBC BB11",263, 0)
	2138	N IBAC
	2139	"RTN","IBC BB11",264, 0)
	2140	Q:IBIFN=" " 0
	2141	"RTN","IBC BB11",265, 0)
	2142	F I=1:1:3 S IBAC(I) =$P($G(^DG CR(399,IBI FN,"U8")), U,I)
	2143	"RTN","IBC BB11",266, 0)
	2144	; All fie lds null, no error
	2145	"RTN","IBC BB11",267, 0)
	2146	I IBAC(1) ="",IBAC(2 )="",IBAC( 3)="" Q 0
	2147	"RTN","IBC BB11",268, 0)
	2148	; Both re quired fie lds comple te, no err or
	2149	"RTN","IBC BB11",269, 0)
	2150	I IBAC(2) '="",IBAC( 3)'="" Q 0
	2151	"RTN","IBC BB11",270, 0)
	2152	; At this point, on e of the 2 required fields has data and one does n ot, so err or
	2153	"RTN","IBC BB11",271, 0)
	2154	Q 1
	2155	"RTN","IBC BB11",272, 0)
	2156	;
	2157	"RTN","IBC BB11",273, 0)
	2158	LNTMCK(IBI FN) ; DEM ;IB2.043 2 - (Line Level) Att achment Co ntrol Numb er - REQUI RED when
	2159	Transmissi on Method = BM, EL, EM, or FT
	2160	"RTN","IBC BB11",274, 0)
	2161	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2162	"RTN","IBC BB11",275, 0)
	2163	; OUTPUT - IBLNERR = 0 = no e rror
	2164	"RTN","IBC BB11",276, 0)
	2165	; IBLNERR = 1 = Erro r
	2166	"RTN","IBC BB11",277, 0)
	2167	;
	2168	"RTN","IBC BB11",278, 0)
	2169	N IBAC,IB PROCP,I,IB LNERR
	2170	"RTN","IBC BB11",279, 0)
	2171	S IBLNERR =0 ; DEM; 432 - Init ialize err or flag IB LNERR to ' 0' for no errors.
	2172	"RTN","IBC BB11",280, 0)
	2173	Q:IBIFN=" " IBLNERR
	2174	"RTN","IBC BB11",281, 0)
	2175	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR
	2176	"RTN","IBC BB11",282, 0)
	2177	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,0 ))#10) ; DEM;432 - Node '0' i s procedur e node.
	2178	"RTN","IBC BB11",283, 0)
	2179	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; DEM;432 - Node '1' i s line lev el Attachm ent Contro l
	2180	fields.
	2181	"RTN","IBC BB11",284, 0)
	2182	. F I=1,3 S IBAC(I) =$P(^DGCR( 399,IBIFN, "CP",IBPRO CP,1),U,I)
	2183	"RTN","IBC BB11",285, 0)
	2184	. I IBAC( 3)="" S IB LNERR=0 Q
	2185	"RTN","IBC BB11",286, 0)
	2186	. I IBAC( 1)'="" S I BLNERR=0 Q
	2187	"RTN","IBC BB11",287, 0)
	2188	. I (IBAC (3)="AA") S IBLNERR= 0 Q
	2189	"RTN","IBC BB11",288, 0)
	2190	. S IBLNE RR=1
	2191	"RTN","IBC BB11",289, 0)
	2192	. Q
	2193	"RTN","IBC BB11",290, 0)
	2194	;
	2195	"RTN","IBC BB11",291, 0)
	2196	Q IBLNERR
	2197	"RTN","IBC BB11",292, 0)
	2198	;
	2199	"RTN","IBC BB11",293, 0)
	2200	LNACCK(IBI FN) ; DEM; IB2.0432 (Line Lev el) If any of the lo op info is present, then Repor t Type &
	2201	Transmissi on Method req'd
	2202	"RTN","IBC BB11",294, 0)
	2203	; input - IBIFN = I EN of the Bill/Claim s file (#3 99)
	2204	"RTN","IBC BB11",295, 0)
	2205	; OUTPUT - IBLNERR = 0 = no e rror
	2206	"RTN","IBC BB11",296, 0)
	2207	; IBLNERR = 1 = Erro r
	2208	"RTN","IBC BB11",297, 0)
	2209	;
	2210	"RTN","IBC BB11",298, 0)
	2211	N IBAC,IB PROCP,I,IB LNERR
	2212	"RTN","IBC BB11",299, 0)
	2213	S IBLNERR =0 ; DEM; 432 - Init ialize err or flag IB LNERR to ' 0' for no errors.
	2214	"RTN","IBC BB11",300, 0)
	2215	Q:IBIFN=" " IBLNERR
	2216	"RTN","IBC BB11",301, 0)
	2217	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR
	2218	"RTN","IBC BB11",302, 0)
	2219	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,0 ))#10) ; DEM;432 - Node '0' i s procedur e node.
	2220	"RTN","IBC BB11",303, 0)
	2221	. Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; DEM;432 - Node '1' i s line lev el Attachm ent Contro l
	2222	fields.
	2223	"RTN","IBC BB11",304, 0)
	2224	. F I=1:1 :3 S IBAC( I)=$P(^DGC R(399,IBIF N,"CP",IBP ROCP,1),U, I)
	2225	"RTN","IBC BB11",305, 0)
	2226	. ; All f ields null , no error
	2227	"RTN","IBC BB11",306, 0)
	2228	. I IBAC( 1)="",IBAC (2)="",IBA C(3)="" S IBLNERR=0 Q
	2229	"RTN","IBC BB11",307, 0)
	2230	. ; Both required f ields comp lete, no e rror
	2231	"RTN","IBC BB11",308, 0)
	2232	. I IBAC( 2)'="",IBA C(3)'="" S IBLNERR=0 Q
	2233	"RTN","IBC BB11",309, 0)
	2234	. ; At th is point, one of the 2 require d fields h as data an d one does not, so e rror
	2235	"RTN","IBC BB11",310, 0)
	2236	. S IBLNE RR=1
	2237	"RTN","IBC BB11",311, 0)
	2238	. Q
	2239	"RTN","IBC BB11",312, 0)
	2240	;
	2241	"RTN","IBC BB11",313, 0)
	2242	Q IBLNERR
	2243	"RTN","IBC BB11",314, 0)
	2244	;
	2245	"RTN","IBC BB11",315, 0)
	2246	;vd/Begin ning of IB 2577 - V alidate Li ne Level f or NDC
	2247	"RTN","IBC BB11",316, 0)
	2248	LNNDCCK(IB IFN) ;IB2 577 (Line Level) Th e Units an d Units/Ba sis of Mea surement f ields are required i f
	2249	the NDC fi eld is pop ulated.
	2250	"RTN","IBC BB11",317, 0)
	2251	; INPUT - IBIFN = IEN of the Bill/Clai ms file (# 399)
	2252	"RTN","IBC BB11",318, 0)
	2253	; OUTPUT - IBLNERR = 0 = no e rror
	2254	"RTN","IBC BB11",319, 0)
	2255	; IBLNERR = 1 = Erro r
	2256	"RTN","IBC BB11",320, 0)
	2257	;
	2258	"RTN","IBC BB11",321, 0)
	2259	N IBAC,IB PROCP,I,IB LNERR
	2260	"RTN","IBC BB11",322, 0)
	2261	S IBLNERR =0 ; IB2 577 - Ini tialize er ror flag I BLNERR to '0' for no errors.
	2262	"RTN","IBC BB11",323, 0)
	2263	Q:IBIFN=" " IBLNERR
	2264	"RTN","IBC BB11",324, 0)
	2265	S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR
	2266	"RTN","IBC BB11",325, 0)
	2267	. Q:($$GE T1^DIQ(399 .0304,IBPR OCP_","_IB IFN_",","N DC","I")=" ") ; IB* 2*577 - No NDC Code
	2268	"RTN","IBC BB11",326, 0)
	2269	. ; If th ere is an NDC Code, then the U NITS and U NITS/BASIS OF MEASUR EMENT are Required.
	2270	"RTN","IBC BB11",327, 0)
	2271	. I $$GET 1^DIQ(399. 0304,IBPRO CP_","_IBI FN_",","UN ITS/BASIS OF MEASURE MENT","I") ="" S
	2272	IBLNERR=1 Q
	2273	"RTN","IBC BB11",328, 0)
	2274	. I $$GET 1^DIQ(399. 0304,IBPRO CP_","_IBI FN_",","UN ITS","I")= "" S IBLNE RR=1 Q ;U nits (Quan tity) is
	2275	required i f there is an NDC Co de.
	2276	"RTN","IBC BB11",329, 0)
	2277	. Q
	2278	"RTN","IBC BB11",330, 0)
	2279	;
	2280	"RTN","IBC BB11",331, 0)
	2281	Q IBLNERR
	2282	"RTN","IBC BB11",332, 0)
	2283	;vd/End o f IB2577
	2284	"RTN","IBC NSBL2")
	2285	0^14^B3959 3451^B3317 3974
	2286	"RTN","IBC NSBL2",1,0 )
	2287	IBCNSBL2 ; ALB/CPM - 'BILL NEXT PAYOR' BU LLETIN ;08 -AUG-96
	2288	"RTN","IBC NSBL2",2,0 )
	2289	;;2.0;INT EGRATED BI LLING;*52 ,80,153,24 0,432,568 *;21-MAR-9 4;Build 40
	2290	"RTN","IBC NSBL2",3,0 )
	2291	;;Per VA Directive 6402, this routine s hould not be modifie d.
	2292	"RTN","IBC NSBL2",4,0 )
	2293	;
	2294	"RTN","IBC NSBL2",5,0 )
	2295	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
	2296	billed
	2297	"RTN","IBC NSBL2",6,0 )
	2298	; 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
	2299	"RTN","IBC NSBL2",7,0 )
	2300	; if ther e is anoth er Third P arty Payer then retu rns true, if any oth er payer ( including patient) t hen set
	2301	array
	2302	"RTN","IBC NSBL2",8,0 )
	2303	;
	2304	"RTN","IBC NSBL2",9,0 )
	2305	; Input : IBIFN -- Poin ter to AR (file #430 ), or Clai m (file #3 99)
	2306	"RTN","IBC NSBL2",10, 0)
	2307	; IBORIG -- Orig inal amoun t of the c laim
	2308	"RTN","IBC NSBL2",11, 0)
	2309	; IBPYMT -- Tota l Amount p aid on the claim
	2310	"RTN","IBC NSBL2",12, 0)
	2311	;
	2312	"RTN","IBC NSBL2",13, 0)
	2313	; Output : IBTXT -- Array , pass by reference, if needed
	2314	"RTN","IBC NSBL2",14, 0)
	2315	; If a another pa yer (third party or patient) f or the cla im can be found,
	2316	"RTN","IBC NSBL2",15, 0)
	2317	; this array will contain t he text th at explain s who the next payer is
	2318	"RTN","IBC NSBL2",16, 0)
	2319	;
	2320	"RTN","IBC NSBL2",17, 0)
	2321	; Returns : 0 -- no ne ed to forw ard EOB (n o next Thi rd Party p ayer found or paymen t=>amount due)
	2322	"RTN","IBC NSBL2",18, 0)
	2323	; 'true^N ext payer' -- if th e EOB of t he bill ne eds to be forwarded for inclus ion in the next bill ,
	2324	"RTN","IBC NSBL2",19, 0)
	2325	; gener ally there must be a nother pay er for the bill that is
	2326	"RTN","IBC NSBL2",20, 0)
	2327	; third party, no n-patient, and payme nt was not the amoun t due
	2328	"RTN","IBC NSBL2",21, 0)
	2329	;
	2330	"RTN","IBC NSBL2",22, 0)
	2331	N X,IB,IB POL,IBCS,I BARCAT,IBS EC,IBRETUR N,IBSEQ,IB INS S IBRE TURN=0
	2332	"RTN","IBC NSBL2",23, 0)
	2333	I '$G(IBI FN) G EOBQ
	2334	"RTN","IBC NSBL2",24, 0)
	2335	I $G(^PRC A(430,IBIF N,0))="" G EOBQ
	2336	"RTN","IBC NSBL2",25, 0)
	2337	I '$G(IBO RIG) G EOB Q
	2338	"RTN","IBC NSBL2",26, 0)
	2339	I $G(IBPY MT)="" G E OBQ
	2340	"RTN","IBC NSBL2",27, 0)
	2341	;
	2342	"RTN","IBC NSBL2",28, 0)
	2343	S IB=$G(^ DGCR(399,I BIFN,0)) I IB="" G E OBQ
	2344	"RTN","IBC NSBL2",29, 0)
	2345	;
	2346	"RTN","IBC NSBL2",30, 0)
	2347	; - quit if there i s no remai ning balan ce on the bill
	2348	"RTN","IBC NSBL2",31, 0)
	2349	I IBPYMT' <IBORIG G EOBQ
	2350	"RTN","IBC NSBL2",32, 0)
	2351	;
	2352	"RTN","IBC NSBL2",33, 0)
	2353	S IBARCAT =$P($G(^DG CR(399.3,+ $P(IB,"^", 7),0)),"^" ,6) I 'IBA RCAT G EOB Q
	2354	"RTN","IBC NSBL2",34, 0)
	2355	;
	2356	"RTN","IBC NSBL2",35, 0)
	2357	; for Eme rgency/Hum anitarian Reimb. IB* 2.0*568
	2358	"RTN","IBC NSBL2",36, 0)
	2359	I IBARCAT =46 D G E OBQ
	2360	"RTN","IBC NSBL2",37, 0)
	2361	. S IBRET URN="2^Eme rgency/Hum anitarian Reimb."
	2362	"RTN","IBC NSBL2",38, 0)
	2363	. S IBTXT (14)="You should bal ance bill this patie nt using t he appropr iate cost- based rate type."
	2364	"RTN","IBC NSBL2",39, 0)
	2365	;
	2366	"RTN","IBC NSBL2",40, 0)
	2367	; for Ine ligible Ho sp. Reimb. IB2.056 8
	2368	"RTN","IBC NSBL2",41, 0)
	2369	I IBARCAT =47 D G E OBQ
	2370	"RTN","IBC NSBL2",42, 0)
	2371	. S IBRET URN="2^Ine ligible Ho sp. Reimb. "
	2372	"RTN","IBC NSBL2",43, 0)
	2373	. S IBTXT (14)="You should bal ance bill this patie nt using t he appropr iate cost- based rate type."
	2374	"RTN","IBC NSBL2",44, 0)
	2375	;
	2376	"RTN","IBC NSBL2",45, 0)
	2377	; - for C hampva thi rd party c laims, bil l the Cham pva Center next
	2378	"RTN","IBC NSBL2",46, 0)
	2379	I IBARCAT =28 D G E OBQ
	2380	"RTN","IBC NSBL2",47, 0)
	2381	. S IBTXT (14)="You should pre pare a cla im to be s ent to the CHAMPVA
	2382	Center.",I BRETURN="1 ^CHAMPVA C enter"
	2383	"RTN","IBC NSBL2",48, 0)
	2384	;
	2385	"RTN","IBC NSBL2",49, 0)
	2386	; - for T ricare thi rd party c laims, nex t bill Tri care or th e patient
	2387	"RTN","IBC NSBL2",50, 0)
	2388	I IBARCAT =32 D G E OBQ
	2389	"RTN","IBC NSBL2",51, 0)
	2390	. ;
	2391	"RTN","IBC NSBL2",52, 0)
	2392	. ; - thi rd party b ill went t o Tricare Supplement al carrier , bill pat ient next
	2393	"RTN","IBC NSBL2",53, 0)
	2394	. 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:-
	2395	1)
	2396	"RTN","IBC NSBL2",54, 0)
	2397	. S IBPOL =$G(^DGCR( 399,IBIFN, IBSEQ))
	2398	"RTN","IBC NSBL2",55, 0)
	2399	. S IBCS= $D(^IBE(35 5.1,"D","C S",+$P($G( ^IBA(355.3 ,+$P(IBPOL ,"^",18),0 )),"^",9)) )>0
	2400	"RTN","IBC NSBL2",56, 0)
	2401	. I IBCS D Q
	2402	"RTN","IBC NSBL2",57, 0)
	2403	.. S IBTX T(14)="Thi s claim wa s sent to the TRICAR E Suppleme ntal insur ance carri er."
	2404	"RTN","IBC NSBL2",58, 0)
	2405	.. S IBTX T(15)="You should se nd a copay ment charg e to the p atient."
	2406	"RTN","IBC NSBL2",59, 0)
	2407	. ;
	2408	"RTN","IBC NSBL2",60, 0)
	2409	. ; - oth erwise thi rd party b ill went t o patients Reimb. In s carrier, bill the tricare FI next
	2410	"RTN","IBC NSBL2",61, 0)
	2411	. S IBRET URN="1^TRI CARE Fisca l Intermed iary"
	2412	"RTN","IBC NSBL2",62, 0)
	2413	. S IBTXT (14)="You should pre pare a cla im to send to the TR ICARE Fisc al Interme diary."
	2414	"RTN","IBC NSBL2",63, 0)
	2415	;
	2416	"RTN","IBC NSBL2",64, 0)
	2417	; - for T ricare cla ims, bill the patien t or Trica re supplem ental poli cy
	2418	"RTN","IBC NSBL2",65, 0)
	2419	I IBARCAT =30 D G E OBQ
	2420	"RTN","IBC NSBL2",66, 0)
	2421	. ;
	2422	"RTN","IBC NSBL2",67, 0)
	2423	. ; - if the patien t has a Tr icare supp lemental p olicy, bil l it
	2424	"RTN","IBC NSBL2",68, 0)
	2425	. I $$CHP SUP(+$P(IB ,"^",2)) D Q
	2426	"RTN","IBC NSBL2",69, 0)
	2427	.. S IBRE TURN="1^TR ICARE Supp lemental p olicy"
	2428	"RTN","IBC NSBL2",70, 0)
	2429	.. S IBTX T(14)="The patient h as a TRICA RE Supplem ental poli cy."
	2430	"RTN","IBC NSBL2",71, 0)
	2431	.. S IBTX T(15)="You should pr epare a cl aim to be sent to th at carrier ."
	2432	"RTN","IBC NSBL2",72, 0)
	2433	. ;
	2434	"RTN","IBC NSBL2",73, 0)
	2435	. ; - oth erwise, bi ll the pat ient
	2436	"RTN","IBC NSBL2",74, 0)
	2437	. S IBTXT (14)="You should sen d a copaym ent charge to the pa tient."
	2438	"RTN","IBC NSBL2",75, 0)
	2439	;
	2440	"RTN","IBC NSBL2",76, 0)
	2441	; - 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
	2442	"RTN","IBC NSBL2",77, 0)
	2443	S IBSEQ=$ P($G(^DGCR (399,IBIFN ,0)),U,21) ,IBSEQ=$S( IBSEQ="P": 2,IBSEQ="S ":3,1:"")
	2444	"RTN","IBC NSBL2",78, 0)
	2445	I +IBSEQ S IBINS=$P ($G(^DGCR( 399,IBIFN, "M")),U,IB SEQ) I +IB INS D
	2446	"RTN","IBC NSBL2",79, 0)
	2447	. S IBRET URN=+IBINS _U_$P($G(^ DIC(36,+IB INS,0)),U, 1)
	2448	"RTN","IBC NSBL2",80, 0)
	2449	. S IBTXT (14)="Ther e is a "_$ S(IBSEQ=2: "secondary ",1:"terti ary")_" pa yor associ ated with this claim ."
	2450	"RTN","IBC NSBL2",81, 0)
	2451	. S IBTXT (15)="You may need t o prepare a claim to be sent t o "_$P(IBR ETURN,U,2) _"."
	2452	"RTN","IBC NSBL2",82, 0)
	2453	;
	2454	"RTN","IBC NSBL2",83, 0)
	2455	EOBQ Q IBR ETURN
	2456	"RTN","IBC NSBL2",84, 0)
	2457	;
	2458	"RTN","IBC NSBL2",85, 0)
	2459	BULL(IBIFN ,IBORIG,IB PYMT) ; Ge nerate bul letin deta iling next payer for a claim, if any
	2460	"RTN","IBC NSBL2",86, 0)
	2461	;
	2462	"RTN","IBC NSBL2",87, 0)
	2463	; Input : IBIFN -- Poin ter to AR (file #430 ), or Clai m (file #3 99)
	2464	"RTN","IBC NSBL2",88, 0)
	2465	; IBORIG -- Orig inal amoun t of the c laim
	2466	"RTN","IBC NSBL2",89, 0)
	2467	; IBPYMT -- Tota l Amount p aid on the claim
	2468	"RTN","IBC NSBL2",90, 0)
	2469	;
	2470	"RTN","IBC NSBL2",91, 0)
	2471	; Output : Bullet in: Mail Group MEA NS TEST BI LLING MAIL GROUP: IB MEANS TES T (350.9,. 11)
	2472	"RTN","IBC NSBL2",92, 0)
	2473	; If a secondary payor for the claim can be fo und, a bul letin will be sent
	2474	"RTN","IBC NSBL2",93, 0)
	2475	; to t he billing unit to a lert them to forward the claim to that p ayor.
	2476	"RTN","IBC NSBL2",94, 0)
	2477	;
	2478	"RTN","IBC NSBL2",95, 0)
	2479	N X,IB,IB X,IBTXT,IB P,IBGRP,IB WLF ;WCJ; IB2.0432
	2480	"RTN","IBC NSBL2",96, 0)
	2481	;
	2482	"RTN","IBC NSBL2",97, 0)
	2483	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
	2484	"RTN","IBC NSBL2",98, 0)
	2485	;
	2486	"RTN","IBC NSBL2",99, 0)
	2487	; WCJ;IB* 2.0*432;Tr igger comm ercial aut o processi ng.
	2488	"RTN","IBC NSBL2",100 ,0)
	2489	; This wi ll replace the bulle tin when a ctivated.
	2490	"RTN","IBC NSBL2",101 ,0)
	2491	; (not us ing a mast er switch just yet s o it's aut omatically activated )
	2492	"RTN","IBC NSBL2",102 ,0)
	2493	;I $$GET1 ^DIQ(350.9 ,1,8.18) D G BULLQ
	2494	"RTN","IBC NSBL2",103 ,0)
	2495	; check i f these sh ould go di rectly to the workli st
	2496	"RTN","IBC NSBL2",104 ,0)
	2497	S IBWLF=$ S('IBX:1," .CHAMPVA C enter.TRIC ARE Fiscal Intermedi ary.TRICAR E Suppleme ntal
	2498	policy."[( "."_$P(IBX ,U,2)_".") :1,".Ineli gible Hosp . Reimb..E mergency/H umanitaria n
	2499	Reimb.."[( "."_$P(IBX ,U,2)_".") :2,1:0)
	2500	"RTN","IBC NSBL2",105 ,0)
	2501	D EN^IBCA PP(IBIFN,I BORIG,IBPY MT,IBWLF)
	2502	"RTN","IBC NSBL2",106 ,0)
	2503	G BULLQ
	2504	"RTN","IBC NSBL2",107 ,0)
	2505	; WCJ;IB* 2.0*432;en d changes
	2506	"RTN","IBC NSBL2",108 ,0)
	2507	;
	2508	"RTN","IBC NSBL2",109 ,0)
	2509	S IB=$G(^ DGCR(399,I BIFN,0)) I IB="" G B ULLQ
	2510	"RTN","IBC NSBL2",110 ,0)
	2511	S IBP=$$P T^IBEFUNC( +$P(IB,"^" ,2))
	2512	"RTN","IBC NSBL2",111 ,0)
	2513	;
	2514	"RTN","IBC NSBL2",112 ,0)
	2515	; - creat e remainde r of bulle tin
	2516	"RTN","IBC NSBL2",113 ,0)
	2517	N XMDUZ,X MTEXT,XMY, XMSUB
	2518	"RTN","IBC NSBL2",114 ,0)
	2519	S XMSUB=" Notificati on of Subs equent Pay or"
	2520	"RTN","IBC NSBL2",115 ,0)
	2521	S XMDUZ=" INTEGRATED BILLING P ACKAGE",XM TEXT="IBTX T("
	2522	"RTN","IBC NSBL2",116 ,0)
	2523	K XMY S X MY(DUZ)=""
	2524	"RTN","IBC NSBL2",117 ,0)
	2525	;
	2526	"RTN","IBC NSBL2",118 ,0)
	2527	S IBTXT(1 )="A payme nt has bee n made on the follow ing claim, which has been iden tified"
	2528	"RTN","IBC NSBL2",119 ,0)
	2529	S IBTXT(2 )="as pote ntially ha ving a sub sequent pa yor:"
	2530	"RTN","IBC NSBL2",120 ,0)
	2531	S IBTXT(3 )=" "
	2532	"RTN","IBC NSBL2",121 ,0)
	2533	S IBTXT(4 )=" Bill Number: "_ $P($G(^PRC A(430,IBIF N,0)),"^")
	2534	"RTN","IBC NSBL2",122 ,0)
	2535	S IBTXT(5 )=" P atient: "_ $E($P(IBP, "^"),1,30) _" Pt. I d: "_$P(IB P,"^",2)
	2536	"RTN","IBC NSBL2",123 ,0)
	2537	S IBTXT(6 )=" Bil l Type: "_ $P($G(^DGC R(399.3,+$ P(IB,"^",7 ),0)),"^")
	2538	"RTN","IBC NSBL2",124 ,0)
	2539	S IBTXT(7 )=" Orig Amount: $" _$J(IBORIG ,0,2)
	2540	"RTN","IBC NSBL2",125 ,0)
	2541	S IBTXT(8 )=" Amoun t Paid: $" _$J(IBPYMT ,0,2)
	2542	"RTN","IBC NSBL2",126 ,0)
	2543	S IBTXT(9 )=" "
	2544	"RTN","IBC NSBL2",127 ,0)
	2545	;
	2546	"RTN","IBC NSBL2",128 ,0)
	2547	S IBX=$G( ^DGCR(399, IBIFN,0))
	2548	"RTN","IBC NSBL2",129 ,0)
	2549	S IBTXT(1 0)="Bill S equence: " _$$EXSET^I BEFUNC($P( IBX,U,21), 399,.21)
	2550	"RTN","IBC NSBL2",130 ,0)
	2551	S IBTXT(1 1)=" Bil l Payer: " _$E($P($G( ^DIC(36,+$ G(^DGCR(39 9,IBIFN,"M P")),0)),U ,1),1,20)
	2552	"RTN","IBC NSBL2",131 ,0)
	2553	;
	2554	"RTN","IBC NSBL2",132 ,0)
	2555	S IBX=$G( ^DGCR(399, IBIFN,"M") )
	2556	"RTN","IBC NSBL2",133 ,0)
	2557	I IBX S I BTXT(10)=I BTXT(10)_$ J("",(40-$ L(IBTXT(10 ))))_" Pr imary Carr ier:
	2558	"_$E($P($G (^DIC(36,+ IBX,0)),U, 1),1,20)
	2559	"RTN","IBC NSBL2",134 ,0)
	2560	I +$P(IBX ,U,2) S IB TXT(11)=IB TXT(11)_$J ("",(40-$L (IBTXT(11) )))_"Secon dary Carri er:
	2561	"_$E($P($G (^DIC(36,+ $P(IBX,U,2 ),0)),U,1) ,1,20)
	2562	"RTN","IBC NSBL2",135 ,0)
	2563	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)
	2564	"RTN","IBC NSBL2",136 ,0)
	2565	S IBTXT(1 3)=" "
	2566	"RTN","IBC NSBL2",137 ,0)
	2567	;
	2568	"RTN","IBC NSBL2",138 ,0)
	2569	; - send to the Mea ns Test bi lling mail group (for now)
	2570	"RTN","IBC NSBL2",139 ,0)
	2571	S IBGRP=$ P($G(^XMB( 3.8,+$P($G (^IBE(350. 9,1,0)),"^ ",11),0)), "^")
	2572	"RTN","IBC NSBL2",140 ,0)
	2573	I IBGRP]" " S XMY("G ."_IBGRP_" @"_^XMB("N ETNAME"))= ""
	2574	"RTN","IBC NSBL2",141 ,0)
	2575	;
	2576	"RTN","IBC NSBL2",142 ,0)
	2577	D ^XMD
	2578	"RTN","IBC NSBL2",143 ,0)
	2579	;
	2580	"RTN","IBC NSBL2",144 ,0)
	2581	BULLQ Q
	2582	"RTN","IBC NSBL2",145 ,0)
	2583	;
	2584	"RTN","IBC NSBL2",146 ,0)
	2585	;
	2586	"RTN","IBC NSBL2",147 ,0)
	2587	CHPSUP(DFN ) ; Does t he patient have a TR ICARE Supp lemental p olicy?
	2588	"RTN","IBC NSBL2",148 ,0)
	2589	; Input: DFN -- Pointer to the pat ient in fi le #2
	2590	"RTN","IBC NSBL2",149 ,0)
	2591	; Output: 0 - Has no TRICAR E Suppleme ntal polic y
	2592	"RTN","IBC NSBL2",150 ,0)
	2593	; 1 - Yes , patient has such a policy.
	2594	"RTN","IBC NSBL2",151 ,0)
	2595	;
	2596	"RTN","IBC NSBL2",152 ,0)
	2597	N X,IBINS ,IBCS
	2598	"RTN","IBC NSBL2",153 ,0)
	2599	D ALL^IBC NS1(DFN,"I BINS",1,DT )
	2600	"RTN","IBC NSBL2",154 ,0)
	2601	S (IBCS,X )=0 F S X =$O(IBINS( X)) Q:'X D Q:IBCS
	2602	"RTN","IBC NSBL2",155 ,0)
	2603	.I $D(^IB E(355.1,"D ","CS",+$P ($G(IBINS( X,355.3)), "^",9))) S IBCS=1
	2604	"RTN","IBC NSBL2",156 ,0)
	2605	Q IBCS
	2606	"RTN","IBC NSBL2",157 ,0)
	2607	;
	2608	"RTN","IBC NSBL2",158 ,0)
	2609	WLCK(IBIFN ) ; does t his claim need to be removed f rom the wo rklist?
	2610	"RTN","IBC NSBL2",159 ,0)
	2611	; IBIFN = claim ien , if colle cted/close d and NO s ubsequent payer, rem ove from w orklist if there
	2612	"RTN","IBC NSBL2",160 ,0)
	2613	;
	2614	"RTN","IBC NSBL2",161 ,0)
	2615	N X
	2616	"RTN","IBC NSBL2",162 ,0)
	2617	Q:$P($$BI LL^RCJIBFN 2(IBIFN),U ,2)'=22 ; AR statu s DBIA 145 2
	2618	"RTN","IBC NSBL2",163 ,0)
	2619	Q:'$D(^DG CR(399,"CA P",1,IBIFN )) ; not on worklis t
	2620	"RTN","IBC NSBL2",164 ,0)
	2621	S X=$$WLR MVF^IBCECO B1(IBIFN," RM",1)
	2622	"RTN","IBC NSBL2",165 ,0)
	2623	Q
	2624	"RTN","IBE CEA")
	2625	0^12^B1371 4935^B1079 2926
	2626	"RTN","IBE CEA",1,0)
	2627	IBECEA ;AL B/RLW - Ca ncel/Edit/ Add Patien t Charges ;12-JUN-92
	2628	"RTN","IBE CEA",2,0)
	2629	;;2.0;INT EGRATED BI LLING ;1 99,135,568 ;21-MAR- 94;Build 4 0
	2630	"RTN","IBE CEA",3,0)
	2631	;;Per VA Directive 6402, this routine s hould not be modifie d.
	2632	"RTN","IBE CEA",4,0)
	2633	;
	2634	"RTN","IBE CEA",5,0)
	2635	EN ; Cance l/Edit/Add Patient C harges -- invoke the List Mana ger.
	2636	"RTN","IBE CEA",6,0)
	2637	K XQORS,V ALMEVL
	2638	"RTN","IBE CEA",7,0)
	2639	EN1 ; Entr ypoint to avoid kill ing XQORS
	2640	"RTN","IBE CEA",8,0)
	2641	I '$$CHEC K^IBECEAU( 1) G ENQ
	2642	"RTN","IBE CEA",9,0)
	2643	D EN^VALM ("IB CHARG ES")
	2644	"RTN","IBE CEA",10,0)
	2645	ENQ K IBSI TE,IBFAC,I BSERV
	2646	"RTN","IBE CEA",11,0)
	2647	Q
	2648	"RTN","IBE CEA",12,0)
	2649	;
	2650	"RTN","IBE CEA",13,0)
	2651	EN1AR ; AR entry for charge ma intenance
	2652	"RTN","IBE CEA",14,0)
	2653	N DIR,X,Y
	2654	"RTN","IBE CEA",15,0)
	2655	D EN1
	2656	"RTN","IBE CEA",16,0)
	2657	S DIR(0)= "EA",DIR(" A")="PRESS RETURN TO CONTINUE. "
	2658	"RTN","IBE CEA",17,0)
	2659	W ! D ^DI R K DIR
	2660	"RTN","IBE CEA",18,0)
	2661	Q
	2662	"RTN","IBE CEA",19,0)
	2663	;
	2664	"RTN","IBE CEA",20,0)
	2665	INIT ; Lis t Manager (IB CHARGE S) main en try point.
	2666	"RTN","IBE CEA",21,0)
	2667	S IBJOB=4 ,IBWHER="I BECEA",IBD UZ=DUZ
	2668	"RTN","IBE CEA",22,0)
	2669	S
	2670	IBACMAR="^ TMP(""IBAC M"",$J)",I BACMIDX="^ TMP(""IBAC MIDX"",$J) ",VALMIDX= "^TMP(""IB CMLIDX"",
	2671	$J)"
	2672	"RTN","IBE CEA",23,0)
	2673	I '$$SLPT S VALMQUI T="" D FNL G INITQ
	2674	"RTN","IBE CEA",24,0)
	2675	I $$SLDT S VALMQUIT ="" D FNL G INITQ
	2676	"RTN","IBE CEA",25,0)
	2677	I $$SLRX S VALMQUIT ="" D FNL G INITQ
	2678	"RTN","IBE CEA",26,0)
	2679	D ARRAY^I BECEA0
	2680	"RTN","IBE CEA",27,0)
	2681	INITQ Q
	2682	"RTN","IBE CEA",28,0)
	2683	;
	2684	"RTN","IBE CEA",29,0)
	2685	PAT ; 'Cha nge Patien t' protoco l entry ac tion.
	2686	"RTN","IBE CEA",30,0)
	2687	I $D(REC) S (GOTPAT ,DFN)=0 ;I B2.0568
	2688	"RTN","IBE CEA",31,0)
	2689	N IBDFN S IBDFN=DFN
	2690	"RTN","IBE CEA",32,0)
	2691	I '$$SLPT D MSG S D FN=IBDFN K REC,GOTPA T G PATQ ; IB2.0568
	2692	"RTN","IBE CEA",33,0)
	2693	DATE ; 'Ch ange Date' protocol entry acti on.
	2694	"RTN","IBE CEA",34,0)
	2695	N IBDT1,I BDT2,IBRXX X S IBDT1= IBABEG,IBD T2=IBAEND, IBRXXX=IBR X
	2696	"RTN","IBE CEA",35,0)
	2697	I $$SLDT D MSG S IB ABEG=IBDT1 ,IBAEND=IB DT2 S:$D(I BDFN) DFN= IBDFN G PA TQ
	2698	"RTN","IBE CEA",36,0)
	2699	I $$SLRX D MSG S IB ABEG=IBDT1 ,IBAEND=IB DT2,IBRX=I BRXXX S:$D (IBDFN) DF N=IBDFN G PATQ
	2700	"RTN","IBE CEA",37,0)
	2701	D ARRAY^I BECEA0,HDR S VALMBCK ="R"
	2702	"RTN","IBE CEA",38,0)
	2703	PATQ Q
	2704	"RTN","IBE CEA",39,0)
	2705	;
	2706	"RTN","IBE CEA",40,0)
	2707	MSG ; Quic k message display.
	2708	"RTN","IBE CEA",41,0)
	2709	N DIR,DIR UT,DUOUT,D TOUT,X,Y
	2710	"RTN","IBE CEA",42,0)
	2711	W !!,*7," No changes were made !",!
	2712	"RTN","IBE CEA",43,0)
	2713	S DIR(0)= "E" D ^DIR S VALMBCK =""
	2714	"RTN","IBE CEA",44,0)
	2715	Q
	2716	"RTN","IBE CEA",45,0)
	2717	;
	2718	"RTN","IBE CEA",46,0)
	2719	HDR ; Buil d screen h eader.
	2720	"RTN","IBE CEA",47,0)
	2721	S IBNAM=$ $PT^IBEFUN C(DFN)
	2722	"RTN","IBE CEA",48,0)
	2723	S VALMHDR (1)=$$SETS TR^VALM1($ $FDATE^VAL M1(IBABEG) _" THRU
	2724	"_$$FDATE^ VALM1(IBAE ND),"Cance l/Edit/Add Charges", 59,22)
	2725	"RTN","IBE CEA",49,0)
	2726	S VALMHDR (2)=$E("Pa tient: "_$ P(IBNAM,"^ "),1,25)_" "_$E(IBNA M)_$P(IBNA M,"^",3)
	2727	"RTN","IBE CEA",50,0)
	2728	Q
	2729	"RTN","IBE CEA",51,0)
	2730	;
	2731	"RTN","IBE CEA",52,0)
	2732	SLPT() ; S elect a pa tient.
	2733	"RTN","IBE CEA",53,0)
	2734	N DIC,X,Y
	2735	"RTN","IBE CEA",54,0)
	2736	I $G(GOTP AT) Q DFN ;IB2.05 68
	2737	"RTN","IBE CEA",55,0)
	2738	N DPTNOFZ Y S DPTNOF ZY=1 ;Sup press PATI ENT file f uzzy looku ps
	2739	"RTN","IBE CEA",56,0)
	2740	S DIC="^D PT(",DIC(0 )="AEMQ" D ^DIC S DF N=+Y
	2741	"RTN","IBE CEA",57,0)
	2742	Q Y>0
	2743	"RTN","IBE CEA",58,0)
	2744	;
	2745	"RTN","IBE CEA",59,0)
	2746	SLDT() ; S elect Char ge dates.
	2747	"RTN","IBE CEA",60,0)
	2748	N DIR,DIR UT,DUOUT,D TOUT,X,Y
	2749	"RTN","IBE CEA",61,0)
	2750	S DIR(0)= "DA^286010 1:NOW:EX", DIR("A")=" Search for CHARGES f rom:
	2751	",DIR("B") =$$DAT2^IB OUTL($$FMA DD^XLFDT(D T,-365)) D ^DIR S IB ABEG=+Y G: 'Y SLDTQ
	2752	"RTN","IBE CEA",62,0)
	2753	S DIR(0)= "DA^"_+Y_" :NOW:EX",D IR("A")=" to: ",DIR( "B")=$$DAT 2^IBOUTL(D T) D ^DIR S
	2754	IBAEND=+Y+ .999999
	2755	"RTN","IBE CEA",63,0)
	2756	SLDTQ Q $D (DIRUT)!($ D(DUOUT))
	2757	"RTN","IBE CEA",64,0)
	2758	;
	2759	"RTN","IBE CEA",65,0)
	2760	SLRX() ; I nclude Rx copay char ges?
	2761	"RTN","IBE CEA",66,0)
	2762	N DIR,DIR UT,DUOUT,D TOUT,X,Y
	2763	"RTN","IBE CEA",67,0)
	2764	S DIR(0)= "Y",DIR("A ")="Includ e RX COPAY charges", DIR("B")=" NO" D ^DIR S IBRX=Y
	2765	"RTN","IBE CEA",68,0)
	2766	Q $D(DIRU T)!($D(DUO UT))
	2767	"RTN","IBE CEA",69,0)
	2768	;
	2769	"RTN","IBE CEA",70,0)
	2770	RCFNL ;
	2771	"RTN","IBE CEA",71,0)
	2772	K:$D(IBAC MAR) @IBAC MAR,IBACMA R K:$D(IBA CMIDX) @IB ACMIDX,IBA CMIDX K:$D (VALMIDX)
	2773	@VALMIDX,V ALMIDX
	2774	"RTN","IBE CEA",72,0)
	2775	K
	2776	IBABEG,IBA END,DFN,IB AT,IBAX,IB Y,VA,IBRX, IBWHER,X,^ TMP("IBECE A",$J),^TM P("IBCMLID X",$J),IBS AVY,
	2777	IBARTYP,IB PRNT,IBDUZ ,IBJOB,IBX A,IBNOW,IB LDT,IBL,IB IL,IBNAM
	2778	"RTN","IBE CEA",73,0)
	2779	Q
	2780	"RTN","IBE CEA",74,0)
	2781	;
	2782	"RTN","IBE CEA",75,0)
	2783	FNL ; List Manager ( IB CHARGES ) exit act ion.
	2784	"RTN","IBE CEA",76,0)
	2785	K:$D(IBAC MAR) @IBAC MAR,IBACMA R K:$D(IBA CMIDX) @IB ACMIDX,IBA CMIDX K:$D (VALMIDX)
	2786	@VALMIDX,V ALMIDX
	2787	"RTN","IBE CEA",77,0)
	2788	K
	2789	IBABEG,IBA END,DFN,IB AT,IBAX,IB Y,VA,IBRX, IBWHER,X,^ TMP("IBECE A",$J),^TM P("IBCMLID X",$J),DFN ,IB
	2790	SAVY,IBART YP,IBPRNT, IBDUZ,IBJO B,IBXA,IBN OW,IBLDT,I BL,IBIL,IB NAM
	2791	"RTN","IBE CEA",78,0)
	2792	Q
	2793	"RTN","IBE CEA",79,0)
	2794	;
	2795	"RTN","IBE CEA",80,0)
	2796	EXIT Q
	2797	"RTN","IBJ DB21")
	2798	0^18^B1274 96258^B733 70335
	2799	"RTN","IBJ DB21",1,0)
	2800	IBJDB21 ;A LB/RB - RE ASONS NOT BILLABLE R EPORT (COM PILE) ;19- JUN-00
	2801	"RTN","IBJ DB21",2,0)
	2802	;;2.0;INT EGRATED BI LLING;12 3,159,185, 399,437,45 8,568;21 -MAR-94;Bu ild 40
	2803	"RTN","IBJ DB21",3,0)
	2804	;;Per VA Directive 6402, this routine s hould not be modifie d.
	2805	"RTN","IBJ DB21",4,0)
	2806	;;
	2807	"RTN","IBJ DB21",5,0)
	2808	EN ; - Ent ry point f rom IBJDB2 .
	2809	"RTN","IBJ DB21",6,0)
	2810	K ^TMP("I BJDB2",$J) ,IB,IBE,EN CTYP,EPIEN ,IBADMDT,R ELBILL
	2811	"RTN","IBJ DB21",7,0)
	2812	I '$G(IBX TRACT) D
	2813	"RTN","IBJ DB21",8,0)
	2814	. F X=1:1 :4 I IBSEL [X S IBE(X )=IBEPS(X) ; Set epi sodes for report.
	2815	"RTN","IBJ DB21",9,0)
	2816	;
	2817	"RTN","IBJ DB21",10,0 )
	2818	; - Print the heade r line for the Excel spreadshe et
	2819	"RTN","IBJ DB21",11,0 )
	2820	I $G(IBEX CEL) D PHD L
	2821	"RTN","IBJ DB21",12,0 )
	2822	;
	2823	"RTN","IBJ DB21",13,0 )
	2824	; - Compi le reason not billab le (RNB) d ata for ep isode.
	2825	"RTN","IBJ DB21",14,0 )
	2826	S IBRNB=0 F S IBRN B=$S(IBSRN B'="A":$O( IBSRNB(IBR NB)),1:$O( ^IBE(356.8 ,IBRNB))) Q:'IBRNB D
	2827	"RTN","IBJ DB21",15,0 )
	2828	.S IB0=0 F S IB0=$ O(^IBT(356 ,"AR",IBRN B,IB0)) Q: 'IB0 D
	2829	"RTN","IBJ DB21",16,0 )
	2830	..S IBN0= $G(^IBT(35 6,IB0,0)), IBN1=$G(^I BT(356,IB0 ,1)) Q:'IB N0!('IBN1)
	2831	"RTN","IBJ DB21",17,0 )
	2832	..S IBEP= +$P(IBN0,U ,18) I IBS EL'[IBEP Q ; Get ep isode.
	2833	"RTN","IBJ DB21",18,0 )
	2834	..S (IBRN B1,IBSORT1 )=$P($G(^I BE(356.8,I BRNB,0)),U )
	2835	"RTN","IBJ DB21",19,0 )
	2836	..;
	2837	"RTN","IBJ DB21",20,0 )
	2838	..; - Get valid dat e entered/ episode da te and amo unt for re port.
	2839	"RTN","IBJ DB21",21,0 )
	2840	..S IBEPD =+$P(IBN0, U,6)\1,IBD EN=+IBN1\1
	2841	"RTN","IBJ DB21",22,0 )
	2842	..S IBDT= $S($E(IBD) ="D":IBDEN ,1:IBEPD)
	2843	"RTN","IBJ DB21",23,0 )
	2844	..Q:IBDT< IBBDT!(IBD T>IBEDT)
	2845	"RTN","IBJ DB21",24,0 )
	2846	..S IBAMT =$$AMOUNT( IBEP,IB0)
	2847	"RTN","IBJ DB21",25,0 )
	2848	..I IBAMT <0 Q ;Qui t if amoun t is -1 *5 68
	2849	"RTN","IBJ DB21",26,0 )
	2850	..;
	2851	"RTN","IBJ DB21",27,0 )
	2852	..; - Get division, if necess ary.
	2853	"RTN","IBJ DB21",28,0 )
	2854	..I IBSD D Q:'VAUT D&('$D(VAU TD(IBDIV)) )
	2855	"RTN","IBJ DB21",29,0 )
	2856	...S IBDI V=$$DIV^IB JD1(IB0)
	2857	"RTN","IBJ DB21",30,0 )
	2858	..E S IB DIV=$S($G( IBEXCEL):+ $$PRIM^VAS ITE(),1:0)
	2859	"RTN","IBJ DB21",31,0 )
	2860	..;
	2861	"RTN","IBJ DB21",32,0 )
	2862	..; - Pro vider & Sp ecialty
	2863	"RTN","IBJ DB21",33,0 )
	2864	..S (IBPR V,IBSPC)=" ",IBQT=0
	2865	"RTN","IBJ DB21",34,0 )
	2866	..I IBEP= 1!(IBEP=2) D I IBQT Q
	2867	"RTN","IBJ DB21",35,0 )
	2868	...S IBPR SP=$$PRVSP C(IBEP,IB0 )
	2869	"RTN","IBJ DB21",36,0 )
	2870	...I IBSP RV'="A",'$ D(IBSPRV(+ IBPRSP)) S IBQT=1 Q
	2871	"RTN","IBJ DB21",37,0 )
	2872	...I IBEP =1,IBSISP' ="A",'$D(I BSISP(+$P( IBPRSP,U,3 ))) S IBQT =1 Q
	2873	"RTN","IBJ DB21",38,0 )
	2874	...I IBEP =2,IBSOSP' ="A",'$D(I BSOSP(+$P( IBPRSP,U,3 ))) S IBQT =1 Q
	2875	"RTN","IBJ DB21",39,0 )
	2876	...S IBPR V=$S($P(IB PRSP,U,2)' ="":$P(IBP RSP,U,2),1 :" UNKNO WN ")
	2877	"RTN","IBJ DB21",40,0 )
	2878	...S IBSP C=$S($P(IB PRSP,U,4)' ="":$P(IBP RSP,U,4),1 :" UNKNO WN ")
	2879	"RTN","IBJ DB21",41,0 )
	2880	..;
	2881	"RTN","IBJ DB21",42,0 )
	2882	..; - Get remaining data for detailed r eport.
	2883	"RTN","IBJ DB21",43,0 )
	2884	..S DFN=+ $P(IBN0,U, 2)
	2885	"RTN","IBJ DB21",44,0 )
	2886	..D DEM^V ADPT S IBP T=$E(VADM( 1),1,25),I BSSN=$P(VA DM(2),U)
	2887	"RTN","IBJ DB21",45,0 )
	2888	..S DIC=" ^VA(200,", DA=+$P(IBN 1,U,4),DR= ".01",DIQ= "IBCLK" D EN^DIQ1
	2889	"RTN","IBJ DB21",46,0 )
	2890	..S IBCLK =$E($G(IBC LK(200,DA, .01)),1,20 )
	2891	"RTN","IBJ DB21",47,0 )
	2892	..I ($P(I BN0,U,18)= 2)&($$EXTE RNAL^DILFD (356,.19," ",$P(IBN0, U,19))["72 HOUR RULE ") D
	2893	"RTN","IBJ DB21",48,0 )
	2894	...S IBAD MDT=$$ADMD T^IBTUTL5( DFN,$P(IBN 0,U,6))
	2895	"RTN","IBJ DB21",49,0 )
	2896	..E S IB ADMDT=""
	2897	"RTN","IBJ DB21",50,0 )
	2898	..S ENCTY P=$P(^IBE( 356.6,$P(I BN0,U,18), 0),U,3) S EPDT=$E($P (IBN0,U,6) ,1,7)
	2899	"RTN","IBJ DB21",51,0 )
	2900	..S EPIEN =$S(ENCTYP =3:$P(IBN0 ,U,8),ENCT YP=4:$P(IB N0,U,9),1: "")
	2901	"RTN","IBJ DB21",52,0 )
	2902	..S RELBI LL=$$RELBI L^IBTUTL5( EPIEN,EPDT ,DFN,ENCTY P)
	2903	"RTN","IBJ DB21",53,0 )
	2904	..;
	2905	"RTN","IBJ DB21",54,0 )
	2906	..; - Get totals fo r summary.
	2907	"RTN","IBJ DB21",55,0 )
	2908	..I '$D(I B(IBDIV,IB EP,IBRNB)) S IB(IBDI V,IBEP,IBR NB)="0^0"
	2909	"RTN","IBJ DB21",56,0 )
	2910	..S $P(IB (IBDIV,IBE P,IBRNB),U )=$P(IB(IB DIV,IBEP,I BRNB),U)+1
	2911	"RTN","IBJ DB21",57,0 )
	2912	..S $P(IB (IBDIV,IBE P,IBRNB),U ,2)=$P(IB( IBDIV,IBEP ,IBRNB),U, 2)+IBAMT
	2913	"RTN","IBJ DB21",58,0 )
	2914	..I IBRPT ="S" Q
	2915	"RTN","IBJ DB21",59,0 )
	2916	..;
	2917	"RTN","IBJ DB21",60,0 )
	2918	..S IBSOR T1=$S(IBSO RT="P":IBP RV,IBSORT= "S":IBSPC, 1:IBSORT1)
	2919	"RTN","IBJ DB21",61,0 )
	2920	..S:IBSOR T1="" IBSO RT1=" "
	2921	"RTN","IBJ DB21",62,0 )
	2922	..;
	2923	"RTN","IBJ DB21",63,0 )
	2924	..I $G(IB EXCEL) D Q
	2925	"RTN","IBJ DB21",64,0 )
	2926	...W !,$E ($P($G(^DG (40.8,IBDI V,0)),U),1 ,25),U
	2927	"RTN","IBJ DB21",65,0 )
	2928	...W $S(I BEP<4:$E(I BE(IBEP)), 1:"H"),U,I BPT,U,$E(I BSSN,6,10) ,U
	2929	"RTN","IBJ DB21",66,0 )
	2930	...W $E($ $INS^IBJD1 (+$P(IBN0, U,2),IBEPD ),1,25),U
	2931	"RTN","IBJ DB21",67,0 )
	2932	...W $$DT ^IBJD(IBEP D,1),U,$$D T^IBJD(IBD EN,1),U
	2933	"RTN","IBJ DB21",68,0 )
	2934	...W $$DT ^IBJD($P(I BN1,U,3),1 ),U,IBCLK, U,IBADMDT, U,$E(IBRNB 1,1,25),U
	2935	"RTN","IBJ DB21",69,0 )
	2936	...W $E(I BPRV,1,25) ,U,$E(IBSP C,1,25),U, IBAMT,U
	2937	"RTN","IBJ DB21",70,0 )
	2938	...I RELB ILL>0 F X= 2:1:$P(REL BILL,";",1 )+1 W $P(R ELBILL,";" ,X)_" "
	2939	"RTN","IBJ DB21",71,0 )
	2940	...I RELB ILL<0 W ""
	2941	"RTN","IBJ DB21",72,0 )
	2942	...W U,$P (IBN1,U,8)
	2943	"RTN","IBJ DB21",73,0 )
	2944	..;
	2945	"RTN","IBJ DB21",74,0 )
	2946	..S X=IBE PD_U_IBDEN _U_$P(IBN1 ,U,3)_U_IB CLK_U_IBRN B1
	2947	"RTN","IBJ DB21",75,0 )
	2948	..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
	2949	"RTN","IBJ DB21",76,0 )
	2950	..S
	2951	^TMP("IBJD B2",$J,IBD IV,IBEP,IB SORT1,IBPT _"@@"_$E(I BSSN,6,10) )=$$INS^IB JD1(+$P(IB N0,U,2),IB EPD)
	2952	"RTN","IBJ DB21",77,0 )
	2953	..S ^TMP( "IBJDB2",$ J,IBDIV,IB EP,IBSORT1 ,IBPT_"@@" _$E(IBSSN, 6,10),+IBN 0)=X
	2954	"RTN","IBJ DB21",78,0 )
	2955	;
	2956	"RTN","IBJ DB21",79,0 )
	2957	I '$G(IBE XCEL) D EN ^IBJDB22 ; Print rep ort(s).
	2958	"RTN","IBJ DB21",80,0 )
	2959	;
	2960	"RTN","IBJ DB21",81,0 )
	2961	ENQ K ^TMP ("IBJDB2")
	2962	"RTN","IBJ DB21",82,0 )
	2963	K DA,DIC, DIQ,DR,IB, IB0,IBAMT, IBCLK,IBDE N,IBDIV,IB DT,IBE,IBE P,IBEPD,IB I
	2964	"RTN","IBJ DB21",83,0 )
	2965	K IBN0,IB N1,IBN2,IB PRSP,IBPRV ,IBPT,IBQT ,IBRNB,IBR NB1,IBSORT 1,IBSPC
	2966	"RTN","IBJ DB21",84,0 )
	2967	K IBSSN,V ADM,X1,X2
	2968	"RTN","IBJ DB21",85,0 )
	2969	Q
	2970	"RTN","IBJ DB21",86,0 )
	2971	;
	2972	"RTN","IBJ DB21",87,0 )
	2973	AMOUNT(EPS ,CLM) ; Re turn the A mount not billed
	2974	"RTN","IBJ DB21",88,0 )
	2975	; Input: EPS - Epis ode(1=Inpa tient,2=Ou tpatient,3 =Prosthet. ,4=Prescr. )
	2976	"RTN","IBJ DB21",89,0 )
	2977	; CLM - Poin ter to Cla im Trackin g File (#3 56)
	2978	"RTN","IBJ DB21",90,0 )
	2979	;Output: AMOUNT not billed
	2980	"RTN","IBJ DB21",91,0 )
	2981	;
	2982	"RTN","IBJ DB21",92,0 )
	2983	N ADM,ADM DT,AMOUNT, BLBS,BLDT, CPT,CPTLST ,DA,DR,DCH D,DFN,DIC, DIQ,DIV,DR G,SPCLTY
	2984	"RTN","IBJ DB21",93,0 )
	2985	N IBRX,EN C,ENCDT,EP DT,PFT,PRS T,PTF,RIMB ,VCPT,TTCS T,X
	2986	"RTN","IBJ DB21",94,0 )
	2987	;
	2988	"RTN","IBJ DB21",95,0 )
	2989	S AMOUNT= 0,X=$G(^IB T(356,CLM, 0))
	2990	"RTN","IBJ DB21",96,0 )
	2991	S ENC=+$P (X,U,4) ; Encoun ter (Po inter to # 409.68)
	2992	"RTN","IBJ DB21",97,0 )
	2993	S ADM=+$P (X,U,5) ; Admiss ion (Po inter to # 405)
	2994	"RTN","IBJ DB21",98,0 )
	2995	S PRST=+$ P(X,U,9) ; Prothe tics (Po inter to # 660)
	2996	"RTN","IBJ DB21",99,0 )
	2997	S EPDT=$P (X,U,6) ; Episod e Date (FM format)
	2998	"RTN","IBJ DB21",100, 0)
	2999	S IBRX=+$ P(X,U,8)
	3000	"RTN","IBJ DB21",101, 0)
	3001	;
	3002	"RTN","IBJ DB21",102, 0)
	3003	; - Assum es REIMBUR SABLE INS. as the RA TE TYPE
	3004	"RTN","IBJ DB21",103, 0)
	3005	S RIMB=$O (^DGCR(399 .3,"B","RE IMBURSABLE INS.",0)) I 'RIMB S RIMB=8
	3006	"RTN","IBJ DB21",104, 0)
	3007	;
	3008	"RTN","IBJ DB21",105, 0)
	3009	G @("AMT" _EPS)
	3010	"RTN","IBJ DB21",106, 0)
	3011	;
	3012	"RTN","IBJ DB21",107, 0)
	3013	AMT1 ; - I npatient C harges
	3014	"RTN","IBJ DB21",108, 0)
	3015	I 'ADM S AMOUNT=-1 G QAMT
	3016	"RTN","IBJ DB21",109, 0)
	3017	S X=$G(^D GPM(ADM,0) ) I X="" S AMOUNT=-1 G QAMT
	3018	"RTN","IBJ DB21",110, 0)
	3019	S PTF=$P( X,U,16) I 'PTF S AMO UNT=-1 G Q AMT
	3020	"RTN","IBJ DB21",111, 0)
	3021	S ADMDT=$ P(X,U)\1,D FN=+$P(X,U ,3)
	3022	"RTN","IBJ DB21",112, 0)
	3023	I $P(X,U, 17) S DCHD =$P($G(^DG PM(+$P(X,U ,17),0)),U )\1
	3024	"RTN","IBJ DB21",113, 0)
	3025	I '$G(DCH D) S DCHD= $$DT^XLFDT ()
	3026	"RTN","IBJ DB21",114, 0)
	3027	;
	3028	"RTN","IBJ DB21",115, 0)
	3029	K ^TMP($J ,"IBCRC-PT F"),^TMP($ J,"IBCRC-D IV"),^TMP( $J,"IBCRC- INDT")
	3030	"RTN","IBJ DB21",116, 0)
	3031	D PTF^IBC RBG(PTF) I '$D(^TMP( $J,"IBCRC- PTF")) S A MOUNT=-1 G QAMT ;*5 68
	3032	"RTN","IBJ DB21",117, 0)
	3033	D PTFDV^I BCRBG(PTF) I '$D(^TM P($J,"IBCR C-DIV")) S AMOUNT=-1 G QAMT ; *568
	3034	"RTN","IBJ DB21",118, 0)
	3035	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
	3036	"RTN","IBJ DB21",119, 0)
	3037	;
	3038	"RTN","IBJ DB21",120, 0)
	3039	S BLDT=""
	3040	"RTN","IBJ DB21",121, 0)
	3041	F S BLDT =$O(^TMP($ J,"IBCRC-I NDT",BLDT) ) Q:BLDT=" " D
	3042	"RTN","IBJ DB21",122, 0)
	3043	.S X=^TMP ($J,"IBCRC -INDT",BLD T)
	3044	"RTN","IBJ DB21",123, 0)
	3045	.S BLBS=$ P(X,U,2),D RG=$P(X,U, 4),DIV=$P( X,U,5),SPC LTY=$P(X,U ,6)
	3046	"RTN","IBJ DB21",124, 0)
	3047	.;
	3048	"RTN","IBJ DB21",125, 0)
	3049	.; - Tort Liable Ch arge (prio r to 09/01 /99)
	3050	"RTN","IBJ DB21",126, 0)
	3051	.I BLDT<2 990901 D Q
	3052	"RTN","IBJ DB21",127, 0)
	3053	..S AMOUN T=AMOUNT+$ $BICOST^IB CRCI(RIMB, 1,BLDT,"IN PATIENT BE DSECTION S TAY",BLBS)
	3054	"RTN","IBJ DB21",128, 0)
	3055	.;
	3056	"RTN","IBJ DB21",129, 0)
	3057	.; - Reas onable Cha rges (on 0 9/01/99 or later)
	3058	"RTN","IBJ DB21",130, 0)
	3059	.I $$NODR G^IBCRBG2( SPCLTY)["O bservation " Q
	3060	"RTN","IBJ DB21",131, 0)
	3061	.I $$NODR G^IBCRBG2( SPCLTY)["N ursing Hom e Care" D Q
	3062	"RTN","IBJ DB21",132, 0)
	3063	..S BLBS= $$MCCRUTL^ IBCRU1("SK ILLED NURS ING CARE", 25)
	3064	"RTN","IBJ DB21",133, 0)
	3065	..S AMOUN T=AMOUNT+$ $BICOST^IB CRCI(RIMB, 1,BLDT,"IN PATIENT BE DSECTION
	3066	STAY",BLBS ,"",DIV,"" ,1)
	3067	"RTN","IBJ DB21",134, 0)
	3068	.;
	3069	"RTN","IBJ DB21",135, 0)
	3070	.S BLBS=$ $BSUPD^IBC RBG2(+SPCL TY,BLDT,1)
	3071	"RTN","IBJ DB21",136, 0)
	3072	.S AMOUNT =AMOUNT+$$ BICOST^IBC RCI(RIMB,1 ,BLDT,"INP ATIENT DRG ",DRG,"",D IV,"",1,BL BS)
	3073	"RTN","IBJ DB21",137, 0)
	3074	;
	3075	"RTN","IBJ DB21",138, 0)
	3076	; - Add t he Profess ional Aver age Amount per Episo de (Reason .Chg only)
	3077	"RTN","IBJ DB21",139, 0)
	3078	I EPDT'<2 990901 S A MOUNT=AMOU NT+$$AVG(E PDT)
	3079	"RTN","IBJ DB21",140, 0)
	3080	;
	3081	"RTN","IBJ DB21",141, 0)
	3082	; - Subtr act the am ount bille d for this Episode
	3083	"RTN","IBJ DB21",142, 0)
	3084	S AMOUNT= AMOUNT-$$C LAMT(DFN,E PDT,1) I A MOUNT=0 S AMOUNT=-1 ;*568
	3085	"RTN","IBJ DB21",143, 0)
	3086	;
	3087	"RTN","IBJ DB21",144, 0)
	3088	K ^TMP($J ,"IBCRC-PT F"),^TMP($ J,"IBCRC-D IV"),^TMP( $J,"IBCRC- INDT")
	3089	"RTN","IBJ DB21",145, 0)
	3090	;
	3091	"RTN","IBJ DB21",146, 0)
	3092	G QAMT
	3093	"RTN","IBJ DB21",147, 0)
	3094	;
	3095	"RTN","IBJ DB21",148, 0)
	3096	AMT2 ; - O utpatient Charges
	3097	"RTN","IBJ DB21",149, 0)
	3098	S X=$$GET OE^SDOE(EN C),ENCDT=+ $P(X,U),DF N=+$P(X,U, 2),DIV=$P( X,U,11)
	3099	"RTN","IBJ DB21",150, 0)
	3100	;
	3101	"RTN","IBJ DB21",151, 0)
	3102	; - Tort Liable Cha rge (prior to 09/01/ 99)
	3103	"RTN","IBJ DB21",152, 0)
	3104	I ENCDT<2 990901 D G QAMT
	3105	"RTN","IBJ DB21",153, 0)
	3106	. S AMOUN T=+$$BICOS T^IBCRCI(R IMB,3,ENCD T,"OUTPATI ENT VISIT DATE")
	3107	"RTN","IBJ DB21",154, 0)
	3108	;
	3109	"RTN","IBJ DB21",155, 0)
	3110	S AMOUNT= $$OPT(ENC, EPDT) ;*5 68
	3111	"RTN","IBJ DB21",156, 0)
	3112	G QAMT ; *568
	3113	"RTN","IBJ DB21",157, 0)
	3114	;
	3115	"RTN","IBJ DB21",158, 0)
	3116	AMT3 ; Pro sthetic Ch arges
	3117	"RTN","IBJ DB21",159, 0)
	3118	N NTBLD
	3119	"RTN","IBJ DB21",160, 0)
	3120	S NTBLD=$ $PRSAMT^IB TUTL5(EPDT ,PRST) I N TBLD=0 S A MOUNT=-1 G QAMT ;*5 68
	3121	"RTN","IBJ DB21",161, 0)
	3122	S DIC="^R MPR(660,", DA=PRST,DR ="14",DIQ= "TTCST" D EN^DIQ1
	3123	"RTN","IBJ DB21",162, 0)
	3124	S AMOUNT= +$G(TTCST( 660,DA,14) )
	3125	"RTN","IBJ DB21",163, 0)
	3126	G QAMT
	3127	"RTN","IBJ DB21",164, 0)
	3128	;
	3129	"RTN","IBJ DB21",165, 0)
	3130	AMT4 ; - P rescriptio n Charges
	3131	"RTN","IBJ DB21",166, 0)
	3132	;
	3133	"RTN","IBJ DB21",167, 0)
	3134	; Protect Rx intern al entry # before RX AMT call s witches to RX number
	3135	"RTN","IBJ DB21",168, 0)
	3136	N IBRXIEN ,NTBLD S I BRXIEN=IBR X
	3137	"RTN","IBJ DB21",169, 0)
	3138	;
	3139	"RTN","IBJ DB21",170, 0)
	3140	; - Tort Liable Cha rge & Reas onable Cha rge (same source)
	3141	"RTN","IBJ DB21",171, 0)
	3142	S NTBLD=$ $RXAMT^IBT UTL5(EPDT, IBRX) I NT BLD=0 S AM OUNT=-1 G QAMT ;*56 8
	3143	"RTN","IBJ DB21",172, 0)
	3144	;
	3145	"RTN","IBJ DB21",173, 0)
	3146	; Patch 4 37 update to call ch arge maste r with eno ugh inform ation
	3147	"RTN","IBJ DB21",174, 0)
	3148	; to look up actual cost of pr escription
	3149	"RTN","IBJ DB21",175, 0)
	3150	;
	3151	"RTN","IBJ DB21",176, 0)
	3152	N IBBI,IB RSNEW
	3153	"RTN","IBJ DB21",177, 0)
	3154	;
	3155	"RTN","IBJ DB21",178, 0)
	3156	; check c harge mast er for the type of b illing--VA Cost or n ot
	3157	"RTN","IBJ DB21",179, 0)
	3158	S IBBI=$$ EVNTITM^IB CRU3(+RIMB ,3,"PRESCR IPTION FIL L",EPDT,.I BRSNEW)
	3159	"RTN","IBJ DB21",180, 0)
	3160	;
	3161	"RTN","IBJ DB21",181, 0)
	3162	S DFN=$$F ILE^IBRXUT L(IBRXIEN, 2)
	3163	"RTN","IBJ DB21",182, 0)
	3164	I $G(DFN) >0&(IBBI[" VA COST") D
	3165	"RTN","IBJ DB21",183, 0)
	3166	. N IBQT Y,IBCOST,I BRFNUM,IBS UBND,IBFEE ,IBRXNODE
	3167	"RTN","IBJ DB21",184, 0)
	3168	.; if th is is a re fill look up the ref ill info f or cost an d quantity
	3169	"RTN","IBJ DB21",185, 0)
	3170	. S IBRF NUM=$$RFLN UM^IBRXUTL (IBRXIEN,E PDT,"")
	3171	"RTN","IBJ DB21",186, 0)
	3172	. I IBRF NUM>0 D
	3173	"RTN","IBJ DB21",187, 0)
	3174	.. S I BSUBND=$$Z EROSUB^IBR XUTL(DFN,I BRXIEN,IBR FNUM)
	3175	"RTN","IBJ DB21",188, 0)
	3176	.. S I BQTY=$P($G (IBSUBND), U,4)
	3177	"RTN","IBJ DB21",189, 0)
	3178	.. S I BCOST=$P($ G(IBSUBND) ,U,11)
	3179	"RTN","IBJ DB21",190, 0)
	3180	.;
	3181	"RTN","IBJ DB21",191, 0)
	3182	.; if th is was an original f ill look u p zero nod e for Rx i nfo
	3183	"RTN","IBJ DB21",192, 0)
	3184	. E D
	3185	"RTN","IBJ DB21",193, 0)
	3186	.. S I BRXNODE=$$ RXZERO^IBR XUTL(DFN,I BRXIEN)
	3187	"RTN","IBJ DB21",194, 0)
	3188	.. S I BQTY=$P($G (IBRXNODE) ,U,7)
	3189	"RTN","IBJ DB21",195, 0)
	3190	.. S I BCOST=$P($ G(IBRXNODE ),U,17)
	3191	"RTN","IBJ DB21",196, 0)
	3192	.;
	3193	"RTN","IBJ DB21",197, 0)
	3194	. S IBRS NEW=+$O(IB RSNEW($P(I BBI,";"),0 ))
	3195	"RTN","IBJ DB21",198, 0)
	3196	. S AMOU NT=$J(+$$R ATECHG^IBC RCC(+IBRSN EW,IBQTY*I BCOST,EPDT ,.IBFEE),0 ,2)
	3197	"RTN","IBJ DB21",199, 0)
	3198	E D
	3199	"RTN","IBJ DB21",200, 0)
	3200	. S AMOU NT=+$$BICO ST^IBCRCI( RIMB,3,EPD T,"PRESCRI PTION FILL ")
	3201	"RTN","IBJ DB21",201, 0)
	3202	;
	3203	"RTN","IBJ DB21",202, 0)
	3204	;
	3205	"RTN","IBJ DB21",203, 0)
	3206	QAMT I AMO UNT=0 S AM OUNT=-1 ;* 568
	3207	"RTN","IBJ DB21",204, 0)
	3208	Q AMOUNT
	3209	"RTN","IBJ DB21",205, 0)
	3210	;
	3211	"RTN","IBJ DB21",206, 0)
	3212	CLAMT(DFN, EPDT,PT) ; Returns t he Total A mount of C laims for Patient/Ep isode
	3213	"RTN","IBJ DB21",207, 0)
	3214	;
	3215	"RTN","IBJ DB21",208, 0)
	3216	; Input: DFN - Poi nter to th e Patient File #2
	3217	"RTN","IBJ DB21",209, 0)
	3218	; EPDT - Epi sode Date
	3219	"RTN","IBJ DB21",210, 0)
	3220	; PT - 0=O utpatient, 1=Inpatie nt
	3221	"RTN","IBJ DB21",211, 0)
	3222	;
	3223	"RTN","IBJ DB21",212, 0)
	3224	N CLAMT,C LM,DAY,IBD ,X
	3225	"RTN","IBJ DB21",213, 0)
	3226	S CLAMT=0 ,DAY=EPDT- 1,CLM=""
	3227	"RTN","IBJ DB21",214, 0)
	3228	F S CLM= $O(^DGCR(3 99,"C",DFN ,CLM)) Q:' CLM D
	3229	"RTN","IBJ DB21",215, 0)
	3230	.S X=$G(^ DGCR(399,C LM,0))
	3231	"RTN","IBJ DB21",216, 0)
	3232	.I $P($P( X,U,3),"." )=$P(EPDT, ".") D
	3233	"RTN","IBJ DB21",217, 0)
	3234	..S IBD=$ $CKBIL^IBT UBOU(CLM,P T) Q:IBD=" "
	3235	"RTN","IBJ DB21",218, 0)
	3236	..I '$P(I BD,U,3) Q ; Not aut horized
	3237	"RTN","IBJ DB21",219, 0)
	3238	..S CLAMT =CLAMT+$G( ^DGCR(399, CLM,"U1"))
	3239	"RTN","IBJ DB21",220, 0)
	3240	;
	3241	"RTN","IBJ DB21",221, 0)
	3242	QCLAMT Q C LAMT
	3243	"RTN","IBJ DB21",222, 0)
	3244	;
	3245	"RTN","IBJ DB21",223, 0)
	3246	OPT(IBOE,I BDT) ; - H as the out patient en counter be en billed?
	3247	"RTN","IBJ DB21",224, 0)
	3248	; Input : IBOE=poi nter to ou tpatient e ncounter i n file #40 9.68
	3249	"RTN","IBJ DB21",225, 0)
	3250	; IBDT=eve nt date CL AIMS TRACK ING(#356)
	3251	"RTN","IBJ DB21",226, 0)
	3252	;
	3253	"RTN","IBJ DB21",227, 0)
	3254	; ; *P re-set var iables: DF N=patient IEN, RIMB= bill rate
	3255	"RTN","IBJ DB21",228, 0)
	3256	;
	3257	"RTN","IBJ DB21",229, 0)
	3258	;
	3259	"RTN","IBJ DB21",230, 0)
	3260	I '$G(DFN )!('$G(IBD T))!('$G(R IMB))!('$G (IBOE)) S IBRTN=0 G OPTQ
	3261	"RTN","IBJ DB21",231, 0)
	3262	N IBCN,IB CPT,IBCT,I BDATA,IBDA Y,IBDIV,IB XX,IBYD,IB YY,IBZ,IBM RA,IBCPTSU M,IBTCHRG, IBRTN,IBAU TH
	3263	"RTN","IBJ DB21",232, 0)
	3264	; - Check to be sur e the enco unter is b illable.
	3265	"RTN","IBJ DB21",233, 0)
	3266	I $$INPT^ IBAMTS1(DF N,IBDT\1_. 2359) S IB RTN=-1 G O PTQ ; Bec ame inpati ent same d ay.
	3267	"RTN","IBJ DB21",234, 0)
	3268	I $$ENCL^ IBAMTS2(IB OE)["1" S IBRTN=-1 G OPTQ ; " ao^ir^sc^s wa^mst^hnc ^cv^shad" encounter.
	3269	"RTN","IBJ DB21",235, 0)
	3270	;
	3271	"RTN","IBJ DB21",236, 0)
	3272	;
	3273	"RTN","IBJ DB21",237, 0)
	3274	; - Gathe r all proc edures ass ociated wi th the enc ounter.
	3275	"RTN","IBJ DB21",238, 0)
	3276	D GETCPT^ SDOE(IBOE, "IBYY") I '$G(IBYY) S IBRTN=-1 G OPTQ ; Check CPT qty.
	3277	"RTN","IBJ DB21",239, 0)
	3278	;
	3279	"RTN","IBJ DB21",240, 0)
	3280	; - Deter mine the e ncounter d ivision.
	3281	"RTN","IBJ DB21",241, 0)
	3282	S IBDIV=+ $P($$GETOE ^SDOE(IBOE ),U,11) S: 'IBDIV IBD IV=+$$PRIM ^VASITE()
	3283	"RTN","IBJ DB21",242, 0)
	3284	;
	3285	"RTN","IBJ DB21",243, 0)
	3286	; - Build array of all billab le encount er procedu res.
	3287	"RTN","IBJ DB21",244, 0)
	3288	S IBXX=0 F S IBXX= $O(IBYY(IB XX)) Q:'IB XX D
	3289	"RTN","IBJ DB21",245, 0)
	3290	. ;
	3291	"RTN","IBJ DB21",246, 0)
	3292	. ; - Get procedure pointer a nd code.
	3293	"RTN","IBJ DB21",247, 0)
	3294	. S IBZ=+ IBYY(IBXX) ,IBCN=$P($ $CPT^ICPTC OD(IBZ),"^ ",2)
	3295	"RTN","IBJ DB21",248, 0)
	3296	. ;
	3297	"RTN","IBJ DB21",249, 0)
	3298	. ; - Ign ore LAB se rvices for vets with Medicare Supplement al coverag e.
	3299	"RTN","IBJ DB21",250, 0)
	3300	. I IBCN> 79999,IBCN <90000 Q
	3301	"RTN","IBJ DB21",251, 0)
	3302	. ;
	3303	"RTN","IBJ DB21",252, 0)
	3304	. ; - Get the insti tutional/p rofessiona l charge c omponents.
	3305	"RTN","IBJ DB21",253, 0)
	3306	. S IBCPT (IBZ,1)=+$ $BICOST^IB CRCI(RIMB, 3,IBDT,"PR OCEDURE",I BZ,"",IBDI V,"",1)
	3307	"RTN","IBJ DB21",254, 0)
	3308	. S IBCPT (IBZ,2)=+$ $BICOST^IB CRCI(RIMB, 3,IBDT,"PR OCEDURE",I BZ,"",IBDI V,"",2)
	3309	"RTN","IBJ DB21",255, 0)
	3310	. ;
	3311	"RTN","IBJ DB21",256, 0)
	3312	. ; - Eli minate com ponents wi thout a ch arge.
	3313	"RTN","IBJ DB21",257, 0)
	3314	. S IBCPT SUM(IBZ)=+ $G(IBCPT(I BZ,1))+$G( IBCPT(IBZ, 2))
	3315	"RTN","IBJ DB21",258, 0)
	3316	. I 'IBCP T(IBZ,1) K IBCPT(IBZ ,1)
	3317	"RTN","IBJ DB21",259, 0)
	3318	. I 'IBCP T(IBZ,2) K IBCPT(IBZ ,2)
	3319	"RTN","IBJ DB21",260, 0)
	3320	;
	3321	"RTN","IBJ DB21",261, 0)
	3322	I '$D(IBC PT) S IBRT N=-1 G OPT Q ; Quit i f no billa ble proced ures remai n.
	3323	"RTN","IBJ DB21",262, 0)
	3324	;
	3325	"RTN","IBJ DB21",263, 0)
	3326	; - Look at all of the vet's bills for the day an d eliminat e
	3327	"RTN","IBJ DB21",264, 0)
	3328	; from the array those proc edures tha t have bee n billed.
	3329	"RTN","IBJ DB21",265, 0)
	3330	S IBXX=0 S IBDAY=$E (IBDT,1,7)
	3331	"RTN","IBJ DB21",266, 0)
	3332	F S IBXX =$O(^DGCR( 399,"AOPV" ,DFN,IBDAY ,IBXX)) Q: 'IBXX D
	3333	"RTN","IBJ DB21",267, 0)
	3334	. ;
	3335	"RTN","IBJ DB21",268, 0)
	3336	. ; - Per form gener al checks on the cla im.
	3337	"RTN","IBJ DB21",269, 0)
	3338	. S IBDAT A=$$CKBIL^ IBTUBOU(IB XX) Q:IBDA TA=""
	3339	"RTN","IBJ DB21",270, 0)
	3340	. S IBAUT H=$P($G(IB DATA),U,2)
	3341	"RTN","IBJ DB21",271, 0)
	3342	. I $G(IB AUTH)<2&($ G(IBAUTH)> 5) Q
	3343	"RTN","IBJ DB21",272, 0)
	3344	. ; - The episode h as been bi lled. Chec k the reve nue code m ultiple fo r
	3345	"RTN","IBJ DB21",273, 0)
	3346	. ; all procedure s billed o n the clai m.
	3347	"RTN","IBJ DB21",274, 0)
	3348	. S IBYY= 0
	3349	"RTN","IBJ DB21",275, 0)
	3350	. F S IB YY=$O(^DGC R(399,IBXX ,"RC",IBYY )) Q:'IBYY S IBYD=^ (IBYY,0) D
	3351	"RTN","IBJ DB21",276, 0)
	3352	. . ;
	3353	"RTN","IBJ DB21",277, 0)
	3354	. . ; - G et the pro cedure cod e,charge t ype and to tal charge s for the revenue co de.
	3355	"RTN","IBJ DB21",278, 0)
	3356	. . S IBZ =$P(IBYD,U ,6)
	3357	"RTN","IBJ DB21",279, 0)
	3358	. . S IBC T=$S($P(IB YD,U,12):$ P(IBYD,U,1 2),1:$P(IB DATA,U,4))
	3359	"RTN","IBJ DB21",280, 0)
	3360	. . S IBT CHRG=$P(IB YD,U,4)
	3361	"RTN","IBJ DB21",281, 0)
	3362	. . I 'IB Z!('IBCT) Q ; Can't determine code/char ge type fo r procedur e.
	3363	"RTN","IBJ DB21",282, 0)
	3364	. . ; Del ete proced ure from u nbilled pr ocedures a rray.
	3365	"RTN","IBJ DB21",283, 0)
	3366	. . I $G( IBTCHRG)'< $G(IBCPTSU M(IBZ)) K IBCPT(IBZ)
	3367	"RTN","IBJ DB21",284, 0)
	3368	. . I $D( IBCPT(IBZ, IBCT)) K I BCPT(IBZ,I BCT)
	3369	"RTN","IBJ DB21",285, 0)
	3370	;
	3371	"RTN","IBJ DB21",286, 0)
	3372	; - Again , quit if no billabl e procedur es remain.
	3373	"RTN","IBJ DB21",287, 0)
	3374	I '$D(IBC PT) S IBRT N=-1 G OPT Q
	3375	"RTN","IBJ DB21",288, 0)
	3376	; - If th ere are bi llable pro cedures re turn TOTAL AMOUNT
	3377	"RTN","IBJ DB21",289, 0)
	3378	I $D(IBCP T) S (IBZ, IBCT,IBRTN )=0
	3379	"RTN","IBJ DB21",290, 0)
	3380	F S IBZ= $O(IBCPT(I BZ)) Q:'IB Z D
	3381	"RTN","IBJ DB21",291, 0)
	3382	.F S IBC T=$O(IBCPT (IBZ,IBCT) ) Q:'IBCT D
	3383	"RTN","IBJ DB21",292, 0)
	3384	..S IBRTN =IBRTN+IBC PT(IBZ,IBC T)
	3385	"RTN","IBJ DB21",293, 0)
	3386	I IBRTN=0 S IBRTN=- 1
	3387	"RTN","IBJ DB21",294, 0)
	3388	;
	3389	"RTN","IBJ DB21",295, 0)
	3390	OPTQ K IBC PT Q IBRTN
	3391	"RTN","IBJ DB21",296, 0)
	3392	;
	3393	"RTN","IBJ DB21",297, 0)
	3394	AVG(EPDT) ; Returns the Averag e Amount o f Inpatien t Professi onal per
	3395	"RTN","IBJ DB21",298, 0)
	3396	; Number of Episodes for the pr evious 12 months
	3397	"RTN","IBJ DB21",299, 0)
	3398	N AVG,M,Z
	3399	"RTN","IBJ DB21",300, 0)
	3400	S AVG=0,M =EPDT\100* 100
	3401	"RTN","IBJ DB21",301, 0)
	3402	I '$D(^IB E(356.19,M ,1)) S M=$ O(^IBE(356 .19,M),-1) I 'M G QA VG
	3403	"RTN","IBJ DB21",302, 0)
	3404	S Z=$G(^I BE(356.19, M,1)) I $P (Z,U,12) S AVG=$P(Z, U,11)/$P(Z ,U,12)
	3405	"RTN","IBJ DB21",303, 0)
	3406	QAVG Q $J( AVG,0,2)
	3407	"RTN","IBJ DB21",304, 0)
	3408	;
	3409	"RTN","IBJ DB21",305, 0)
	3410	PRVSPC(EPS ,CLM) ; Re turn the P rovider an d the Spec ialty
	3411	"RTN","IBJ DB21",306, 0)
	3412	; Input: EPS - Epi sode(1 = I npatient O R 2 = Outp atient)
	3413	"RTN","IBJ DB21",307, 0)
	3414	; CLM - Poi nter to Cl aim Tracki ng File (# 356)
	3415	"RTN","IBJ DB21",308, 0)
	3416	; Output: Provider Code (Poin ter to #20 0) ^ Provi der Name ^
	3417	"RTN","IBJ DB21",309, 0)
	3418	; Specialty Code (Poi nter to #4 0.7 or #45 .7) ^ Spec ialty Name
	3419	"RTN","IBJ DB21",310, 0)
	3420	;
	3421	"RTN","IBJ DB21",311, 0)
	3422	N ADM,DFN ,ENC,PRI,P RS,PRV,PRV LST,SPC,ST P,X,VAIN,V AINDT
	3423	"RTN","IBJ DB21",312, 0)
	3424	;
	3425	"RTN","IBJ DB21",313, 0)
	3426	S X=$G(^I BT(356,CLM ,0))
	3427	"RTN","IBJ DB21",314, 0)
	3428	S DFN=$P( X,U,2),ENC =$P(X,U,4) ,ADM=$P(X, U,5),PRS=$ P(X,U,8)
	3429	"RTN","IBJ DB21",315, 0)
	3430	;
	3431	"RTN","IBJ DB21",316, 0)
	3432	S (PRV,SP C)="^"
	3433	"RTN","IBJ DB21",317, 0)
	3434	I EPS=1,A DM D G QP S ; Inpat ient
	3435	"RTN","IBJ DB21",318, 0)
	3436	.S X=$G(^ DGPM(ADM,0 )),VAINDT= $P(X,U)\1 I 'VAINDT Q
	3437	"RTN","IBJ DB21",319, 0)
	3438	.D INP^VA DPT S PRV= $G(VAIN(11 )),SPC=$G( VAIN(3))
	3439	"RTN","IBJ DB21",320, 0)
	3440	.S:PRV="" PRV="^" S :SPC="" SP C="^"
	3441	"RTN","IBJ DB21",321, 0)
	3442	;
	3443	"RTN","IBJ DB21",322, 0)
	3444	I EPS=2,E NC D G QP S ; Outpa tient
	3445	"RTN","IBJ DB21",323, 0)
	3446	.D GETPRV ^SDOE(ENC, "PRVLST")
	3447	"RTN","IBJ DB21",324, 0)
	3448	.S (X,PRI )=""
	3449	"RTN","IBJ DB21",325, 0)
	3450	.F S X=$ O(PRVLST(X ),-1) Q:X= ""!PRI D
	3451	"RTN","IBJ DB21",326, 0)
	3452	..N IBX S PRV=+PRVL ST(X)
	3453	"RTN","IBJ DB21",327, 0)
	3454	..I $P(PR VLST(X),U, 4)="P" S P RI=1 ; Pri mary provi der
	3455	"RTN","IBJ DB21",328, 0)
	3456	..I PRV S PRV=PRV_U _$P($G(^VA (200,+PRV, 0)),U)
	3457	"RTN","IBJ DB21",329, 0)
	3458	..S IBX=$ $GETOE^SDO E(ENC),STP =$P(IBX,U, 3)
	3459	"RTN","IBJ DB21",330, 0)
	3460	..I STP'= "" S SPC=S TP_U_$P($G (^DIC(40.7 ,STP,0)),U )
	3461	"RTN","IBJ DB21",331, 0)
	3462	;
	3463	"RTN","IBJ DB21",332, 0)
	3464	QPS Q (PRV _U_SPC)
	3465	"RTN","IBJ DB21",333, 0)
	3466	;
	3467	"RTN","IBJ DB21",334, 0)
	3468	PHDL ; - P rint the h eader line for the E xcel sprea dsheet
	3469	"RTN","IBJ DB21",335, 0)
	3470	N X
	3471	"RTN","IBJ DB21",336, 0)
	3472	S X="Divi sion^Svc^P atient^SSN ^Insurance ^Episode D t^Dt Enter ed^Dt Lst Edit^"
	3473	"RTN","IBJ DB21",337, 0)
	3474	S X=X_"Ls t Edited B y^Next Adm ission^RNB Cat^Provi der^Specia lty^Entry Amt^Relate d
	3475	Bills^Comm ents"
	3476	"RTN","IBJ DB21",338, 0)
	3477	W !,X
	3478	"RTN","IBJ DB21",339, 0)
	3479	Q
	3480	"RTN","IBJ DF11")
	3481	0^17^B3023 0903^B2960 5847
	3482	"RTN","IBJ DF11",1,0)
	3483	IBJDF11 ;A LB/CPM - T HIRD PARTY FOLLOW-UP REPORT (C OMPILE) ;0 9-JAN-97
	3484	"RTN","IBJ DF11",2,0)
	3485	;;2.0;INT EGRATED BI LLING;*69 ,80,118,12 8,204,205, 227,451,53 0,554,568 *;21-MAR-9 4;Build 40
	3486	"RTN","IBJ DF11",3,0)
	3487	;;Per VA Directive 6402, this routine s hould not be modifie d.
	3488	"RTN","IBJ DF11",4,0)
	3489	;
	3490	"RTN","IBJ DF11",5,0)
	3491	DQ ; - Tas ked entry point.
	3492	"RTN","IBJ DF11",6,0)
	3493	K ^TMP("I BJDF1",$J) S IBQ=0
	3494	"RTN","IBJ DF11",7,0)
	3495	;
	3496	"RTN","IBJ DF11",8,0)
	3497	; - Colle ct divisio ns when ru nning the job for al l division s.
	3498	"RTN","IBJ DF11",9,0)
	3499	I IBSD,VA UTD S J=0 F S J=$O( ^DG(40.8,J )) Q:'J S VAUTD(J)= ""
	3500	"RTN","IBJ DF11",10,0 )
	3501	;
	3502	"RTN","IBJ DF11",11,0 )
	3503	; - Find data requi red for th e report.
	3504	"RTN","IBJ DF11",12,0 )
	3505	S IBA=0 F S IBA=$O (^PRCA(430 ,"AC",16,I BA)) Q:'IB A D Q:IB Q
	3506	"RTN","IBJ DF11",13,0 )
	3507	.;
	3508	"RTN","IBJ DF11",14,0 )
	3509	.I IBA#10 0=0 S IBQ= $$STOP^IBO UTL("Third Party Fol low-Up Rep ort") Q:IB Q
	3510	"RTN","IBJ DF11",15,0 )
	3511	.;
	3512	"RTN","IBJ DF11",16,0 )
	3513	.S IBAR=$ G(^PRCA(43 0,IBA,0))
	3514	"RTN","IBJ DF11",17,0 )
	3515	.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
	3516	types 46,4 7
	3517	"RTN","IBJ DF11",18,0 )
	3518	.I '$D(^D GCR(399,IB A,0)) Q ; No corres ponding cl aim to thi s AR.
	3519	"RTN","IBJ DF11",19,0 )
	3520	.;
	3521	"RTN","IBJ DF11",20,0 )
	3522	.; - Dete rmine whet her bill i s inpatien t, outpati ent, or RX refill.
	3523	"RTN","IBJ DF11",21,0 )
	3524	.S IBTYP= $P($G(^DGC R(399,IBA, 0)),U,5),I BTYP=$S(IB TYP>2:2,1: 1)
	3525	"RTN","IBJ DF11",22,0 )
	3526	.S:$D(^IB A(362.4,"C ",IBA)) IB TYP=3
	3527	"RTN","IBJ DF11",23,0 )
	3528	.I $P(IBA R,U,2)=45 S IBTYP=4 ;IB2554 /DRF Look for Non-VA
	3529	"RTN","IBJ DF11",24,0 )
	3530	.I IBSEL' [IBTYP,IBS EL'[5 Q
	3531	"RTN","IBJ DF11",25,0 )
	3532	.;
	3533	"RTN","IBJ DF11",26,0 )
	3534	.; - Chec k the rece ivable age , if neces sary.
	3535	"RTN","IBJ DF11",27,0 )
	3536	.I IBSMN S:"Aa"[IBS DATE IBARD =$$ACT^IBJ DF2(IBA) S :"Dd"[IBSD ATE IBARD= $$DATE1^IB JDF2(IBA)
	3537	Q:'IBARD S:IBARD IB ARD=$$FMDI FF^XLFDT(D T,IBARD) I IBARD<IBS MN!(IBARD> IBSMX) Q
	3538	"RTN","IBJ DF11",28,0 )
	3539	.;
	3540	"RTN","IBJ DF11",29,0 )
	3541	.; - Chec k the mini mum dollar amount, i f necessar y.
	3542	"RTN","IBJ DF11",30,0 )
	3543	.S IBWBA= +$G(^PRCA( 430,IBA,7) ) I IBSAM, IBWBA<IBSA M Q
	3544	"RTN","IBJ DF11",31,0 )
	3545	.;
	3546	"RTN","IBJ DF11",32,0 )
	3547	.; - Get division, if necessa ry.
	3548	"RTN","IBJ DF11",33,0 )
	3549	.I 'IBSD S IBDIV=0
	3550	"RTN","IBJ DF11",34,0 )
	3551	.E S IBD IV=$$DIV^I BJDF2(IBA) I 'IBDIV S IBDIV=+$ $PRIM^VASI TE()
	3552	"RTN","IBJ DF11",35,0 )
	3553	.I IBSD,' VAUTD Q:'$ D(VAUTD(IB DIV)) ; Not a sele cted divis ion.
	3554	"RTN","IBJ DF11",36,0 )
	3555	.;
	3556	"RTN","IBJ DF11",37,0 )
	3557	.; - Excl ude receiv ables refe rred to Re gional Cou nsel, if n ecessary.
	3558	"RTN","IBJ DF11",38,0 )
	3559	.S IBWRC= $G(^PRCA(4 30,IBA,6)) I 'IBSRC, $P(IBWRC,U ,4) Q
	3560	"RTN","IBJ DF11",39,0 )
	3561	.S IBWRC= $S('$P(IBW RC,U,4):"" ,$P(IBWRC, U,22):$P(I BWRC,U,22) ,1:$P(IBWR C,U,4))
	3562	"RTN","IBJ DF11",40,0 )
	3563	.;
	3564	"RTN","IBJ DF11",41,0 )
	3565	.; - Get the insura nce carrie r and excl ude claim, if necess ary.
	3566	"RTN","IBJ DF11",42,0 )
	3567	.S IBWIN= $$INS(IBA) I IBWIN=" " Q
	3568	"RTN","IBJ DF11",43,0 )
	3569	.;
	3570	"RTN","IBJ DF11",44,0 )
	3571	.; - Get the claim patient an d exclude claim, if necessary.
	3572	"RTN","IBJ DF11",45,0 )
	3573	.S IBWPT= $$PAT(IBA) I IBWPT=" " Q
	3574	"RTN","IBJ DF11",46,0 )
	3575	.;
	3576	"RTN","IBJ DF11",47,0 )
	3577	.; - Get remaining claim info rmation.
	3578	"RTN","IBJ DF11",48,0 )
	3579	.; IB2.0 451 - get 1st/3rd p arty payme nt EEOB in dicator fo r bill
	3580	"RTN","IBJ DF11",49,0 )
	3581	.S IBPFLA G=$$EEOB^I BOA31(IBA)
	3582	"RTN","IBJ DF11",50,0 )
	3583	.S IBWDP= $P(IBAR,U, 10)
	3584	"RTN","IBJ DF11",51,0 )
	3585	.;IB2.0 530 Add in dicator fo r rejects - External Bill # (. 01) value is passed in, not IE N
	3586	"RTN","IBJ DF11",52,0 )
	3587	.S IBWBN= $G(IBPFLAG )_$S(+$$BI LLREJ^IBJT U6($P($G(^ DGCR(399,I BA,0)),U)) :"c",1:"") _$P(IBAR,U ) ; flag
	3588	bill # whe n applicab le
	3589	"RTN","IBJ DF11",53,0 )
	3590	.S IBBU=$ G(^DGCR(39 9,IBA,"U") ),IBWFR=+I BBU,IBWTO= $P(IBBU,U, 2)
	3591	"RTN","IBJ DF11",54,0 )
	3592	.S IBWSC= $$OTH($P(I BWPT,U,5), $P(IBWIN," @@",2),IBW FR),IBWOR= $P(IBAR,U, 3)
	3593	"RTN","IBJ DF11",55,0 )
	3594	.S IBWSI= $P($G(^DPT (+$P(IBWPT ,U,5),.312 ,+$P($G(^D GCR(399,IB A,"MP")),U ,2),0)),U, 2)
	3595	"RTN","IBJ DF11",56,0 )
	3596	.;
	3597	"RTN","IBJ DF11",57,0 )
	3598	.; - Set up main re port index .
	3599	"RTN","IBJ DF11",58,0 )
	3600	.F X=IBTY P,5 I IBSE L[X D
	3601	"RTN","IBJ DF11",59,0 )
	3602	..S
	3603	^TMP("IBJD F1",$J,IBD IV,X,IBWIN ,$P(IBWPT, U)_"@@"_$P (IBWPT,U,5 ),IBWDP_"@ @"_IBWBN)= $P(IBWP
	3604	T,U,2)_"
	3605	("_$P(IBWP T,U,4)_")" _U_$P(IBWP T,U,3)_U_I BWSC_U_IBW FR_U_IBWTO _U_IBWOR_U _IBWBA_"~" _IBW
	3606	RC_U_IBWSI
	3607	"RTN","IBJ DF11",60,0 )
	3608	.;
	3609	"RTN","IBJ DF11",61,0 )
	3610	.; - Add bill comme nt history , if neces sary.
	3611	"RTN","IBJ DF11",62,0 )
	3612	.I IBSH D
	3613	"RTN","IBJ DF11",63,0 )
	3614	..S X=0 F S X=$O(^ PRCA(433," C",IBA,X)) Q:'X D
	3615	"RTN","IBJ DF11",64,0 )
	3616	...S Y=$G (^PRCA(433 ,X,1))
	3617	"RTN","IBJ DF11",65,0 )
	3618	...I $P(Y ,U,2)'=35, $P(Y,U,2)' =45 Q ; N ot a decre ase/commen t transact .
	3619	"RTN","IBJ DF11",66,0 )
	3620	...S DAT= $S(Y:+Y\1, 1:+$P(Y,U, 9)\1)
	3621	"RTN","IBJ DF11",67,0 )
	3622	...;
	3623	"RTN","IBJ DF11",68,0 )
	3624	...; - Ap pend brief and trans action com ments.
	3625	"RTN","IBJ DF11",69,0 )
	3626	...K COM, COM1 S COM (0)=DAT,X1 =0
	3627	"RTN","IBJ DF11",70,0 )
	3628	...S COM1 (1)=$P($G( ^PRCA(433, X,5)),U,2) ,COM1(2)=$ E($P($G(^( 8)),U,6),1 ,70)
	3629	"RTN","IBJ DF11",71,0 )
	3630	...S COM( 1)=COM1(1) _$S(COM1(1 )]""&(COM1 (2)]""):"\| ",1:"")_CO M1(2)
	3631	"RTN","IBJ DF11",72,0 )
	3632	...I COM( 1)]"" S CO M(1)=""_ COM(1)_" ",X1=1
	3633	"RTN","IBJ DF11",73,0 )
	3634	...;
	3635	"RTN","IBJ DF11",74,0 )
	3636	...; - Ge t main com ments.
	3637	"RTN","IBJ DF11",75,0 )
	3638	...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)
	3639	"RTN","IBJ DF11",76,0 )
	3640	...;
	3641	"RTN","IBJ DF11",77,0 )
	3642	...S X1=" " F S X1= $O(COM(X1) ) Q:X1="" F X2=IBTY P,4 I IBSE L[X2 D
	3643	"RTN","IBJ DF11",78,0 )
	3644	....S
	3645	^TMP("IBJD F1",$J,IBD IV,X2,IBWI N,$P(IBWPT ,U)_"@@"_$ P(IBWPT,U, 5),IBWDP_" @@"_IBWBN, X,X1)=CO
	3646	M(X1)
	3647	"RTN","IBJ DF11",79,0 )
	3648	;
	3649	"RTN","IBJ DF11",80,0 )
	3650	I 'IBQ D EN^IBJDF12 ; Print t he report.
	3651	"RTN","IBJ DF11",81,0 )
	3652	;
	3653	"RTN","IBJ DF11",82,0 )
	3654	ENQ K ^TMP ("IBJDF1", $J)
	3655	"RTN","IBJ DF11",83,0 )
	3656	I $D(ZTQU EUED) S ZT REQ="@" G ENQ1
	3657	"RTN","IBJ DF11",84,0 )
	3658	;
	3659	"RTN","IBJ DF11",85,0 )
	3660	D ^%ZISC
	3661	"RTN","IBJ DF11",86,0 )
	3662	ENQ1 K IBA ,IBAR,IBAR D,IBBU,IBD IV,IBQ,IBI O,IBWRC,IB WPT,IBWDP, IBWIN,IBWB N
	3663	"RTN","IBJ DF11",87,0 )
	3664	K IBTYP,I BWSC,IBWSI ,IBWFR,IBW TO,IBWOR,I BWBA,COM,C OM1,DAT,VA UTD
	3665	"RTN","IBJ DF11",88,0 )
	3666	K X,X1,X2 ,Y,Z
	3667	"RTN","IBJ DF11",89,0 )
	3668	Q
	3669	"RTN","IBJ DF11",90,0 )
	3670	;
	3671	"RTN","IBJ DF11",91,0 )
	3672	INS(X) ; - Find the Insurance company an d decide t o include the claim.
	3673	"RTN","IBJ DF11",92,0 )
	3674	; Input: X=Pointer to the cl aim/AR in file #399/ #430
	3675	"RTN","IBJ DF11",93,0 )
	3676	; plus al l variable input in IBS*
	3677	"RTN","IBJ DF11",94,0 )
	3678	; Output: Y=Insuran ce Company name and pointer to file #36
	3679	"RTN","IBJ DF11",95,0 )
	3680	;
	3681	"RTN","IBJ DF11",96,0 )
	3682	N Y,Z,Z1 S Y=""
	3683	"RTN","IBJ DF11",97,0 )
	3684	I '$G(X) G INSQ
	3685	"RTN","IBJ DF11",98,0 )
	3686	S Z=+$G(^ DGCR(399,X ,"MP")),Z1 =$P($G(^DI C(36,Z,0)) ,U)
	3687	"RTN","IBJ DF11",99,0 )
	3688	I $G(IBSI ) G INSQ:' $D(IBSI(Z) ),INSC
	3689	"RTN","IBJ DF11",100, 0)
	3690	I IBSIF'= "@",'Z G I NSQ
	3691	"RTN","IBJ DF11",101, 0)
	3692	I $D(IBSI A) G:IBSIA ="ALL"&('Z ) INSQ G:I BSIA="NULL "&(Z) INSQ
	3693	"RTN","IBJ DF11",102, 0)
	3694	I Z1="" S Z1="UNKNO WN" G INSC
	3695	"RTN","IBJ DF11",103, 0)
	3696	I $G(IBSI A)="ALL" G INSC
	3697	"RTN","IBJ DF11",104, 0)
	3698	I IBSIF=" @",IBSIL=" zzzzz" G I NSC
	3699	"RTN","IBJ DF11",105, 0)
	3700	I IBSIF]Z 1!(Z1]IBSI L) G INSQ
	3701	"RTN","IBJ DF11",106, 0)
	3702	;
	3703	"RTN","IBJ DF11",107, 0)
	3704	INSC S Y=Z 1_"@@"_Z
	3705	"RTN","IBJ DF11",108, 0)
	3706	INSQ Q Y
	3707	"RTN","IBJ DF11",109, 0)
	3708	;
	3709	"RTN","IBJ DF11",110, 0)
	3710	PAT(X) ; - Find the claim pati ent and de cide to in clude the claim.
	3711	"RTN","IBJ DF11",111, 0)
	3712	; Input: X=Pointer to the cl aim/AR in file #399/ #430
	3713	"RTN","IBJ DF11",112, 0)
	3714	; plus al l variable input in IBS*
	3715	"RTN","IBJ DF11",113, 0)
	3716	; Output: Y=1^2^3^4 ^5, where
	3717	"RTN","IBJ DF11",114, 0)
	3718	; 1 => so rt key (na me or last four)
	3719	"RTN","IBJ DF11",115, 0)
	3720	; 2 => pa tient name
	3721	"RTN","IBJ DF11",116, 0)
	3722	; 3 => pa tient ssn
	3723	"RTN","IBJ DF11",117, 0)
	3724	; 4 => pa tient age
	3725	"RTN","IBJ DF11",118, 0)
	3726	; 5 => pa tient poin ter to fil e #2
	3727	"RTN","IBJ DF11",119, 0)
	3728	;
	3729	"RTN","IBJ DF11",120, 0)
	3730	N AGE,DFN ,DOB,KEY,Y ,Z S Y=""
	3731	"RTN","IBJ DF11",121, 0)
	3732	I '$G(X) G PATQ
	3733	"RTN","IBJ DF11",122, 0)
	3734	S DFN=+$P ($G(^DGCR( 399,X,0)), U,2),Z=$G( ^DPT(DFN,0 ))
	3735	"RTN","IBJ DF11",123, 0)
	3736	S KEY=$S( IBSN="N":$ P(Z,U),1:$ E($P(Z,U,9 ),6,9))
	3737	"RTN","IBJ DF11",124, 0)
	3738	;
	3739	"RTN","IBJ DF11",125, 0)
	3740	I IBSNF'= "@",'DFN G PATQ
	3741	"RTN","IBJ DF11",126, 0)
	3742	I $D(IBSN A) G:IBSNA ="ALL"&('D FN) PATQ G :IBSNA="NU LL"&(DFN) PATQ
	3743	"RTN","IBJ DF11",127, 0)
	3744	I KEY="" S Y="UNK^U NK^UNK^UNK ^UNK" G PA TQ
	3745	"RTN","IBJ DF11",128, 0)
	3746	I $G(IBSN A)="ALL" G PATC
	3747	"RTN","IBJ DF11",129, 0)
	3748	I IBSNF=" @",IBSNL=" zzzzz" G P ATC
	3749	"RTN","IBJ DF11",130, 0)
	3750	I IBSNF]K EY!(KEY]IB SNL) G PAT Q
	3751	"RTN","IBJ DF11",131, 0)
	3752	;
	3753	"RTN","IBJ DF11",132, 0)
	3754	PATC ; - F ind all pa tient data .
	3755	"RTN","IBJ DF11",133, 0)
	3756	S DOB=$P( Z,U,3)
	3757	"RTN","IBJ DF11",134, 0)
	3758	S AGE=$S( 'DOB:"UNK" ,1:$E(DT,1 ,3)-$E(DOB ,1,3)-($E( DT,4,7)<$E (DOB,4,7)) )
	3759	"RTN","IBJ DF11",135, 0)
	3760	S Y=KEY_U _$E($P(Z,U ),1,17)_U_ $P(Z,U,9)_ U_AGE_U_DF N
	3761	"RTN","IBJ DF11",136, 0)
	3762	PATQ Q Y
	3763	"RTN","IBJ DF11",137, 0)
	3764	;
	3765	"RTN","IBJ DF11",138, 0)
	3766	OTH(DFN,IN S,DS) ; - Find a pat ient's oth er valid i nsurance c arrier (if any).
	3767	"RTN","IBJ DF11",139, 0)
	3768	; Input: DFN=Point er to the patient in file #2
	3769	"RTN","IBJ DF11",140, 0)
	3770	; INS=Point er to the patient's primary ca rrier in f ile #36
	3771	"RTN","IBJ DF11",141, 0)
	3772	; DS=Date of service for valid ity check
	3773	"RTN","IBJ DF11",142, 0)
	3774	; Output: Valid ins urance car rier (1st 13 chars.) or null
	3775	"RTN","IBJ DF11",143, 0)
	3776	;
	3777	"RTN","IBJ DF11",144, 0)
	3778	N Y S Y=" " I '$G(DF N)!('$G(DS )) G OTHQ
	3779	"RTN","IBJ DF11",145, 0)
	3780	S Z=0 F S Z=$O(^DP T(DFN,.312 ,Z)) Q:'Z S X=$G(^( Z,0)) D:X Q:Y]""
	3781	"RTN","IBJ DF11",146, 0)
	3782	.I $G(INS ),+X=INS Q
	3783	"RTN","IBJ DF11",147, 0)
	3784	.S X1=$G( ^DIC(36,+X ,0)) I X1= "" Q
	3785	"RTN","IBJ DF11",148, 0)
	3786	.I $P(X1, U,2)'="N", $$CHK^IBCN S1(X,DS) S Y=$E($P(X 1,U),1,13)
	3787	"RTN","IBJ DF11",149, 0)
	3788	;
	3789	"RTN","IBJ DF11",150, 0)
	3790	OTHQ Q Y
	3791	"RTN","IBJ DF2")
	3792	0^16^B6853 3516^B6780 0970
	3793	"RTN","IBJ DF2",1,0)
	3794	IBJDF2 ;AL B/CPM - TH IRD PARTY FOLLOW-UP SUMMARY RE PORT ;Feb 09, 2018@1 0:11:43
	3795	"RTN","IBJ DF2",2,0)
	3796	;;2.0;INT EGRATED BI LLING;69 ,91,100,11 8,133,205, 554,597,56 8;21-MAR -94;Build 40
	3797	"RTN","IBJ DF2",3,0)
	3798	;;Per VA Directive 6402, this routine s hould not be modifie d.
	3799	"RTN","IBJ DF2",4,0)
	3800	;
	3801	"RTN","IBJ DF2",5,0)
	3802	EN ; - Opt ion entry point.
	3803	"RTN","IBJ DF2",6,0)
	3804	;
	3805	"RTN","IBJ DF2",7,0)
	3806	W !!,"Thi s report p rovides a summary of all outst anding Thi rd Party r eceivables .",!
	3807	"RTN","IBJ DF2",8,0)
	3808	;
	3809	"RTN","IBJ DF2",9,0)
	3810	DATE ; - C hoose date to use fo r calculat ion
	3811	"RTN","IBJ DF2",10,0)
	3812	W !!,"Cal culate rep ort using (D)ATE OF CARE or (A )CTIVE IN AR (days): (A)CTIVE IN AR// " R X:DTIME
	3813	"RTN","IBJ DF2",11,0)
	3814	G:'$T!(X[ "^") ENQ S :X="" X="A " S X=$E(X )
	3815	"RTN","IBJ DF2",12,0)
	3816	I "ADad"' [X S IBOFF =99 D HELP ^IBJDF1H G DATE
	3817	"RTN","IBJ DF2",13,0)
	3818	W " ",$S ("Dd"[X:"D ATE OF CAR E",1:"(DAY S) ACTIVE IN AR")
	3819	"RTN","IBJ DF2",14,0)
	3820	S IBSDATE =$S("Dd"[X :"D",1:"A" )
	3821	"RTN","IBJ DF2",15,0)
	3822	;
	3823	"RTN","IBJ DF2",16,0)
	3824	; - Sort by divisio n.
	3825	"RTN","IBJ DF2",17,0)
	3826	S DIR(0)= "Y",DIR("B ")="NO"
	3827	"RTN","IBJ DF2",18,0)
	3828	S DIR("A" )="Do you wish to so rt this re port by di vision"
	3829	"RTN","IBJ DF2",19,0)
	3830	S DIR("?" )="^D DHLP ^IBJDF2"
	3831	"RTN","IBJ DF2",20,0)
	3832	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) G E NQ
	3833	"RTN","IBJ DF2",21,0)
	3834	S IBSORT= +Y K DIROU T,DTOUT,DU OUT,DIRUT
	3835	"RTN","IBJ DF2",22,0)
	3836	;
	3837	"RTN","IBJ DF2",23,0)
	3838	; - Issue prompt fo r division .
	3839	"RTN","IBJ DF2",24,0)
	3840	I IBSORT D PSDR^IBO DIV G:Y<0 ENQ
	3841	"RTN","IBJ DF2",25,0)
	3842	;
	3843	"RTN","IBJ DF2",26,0)
	3844	TYP ; - Se lect type of summari es to prin t.
	3845	"RTN","IBJ DF2",27,0)
	3846	; IB2.0 554 DRF 10 /19/2015 A dd Non-VA care
	3847	"RTN","IBJ DF2",28,0)
	3848	W !!,"Cho ose which type of su mmaries to print:",!
	3849	"RTN","IBJ DF2",29,0)
	3850	S DIR(0)= "LO^1:5^K: +$P(X,""-" ",2)>5 X"
	3851	"RTN","IBJ DF2",30,0)
	3852	S DIR("A" ,1)=" 1 - INPATI ENT RECEIV ABLES"
	3853	"RTN","IBJ DF2",31,0)
	3854	S DIR("A" ,2)=" 2 - OUTPAT IENT RECEI VABLES"
	3855	"RTN","IBJ DF2",32,0)
	3856	S DIR("A" ,3)=" 3 - PHARMA CY REFILL RECEIVABLE S"
	3857	"RTN","IBJ DF2",33,0)
	3858	S DIR("A" ,4)=" 4 - NON-VA CARE RECE IVABLES"
	3859	"RTN","IBJ DF2",34,0)
	3860	S DIR("A" ,5)=" 5 - ALL RE CEIVABLES"
	3861	"RTN","IBJ DF2",35,0)
	3862	S DIR("A" ,6)="",DIR ("A")="Sel ect",DIR(" B")=5
	3863	"RTN","IBJ DF2",36,0)
	3864	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) G E NQ
	3865	"RTN","IBJ DF2",37,0)
	3866	S IBSEL=Y K DIROUT, DTOUT,DUOU T,DIRUT
	3867	"RTN","IBJ DF2",38,0)
	3868	;
	3869	"RTN","IBJ DF2",39,0)
	3870	W !!,"Thi s report o nly requir es an 80 c olumn prin ter."
	3871	"RTN","IBJ DF2",40,0)
	3872	W !!,"Not e: This re port requi res a sear ch through all activ e receivab les."
	3873	"RTN","IBJ DF2",41,0)
	3874	W !?6,"Yo u should q ueue this report to run after normal bus iness hour s.",!
	3875	"RTN","IBJ DF2",42,0)
	3876	;
	3877	"RTN","IBJ DF2",43,0)
	3878	; - Selec t a device .
	3879	"RTN","IBJ DF2",44,0)
	3880	S %ZIS="Q M" D ^%ZIS G:POP ENQ
	3881	"RTN","IBJ DF2",45,0)
	3882	I $D(IO(" Q")) D G ENQ
	3883	"RTN","IBJ DF2",46,0)
	3884	.S ZTRTN= "DQ^IBJDF2 ",ZTDESC=" IB - FOLLO W-UP SUMMA RY REPORT"
	3885	"RTN","IBJ DF2",47,0)
	3886	.F I="IBS EL","IBSDA TE","IBSOR T","VAUTD" ,"VAUTD(" S ZTSAVE(I )=""
	3887	"RTN","IBJ DF2",48,0)
	3888	.D ^%ZTLO AD
	3889	"RTN","IBJ DF2",49,0)
	3890	.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
	3891	job.")
	3892	"RTN","IBJ DF2",50,0)
	3893	.K ZTSK,I O("Q") D H OME^%ZIS
	3894	"RTN","IBJ DF2",51,0)
	3895	;
	3896	"RTN","IBJ DF2",52,0)
	3897	U IO
	3898	"RTN","IBJ DF2",53,0)
	3899	;
	3900	"RTN","IBJ DF2",54,0)
	3901	DQ ; - Tas ked entry point.
	3902	"RTN","IBJ DF2",55,0)
	3903	;
	3904	"RTN","IBJ DF2",56,0)
	3905	I $G(IBXT RACT) D E^ IBJDE(9,1) ; Change extract st atus.
	3906	"RTN","IBJ DF2",57,0)
	3907	;
	3908	"RTN","IBJ DF2",58,0)
	3909	K IB F I= 1,2,3,4,5 I IBSEL[I D
	3910	"RTN","IBJ DF2",59,0)
	3911	.I 'IBSOR T D Q
	3912	"RTN","IBJ DF2",60,0)
	3913	..F J=1:1 :9 S IB(0, I,J)=""
	3914	"RTN","IBJ DF2",61,0)
	3915	.I 'VAUTD D Q
	3916	"RTN","IBJ DF2",62,0)
	3917	..S J=0 F S J=$O(V AUTD(J)) Q :'J F K=1 :1:9 S IB( J,I,K)=""
	3918	"RTN","IBJ DF2",63,0)
	3919	.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)=" "
	3920	"RTN","IBJ DF2",64,0)
	3921	;
	3922	"RTN","IBJ DF2",65,0)
	3923	; - Find data requi red for th e report.
	3924	"RTN","IBJ DF2",66,0)
	3925	S (IBQ,IB A)=0 F S IBA=$O(^PR CA(430,"AC ",16,IBA)) Q:'IBA D Q:IBQ
	3926	"RTN","IBJ DF2",67,0)
	3927	.;
	3928	"RTN","IBJ DF2",68,0)
	3929	.I IBA#10 0=0 S IBQ= $$STOP^IBO UTL("Third Party Fol low-Up Sum mary Repor t") Q:IBQ
	3930	"RTN","IBJ DF2",69,0)
	3931	.;
	3932	"RTN","IBJ DF2",70,0)
	3933	.S IBAR=$ G(^PRCA(43 0,IBA,0))
	3934	"RTN","IBJ DF2",71,0)
	3935	.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 .
	3936	"RTN","IBJ DF2",72,0)
	3937	.S:"Aa"[I BSDATE IBA RD=$$ACT(I BA) S:"Dd" [IBSDATE I BARD=$$DAT E1(IBA) I 'IBARD Q ; No activ ation
	3938	date.
	3939	"RTN","IBJ DF2",73,0)
	3940	.I '$D(^D GCR(399,IB A,0)) Q ; No co rrespondin g claim to this AR.
	3941	"RTN","IBJ DF2",74,0)
	3942	.;
	3943	"RTN","IBJ DF2",75,0)
	3944	.; - Get division i f necessar y.
	3945	"RTN","IBJ DF2",76,0)
	3946	.I 'IBSOR T S IBDIV= 0
	3947	"RTN","IBJ DF2",77,0)
	3948	.E S IBD IV=$$DIV(I BA) I 'IBD IV S IBDIV =+$$PRIM^V ASITE()
	3949	"RTN","IBJ DF2",78,0)
	3950	.I IBSORT ,'VAUTD Q: '$D(VAUTD( IBDIV)) ; Not a sel ected divi sion.
	3951	"RTN","IBJ DF2",79,0)
	3952	.;
	3953	"RTN","IBJ DF2",80,0)
	3954	.; - Dete rmine whet her bill i s inpatien t, outpati ent, or RX refill.
	3955	"RTN","IBJ DF2",81,0)
	3956	.S IBTYP= $P($G(^DGC R(399,IBA, 0)),U,5),I BTYP=$S(IB TYP>2:2,1: 1)
	3957	"RTN","IBJ DF2",82,0)
	3958	.S:$D(^IB A(362.4,"C ",IBA)) IB TYP=3
	3959	"RTN","IBJ DF2",83,0)
	3960	.I $P(IBA R,U,2)=45 S IBTYP=4 ;IB2554 /DRF Look for Non-VA
	3961	"RTN","IBJ DF2",84,0)
	3962	.I IBSEL' [IBTYP,IBS EL'[5 Q
	3963	"RTN","IBJ DF2",85,0)
	3964	.;
	3965	"RTN","IBJ DF2",86,0)
	3966	.; - Hand le claims referred t o Regional Counsel.
	3967	"RTN","IBJ DF2",87,0)
	3968	.S IBOUT= +$G(^PRCA( 430,IBA,7) )
	3969	"RTN","IBJ DF2",88,0)
	3970	.I $P($G( ^PRCA(430, IBA,6)),U, 4) D Q
	3971	"RTN","IBJ DF2",89,0)
	3972	..F I=IBT YP,5 I IBS EL[I D
	3973	"RTN","IBJ DF2",90,0)
	3974	...S $P(I B(IBDIV,I, 8),U)=+IB( IBDIV,I,8) +1
	3975	"RTN","IBJ DF2",91,0)
	3976	...S $P(I B(IBDIV,I, 8),U,2)=$P (IB(IBDIV, I,8),U,2)+ IBOUT
	3977	"RTN","IBJ DF2",92,0)
	3978	.;
	3979	"RTN","IBJ DF2",93,0)
	3980	.; - Dete rmine age and outsta nding bala nce.
	3981	"RTN","IBJ DF2",94,0)
	3982	.S IBAGE= $$FMDIFF^X LFDT(DT,IB ARD),IBCAT =$$CAT(IBA GE)
	3983	"RTN","IBJ DF2",95,0)
	3984	.;
	3985	"RTN","IBJ DF2",96,0)
	3986	.F I=IBTY P,5 I IBSE L[I D
	3987	"RTN","IBJ DF2",97,0)
	3988	..S $P(IB (IBDIV,I,I BCAT),U)=+ IB(IBDIV,I ,IBCAT)+1
	3989	"RTN","IBJ DF2",98,0)
	3990	..S $P(IB (IBDIV,I,I BCAT),U,2) =$P(IB(IBD IV,I,IBCAT ),U,2)+IBO UT
	3991	"RTN","IBJ DF2",99,0)
	3992	;
	3993	"RTN","IBJ DF2",100,0 )
	3994	I IBQ G E NQ
	3995	"RTN","IBJ DF2",101,0 )
	3996	;
	3997	"RTN","IBJ DF2",102,0 )
	3998	; - Extra ct summary data.
	3999	"RTN","IBJ DF2",103,0 )
	4000	; *597 fi x array su bscripts f or all typ es
	4001	"RTN","IBJ DF2",104,0 )
	4002	I $G(IBXT RACT) D G ENQ
	4003	"RTN","IBJ DF2",105,0 )
	4004	.F I=1:1: 8 D
	4005	"RTN","IBJ DF2",106,0 )
	4006	..F J=1,2 S $P(IB(0 ,5,9),U,J) =$P(IB(0,5 ,9),U,J)+$ P(IB(0,5,I ),U,J)
	4007	"RTN","IBJ DF2",107,0 )
	4008	.S I=0 F J=1:1:9 D
	4009	"RTN","IBJ DF2",108,0 )
	4010	..S I=I+1 ,IB(I)=+IB (0,5,J),I= I+1,IB(I)= $J(+$P(IB( 0,5,J),U,2 ),0,2)
	4011	"RTN","IBJ DF2",109,0 )
	4012	.D E^IBJD E(9,0)
	4013	"RTN","IBJ DF2",110,0 )
	4014	;
	4015	"RTN","IBJ DF2",111,0 )
	4016	; - Print the repor ts.
	4017	"RTN","IBJ DF2",112,0 )
	4018	S (IBPAG, IBQ)=0 D N OW^%DTC S IBRUN=$$DA T2^IBOUTL( %)
	4019	"RTN","IBJ DF2",113,0 )
	4020	I 'IBSORT D SUM(0) G ENQ
	4021	"RTN","IBJ DF2",114,0 )
	4022	;
	4023	"RTN","IBJ DF2",115,0 )
	4024	S IBDIV=0 F S IBDI V=$O(IB(IB DIV)) Q:'I BDIV D SU M(IBDIV) Q :IBQ
	4025	"RTN","IBJ DF2",116,0 )
	4026	;
	4027	"RTN","IBJ DF2",117,0 )
	4028	ENQ I $D(Z TQUEUED) S ZTREQ="@" G ENQ1
	4029	"RTN","IBJ DF2",118,0 )
	4030	;
	4031	"RTN","IBJ DF2",119,0 )
	4032	D ^%ZISC
	4033	"RTN","IBJ DF2",120,0 )
	4034	ENQ1 K
	4035	IB,IBOFF,I BQ,IBSDATE ,IBSEL,IBS ORT,IBTEXT ,IBA,IBAR, IBARD,IBDI V,IBAGE,IB OUT,IBCAT, IBPAG,IBRU N
	4036	"RTN","IBJ DF2",121,0 )
	4037	K IBDH,IB TYP,IBTYPH ,%,%ZIS,DF N,I,J,K,PO P,VAUTD,X, Y,Z,ZTDESC ,ZTRTN,ZTS AVE
	4038	"RTN","IBJ DF2",122,0 )
	4039	K DIROUT, DTOUT,DUOU T,DIRUT
	4040	"RTN","IBJ DF2",123,0 )
	4041	Q
	4042	"RTN","IBJ DF2",124,0 )
	4043	;
	4044	"RTN","IBJ DF2",125,0 )
	4045	SUM(IBDIV) ; - Print the repor t.
	4046	"RTN","IBJ DF2",126,0 )
	4047	; Input: IBDIV=Poi nter to th e division in file # 40.8
	4048	"RTN","IBJ DF2",127,0 )
	4049	;
	4050	"RTN","IBJ DF2",128,0 )
	4051	S IBTYP=0 F S IBTY P=$O(IB(IB DIV,IBTYP) ) Q:'IBTYP D Q:IBQ
	4052	"RTN","IBJ DF2",129,0 )
	4053	.I $E(IOS T,1,2)="C- "!(IBPAG) W @IOF,*13
	4054	"RTN","IBJ DF2",130,0 )
	4055	.S IBPAG= IBPAG+1 I $E(IOST,1, 2)'="C-" W !?68,"Pag e: ",IBPAG
	4056	"RTN","IBJ DF2",131,0 )
	4057	.W !!?22, "THIRD PAR TY FOLLOW- UP SUMMARY REPORT"
	4058	"RTN","IBJ DF2",132,0 )
	4059	.S IBTYPH =$S(IBTYP= 1:"INPATIE NT",IBTYP= 2:"OUTPATI ENT",IBTYP =3:"RX REF ILL",IBTYP =4:"NON-
	4060	VA",1:"ALL REIMBURSA BLE")_" RE CEIVABLES" _$S(IBSDAT E="D":" ( date of ca re )",1:" ( days in AR )")
	4061	"RTN","IBJ DF2",133,0 )
	4062	.W !?(80- $L(IBTYPH) )\2,IBTYPH
	4063	"RTN","IBJ DF2",134,0 )
	4064	.I IBDIV S IBDH="Di vision: "_ $P($G(^DG( 40.8,IBDIV ,0)),U) W !?(80-$L(I BDH)\2),IB DH
	4065	"RTN","IBJ DF2",135,0 )
	4066	.W !!?24, "Run Date: ",IBRUN,! ?24,$$DASH (31),!!
	4067	"RTN","IBJ DF2",136,0 )
	4068	.;
	4069	"RTN","IBJ DF2",137,0 )
	4070	.; - Calc ulate tota ls first.
	4071	"RTN","IBJ DF2",138,0 )
	4072	.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)
	4073	"RTN","IBJ DF2",139,0 )
	4074	.;
	4075	"RTN","IBJ DF2",140,0 )
	4076	.W "AR Ca tegory",?3 1,"# Recei vables",?5 2,"Total O utstanding Balance"
	4077	"RTN","IBJ DF2",141,0 )
	4078	.W !,"--- --------", ?31,"----- --------", ?52,"----- ---------- ---------- ",!
	4079	"RTN","IBJ DF2",142,0 )
	4080	.;
	4081	"RTN","IBJ DF2",143,0 )
	4082	.I 'IB(IB DIV,IBTYP, 9) W !,"Th ere are no active re ceivables" ,$S(IBDIV: " for this division" ,1:""),"." D PAUSE
	4083	Q
	4084	"RTN","IBJ DF2",144,0 )
	4085	.;
	4086	"RTN","IBJ DF2",145,0 )
	4087	.; - Prim ary loop t o write re sults.
	4088	"RTN","IBJ DF2",146,0 )
	4089	.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
	4090	"RTN","IBJ DF2",147,0 )
	4091	..W:I=9 ! W !,X,?30 ,$J(+IB(IB DIV,IBTYP, I),6)
	4092	"RTN","IBJ DF2",148,0 )
	4093	..W " (" ,$J(+IB(IB DIV,IBTYP, I)/+IB(IBD IV,IBTYP,9 )*100,0,$S (I=9:0,1:2 )),"%)"
	4094	"RTN","IBJ DF2",149,0 )
	4095	..S Z=$FN ($P(IB(IBD IV,IBTYP,I ),U,2),"," ,2)
	4096	"RTN","IBJ DF2",150,0 )
	4097	..W ?52,$ J($S(I=1!( I=9):"$",1 :"")_Z,15)
	4098	"RTN","IBJ DF2",151,0 )
	4099	..W " (" ,$J($S('Y: 0,1:$P(IB( IBDIV,IBTY P,I),U,2)/ Y*100),0,$ S(I=9:0,1: 2)),"%)"
	4100	"RTN","IBJ DF2",152,0 )
	4101	.;
	4102	"RTN","IBJ DF2",153,0 )
	4103	.D PAUSE
	4104	"RTN","IBJ DF2",154,0 )
	4105	;
	4106	"RTN","IBJ DF2",155,0 )
	4107	SUMQ Q
	4108	"RTN","IBJ DF2",156,0 )
	4109	;
	4110	"RTN","IBJ DF2",157,0 )
	4111	DASH(X) ; - Return a dashed li ne.
	4112	"RTN","IBJ DF2",158,0 )
	4113	Q $TR($J( "",X)," ", "=")
	4114	"RTN","IBJ DF2",159,0 )
	4115	;
	4116	"RTN","IBJ DF2",160,0 )
	4117	PAUSE ; - Page break .
	4118	"RTN","IBJ DF2",161,0 )
	4119	I $E(IOST ,1,2)'="C- " Q
	4120	"RTN","IBJ DF2",162,0 )
	4121	N IBX,DIR ,DIRUT,DUO UT,DTOUT,D IROUT,X,Y
	4122	"RTN","IBJ DF2",163,0 )
	4123	F IBX=$Y: 1:(IOSL-3) W !
	4124	"RTN","IBJ DF2",164,0 )
	4125	S DIR(0)= "E" D ^DIR I $D(DIRU T)!($D(DUO UT)) S IBQ =1
	4126	"RTN","IBJ DF2",165,0 )
	4127	Q
	4128	"RTN","IBJ DF2",166,0 )
	4129	;
	4130	"RTN","IBJ DF2",167,0 )
	4131	DHLP ; - ' Display Re gistration User' hel p.
	4132	"RTN","IBJ DF2",168,0 )
	4133	W !,"Ente r <CR> to summarize all receiv ables with out regard to divisi on,"
	4134	"RTN","IBJ DF2",169,0 )
	4135	W !,"or Y ES to sele ct those d ivisions f or which a separate report sho uld"
	4136	"RTN","IBJ DF2",170,0 )
	4137	W !,"be c reated."
	4138	"RTN","IBJ DF2",171,0 )
	4139	Q
	4140	"RTN","IBJ DF2",172,0 )
	4141	;
	4142	"RTN","IBJ DF2",173,0 )
	4143	CAT(X) ; - Determine category to place r eceivable.
	4144	"RTN","IBJ DF2",174,0 )
	4145	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)
	4146	"RTN","IBJ DF2",175,0 )
	4147	;
	4148	"RTN","IBJ DF2",176,0 )
	4149	ACT(X) ; - Determine the activ ation date for a rec eivable.
	4150	"RTN","IBJ DF2",177,0 )
	4151	N Y S Y=0 I '$G(X) G ACTQ
	4152	"RTN","IBJ DF2",178,0 )
	4153	S Y=$P($G (^PRCA(430 ,X,6)),U,2 1) I Y G A CTQ
	4154	"RTN","IBJ DF2",179,0 )
	4155	S Y=$P($G (^PRCA(430 ,X,9)),U,3 ) I Y G AC TQ
	4156	"RTN","IBJ DF2",180,0 )
	4157	S Y=$P($G (^PRCA(430 ,X,0)),U,1 0)
	4158	"RTN","IBJ DF2",181,0 )
	4159	ACTQ Q Y
	4160	"RTN","IBJ DF2",182,0 )
	4161	;
	4162	"RTN","IBJ DF2",183,0 )
	4163	DATE1(X) ; - Determi ne the Dat e of Care
	4164	"RTN","IBJ DF2",184,0 )
	4165	N Y S Y=0 I '$G(X) G DATEQ
	4166	"RTN","IBJ DF2",185,0 )
	4167	S Y=$P($G (^DGCR(399 ,X,"U")),U ,2) I Y G DATEQ
	4168	"RTN","IBJ DF2",186,0 )
	4169	DATEQ Q Y
	4170	"RTN","IBJ DF2",187,0 )
	4171	;
	4172	"RTN","IBJ DF2",188,0 )
	4173	DIV(IBX) ; - Determi ne the div ision for a claim.
	4174	"RTN","IBJ DF2",189,0 )
	4175	; Input: IBX=Point er to a cl aim in fil e #399
	4176	"RTN","IBJ DF2",190,0 )
	4177	; Output: IBY=Point er to a di vision in file #40.8 ,
	4178	"RTN","IBJ DF2",191,0 )
	4179	; or 0 if not det ermined
	4180	"RTN","IBJ DF2",192,0 )
	4181	;
	4182	"RTN","IBJ DF2",193,0 )
	4183	N DFN,IBA DM,IBEV,IB D,IBPTF,IB U,IBY,IBC, IBTY,VAIND T,VADMVT
	4184	"RTN","IBJ DF2",194,0 )
	4185	S IBY=0,I BC=$G(^DGC R(399,+$G( IBX),0)) I $P(IBC,U) ="" G DIVQ
	4186	"RTN","IBJ DF2",195,0 )
	4187	S DFN=+$P (IBC,U,2), IBEV=+$P(I BC,U,3)\1, IBTY=$P(IB C,U,5)
	4188	"RTN","IBJ DF2",196,0 )
	4189	;
	4190	"RTN","IBJ DF2",197,0 )
	4191	S IBY=+$P (IBC,U,22) I +IBY G DIVQ ; use bill defa ult divisi on if defi ned
	4192	"RTN","IBJ DF2",198,0 )
	4193	;
	4194	"RTN","IBJ DF2",199,0 )
	4195	; - For P harmacy or Prostheti cs claims, use the p rimary div ision.
	4196	"RTN","IBJ DF2",200,0 )
	4197	I $D(^IBA (362.4,"AI FN"_IBX))! $D(^IBA(36 2.5,"AIFN" _IBX)) D G DIVQ
	4198	"RTN","IBJ DF2",201,0 )
	4199	.S IBY=$$ PRIM^VASIT E(DT) S:IB Y'>0 IBY=0
	4200	"RTN","IBJ DF2",202,0 )
	4201	;
	4202	"RTN","IBJ DF2",203,0 )
	4203	; - Check all visit dates if outpatient claim.
	4204	"RTN","IBJ DF2",204,0 )
	4205	I IBTY>2 D G DIVQ
	4206	"RTN","IBJ DF2",205,0 )
	4207	.S IBY=$$ OPT(IBEV,D FN) Q:IBY
	4208	"RTN","IBJ DF2",206,0 )
	4209	.S IBD=0 F S IBD=$ O(^DGCR(39 9,IBX,"OP" ,IBD)) Q:' IBD S IBY =$$OPT(IBD ,DFN) Q:IB Y
	4210	"RTN","IBJ DF2",207,0 )
	4211	;
	4212	"RTN","IBJ DF2",208,0 )
	4213	; - Check inpatient claim.
	4214	"RTN","IBJ DF2",209,0 )
	4215	S IBPTF=+ $P(IBC,U,8 ),IBU=$G(^ DGCR(399,I BX,"U"))
	4216	"RTN","IBJ DF2",210,0 )
	4217	I IBPTF S IBADM=$O( ^DGPM("APT F",IBPTF,0 )) I IBADM S IBY=$$I NP(IBADM) G:IBY DIVQ
	4218	"RTN","IBJ DF2",211,0 )
	4219	S VAINDT= +IBU\1_.23 D ADM^VAD PT2 I VADM VT S IBY=$ $INP(VADMV T) G:IBY D IVQ
	4220	"RTN","IBJ DF2",212,0 )
	4221	S VAINDT= $S($P(IBEV ,".",2):IB EV,1:+IBEV \1_.23) D ADM^VADPT2 I VADMVT S IBY=$$IN P(VADMVT)
	4222	"RTN","IBJ DF2",213,0 )
	4223	;
	4224	"RTN","IBJ DF2",214,0 )
	4225	DIVQ ; - I f a divisi on cannot be determi ned, use t he primary division.
	4226	"RTN","IBJ DF2",215,0 )
	4227	I 'IBY S IBY=$$PRIM ^VASITE(DT ) S:IBY'>0 IBY=0
	4228	"RTN","IBJ DF2",216,0 )
	4229	Q IBY
	4230	"RTN","IBJ DF2",217,0 )
	4231	;
	4232	"RTN","IBJ DF2",218,0 )
	4233	INP(X) ; - Return di vision for a movemen t.
	4234	"RTN","IBJ DF2",219,0 )
	4235	Q +$P($G( ^DIC(42,+$ P($G(^DGPM (+$G(X),0) ),U,6),0)) ,U,11)
	4236	"RTN","IBJ DF2",220,0 )
	4237	;
	4238	"RTN","IBJ DF2",221,0 )
	4239	OPT(X,DFN) ; - Retur n division for a pat ient's out patient vi sit date.
	4240	"RTN","IBJ DF2",222,0 )
	4241	N IBFR,IB TO,IBY,IBY 1,IBZ,IBZE RR
	4242	"RTN","IBJ DF2",223,0 )
	4243	S IBY=0 I '$G(X) G OPTQ
	4244	"RTN","IBJ DF2",224,0 )
	4245	S IBFR=X, IBTO=X\1_" .99"
	4246	"RTN","IBJ DF2",225,0 )
	4247	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
	4248	"RTN","IBJ DF2",226,0 )
	4249	.I $P(IBY 1,U,11) S IBY=$P(IBY 1,U,11) Q
	4250	"RTN","IBJ DF2",227,0 )
	4251	.S IBFR=I BY1+.00000 1
	4252	"RTN","IBJ DF2",228,0 )
	4253	OPTQ Q IBY
	4254	"RTN","IBJ DF2",229,0 )
	4255	;
	4256	"RTN","IBJ DF2",230,0 )
	4257	CATN ; - L ist of cat egory name s.
	4258	"RTN","IBJ DF2",231,0 )
	4259	;;Less th an 30 days old
	4260	"RTN","IBJ DF2",232,0 )
	4261	;;31-60 d ays
	4262	"RTN","IBJ DF2",233,0 )
	4263	;;61-90 d ays
	4264	"RTN","IBJ DF2",234,0 )
	4265	;;91-120 days
	4266	"RTN","IBJ DF2",235,0 )
	4267	;;121-180 days
	4268	"RTN","IBJ DF2",236,0 )
	4269	;;181-365 days
	4270	"RTN","IBJ DF2",237,0 )
	4271	;;Over 36 5 days
	4272	"RTN","IBJ DF2",238,0 )
	4273	;;Referre d to Regio nal Counse l
	4274	"RTN","IBJ DF2",239,0 )
	4275	;;Total T hird Party Receivabl es
	4276	"RTN","IBJ DF4")
	4277	0^19^B4368 1161^B2713 1031
	4278	"RTN","IBJ DF4",1,0)
	4279	IBJDF4 ;AL B/RB - FIR ST PARTY F OLLOW-UP R EPORT ;15- APR-00
	4280	"RTN","IBJ DF4",2,0)
	4281	;;2.0;INT EGRATED BI LLING;12 3,204,220, 568;21-M AR-94;Buil d 40
	4282	"RTN","IBJ DF4",3,0)
	4283	;;Per VA Directive 6402, this routine s hould not be modifie d.
	4284	"RTN","IBJ DF4",4,0)
	4285	;
	4286	"RTN","IBJ DF4",5,0)
	4287	EN ; - Opt ion entry point.
	4288	"RTN","IBJ DF4",6,0)
	4289	S IBEXCEL =0
	4290	"RTN","IBJ DF4",7,0)
	4291	N X,XX,I, CH,LAST
	4292	"RTN","IBJ DF4",8,0)
	4293	K IBSUS
	4294	"RTN","IBJ DF4",9,0)
	4295	S XX=$$GE T1^DID(433 ,90,,"POIN TER") ; current li st of AR s uspension types, fil eman set o f codes an d
	4296	descriptio ns
	4297	"RTN","IBJ DF4",10,0)
	4298	F I=1:1 S CH=$P(XX, ";",I) Q:C H="" S IB SUS($P(CH, ":",1))=$P (CH,":",2)
	4299	"RTN","IBJ DF4",11,0)
	4300	S LAST=$O (IBSUS("") ,-1),IBSUS (LAST+1)=" NONE"
	4301	"RTN","IBJ DF4",12,0)
	4302	S LAST=LA ST+2,IBSUS (LAST)="AL L OF THE A BOVE"
	4303	"RTN","IBJ DF4",13,0)
	4304	;
	4305	"RTN","IBJ DF4",14,0)
	4306	; - Selec t AR categ ories to p rint.
	4307	"RTN","IBJ DF4",15,0)
	4308	S IBPRT=" Choose whi ch type of receivabl es to prin t:"
	4309	"RTN","IBJ DF4",16,0)
	4310	K IBOPT
	4311	"RTN","IBJ DF4",17,0)
	4312	S IBOPT(1 )="EMERGEN CY/HUMANIT ARIAN"
	4313	"RTN","IBJ DF4",18,0)
	4314	S IBOPT(2 )="INELIGI BLE"
	4315	"RTN","IBJ DF4",19,0)
	4316	S IBOPT(3 )="C-MEANS TEST & RX COPAY"
	4317	"RTN","IBJ DF4",20,0)
	4318	S IBOPT(4 )="LONG TE RM CARE CO PAY"
	4319	"RTN","IBJ DF4",21,0)
	4320	S IBOPT(5 )="ALL OF THE ABOVE"
	4321	"RTN","IBJ DF4",22,0)
	4322	S IBSEL=$ $MLTP^IBJD (IBPRT,.IB OPT,1) I ' IBSEL G EN Q
	4323	"RTN","IBJ DF4",23,0)
	4324	;
	4325	"RTN","IBJ DF4",24,0)
	4326	STA ; - Ch oose bill status.
	4327	"RTN","IBJ DF4",25,0)
	4328	W !!,"Run report fo r (A)CTIVE ARs, (S)U SPENDED AR s, or (B)O TH: B// "
	4329	"RTN","IBJ DF4",26,0)
	4330	R X:DTIME G:'$T!(X[ "^") ENQ S :X="" X="B " S X=$E(X )
	4331	"RTN","IBJ DF4",27,0)
	4332	I "AaBbSs "'[X S IBO FF=1 D HEL P^IBJDF4H G STA
	4333	"RTN","IBJ DF4",28,0)
	4334	S IBSTA=$ S("Aa"[X:" A","Ss"[X: "S",1:"B")
	4335	"RTN","IBJ DF4",29,0)
	4336	W " ",$S (IBSTA="A" :"ACTIVE", IBSTA="S": "SUSPENDED ",1:"BOTH" )
	4337	"RTN","IBJ DF4",30,0)
	4338	;
	4339	"RTN","IBJ DF4",31,0)
	4340	SUSTYP ;If SUSPENDED is chosen , prompt f or which s uspended b ills to di splay IB2 .0568/DRF
	4341	"RTN","IBJ DF4",32,0)
	4342	I IBSTA=" S" D
	4343	"RTN","IBJ DF4",33,0)
	4344	. S IBPRT ="Choose w hich suspe nded types to print: "
	4345	"RTN","IBJ DF4",34,0)
	4346	. S IBSEL ST=$$MLTP0 (IBPRT,.IB SUS,1)
	4347	"RTN","IBJ DF4",35,0)
	4348	I IBSTA=" S",IBSELST ="" G ENQ
	4349	"RTN","IBJ DF4",36,0)
	4350	;
	4351	"RTN","IBJ DF4",37,0)
	4352	; - Selec t a detail ed or summ ary report .
	4353	"RTN","IBJ DF4",38,0)
	4354	D DS^IBJD G ENQ:IBR PT["^"
	4355	"RTN","IBJ DF4",39,0)
	4356	I IBRPT=" S" D G RC
	4357	"RTN","IBJ DF4",40,0)
	4358	. S IBSN= "N",IBSNA= "ALL",IBSN F="",IBSNL ="zzzzz",I BSMN="A"
	4359	"RTN","IBJ DF4",41,0)
	4360	;
	4361	"RTN","IBJ DF4",42,0)
	4362	; - Deter mine sorti ng (By nam e or Last 4 SSN)
	4363	"RTN","IBJ DF4",43,0)
	4364	S IBSN=$$ SNL^IBJD() G ENQ:IBS N="^"
	4365	"RTN","IBJ DF4",44,0)
	4366	;
	4367	"RTN","IBJ DF4",45,0)
	4368	; - Deter mine the r ange
	4369	"RTN","IBJ DF4",46,0)
	4370	S X=$$INT V^IBJD("PA TIENT "_$S (IBSN="N": "NAME",1:" LAST 4")) G ENQ:X="^ "
	4371	"RTN","IBJ DF4",47,0)
	4372	S IBSNF=$ P(X,"^",1) ,IBSNL=$P( X,"^",2),I BSNA=$P(X, "^",3)
	4373	"RTN","IBJ DF4",48,0)
	4374	;
	4375	"RTN","IBJ DF4",49,0)
	4376	AGE ; - De termine if the activ e receivab le must be within an age range .
	4377	"RTN","IBJ DF4",50,0)
	4378	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
	4379	(R)ANGE: A LL// "
	4380	"RTN","IBJ DF4",51,0)
	4381	R X:DTIME G:'$T!(X[ "^") ENQ S :X="" X="A " S X=$E(X )
	4382	"RTN","IBJ DF4",52,0)
	4383	I "ARar"' [X S IBOFF =9 D HELP^ IBJDF4H G AGE
	4384	"RTN","IBJ DF4",53,0)
	4385	S IBSMN=$ S("Rr"[X:" R",1:"A") W " ",$S( IBSMN="R": "RANGE",1: "ALL")
	4386	"RTN","IBJ DF4",54,0)
	4387	I IBSMN=" A" G AMT
	4388	"RTN","IBJ DF4",55,0)
	4389	;
	4390	"RTN","IBJ DF4",56,0)
	4391	; - Deter mine the a ctive rece ivable age range.
	4392	"RTN","IBJ DF4",57,0)
	4393	W !,"EXAM PLE Range: 31-60 day s"
	4394	"RTN","IBJ DF4",58,0)
	4395	S DIR(0)= "NA^1:9999 9"
	4396	"RTN","IBJ DF4",59,0)
	4397	S DIR("A" )="Enter t he minimum age of th e receivab le: "
	4398	"RTN","IBJ DF4",60,0)
	4399	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=16 D HELP^IBJ DF4H"
	4400	"RTN","IBJ DF4",61,0)
	4401	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4402	"RTN","IBJ DF4",62,0)
	4403	S IBSMN=+ Y W " ", IBSMN," DA YS" K DIRO UT,DTOUT,D UOUT,DIRUT
	4404	"RTN","IBJ DF4",63,0)
	4405	;
	4406	"RTN","IBJ DF4",64,0)
	4407	S DIR(0)= "NA^"_IBSM N_":99999"
	4408	"RTN","IBJ DF4",65,0)
	4409	S DIR("A" )="Enter t he maximum age of th e receivab le: "
	4410	"RTN","IBJ DF4",66,0)
	4411	S DIR("B" )=IBSMN,DI R("T")=DTI ME,DIR("?" )="^S IBOF F=21 D HEL P^IBJDF4H"
	4412	"RTN","IBJ DF4",67,0)
	4413	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4414	"RTN","IBJ DF4",68,0)
	4415	S IBSMX=+ Y W " ", IBSMX," DA YS" K DIRO UT,DTOUT,D UOUT,DIRUT
	4416	"RTN","IBJ DF4",69,0)
	4417	;
	4418	"RTN","IBJ DF4",70,0)
	4419	AMT ; - Pr int receiv ables with a minimum balance.
	4420	"RTN","IBJ DF4",71,0)
	4421	S DIR(0)= "Y",DIR("B ")="NO" W !
	4422	"RTN","IBJ DF4",72,0)
	4423	S DIR("A" )="Print r eceivables with a mi nimum bala nce"
	4424	"RTN","IBJ DF4",73,0)
	4425	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=26 D HELP^IBJ DF4H"
	4426	"RTN","IBJ DF4",74,0)
	4427	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4428	"RTN","IBJ DF4",75,0)
	4429	S IBSAM=+ Y K DIROUT ,DTOUT,DUO UT,DIRUT G :'IBSAM EX CEL
	4430	"RTN","IBJ DF4",76,0)
	4431	;
	4432	"RTN","IBJ DF4",77,0)
	4433	AMT1 ; - D etermine t he minimum balance a mount.
	4434	"RTN","IBJ DF4",78,0)
	4435	S DIR(0)= "NA^1:9999 999"
	4436	"RTN","IBJ DF4",79,0)
	4437	S DIR("A" )="Enter t he minimum balance a mount of t he receiva ble: "
	4438	"RTN","IBJ DF4",80,0)
	4439	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=33 D HELP^IBJ DF4H"
	4440	"RTN","IBJ DF4",81,0)
	4441	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4442	"RTN","IBJ DF4",82,0)
	4443	S IBSAM=+ Y K DIROUT ,DTOUT,DUO UT,DIRUT
	4444	"RTN","IBJ DF4",83,0)
	4445	;
	4446	"RTN","IBJ DF4",84,0)
	4447	EXCEL ; - Determine whether to gather da ta for Exc el report.
	4448	"RTN","IBJ DF4",85,0)
	4449	S IBEXCEL =$$EXCEL^I BJD() G EN Q:IBEXCEL= "^"
	4450	"RTN","IBJ DF4",86,0)
	4451	I IBEXCEL S IBSH=1, IBSH1="M" G RC
	4452	"RTN","IBJ DF4",87,0)
	4453	;
	4454	"RTN","IBJ DF4",88,0)
	4455	BCH ; - De termine wh ether to i nclude the bill comm ent histor y.
	4456	"RTN","IBJ DF4",89,0)
	4457	S DIR(0)= "Y",DIR("B ")="NO" W !
	4458	"RTN","IBJ DF4",90,0)
	4459	S DIR("A" )="Include the bill comment hi story with each rece ivable"
	4460	"RTN","IBJ DF4",91,0)
	4461	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=38 D HELP^IBJ DF4H"
	4462	"RTN","IBJ DF4",92,0)
	4463	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4464	"RTN","IBJ DF4",93,0)
	4465	S IBSH=+Y K DIROUT, DTOUT,DUOU T,DIRUT G: 'IBSH RC
	4466	"RTN","IBJ DF4",94,0)
	4467	;
	4468	"RTN","IBJ DF4",95,0)
	4469	S DIR(0)= "SA^A:ALL; M:MOST REC ENT"
	4470	"RTN","IBJ DF4",96,0)
	4471	S DIR("A" )="Print ( A)LL comme nts or the (M)OST RE CENT comme nt: "
	4472	"RTN","IBJ DF4",97,0)
	4473	S DIR("B" )="ALL",DI R("T")=DTI ME,DIR("?" )="^S IBOF F=47 D HEL P^IBJDF4H"
	4474	"RTN","IBJ DF4",98,0)
	4475	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4476	"RTN","IBJ DF4",99,0)
	4477	S IBSH1=Y K DIROUT, DTOUT,DUOU T,DIRUT G: IBSH1="A" RC
	4478	"RTN","IBJ DF4",100,0 )
	4479	;
	4480	"RTN","IBJ DF4",101,0 )
	4481	S DIR(0)= "NAO^1:999 "
	4482	"RTN","IBJ DF4",102,0 )
	4483	S DIR("A" )="Minimum age of mo st recent bill comme nt (option al): "
	4484	"RTN","IBJ DF4",103,0 )
	4485	S DIR("T" )=DTIME,DI R("?")="^S IBOFF=54 D HELP^IBJ DF4H"
	4486	"RTN","IBJ DF4",104,0 )
	4487	D ^DIR K DIR G:$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4488	"RTN","IBJ DF4",105,0 )
	4489	S IBSH2=+ Y W:IBSH2 " days" K DIROUT,DTO UT,DUOUT
	4490	"RTN","IBJ DF4",106,0 )
	4491	;
	4492	"RTN","IBJ DF4",107,0 )
	4493	RC ; - Inc lude recei vables ref erred to R egional Co unsel?
	4494	"RTN","IBJ DF4",108,0 )
	4495	S DIR(0)= "Y",DIR("B ")="NO",DI R("T")=DTI ME W !
	4496	"RTN","IBJ DF4",109,0 )
	4497	S DIR("A" )="Include ARs refer red to Reg ional Coun sel"
	4498	"RTN","IBJ DF4",110,0 )
	4499	S DIR("?" )="^S IBOF F=61 D HEL P^IBJDF4H"
	4500	"RTN","IBJ DF4",111,0 )
	4501	D ^DIR K DIR G:$D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) ENQ
	4502	"RTN","IBJ DF4",112,0 )
	4503	S IBSRC=+ Y K DIROUT ,DTOUT,DUO UT,DIRUT
	4504	"RTN","IBJ DF4",113,0 )
	4505	;
	4506	"RTN","IBJ DF4",114,0 )
	4507	DEV ; - Se lect a dev ice.
	4508	"RTN","IBJ DF4",115,0 )
	4509	I '$G(IBE XCEL) D
	4510	"RTN","IBJ DF4",116,0 )
	4511	. W !!,"N ote: This report wil l search t hrough all "
	4512	"RTN","IBJ DF4",117,0 )
	4513	. W $S(IB STA="A":"a ctive",IBS TA="S":"su spended",1 :"active & suspended ")," recei vables."
	4514	"RTN","IBJ DF4",118,0 )
	4515	. W !?6," It is reco mmended th at you que ue it to r un after n ormal busi ness hours ."
	4516	"RTN","IBJ DF4",119,0 )
	4517	;
	4518	"RTN","IBJ DF4",120,0 )
	4519	I $G(IBEX CEL) D EXM SG^IBJD
	4520	"RTN","IBJ DF4",121,0 )
	4521	;
	4522	"RTN","IBJ DF4",122,0 )
	4523	W ! S %ZI S="QM" D ^ %ZIS G:POP ENQ
	4524	"RTN","IBJ DF4",123,0 )
	4525	I $D(IO(" Q")) D G ENQ
	4526	"RTN","IBJ DF4",124,0 )
	4527	.S ZTRTN= "DQ^IBJDF4 ",ZTDESC=" IB - FIRST PARTY FOL LOW-UP REP ORT"
	4528	"RTN","IBJ DF4",125,0 )
	4529	.S ZTSAVE ("IB*")="" D ^%ZTLOA D
	4530	"RTN","IBJ DF4",126,0 )
	4531	.I $G(ZTS K) W !!,"T his job ha s been que ued. The t ask no. is ",ZTSK,". "
	4532	"RTN","IBJ DF4",127,0 )
	4533	.E W !!, "Unable to queue thi s job."
	4534	"RTN","IBJ DF4",128,0 )
	4535	.K ZTSK,I O("Q") D H OME^%ZIS
	4536	"RTN","IBJ DF4",129,0 )
	4537	;
	4538	"RTN","IBJ DF4",130,0 )
	4539	U IO
	4540	"RTN","IBJ DF4",131,0 )
	4541	;
	4542	"RTN","IBJ DF4",132,0 )
	4543	; If call ed by the Extraction Module, c hange extr act status for the 5
	4544	"RTN","IBJ DF4",133,0 )
	4545	; reports : Emergenc y/Humanita rian, Inel igible rec eivables, C-Means Te st,
	4546	"RTN","IBJ DF4",134,0 )
	4547	; RX Copay /SC VET an d RX Copay /NSC VET
	4548	"RTN","IBJ DF4",135,0 )
	4549	DQ I $G(IB XTRACT) F I=12:1:16 D E^IBJDE( I,1)
	4550	"RTN","IBJ DF4",136,0 )
	4551	;
	4552	"RTN","IBJ DF4",137,0 )
	4553	D ST^IBJD F41 ; Co mpile and print the report.
	4554	"RTN","IBJ DF4",138,0 )
	4555	;
	4556	"RTN","IBJ DF4",139,0 )
	4557	ENQ K IBSE L,IBSN,IBS NF,IBSNL,I BOFF,IBSNA ,IBSH,IBSH 1,IBSH2,IB SAM,IBSRC, IBTEXT
	4558	"RTN","IBJ DF4",140,0 )
	4559	K IBI,IBO PT,IBPRT,I BSTA,IBEXC EL,IBRPT,I BSMN,IBSMX ,IBSELST,I BSUSTYP,PO P,DIROUT,D TOUT,DUOUT
	4560	"RTN","IBJ DF4",141,0 )
	4561	K DIRUT,% ZIS,ZTDESC ,ZTRTN,ZTS AVE,I,X,Y
	4562	"RTN","IBJ DF4",142,0 )
	4563	Q
	4564	"RTN","IBJ DF4",143,0 )
	4565	;
	4566	"RTN","IBJ DF4",144,0 )
	4567	MLTP0(PRPT ,OPT,ALL) ; Function for multi ple value selection
	4568	"RTN","IBJ DF4",145,0 )
	4569	; Input: PRPT - Str ing to be prompted t o the user , before l isting opt ions
	4570	"RTN","IBJ DF4",146,0 )
	4571	; OPT - Arr ay contain ing the po ssible ent ries (inde xed by cod e)
	4572	"RTN","IBJ DF4",147,0 )
	4573	; Obs : Code mus t be seque ntial star ting with 0
	4574	"RTN","IBJ DF4",148,0 )
	4575	; ALL - Fla g indicati ng if the last optio n is ALL O F THE ABOV E
	4576	"RTN","IBJ DF4",149,0 )
	4577	;
	4578	"RTN","IBJ DF4",150,0 )
	4579	; Output: MLTP - Us er selecti on, i.e. " ,1,2,3," o r "1," or NULL (noth ing
	4580	"RTN","IBJ DF4",151,0 )
	4581	; w as selecte d)
	4582	"RTN","IBJ DF4",152,0 )
	4583	;
	4584	"RTN","IBJ DF4",153,0 )
	4585	N A,DIR,D IRUT,DTOUT ,DUOUT,DIR OUT,I,IX,L ST,MLTP
	4586	"RTN","IBJ DF4",154,0 )
	4587	;
	4588	"RTN","IBJ DF4",155,0 )
	4589	PRPT S MLT P="",ALL=+ $G(ALL)
	4590	"RTN","IBJ DF4",156,0 )
	4591	S LST=$O( OPT(""),-1 )
	4592	"RTN","IBJ DF4",157,0 )
	4593	S DIR(0)= "LO^0:"_LS T_"^K:+$P( X,""-"",2) >"_LST_" X "
	4594	"RTN","IBJ DF4",158,0 )
	4595	S DIR("A" ,1)=$G(PRP T),DIR("A" ,2)=""
	4596	"RTN","IBJ DF4",159,0 )
	4597	S A="",IX =3
	4598	"RTN","IBJ DF4",160,0 )
	4599	F S A=$O (OPT(A)) Q:A="" D
	4600	"RTN","IBJ DF4",161,0 )
	4601	. S DIR(" A",IX)=" "_A_" - " _$G(OPT(A) ),IX=IX+1
	4602	"RTN","IBJ DF4",162,0 )
	4603	S DIR("A" ,IX)="",DI R("A")="Se lect",DIR( "B")=LST,D IR("T")=DT IME W !
	4604	"RTN","IBJ DF4",163,0 )
	4605	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) G Q T
	4606	"RTN","IBJ DF4",164,0 )
	4607	S MLTP=Y K DIROUT,D TOUT,DUOUT ,DIRUT
	4608	"RTN","IBJ DF4",165,0 )
	4609	;
	4610	"RTN","IBJ DF4",166,0 )
	4611	I ALL,MLT P[LST S ML TP=LST_","
	4612	"RTN","IBJ DF4",167,0 )
	4613	;
	4614	"RTN","IBJ DF4",168,0 )
	4615	S DIR(0)= "Y",DIR("A ",1)="You have selec ted",DIR(" A",2)=""
	4616	"RTN","IBJ DF4",169,0 )
	4617	S A="",IX =3
	4618	"RTN","IBJ DF4",170,0 )
	4619	F I=1:1:( $L(MLTP,", ")-1) D
	4620	"RTN","IBJ DF4",171,0 )
	4621	. S DIR(" A",IX)=" "_$P(MLT P,",",I)_" - "_$G(OP T($P(MLTP, ",",I)))
	4622	"RTN","IBJ DF4",172,0 )
	4623	. S IX=IX +1
	4624	"RTN","IBJ DF4",173,0 )
	4625	S DIR("A" ,IX)=""
	4626	"RTN","IBJ DF4",174,0 )
	4627	S DIR("A" )="Are you sure",DIR ("B")="NO" ,DIR("T")= DTIME W !
	4628	"RTN","IBJ DF4",175,0 )
	4629	D ^DIR K DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) S M LTP="" G Q T
	4630	"RTN","IBJ DF4",176,0 )
	4631	K DIROUT, DTOUT,DUOU T,DIRUT I 'Y K DIR G PRPT
	4632	"RTN","IBJ DF4",177,0 )
	4633	;
	4634	"RTN","IBJ DF4",178,0 )
	4635	I ALL,MLT P[LST D
	4636	"RTN","IBJ DF4",179,0 )
	4637	. S MLTP= "" F I=(LS T-1):-1:0 S MLTP=I_" ,"_MLTP
	4638	"RTN","IBJ DF4",180,0 )
	4639	;
	4640	"RTN","IBJ DF4",181,0 )
	4641	QT I MLTP' ="" S MLTP =","_MLTP
	4642	"RTN","IBJ DF4",182,0 )
	4643	Q MLTP
	4644	"RTN","IBJ DF41")
	4645	0^20^B1030 09700^B888 27246
	4646	"RTN","IBJ DF41",1,0)
	4647	IBJDF41 ;A LB/RB - FI RST PARTY FOLLOW-UP REPORT (CO MPILE) ;15 -APR-00
	4648	"RTN","IBJ DF41",2,0)
	4649	;;2.0;INT EGRATED BI LLING;12 3,159,204, 356,451,47 3,568;21 -MAR-94;Bu ild 40
	4650	"RTN","IBJ DF41",3,0)
	4651	;;Per VA Directive 6402, this routine s hould not be modifie d.
	4652	"RTN","IBJ DF41",4,0)
	4653	;
	4654	"RTN","IBJ DF41",5,0)
	4655	ST ; - Tas ked entry point.
	4656	"RTN","IBJ DF41",6,0)
	4657	K IB,IBCA T,^TMP("IB JDF4",$J)
	4658	"RTN","IBJ DF41",7,0)
	4659	S IBQ=0
	4660	"RTN","IBJ DF41",8,0)
	4661	;
	4662	"RTN","IBJ DF41",9,0)
	4663	; - Set s elected ca tegories f or report.
	4664	"RTN","IBJ DF41",10,0 )
	4665	I IBSEL[1 S IBCAT(2 )=1
	4666	"RTN","IBJ DF41",11,0 )
	4667	I IBSEL[2 S IBCAT(1 )=2
	4668	"RTN","IBJ DF41",12,0 )
	4669	I IBSEL[3 S IBCAT(1 8)=3 F X=2 2,23 S IBC AT(X)=4
	4670	"RTN","IBJ DF41",13,0 )
	4671	I IBSEL[4 F X=33:1: 39 S IBCAT (X)=5
	4672	"RTN","IBJ DF41",14,0 )
	4673	;
	4674	"RTN","IBJ DF41",15,0 )
	4675	; - Print the heade r line for the Excel spreadshe et
	4676	"RTN","IBJ DF41",16,0 )
	4677	I $G(IBEX CEL) D PHD L
	4678	"RTN","IBJ DF41",17,0 )
	4679	;
	4680	"RTN","IBJ DF41",18,0 )
	4681	; - Find data requi red for re port.
	4682	"RTN","IBJ DF41",19,0 )
	4683	F IB=16,1 9,40 D G: IBQ ENQ
	4684	"RTN","IBJ DF41",20,0 )
	4685	. I IBSTA ="A",IB'=1 6 Q ; Active A R's only.
	4686	"RTN","IBJ DF41",21,0 )
	4687	. I IBSTA ="S",IB=16 Q ; Suspende d AR's onl y.
	4688	"RTN","IBJ DF41",22,0 )
	4689	. I IB'=4 0 D
	4690	"RTN","IBJ DF41",23,0 )
	4691	. . S IBC AT=""
	4692	"RTN","IBJ DF41",24,0 )
	4693	. . F S IBCAT=$O(I BCAT(IBCAT )) Q:IBCAT ="" D
	4694	"RTN","IBJ DF41",25,0 )
	4695	. . . D I NIT^IBJDF4 3
	4696	"RTN","IBJ DF41",26,0 )
	4697	. S IBA=0
	4698	"RTN","IBJ DF41",27,0 )
	4699	. F S IB A=$O(^PRCA (430,"AC", IB,IBA)) Q :'IBA D Q:IBQ
	4700	"RTN","IBJ DF41",28,0 )
	4701	. . D PRO C
	4702	"RTN","IBJ DF41",29,0 )
	4703	;
	4704	"RTN","IBJ DF41",30,0 )
	4705	I 'IBQ,'$ G(IBEXCEL) D EN^IBJD F42 ; Prin t the repo rt.
	4706	"RTN","IBJ DF41",31,0 )
	4707	;
	4708	"RTN","IBJ DF41",32,0 )
	4709	ENQ K ^TMP ("IBJDF4", $J)
	4710	"RTN","IBJ DF41",33,0 )
	4711	I $D(ZTQU EUED) S ZT REQ="@" G ENQ1
	4712	"RTN","IBJ DF41",34,0 )
	4713	;
	4714	"RTN","IBJ DF41",35,0 )
	4715	D ^%ZISC
	4716	"RTN","IBJ DF41",36,0 )
	4717	ENQ1 K IB, IB0,IBA,IB A1,IBADM,I BAGE,IBAR, IBAR1,IBBA ,IBBN,IBBU ,IBC,IBCAT ,IBCAT1
	4718	"RTN","IBJ DF41",37,0 )
	4719	K IBELIG, IBEXCEL,IB FLG,IBAI,I BAIQ,IBIDX ,IBIO,IBIN T,IBN,IBPA ,IBPD,IBPA T
	4720	"RTN","IBJ DF41",38,0 )
	4721	K IBPT,IB Q,IBRFD,IB RFT,IBSRC, IBRP,IBVA, COM,COM1,D AT,DFN,X,X 1,X2,Y,Z
	4722	"RTN","IBJ DF41",39,0 )
	4723	Q
	4724	"RTN","IBJ DF41",40,0 )
	4725	;
	4726	"RTN","IBJ DF41",41,0 )
	4727	PROC ; - P rocess dat a for repo rt(s).
	4728	"RTN","IBJ DF41",42,0 )
	4729	I IBA#100 =0 D Q:IB Q
	4730	"RTN","IBJ DF41",43,0 )
	4731	. S IBQ=$ $STOP^IBOU TL("First Party Foll ow-Up Repo rt")
	4732	"RTN","IBJ DF41",44,0 )
	4733	S IBAR=$G (^PRCA(430 ,IBA,0)) I 'IBAR Q
	4734	"RTN","IBJ DF41",45,0 )
	4735	S IBCAT=+ $P(IBAR,U, 2) I '$D(I BCAT(IBCAT )) Q ; Ge t valid AR category.
	4736	"RTN","IBJ DF41",46,0 )
	4737	I '$$CLMA CT^IBJD(IB A,IBCAT) Q ; In valid IB c laim/actio n.
	4738	"RTN","IBJ DF41",47,0 )
	4739	S IBSUSTY P=""
	4740	"RTN","IBJ DF41",48,0 )
	4741	I IB=40 S IBSUSTYP= $$SUST(IBA )
	4742	"RTN","IBJ DF41",49,0 )
	4743	I IBSTA=" S",IBSELST '[(","_IBS USTYP_",") Q ; Fi lter by su spended ty pe IB256 8/DRF
	4744	"RTN","IBJ DF41",50,0 )
	4745	S IBPT=$$ PAT(IBA) I IBPT="" Q ; Ge t patient info.
	4746	"RTN","IBJ DF41",51,0 )
	4747	S DFN=$P( IBPT,U,2)
	4748	"RTN","IBJ DF41",52,0 )
	4749	S IBAGE=$ $FMDIFF^XL FDT(DT,+$P (IBAR,U,10 ))
	4750	"RTN","IBJ DF41",53,0 )
	4751	I IBSMN,I BAGE<IBSMN !(IBAGE>IB SMX) Q ; AR outside a ge range.
	4752	"RTN","IBJ DF41",54,0 )
	4753	S IBVA=$$ VA^IBJD1(D FN),IBBN=$ P(IBAR,U), IBPD=$P($$ PYMT^IBJD1 (IBA),U)
	4754	"RTN","IBJ DF41",55,0 )
	4755	S IBPAT=$ P(IBPT,U)_ "@@"_DFN
	4756	"RTN","IBJ DF41",56,0 )
	4757	;
	4758	"RTN","IBJ DF41",57,0 )
	4759	; - Check the AR ba lance amou nts, if ne cessary.
	4760	"RTN","IBJ DF41",58,0 )
	4761	S (IBADM, IBBA,IBINT ,IBPA)=0,I BN=$G(^PRC A(430,IBA, 7))
	4762	"RTN","IBJ DF41",59,0 )
	4763	F X=1:1:5 D
	4764	"RTN","IBJ DF41",60,0 )
	4765	. S IBBA= IBBA+$P(IB N,U,X)
	4766	"RTN","IBJ DF41",61,0 )
	4767	. S:X=1 I BPA=+IBN S :X=2 IBINT =$P(IBN,U, 2) S:X=3 I BADM=$P(IB N,U,3)
	4768	"RTN","IBJ DF41",62,0 )
	4769	;
	4770	"RTN","IBJ DF41",63,0 )
	4771	I '$G(IBE XCEL) D EN ^IBJDF43 I IBRPT="S" Q ; Ge t summary stats.
	4772	"RTN","IBJ DF41",64,0 )
	4773	;
	4774	"RTN","IBJ DF41",65,0 )
	4775	I IBSAM,I BBA<IBSAM Q
	4776	"RTN","IBJ DF41",66,0 )
	4777	;
	4778	"RTN","IBJ DF41",67,0 )
	4779	; - Check if AR was referred to R-Regio nal Counse l, D-DMC, or T-TOP
	4780	"RTN","IBJ DF41",68,0 )
	4781	; and e xclude, if necessary .
	4782	"RTN","IBJ DF41",69,0 )
	4783	S IB0=$S( IB=40:19,1 :IB),IBIDX =0,IBRFT=" "
	4784	"RTN","IBJ DF41",70,0 )
	4785	S IBAIQ=0 ,IBAI=$G(^ TMP("IBJDF 4",$J,IBPA T,0,"A"))
	4786	"RTN","IBJ DF41",71,0 )
	4787	S IBRFD=$ P($G(^PRCA (430,IBA,6 )),U,4)
	4788	"RTN","IBJ DF41",72,0 )
	4789	I IBRPT=" D",IBRFD D I IBAIQ Q ; Referred to RC
	4790	"RTN","IBJ DF41",73,0 )
	4791	. S IBRFT ="R" I IBA I'["R" S I BAI=IBAI_" R"
	4792	"RTN","IBJ DF41",74,0 )
	4793	. I 'IBSR C S IBAIQ= 1 Q
	4794	"RTN","IBJ DF41",75,0 )
	4795	. D SREF( "R",IBRFD, IB0,,.IBID X)
	4796	"RTN","IBJ DF41",76,0 )
	4797	S IBRFD=+ $G(^PRCA(4 30,IBA,12) )
	4798	"RTN","IBJ DF41",77,0 )
	4799	I IBRPT=" D",IBRFD D ; Referred to DMC
	4800	"RTN","IBJ DF41",78,0 )
	4801	. S IBRFT =IBRFT_"D" I IBAI'[" D" S IBAI= IBAI_"D"
	4802	"RTN","IBJ DF41",79,0 )
	4803	. D SREF( "D",IBRFD, IB0,,.IBID X)
	4804	"RTN","IBJ DF41",80,0 )
	4805	S IBRFD=+ $G(^PRCA(4 30,IBA,14) )
	4806	"RTN","IBJ DF41",81,0 )
	4807	I IBRPT=" D",IBRFD D ; Referred to TOP
	4808	"RTN","IBJ DF41",82,0 )
	4809	. S IBRFT =IBRFT_"T" I IBAI'[" T" S IBAI= IBAI_"T"
	4810	"RTN","IBJ DF41",83,0 )
	4811	. D SREF( "T",IBRFD, IB0,,.IBID X)
	4812	"RTN","IBJ DF41",84,0 )
	4813	;
	4814	"RTN","IBJ DF41",85,0 )
	4815	; - Check if AR is on P-Repay ment plan or F-Defau lted repay ment plan.
	4816	"RTN","IBJ DF41",86,0 )
	4817	; and e xclude if repayment plan is ac tive.
	4818	"RTN","IBJ DF41",87,0 )
	4819	S IBRP=$$ RP(IBA)
	4820	"RTN","IBJ DF41",88,0 )
	4821	I IBRP D
	4822	"RTN","IBJ DF41",89,0 )
	4823	. I IBRP= 2 S IBRFT= IBRFT_"F" I IBAI'[" F" S IBAI= IBAI_"F"
	4824	"RTN","IBJ DF41",90,0 )
	4825	. I IBRP= 1 S IBRFT= IBRFT_"P" I IBAI'["P "&(IBAI'[" F") S IBAI =IBAI_"P"
	4826	"RTN","IBJ DF41",91,0 )
	4827	. D SREF( "P",$P(IBR P,"^",2),I B0,$S(+IBR P=2:1,1:0) ,.IBIDX)
	4828	"RTN","IBJ DF41",92,0 )
	4829	;
	4830	"RTN","IBJ DF41",93,0 )
	4831	I IBIDX S IBFLG=1
	4832	"RTN","IBJ DF41",94,0 )
	4833	;
	4834	"RTN","IBJ DF41",95,0 )
	4835	; - Check if VA Emp loyee
	4836	"RTN","IBJ DF41",96,0 )
	4837	I $P(IBVA ,"^")["*", IBAI'["V" S IBAI=IBA I_"V"
	4838	"RTN","IBJ DF41",97,0 )
	4839	;
	4840	"RTN","IBJ DF41",98,0 )
	4841	I IBAI'=" " S ^TMP(" IBJDF4",$J ,IBPAT,0," A")=IBAI
	4842	"RTN","IBJ DF41",99,0 )
	4843	;
	4844	"RTN","IBJ DF41",100, 0)
	4845	; IB2.0 451 - Chec k for EEOB on associ ated 3rd p arty bills and attac h EOB indi cator '%' if applica ble
	4846	"RTN","IBJ DF41",101, 0)
	4847	S IBBN=$$ IBEEOBCK(I BBN,DFN)_I BBN ; Pas s AR BILL# , Pat ID
	4848	"RTN","IBJ DF41",102, 0)
	4849	;
	4850	"RTN","IBJ DF41",103, 0)
	4851	; - Set u p indexes for detail report.
	4852	"RTN","IBJ DF41",104, 0)
	4853	I $G(IBEX CEL) D Q
	4854	"RTN","IBJ DF41",105, 0)
	4855	. S
	4856	IBEXCEL1=$ P($G(^PRCA (430.2,IBC AT,0)),U,2 )_U_$P(IBP T,U,3)_U_$ P(IBVA,U)_ U_$P(IBPT, U,4)_U_$$D T^I
	4857	BJD($P(IBP T,U,6),1)_ U_$$ELIG^I BJDF42(+$P (IBPT,U,5) )_U
	4858	"RTN","IBJ DF41",106, 0)
	4859	. S
	4860	IBEXCEL1=I BEXCEL1_$$ GET1^DIQ(2 ,DFN,.381) _U_$$MTRX( DFN)_U_IBB N_U_$S(IB= 16:"A",1:" S")_U_$S("
	4861	BS"[IBSTA: $$ABBR($G( IBSUSTYP)) ,1:"")_U_I BRFT_U_$$D T^IBJD($P( IBAR,U,10) ,1)_U_$$DT ^IBJD(IBPD ,1)
	4862	_U_IBBA_U_ IBPA_U_IBI NT_U_IBADM _U
	4863	"RTN","IBJ DF41",107, 0)
	4864	. I IBSH D COM
	4865	"RTN","IBJ DF41",108, 0)
	4866	. S IBD=0 I DAT!IBP D S IBD=$$ FMDIFF^XLF DT(DT,$S(' DAT:IBPD,1 :$G(DAT)))
	4867	"RTN","IBJ DF41",109, 0)
	4868	. S IBEXC EL1=IBEXCE L1_U_IBD
	4869	"RTN","IBJ DF41",110, 0)
	4870	. W !,IBE XCEL1 K IB D,IBEXCEL1
	4871	"RTN","IBJ DF41",111, 0)
	4872	;
	4873	"RTN","IBJ DF41",112, 0)
	4874	I '($D(^T MP("IBJDF4 ",$J,IBPAT ))#10) D
	4875	"RTN","IBJ DF41",113, 0)
	4876	. S
	4877	^TMP("IBJD F4",$J,IBP AT)=$P(IBP T,U,3,5)_U _$$MTRX(DF N)_U_$P(IB PT,U,6)_"^ "_$P(IBVA, "^",2)_"^" _$$
	4878	ACCBAL($P( IBPT,U,7))
	4879	"RTN","IBJ DF41",114, 0)
	4880	S
	4881	^TMP("IBJD F4",$J,IBP AT,IB0,IBC AT,IBBN)=I BPD_U_IBBA _U_IBPA_U_ IBINT_U_IB ADM_U_IBID X_U_$S($D
	4882	(IBSUSTYP) :IBSUSTYP, 1:"")
	4883	"RTN","IBJ DF41",115, 0)
	4884	;
	4885	"RTN","IBJ DF41",116, 0)
	4886	I IBSH D COM
	4887	"RTN","IBJ DF41",117, 0)
	4888	Q
	4889	"RTN","IBJ DF41",118, 0)
	4890	;
	4891	"RTN","IBJ DF41",119, 0)
	4892	ACCBAL(DFN ) ; Calcul ates the A ccount Bal ance for t he Bill
	4893	"RTN","IBJ DF41",120, 0)
	4894	; Input: DFN - Pati ent/Debtor internal number
	4895	"RTN","IBJ DF41",121, 0)
	4896	; Output: BAL - Pat ient/Debto r Account Balance
	4897	"RTN","IBJ DF41",122, 0)
	4898	;
	4899	"RTN","IBJ DF41",123, 0)
	4900	N B0,B7,B AL,BILL,I
	4901	"RTN","IBJ DF41",124, 0)
	4902	S (BAL,BI LL)=0
	4903	"RTN","IBJ DF41",125, 0)
	4904	F S BILL =$O(^PRCA( 430,"C",DF N,BILL)) Q :BILL="" D
	4905	"RTN","IBJ DF41",126, 0)
	4906	. S B0=$G (^PRCA(430 ,BILL,0)) I $P(B0,"^ ",8)'=16 Q
	4907	"RTN","IBJ DF41",127, 0)
	4908	. S B7=$G (^PRCA(430 ,BILL,7))
	4909	"RTN","IBJ DF41",128, 0)
	4910	. F I=1:1 :5 S BAL=B AL+$P(B7," ^",I)
	4911	"RTN","IBJ DF41",129, 0)
	4912	Q BAL
	4913	"RTN","IBJ DF41",130, 0)
	4914	;
	4915	"RTN","IBJ DF41",131, 0)
	4916	PHDL ; - P rint the h eader line for the E xcel sprea dsheet
	4917	"RTN","IBJ DF41",132, 0)
	4918	N X
	4919	"RTN","IBJ DF41",133, 0)
	4920	S X="Cat^ Patient^VA Empl.?^SS N^Dt Death ^Prim.Elig .^Med.Elig .?^"
	4921	"RTN","IBJ DF41",134, 0)
	4922	S X=X_"Me ans Tst St s^Means Ts t Dt^RX Co pay Exemp. Sts^RX Cop ay Exemp.D t^"
	4923	"RTN","IBJ DF41",135, 0)
	4924	S X=X_"Bi ll #^Act/S usp^Reason ^Refer. to ^Dt Bill p rep.^Last Pymt Dt^" ;Added rea son IB25 68/DRF
	4925	"RTN","IBJ DF41",136, 0)
	4926	S X=X_"Cu rr.Bal.^Pr inc.Bal.^I nt.^Admin. ^Last Comm .Dt^Days L st Comm.^"
	4927	"RTN","IBJ DF41",137, 0)
	4928	W !,X
	4929	"RTN","IBJ DF41",138, 0)
	4930	Q
	4931	"RTN","IBJ DF41",139, 0)
	4932	;
	4933	"RTN","IBJ DF41",140, 0)
	4934	PAT(X) ; - Find the AR patient and decid e to inclu de the AR.
	4935	"RTN","IBJ DF41",141, 0)
	4936	; Inpu t: X=AR po inter to f ile #430 a nd pre-set variables IBS*
	4937	"RTN","IBJ DF41",142, 0)
	4938	; Outpu t: Y=Sort key (name or last 4) ^ Patient pointer t o file #2
	4939	"RTN","IBJ DF41",143, 0)
	4940	; ^ Nam e ^ SSN ^ Eligibilit ies ^ Date of death (if any)
	4941	"RTN","IBJ DF41",144, 0)
	4942	; ^ Deb tor pointe r to file #340
	4943	"RTN","IBJ DF41",145, 0)
	4944	N PAT,KEY ,DBTR,DFN, DEATH,NAME ,SSN,VAEL, VADM,X1,X2
	4945	"RTN","IBJ DF41",146, 0)
	4946	S PAT="" G:'$G(X) P ATQ
	4947	"RTN","IBJ DF41",147, 0)
	4948	S DBTR=+$ P($G(^PRCA (430,X,0)) ,U,9)
	4949	"RTN","IBJ DF41",148, 0)
	4950	S X1=$P($ G(^RCD(340 ,DBTR,0)), U) G:X1'[" DPT" PATQ
	4951	"RTN","IBJ DF41",149, 0)
	4952	S DFN=+X1 G:'DFN PA TQ D DEM^V ADPT
	4953	"RTN","IBJ DF41",150, 0)
	4954	S NAME=VA DM(1),SSN= $P(VADM(2) ,"^"),DEAT H=VADM(6)\ 1
	4955	"RTN","IBJ DF41",151, 0)
	4956	S KEY=$S( IBSN="N":N AME,1:$E(S SN,6,9))
	4957	"RTN","IBJ DF41",152, 0)
	4958	I KEY=""! (IBSNF'="@ "&('DFN)) G PATQ
	4959	"RTN","IBJ DF41",153, 0)
	4960	I $D(IBSN A) G:IBSNA ="ALL"&('D FN) PATQ G :IBSNA="NU LL"&(DFN) PATQ
	4961	"RTN","IBJ DF41",154, 0)
	4962	I $G(IBSN A)="ALL" G PATC
	4963	"RTN","IBJ DF41",155, 0)
	4964	I IBSNF=" @",IBSNL=" zzzzz" G P ATC
	4965	"RTN","IBJ DF41",156, 0)
	4966	I IBSNF'= KEY,IBSNF] KEY G PATQ
	4967	"RTN","IBJ DF41",157, 0)
	4968	I IBSNL'= KEY,KEY]IB SNL G PATQ
	4969	"RTN","IBJ DF41",158, 0)
	4970	;
	4971	"RTN","IBJ DF41",159, 0)
	4972	PATC ; - S et patient eligibili ties.
	4973	"RTN","IBJ DF41",160, 0)
	4974	D ELIG^VA DPT S X2=+ $G(VAEL(1) )_";"
	4975	"RTN","IBJ DF41",161, 0)
	4976	I +X2 S X 1=0 F S X 1=$O(VAEL( 1,X1)) Q:' X1 S X2=X 2_X1_";"
	4977	"RTN","IBJ DF41",162, 0)
	4978	;
	4979	"RTN","IBJ DF41",163, 0)
	4980	S PAT=KEY _U_DFN_U_$ E(NAME,1,2 6)_U_SSN_U _X2_U_DEAT H
	4981	"RTN","IBJ DF41",164, 0)
	4982	S PAT=PAT _U_DBTR
	4983	"RTN","IBJ DF41",165, 0)
	4984	PATQ Q PAT
	4985	"RTN","IBJ DF41",166, 0)
	4986	;
	4987	"RTN","IBJ DF41",167, 0)
	4988	RP(X) ; - Check if c laim/recei vable is u nder a rep ayment pla n.
	4989	"RTN","IBJ DF41",168, 0)
	4990	; Inpu t: X=Bill pointer to file #399 /#430
	4991	"RTN","IBJ DF41",169, 0)
	4992	; Outpu t: 0-Not o n repay pl an, 1-On r epay plan, 2-On defa ulted plan
	4993	"RTN","IBJ DF41",170, 0)
	4994	N Z
	4995	"RTN","IBJ DF41",171, 0)
	4996	S Z=$$REP DATA^RCBEC HGA(X,1) I Z="" Q 0
	4997	"RTN","IBJ DF41",172, 0)
	4998	I '$P(Z," ^",7) Q (" 1^"_$P(Z," ^"))
	4999	"RTN","IBJ DF41",173, 0)
	5000	Q ("2^"_$ P(Z,"^"))
	5001	"RTN","IBJ DF41",174, 0)
	5002	;
	5003	"RTN","IBJ DF41",175, 0)
	5004	MTRX(X) ; - Return p atient's m eans test and/or RX copay stat us and mos t recent
	5005	"RTN","IBJ DF41",176, 0)
	5006	; test dates for both.
	5007	"RTN","IBJ DF41",177, 0)
	5008	; Inpu t: X=Patie nt pointer to file # 2 and opt. variable IBEXCEL
	5009	"RTN","IBJ DF41",178, 0)
	5010	; Outpu t: Y=Means test stat us ^ Date ^ RX copay status ^ Date
	5011	"RTN","IBJ DF41",179, 0)
	5012	N MTST,RX ST,Y
	5013	"RTN","IBJ DF41",180, 0)
	5014	S Y="^^^" ,MTST=$$LS T^DGMTU(X) ,RXST=$$RX ST^IBARXEU (X)
	5015	"RTN","IBJ DF41",181, 0)
	5016	I '$G(IBE XCEL) D
	5017	"RTN","IBJ DF41",182, 0)
	5018	. S $P(Y, "^",1,2)=$ P(MTST,"^" ,3)_"^"_$$ DAT1^IBOUT L($P(MTST, "^",2))
	5019	"RTN","IBJ DF41",183, 0)
	5020	. S $P(Y, "^",3)=$S( 'RXST:"NON -EXEMPT",+ RXST=1:"EX EMPT",1:"" )
	5021	"RTN","IBJ DF41",184, 0)
	5022	. I $P(Y, "^",3)'="" S $P(Y,"^ ",4)=$$DAT 1^IBOUTL($ P(RXST,"^" ,5))
	5023	"RTN","IBJ DF41",185, 0)
	5024	I $G(IBEX CEL) D
	5025	"RTN","IBJ DF41",186, 0)
	5026	. S $P(Y, "^",1,2)=$ P(MTST,"^" ,4)_"^"_$$ DT^IBJD($P (MTST,"^", 2),1)
	5027	"RTN","IBJ DF41",187, 0)
	5028	. S $P(Y, "^",3)=$S( 'RXST:"M", +RXST=1:"E ",1:"")
	5029	"RTN","IBJ DF41",188, 0)
	5030	. I $P(Y, "^",3)'="" S $P(Y,"^ ",4)=$$DT^ IBJD($P(RX ST,"^",5), 1)
	5031	"RTN","IBJ DF41",189, 0)
	5032	Q Y
	5033	"RTN","IBJ DF41",190, 0)
	5034	;
	5035	"RTN","IBJ DF41",191, 0)
	5036	SREF(RFT,D AT,STS,DEF ,IDX) ; Se t the "ref erred to" informatio n on the
	5037	"RTN","IBJ DF41",192, 0)
	5038	; tem porary glo bal ^TMP
	5039	"RTN","IBJ DF41",193, 0)
	5040	;Input: R FT: "R": R C, "D": DM C, "T": TO P, "P": RE PAYMENT PL AN
	5041	"RTN","IBJ DF41",194, 0)
	5042	; D AT: Date i t was refe rred/estab lished
	5043	"RTN","IBJ DF41",195, 0)
	5044	; S TS: Receiv able statu s (16-Acti ve,19-Susp ended)
	5045	"RTN","IBJ DF41",196, 0)
	5046	; D EF: Repaym ent Plan i n Default? (1 - YES, 0 - NO)
	5047	"RTN","IBJ DF41",197, 0)
	5048	; I DX: Subscr ipt to be set in the Temporary global ^T MP
	5049	"RTN","IBJ DF41",198, 0)
	5050	;Output: IDX: Subsc ript set i n the Temp orary glob al ^TMP
	5051	"RTN","IBJ DF41",199, 0)
	5052	;
	5053	"RTN","IBJ DF41",200, 0)
	5054	N SREF,ID X1
	5055	"RTN","IBJ DF41",201, 0)
	5056	S DEF=+$G (DEF),IDX= +$G(IDX)
	5057	"RTN","IBJ DF41",202, 0)
	5058	I RFT="R" S SREF="R EFERRED TO RC"
	5059	"RTN","IBJ DF41",203, 0)
	5060	I RFT="D" S SREF="R EFERRED TO DMC"
	5061	"RTN","IBJ DF41",204, 0)
	5062	I RFT="T" S SREF="R EFERRED TO TOP"
	5063	"RTN","IBJ DF41",205, 0)
	5064	I RFT="P" D
	5065	"RTN","IBJ DF41",206, 0)
	5066	. S SREF= "REPAYMENT PLAN ESTA BLISHED"
	5067	"RTN","IBJ DF41",207, 0)
	5068	. I $G(DE F) S SREF= SREF_" (CU RRENTLY IN DEFAULT)"
	5069	"RTN","IBJ DF41",208, 0)
	5070	;
	5071	"RTN","IBJ DF41",209, 0)
	5072	I 'IDX S IDX=$O(^TM P("IBJDF4" ,$J,IBPAT, 0,"C",STS, ""),-1)+1
	5073	"RTN","IBJ DF41",210, 0)
	5074	S IDX1=$O (^TMP("IBJ DF4",$J,IB PAT,0,"C", STS,IDX,"" ),-1)+1
	5075	"RTN","IBJ DF41",211, 0)
	5076	S ^TMP("I BJDF4",$J, IBPAT,0,"C ",STS,IDX, IDX1)=DAT
	5077	"RTN","IBJ DF41",212, 0)
	5078	S ^TMP("I BJDF4",$J, IBPAT,0,"C ",STS,IDX, IDX1,1)=SR EF
	5079	"RTN","IBJ DF41",213, 0)
	5080	Q
	5081	"RTN","IBJ DF41",214, 0)
	5082	;
	5083	"RTN","IBJ DF41",215, 0)
	5084	COM ; - Ge t bill com ments.
	5085	"RTN","IBJ DF41",216, 0)
	5086	I 'IBIDX, '$G(IBEXCE L) D
	5087	"RTN","IBJ DF41",217, 0)
	5088	. S IBFLG =0,IBIDX=$ O(^TMP("IB JDF4",$J,I BPAT,0,"C" ,IB0,""),- 1)+1
	5089	"RTN","IBJ DF41",218, 0)
	5090	;
	5091	"RTN","IBJ DF41",219, 0)
	5092	S DAT=0,I BA1=$S(IBS H1="M":999 999999,1:0 )
	5093	"RTN","IBJ DF41",220, 0)
	5094	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
	5095	IBSH1="M", DAT Q
	5096	"RTN","IBJ DF41",221, 0)
	5097	. S IBC=$ G(^PRCA(43 3,IBA1,1)) Q:'IBC
	5098	"RTN","IBJ DF41",222, 0)
	5099	. I $G(IB SH2),$$FMD IFF^XLFDT( DT,+IBC)>I BSH2 Q ; Comment ag e not mini mum.
	5100	"RTN","IBJ DF41",223, 0)
	5101	. I $P(IB C,U,2)'=35 ,$P(IBC,U, 2)'=45 Q ; Not de crease/com ment trans act.
	5102	"RTN","IBJ DF41",224, 0)
	5103	. S DAT=$ S(IBC:+IBC \1,1:+$P(I BC,U,9)\1)
	5104	"RTN","IBJ DF41",225, 0)
	5105	. I $G(IB EXCEL),IBS H1="M" S I BEXCEL1=IB EXCEL1_$$D T^IBJD(DAT ,1) Q
	5106	"RTN","IBJ DF41",226, 0)
	5107	. ;
	5108	"RTN","IBJ DF41",227, 0)
	5109	. ; - App end brief and transa ction comm ents.
	5110	"RTN","IBJ DF41",228, 0)
	5111	. K COM,C OM1 S COM( 0)=DAT,X1= 0
	5112	"RTN","IBJ DF41",229, 0)
	5113	. S COM1( 1)=$P($G(^ PRCA(433,I BA1,5)),U, 2)
	5114	"RTN","IBJ DF41",230, 0)
	5115	. S COM1( 2)=$E($P($ G(^PRCA(43 3,IBA1,8)) ,U,6),1,70 )
	5116	"RTN","IBJ DF41",231, 0)
	5117	. S COM(1 )=COM1(1)_ $S(COM1(1) ]""&(COM1( 2)]""):"\|" ,1:"")_COM 1(2)
	5118	"RTN","IBJ DF41",232, 0)
	5119	. I COM(1 )]"" S COM (1)=""_C OM(1)_"" ,X1=1
	5120	"RTN","IBJ DF41",233, 0)
	5121	. ;
	5122	"RTN","IBJ DF41",234, 0)
	5123	. ; - Get main comm ents.
	5124	"RTN","IBJ DF41",235, 0)
	5125	. S X2=0
	5126	"RTN","IBJ DF41",236, 0)
	5127	. F S X2 =$O(^PRCA( 433,IBA1,7 ,X2)) Q:'X 2 D
	5128	"RTN","IBJ DF41",237, 0)
	5129	. . S COM ($S(X1:X2+ 1,1:X2))=^ PRCA(433,I BA1,7,X2,0 )
	5130	"RTN","IBJ DF41",238, 0)
	5131	. ;
	5132	"RTN","IBJ DF41",239, 0)
	5133	. I $G(IB EXCEL) Q
	5134	"RTN","IBJ DF41",240, 0)
	5135	. ;
	5136	"RTN","IBJ DF41",241, 0)
	5137	. S IBFLG =1,^TMP("I BJDF4",$J, IBPAT,0,"C ",IB0,IBID X,IBA1)=$G (COM(0)),X 1=0
	5138	"RTN","IBJ DF41",242, 0)
	5139	. F S X1 =$O(COM(X1 )) Q:X1="" D
	5140	"RTN","IBJ DF41",243, 0)
	5141	. . S ^TM P("IBJDF4" ,$J,IBPAT, 0,"C",IB0, IBIDX,IBA1 ,X1)=COM(X 1)
	5142	"RTN","IBJ DF41",244, 0)
	5143	;
	5144	"RTN","IBJ DF41",245, 0)
	5145	I '$G(IBE XCEL),IBFL G D
	5146	"RTN","IBJ DF41",246, 0)
	5147	. S $P(^T MP("IBJDF4 ",$J,IBPAT ,IB0,IBCAT ,IBBN),"^" ,6)=IBIDX
	5148	"RTN","IBJ DF41",247, 0)
	5149	Q
	5150	"RTN","IBJ DF41",248, 0)
	5151	; IB2.0 451 - Use Event Dat e to find an associa ted 3rd Pa rty bill w ith an ass ociated EE OB
	5152	"RTN","IBJ DF41",249, 0)
	5153	IBEEOBCK(I BBN,DFN) ; Passed AR Bill, Pat ient ID
	5154	"RTN","IBJ DF41",250, 0)
	5155	; Functio n will qui t as soon as a 3rd p arty bill is located that has an associa ted EEOB
	5156	"RTN","IBJ DF41",251, 0)
	5157	;
	5158	"RTN","IBJ DF41",252, 0)
	5159	; Find 3r d Party Bi lls with a n Event Da te
	5160	"RTN","IBJ DF41",253, 0)
	5161	N IBREF,I BEEOB,IBDT
	5162	"RTN","IBJ DF41",254, 0)
	5163	S IBEEOB= ""
	5164	"RTN","IBJ DF41",255, 0)
	5165	; Loop th rough Xref of ARbill (#430) to Action fi le (#350)
	5166	"RTN","IBJ DF41",256, 0)
	5167	I +$G(IBB N) S IBREF =0 F S IB REF=$O(^IB ("ABIL",IB BN,IBREF)) Q:'IBREF D Q:IBEE OB="%"
	5168	"RTN","IBJ DF41",257, 0)
	5169	. S IBDT= $P($G(^IB( IBREF,0)), "^",17) ;G et event D ate
	5170	"RTN","IBJ DF41",258, 0)
	5171	. I IBDT S IBEEOB=$ $TPEVDT(DF N,IBDT)
	5172	"RTN","IBJ DF41",259, 0)
	5173	. I IBDT S IBEEOB=$ $TPOPV(DFN ,IBDT)
	5174	"RTN","IBJ DF41",260, 0)
	5175	;
	5176	"RTN","IBJ DF41",261, 0)
	5177	Q IBEEOB
	5178	"RTN","IBJ DF41",262, 0)
	5179	;
	5180	"RTN","IBJ DF41",263, 0)
	5181	; IB2.0 451 - Trav erse all T HIRD PARTY bills for a patient with a sp ecific Eve nt Date (3 99,.03)
	5182	"RTN","IBJ DF41",264, 0)
	5183	TPEVDT(DFN ,EVDT) ;
	5184	"RTN","IBJ DF41",265, 0)
	5185	; Functio n will qui t as soon as a 3rd p arty bill is located that has an associa ted EEOB
	5186	"RTN","IBJ DF41",266, 0)
	5187	; 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
	5188	"RTN","IBJ DF41",267, 0)
	5189	I '$G(DFN )!'$G(EVDT ) Q ""
	5190	"RTN","IBJ DF41",268, 0)
	5191	N IBIFN,I BEEOB
	5192	"RTN","IBJ DF41",269, 0)
	5193	S IBEEOB= "",IBIFN=" "
	5194	"RTN","IBJ DF41",270, 0)
	5195	F S IBIF N=$O(^DGCR (399,"APDT ",DFN,IBIF N),-1) Q:' IBIFN D Q:IBEEOB=" %"
	5196	"RTN","IBJ DF41",271, 0)
	5197	. I $D(^D GCR(399,"A PDT",DFN,I BIFN,99999 99-EVDT)) S IBEEOB=$ $EEOBCK(IB IFN)
	5198	"RTN","IBJ DF41",272, 0)
	5199	Q IBEEOB
	5200	"RTN","IBJ DF41",273, 0)
	5201	;
	5202	"RTN","IBJ DF41",274, 0)
	5203	; IB2.0 451 - Trav erse all T HIRD PARTY bills for a patient with any Opt Visit Dates same as Event Date
	5204	(399,43)
	5205	"RTN","IBJ DF41",275, 0)
	5206	TPOPV(DFN, EVDT) ;
	5207	"RTN","IBJ DF41",276, 0)
	5208	; Functio n will qui t as soon as a 3rd p arty bill is located that has an associa ted EEOB
	5209	"RTN","IBJ DF41",277, 0)
	5210	N IBIFN,I BEEOB
	5211	"RTN","IBJ DF41",278, 0)
	5212	S IBEEOB= ""
	5213	"RTN","IBJ DF41",279, 0)
	5214	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
	5215	Q:IBEEOB=" %"
	5216	"RTN","IBJ DF41",280, 0)
	5217	. ; attac h EOB indi cator '%' to bill # when appli cable
	5218	"RTN","IBJ DF41",281, 0)
	5219	. S IBEEO B=$$EEOBCK (IBIFN)
	5220	"RTN","IBJ DF41",282, 0)
	5221	Q IBEEOB
	5222	"RTN","IBJ DF41",283, 0)
	5223	;
	5224	"RTN","IBJ DF41",284, 0)
	5225	; IB2.0 451 - Chec k for EEOB indicator
	5226	"RTN","IBJ DF41",285, 0)
	5227	EEOBCK(IBB ILL) ;
	5228	"RTN","IBJ DF41",286, 0)
	5229	; Check f or 1st and 3rd party payment a ctivity on bill
	5230	"RTN","IBJ DF41",287, 0)
	5231	; IBBILL is the IEN for the b ill # in f iles #399/ #430 and m ust be val id,
	5232	"RTN","IBJ DF41",288, 0)
	5233	; check t he EOB typ e and excl ude it if it is an M RA. Otherw ise,
	5234	"RTN","IBJ DF41",289, 0)
	5235	; returns the EEOB indicator '%' if pay ment activ ity was fo und.
	5236	"RTN","IBJ DF41",290, 0)
	5237	; Access to file #3 61.1 cover ed by IA # 4051.
	5238	"RTN","IBJ DF41",291, 0)
	5239	; Access to file #3 99 covered by IA #38 20.
	5240	"RTN","IBJ DF41",292, 0)
	5241	N IBOUT,I BVAL,Z
	5242	"RTN","IBJ DF41",293, 0)
	5243	I $G(IBBI LL)=0 Q ""
	5244	"RTN","IBJ DF41",294, 0)
	5245	I '$O(^IB M(361.1,"B ",IBBILL,0 )) Q "" ; no entry here
	5246	"RTN","IBJ DF41",295, 0)
	5247	I $P($G(^ DGCR(399,I BBILL,0)), "^",13)=1 Q "" ;avo id 'ENTERE D/NOT REVI EWED' stat us
	5248	"RTN","IBJ DF41",296, 0)
	5249	; handle both singl e and mult iple bill entries in file #361 .1
	5250	"RTN","IBJ DF41",297, 0)
	5251	S Z=0 F S Z=$O(^IB M(361.1,"B ",IBBILL,Z )) Q:'Z D Q:$G(IBO UT)="%"
	5252	"RTN","IBJ DF41",298, 0)
	5253	. S IBVAL =$G(^IBM(3 61.1,Z,0))
	5254	"RTN","IBJ DF41",299, 0)
	5255	. S IBOUT =$S($P(IBV AL,"^",4)= 1:"",$P(IB VAL,"^",4) =0:"%",1:" ")
	5256	"RTN","IBJ DF41",300, 0)
	5257	Q IBOUT ; EOB indi cator for either 1st or 3rd pa rty paymen t on bill
	5258	"RTN","IBJ DF41",301, 0)
	5259	;
	5260	"RTN","IBJ DF41",302, 0)
	5261	;
	5262	"RTN","IBJ DF41",303, 0)
	5263	SUST(IBA) ;Look for suspended type for a suspended bill IB2 568/DRF
	5264	"RTN","IBJ DF41",304, 0)
	5265	N TRANS,S T
	5266	"RTN","IBJ DF41",305, 0)
	5267	S IBA=$G( IBA) I IBA ="" Q ""
	5268	"RTN","IBJ DF41",306, 0)
	5269	S ST=""
	5270	"RTN","IBJ DF41",307, 0)
	5271	S TRANS=$ O(^PRCA(43 3,"C",IBA, ""),-1)
	5272	"RTN","IBJ DF41",308, 0)
	5273	S ST=$P($ G(^PRCA(43 3,TRANS,1) ),U,11)
	5274	"RTN","IBJ DF41",309, 0)
	5275	I ST="" S ST=12 ;Ad ded option for NONE
	5276	"RTN","IBJ DF41",310, 0)
	5277	Q ST
	5278	"RTN","IBJ DF41",311, 0)
	5279	;
	5280	"RTN","IBJ DF41",312, 0)
	5281	;
	5282	"RTN","IBJ DF41",313, 0)
	5283	ABBR(SUSP) ;Return a bbreviatio n for susp ended bill types IB* 2*568/DRF
	5284	"RTN","IBJ DF41",314, 0)
	5285	S SUSP=$G (SUSP)
	5286	"RTN","IBJ DF41",315, 0)
	5287	I SUSP=0 Q "NonCoS"
	5288	"RTN","IBJ DF41",316, 0)
	5289	I SUSP=1 Q "IniCoS"
	5290	"RTN","IBJ DF41",317, 0)
	5291	I SUSP=2 Q "AplCoW"
	5292	"RTN","IBJ DF41",318, 0)
	5293	I SUSP=3 Q "AdminS"
	5294	"RTN","IBJ DF41",319, 0)
	5295	I SUSP=4 Q "Compro"
	5296	"RTN","IBJ DF41",320, 0)
	5297	I SUSP=5 Q "Termin"
	5298	"RTN","IBJ DF41",321, 0)
	5299	I SUSP=6 Q "BnkCh7"
	5300	"RTN","IBJ DF41",322, 0)
	5301	I SUSP=7 Q "BnkC13"
	5302	"RTN","IBJ DF41",323, 0)
	5303	I SUSP=8 Q "BnkOth"
	5304	"RTN","IBJ DF41",324, 0)
	5305	I SUSP=9 Q "Probat"
	5306	"RTN","IBJ DF41",325, 0)
	5307	I SUSP=10 Q "Choice "
	5308	"RTN","IBJ DF41",326, 0)
	5309	I SUSP=11 Q "Disput "
	5310	"RTN","IBJ DF41",327, 0)
	5311	I SUSP=12 Q "None"
	5312	"RTN","IBJ DF41",328, 0)
	5313	Q ""
	5314	"RTN","IBJ DF42")
	5315	0^21^B5500 7532^B5323 7550
	5316	"RTN","IBJ DF42",1,0)
	5317	IBJDF42 ;A LB/RB - FI RST PARTY FOLLOW-UP REPORT (PR INT);15-AP R-00
	5318	"RTN","IBJ DF42",2,0)
	5319	;;2.0;INT EGRATED BI LLING;*12 3,204,568 *;21-MAR-9 4;Build 40
	5320	"RTN","IBJ DF42",3,0)
	5321	;;Per VA Directive 6402, this routine s hould not be modifie d.
	5322	"RTN","IBJ DF42",4,0)
	5323	;
	5324	"RTN","IBJ DF42",5,0)
	5325	EN ; - Pri nt the Fol low-up rep ort.
	5326	"RTN","IBJ DF42",6,0)
	5327	;
	5328	"RTN","IBJ DF42",7,0)
	5329	S IBCT(1) ="INELIGIB LE",IBCT(2 )="EMERG/H UMAN.",IBC T(18)="C M EANS TEST"
	5330	"RTN","IBJ DF42",8,0)
	5331	S IBCT(22 )="RX COPA Y/SC",IBCT (23)="RX C OPAY/NSC"
	5332	"RTN","IBJ DF42",9,0)
	5333	S IBCT(33 )="ADHC LT C"
	5334	"RTN","IBJ DF42",10,0 )
	5335	S IBCT(34 )="DOM LTC "
	5336	"RTN","IBJ DF42",11,0 )
	5337	S IBCT(35 )="RESPITE INPT LTC"
	5338	"RTN","IBJ DF42",12,0 )
	5339	S IBCT(36 )="RESPITE OPT LTC"
	5340	"RTN","IBJ DF42",13,0 )
	5341	S IBCT(37 )="GERIATR IC INPT LT C"
	5342	"RTN","IBJ DF42",14,0 )
	5343	S IBCT(38 )="GERIATR IC OPT LTC "
	5344	"RTN","IBJ DF42",15,0 )
	5345	S IBCT(39 )="NURSING HOME LTC"
	5346	"RTN","IBJ DF42",16,0 )
	5347	;
	5348	"RTN","IBJ DF42",17,0 )
	5349	S IBQ=0 D NOW^%DTC S IBRUN=$$ DAT2^IBOUT L(%) G:IBR PT="S" SUM
	5350	"RTN","IBJ DF42",18,0 )
	5351	S IBPRTFL G=0 D DET D PAUSE:'I BPRTFLG I IBQ!'IBPRT FLG G ENQ
	5352	"RTN","IBJ DF42",19,0 )
	5353	;
	5354	"RTN","IBJ DF42",20,0 )
	5355	D PAUSE I IBQ G ENQ
	5356	"RTN","IBJ DF42",21,0 )
	5357	;
	5358	"RTN","IBJ DF42",22,0 )
	5359	SUM I 'IBQ D PRT^IBJ DF43 ; Pri nt summary .
	5360	"RTN","IBJ DF42",23,0 )
	5361	ENQ K IB0, IBAI,IBC,I BCAT,IBCD, IBC1,IBC2, IBCT,IBCNT ,IBN,IBP,I BPAG,IBQ,I BRUN,IBS
	5362	"RTN","IBJ DF42",24,0 )
	5363	K IBST,IB TOT,%,DFN, IBPRTFLG
	5364	"RTN","IBJ DF42",25,0 )
	5365	Q
	5366	"RTN","IBJ DF42",26,0 )
	5367	;
	5368	"RTN","IBJ DF42",27,0 )
	5369	DET ; - Pr int report for a spe cific cate gory.
	5370	"RTN","IBJ DF42",28,0 )
	5371	;
	5372	"RTN","IBJ DF42",29,0 )
	5373	D HDR1 G: IBQ DETQ
	5374	"RTN","IBJ DF42",30,0 )
	5375	S (IBPT,I B,IBCAT,IB 0)=""
	5376	"RTN","IBJ DF42",31,0 )
	5377	F S IBPT =$O(^TMP(" IBJDF4",$J ,IBPT)) Q: IBPT="" D Q:IBQ
	5378	"RTN","IBJ DF42",32,0 )
	5379	. I $O(^T MP("IBJDF4 ",$J,IBPT, 0))="" Q
	5380	"RTN","IBJ DF42",33,0 )
	5381	. S IBP=$ G(^TMP("IB JDF4",$J,I BPT))
	5382	"RTN","IBJ DF42",34,0 )
	5383	. I $Y>(I OSL-14) D PAUSE Q:IB Q D HDR1 Q:IBQ
	5384	"RTN","IBJ DF42",35,0 )
	5385	. D WPAT
	5386	"RTN","IBJ DF42",36,0 )
	5387	. F IB=16 ,19 D Q:I BQ
	5388	"RTN","IBJ DF42",37,0 )
	5389	. . I IBS TA="A",IB' =16 Q
	5390	"RTN","IBJ DF42",38,0 )
	5391	. . I IBS TA="S",IB= 16 Q
	5392	"RTN","IBJ DF42",39,0 )
	5393	. . I '$D (^TMP("IBJ DF4",$J,IB PT,IB)) D Q
	5394	"RTN","IBJ DF42",40,0 )
	5395	. . . I $ Y>(IOSL-5) D PAUSE Q :IBQ D HD R1,WPAT,HD R2 Q:IBQ
	5396	"RTN","IBJ DF42",41,0 )
	5397	. . . W ! ,"-> NO "_ $S(IB=16:" ACTIVE",1: "SUSPENDED ")_" BILLS ."
	5398	"RTN","IBJ DF42",42,0 )
	5399	. . I $Y> (IOSL-9) D PAUSE Q:I BQ D HDR1 ,WPAT Q:IB Q
	5400	"RTN","IBJ DF42",43,0 )
	5401	. . D HDR 2
	5402	"RTN","IBJ DF42",44,0 )
	5403	. . K IBF LG S IBTOT ="",IBCNT= 0
	5404	"RTN","IBJ DF42",45,0 )
	5405	. . F S IBCAT=$O(^ TMP("IBJDF 4",$J,IBPT ,IB,IBCAT) ) Q:IBCAT= "" D Q:I BQ
	5406	"RTN","IBJ DF42",46,0 )
	5407	. . . F S IB0=$O(^ TMP("IBJDF 4",$J,IBPT ,IB,IBCAT, IB0)) Q:IB 0="" D Q :IBQ
	5408	"RTN","IBJ DF42",47,0 )
	5409	. . . . S IBN=$G(^T MP("IBJDF4 ",$J,IBPT, IB,IBCAT,I B0))
	5410	"RTN","IBJ DF42",48,0 )
	5411	. . . . I $Y>(IOSL- 5) D PAUSE Q:IBQ D HDR1,WPAT, HDR2 Q:IBQ
	5412	"RTN","IBJ DF42",49,0 )
	5413	. . . . D WBIL Q:IB Q
	5414	"RTN","IBJ DF42",50,0 )
	5415	. . . . S IBCNT=IBC NT+1
	5416	"RTN","IBJ DF42",51,0 )
	5417	. . . I ' IBQ,$O(^TM P("IBJDF4" ,$J,IBPT,I B,IBCAT))= "" D
	5418	"RTN","IBJ DF42",52,0 )
	5419	. . . . D TOT W !
	5420	"RTN","IBJ DF42",53,0 )
	5421	. . ; - D isplay bil l comment history, i f selected .
	5422	"RTN","IBJ DF42",54,0 )
	5423	. . S IBP RTFLG=1
	5424	"RTN","IBJ DF42",55,0 )
	5425	. . D WCO M(IBPT,IB)
	5426	"RTN","IBJ DF42",56,0 )
	5427	;
	5428	"RTN","IBJ DF42",57,0 )
	5429	I 'IBPRTF LG D
	5430	"RTN","IBJ DF42",58,0 )
	5431	. W !!!!! !,"There a re no rece ivables fo r the para meters ent ered."
	5432	"RTN","IBJ DF42",59,0 )
	5433	;
	5434	"RTN","IBJ DF42",60,0 )
	5435	DETQ Q
	5436	"RTN","IBJ DF42",61,0 )
	5437	;
	5438	"RTN","IBJ DF42",62,0 )
	5439	WPAT ; - W rite patie nt data.
	5440	"RTN","IBJ DF42",63,0 )
	5441	N I,X
	5442	"RTN","IBJ DF42",64,0 )
	5443	S DFN=$P( IBPT,"@@", 2),IBAI=$G (^TMP("IBJ DF4",$J,IB PT,0,"A"))
	5444	"RTN","IBJ DF42",65,0 )
	5445	W !!,"Pat ient Name : ",$P (IBP,U) W: IBAI["V" " *"
	5446	"RTN","IBJ DF42",66,0 )
	5447	W ?63,"SS N: ",$$SSN ($P(IBP,U, 2)),!,"Mea ns Test St atus: ",$P (IBP,U,4)
	5448	"RTN","IBJ DF42",67,0 )
	5449	W:$P(IBP, U,5)'="" " ("_$P(IBP ,U,5)_")"
	5450	"RTN","IBJ DF42",68,0 )
	5451	W ?58,"Me dicaid: ", $$GET1^DIQ (2,DFN,.38 1)
	5452	"RTN","IBJ DF42",69,0 )
	5453	W !,"RX C opay Statu s : ",$P( IBP,U,6)
	5454	"RTN","IBJ DF42",70,0 )
	5455	W:$P(IBP, U,7)'="" " ("_$P(IBP ,U,7)_")"
	5456	"RTN","IBJ DF42",71,0 )
	5457	W:$P(IBP, U,8) ?53," Date of De ath: ",$$D AT1^IBOUTL ($P(IBP,U, 8))
	5458	"RTN","IBJ DF42",72,0 )
	5459	W !,"Elig ibilities : " S X =$$ELIG($P (IBP,U,3))
	5460	"RTN","IBJ DF42",73,0 )
	5461	F I=1:1 Q :X="" W ? 19,$E(X,1, 61) S X=$E (X,62,999) I X'="" W !
	5462	"RTN","IBJ DF42",74,0 )
	5463	S X=$$INF O(IBAI)
	5464	"RTN","IBJ DF42",75,0 )
	5465	I X'="" D
	5466	"RTN","IBJ DF42",76,0 )
	5467	. W !,"Ad ditional I nfo : "
	5468	"RTN","IBJ DF42",77,0 )
	5469	. F I=1:1 Q:X="" W ?19,$E(X, 1,61) S X= $E(X,62,99 9) I X'="" W !
	5470	"RTN","IBJ DF42",78,0 )
	5471	;
	5472	"RTN","IBJ DF42",79,0 )
	5473	Q
	5474	"RTN","IBJ DF42",80,0 )
	5475	;
	5476	"RTN","IBJ DF42",81,0 )
	5477	WBIL ; - W rite bill data.
	5478	"RTN","IBJ DF42",82,0 )
	5479	W ! W:'$D (IBFLG(IBC AT)) IBCT( IBCAT) W ? 13,IB0
	5480	"RTN","IBJ DF42",83,0 )
	5481	W:$P(IBN, "^",6) ?25 ,$J("("_$P (IBN,"^",6 )_")",4)
	5482	"RTN","IBJ DF42",84,0 )
	5483	W ?30,$$D AT1^IBOUTL (+IBN)
	5484	"RTN","IBJ DF42",85,0 )
	5485	W ?39,$J( $FN($P(IBN ,U,2),",", 2),10),?50 ,$J($FN($P (IBN,U,3), ",",2),10)
	5486	"RTN","IBJ DF42",86,0 )
	5487	W ?61,$J( $FN($P(IBN ,U,4),",", 2),9),?71, $J($FN($P( IBN,U,5)," ,",2),9)
	5488	"RTN","IBJ DF42",87,0 )
	5489	I "SB"[IB STA,$P(IBN ,U,7)]"" W ?82,IBSUS ($P(IBN,U, 7))
	5490	"RTN","IBJ DF42",88,0 )
	5491	S $P(IBTO T,"^")=$P( IBTOT,"^") +$P(IBN,U, 2)
	5492	"RTN","IBJ DF42",89,0 )
	5493	S $P(IBTO T,"^",2)=$ P(IBTOT,"^ ",2)+$P(IB N,U,3)
	5494	"RTN","IBJ DF42",90,0 )
	5495	S $P(IBTO T,"^",3)=$ P(IBTOT,"^ ",3)+$P(IB N,U,4)
	5496	"RTN","IBJ DF42",91,0 )
	5497	S $P(IBTO T,"^",4)=$ P(IBTOT,"^ ",4)+$P(IB N,U,5)
	5498	"RTN","IBJ DF42",92,0 )
	5499	S IBFLG(I BCAT)=""
	5500	"RTN","IBJ DF42",93,0 )
	5501	Q
	5502	"RTN","IBJ DF42",94,0 )
	5503	;
	5504	"RTN","IBJ DF42",95,0 )
	5505	WCOM(IBPT, IB) ; - Wr ite bill c omments.
	5506	"RTN","IBJ DF42",96,0 )
	5507	N CMDT,CO NT,DIWL,DI WR,IBIDX,I BTR,IBLN,I BX,X
	5508	"RTN","IBJ DF42",97,0 )
	5509	;
	5510	"RTN","IBJ DF42",98,0 )
	5511	S (IBIDX, IBTR,IBLN) ="",DIWL=1 ,DIWR=64 K ^UTILITY( $J,"W")
	5512	"RTN","IBJ DF42",99,0 )
	5513	F S IBID X=$O(^TMP( "IBJDF4",$ J,IBPT,0," C",IB,IBID X)) Q:IBID X="" D Q :IBQ
	5514	"RTN","IBJ DF42",100, 0)
	5515	. I $Y>(I OSL-6) D W CPB Q:IBQ
	5516	"RTN","IBJ DF42",101, 0)
	5517	. D WCD(I BIDX)
	5518	"RTN","IBJ DF42",102, 0)
	5519	. F S IB TR=$O(^TMP ("IBJDF4", $J,IBPT,0, "C",IB,IBI DX,IBTR)) Q:IBTR="" D Q:IBQ
	5520	"RTN","IBJ DF42",103, 0)
	5521	. . S CMD T=$G(^TMP( "IBJDF4",$ J,IBPT,0," C",IB,IBID X,IBTR))
	5522	"RTN","IBJ DF42",104, 0)
	5523	. . I $Y> (IOSL-4) D WCPB Q:IB Q
	5524	"RTN","IBJ DF42",105, 0)
	5525	. . S CON T=0 D WCD( ,1,)
	5526	"RTN","IBJ DF42",106, 0)
	5527	. . F S IBLN=$O(^T MP("IBJDF4 ",$J,IBPT, 0,"C",IB,I BIDX,IBTR, IBLN)) Q:I BLN="" D Q:IBQ
	5528	"RTN","IBJ DF42",107, 0)
	5529	. . . S I BX=$G(^TMP ("IBJDF4", $J,IBPT,0, "C",IB,IBI DX,IBTR,IB LN))
	5530	"RTN","IBJ DF42",108, 0)
	5531	. . . I $ E(IBX)=" " ,$L(IBX)>1 S $E(IBX) =""
	5532	"RTN","IBJ DF42",109, 0)
	5533	. . . S X =IBX D ^DI WP
	5534	"RTN","IBJ DF42",110, 0)
	5535	. . . I ' CONT,$L(IB X)<66 D WC TX
	5536	"RTN","IBJ DF42",111, 0)
	5537	. . . S C ONT=$L(IBX )>65
	5538	"RTN","IBJ DF42",112, 0)
	5539	. . . I ' $O(^TMP("I BJDF4",$J, IBPT,0,"C" ,IB,IBIDX, IBTR,IBLN) ) D
	5540	"RTN","IBJ DF42",113, 0)
	5541	. . . . D :$D(^UTILI TY($J,"W") ) WCTX
	5542	"RTN","IBJ DF42",114, 0)
	5543	K ^UTILIT Y($J,"W")
	5544	"RTN","IBJ DF42",115, 0)
	5545	Q
	5546	"RTN","IBJ DF42",116, 0)
	5547	;
	5548	"RTN","IBJ DF42",117, 0)
	5549	WCD(I,D,C) ; - Write the comme nt date.
	5550	"RTN","IBJ DF42",118, 0)
	5551	; Input: I - Index # "(I)"
	5552	"RTN","IBJ DF42",119, 0)
	5553	; D - Print the Date " - MM/DD/ YY"
	5554	"RTN","IBJ DF42",120, 0)
	5555	; C - Print the Cont. "(Continue d)"
	5556	"RTN","IBJ DF42",121, 0)
	5557	;
	5558	"RTN","IBJ DF42",122, 0)
	5559	W:$G(I) ! ,"(",I,")" W:$G(D) ? 3," - ",$$ DAT1^IBOUT L(CMDT),": "
	5560	"RTN","IBJ DF42",123, 0)
	5561	W:$G(C) " (Continued )",!
	5562	"RTN","IBJ DF42",124, 0)
	5563	Q
	5564	"RTN","IBJ DF42",125, 0)
	5565	;
	5566	"RTN","IBJ DF42",126, 0)
	5567	WCTX ; - W rite the c omment tex t.
	5568	"RTN","IBJ DF42",127, 0)
	5569	N LIN,WLI N,Z
	5570	"RTN","IBJ DF42",128, 0)
	5571	S LIN=""
	5572	"RTN","IBJ DF42",129, 0)
	5573	F S LIN= $O(^UTILIT Y($J,"W",1 ,LIN)) Q:L IN="" D Q:IBQ
	5574	"RTN","IBJ DF42",130, 0)
	5575	. S WLIN= $G(^UTILIT Y($J,"W",1 ,LIN,0)) Q :WLIN=""
	5576	"RTN","IBJ DF42",131, 0)
	5577	. W ?16,W LIN
	5578	"RTN","IBJ DF42",132, 0)
	5579	. I '$O(^ UTILITY($J ,"W",1,LIN )) W ! Q
	5580	"RTN","IBJ DF42",133, 0)
	5581	. I $Y>(I OSL-4) D W CPB,WCD(IB IDX,1,1) Q
	5582	"RTN","IBJ DF42",134, 0)
	5583	. W !
	5584	"RTN","IBJ DF42",135, 0)
	5585	K ^UTILIT Y($J,"W")
	5586	"RTN","IBJ DF42",136, 0)
	5587	Q
	5588	"RTN","IBJ DF42",137, 0)
	5589	;
	5590	"RTN","IBJ DF42",138, 0)
	5591	WCPB ; - P age Break in the mid dle of the Comments
	5592	"RTN","IBJ DF42",139, 0)
	5593	D PAUSE Q :IBQ D HD R1,WPAT W !!
	5594	"RTN","IBJ DF42",140, 0)
	5595	Q
	5596	"RTN","IBJ DF42",141, 0)
	5597	;
	5598	"RTN","IBJ DF42",142, 0)
	5599	HDR1 ; - W rite the r eport head er.
	5600	"RTN","IBJ DF42",143, 0)
	5601	N X,I
	5602	"RTN","IBJ DF42",144, 0)
	5603	W:'$G(IBP AG) ! I $E (IOST,1,2) ="C-"!$G(I BPAG) W @I OF,*13
	5604	"RTN","IBJ DF42",145, 0)
	5605	S IBPAG=$ G(IBPAG)+1 W "First Party Foll ow-Up Repo rt"
	5606	"RTN","IBJ DF42",146, 0)
	5607	W ?34,"Ru n Date: ", IBRUN,?71, "Page: ",$ J(IBPAG,3)
	5608	"RTN","IBJ DF42",147, 0)
	5609	S X="ALL "_$S(IBSTA '="S":"ACT IVE",1:"") _$S(IBSTA= "B":" AND ",1:"")
	5610	"RTN","IBJ DF42",148, 0)
	5611	S X=X_$S( IBSTA'="A" :"SUSPENDE D",1:"")_$ $TYPE(IBSE L)_" RECEI VABLES"
	5612	"RTN","IBJ DF42",149, 0)
	5613	I IBSMN'= "A" S X=X_ " OVER "_I BSMN_" AND UNDER "_I BSMX_" DAY S OLD"
	5614	"RTN","IBJ DF42",150, 0)
	5615	S X=X_" / BY "_$S(I BSN="N":"N AME",1:"LA ST 4 SSN")
	5616	"RTN","IBJ DF42",151, 0)
	5617	S X=X_" ( "_$S($G(IB SNA)="ALL" :"ALL",1:" From "_$S( IBSNF="":" FIRST",1:I BSNF)_" to
	5618	"_$S(IBSNL ="zzzzz":" LAST",1:IB SNL))_")"
	5619	"RTN","IBJ DF42",152, 0)
	5620	S X=X_" / "_$S('IBS AM:"NO ",1 :"")_"MINI MUM BALANC E"
	5621	"RTN","IBJ DF42",153, 0)
	5622	S X=X_$S( IBSAM:": $ "_$FN(IBSA M,",",2),1 :"")
	5623	"RTN","IBJ DF42",154, 0)
	5624	S X=X_" / "_$S('IBS H:"NO ",IB SH1="A":"A LL ",1:"ON LY ")_"COM MENTS"
	5625	"RTN","IBJ DF42",155, 0)
	5626	S X=X_$S( $G(IBSH2): " LESS THA N "_IBSH2_ " DAYS OLD ",1:"")
	5627	"RTN","IBJ DF42",156, 0)
	5628	S X=X_" / RECEIVABL ES REFERRE D TO RC "_ $S('IBSRC: "NOT ",1:" ")_"INCLUD ED"
	5629	"RTN","IBJ DF42",157, 0)
	5630	F I=1:1 W !,$E(X,1, 80) S X=$E (X,81,999) I X="" Q
	5631	"RTN","IBJ DF42",158, 0)
	5632	;
	5633	"RTN","IBJ DF42",159, 0)
	5634	S IBQ=$$S TOP^IBOUTL ("First Pa rty Follow -Up Report ")
	5635	"RTN","IBJ DF42",160, 0)
	5636	Q
	5637	"RTN","IBJ DF42",161, 0)
	5638	;
	5639	"RTN","IBJ DF42",162, 0)
	5640	TYPE(SEL) ; Returns a string w ith the ty pe of rece ivables (d escription )
	5641	"RTN","IBJ DF42",163, 0)
	5642	; selecte d or NULL if ALL rec eivable ty pe have be en selecte d.
	5643	"RTN","IBJ DF42",164, 0)
	5644	; SEL - U ser input for the pa rameter "T ype of Rec eivable"
	5645	"RTN","IBJ DF42",165, 0)
	5646	;
	5647	"RTN","IBJ DF42",166, 0)
	5648	N TYPE,I, X
	5649	"RTN","IBJ DF42",167, 0)
	5650	I SEL="1, 2,3," Q ""
	5651	"RTN","IBJ DF42",168, 0)
	5652	S TYPE="" ,X="EMERGE NCY/HUMANI TARIAN^INE LIGIBLE^C- MEANS TEST & RX COPA Y"
	5653	"RTN","IBJ DF42",169, 0)
	5654	F I=2:1:( $L(SEL,"," )-1) D
	5655	"RTN","IBJ DF42",170, 0)
	5656	. S TYPE= TYPE_$S(I= ($L(SEL,", ")-1)&(TYP E'=""):" A ND ",1:", ")
	5657	"RTN","IBJ DF42",171, 0)
	5658	. S TYPE= TYPE_$P(X, "^",+$P(SE L,",",I))
	5659	"RTN","IBJ DF42",172, 0)
	5660	S $E(TYPE ,1)=""
	5661	"RTN","IBJ DF42",173, 0)
	5662	;
	5663	"RTN","IBJ DF42",174, 0)
	5664	Q TYPE
	5665	"RTN","IBJ DF42",175, 0)
	5666	;
	5667	"RTN","IBJ DF42",176, 0)
	5668	HDR2 ; - W rite bill sub-header .
	5669	"RTN","IBJ DF42",177, 0)
	5670	W ! I IBS TA="B" W ! ,$S(IB=16: "ACTIVE",1 :"SUSPENDE D")
	5671	"RTN","IBJ DF42",178, 0)
	5672	W ! I IBS TA="B" W $ S(IB=16:"= =====",1:" =========" )
	5673	"RTN","IBJ DF42",179, 0)
	5674	W:IBSH ?2 6,"COM" W ?30,"Last" ,?40,"Curr ent",?51," Principal"
	5675	"RTN","IBJ DF42",180, 0)
	5676	W !,"Cate gory",?13, "Bill Numb er",?26,"R EF"
	5677	"RTN","IBJ DF42",181, 0)
	5678	W ?30,"Pa yment",?40 ,"Balance" ,?51,"Bala nce",?62," Interest", ?72,"Admin ."
	5679	"RTN","IBJ DF42",182, 0)
	5680	I "BS"[IB STA W ?82, "Suspended Type"
	5681	"RTN","IBJ DF42",183, 0)
	5682	W !,$$DAS H(96,1)
	5683	"RTN","IBJ DF42",184, 0)
	5684	Q
	5685	"RTN","IBJ DF42",185, 0)
	5686	;
	5687	"RTN","IBJ DF42",186, 0)
	5688	TOT ; - Wr ite balanc e total fo r patient.
	5689	"RTN","IBJ DF42",187, 0)
	5690	N I,J
	5691	"RTN","IBJ DF42",188, 0)
	5692	I IBCNT>1 W ! F I=4 0,51,62,72 W ?I,$E(" ---------" ,1,$S(I>60 :8,1:9))
	5693	"RTN","IBJ DF42",189, 0)
	5694	W:IBCNT'> 1 !
	5695	"RTN","IBJ DF42",190, 0)
	5696	W !,"Acco unt Balanc e: $"_$FN( $P(IBP,"^" ,10),",",2 )
	5697	"RTN","IBJ DF42",191, 0)
	5698	I IBCNT'> 1 Q
	5699	"RTN","IBJ DF42",192, 0)
	5700	S J=1 F I =39,50,60, 70 W ?I,$J ($FN($P(IB TOT,"^",J) ,",",2),10 ) S J=J+1
	5701	"RTN","IBJ DF42",193, 0)
	5702	Q
	5703	"RTN","IBJ DF42",194, 0)
	5704	;
	5705	"RTN","IBJ DF42",195, 0)
	5706	DASH(X,Y) ; - Return a dashed line.
	5707	"RTN","IBJ DF42",196, 0)
	5708	Q $TR($J( "",X)," ", $S(Y:"-",1 :"="))
	5709	"RTN","IBJ DF42",197, 0)
	5710	;
	5711	"RTN","IBJ DF42",198, 0)
	5712	ELIG(X) ; - Return e ligibility code name .
	5713	"RTN","IBJ DF42",199, 0)
	5714	; X - Eli gibility c odes separ ated by se mi-collon (;)
	5715	"RTN","IBJ DF42",200, 0)
	5716	;
	5717	"RTN","IBJ DF42",201, 0)
	5718	N ELIG,I
	5719	"RTN","IBJ DF42",202, 0)
	5720	S ELIG="" F I=1:1:$ L(X,";") D
	5721	"RTN","IBJ DF42",203, 0)
	5722	. I '$P(X ,";",I) Q
	5723	"RTN","IBJ DF42",204, 0)
	5724	. S ELIG= ELIG_", "_ $E($P($G(^ DIC(8,+$P( X,";",I),0 )),U),1,20 )
	5725	"RTN","IBJ DF42",205, 0)
	5726	S $E(ELIG ,1,2)=""
	5727	"RTN","IBJ DF42",206, 0)
	5728	;
	5729	"RTN","IBJ DF42",207, 0)
	5730	Q ELIG
	5731	"RTN","IBJ DF42",208, 0)
	5732	;
	5733	"RTN","IBJ DF42",209, 0)
	5734	INFO(X) ; - Return t he patient Additiona l Informat ion about the Patien t Accout
	5735	"RTN","IBJ DF42",210, 0)
	5736	; X - Fla gs represe nting the observatio ns
	5737	"RTN","IBJ DF42",211, 0)
	5738	;
	5739	"RTN","IBJ DF42",212, 0)
	5740	N INFO,I
	5741	"RTN","IBJ DF42",213, 0)
	5742	S INFO="" F I=1:1:$ L(X) D
	5743	"RTN","IBJ DF42",214, 0)
	5744	. I $E(X, I)="V" S I NFO=INFO_" , '*' - VA EMPLOYEE"
	5745	"RTN","IBJ DF42",215, 0)
	5746	. I $E(X, I)="R" S I NFO=INFO_" , REFERRED TO RC"
	5747	"RTN","IBJ DF42",216, 0)
	5748	. I $E(X, I)="D" S I NFO=INFO_" , REFERRED TO DMC"
	5749	"RTN","IBJ DF42",217, 0)
	5750	. I $E(X, I)="T" S I NFO=INFO_" , REFERRED TO TOP"
	5751	"RTN","IBJ DF42",218, 0)
	5752	. I $E(X, I)="P" S I NFO=INFO_" , UNDER RE PAYMENT PL AN"
	5753	"RTN","IBJ DF42",219, 0)
	5754	. I $E(X, I)="F" S I NFO=INFO_" , UNDER DE FAULTED RE PAYMENT PL AN"
	5755	"RTN","IBJ DF42",220, 0)
	5756	S $E(INFO ,1,2)=""
	5757	"RTN","IBJ DF42",221, 0)
	5758	;
	5759	"RTN","IBJ DF42",222, 0)
	5760	Q INFO
	5761	"RTN","IBJ DF42",223, 0)
	5762	;
	5763	"RTN","IBJ DF42",224, 0)
	5764	SSN(X) ; - Format th e SSN.
	5765	"RTN","IBJ DF42",225, 0)
	5766	Q $S(X]"" :$E(X,1,3) _"-"_$E(X, 4,5)_"-"_$ E(X,6,10), 1:"")
	5767	"RTN","IBJ DF42",226, 0)
	5768	;
	5769	"RTN","IBJ DF42",227, 0)
	5770	PAUSE ; - Page break .
	5771	"RTN","IBJ DF42",228, 0)
	5772	I $E(IOST ,1,2)'="C- " Q
	5773	"RTN","IBJ DF42",229, 0)
	5774	N IBX,DIR ,DIRUT,DUO UT,DTOUT,D IROUT,X,Y
	5775	"RTN","IBJ DF42",230, 0)
	5776	F IBX=$Y: 1:(IOSL-3) W !
	5777	"RTN","IBJ DF42",231, 0)
	5778	S DIR(0)= "E" D ^DIR S:$D(DIRU T)!($D(DUO UT)) IBQ=1
	5779	"RTN","IBJ DF42",232, 0)
	5780	Q
	5781	"RTN","IBJ DF43")
	5782	0^22^B2542 7864^B2346 9371
	5783	"RTN","IBJ DF43",1,0)
	5784	IBJDF43 ;A LB/RB - FI RST PARTY FOLLOW-UP REPORT (CO MPILE/PRIN T SUMMARY) ;15-APR-00
	5785	"RTN","IBJ DF43",2,0)
	5786	;;2.0;INT EGRATED BI LLING;12 3,568;21 -MAR-94;Bu ild 40
	5787	"RTN","IBJ DF43",3,0)
	5788	;;Per VA Directive 6402, this routine s hould not be modifie d.
	5789	"RTN","IBJ DF43",4,0)
	5790	;
	5791	"RTN","IBJ DF43",5,0)
	5792	INIT ; - I nitialize counters ( Called by IBJDF41)
	5793	"RTN","IBJ DF43",6,0)
	5794	; Pre-s et variabl es IB, IB( , IBCAT, I BSRC requi red.
	5795	"RTN","IBJ DF43",7,0)
	5796	N I,IB0 S IB0=$S(IB =40:19,1:I B)
	5797	"RTN","IBJ DF43",8,0)
	5798	;
	5799	"RTN","IBJ DF43",9,0)
	5800	I '$D(IB( IBCAT,IB0) ) D
	5801	"RTN","IBJ DF43",10,0 )
	5802	.I IBSTA= "A",IB0'=1 6 Q ; Act ive AR's o nly.
	5803	"RTN","IBJ DF43",11,0 )
	5804	.I IBSTA= "S",IB0=16 Q ; Susp ended AR's only.
	5805	"RTN","IBJ DF43",12,0 )
	5806	.F I=1:1: $S(IBSRC:8 ,1:7),9 S IB(IBCAT,I B0,I)=0
	5807	"RTN","IBJ DF43",13,0 )
	5808	Q
	5809	"RTN","IBJ DF43",14,0 )
	5810	;
	5811	"RTN","IBJ DF43",15,0 )
	5812	EN ; - Com pile entry point fro m IBJDF41.
	5813	"RTN","IBJ DF43",16,0 )
	5814	; Pre-s et variabl es IB, IB( , IBA, IBC AT, IBSRC required.
	5815	"RTN","IBJ DF43",17,0 )
	5816	N I,IB0,I BAGE,IBARD ,IBCAT1,IB OUT S IB0= $S(IB=40:1 9,1:IB)
	5817	"RTN","IBJ DF43",18,0 )
	5818	;
	5819	"RTN","IBJ DF43",19,0 )
	5820	; - Add t otals for summary.
	5821	"RTN","IBJ DF43",20,0 )
	5822	I IBSTA=" S" S IBSUS TYP=$$SUST ^IBJDF41(I BA) I IBSE LST'[(","_ IBSUSTYP_" ,") G ENQ ;Filter b y suspende d
	5823	type IB2 568/DRF
	5824	"RTN","IBJ DF43",21,0 )
	5825	S IBARD=$ $ACT^IBJDF 2(IBA) G:' IBARD ENQ ; No activ ation date .
	5826	"RTN","IBJ DF43",22,0 )
	5827	S IBOUT=0 F I=1:1:5 S IBOUT=I BOUT+$P($G (^PRCA(430 ,IBA,7)),U ,I)
	5828	"RTN","IBJ DF43",23,0 )
	5829	;
	5830	"RTN","IBJ DF43",24,0 )
	5831	; - Handl e claims r eferred to Regional Counsel.
	5832	"RTN","IBJ DF43",25,0 )
	5833	I IBSRC,$ P($G(^PRCA (430,IBA,6 )),U,4) D G ENQ
	5834	"RTN","IBJ DF43",26,0 )
	5835	.S $P(IB( IBCAT,IB0, 8),U)=$P(I B(IBCAT,IB 0,8),U)+1
	5836	"RTN","IBJ DF43",27,0 )
	5837	.S $P(IB( IBCAT,IB0, 8),U,2)=$P (IB(IBCAT, IB0,8),U,2 )+IBOUT
	5838	"RTN","IBJ DF43",28,0 )
	5839	;
	5840	"RTN","IBJ DF43",29,0 )
	5841	I 'IBSRC, $P($G(^PRC A(430,IBA, 6)),U,4) G ENQ ;Fil ter by reg ional coun sel IB25 68/DRF
	5842	"RTN","IBJ DF43",30,0 )
	5843	S IBAGE=$ $FMDIFF^XL FDT(DT,IBA RD),IBCAT1 =$$CAT^IBJ DF2(IBAGE)
	5844	"RTN","IBJ DF43",31,0 )
	5845	S $P(IB(I BCAT,IB0,I BCAT1),U)= $P(IB(IBCA T,IB0,IBCA T1),U)+1
	5846	"RTN","IBJ DF43",32,0 )
	5847	S $P(IB(I BCAT,IB0,I BCAT1),U,2 )=$P(IB(IB CAT,IB0,IB CAT1),U,2) +IBOUT
	5848	"RTN","IBJ DF43",33,0 )
	5849	;
	5850	"RTN","IBJ DF43",34,0 )
	5851	ENQ K IBPR TFLG,IBPAG ,IBRUN,J,Z Q
	5852	"RTN","IBJ DF43",35,0 )
	5853	;
	5854	"RTN","IBJ DF43",36,0 )
	5855	PRT ; - Pr int entry point from IBJDF42.
	5856	"RTN","IBJ DF43",37,0 )
	5857	;
	5858	"RTN","IBJ DF43",38,0 )
	5859	; - Extra ct summary data.
	5860	"RTN","IBJ DF43",39,0 )
	5861	I $G(IBXT RACT) D EX TMO(.IB) G ENQ1
	5862	"RTN","IBJ DF43",40,0 )
	5863	;
	5864	"RTN","IBJ DF43",41,0 )
	5865	; - Print the summa ry report.
	5866	"RTN","IBJ DF43",42,0 )
	5867	D SUM
	5868	"RTN","IBJ DF43",43,0 )
	5869	;
	5870	"RTN","IBJ DF43",44,0 )
	5871	ENQ1 Q
	5872	"RTN","IBJ DF43",45,0 )
	5873	;
	5874	"RTN","IBJ DF43",46,0 )
	5875	EXTMO(IBS) ; Extract /transmit data to DM Extract M odule
	5876	"RTN","IBJ DF43",47,0 )
	5877	; IBS - A rray conta ining the summary in formation
	5878	"RTN","IBJ DF43",48,0 )
	5879	;
	5880	"RTN","IBJ DF43",49,0 )
	5881	N IB,IBCT ,IBI,IBJ,I BR,IBSQ,IB TP,IBZ
	5882	"RTN","IBJ DF43",50,0 )
	5883	;
	5884	"RTN","IBJ DF43",51,0 )
	5885	F IBI=1:1 :5 F IBJ=1 :1:18 S IB (IBI,IBJ)= $S(IBJ#2:0 ,1:"0.00")
	5886	"RTN","IBJ DF43",52,0 )
	5887	;
	5888	"RTN","IBJ DF43",53,0 )
	5889	S IBCT=""
	5890	"RTN","IBJ DF43",54,0 )
	5891	F S IBCT =$O(IBS(IB CT)) Q:IBC T="" D
	5892	"RTN","IBJ DF43",55,0 )
	5893	. S IBTP= 0
	5894	"RTN","IBJ DF43",56,0 )
	5895	. I IBCT= 2 S IBTP=1 ; Emergency/ Humatiatir an
	5896	"RTN","IBJ DF43",57,0 )
	5897	. I IBCT= 1 S IBTP=2 ; Ineligible
	5898	"RTN","IBJ DF43",58,0 )
	5899	. I IBCT= 18 S IBTP= 3 ; C - Means Test
	5900	"RTN","IBJ DF43",59,0 )
	5901	. I IBCT= 22 S IBTP= 4 ; RX CO-Paym ent/SC VET
	5902	"RTN","IBJ DF43",60,0 )
	5903	. I IBCT= 23 S IBTP= 5 ; RX CO-Paym ent/NSC VE T
	5904	"RTN","IBJ DF43",61,0 )
	5905	. S IBSQ= 1
	5906	"RTN","IBJ DF43",62,0 )
	5907	. F IBI=1 :1:8 D
	5908	"RTN","IBJ DF43",63,0 )
	5909	. . S IBZ =$G(IBS(IB CT,16,IBI) )
	5910	"RTN","IBJ DF43",64,0 )
	5911	. . S IB( IBTP,IBSQ) =+IBZ
	5912	"RTN","IBJ DF43",65,0 )
	5913	. . S IB( IBTP,IBSQ+ 1)=$FN(+$P (IBZ,"^",2 ),"",2)
	5914	"RTN","IBJ DF43",66,0 )
	5915	. . S IB( IBTP,17)=I B(IBTP,17) +IBZ
	5916	"RTN","IBJ DF43",67,0 )
	5917	. . S IB( IBTP,18)=I B(IBTP,18) +$P(IBZ,"^ ",2)
	5918	"RTN","IBJ DF43",68,0 )
	5919	. . S IBS Q=IBSQ+2
	5920	"RTN","IBJ DF43",69,0 )
	5921	. S IB(IB TP,18)=$FN (IB(IBTP,1 8),"",2)
	5922	"RTN","IBJ DF43",70,0 )
	5923	;
	5924	"RTN","IBJ DF43",71,0 )
	5925	F IBR=12: 1:16 D E^I BJDE(IBR,0 )
	5926	"RTN","IBJ DF43",72,0 )
	5927	Q
	5928	"RTN","IBJ DF43",73,0 )
	5929	;
	5930	"RTN","IBJ DF43",74,0 )
	5931	SUM ; - Pr int summar y for AR c ategory.
	5932	"RTN","IBJ DF43",75,0 )
	5933	; Input: IBCAT=AR c ategory po inter to f ile #430.2
	5934	"RTN","IBJ DF43",76,0 )
	5935	S IBS=$S( IBSRC:8,1: 7)
	5936	"RTN","IBJ DF43",77,0 )
	5937	S (IBCAT, IB,IBPRTFL G)=0
	5938	"RTN","IBJ DF43",78,0 )
	5939	F S IBCA T=$O(IB(IB CAT)) Q:'I BCAT D Q :IBQ
	5940	"RTN","IBJ DF43",79,0 )
	5941	. D HDR
	5942	"RTN","IBJ DF43",80,0 )
	5943	. F S IB =$O(IB(IBC AT,IB)) Q: 'IB D Q: IBQ
	5944	"RTN","IBJ DF43",81,0 )
	5945	. . ; - C alculate t otals firs t.
	5946	"RTN","IBJ DF43",82,0 )
	5947	. . F I=1 :1:IBS D Q:IBQ
	5948	"RTN","IBJ DF43",83,0 )
	5949	. . . 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)
	5950	"RTN","IBJ DF43",84,0 )
	5951	. . ;
	5952	"RTN","IBJ DF43",85,0 )
	5953	. . I $Y> (IOSL-16) D HDR Q:IB Q
	5954	"RTN","IBJ DF43",86,0 )
	5955	. . ;
	5956	"RTN","IBJ DF43",87,0 )
	5957	. . S X=$ S(IB=16:"A CTIVE ",1: "SUSPENDED ")
	5958	"RTN","IBJ DF43",88,0 )
	5959	. . S X=X _$P($G(^PR CA(430.2,I BCAT,0)),U )
	5960	"RTN","IBJ DF43",89,0 )
	5961	. . W !!! !?(80-$L(X )\2),X,!?( 80-$L(X)\2 ),$$DASH($ L(X)),!!
	5962	"RTN","IBJ DF43",90,0 )
	5963	. . ;
	5964	"RTN","IBJ DF43",91,0 )
	5965	. . W "AR Category" ,?31,"# Re ceivables" ,?52,"Tota l Outstand ing Balanc e",!
	5966	"RTN","IBJ DF43",92,0 )
	5967	. . W "-- ---------" ,?31,"---- ---------" ,?52,"---- ---------- ---------- -",!
	5968	"RTN","IBJ DF43",93,0 )
	5969	. . I 'IB (IBCAT,IB, 9) W !,"Th ere are no statistic s for this category. " D PAUSE Q
	5970	"RTN","IBJ DF43",94,0 )
	5971	. . ;
	5972	"RTN","IBJ DF43",95,0 )
	5973	. . ; - P rimary loo p to write results.
	5974	"RTN","IBJ DF43",96,0 )
	5975	. . S Y=$ P(IB(IBCAT ,IB,9),U,2 )
	5976	"RTN","IBJ DF43",97,0 )
	5977	. . F I=1 :1:IBS,9 S X=$P($T(C ATN+I),";; ",2,99) D
	5978	"RTN","IBJ DF43",98,0 )
	5979	. . . W:I =9 ! W !,X ,?30,$J(+I B(IBCAT,IB ,I),6)
	5980	"RTN","IBJ DF43",99,0 )
	5981	. . . W " (",$J(+I B(IBCAT,IB ,I)/+IB(IB CAT,IB,9)* 100,0,$S(I =9:0,1:2)) ,"%)"
	5982	"RTN","IBJ DF43",100, 0)
	5983	. . . S Z =$FN($P(IB (IBCAT,IB, I),U,2),", ",2)
	5984	"RTN","IBJ DF43",101, 0)
	5985	. . . W ? 52,$J($S(I =1!(I=9):" $",1:"")_Z ,15)
	5986	"RTN","IBJ DF43",102, 0)
	5987	. . . W " (",$J($S ('Y:0,1:$P (IB(IBCAT, IB,I),U,2) /Y*100),0, $S(I=9:0,1 :2)),"%)"
	5988	"RTN","IBJ DF43",103, 0)
	5989	. . ;
	5990	"RTN","IBJ DF43",104, 0)
	5991	. . S IBP RTFLG=1 D PAUSE
	5992	"RTN","IBJ DF43",105, 0)
	5993	;
	5994	"RTN","IBJ DF43",106, 0)
	5995	I 'IBPRTF LG D
	5996	"RTN","IBJ DF43",107, 0)
	5997	. W !!!!! !,"There a re no rece ivables fo r the para meters ent ered."
	5998	"RTN","IBJ DF43",108, 0)
	5999	;
	6000	"RTN","IBJ DF43",109, 0)
	6001	SUMQ Q
	6002	"RTN","IBJ DF43",110, 0)
	6003	;
	6004	"RTN","IBJ DF43",111, 0)
	6005	HDR ; - Wr ite the su mmary repo rt header.
	6006	"RTN","IBJ DF43",112, 0)
	6007	W:'$G(IBP AG) ! I $E (IOST,1,2) ="C-"!$G(I BPAG) W @I OF,*13
	6008	"RTN","IBJ DF43",113, 0)
	6009	S IBPAG=$ G(IBPAG)+1
	6010	"RTN","IBJ DF43",114, 0)
	6011	W "FIRST PARTY FOLL OW-UP SUMM ARY REPORT Run Dat e: ",IBRUN
	6012	"RTN","IBJ DF43",115, 0)
	6013	W ?71,"Pa ge: ",$J(I BPAG,3)
	6014	"RTN","IBJ DF43",116, 0)
	6015	S X=""
	6016	"RTN","IBJ DF43",117, 0)
	6017	I IBRPT=" D" D
	6018	"RTN","IBJ DF43",118, 0)
	6019	. I IBSMN '="A" D
	6020	"RTN","IBJ DF43",119, 0)
	6021	. . S X=" RECEIVAB LES OVER " _IBSMN_" A ND LESS TH AN "_IBSMX _" DAYS OL D "
	6022	"RTN","IBJ DF43",120, 0)
	6023	. I $G(IB SNA)'="ALL " D
	6024	"RTN","IBJ DF43",121, 0)
	6025	. . S X=X _"/ PATIEN TS FROM '" _$S(IBSNF= "":"FIRST" ,1:IBSNF)_ "' TO '"
	6026	"RTN","IBJ DF43",122, 0)
	6027	. . S X=X _$S(IBSNL= "zzzzz":"L AST",1:IBS NL)_"' "
	6028	"RTN","IBJ DF43",123, 0)
	6029	. I $G(IB SAM) S X=X _"/ MINIMU M BALANCE: $"_$FN(IB SAM,",",2) _" "
	6030	"RTN","IBJ DF43",124, 0)
	6031	S X=X_"/ RECEIVABLE S REFERRED TO RC "_$ S('IBSRC:" NOT ",1:"" )_"INCLUDE D"
	6032	"RTN","IBJ DF43",125, 0)
	6033	S $E(X,1, 2)=""
	6034	"RTN","IBJ DF43",126, 0)
	6035	F I=1:1 W !,$E(X,1, 80) S X=$E (X,81,999) I X="" Q
	6036	"RTN","IBJ DF43",127, 0)
	6037	;
	6038	"RTN","IBJ DF43",128, 0)
	6039	Q
	6040	"RTN","IBJ DF43",129, 0)
	6041	;
	6042	"RTN","IBJ DF43",130, 0)
	6043	DASH(X) ; - Return a dashed li ne.
	6044	"RTN","IBJ DF43",131, 0)
	6045	Q $TR($J( "",X)," ", "=")
	6046	"RTN","IBJ DF43",132, 0)
	6047	;
	6048	"RTN","IBJ DF43",133, 0)
	6049	PAUSE ; - Page break .
	6050	"RTN","IBJ DF43",134, 0)
	6051	I $E(IOST ,1,2)'="C- " Q
	6052	"RTN","IBJ DF43",135, 0)
	6053	N IBX,DIR ,DIRUT,DUO UT,DTOUT,D IROUT,X,Y
	6054	"RTN","IBJ DF43",136, 0)
	6055	F IBX=$Y: 1:(IOSL-3) W !
	6056	"RTN","IBJ DF43",137, 0)
	6057	S DIR(0)= "E" D ^DIR S:$D(DIRU T)!($D(DUO UT)) IBQ=1
	6058	"RTN","IBJ DF43",138, 0)
	6059	Q
	6060	"RTN","IBJ DF43",139, 0)
	6061	;
	6062	"RTN","IBJ DF43",140, 0)
	6063	CATN ; - L ist of cat egory name s.
	6064	"RTN","IBJ DF43",141, 0)
	6065	;;Less th an 30 days old
	6066	"RTN","IBJ DF43",142, 0)
	6067	;;31-60 d ays
	6068	"RTN","IBJ DF43",143, 0)
	6069	;;61-90 d ays
	6070	"RTN","IBJ DF43",144, 0)
	6071	;;91-120 days
	6072	"RTN","IBJ DF43",145, 0)
	6073	;;121-180 days
	6074	"RTN","IBJ DF43",146, 0)
	6075	;;181-365 days
	6076	"RTN","IBJ DF43",147, 0)
	6077	;;Over 36 5 days
	6078	"RTN","IBJ DF43",148, 0)
	6079	;;Referre d to Regio nal Counse l
	6080	"RTN","IBJ DF43",149, 0)
	6081	;;Total F irst Party Receivabl es
	6082	"RTN","IBJ TLA1")
	6083	0^2^B13446 872^B12051 503
	6084	"RTN","IBJ TLA1",1,0)
	6085	IBJTLA1 ;A LB/ARH - T PI ACTIVE BILLS LIST BUILD ;2/ 14/95
	6086	"RTN","IBJ TLA1",2,0)
	6087	;;2.0;INT EGRATED BI LLING;39 ,80,61,51, 153,137,18 3,276,451, 516,530,56 8;21-MAR -94;Build 40
	6088	"RTN","IBJ TLA1",3,0)
	6089	;;Per VA Directive 6402, this routine s hould not be modifie d.
	6090	"RTN","IBJ TLA1",4,0)
	6091	;
	6092	"RTN","IBJ TLA1",5,0)
	6093	BLDA ; bui ld active list for t hird party joint inq uiry activ e list
	6094	"RTN","IBJ TLA1",6,0)
	6095	N IBIFN,I BCNT S VAL MCNT=0,IBC NT=0
	6096	"RTN","IBJ TLA1",7,0)
	6097	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
	6098	"RTN","IBJ TLA1",8,0)
	6099	;
	6100	"RTN","IBJ TLA1",9,0)
	6101	I VALMCNT =0 D SET(" ",0),SET( "No Active Bills for this Pati ent",0)
	6102	"RTN","IBJ TLA1",10,0 )
	6103	;
	6104	"RTN","IBJ TLA1",11,0 )
	6105	Q
	6106	"RTN","IBJ TLA1",12,0 )
	6107	;
	6108	"RTN","IBJ TLA1",13,0 )
	6109	SCRN ; add bill to s creen list (IBIFN,DF N must be defined)
	6110	"RTN","IBJ TLA1",14,0 )
	6111	N X,IBY,I BD0,IBDU,I BDM,TYPE,R EJFLAG,IND FLG,IBTYP S X=""
	6112	"RTN","IBJ TLA1",15,0 )
	6113	S
	6114	IBCNT=IBCN T+1,IBD0=$ G(^DGCR(39 9,+IBIFN,0 )),IBDU=$G (^DGCR(399 ,+IBIFN,"U ")),IBDM=$ G(^DGCR(39
	6115	9,+IBIFN," M"))
	6116	"RTN","IBJ TLA1",16,0 )
	6117	S IBY=IBC NT,X=$$SET FLD^VALM1( IBY,X,"NUM BER")
	6118	"RTN","IBJ TLA1",17,0 )
	6119	; IB2.0 451 - get EEOB indic ator for b ill # when applicabl e
	6120	"RTN","IBJ TLA1",18,0 )
	6121	S IBPFLAG =$$EEOB(+I BIFN)
	6122	"RTN","IBJ TLA1",19,0 )
	6123	S REJFLAG =+$$BILLRE J^IBJTU6($ P(IBD0,U)) ;IB2.05 30 Add ind icator for rejects
	6124	"RTN","IBJ TLA1",20,0 )
	6125	S INDFLG= $S($G(IBPF LAG)'="":" %",1:"")_$ S(REJFLAG: "c",1:"") S:INDFLG=" " INDFLG=" "
	6126	"RTN","IBJ TLA1",21,0 )
	6127	S IBY=IND FLG_$P(IBD 0,U,1)_$$E CME^IBTRE( IBIFN),X=$ $SETFLD^VA LM1(IBY,X, "BILL") ;a dd EEOB
	6128	indicator '%' to bil l number w hen applic able
	6129	"RTN","IBJ TLA1",22,0 )
	6130	S IBY=$S( $$REF^IBJT U31(+IBIFN ):"r",1:"" ),X=$$SETF LD^VALM1(I BY,X,"REFE R")
	6131	"RTN","IBJ TLA1",23,0 )
	6132	S IBY=$S( $$IB^IBRUT L(+IBIFN,0 ):"*",1:"" ),X=$$SETF LD^VALM1(I BY,X,"HD")
	6133	"RTN","IBJ TLA1",24,0 )
	6134	S IBY=$$D ATE($P(IBD U,U,1)),X= $$SETFLD^V ALM1(IBY,X ,"STFROM")
	6135	"RTN","IBJ TLA1",25,0 )
	6136	S IBY=$$D ATE($P(IBD U,U,2)),X= $$SETFLD^V ALM1(IBY,X ,"STTO")
	6137	"RTN","IBJ TLA1",26,0 )
	6138	;
	6139	"RTN","IBJ TLA1",27,0 )
	6140	S
	6141	IBY=$P($$L ST^DGMTU(D FN,$P(IBDU ,U)),U,4), IBY=$S(IBY ="C":"YES" ,IBY="P":" PEN",IBY=" R":"REQ",I BY="G
	6142	":"GMT",1: "NO"),X=$$ SETFLD^VAL M1(IBY,X," MT?")
	6143	"RTN","IBJ TLA1",28,0 )
	6144	;S
	6145	IBY=$$TYPE ($P(IBD0,U ,5))_$$TF( $P(IBD0,U, 6))_$S($P( IBD0,U,27) =1:"I",$P( IBD0,U,27) =2:"P",1:" "),X=$$SE
	6146	TFLD^VALM1 (IBY,X,"TY PE") ; 51 6 - baa
	6147	"RTN","IBJ TLA1",29,0 )
	6148	S TYPE=$$ TYPE($P(IB D0,U,5)) I $E(TYPE,2 )="P" S TY PE=$E(TYPE ) ; 516 - baa
	6149	"RTN","IBJ TLA1",30,0 )
	6150	;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") ;
	6151	516 - baa
	6152	"RTN","IBJ TLA1",31,0 )
	6153	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") ;
	6154	568 - lmh ret space if null
	6155	"RTN","IBJ TLA1",32,0 )
	6156	;
	6157	"RTN","IBJ TLA1",33,0 )
	6158	; Return care type for (I)npa t,(O)utpat , (R)x or (P)rosthet ics - add under TJPI screen TY PE column - 568
	6159	"RTN","IBJ TLA1",34,0 )
	6160	S IBTYP=$ $TYP^IBRFN (IBIFN)
	6161	"RTN","IBJ TLA1",35,0 )
	6162	S IBTYP=$ S(IBTYP="" :-1,IBTYP= "PR":"P",I BTYP="PH": "R",1:IBTY P)
	6163	"RTN","IBJ TLA1",36,0 )
	6164	S IBY=IBY _"/"_IBTYP ,X=$$SETFL D^VALM1(IB Y,X,"TYPE" )
	6165	"RTN","IBJ TLA1",37,0 )
	6166	;
	6167	"RTN","IBJ TLA1",38,0 )
	6168	S IBY=" " _$P($$ARST ATA^IBJTU4 (IBIFN),U, 2),X=$$SET FLD^VALM1( IBY,X,"ARS T")
	6169	"RTN","IBJ TLA1",39,0 )
	6170	;
	6171	"RTN","IBJ TLA1",40,0 )
	6172	S IBY=$P( $G(^DGCR(3 99.3,+$P(I BD0,U,7),0 )),U,4),X= $$SETFLD^V ALM1(IBY,X ,"RATE")
	6173	"RTN","IBJ TLA1",41,0 )
	6174	S IBY=$S( $$MINS^IBJ TU31(+IBIF N):"+",1:" "),X=$$SET FLD^VALM1( IBY,X,"CB" )
	6175	"RTN","IBJ TLA1",42,0 )
	6176	S IBY=+$G (^DGCR(399 ,+IBIFN,"M P"))
	6177	"RTN","IBJ TLA1",43,0 )
	6178	I 'IBY,$$ MCRWNR^IBE FUNC($$CUR R^IBCEF2(I BIFN)) S I BY=+$$CURR ^IBCEF2(IB IFN)
	6179	"RTN","IBJ TLA1",44,0 )
	6180	S IBY=$P( $G(^DIC(36 ,+IBY,0)), U,1)
	6181	"RTN","IBJ TLA1",45,0 )
	6182	S X=$$SET FLD^VALM1( IBY,X,"INS UR")
	6183	"RTN","IBJ TLA1",46,0 )
	6184	S IBY=$$B ILL^RCJIBF N2(IBIFN)
	6185	"RTN","IBJ TLA1",47,0 )
	6186	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,1),8,2) ,X,"OAMT")
	6187	"RTN","IBJ TLA1",48,0 )
	6188	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,3),8,2) ,X,"CAMT")
	6189	"RTN","IBJ TLA1",49,0 )
	6190	D SET(X,I BCNT)
	6191	"RTN","IBJ TLA1",50,0 )
	6192	Q
	6193	"RTN","IBJ TLA1",51,0 )
	6194	;
	6195	"RTN","IBJ TLA1",52,0 )
	6196	DATE(X) ; date in ex ternal for mat
	6197	"RTN","IBJ TLA1",53,0 )
	6198	N Y S Y=" " I X?7N.E S Y=$E(X, 4,5)_"/"_$ E(X,6,7)_" /"_$E(X,2, 3)
	6199	"RTN","IBJ TLA1",54,0 )
	6200	Q Y
	6201	"RTN","IBJ TLA1",55,0 )
	6202	;
	6203	"RTN","IBJ TLA1",56,0 )
	6204	TYPE(X) ; return abb reviated f orm of Bil l Classifi cation (39 9,.05)
	6205	"RTN","IBJ TLA1",57,0 )
	6206	Q $S(X=1: "IP",X=2:" IH",X=3:"O P",X=4:"OH ",1:"")
	6207	"RTN","IBJ TLA1",58,0 )
	6208	;
	6209	"RTN","IBJ TLA1",59,0 )
	6210	TF(X) ; re turn abbre viated for m of Timef rame of Bi ll (399,.0 6)
	6211	"RTN","IBJ TLA1",60,0 )
	6212	Q $S(X=2: "-F",X=3:" -C",X=4:"- L",X'=1:"- O",1:"")
	6213	"RTN","IBJ TLA1",61,0 )
	6214	;
	6215	"RTN","IBJ TLA1",62,0 )
	6216	SET(X,CNT) ; set up list manag er screen array
	6217	"RTN","IBJ TLA1",63,0 )
	6218	S VALMCNT =VALMCNT+1
	6219	"RTN","IBJ TLA1",64,0 )
	6220	S ^TMP("I BJTLA",$J, VALMCNT,0) =X Q:'CNT
	6221	"RTN","IBJ TLA1",65,0 )
	6222	S ^TMP("I BJTLA",$J, "IDX",VALM CNT,+CNT)= ""
	6223	"RTN","IBJ TLA1",66,0 )
	6224	S ^TMP("I BJTLAX",$J ,CNT)=VALM CNT_U_IBIF N
	6225	"RTN","IBJ TLA1",67,0 )
	6226	Q
	6227	"RTN","IBJ TLA1",68,0 )
	6228	;
	6229	"RTN","IBJ TLA1",69,0 )
	6230	EEOB(IBIFN ) ; get pa yment info rmation
	6231	"RTN","IBJ TLA1",70,0 )
	6232	; IB2.0 451 - find an EOB pa yment for a bill
	6233	"RTN","IBJ TLA1",71,0 )
	6234	; input i s the IEN for the bi ll # in fi le #399 an d must be valid,
	6235	"RTN","IBJ TLA1",72,0 )
	6236	; output is the EEO B indicato r '%' if a payment i s found in file #361 .1,
	6237	"RTN","IBJ TLA1",73,0 )
	6238	; exclude EOB type MRA (Medic are).
	6239	"RTN","IBJ TLA1",74,0 )
	6240	N IBPFLAG ,IBVAL,Z
	6241	"RTN","IBJ TLA1",75,0 )
	6242	I $G(IBIF N)=0 Q ""
	6243	"RTN","IBJ TLA1",76,0 )
	6244	I '$O(^IB M(361.1,"B ",IBIFN,0) ) Q "" ; no entry h ere
	6245	"RTN","IBJ TLA1",77,0 )
	6246	I $P($G(^ DGCR(399,I BIFN,0))," ^",13)=1 Q "" ;avoi d 'ENTERED /NOT REVIE WED' statu s
	6247	"RTN","IBJ TLA1",78,0 )
	6248	; handle both singl e and mult iple bill entries in file #361 .1
	6249	"RTN","IBJ TLA1",79,0 )
	6250	S Z=0 F S Z=$O(^IB M(361.1,"B ",IBIFN,Z) ) Q:'Z D Q:$G(IBPF LAG)="%"
	6251	"RTN","IBJ TLA1",80,0 )
	6252	. S IBVAL =$G(^IBM(3 61.1,Z,0))
	6253	"RTN","IBJ TLA1",81,0 )
	6254	. S IBPFL AG=$S($P(I BVAL,"^",4 )=1:"",$P( IBVAL,"^", 4)=0:"%",1 :"")
	6255	"RTN","IBJ TLA1",82,0 )
	6256	Q IBPFLAG ; EOB in dicator fo r either 1 st or 3rd payment on bill
	6257	"RTN","IBJ TLA1",83,0 )
	6258	;
	6259	"RTN","IBJ TLB1")
	6260	0^7^B13573 050^B12752 963
	6261	"RTN","IBJ TLB1",1,0)
	6262	IBJTLB1 ;A LB/ARH - T PI INACTIV E LIST BUI LD ;2/14/9 5
	6263	"RTN","IBJ TLB1",2,0)
	6264	;;2.0;INT EGRATED BI LLING;39 ,80,61,137 ,276,451,5 16,530,568 ;21-MAR- 94;Build 4 0
	6265	"RTN","IBJ TLB1",3,0)
	6266	;;Per VA Directive 6402, this routine s hould not be modifie d.
	6267	"RTN","IBJ TLB1",4,0)
	6268	;
	6269	"RTN","IBJ TLB1",5,0)
	6270	BLDA ; bui ld active list for t hird party joint inq uiry activ e list, DF N must be defined
	6271	"RTN","IBJ TLB1",6,0)
	6272	; 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
	6273	greater
	6274	"RTN","IBJ TLB1",7,0)
	6275	; all bil ls for a s ingle day are includ ed in the same searc h so even IBMAXCNT m ay be exce eded
	6276	"RTN","IBJ TLB1",8,0)
	6277	; 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
	6278	"RTN","IBJ TLB1",9,0)
	6279	; 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
	6280	next
	6281	"RTN","IBJ TLB1",10,0 )
	6282	; end dat e of the s earch, thi s results in each CD action de fault work ing backwa rds throug h the date
	6283	range unti l
	6284	"RTN","IBJ TLB1",11,0 )
	6285	; 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
	6286	changed
	6287	"RTN","IBJ TLB1",12,0 )
	6288	N IBIFN,I BCNT,IBBDT ,IBEDT,IBF IRST,IBLAS T,IBDT1,IB DT2,IBMAXC NT K IBHMS G
	6289	"RTN","IBJ TLB1",13,0 )
	6290	S IBEDT=$ S(+$G(IBEN D):IBEND,1 :DT),IBBDT =$$FMADD^X LFDT(IBEDT ,-180),IBM AXCNT=52
	6291	"RTN","IBJ TLB1",14,0 )
	6292	;
	6293	"RTN","IBJ TLB1",15,0 )
	6294	S (VALMCN T,IBCNT)=0 ,IBDT1=$S( IBEDT'="": -(IBEDT+.0 1),1:""),I BDT2=-IBBD T
	6295	"RTN","IBJ TLB1",16,0 )
	6296	S IBFIRST =IBBDT,IBL AST=-$O(^D GCR(399,"A PDS",DFN," "))
	6297	"RTN","IBJ TLB1",17,0 )
	6298	;
	6299	"RTN","IBJ TLB1",18,0 )
	6300	F S IBDT 1=$O(^DGCR (399,"APDS ",DFN,IBDT 1)) Q:'IBD T1!(IBDT1> IBDT2&(IBC NT'<IBMAXC NT)) S
	6301	IBFIRST=-I BDT1 D
	6302	"RTN","IBJ TLB1",19,0 )
	6303	. 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
	6304	SCRN W "."
	6305	"RTN","IBJ TLB1",20,0 )
	6306	;
	6307	"RTN","IBJ TLB1",21,0 )
	6308	S IBBEG=$ S('IBDT1:" ",IBBDT>IB FIRST:IBFI RST,1:IBBD T),IBBDT=$ S(+IBBEG:$ $DATE(IBBE G),1:"BEGI N")
	6309	"RTN","IBJ TLB1",22,0 )
	6310	S IBEND=$ S(IBEDT="" !(IBLAST'> IBEDT):"", 1:IBEDT),I BEDT=$S(+I BEND:$$DAT E(IBEND),1 :"END")
	6311	"RTN","IBJ TLB1",23,0 )
	6312	;
	6313	"RTN","IBJ TLB1",24,0 )
	6314	I 'IBBEG, 'IBEND S I BHMSG="** All Inacti ve Bills * *"
	6315	"RTN","IBJ TLB1",25,0 )
	6316	I $G(IBHM SG)="" S I BHMSG=IBBD T_" - "_IB EDT
	6317	"RTN","IBJ TLB1",26,0 )
	6318	S IBHMSG= IBHMSG_" ("_VALMCN T_")"
	6319	"RTN","IBJ TLB1",27,0 )
	6320	;
	6321	"RTN","IBJ TLB1",28,0 )
	6322	I VALMCNT =0 D SET(" ",0),SET( "No Inacti ve Bills f or this Pa tient",0)
	6323	"RTN","IBJ TLB1",29,0 )
	6324	;
	6325	"RTN","IBJ TLB1",30,0 )
	6326	Q
	6327	"RTN","IBJ TLB1",31,0 )
	6328	;
	6329	"RTN","IBJ TLB1",32,0 )
	6330	SCRN ; add bill to s creen list (IBIFN,DF N must be defined)
	6331	"RTN","IBJ TLB1",33,0 )
	6332	N X,IBY,I BD0,IBDU,I BDM,TYPE,R EJFLAG,IND FLG S X=""
	6333	"RTN","IBJ TLB1",34,0 )
	6334	S
	6335	IBCNT=IBCN T+1,IBD0=$ G(^DGCR(39 9,+IBIFN,0 )),IBDU=$G (^DGCR(399 ,+IBIFN,"U ")),IBDM=$ G(^DGCR(39
	6336	9,+IBIFN," M"))
	6337	"RTN","IBJ TLB1",35,0 )
	6338	S IBY=IBC NT,X=$$SET FLD^VALM1( IBY,X,"NUM BER")
	6339	"RTN","IBJ TLB1",36,0 )
	6340	; IB2.0 451 - get EEOB indic ator for b ill # when applicabl e
	6341	"RTN","IBJ TLB1",37,0 )
	6342	S IBPFLAG =$$EEOB^IB JTLA1(+IBI FN)
	6343	"RTN","IBJ TLB1",38,0 )
	6344	S REJFLAG =+$$BILLRE J^IBJTU6($ P(IBD0,U)) ;IB2.05 30 Add ind icator for rejects
	6345	"RTN","IBJ TLB1",39,0 )
	6346	S INDFLG= $S($G(IBPF LAG)'="":" %",1:"")_$ S(REJFLAG: "c",1:"") S:INDFLG=" " INDFLG=" "
	6347	"RTN","IBJ TLB1",40,0 )
	6348	S IBY=$P( IBD0,U,1)_ $$ECME^IBT RE(IBIFN), X=$$SETFLD ^VALM1(IBY ,X,"BILL")
	6349	"RTN","IBJ TLB1",41,0 )
	6350	S IBY=IND FLG_IBY,X= $$SETFLD^V ALM1(IBY,X ,"BILL")
	6351	"RTN","IBJ TLB1",42,0 )
	6352	S IBY=$S( $$REF^IBJT U31(+IBIFN ):"r",1:"" ),X=$$SETF LD^VALM1(I BY,X,"REFE R")
	6353	"RTN","IBJ TLB1",43,0 )
	6354	S IBY=$S( $$IB^IBRUT L(+IBIFN,0 ):"*",1:"" ),X=$$SETF LD^VALM1(I BY,X,"HD")
	6355	"RTN","IBJ TLB1",44,0 )
	6356	S IBY=$$D ATE($P(IBD U,U,1)),X= $$SETFLD^V ALM1(IBY,X ,"STFROM")
	6357	"RTN","IBJ TLB1",45,0 )
	6358	S IBY=$$D ATE($P(IBD U,U,2)),X= $$SETFLD^V ALM1(IBY,X ,"STTO")
	6359	"RTN","IBJ TLB1",46,0 )
	6360	;
	6361	"RTN","IBJ TLB1",47,0 )
	6362	;S IBY=$$ TYPE($P(IB D0,U,5))_$ $TF($P(IBD 0,U,6)),X= $$SETFLD^V ALM1(IBY,X ,"TYPE")
	6363	"RTN","IBJ TLB1",48,0 )
	6364	S TYPE=$$ TYPE($P(IB D0,U,5)) I $E(TYPE,2 )="P" S TY PE=$E(TYPE ) ; 516 - baa
	6365	"RTN","IBJ TLB1",49,0 )
	6366	;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") ;
	6367	516 - baa
	6368	"RTN","IBJ TLB1",50,0 )
	6369	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")
	6370	"RTN","IBJ TLB1",51,0 )
	6371	S IBTYP=$ $TYP^IBRFN (IBIFN)
	6372	"RTN","IBJ TLB1",52,0 )
	6373	S IBTYP=$ S(IBTYP="" :-1,IBTYP= "PR":"P",I BTYP="PH": "R",1:IBTY P)
	6374	"RTN","IBJ TLB1",53,0 )
	6375	S IBY=IBY _"/"_IBTYP ,X=$$SETFL D^VALM1(IB Y,X,"TYPE" )
	6376	"RTN","IBJ TLB1",54,0 )
	6377	S IBY=" " _$P($$ARST ATA^IBJTU4 (IBIFN),U, 2),X=$$SET FLD^VALM1( IBY,X,"ARS T")
	6378	"RTN","IBJ TLB1",55,0 )
	6379	;
	6380	"RTN","IBJ TLB1",56,0 )
	6381	S IBY=$P( $G(^DGCR(3 99.3,+$P(I BD0,U,7),0 )),U,4),X= $$SETFLD^V ALM1(IBY,X ,"RATE")
	6382	"RTN","IBJ TLB1",57,0 )
	6383	S IBY=$S( $$MINS^IBJ TU31(IBIFN ):"+",1:"" ),X=$$SETF LD^VALM1(I BY,X,"CB")
	6384	"RTN","IBJ TLB1",58,0 )
	6385	S IBY=+$G (^DGCR(399 ,+IBIFN,"M P"))
	6386	"RTN","IBJ TLB1",59,0 )
	6387	I 'IBY,$$ MCRWNR^IBE FUNC(+$$CU RR^IBCEF2( IBIFN)) S IBY=+$$CUR R^IBCEF2(I BIFN)
	6388	"RTN","IBJ TLB1",60,0 )
	6389	S IBY=$P( $G(^DIC(36 ,+IBY,0)), U,1),X=$$S ETFLD^VALM 1(IBY,X,"I NSUR")
	6390	"RTN","IBJ TLB1",61,0 )
	6391	S IBY=$$B ILL^RCJIBF N2(IBIFN)
	6392	"RTN","IBJ TLB1",62,0 )
	6393	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,1),8,2) ,X,"OAMT")
	6394	"RTN","IBJ TLB1",63,0 )
	6395	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,3),8,2) ,X,"CAMT")
	6396	"RTN","IBJ TLB1",64,0 )
	6397	D SET(X,I BCNT)
	6398	"RTN","IBJ TLB1",65,0 )
	6399	Q
	6400	"RTN","IBJ TLB1",66,0 )
	6401	;
	6402	"RTN","IBJ TLB1",67,0 )
	6403	DATE(X) ; date in ex ternal for mat
	6404	"RTN","IBJ TLB1",68,0 )
	6405	Q $E(X,4, 5)_"/"_$E( X,6,7)_"/" _$E(X,2,3)
	6406	"RTN","IBJ TLB1",69,0 )
	6407	;
	6408	"RTN","IBJ TLB1",70,0 )
	6409	TYPE(X) ; return abb reviated f orm of Bil l Classifi cation (39 9,.05)
	6410	"RTN","IBJ TLB1",71,0 )
	6411	; modifie d for 516 - baa
	6412	"RTN","IBJ TLB1",72,0 )
	6413	;Q $S(X=1 :"IP",X=2: "IH",X=3:" OP",X=4:"O H",1:"")
	6414	"RTN","IBJ TLB1",73,0 )
	6415	Q $S(X=1: "I",X=2:"I H",X=3:"O" ,X=4:"OH", 1:"")
	6416	"RTN","IBJ TLB1",74,0 )
	6417	;
	6418	"RTN","IBJ TLB1",75,0 )
	6419	TF(X) ; re turn abbre viated for m of Timef rame of Bi ll (399,.0 6)
	6420	"RTN","IBJ TLB1",76,0 )
	6421	Q $S(X=2: "-F",X=3:" -C",X=4:"- L",X'=1:"- O",1:"")
	6422	"RTN","IBJ TLB1",77,0 )
	6423	;
	6424	"RTN","IBJ TLB1",78,0 )
	6425	SET(X,CNT) ; set up list manag er screen array
	6426	"RTN","IBJ TLB1",79,0 )
	6427	S VALMCNT =VALMCNT+1
	6428	"RTN","IBJ TLB1",80,0 )
	6429	S ^TMP("I BJTLB",$J, VALMCNT,0) =X Q:'CNT
	6430	"RTN","IBJ TLB1",81,0 )
	6431	S ^TMP("I BJTLB",$J, "IDX",VALM CNT,+CNT)= ""
	6432	"RTN","IBJ TLB1",82,0 )
	6433	S ^TMP("I BJTLBX",$J ,CNT)=VALM CNT_U_IBIF N
	6434	"RTN","IBJ TLB1",83,0 )
	6435	Q
	6436	"RTN","IBT RE2")
	6437	0^3^B41874 411^B32981 505
	6438	"RTN","IBT RE2",1,0)
	6439	IBTRE2 ;AL B/AAS - CL AIMS TRACK ING - ACTI ONS ;27-JU N-93
	6440	"RTN","IBT RE2",2,0)
	6441	;;2.0;INT EGRATED BI LLING;23 ,121,249,3 12,568;2 1-MAR-94;B uild 40
	6442	"RTN","IBT RE2",3,0)
	6443	;;Per VA Directive 6402, this routine s hould not be modifie d.
	6444	"RTN","IBT RE2",4,0)
	6445	;
	6446	"RTN","IBT RE2",5,0)
	6447	% G EN^IBT RE
	6448	"RTN","IBT RE2",6,0)
	6449	;
	6450	"RTN","IBT RE2",7,0)
	6451	AT ; -- Ad d tracking entry
	6452	"RTN","IBT RE2",8,0)
	6453	I '$$PFSS WARN^IBBSH DWN() S VA LMBCK="R" Q ;IB2.031 2
	6454	"RTN","IBT RE2",9,0)
	6455	D FULL^VA LM1
	6456	"RTN","IBT RE2",10,0)
	6457	N X,Y,DIC ,DA,DR,DD, DO,DIR,DIR UT,DTOUT,D UOUT,IBETY P,IBQUIT,I BTDT,VAIN, VAINDT,IBT RN,IBTDTE
	6458	"RTN","IBT RE2",11,0)
	6459	N IBDEL,I BDELO,IBMA RK,IBPR,IB PRO,PCOV,P IEN,RC
	6460	"RTN","IBT RE2",12,0)
	6461	;
	6462	"RTN","IBT RE2",13,0)
	6463	TEST S IBQ UIT=0
	6464	"RTN","IBT RE2",14,0)
	6465	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
	6466	Tracking T ype: " ;5 68
	6467	"RTN","IBT RE2",15,0)
	6468	D ^DIC K DIC S IBET YP=+Y I +Y <0 G ATQ
	6469	"RTN","IBT RE2",16,0)
	6470	W !
	6471	"RTN","IBT RE2",17,0)
	6472	;
	6473	"RTN","IBT RE2",18,0)
	6474	ADM I IBET YP=$O(^IBE (356.6,"AC ",1,0)) D I IBQUIT G ATQ
	6475	"RTN","IBT RE2",19,0)
	6476	.N DIR
	6477	"RTN","IBT RE2",20,0)
	6478	.S DIR("? ")=" "
	6479	"RTN","IBT RE2",21,0)
	6480	.S DIR("? ",1)=" Enter any Date!"
	6481	"RTN","IBT RE2",22,0)
	6482	.S DIR("? ",2)=" "
	6483	"RTN","IBT RE2",23,0)
	6484	.S DIR("? ",3)=" If the pat ient was a n inpatien t on that date the s ystem will use the"
	6485	"RTN","IBT RE2",24,0)
	6486	.S DIR("? ",4)=" correct ad mission da te. If yo u are trac king an ad missions a t another"
	6487	"RTN","IBT RE2",25,0)
	6488	.S DIR("? ",5)=" facility y ou may ent er that da te. Enter '??' to g et a list of the"
	6489	"RTN","IBT RE2",26,0)
	6490	.S DIR("? ",6)=" last 10 ad missions f or this pa tient."
	6491	"RTN","IBT RE2",27,0)
	6492	.S DIR("? ?")="^D LI STA^IBTRE2 0"
	6493	"RTN","IBT RE2",28,0)
	6494	.S DIR(0) ="DO^::AEX TP",DIR("A ")="Admiss ion Date"
	6495	"RTN","IBT RE2",29,0)
	6496	.D ^DIR K DIR S (IB TDT,VAINDT )=+Y I $P( VAINDT,"." ,2)="" S V AINDT=VAIN DT+.24
	6497	"RTN","IBT RE2",30,0)
	6498	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	6499	"RTN","IBT RE2",31,0)
	6500	.; -- che ck for val id admissi on
	6501	"RTN","IBT RE2",32,0)
	6502	.S VA200= "" D INP^V ADPT I VAI N(1)="" D ;look for one day a dmission
	6503	"RTN","IBT RE2",33,0)
	6504	..S IBX=+ $O(^(+$O(^ DGPM("ATID 1",DFN,999 9999-IBTDT )),0)),IBX =+$G(^DGPM (IBX,0))
	6505	"RTN","IBT RE2",34,0)
	6506	..I $E(IB X,1,7)=IBT DT S VAIND T=IBX D IN P^VADPT ;9 999999.999 9999
	6507	"RTN","IBT RE2",35,0)
	6508	..I VAIN( 1) W !!,"W ARNING: Th is appears to be a o ne day sta y."
	6509	"RTN","IBT RE2",36,0)
	6510	.I VAIN(1 )="" D
	6511	"RTN","IBT RE2",37,0)
	6512	..W !!,*7 ,"WARNING: Patient d oes not ap pear to be an inpati ent on thi s date!",!
	6513	"RTN","IBT RE2",38,0)
	6514	..I VAIN( 7)="" S VA IN(7)=IBTD T,Y=IBTDT D D^DIQ S $P(VAIN(7) ,"^",2)=Y
	6515	"RTN","IBT RE2",39,0)
	6516	.;
	6517	"RTN","IBT RE2",40,0)
	6518	.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
	6519	you do not wish to t rack this date."
	6520	"RTN","IBT RE2",41,0)
	6521	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Admissi on Date
	6522	"_$P(VAIN( 7),"^",2), DIR("B")=" NO"
	6523	"RTN","IBT RE2",42,0)
	6524	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	6525	"RTN","IBT RE2",43,0)
	6526	.I VAIN(1 ) D ADM^IB TUTL(VAIN( 1))
	6527	"RTN","IBT RE2",44,0)
	6528	.I 'VAIN( 1) D OTH^I BTUTL(DFN, IBETYP,IBT DT)
	6529	"RTN","IBT RE2",45,0)
	6530	.Q
	6531	"RTN","IBT RE2",46,0)
	6532	;
	6533	"RTN","IBT RE2",47,0)
	6534	OPT I IBET YP=$O(^IBE (356.6,"AC ",2,0)) D I IBQUIT G ATQ
	6535	"RTN","IBT RE2",48,0)
	6536	.;
	6537	"RTN","IBT RE2",49,0)
	6538	.N DIR,IB SD,IBARRAY
	6539	"RTN","IBT RE2",50,0)
	6540	.;get all possible scheduling data for patient
	6541	"RTN","IBT RE2",51,0)
	6542	.K ^TMP($ J,"SDAMA30 1")
	6543	"RTN","IBT RE2",52,0)
	6544	.S
	6545	IBARRAY(4) =DFN,IBARR AY("SORT") ="P",IBARR AY("FLDS") ="1;2;3;10 ;12",IBSD= $$SDAPI^SD AMA301(.IB A
	6546	RRAY)
	6547	"RTN","IBT RE2",53,0)
	6548	.;
	6549	"RTN","IBT RE2",54,0)
	6550	.S DIR("? ")="Time i s Required ."
	6551	"RTN","IBT RE2",55,0)
	6552	.S DIR("? ",1)=" Enter the Outpatient Visit Dat e."
	6553	"RTN","IBT RE2",56,0)
	6554	.S DIR("? ",2)=" If no sche duled visi t is found you will be given a warning. Enter"
	6555	"RTN","IBT RE2",57,0)
	6556	.S DIR("? ",3)=" '??' to ge t a list o f schedule d visits b etween "_$ $DAT1^IBOU TL(IBTBDT) _" and
	6557	"_$$DAT1^I BOUTL(IBTE DT)_"."
	6558	"RTN","IBT RE2",58,0)
	6559	.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."
	6560	"RTN","IBT RE2",59,0)
	6561	.S DIR("? ?")="^D LI STO^IBTRE2 0"
	6562	"RTN","IBT RE2",60,0)
	6563	.S DIR(0) ="DO^::AEX TP",DIR("A ")="Outpat ient Visit Date"
	6564	"RTN","IBT RE2",61,0)
	6565	.D ^DIR K DIR S IBT DT=Y
	6566	"RTN","IBT RE2",62,0)
	6567	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	6568	"RTN","IBT RE2",63,0)
	6569	.;
	6570	"RTN","IBT RE2",64,0)
	6571	.; check scheduling and encou nters file for entri es
	6572	"RTN","IBT RE2",65,0)
	6573	.S X=$D(^ TMP($J,"SD AMA301",DF N,IBTDT))
	6574	"RTN","IBT RE2",66,0)
	6575	.;
	6576	"RTN","IBT RE2",67,0)
	6577	.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
	6578	S IBX=$O(^ TMP($J,""S DAMA301"", IBX)) W !? 5,IBX,?10, $G(^(IBX)) "
	6579	"RTN","IBT RE2",68,0)
	6580	.;
	6581	"RTN","IBT RE2",69,0)
	6582	.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
	6583	"RTN","IBT RE2",70,0)
	6584	.;
	6585	"RTN","IBT RE2",71,0)
	6586	.; if non say so
	6587	"RTN","IBT RE2",72,0)
	6588	.I 'X,IBS D'=-1 W !! ,*7,"WARNI NG: No Vis it informa tion for t his Patien t for this date.",!
	6589	"RTN","IBT RE2",73,0)
	6590	.;
	6591	"RTN","IBT RE2",74,0)
	6592	.; ask if okay to a dd entry.
	6593	"RTN","IBT RE2",75,0)
	6594	.S Y=IBTD T D D^DIQ S IBTDTE=Y
	6595	"RTN","IBT RE2",76,0)
	6596	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Visit D ate "_IBTD TE,DIR("B" )="NO"
	6597	"RTN","IBT RE2",77,0)
	6598	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	6599	"RTN","IBT RE2",78,0)
	6600	.D OPT^IB TUTL1(DFN, IBETYP,IBT DT,$P($G(^ TMP($J,"SD AMA301",DF N,IBTDT)), "^",12))
	6601	"RTN","IBT RE2",79,0)
	6602	.K ^TMP($ J,"SDAMA30 1")
	6603	"RTN","IBT RE2",80,0)
	6604	.Q
	6605	"RTN","IBT RE2",81,0)
	6606	;
	6607	"RTN","IBT RE2",82,0)
	6608	SCH I IBET YP=$O(^IBE (356.6,"AC ",5,0)) D I IBQUIT G ATQ
	6609	"RTN","IBT RE2",83,0)
	6610	.N DIR
	6611	"RTN","IBT RE2",84,0)
	6612	.S DIR("? ")=" "
	6613	"RTN","IBT RE2",85,0)
	6614	.S DIR("? ",1)=" Enter date of the sc heduled ad mission."
	6615	"RTN","IBT RE2",86,0)
	6616	.S DIR("? ",2)=" If you use the sched uled admis sion packa ge to sche dule admis sions"
	6617	"RTN","IBT RE2",87,0)
	6618	.S DIR("? ",3)=" you may en ter '??' t o get a li st of sche duled admi ssions bet ween"
	6619	"RTN","IBT RE2",88,0)
	6620	.S DIR("? ",4)=" "_$$DAT1^I BOUTL(IBTB DT)_" and "_$$DAT1^I BOUTL(IBTE DT)_". Us e the chan ge date
	6621	range acti on"
	6622	"RTN","IBT RE2",89,0)
	6623	.S DIR("? ",5)=" to change listing of scheduled admission s."
	6624	"RTN","IBT RE2",90,0)
	6625	.S DIR("? ",5)=" This shoul d be a fut ure schedu led admiss ion."
	6626	"RTN","IBT RE2",91,0)
	6627	.S DIR(0) ="DO^::AEX T",DIR("A" )="Schedul ed Admissi on Date"
	6628	"RTN","IBT RE2",92,0)
	6629	.S DIR("? ?")="^D LI STS^IBTRE2 0"
	6630	"RTN","IBT RE2",93,0)
	6631	.D ^DIR K DIR S IBT DT=+Y
	6632	"RTN","IBT RE2",94,0)
	6633	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	6634	"RTN","IBT RE2",95,0)
	6635	.; ask if okay to a dd entry.
	6636	"RTN","IBT RE2",96,0)
	6637	.D FINDS^ IBTRE20
	6638	"RTN","IBT RE2",97,0)
	6639	.S Y=IBTD T D D^DIQ S IBTDTE=Y
	6640	"RTN","IBT RE2",98,0)
	6641	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Schedul ed Adm. Da te
	6642	"_IBTDTE,D IR("B")="N O"
	6643	"RTN","IBT RE2",99,0)
	6644	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	6645	"RTN","IBT RE2",100,0 )
	6646	.I IBTDT\ 1'>DT S VA INDT=IBTDT \1+.24 D I NP^VADPT I $G(VAIN(1 )) D Q
	6647	"RTN","IBT RE2",101,0 )
	6648	..W !!,"P atient an inpatient on this da te, using inpatient admission. "
	6649	"RTN","IBT RE2",102,0 )
	6650	..D ADM^I BTUTL(VAIN (1))
	6651	"RTN","IBT RE2",103,0 )
	6652	.D SCH^IB TUTL2(DFN, IBTDT)
	6653	"RTN","IBT RE2",104,0 )
	6654	.Q
	6655	"RTN","IBT RE2",105,0 )
	6656	;
	6657	"RTN","IBT RE2",106,0 )
	6658	PRO I IBET YP=$O(^IBE (356.6,"AC ",3,0)) D I IBQUIT G ATQ
	6659	"RTN","IBT RE2",107,0 )
	6660	.;
	6661	"RTN","IBT RE2",108,0 )
	6662	.N DIR,IB SD,IBARRAY ,C,IBDEL,I BDELO,IBMA RK
	6663	"RTN","IBT RE2",109,0 )
	6664	.;get all possible scheduling data for patient
	6665	"RTN","IBT RE2",110,0 )
	6666	.S IBARRA Y(0)=DFN
	6667	"RTN","IBT RE2",111,0 )
	6668	.;
	6669	"RTN","IBT RE2",112,0 )
	6670	.D LISTP^ IBTRE20
	6671	"RTN","IBT RE2",113,0 )
	6672	.W !
	6673	"RTN","IBT RE2",114,0 )
	6674	.I C=0 S IBQUIT=1 Q
	6675	"RTN","IBT RE2",115,0 )
	6676	.S DIR("? ")="Prosth etics"
	6677	"RTN","IBT RE2",116,0 )
	6678	.S DIR(0) ="N",DIR(" A")="Prost hetics Ent ry"
	6679	"RTN","IBT RE2",117,0 )
	6680	.D ^DIR K DIR
	6681	"RTN","IBT RE2",118,0 )
	6682	.I $D(DIR UT) S IBQU IT=1 Q
	6683	"RTN","IBT RE2",119,0 )
	6684	.I Y>0 S
	6685	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,
	6686	5)
	6687	"RTN","IBT RE2",120,0 )
	6688	.;
	6689	"RTN","IBT RE2",121,0 )
	6690	.; ask if okay to a dd entry.
	6691	"RTN","IBT RE2",122,0 )
	6692	.S Y=IBDE L D D^DIQ S IBTDTE=Y
	6693	"RTN","IBT RE2",123,0 )
	6694	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Prosthe tics "_IBP RO_" for
	6695	"_IBDELO,D IR("B")="N O"
	6696	"RTN","IBT RE2",124,0 )
	6697	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	6698	"RTN","IBT RE2",125,0 )
	6699	.S PCOV=$ $PTCOV^IBC NSU3(DFN,I BDEL,"PROS THETICS")
	6700	"RTN","IBT RE2",126,0 )
	6701	.S IBMARK ="" I 'PCO V S IBMARK ="NO PROST HETIC COVE RAGE"
	6702	"RTN","IBT RE2",127,0 )
	6703	.D PRO^IB TUTL1(DFN, IBDEL,PIEN ,IBMARK)
	6704	"RTN","IBT RE2",128,0 )
	6705	.Q
	6706	"RTN","IBT RE2",129,0 )
	6707	;
	6708	"RTN","IBT RE2",130,0 )
	6709	I $G(IBQU IT) G ATQ
	6710	"RTN","IBT RE2",131,0 )
	6711	I $D(IBTA SS) Q ; l eave prema turely if from assig n reason
	6712	"RTN","IBT RE2",132,0 )
	6713	;
	6714	"RTN","IBT RE2",133,0 )
	6715	I $G(IBTR N) N IBTAT RK S IBTAT RK=1 D QE1 ^IBTRE1
	6716	"RTN","IBT RE2",134,0 )
	6717	;
	6718	"RTN","IBT RE2",135,0 )
	6719	D BLD^IBT RE
	6720	"RTN","IBT RE2",136,0 )
	6721	;
	6722	"RTN","IBT RE2",137,0 )
	6723	ATQ Q:$D(I BTASS)
	6724	"RTN","IBT RE2",138,0 )
	6725	I $G(IBQU IT) W !,"N othing Add ed",! D PA USE^VALM1
	6726	"RTN","IBT RE2",139,0 )
	6727	S VALMBCK ="R"
	6728	"RTN","IBT RE2",140,0 )
	6729	Q
	6730	"RTN","IBT RE20")
	6731	0^4^B20324 155^B13573 861
	6732	"RTN","IBT RE20",1,0)
	6733	IBTRE20 ;A LB/AAS - C LAIMS TRAC KING EXECU TABLE HELP ;13-OCT-9 3
	6734	"RTN","IBT RE20",2,0)
	6735	;;2.0;INT EGRATED BI LLING;40 ,91,249,56 8;21-MAR -94;Build 40
	6736	"RTN","IBT RE20",3,0)
	6737	;;Per VA Directive 6402, this routine s hould not be modifie d.
	6738	"RTN","IBT RE20",4,0)
	6739	;
	6740	"RTN","IBT RE20",5,0)
	6741	;
	6742	"RTN","IBT RE20",6,0)
	6743	LISTA ; -- list inpa tient admi ssions for patient
	6744	"RTN","IBT RE20",7,0)
	6745	N C,I,J,N ,X,Y,IBX
	6746	"RTN","IBT RE20",8,0)
	6747	K ^TMP("I BM",$J)
	6748	"RTN","IBT RE20",9,0)
	6749	Q:'$D(DFN )
	6750	"RTN","IBT RE20",10,0 )
	6751	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
	6752	D=^(0),C=C +1,^TMP("I BM",$J,C)= N_"^"_D
	6753	"RTN","IBT RE20",11,0 )
	6754	;
	6755	"RTN","IBT RE20",12,0 )
	6756	I C=0 W ! !,"No Admi ssions to Choose Fro m." Q
	6757	"RTN","IBT RE20",13,0 )
	6758	;
	6759	"RTN","IBT RE20",14,0 )
	6760	W !!,"CHO OSE FROM:" F IBI=1:1 :10 Q:'$D( ^TMP("IBM" ,$J,IBI)) D WRA
	6761	"RTN","IBT RE20",15,0 )
	6762	K ^TMP("I BM",$J)
	6763	"RTN","IBT RE20",16,0 )
	6764	Q
	6765	"RTN","IBT RE20",17,0 )
	6766	;
	6767	"RTN","IBT RE20",18,0 )
	6768	WRA S IBX= $P(^TMP("I BM",$J,IBI ),"^",2,20 ),Y=+IBX X ^DD("DD")
	6769	"RTN","IBT RE20",19,0 )
	6770	W !," ",Y
	6771	"RTN","IBT RE20",20,0 )
	6772	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))
	6773	"RTN","IBT RE20",21,0 )
	6774	;
	6775	"RTN","IBT RE20",22,0 )
	6776	W ?50,"TO : ",$E($P ($G(^DIC(4 2,+$P(IBX, "^",6),0)) ,"^"),1,17 )
	6777	"RTN","IBT RE20",23,0 )
	6778	I $D(^DG( 405.4,+$P( IBX,"^",7) ,0)) W " [ ",$E($P(^( 0),"^",1), 1,10),"]"
	6779	"RTN","IBT RE20",24,0 )
	6780	I $P(IBX, "^",18)=9 W !?23,"FR OM: ",$P( $G(^DIC(4, +$P(IBX,"^ ",5),0))," ^")
	6781	"RTN","IBT RE20",25,0 )
	6782	Q
	6783	"RTN","IBT RE20",26,0 )
	6784	;
	6785	"RTN","IBT RE20",27,0 )
	6786	LISTO ; -- list outp atient app ointments
	6787	"RTN","IBT RE20",28,0 )
	6788	N C,I,J,N ,X,Y,IBX,I BI,IBDT
	6789	"RTN","IBT RE20",29,0 )
	6790	; assumes ^TMP($J," SDAMA301", DFN,IBTDT) defined a nd IBSD(re sult from SD)
	6791	"RTN","IBT RE20",30,0 )
	6792	Q:'$D(DFN )
	6793	"RTN","IBT RE20",31,0 )
	6794	;
	6795	"RTN","IBT RE20",32,0 )
	6796	I IBSD<0 W !!,"Unab le to look -up Outpat ient Visit s to Choos e From." D Q
	6797	"RTN","IBT RE20",33,0 )
	6798	. N IBX F S IBX=$O (^TMP($J," SDAMA301", IBX)) Q:'I BX W !?5, IBX,?10,$G (^(IBX))
	6799	"RTN","IBT RE20",34,0 )
	6800	;
	6801	"RTN","IBT RE20",35,0 )
	6802	I IBSD=0 W !!,"No O utpatient Visits to Choose Fro m." Q
	6803	"RTN","IBT RE20",36,0 )
	6804	;
	6805	"RTN","IBT RE20",37,0 )
	6806	W !!,"CHO OSE FROM:" S IBI=0,I BDT=$G(IBT BDT) F S
	6807	IBDT=$O(^T MP($J,"SDA MA301",DFN ,IBDT)),IB I=IBI+1 Q: 'IBDT!(IBI >12) D WR O
	6808	"RTN","IBT RE20",38,0 )
	6809	Q
	6810	"RTN","IBT RE20",39,0 )
	6811	;
	6812	"RTN","IBT RE20",40,0 )
	6813	WRO N IBSD D,Y
	6814	"RTN","IBT RE20",41,0 )
	6815	S Y=IBDT X ^DD("DD" ) W !," ",Y
	6816	"RTN","IBT RE20",42,0 )
	6817	S IBSDD=$ G(^TMP($J, "SDAMA301" ,DFN,IBDT) )
	6818	"RTN","IBT RE20",43,0 )
	6819	W ?27,"Cl inic: ",$P ($P(IBSDD, "^",2),";" ,2),?60," Type: ",$E ($P($P(IBS DD,"^",10) ,";",2),1, 12)
	6820	"RTN","IBT RE20",44,0 )
	6821	;
	6822	"RTN","IBT RE20",45,0 )
	6823	S IBSDD=$ P(IBSDD,"^ ",3) I $L( IBSDD),$P( IBSDD,";") '="R" W !, ?10," [Sta tus: ",$P( IBSDD,";", 2),"]"
	6824	"RTN","IBT RE20",46,0 )
	6825	Q
	6826	"RTN","IBT RE20",47,0 )
	6827	;
	6828	"RTN","IBT RE20",48,0 )
	6829	LISTS ; -- list sche duled admi ssions
	6830	"RTN","IBT RE20",49,0 )
	6831	N C,I,J,N ,X,Y,IBX,I BI
	6832	"RTN","IBT RE20",50,0 )
	6833	K ^TMP("I BM",$J)
	6834	"RTN","IBT RE20",51,0 )
	6835	Q:'$D(DFN )
	6836	"RTN","IBT RE20",52,0 )
	6837	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
	6838	$P(D,"^",2 )'<IBTBDT, $P(D,"^",2 )'>IBTEDT S C=C+1,^T MP("IBM",$ J,C)=I_"^" _D
	6839	"RTN","IBT RE20",53,0 )
	6840	;
	6841	"RTN","IBT RE20",54,0 )
	6842	I C=0 W ! !,"No Sche duled Admi ssions to Choose Fro m." Q
	6843	"RTN","IBT RE20",55,0 )
	6844	;
	6845	"RTN","IBT RE20",56,0 )
	6846	W !!,"CHO OSE FROM:" F IBI=1:1 :12 Q:'$D( ^TMP("IBM" ,$J,IBI)) D WRS
	6847	"RTN","IBT RE20",57,0 )
	6848	K ^TMP("I BM",$J)
	6849	"RTN","IBT RE20",58,0 )
	6850	Q
	6851	"RTN","IBT RE20",59,0 )
	6852	;
	6853	"RTN","IBT RE20",60,0 )
	6854	WRS S IBX= $P($G(^TMP ("IBM",$J, IBI)),"^", 2,20),Y=$P (IBX,"^",2 ) X ^DD("D D")
	6855	"RTN","IBT RE20",61,0 )
	6856	W !," ",Y
	6857	"RTN","IBT RE20",62,0 )
	6858	W ?27," S pec: ",$E( $P($G(^DIC (45.7,+$P( IBX,"^",9) ,0)),"^"), 1,25)
	6859	"RTN","IBT RE20",63,0 )
	6860	;
	6861	"RTN","IBT RE20",64,0 )
	6862	W ?58," T o: ",$E($P ($G(^DIC(4 2,+$P(IBX, "^",8),0)) ,"^"),1,16 )
	6863	"RTN","IBT RE20",65,0 )
	6864	Q
	6865	"RTN","IBT RE20",66,0 )
	6866	;
	6867	"RTN","IBT RE20",67,0 )
	6868	FINDS ; -- match a s cheduled a dmission
	6869	"RTN","IBT RE20",68,0 )
	6870	Q:'$D(DFN )
	6871	"RTN","IBT RE20",69,0 )
	6872	Q:'$D(IBT DT)
	6873	"RTN","IBT RE20",70,0 )
	6874	N I,J
	6875	"RTN","IBT RE20",71,0 )
	6876	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
	6877	$P(IBTDT," .")=$P(J," .") S IBTD T=J Q
	6878	"RTN","IBT RE20",72,0 )
	6879	Q
	6880	"RTN","IBT RE20",73,0 )
	6881	;
	6882	"RTN","IBT RE20",74,0 )
	6883	ID ; -- wr ite out id entifier f or entry, called by ^dd(356,0, "id","writ e")
	6884	"RTN","IBT RE20",75,0 )
	6885	N IBOE,IB OE0
	6886	"RTN","IBT RE20",76,0 )
	6887	S IBOE=$P (^(0),"^", 4),IBOE0=$ $SCE^IBSDU (+IBOE) I IBOE,$P(IB OE0,U,4) W
	6888	?58,"["_$E ($P($G(^SC (+$P(IBOE0 ,U,4),0)), U),1,20)," ]"
	6889	"RTN","IBT RE20",77,0 )
	6890	Q
	6891	"RTN","IBT RE20",78,0 )
	6892	;
	6893	"RTN","IBT RE20",79,0 )
	6894	PRINT ; pa tch 40, cu stom look up. Input : IBX -- 0th node in file # 356.
	6895	"RTN","IBT RE20",80,0 )
	6896	Q:$D(IBX) [0
	6897	"RTN","IBT RE20",81,0 )
	6898	N NAM,EPI S,EVENT,DI SPL,CLIN
	6899	"RTN","IBT RE20",82,0 )
	6900	S NAM=$E( $P($G(^DPT (+$P(IBX,U ,2),0)),U) ,1,22)
	6901	"RTN","IBT RE20",83,0 )
	6902	S EPIS=$P ($P(IBX,U, 6),".")
	6903	"RTN","IBT RE20",84,0 )
	6904	I EPIS S EPIS=$E(EP IS,4,5)_"- "_$E(EPIS, 6,7)_"-"_$ E(EPIS,2,3 )
	6905	"RTN","IBT RE20",85,0 )
	6906	S EVENT=$ E($P($G(^I BE(356.6,+ $P(IBX,U,1 8),0)),U), 1,5)
	6907	"RTN","IBT RE20",86,0 )
	6908	S DISPL=$ $EXPAND^IB TRE(356,.0 7,$P(IBX,U ,7))
	6909	"RTN","IBT RE20",87,0 )
	6910	S CLIN=+$ $SCE^IBSDU (+$P(IBX," ^",4),4)
	6911	"RTN","IBT RE20",88,0 )
	6912	I CLIN S DISPL="["_ $E($P($G(^ SC(CLIN,0) ),U),1,22) _"]"
	6913	"RTN","IBT RE20",89,0 )
	6914	W ?13,NAM ,?37,EPIS, ?47,EVENT, ?54,DISPL
	6915	"RTN","IBT RE20",90,0 )
	6916	Q
	6917	"RTN","IBT RE20",91,0 )
	6918	;
	6919	"RTN","IBT RE20",92,0 )
	6920	LISTP ; -- list inpa tient admi ssions for patient
	6921	"RTN","IBT RE20",93,0 )
	6922	N I,X,Y,P ,P1,P2,DDT ,DDTO,IBX, SDT,TP,TYP E
	6923	"RTN","IBT RE20",94,0 )
	6924	K ^TMP("I BPRO",$J)
	6925	"RTN","IBT RE20",95,0 )
	6926	Q:'$D(DFN )
	6927	"RTN","IBT RE20",96,0 )
	6928	S (I,C)=0
	6929	"RTN","IBT RE20",97,0 )
	6930	F S I=$O (^RMPR(660 ,"C",DFN,I )) Q:'I I $D(^RMPR( 660,I,0)) S D=^(0) D
	6931	"RTN","IBT RE20",98,0 )
	6932	.S SDT=$P (D,U,12) I SDT<IBTBD T!(SDT>IBT EDT) Q
	6933	"RTN","IBT RE20",99,0 )
	6934	.I $O(^IB T(356,"APR O",I,0)) Q
	6935	"RTN","IBT RE20",100, 0)
	6936	.S C=C+1, ^TMP("IBPR O",$J,C)=I _"^"_D
	6937	"RTN","IBT RE20",101, 0)
	6938	;
	6939	"RTN","IBT RE20",102, 0)
	6940	I C=0 W ! !,"No Pros thetics to Choose Fr om." Q
	6941	"RTN","IBT RE20",103, 0)
	6942	;
	6943	"RTN","IBT RE20",104, 0)
	6944	W !!,"CHO OSE FROM:" F IBI=1:1 :10 Q:'$D( ^TMP("IBPR O",$J,IBI) ) D WRP
	6945	"RTN","IBT RE20",105, 0)
	6946	K ^TMP("I BPRO",$J)
	6947	"RTN","IBT RE20",106, 0)
	6948	Q
	6949	"RTN","IBT RE20",107, 0)
	6950	;
	6951	"RTN","IBT RE20",108, 0)
	6952	WRP S
	6953	IBX=$P(^TM P("IBPRO", $J,IBI),"^ ",1,20),N= $P(IBX,U,1 ),P=$P(IBX ,U,7),P1=$ P(^RMPR(66 1,P,0),U,1 ),P2=$P(
	6954	^PRC(441,P 1,0),U,2)
	6955	"RTN","IBT RE20",109, 0)
	6956	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
	6957	"RTN","IBT RE20",110, 0)
	6958	S TP=$P(I BX,U,4),TY PE=$S(TP=" I":"INITIA L
	6959	ISSUE",TP= "R":"REPLA CE",TP="S" :"SPARE",T P="X":"REP AIR",1:"RE NTAL")
	6960	"RTN","IBT RE20",111, 0)
	6961	W !," ", IBI,?10,$E (P2,1,25), ?40,TYPE,? 58,"DELIVE RED:",DDTO
	6962	"RTN","IBT RE20",112, 0)
	6963	;
	6964	"RTN","IBT RE20",113, 0)
	6965	Q
	6966	"RTN","IBT RKR5")
	6967	0^5^B38746 753^B35067 366
	6968	"RTN","IBT RKR5",1,0)
	6969	IBTRKR5 ;A LB/AAS - C LAIMS TRAC KING - ADD /TRACK PRO STHETICS ; 13-JAN-94
	6970	"RTN","IBT RKR5",2,0)
	6971	;;2.0;INT EGRATED BI LLING;13 ,260,312,3 39,389,474 ,498,568 ;21-MAR-94 ;Build 40
	6972	"RTN","IBT RKR5",3,0)
	6973	;;Per VA Directive 6402, this routine s hould not be modifie d.
	6974	"RTN","IBT RKR5",4,0)
	6975	;
	6976	"RTN","IBT RKR5",5,0)
	6977	% ; -- ent ry point f or nightly backgroun d job
	6978	"RTN","IBT RKR5",6,0)
	6979	N IBTSBDT ,IBTSEDT
	6980	"RTN","IBT RKR5",7,0)
	6981	S IBTSBDT =$$FMADD^X LFDT(DT,$S ($E(DT,6,7 )=10:-730, 1:-20))-.1 ;IB2.0 568
	6982	"RTN","IBT RKR5",8,0)
	6983	S IBTSEDT =$$FMADD^X LFDT(DT,-3 )+.9
	6984	"RTN","IBT RKR5",9,0)
	6985	D EN1
	6986	"RTN","IBT RKR5",10,0 )
	6987	Q
	6988	"RTN","IBT RKR5",11,0 )
	6989	;
	6990	"RTN","IBT RKR5",12,0 )
	6991	EN ; -- en try point to ask dat e range
	6992	"RTN","IBT RKR5",13,0 )
	6993	N IBSWINF O S IBSWIN FO=$$SWSTA T^IBBAPI() ; IB2.0312
	6994	"RTN","IBT RKR5",14,0 )
	6995	N IBBDT,I BEDT,IBTSB DT,IBTSEDT ,IBTALK
	6996	"RTN","IBT RKR5",15,0 )
	6997	S IBTALK= 1
	6998	"RTN","IBT RKR5",16,0 )
	6999	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
	7000	"RTN","IBT RKR5",17,0 )
	7001	W !!!,"Se lect the D ate Range of Prosthe tics to Ad d to Claim s Tracking .",!
	7002	"RTN","IBT RKR5",18,0 )
	7003	D DATE^IB OUTL
	7004	"RTN","IBT RKR5",19,0 )
	7005	I IBBDT<1 !(IBEDT<1) G ENQ
	7006	"RTN","IBT RKR5",20,0 )
	7007	S IBTSBDT =IBBDT,IBT SEDT=IBEDT
	7008	"RTN","IBT RKR5",21,0 )
	7009	;
	7010	"RTN","IBT RKR5",22,0 )
	7011	; -- chec k selected dates ; IB2.0312
	7012	"RTN","IBT RKR5",23,0 )
	7013	; Do NOT PROCESS on VistA if Start or E nd>=Switch Eff Dt ; CCR-930
	7014	"RTN","IBT RKR5",24,0 )
	7015	I +IBSWIN FO,((IBTSB DT+1)>$P(I BSWINFO,"^ ",2))!((IB TSEDT+1)>$ P(IBSWINFO ,"^",2)) D G EN
	7016	"RTN","IBT RKR5",25,0 )
	7017	.W !!,"T he Begin O R End Date CANNOT be on or aft er the PFS S Effectiv e date"
	7018	"RTN","IBT RKR5",26,0 )
	7019	.W ": ", $$FMTE^XLF DT($P(IBSW INFO,"^",2 ))
	7020	"RTN","IBT RKR5",27,0 )
	7021	;
	7022	"RTN","IBT RKR5",28,0 )
	7023	S IBTRKR= $G(^IBE(35 0.9,1,6))
	7024	"RTN","IBT RKR5",29,0 )
	7025	; start d ate can't be before parameters
	7026	"RTN","IBT RKR5",30,0 )
	7027	I +IBTRKR ,IBTSBDT<+ IBTRKR S I BTSBDT=IBT RKR W !!," Begin date is before Claims Tr acking Sta rt Date,
	7028	changed to ",$$DAT1^ IBOUTL(IBT SBDT)
	7029	"RTN","IBT RKR5",31,0 )
	7030	; -- end date into future
	7031	"RTN","IBT RKR5",32,0 )
	7032	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
	7033	date queue d to run."
	7034	"RTN","IBT RKR5",33,0 )
	7035	;
	7036	"RTN","IBT RKR5",34,0 )
	7037	W !!,"Thi s should b e queued t o run afte r hours"
	7038	"RTN","IBT RKR5",35,0 )
	7039	W !!!,"I' m going to automatic ally queue this off and send y ou a"
	7040	"RTN","IBT RKR5",36,0 )
	7041	W !,"mail message w hen comple te.",!
	7042	"RTN","IBT RKR5",37,0 )
	7043	S ZTIO="" ,ZTRTN="EN 1^IBTRKR5" ,ZTSAVE("I B*")="",ZT DESC="IB - Add Prost hetics to Claims Tra cking"
	7044	"RTN","IBT RKR5",38,0 )
	7045	D ^%ZTLOA D I $G(ZTS K) K ZTSK W !,"Reque st Queued"
	7046	"RTN","IBT RKR5",39,0 )
	7047	ENQ K ZTSK ,ZTIO,ZTSA VE,ZTDESC, ZTRTN
	7048	"RTN","IBT RKR5",40,0 )
	7049	D HOME^%Z IS
	7050	"RTN","IBT RKR5",41,0 )
	7051	Q
	7052	"RTN","IBT RKR5",42,0 )
	7053	;
	7054	"RTN","IBT RKR5",43,0 )
	7055	EN1 ; -- a dd prostet hics to cl aims track ing file
	7056	"RTN","IBT RKR5",44,0 )
	7057	N I,J,X,Y ,IBTRKR,IB DT,DFN,IBD ATA,IBCNT, IBCNT1,IBC NT2,IBDTS, PROCOV
	7058	"RTN","IBT RKR5",45,0 )
	7059	N IBSWINF O S IBSWIN FO=$$SWSTA T^IBBAPI() ; IB2.0312
	7060	"RTN","IBT RKR5",46,0 )
	7061	;
	7062	"RTN","IBT RKR5",47,0 )
	7063	; -- chec k paramete rs
	7064	"RTN","IBT RKR5",48,0 )
	7065	S IBTRKR= $G(^IBE(35 0.9,1,6))
	7066	"RTN","IBT RKR5",49,0 )
	7067	G:'$P(IBT RKR,"^",5) EN1Q ; qu it if prot hetics tra cking off
	7068	"RTN","IBT RKR5",50,0 )
	7069	I +IBTRKR ,IBTSBDT<+ IBTRKR S I BTSBDT=IBT RKR ; star t date can 't be befo re paramet ers
	7070	"RTN","IBT RKR5",51,0 )
	7071	;
	7072	"RTN","IBT RKR5",52,0 )
	7073	; -- user s can queu e into fut ure, make sure dates not after date run
	7074	"RTN","IBT RKR5",53,0 )
	7075	I IBTSEDT >$$FMADD^X LFDT(DT,-3 ) S IBMESS ="(Selecte d end date of "_$$DA T1^IBOUTL( IBTSEDT)_"
	7076	automatica lly change d to "_$$D AT1^IBOUTL ($$FMADD^X LFDT(DT,-
	7077	3))_".)",I BTSEDT=$$F MADD^XLFDT (DT,-3)
	7078	"RTN","IBT RKR5",54,0 )
	7079	;
	7080	"RTN","IBT RKR5",55,0 )
	7081	;S IBPRTY P=$O(^IBE( 356.6,"AC" ,3,0)) ; t his is the event typ e pointer for prosth etics
	7082	"RTN","IBT RKR5",56,0 )
	7083	;
	7084	"RTN","IBT RKR5",57,0 )
	7085	; -- cnt= total cou nt, cnt1=c ount added nsc, cnt2 =count of pending
	7086	"RTN","IBT RKR5",58,0 )
	7087	S (IBCNT, IBCNT1,IBC NT2)=0
	7088	"RTN","IBT RKR5",59,0 )
	7089	S (IBDTS, IBDT)=IBTS BDT-.0001
	7090	"RTN","IBT RKR5",60,0 )
	7091	;
	7092	"RTN","IBT RKR5",61,0 )
	7093	; loop tw ice, once for shipmn et date (n ew search) , and once for
	7094	"RTN","IBT RKR5",62,0 )
	7095	; deliver y date (ol d search) for backwa rd compati bility.
	7096	"RTN","IBT RKR5",63,0 )
	7097	F S IBDT =$O(^RMPR( 660,"AF",I BDT)) Q:'I BDT!(IBDT> IBTSEDT) D
	7098	"RTN","IBT RKR5",64,0 )
	7099	.; Do NOT PROCES S on VistA if IBDT>= Switch Eff Date ; CCR-930
	7100	"RTN","IBT RKR5",65,0 )
	7101	.I +IB SWINFO,(IB DT+1)>$P(I BSWINFO,"^ ",2) Q ; IB2.0312
	7102	"RTN","IBT RKR5",66,0 )
	7103	.S IBD A=0 F S I BDA=$O(^RM PR(660,"AF ",IBDT,IBD A)) Q:'IBD A D PRCHK
	7104	"RTN","IBT RKR5",67,0 )
	7105	;
	7106	"RTN","IBT RKR5",68,0 )
	7107	; reset d ate and do old check
	7108	"RTN","IBT RKR5",69,0 )
	7109	S IBDT=IB DTS
	7110	"RTN","IBT RKR5",70,0 )
	7111	F S IBDT =$O(^RMPR( 660,"CT",I BDT)) Q:'I BDT!(IBDT> IBTSEDT) D
	7112	"RTN","IBT RKR5",71,0 )
	7113	.; Do NOT PROCES S on VistA if IBDT>= Switch Eff Date ; CCR-930
	7114	"RTN","IBT RKR5",72,0 )
	7115	.I +IB SWINFO,(IB DT+1)>$P(I BSWINFO,"^ ",2) Q ; IB2.0312
	7116	"RTN","IBT RKR5",73,0 )
	7117	.S IBD A="" F S IBDA=$O(^R MPR(660,"C T",IBDT,IB DA)) Q:'IB DA D PRCH K
	7118	"RTN","IBT RKR5",74,0 )
	7119	;
	7120	"RTN","IBT RKR5",75,0 )
	7121	I $G(IBTA LK) D BULL ;^IBTRKR5 1
	7122	"RTN","IBT RKR5",76,0 )
	7123	EN1Q I $D( ZTQUEUED) S ZTREQ="@ "
	7124	"RTN","IBT RKR5",77,0 )
	7125	Q
	7126	"RTN","IBT RKR5",78,0 )
	7127	;
	7128	"RTN","IBT RKR5",79,0 )
	7129	PRCHK ; -- check and add item
	7130	"RTN","IBT RKR5",80,0 )
	7131	N IBE,IBP ,IBDX,IBRM ARK,IBARR, IBT,IBINS
	7132	"RTN","IBT RKR5",81,0 )
	7133	S IBCNT=I BCNT+1,IBR MARK=""
	7134	"RTN","IBT RKR5",82,0 )
	7135	I '$D(ZTQ UEUED),($G (IBTALK)) W "."
	7136	"RTN","IBT RKR5",83,0 )
	7137	;
	7138	"RTN","IBT RKR5",84,0 )
	7139	S IBDATA= $G(^RMPR(6 60,+IBDA,0 )) Q:IBDAT A=""
	7140	"RTN","IBT RKR5",85,0 )
	7141	S DFN=$P( IBDATA,"^" ,2) Q:'DFN
	7142	"RTN","IBT RKR5",86,0 )
	7143	; quit if non billa ble PSAS H CPCS code is found
	7144	"RTN","IBT RKR5",87,0 )
	7145	I $$IBPHP (IBDA) Q
	7146	"RTN","IBT RKR5",88,0 )
	7147	D CL^SDCO 21(DFN,IBD T,"",.IBAR R)
	7148	"RTN","IBT RKR5",89,0 )
	7149	;
	7150	"RTN","IBT RKR5",90,0 )
	7151	; -- chec ks copied from rmprb il v2.0 /f eb 2, 1994
	7152	"RTN","IBT RKR5",91,0 )
	7153	Q:'$D(^RM PR(660,+IB DA,"AM"))
	7154	"RTN","IBT RKR5",92,0 )
	7155
	7156	Q:$P(^RMPR (660,+IBDA ,0),U,9)=" "!($P(^(0) ,U,12)="") !($P(^(0), U,14)="V") !($P(^(0), U,2)="")!( $P(^(0),U, 1
	7157	5)="*")
	7158	"RTN","IBT RKR5",93,0 )
	7159	;Q:($P(^R MPR(660,+I BDA,"AM"), U,3)=2)!($ P(^("AM"), U,3)=3)
	7160	"RTN","IBT RKR5",94,0 )
	7161	;
	7162	"RTN","IBT RKR5",95,0 )
	7163	;
	7164	"RTN","IBT RKR5",96,0 )
	7165	I $O(^IBT (356,"APRO ",IBDA,0)) G PRCHKQ ; already in claims tracking
	7166	"RTN","IBT RKR5",97,0 )
	7167	;
	7168	"RTN","IBT RKR5",98,0 )
	7169	; -- see if trackin g only ins ured and p t is insur ed
	7170	"RTN","IBT RKR5",99,0 )
	7171	I $P(IBTR KR,"^",5)= 1,'$$INSUR ED^IBCNS1( DFN,IBDT) G PRCHKQ ; patient n ot insured
	7172	"RTN","IBT RKR5",100, 0)
	7173	;
	7174	"RTN","IBT RKR5",101, 0)
	7175	; -- if c lasificati ons requir ed, check exemptions
	7176	"RTN","IBT RKR5",102, 0)
	7177	;IB2.05 68
	7178	"RTN","IBT RKR5",103, 0)
	7179	N IBSC,SC P,SCR,SUB
	7180	"RTN","IBT RKR5",104, 0)
	7181	S SCR=0
	7182	"RTN","IBT RKR5",105, 0)
	7183	I '$D(IBA RR) G CLQ
	7184	"RTN","IBT RKR5",106, 0)
	7185	F IBP=1:1 :4 S IBDX( IBP)=$G(^R MPR(660,+I BDA,"BA"_I BP)) D
	7186	"RTN","IBT RKR5",107, 0)
	7187	.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
	7188	"RTN","IBT RKR5",108, 0)
	7189	I 'SCR S IBRMARK="N EEDS SC DE TERMINATIO N" G CLQ ; no ICD no de in RMPR , use old method of
	7190	determinin g status
	7191	"RTN","IBT RKR5",109, 0)
	7192	S IBRMARK =""
	7193	"RTN","IBT RKR5",110, 0)
	7194	S IBE=0 F S IBE=$O (IBARR(IBE )) Q:'IBE D Q:($L( $G(IBRMARK )))
	7195	"RTN","IBT RKR5",111, 0)
	7196	.F IBP=1: 1:4 Q:$L($ G(IBRMARK) ) D
	7197	"RTN","IBT RKR5",112, 0)
	7198	..S (SUB, REC)="" I IBSC(IBP) S SUB="CL" _IBSC(IBP) ,REC=$T(@S UB)
	7199	"RTN","IBT RKR5",113, 0)
	7200	..S IBRMA RK=$S(REC' ="":$P(REC ,";",3),1: "NEEDS SC DETERMINAT ION")
	7201	"RTN","IBT RKR5",114, 0)
	7202	;
	7203	"RTN","IBT RKR5",115, 0)
	7204	;
	7205	"RTN","IBT RKR5",116, 0)
	7206	CLQ ; -- o k to add t o tracking module
	7207	"RTN","IBT RKR5",117, 0)
	7208	S PROCOV= 0,SCR=+$G( SCR)
	7209	"RTN","IBT RKR5",118, 0)
	7210	S PROCOV= +$$PTCOV^I BCNSU3(DFN ,IBDT,"PRO STHETICS")
	7211	"RTN","IBT RKR5",119, 0)
	7212	I 'PROCOV ,IBRMARK=" NEEDS SC D ETERMINATI ON" S IBRM ARK="NO PR OSTHETIC C OVERAGE"
	7213	"RTN","IBT RKR5",120, 0)
	7214	I 'PROCOV ,IBRMARK=" " S IBRMAR K="NO PROS THETIC COV ERAGE"
	7215	"RTN","IBT RKR5",121, 0)
	7216	D PRO^IBT UTL1(DFN,I BDT,IBDA,$ G(IBRMARK) ) I '$D(ZT QUEUED),$G (IBTALK) W "+"
	7217	"RTN","IBT RKR5",122, 0)
	7218	I SCR=1 S IBCNT2=IB CNT2+1
	7219	"RTN","IBT RKR5",123, 0)
	7220	I SCR=0 S IBCNT1=IB CNT1+1
	7221	"RTN","IBT RKR5",124, 0)
	7222	K VAEL,VA ,IBDATA,DF N,X,Y
	7223	"RTN","IBT RKR5",125, 0)
	7224	PRCHKQ Q
	7225	"RTN","IBT RKR5",126, 0)
	7226	;
	7227	"RTN","IBT RKR5",127, 0)
	7228	IBPHP(IBDA ) ; non bi llable PSA S HCPCS co des
	7229	"RTN","IBT RKR5",128, 0)
	7230	; input-p atient ite m in #660
	7231	"RTN","IBT RKR5",129, 0)
	7232	; output- value if t he code wi th the fir st 2 chars in the st ring is fo und
	7233	"RTN","IBT RKR5",130, 0)
	7234	N IBPSAS, IBPIN S IB PIN=""
	7235	"RTN","IBT RKR5",131, 0)
	7236	S IBPSAS= ",BA,DI,DL ,EC,EV,FE, HI,HN,HS,N R,RE,SB,SI ,TH,TM,TR, VA,"
	7237	"RTN","IBT RKR5",132, 0)
	7238	; return the pointe r^descript ion^the co de (#661.1 ,.01)
	7239	"RTN","IBT RKR5",133, 0)
	7240	S IBPIN=$ $PIN^IBATU TL(+IBDA)
	7241	"RTN","IBT RKR5",134, 0)
	7242	S IBPIN=$ P(IBPIN,U, 3)
	7243	"RTN","IBT RKR5",135, 0)
	7244	S IBPIN=$ F(IBPSAS," ,"_$E(IBPI N,1,2)_"," )
	7245	"RTN","IBT RKR5",136, 0)
	7246	Q IBPIN
	7247	"RTN","IBT RKR5",137, 0)
	7248	;
	7249	"RTN","IBT RKR5",138, 0)
	7250	BULL ; -- send bulle tin
	7251	"RTN","IBT RKR5",139, 0)
	7252	;
	7253	"RTN","IBT RKR5",140, 0)
	7254	S XMSUB=" Prosthetic Items add ed to Clai ms Trackin g Complete "
	7255	"RTN","IBT RKR5",141, 0)
	7256	S IBT(1)= "The proce ss to auto matically add Prosth etic Items has succe ssfully co mpleted."
	7257	"RTN","IBT RKR5",142, 0)
	7258	S IBT(1.1 )=""
	7259	"RTN","IBT RKR5",143, 0)
	7260	S IBT(2)= " Start D ate: "_$$D AT1^IBOUTL (IBTSBDT)
	7261	"RTN","IBT RKR5",144, 0)
	7262	S IBT(3)= " End D ate: "_$$D AT1^IBOUTL (IBTSEDT)
	7263	"RTN","IBT RKR5",145, 0)
	7264	I $D(IBME SS) S IBT( 3.1)=IBMES S
	7265	"RTN","IBT RKR5",146, 0)
	7266	S IBT(4)= ""
	7267	"RTN","IBT RKR5",147, 0)
	7268	S IBT(5)= " Total Pr osthetics Items chec ked: "_$G( IBCNT)
	7269	"RTN","IBT RKR5",148, 0)
	7270	S IBT(6)= "Total NSC Prostheti c Items Ad ded: "_$G( IBCNT1)
	7271	"RTN","IBT RKR5",149, 0)
	7272	S IBT(7)= " Total SC Prostheti c Items Ad ded: "_$G( IBCNT2)
	7273	"RTN","IBT RKR5",150, 0)
	7274	S IBT(8)= ""
	7275	"RTN","IBT RKR5",151, 0)
	7276	S IBT(9)= "*The item s added as SC requir e determin ation and editing to be billed "
	7277	"RTN","IBT RKR5",152, 0)
	7278	D SEND^IB TRKR31
	7279	"RTN","IBT RKR5",153, 0)
	7280	BULLQ Q
	7281	"RTN","IBT RKR5",154, 0)
	7282	;
	7283	"RTN","IBT RKR5",155, 0)
	7284	CLTXT ; cl assificati on text fo r reason n ot billabl e
	7285	"RTN","IBT RKR5",156, 0)
	7286	CL2 ;;AGEN T ORANGE
	7287	"RTN","IBT RKR5",157, 0)
	7288	CL3 ;;IONI ZING RADIA TION
	7289	"RTN","IBT RKR5",158, 0)
	7290	CL4 ;;SC T REATMENT
	7291	"RTN","IBT RKR5",159, 0)
	7292	CL5 ;;SOUT HWEST ASIA
	7293	"RTN","IBT RKR5",160, 0)
	7294	CL6 ;;MILI TARY SEXUA L TRAUMA
	7295	"RTN","IBT RKR5",161, 0)
	7296	CL7 ;;HEAD /NECK CANC ER
	7297	"RTN","IBT RKR5",162, 0)
	7298	CL8 ;;COMB AT VETERAN
	7299	"RTN","IBY 568PO")
	7300	0^^B780221 44^n/a
	7301	"RTN","IBY 568PO",1,0 )
	7302	IBY568PO ; ALB/BAA - Post insta ll routine for patch 568; 5-AU G-16
	7303	"RTN","IBY 568PO",2,0 )
	7304	;;2.0;INT EGRATED BI LLING;56 8;21-MAR -94;Build 40
	7305	"RTN","IBY 568PO",3,0 )
	7306	;;Per VA Directive 6402, this routine s hould not be modifie d.
	7307	"RTN","IBY 568PO",4,0 )
	7308	;
	7309	"RTN","IBY 568PO",5,0 )
	7310	Q
	7311	"RTN","IBY 568PO",6,0 )
	7312	; This po st-install routine w ill create a new sec urity key
	7313	"RTN","IBY 568PO",7,0 )
	7314	; called IB PARAMET ER EDIT.
	7315	"RTN","IBY 568PO",8,0 )
	7316	; It will be added to two men u options/
	7317	"RTN","IBY 568PO",9,0 )
	7318	;
	7319	"RTN","IBY 568PO",10, 0)
	7320	; The new IB PARAME TER EDIT k ey will be used to l ock
	7321	"RTN","IBY 568PO",11, 0)
	7322	;
	7323	"RTN","IBY 568PO",12, 0)
	7324	; IB T EDIT TRA CKING PARA METERS
	7325	"RTN","IBY 568PO",13, 0)
	7326	; IB J MCCR SIT E PARAMETE RS
	7327	"RTN","IBY 568PO",14, 0)
	7328	;
	7329	"RTN","IBY 568PO",15, 0)
	7330	; This ro utine will add PROST HETICS to Plan Cover age Limita tions file
	7331	"RTN","IBY 568PO",16, 0)
	7332	;
	7333	"RTN","IBY 568PO",17, 0)
	7334	; This ro utine will add three new rate types and the rate s cheduals f or each.
	7335	"RTN","IBY 568PO",18, 0)
	7336	;
	7337	"RTN","IBY 568PO",19, 0)
	7338	; HU MANITARIAN REIMB. IN S.
	7339	"RTN","IBY 568PO",20, 0)
	7340	; IN ELIGIBLE R EIMB. INS.
	7341	"RTN","IBY 568PO",21, 0)
	7342	; DE NTAL REIMB . INS
	7343	"RTN","IBY 568PO",22, 0)
	7344	;
	7345	"RTN","IBY 568PO",23, 0)
	7346	;
	7347	"RTN","IBY 568PO",24, 0)
	7348	START ; CA LL SECTION S
	7349	"RTN","IBY 568PO",25, 0)
	7350	D MES^XPD UTL(" Sta rting post -install f or IB2.0 568")
	7351	"RTN","IBY 568PO",26, 0)
	7352	D RIDER
	7353	"RTN","IBY 568PO",27, 0)
	7354	D PLAN
	7355	"RTN","IBY 568PO",28, 0)
	7356	D ADDRT
	7357	"RTN","IBY 568PO",29, 0)
	7358	D ADDRS ; add Rate Schedules (363)
	7359	"RTN","IBY 568PO",30, 0)
	7360	D NEWIBER
	7361	"RTN","IBY 568PO",31, 0)
	7362	; Complet ion messag e
	7363	"RTN","IBY 568PO",32, 0)
	7364	D MES^XPD UTL(" Fin ished post -install f or IB2.0 568")
	7365	"RTN","IBY 568PO",33, 0)
	7366	Q
	7367	"RTN","IBY 568PO",34, 0)
	7368	;
	7369	"RTN","IBY 568PO",35, 0)
	7370	RIDER ; ad d Prostihe tic Insura nce Rider (355.6)
	7371	"RTN","IBY 568PO",36, 0)
	7372	N IBNAME, DD,DO,DLAY GO,DIC,X,Y ,IBDA,IBAR R,IBX
	7373	"RTN","IBY 568PO",37, 0)
	7374	D MES^XPD UTL(" ")
	7375	"RTN","IBY 568PO",38, 0)
	7376	;
	7377	"RTN","IBY 568PO",39, 0)
	7378	S IBNAME= "PROSTHETI CS COVERAG E"
	7379	"RTN","IBY 568PO",40, 0)
	7380	I $O(^IBE (355.6,"B" ,IBNAME,0) ) S IBX=" - "_IBNA ME_" Insur ance Rider (355.6) a lready exi sts, no
	7381	change" D MES^XPDUTL (IBX) Q
	7382	"RTN","IBY 568PO",41, 0)
	7383	;
	7384	"RTN","IBY 568PO",42, 0)
	7385	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
	7386	"RTN","IBY 568PO",43, 0)
	7387	S IBDA=+Y
	7388	"RTN","IBY 568PO",44, 0)
	7389	;
	7390	"RTN","IBY 568PO",45, 0)
	7391	S IBX=" * "_IBNAM E_" Insura nce Rider (355.6) ad ded" D MES ^XPDUTL(IB X)
	7392	"RTN","IBY 568PO",46, 0)
	7393	Q
	7394	"RTN","IBY 568PO",47, 0)
	7395	;
	7396	"RTN","IBY 568PO",48, 0)
	7397	PLAN ; add Prostheti cs to Plan Coverage Limitation s
	7398	"RTN","IBY 568PO",49, 0)
	7399	D MES^XPD UTL("Addin g PROSTHET ICS to Pla n Coverage Limitatio ns file... ")
	7400	"RTN","IBY 568PO",50, 0)
	7401	N IBA,IBN AME,IBRIDE R,IBRDA,IB X,DD,DO,DL AYGO,DIC,X ,Y,IBDA,DI E,DA,DR,IB FILE
	7402	"RTN","IBY 568PO",51, 0)
	7403	S IBFILE= " Plan Lim itation Ca tegory (#3 55.31) "
	7404	"RTN","IBY 568PO",52, 0)
	7405	;
	7406	"RTN","IBY 568PO",53, 0)
	7407	S IBNAME= "PROSTHETI CS",IBRIDE R="PROSTHE TICS COVER AGE"
	7408	"RTN","IBY 568PO",54, 0)
	7409	S IBRDA=$ O(^IBE(355 .6,"B",IBR IDER,0)) I 'IBRDA S IBX=" - "_IBNAME_I BFILE_"Not Added, Ri der
	7410	Missing" D MES^XPDUT L(IBX) Q
	7411	"RTN","IBY 568PO",55, 0)
	7412	;
	7413	"RTN","IBY 568PO",56, 0)
	7414	I $O(^IBE (355.31,"B ",IBNAME,0 )) S IBA=" >> "_IBNAM E_IBFILE_" exists, no change" D MES^XPDUT L(IBA)
	7415	Q
	7416	"RTN","IBY 568PO",57, 0)
	7417	;
	7418	"RTN","IBY 568PO",58, 0)
	7419	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
	7420	Y<1 K X,Y Q
	7421	"RTN","IBY 568PO",59, 0)
	7422	;
	7423	"RTN","IBY 568PO",60, 0)
	7424	S DIE="^I BE(355.31, ",DA=+IBDA ,DR=".02// /Prostheti cs coverag e" D ^DIE K DIE,DA,D R,X,Y
	7425	"RTN","IBY 568PO",61, 0)
	7426	;
	7427	"RTN","IBY 568PO",62, 0)
	7428	D MES^XPD UTL("Prost hetics Pla n added... ..")
	7429	"RTN","IBY 568PO",63, 0)
	7430	;
	7431	"RTN","IBY 568PO",64, 0)
	7432	Q
	7433	"RTN","IBY 568PO",65, 0)
	7434	;
	7435	"RTN","IBY 568PO",66, 0)
	7436	ADDRT ; Ad d Rate Typ es (399.3)
	7437	"RTN","IBY 568PO",67, 0)
	7438	N IBA,IBC NT,FLG,IBI ,REC,C,DON E,RTNAM,RT NUM
	7439	"RTN","IBY 568PO",68, 0)
	7440	S IBCNT=0
	7441	"RTN","IBY 568PO",69, 0)
	7442	;
	7443	"RTN","IBY 568PO",70, 0)
	7444	D MES^XPD UTL(" -> Adding new Rate T ype entrie s to file 399.3 ..." )
	7445	"RTN","IBY 568PO",71, 0)
	7446	;
	7447	"RTN","IBY 568PO",72, 0)
	7448	S C=";",( FLG,IBCNT) =0
	7449	"RTN","IBY 568PO",73, 0)
	7450	F RTNUM=1 9,20,21 D
	7451	"RTN","IBY 568PO",74, 0)
	7452	. S IBI=" RT"_RTNUM
	7453	"RTN","IBY 568PO",75, 0)
	7454	. S REC=$ P($T(@IBI) ,";",3,99)
	7455	"RTN","IBY 568PO",76, 0)
	7456	. S RTNAM =$P(REC,C, 1)
	7457	"RTN","IBY 568PO",77, 0)
	7458	. ; do a lookup and quit if e xists.
	7459	"RTN","IBY 568PO",78, 0)
	7460	. S DONE= $$NEW(RTNA M,RTNUM,RE C) Q:DONE= -1
	7461	"RTN","IBY 568PO",79, 0)
	7462	. ;
	7463	"RTN","IBY 568PO",80, 0)
	7464	. D MES^X PDUTL("New Rate Type "_RTNAM_" added") S FLG=1,IBC NT=IBCNT+1
	7465	"RTN","IBY 568PO",81, 0)
	7466	;
	7467	"RTN","IBY 568PO",82, 0)
	7468	RTQ I FLG S IBA(1)=" >> " _IBCNT_" R ate Types added (399 .3)..." D MES^XPDUTL (.IBA)
	7469	"RTN","IBY 568PO",83, 0)
	7470	Q
	7471	"RTN","IBY 568PO",84, 0)
	7472	;
	7473	"RTN","IBY 568PO",85, 0)
	7474	NEW(NAM,NU M,REC) ; c reate new rate type
	7475	"RTN","IBY 568PO",86, 0)
	7476	; see if entry exis ts
	7477	"RTN","IBY 568PO",87, 0)
	7478	N DD,DO,D LAYGO,DIC, DIE,DA,DR, X,Y,RN,OUT
	7479	"RTN","IBY 568PO",88, 0)
	7480	S X=NAM
	7481	"RTN","IBY 568PO",89, 0)
	7482	S DIC="^D GCR(399.3, " D ^DIC S OUT=+Y
	7483	"RTN","IBY 568PO",90, 0)
	7484	I OUT>0 D MES^XPDUT L(" "_NAM _" already exists.") Q OUT
	7485	"RTN","IBY 568PO",91, 0)
	7486	; add ent ry
	7487	"RTN","IBY 568PO",92, 0)
	7488	K DO
	7489	"RTN","IBY 568PO",93, 0)
	7490	S DIC(0)= "L",DLAYGO =399.3,DR= "",X=NAM,D A=NUM
	7491	"RTN","IBY 568PO",94, 0)
	7492	D FILE^DI CN I +Y=-1 D MES^XPD UTL(" "_NAM_" failed to add!") Q +Y
	7493	"RTN","IBY 568PO",95, 0)
	7494	S RN=+Y
	7495	"RTN","IBY 568PO",96, 0)
	7496	S DA=RN
	7497	"RTN","IBY 568PO",97, 0)
	7498	S
	7499	DR=".02/// "_$P(REC,C ,2)_";.03/ //0"_";.04 ///"_$P(RE C,C,4)_";. 05///"_$P( REC,C,5)_" ;.06///"_$ P(REC,C,6)
	7500	_";.07///" _$P(REC,C, 7)
	7501	"RTN","IBY 568PO",98, 0)
	7502	S DIE="^D GCR(399.3, "
	7503	"RTN","IBY 568PO",99, 0)
	7504	D ^DIE
	7505	"RTN","IBY 568PO",100 ,0)
	7506	S DIC(0)= "L",DLAYGO =399.3,DR= "",DA=RN
	7507	"RTN","IBY 568PO",101 ,0)
	7508	S DR=".08 ///"_$P(RE C,C,8)_";. 09///1;.1/ //"_$P(REC ,C,10)_";. 11///"_$P( REC,C,11)_ ";580950.1 ///1"
	7509	"RTN","IBY 568PO",102 ,0)
	7510	S DIE="^D GCR(399.3, "
	7511	"RTN","IBY 568PO",103 ,0)
	7512	D ^DIE
	7513	"RTN","IBY 568PO",104 ,0)
	7514	Q 1
	7515	"RTN","IBY 568PO",105 ,0)
	7516	;
	7517	"RTN","IBY 568PO",106 ,0)
	7518	ADDRS ; Ad d Rate Sch edules (36 3) for EME RGENCY/HUM ANITARIAN REIMB. & I NELIGIBLE HOSP. REIM B.
	7519	"RTN","IBY 568PO",107 ,0)
	7520	D MES^XPD UTL(" -> Adding new Rate S chedules t o file 363 ...")
	7521	"RTN","IBY 568PO",108 ,0)
	7522	N
	7523	IBA,IBCNT, IBI,IBLN,I BFN,IBRT,I BBS,IBCNTC S,IBJ,IBLN CS,IBCS,IB CSFN,IBVDT ,DD,DO,DLA YGO,DIC,DI E,DA,D
	7524	R,X,Y,IBAD JST,IBADMI N,IBDISP,I BRN,IBRS,I BRS1,INDT
	7525	"RTN","IBY 568PO",109 ,0)
	7526	S IBCNT=0
	7527	"RTN","IBY 568PO",110 ,0)
	7528	;
	7529	"RTN","IBY 568PO",111 ,0)
	7530	F IBI=1:1 S IBLN=$P ($T(RSF+IB I),";;",2) Q:IBLN="E ND" I $E( IBLN)?1A D
	7531	"RTN","IBY 568PO",112 ,0)
	7532	. ;Check for proble ms
	7533	"RTN","IBY 568PO",113 ,0)
	7534	. I $O(^I BE(363,"B" ,$P(IBLN,U ,1),0)) Q ;Already exists
	7535	"RTN","IBY 568PO",114 ,0)
	7536	. S IBBS= $P(IBLN,U, 4) I IBBS' ="" S IBBS =$$MCCRUTL (IBBS,13) Q:'IBBS ; Billable s ervice inv alid
	7537	"RTN","IBY 568PO",115 ,0)
	7538	. S IBRN= $P(IBLN,U, 1)
	7539	"RTN","IBY 568PO",116 ,0)
	7540	. S IBRT= $P(IBLN,U, 2),IBRT=$O (^DGCR(399 .3,"B",IBR T,0)) D Q :'IBRT
	7541	"RTN","IBY 568PO",117 ,0)
	7542	.. I 'IBR T D MSG(" Rate Ty pe "_$P(IB LN,U,2)_" not define d, RS "_$P (IBLN,U,1) _" not cre ated")
	7543	"RTN","IBY 568PO",118 ,0)
	7544	.. I +$P( $G(^DGCR(3 99.3,+IBRT ,0)),U,3) S IBRT=0 D MSG(" **** Rate Type "_$P(IBLN, U,2)_" not
	7545	Active, RS "_$P(IBLN ,U,1)_" no t created" )
	7546	"RTN","IBY 568PO",119 ,0)
	7547	. ;No pro blems foun d, so crea te entry
	7548	"RTN","IBY 568PO",120 ,0)
	7549	. I IBRN= "HR-INPT" S IBNAME=" HMN-INPT"
	7550	"RTN","IBY 568PO",121 ,0)
	7551	. I IBRN= "HR-OPT" S IBNAME="H MN-OPT"
	7552	"RTN","IBY 568PO",122 ,0)
	7553	. I IBRN= "HR-RX" S IBNAME="HM N-RX"
	7554	"RTN","IBY 568PO",123 ,0)
	7555	. I IBRN= "HR-OPT DE NTAL" S IB NAME="DNTL -OPT DENTA L"
	7556	"RTN","IBY 568PO",124 ,0)
	7557	. I IBRN= "IR-INPT" S IBNAME=" INELIG-INP T"
	7558	"RTN","IBY 568PO",125 ,0)
	7559	. I IBRN= "IR-OPT" S IBNAME="I NELIG-OPT"
	7560	"RTN","IBY 568PO",126 ,0)
	7561	. I IBRN= "IR-RX" S IBNAME="IN ELIG-RX"
	7562	"RTN","IBY 568PO",127 ,0)
	7563	. N IBX,I BRSFN,IBRS 0 S IBRSFN =0
	7564	"RTN","IBY 568PO",128 ,0)
	7565	. F S IB RSFN=$O(^I BE(363,"B" ,IBNAME,IB RSFN)) Q: 'IBRSFN D
	7566	"RTN","IBY 568PO",129 ,0)
	7567	.. S IBRS 0=$G(^IBE( 363,IBRSFN ,0)),IBRS1 =$G(^IBE(3 63,IBNAME, 1))
	7568	"RTN","IBY 568PO",130 ,0)
	7569	.. I $P(I BRS0,U,1)= IBNAME D
	7570	"RTN","IBY 568PO",131 ,0)
	7571	... S IBV DT=$$FMTE^ XLFDT($P(I BRS0,U,5), "2DZ"),IND T=$$FMTE^X LFDT($P(IB RS0,U,6)," 2DZ")
	7572	"RTN","IBY 568PO",132 ,0)
	7573	... I IBN AME["RX" S IBDISP=$P (IBRS1,U,1 ),IBADMIN= $P(IBRS1,U ,2),IBADJS T=$G(^IBE( 363,IBNAME ,10))
	7574	"RTN","IBY 568PO",133 ,0)
	7575	... K DD, DO
	7576	"RTN","IBY 568PO",134 ,0)
	7577	... S DLA YGO=363,DI C="^IBE(36 3,",DIC(0) ="L",X=$P( IBLN,U,1)
	7578	"RTN","IBY 568PO",135 ,0)
	7579	... D FIL E^DICN K D IC,DINUM,D LAYGO
	7580	"RTN","IBY 568PO",136 ,0)
	7581	... I Y<1 K X,Y Q
	7582	"RTN","IBY 568PO",137 ,0)
	7583	... S IBF N=+Y,IBCNT =IBCNT+1
	7584	"RTN","IBY 568PO",138 ,0)
	7585	... S DR= ".02///"_I BRT_";.03/ //"_$P(IBL N,U,3) I + IBBS S DR= DR_";.04// /"_IBBS
	7586	"RTN","IBY 568PO",139 ,0)
	7587	... S DR= DR_";.05// /^S X=IBVD T;.06///^S X=INDT"
	7588	"RTN","IBY 568PO",140 ,0)
	7589	... I IBR N["RX",IBD ISP]"" S D R=DR_";1.0 1///"_IBDI SP
	7590	"RTN","IBY 568PO",141 ,0)
	7591	... I IBR N["RX",IBA DMIN]"" S DR=DR_";1. 02///"_IBA DMIN
	7592	"RTN","IBY 568PO",142 ,0)
	7593	... I IBR N["RX",IBA DJST]"" S DR=DR_";10 ///"_IBADJ ST
	7594	"RTN","IBY 568PO",143 ,0)
	7595	... S DIE ="^IBE(363 ,",DA=IBFN D ^DIE K DIE,DA,DR, X,Y
	7596	"RTN","IBY 568PO",144 ,0)
	7597	... S IBC NTCS=0
	7598	"RTN","IBY 568PO",145 ,0)
	7599	... ; add all Reaso nable Char ges Charge Sets
	7600	"RTN","IBY 568PO",146 ,0)
	7601	... S IBC NTCS=$$RSC S(IBFN,IBV DT,IBRSFN)
	7602	"RTN","IBY 568PO",147 ,0)
	7603	... D MES ^XPDUTL(" Tot al Charge Set"_$S(IB CNTCS=1:" ",1:"s ")_ IBCNTCS_" added to t he rate
	7604	schedule." )
	7605	"RTN","IBY 568PO",148 ,0)
	7606	D MES^XPD UTL(" Rate Sc hedules co mpleted.")
	7607	"RTN","IBY 568PO",149 ,0)
	7608	Q ;ADDRS
	7609	"RTN","IBY 568PO",150 ,0)
	7610	;
	7611	"RTN","IBY 568PO",151 ,0)
	7612	;
	7613	"RTN","IBY 568PO",152 ,0)
	7614	RSCS(IBFN, IBVDT,IBCO PY) ; add existing C harge Sets to HR & I R
	7615	"RTN","IBY 568PO",153 ,0)
	7616	; copy th e Charge S ets from t he corresp onding RI RS (v2)
	7617	"RTN","IBY 568PO",154 ,0)
	7618	N IBCNT,I BNRS,IBRSN M,IBTY,IBC S,IBXFN,IB CSFN,IBCSN M,IBCSAA,I BNAME
	7619	"RTN","IBY 568PO",155 ,0)
	7620	S IBCNT=0
	7621	"RTN","IBY 568PO",156 ,0)
	7622	S IBNRS=$ G(^IBE(363 ,+$G(IBFN) ,0)),IBRSN M=$P(IBNRS ,"^",1)
	7623	"RTN","IBY 568PO",157 ,0)
	7624	S IBTY=$P (IBNRS,"^" ,3)
	7625	"RTN","IBY 568PO",158 ,0)
	7626	I 'IBCOPY G RSCSQ
	7627	"RTN","IBY 568PO",159 ,0)
	7628	I +$P($G( ^IBE(363,+ IBCOPY,0)) ,U,3)=IBTY D
	7629	"RTN","IBY 568PO",160 ,0)
	7630	. S IBXFN =0 F S IB XFN=$O(^IB E(363,IBCO PY,11,IBXF N)) Q:'IBX FN D
	7631	"RTN","IBY 568PO",161 ,0)
	7632	.. S IBCS =$G(^IBE(3 63,IBCOPY, 11,IBXFN,0 )),IBCSFN= +IBCS
	7633	"RTN","IBY 568PO",162 ,0)
	7634	.. I +$$R SCSFILE(IB FN,$P($G(^ IBE(363.1, IBCSFN,0)) ,U,1),$P(I BCS,U,2)) S IBCNT=IB CNT+1
	7635	"RTN","IBY 568PO",163 ,0)
	7636	RSCSQ Q IB CNT
	7637	"RTN","IBY 568PO",164 ,0)
	7638	;
	7639	"RTN","IBY 568PO",165 ,0)
	7640	;
	7641	"RTN","IBY 568PO",166 ,0)
	7642	RSCSFILE(I BFN,IBCSNM ,IBCSAA) ; Add Charg e Set to a Rate Sche dule
	7643	"RTN","IBY 568PO",167 ,0)
	7644	N IBX,DD, DO,DLAYGO, DIC,DA,DR, X,Y,IBCSFN S IBX=0
	7645	"RTN","IBY 568PO",168 ,0)
	7646	I $G(^IBE (363,+$G(I BFN),0))=" " G RSCSFQ
	7647	"RTN","IBY 568PO",169 ,0)
	7648	I $G(IBCS NM)="" G R SCSFQ
	7649	"RTN","IBY 568PO",170 ,0)
	7650	S IBCSFN= $O(^IBE(36 3.1,"B",IB CSNM,0)) I 'IBCSFN G RSCSFQ
	7651	"RTN","IBY 568PO",171 ,0)
	7652	I $O(^IBE (363,IBFN, 11,"B",IBC SFN,0)) G RSCSFQ
	7653	"RTN","IBY 568PO",172 ,0)
	7654	S DLAYGO= 363,DA(1)= +IBFN,DIC= "^IBE(363, "_DA(1)_", 11,",DIC(0 )="L"
	7655	"RTN","IBY 568PO",173 ,0)
	7656	S X=IBCSN M,DIC("DR" )=".02///" _$G(IBCSAA ),DIC("P") ="363.0011 P" D ^DIC S:+Y IBX=1
	7657	"RTN","IBY 568PO",174 ,0)
	7658	RSCSFQ Q I BX
	7659	"RTN","IBY 568PO",175 ,0)
	7660	;
	7661	"RTN","IBY 568PO",176 ,0)
	7662	;
	7663	"RTN","IBY 568PO",177 ,0)
	7664	NEWIBER ; set up new error for COB workl ist
	7665	"RTN","IBY 568PO",178 ,0)
	7666	N IB02,IB 04,IB05,IB NAME,DD,DO ,DLAYGO,DI C,X,Y,IBDA ,IBARR,IBX
	7667	"RTN","IBY 568PO",179 ,0)
	7668	D MES^XPD UTL(" ")
	7669	"RTN","IBY 568PO",180 ,0)
	7670	;
	7671	"RTN","IBY 568PO",181 ,0)
	7672	S IBNAME= "IB815"
	7673	"RTN","IBY 568PO",182 ,0)
	7674	S IB02="B alance bil l this pat ient using the appro priate cos t-based ra te type."
	7675	"RTN","IBY 568PO",183 ,0)
	7676	S IB04="I NTEGRATED BILLING"
	7677	"RTN","IBY 568PO",184 ,0)
	7678	S IB05="D ISPLAY MES SAGE"
	7679	"RTN","IBY 568PO",185 ,0)
	7680	I $O(^IBE (350.8,"B" ,IBNAME,0) ) S IBX=" - "_IBNA ME_" IB Er ror (350.8 ) already exists, no change" D
	7681	MES^XPDUTL (IBX) Q
	7682	"RTN","IBY 568PO",186 ,0)
	7683	;
	7684	"RTN","IBY 568PO",187 ,0)
	7685	K DD,DO S DLAYGO=35 0.8,DIC="^ IBE(350.8, ",DIC(0)=" L",X=IBNAM E D FILE^D ICN
	7686	"RTN","IBY 568PO",188 ,0)
	7687	K DIC I Y <1 K X,Y Q
	7688	"RTN","IBY 568PO",189 ,0)
	7689	S IBDA=+Y
	7690	"RTN","IBY 568PO",190 ,0)
	7691	S RN=+Y
	7692	"RTN","IBY 568PO",191 ,0)
	7693	S DA=RN
	7694	"RTN","IBY 568PO",192 ,0)
	7695	S DR=".02 ///"_IB02_ ";.03///"_ IBNAME_";. 04///"_IB0 4_";.05/// "_IB05
	7696	"RTN","IBY 568PO",193 ,0)
	7697	S DIE="^I BE(350.8,"
	7698	"RTN","IBY 568PO",194 ,0)
	7699	D ^DIE
	7700	"RTN","IBY 568PO",195 ,0)
	7701	;
	7702	"RTN","IBY 568PO",196 ,0)
	7703	S IBX=" * "_IBNAM E_" IB Err or (350.8) added" D MES^XPDUTL (IBX)
	7704	"RTN","IBY 568PO",197 ,0)
	7705	Q
	7706	"RTN","IBY 568PO",198 ,0)
	7707	;
	7708	"RTN","IBY 568PO",199 ,0)
	7709	;
	7710	"RTN","IBY 568PO",200 ,0)
	7711	MCCRUTL(X, P) ; retur ns IFN of item in 39 9.1 if Nam e is found and piece P is true
	7712	"RTN","IBY 568PO",201 ,0)
	7713	N IBX,IBY S IBY=""
	7714	"RTN","IBY 568PO",202 ,0)
	7715	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
	7716	IBY=IBX
	7717	"RTN","IBY 568PO",203 ,0)
	7718	Q IBY
	7719	"RTN","IBY 568PO",204 ,0)
	7720	;
	7721	"RTN","IBY 568PO",205 ,0)
	7722	;
	7723	"RTN","IBY 568PO",206 ,0)
	7724	MSG(X) ;
	7725	"RTN","IBY 568PO",207 ,0)
	7726	N IBX S I BX=$O(IBA( 999999),-1 ) S:'IBX I BX=1 S IBX =IBX+1
	7727	"RTN","IBY 568PO",208 ,0)
	7728	S IBA(IBX )=$G(X)
	7729	"RTN","IBY 568PO",209 ,0)
	7730	Q ;MSG
	7731	"RTN","IBY 568PO",210 ,0)
	7732	;
	7733	"RTN","IBY 568PO",211 ,0)
	7734	RSDT(PRE) ;Copy the active RX charge sch edule from RI to FR
	7735	"RTN","IBY 568PO",212 ,0)
	7736	N IBCS,IB CS0,IBDISP ,IBADMIN,I BADJST
	7737	"RTN","IBY 568PO",213 ,0)
	7738	S IBCS=""
	7739	"RTN","IBY 568PO",214 ,0)
	7740	I PRE="HR " S IBCS=$ O(^IBE(363 ,"B","HMN- RX",""),-1 )
	7741	"RTN","IBY 568PO",215 ,0)
	7742	I PRE="IR " S IBCS=$ O(^IBE(363 ,"B","INEL IG-RX","") ,-1)
	7743	"RTN","IBY 568PO",216 ,0)
	7744	S IBCS0=$ G(^IBE(363 ,IBCS,0))
	7745	"RTN","IBY 568PO",217 ,0)
	7746	S IBDISP= $P($G(^IBE (363,IBCS, 1)),U,1),I BADMIN=$P( $G(^IBE(36 3,IBCS,1)) ,U,2)
	7747	"RTN","IBY 568PO",218 ,0)
	7748	S IBADJST =$G(^IBE(3 63,IBCS,10 ))
	7749	"RTN","IBY 568PO",219 ,0)
	7750	Q $P(IBCS 0,U,5)
	7751	"RTN","IBY 568PO",220 ,0)
	7752	;
	7753	"RTN","IBY 568PO",221 ,0)
	7754	;
	7755	"RTN","IBY 568PO",222 ,0)
	7756	NEWRT ;Rat e Type
	7757	"RTN","IBY 568PO",223 ,0)
	7758	RT19 ;;HUM ANITARIAN REIMB. INS .;HUMANITA RIAN REIMB . INS.;0;H UM
	7759	REIM;1;EME RGENCY/HUM ANITARIAN REIMB.;i;1 ;0;1;28
	7760	"RTN","IBY 568PO",224 ,0)
	7761	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
	7762	"RTN","IBY 568PO",225 ,0)
	7763	RT21 ;;DEN TAL REIMB. INS.;DENT AL REIMB. INS.;0;DEN REIM;1;EM ERGENCY/HU MANITARIAN
	7764	REIMB.;i;1 ;0;1;28
	7765	"RTN","IBY 568PO",226 ,0)
	7766	;;END
	7767	"RTN","IBY 568PO",227 ,0)
	7768	;
	7769	"RTN","IBY 568PO",228 ,0)
	7770	RSF ;Rate Schedules (363) for EMERGENCY/ HUMANITARI AN REIMB. & INELIGIB LE HOSP. R EIMB.
	7771	"RTN","IBY 568PO",229 ,0)
	7772	;;HR-INPT ^HUMANITAR IAN REIMB. INS.^1^IN PATIENT
	7773	"RTN","IBY 568PO",230 ,0)
	7774	;;HR-OPT^ HUMANITARI AN REIMB. INS.^3
	7775	"RTN","IBY 568PO",231 ,0)
	7776	;;HR-RX^H UMANITARIA N REIMB. I NS.^3
	7777	"RTN","IBY 568PO",232 ,0)
	7778	;;HR-OPT DENTAL^DEN TAL REIMB. INS.^3
	7779	"RTN","IBY 568PO",233 ,0)
	7780	;;IR-INPT ^INELIGIBL E REIMB. I NS.^1^INPA TIENT
	7781	"RTN","IBY 568PO",234 ,0)
	7782	;;IR-OPT^ INELIGIBLE REIMB. IN S.^3
	7783	"RTN","IBY 568PO",235 ,0)
	7784	;;IR-RX^I NELIGIBLE REIMB. INS .^3
	7785	"RTN","IBY 568PO",236 ,0)
	7786	;;END
	7787	"VER")
	7788	8.0^22.2
	7789	"BLD",1019 0,6)
	7790	8^
	7791	$END KID I B2.0568