1. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 11/30/2016 2:07:42 PM Eastern Standard Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

1.1 Files compared

#	Location	File	Last Modified
1	OSCIF_ROE_RRE_REE.zip	ZZCIFIB_2_0_568_110716.KID	Mon Nov 7 17:35:24 2016 UTC
2	OSCIF_ROE_RRE_REE.zip	ZZCIFIB_2_0_568_110716.KID	Wed Nov 30 19:07:31 2016 UTC

1.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	1	4698
Changed	0	0
Inserted	0	0
Removed	0	0

1.3 Comparison options

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

1.4 Active regular expressions

No regular expressions were active.

1.5 Comparison detail

	1	KIDS Distr ibution sa ved on Nov 07, 2016@ 12:19:06
	2	IB2.0568 CIF SUBMI SSION
	3	KIDS:Z ZCIFIB2.0 568^
	4
	5	INSTALL NAME
	6	ZZCIFIB2. 0568
	7	"BLD",1031 9,0)
	8	ZZCIFIB2. 0568^^0^3 161107^n
	9	"BLD",1031 9,1,0)
	10	^^4^4^3161 107^
	11	"BLD",1031 9,1,1,0)
	12
	13	"BLD",1031 9,1,2,0)
	14
	15	"BLD",1031 9,1,3,0)
	16	Code in Fl ight submi ssion for patch IB2 .0568 - 1 1/07/2016 (HAPE Reve nue
	17	"BLD",1031 9,1,4,0)
	18	Enhancemen ts)
	19	"BLD",1031 9,4,0)
	20	^9.64PA^^
	21	"BLD",1031 9,6.3)
	22	1
	23	"BLD",1031 9,"INID")
	24	^n
	25	"BLD",1031 9,"INIT")
	26	IBY568PO
	27	"BLD",1031 9,"KRN",0)
	28	^9.67PA^77 9.2^20
	29	"BLD",1031 9,"KRN",.4 ,0)
	30	.4
	31	"BLD",1031 9,"KRN",.4 01,0)
	32	.401
	33	"BLD",1031 9,"KRN",.4 02,0)
	34	.402
	35	"BLD",1031 9,"KRN",.4 03,0)
	36	.403
	37	"BLD",1031 9,"KRN",.5 ,0)
	38	.5
	39	"BLD",1031 9,"KRN",.8 4,0)
	40	.84
	41	"BLD",1031 9,"KRN",3. 6,0)
	42	3.6
	43	"BLD",1031 9,"KRN",3. 8,0)
	44	3.8
	45	"BLD",1031 9,"KRN",9. 2,0)
	46	9.2
	47	"BLD",1031 9,"KRN",9. 8,0)
	48	9.8
	49	"BLD",1031 9,"KRN",9. 8,"NM",0)
	50	^9.68A^6^5
	51	"BLD",1031 9,"KRN",9. 8,"NM",1,0 )
	52	IBJDB21^^0 ^B12749625 8
	53	"BLD",1031 9,"KRN",9. 8,"NM",2,0 )
	54	IBJTLA1^^0 ^B13446872
	55	"BLD",1031 9,"KRN",9. 8,"NM",4,0 )
	56	IBTRKR5^^0 ^B36509050
	57	"BLD",1031 9,"KRN",9. 8,"NM",5,0 )
	58	IBTRE2^^0^ B41201696
	59	"BLD",1031 9,"KRN",9. 8,"NM",6,0 )
	60	IBTRE20^^0 ^B20248565
	61	"BLD",1031 9,"KRN",9. 8,"NM","B" ,"IBJDB21" ,1)
	62
	63	"BLD",1031 9,"KRN",9. 8,"NM","B" ,"IBJTLA1" ,2)
	64
	65	"BLD",1031 9,"KRN",9. 8,"NM","B" ,"IBTRE2", 5)
	66
	67	"BLD",1031 9,"KRN",9. 8,"NM","B" ,"IBTRE20" ,6)
	68
	69	"BLD",1031 9,"KRN",9. 8,"NM","B" ,"IBTRKR5" ,4)
	70
	71	"BLD",1031 9,"KRN",19 ,0)
	72	19
	73	"BLD",1031 9,"KRN",19 ,"NM",0)
	74	^9.68A^1^1
	75	"BLD",1031 9,"KRN",19 ,"NM",1,0)
	76	IBT SUP MA NUALLY QUE PRSTHTCS^ ^0
	77	"BLD",1031 9,"KRN",19 ,"NM","B", "IBT SUP M ANUALLY QU E PRSTHTCS ",1)
	78
	79	"BLD",1031 9,"KRN",19 .1,0)
	80	19.1
	81	"BLD",1031 9,"KRN",10 1,0)
	82	101
	83	"BLD",1031 9,"KRN",40 9.61,0)
	84	409.61
	85	"BLD",1031 9,"KRN",40 9.61,"NM", 0)
	86	^9.68A^1^1
	87	"BLD",1031 9,"KRN",40 9.61,"NM", 1,0)
	88	IBJT ACTIV E LIST^^0
	89	"BLD",1031 9,"KRN",40 9.61,"NM", "B","IBJT ACTIVE LIS T",1)
	90
	91	"BLD",1031 9,"KRN",77 1,0)
	92	771
	93	"BLD",1031 9,"KRN",77 1,"NM",0)
	94	^9.68A^^
	95	"BLD",1031 9,"KRN",77 9.2,0)
	96	779.2
	97	"BLD",1031 9,"KRN",87 0,0)
	98	870
	99	"BLD",1031 9,"KRN",89 89.51,0)
	100	8989.51
	101	"BLD",1031 9,"KRN",89 89.52,0)
	102	8989.52
	103	"BLD",1031 9,"KRN",89 94,0)
	104	8994
	105	"BLD",1031 9,"KRN","B ",.4,.4)
	106
	107	"BLD",1031 9,"KRN","B ",.401,.40 1)
	108
	109	"BLD",1031 9,"KRN","B ",.402,.40 2)
	110
	111	"BLD",1031 9,"KRN","B ",.403,.40 3)
	112
	113	"BLD",1031 9,"KRN","B ",.5,.5)
	114
	115	"BLD",1031 9,"KRN","B ",.84,.84)
	116
	117	"BLD",1031 9,"KRN","B ",3.6,3.6)
	118
	119	"BLD",1031 9,"KRN","B ",3.8,3.8)
	120
	121	"BLD",1031 9,"KRN","B ",9.2,9.2)
	122
	123	"BLD",1031 9,"KRN","B ",9.8,9.8)
	124
	125	"BLD",1031 9,"KRN","B ",19,19)
	126
	127	"BLD",1031 9,"KRN","B ",19.1,19. 1)
	128
	129	"BLD",1031 9,"KRN","B ",101,101)
	130
	131	"BLD",1031 9,"KRN","B ",409.61,4 09.61)
	132
	133	"BLD",1031 9,"KRN","B ",771,771)
	134
	135	"BLD",1031 9,"KRN","B ",779.2,77 9.2)
	136
	137	"BLD",1031 9,"KRN","B ",870,870)
	138
	139	"BLD",1031 9,"KRN","B ",8989.51, 8989.51)
	140
	141	"BLD",1031 9,"KRN","B ",8989.52, 8989.52)
	142
	143	"BLD",1031 9,"KRN","B ",8994,899 4)
	144
	145	"BLD",1031 9,"QDEF")
	146	^^^^NO^^^^ NO^^NO
	147	"BLD",1031 9,"QUES",0 )
	148	^9.62^^
	149	"BLD",1031 9,"REQB",0 )
	150	^9.611^^
	151	"INIT")
	152	IBY568PO
	153	"KRN",19,1 1784,-1)
	154	0^1
	155	"KRN",19,1 1784,0)
	156	IBT SUP MA NUALLY QUE PRSTHTCS^ Manually A dd Prosthe tics to Cl aims Track ing^^R^^^^
	157	^^^^INTEGR ATED BILLI NG
	158	"KRN",19,1 1784,1,0)
	159	^^5^5^3161 101^
	160	"KRN",19,1 1784,1,1,0 )
	161	This optio n allows t he user to select a date range of prosth etics
	162	"KRN",19,1 1784,1,2,0 )
	163	encounters and tries to add th em to the Claims tra cking modu le.
	164	"KRN",19,1 1784,1,3,0 )
	165
	166	"KRN",19,1 1784,1,4,0 )
	167	The option will auto matically queue off a task to add prosth etics and
	168	"KRN",19,1 1784,1,5,0 )
	169	when compl ete send t he request ing user a mail mess age.
	170	"KRN",19,1 1784,25)
	171	EN^IBTRKR5
	172	"KRN",19,1 1784,"U")
	173	MANUALLY A DD PROSTHE TICS TO CL
	174	"KRN",409. 61,84,-1)
	175	0^1
	176	"KRN",409. 61,84,0)
	177	IBJT ACTIV E LIST^1^^ 80^4^20^1^ 1^Active B ill^IBJT A CTIVE LIST SCREEN ME NU^Third P
	178	arty Activ e Bills^1^ ^1
	179	"KRN",409. 61,84,1)
	180	^VALM HIDD EN ACTIONS
	181	"KRN",409. 61,84,"ARR AY")
	182	^TMP("IBJ TLA",$J)
	183	"KRN",409. 61,84,"COL ",0)
	184	^409.621^1 4^14
	185	"KRN",409. 61,84,"COL ",1,0)
	186	NUMBER^1^3
	187	"KRN",409. 61,84,"COL ",2,0)
	188	BILL^4^9^ Bill #
	189	"KRN",409. 61,84,"COL ",3,0)
	190	HD^14^1
	191	"KRN",409. 61,84,"COL ",4,0)
	192	STFROM^15^ 8^From
	193	"KRN",409. 61,84,"COL ",5,0)
	194	STTO^24^8^ To
	195	"KRN",409. 61,84,"COL ",6,0)
	196	TYPE^37^5^ Type
	197	"KRN",409. 61,84,"COL ",7,0)
	198	ARST^42^4^ Stat
	199	"KRN",409. 61,84,"COL ",8,0)
	200	RATE^47^7^ Rate
	201	"KRN",409. 61,84,"COL ",9,0)
	202	CB^55^1
	203	"KRN",409. 61,84,"COL ",10,0)
	204	INSUR^56^7 ^Insurer
	205	"KRN",409. 61,84,"COL ",11,0)
	206	OAMT^64^8^ Orig Amt
	207	"KRN",409. 61,84,"COL ",12,0)
	208	CAMT^73^8^ Curr Amt
	209	"KRN",409. 61,84,"COL ",13,0)
	210	REFER^13^1
	211	"KRN",409. 61,84,"COL ",14,0)
	212	MT?^33^3^M T?
	213	"KRN",409. 61,84,"COL ","B","ARS T",7)
	214
	215	"KRN",409. 61,84,"COL ","B","BIL L",2)
	216
	217	"KRN",409. 61,84,"COL ","B","CAM T",12)
	218
	219	"KRN",409. 61,84,"COL ","B","CAT ",14)
	220
	221	"KRN",409. 61,84,"COL ","B","CB" ,9)
	222
	223	"KRN",409. 61,84,"COL ","B","HD" ,3)
	224
	225	"KRN",409. 61,84,"COL ","B","INS UR",10)
	226
	227	"KRN",409. 61,84,"COL ","B","MT? ",14)
	228
	229	"KRN",409. 61,84,"COL ","B","NUM BER",1)
	230
	231	"KRN",409. 61,84,"COL ","B","OAM T",11)
	232
	233	"KRN",409. 61,84,"COL ","B","RAT E",8)
	234
	235	"KRN",409. 61,84,"COL ","B","REF ER",13)
	236
	237	"KRN",409. 61,84,"COL ","B","STF ROM",4)
	238
	239	"KRN",409. 61,84,"COL ","B","STT O",5)
	240
	241	"KRN",409. 61,84,"COL ","B","TYP E",6)
	242
	243	"KRN",409. 61,84,"FNL ")
	244	D EXIT^IBJ TLA
	245	"KRN",409. 61,84,"HDR ")
	246	D HDR^IBJT LA
	247	"KRN",409. 61,84,"HLP ")
	248	D HELP^IBJ TLA
	249	"KRN",409. 61,84,"INI T")
	250	D INIT^IBJ TLA
	251	"MBREQ")
	252	0
	253	"ORD",17,4 09.61)
	254	409.61;17; 1;;;;LME1^ XPDIA1;;;L MDEL^XPDIA 1
	255	"ORD",17,4 09.61,0)
	256	LIST TEMPL ATE
	257	"ORD",18,1 9)
	258	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
	259	"ORD",18,1 9,0)
	260	OPTION
	261	"QUES","XP F1",0)
	262	Y
	263	"QUES","XP F1","??")
	264	^D REP^XPD H
	265	"QUES","XP F1","A")
	266	Shall I wr ite over y our \|FLAG\| File
	267	"QUES","XP F1","B")
	268	YES
	269	"QUES","XP F1","M")
	270	D XPF1^XPD IQ
	271	"QUES","XP F2",0)
	272	Y
	273	"QUES","XP F2","??")
	274	^D DTA^XPD H
	275	"QUES","XP F2","A")
	276	Want my da ta \|FLAG\| yours
	277	"QUES","XP F2","B")
	278	YES
	279	"QUES","XP F2","M")
	280	D XPF2^XPD IQ
	281	"QUES","XP I1",0)
	282	YO
	283	"QUES","XP I1","??")
	284	^D INHIBIT ^XPDH
	285	"QUES","XP I1","A")
	286	Want KIDS to INHIBIT LOGONs du ring the i nstall
	287	"QUES","XP I1","B")
	288	NO
	289	"QUES","XP I1","M")
	290	D XPI1^XPD IQ
	291	"QUES","XP M1",0)
	292	PO^VA(200, :EM
	293	"QUES","XP M1","??")
	294	^D MG^XPDH
	295	"QUES","XP M1","A")
	296	Enter the Coordinato r for Mail Group '\|F LAG\|'
	297	"QUES","XP M1","B")
	298
	299	"QUES","XP M1","M")
	300	D XPM1^XPD IQ
	301	"QUES","XP O1",0)
	302	Y
	303	"QUES","XP O1","??")
	304	^D MENU^XP DH
	305	"QUES","XP O1","A")
	306	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	307	"QUES","XP O1","B")
	308	NO
	309	"QUES","XP O1","M")
	310	D XPO1^XPD IQ
	311	"QUES","XP Z1",0)
	312	Y
	313	"QUES","XP Z1","??")
	314	^D OPT^XPD H
	315	"QUES","XP Z1","A")
	316	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	317	"QUES","XP Z1","B")
	318	NO
	319	"QUES","XP Z1","M")
	320	D XPZ1^XPD IQ
	321	"QUES","XP Z2",0)
	322	Y
	323	"QUES","XP Z2","??")
	324	^D RTN^XPD H
	325	"QUES","XP Z2","A")
	326	Want to MO VE routine s to other CPUs
	327	"QUES","XP Z2","B")
	328	NO
	329	"QUES","XP Z2","M")
	330	D XPZ2^XPD IQ
	331	"RTN")
	332	6
	333	"RTN","IBJ DB21")
	334	0^1^B12749 6258
	335	"RTN","IBJ DB21",1,0)
	336	IBJDB21 ;A LB/RB - RE ASONS NOT BILLABLE R EPORT (COM PILE) ;19- JUN-00
	337	"RTN","IBJ DB21",2,0)
	338	;;2.0;INT EGRATED BI LLING;12 3,159,185, 399,437,45 8,568;21 -MAR-94;Bu ild 1
	339	"RTN","IBJ DB21",3,0)
	340	;;Per VA Directive 6402, this routine s hould not be modifie d.
	341	"RTN","IBJ DB21",4,0)
	342	;;
	343	"RTN","IBJ DB21",5,0)
	344	EN ; - Ent ry point f rom IBJDB2 .
	345	"RTN","IBJ DB21",6,0)
	346	K ^TMP("I BJDB2",$J) ,IB,IBE,EN CTYP,EPIEN ,IBADMDT,R ELBILL
	347	"RTN","IBJ DB21",7,0)
	348	I '$G(IBX TRACT) D
	349	"RTN","IBJ DB21",8,0)
	350	. F X=1:1 :4 I IBSEL [X S IBE(X )=IBEPS(X) ; Set epi sodes for report.
	351	"RTN","IBJ DB21",9,0)
	352	;
	353	"RTN","IBJ DB21",10,0 )
	354	; - Print the heade r line for the Excel spreadshe et
	355	"RTN","IBJ DB21",11,0 )
	356	I $G(IBEX CEL) D PHD L
	357	"RTN","IBJ DB21",12,0 )
	358	;
	359	"RTN","IBJ DB21",13,0 )
	360	; - Compi le reason not billab le (RNB) d ata for ep isode.
	361	"RTN","IBJ DB21",14,0 )
	362	S IBRNB=0 F S IBRN B=$S(IBSRN B'="A":$O( IBSRNB(IBR NB)),1:$O( ^IBE(356.8 ,IBRNB)))
	363	Q:'IBRNB D
	364	"RTN","IBJ DB21",15,0 )
	365	.S IB0=0 F S IB0=$ O(^IBT(356 ,"AR",IBRN B,IB0)) Q: 'IB0 D
	366	"RTN","IBJ DB21",16,0 )
	367	..S IBN0= $G(^IBT(35 6,IB0,0)), IBN1=$G(^I BT(356,IB0 ,1)) Q:'IB N0!('IBN1)
	368	"RTN","IBJ DB21",17,0 )
	369	..S IBEP= +$P(IBN0,U ,18) I IBS EL'[IBEP Q ; Get ep isode.
	370	"RTN","IBJ DB21",18,0 )
	371	..S (IBRN B1,IBSORT1 )=$P($G(^I BE(356.8,I BRNB,0)),U )
	372	"RTN","IBJ DB21",19,0 )
	373	..;
	374	"RTN","IBJ DB21",20,0 )
	375	..; - Get valid dat e entered/ episode da te and amo unt for re port.
	376	"RTN","IBJ DB21",21,0 )
	377	..S IBEPD =+$P(IBN0, U,6)\1,IBD EN=+IBN1\1
	378	"RTN","IBJ DB21",22,0 )
	379	..S IBDT= $S($E(IBD) ="D":IBDEN ,1:IBEPD)
	380	"RTN","IBJ DB21",23,0 )
	381	..Q:IBDT< IBBDT!(IBD T>IBEDT)
	382	"RTN","IBJ DB21",24,0 )
	383	..S IBAMT =$$AMOUNT( IBEP,IB0)
	384	"RTN","IBJ DB21",25,0 )
	385	..I IBAMT <0 Q ;Qui t if amoun t is -1 *5 68
	386	"RTN","IBJ DB21",26,0 )
	387	..;
	388	"RTN","IBJ DB21",27,0 )
	389	..; - Get division, if necess ary.
	390	"RTN","IBJ DB21",28,0 )
	391	..I IBSD D Q:'VAUT D&('$D(VAU TD(IBDIV)) )
	392	"RTN","IBJ DB21",29,0 )
	393	...S IBDI V=$$DIV^IB JD1(IB0)
	394	"RTN","IBJ DB21",30,0 )
	395	..E S IB DIV=$S($G( IBEXCEL):+ $$PRIM^VAS ITE(),1:0)
	396	"RTN","IBJ DB21",31,0 )
	397	..;
	398	"RTN","IBJ DB21",32,0 )
	399	..; - Pro vider & Sp ecialty
	400	"RTN","IBJ DB21",33,0 )
	401	..S (IBPR V,IBSPC)=" ",IBQT=0
	402	"RTN","IBJ DB21",34,0 )
	403	..I IBEP= 1!(IBEP=2) D I IBQT Q
	404	"RTN","IBJ DB21",35,0 )
	405	...S IBPR SP=$$PRVSP C(IBEP,IB0 )
	406	"RTN","IBJ DB21",36,0 )
	407	...I IBSP RV'="A",'$ D(IBSPRV(+ IBPRSP)) S IBQT=1 Q
	408	"RTN","IBJ DB21",37,0 )
	409	...I IBEP =1,IBSISP' ="A",'$D(I BSISP(+$P( IBPRSP,U,3 ))) S IBQT =1 Q
	410	"RTN","IBJ DB21",38,0 )
	411	...I IBEP =2,IBSOSP' ="A",'$D(I BSOSP(+$P( IBPRSP,U,3 ))) S IBQT =1 Q
	412	"RTN","IBJ DB21",39,0 )
	413	...S IBPR V=$S($P(IB PRSP,U,2)' ="":$P(IBP RSP,U,2),1 :" UNKNO WN ")
	414	"RTN","IBJ DB21",40,0 )
	415	...S IBSP C=$S($P(IB PRSP,U,4)' ="":$P(IBP RSP,U,4),1 :" UNKNO WN ")
	416	"RTN","IBJ DB21",41,0 )
	417	..;
	418	"RTN","IBJ DB21",42,0 )
	419	..; - Get remaining data for detailed r eport.
	420	"RTN","IBJ DB21",43,0 )
	421	..S DFN=+ $P(IBN0,U, 2)
	422	"RTN","IBJ DB21",44,0 )
	423	..D DEM^V ADPT S IBP T=$E(VADM( 1),1,25),I BSSN=$P(VA DM(2),U)
	424	"RTN","IBJ DB21",45,0 )
	425	..S DIC=" ^VA(200,", DA=+$P(IBN 1,U,4),DR= ".01",DIQ= "IBCLK" D EN^DIQ1
	426	"RTN","IBJ DB21",46,0 )
	427	..S IBCLK =$E($G(IBC LK(200,DA, .01)),1,20 )
	428	"RTN","IBJ DB21",47,0 )
	429	..I ($P(I BN0,U,18)= 2)&($$EXTE RNAL^DILFD (356,.19," ",$P(IBN0, U,19))["72 HOUR RULE
	430	") D
	431	"RTN","IBJ DB21",48,0 )
	432	...S IBAD MDT=$$ADMD T^IBTUTL5( DFN,$P(IBN 0,U,6))
	433	"RTN","IBJ DB21",49,0 )
	434	..E S IB ADMDT=""
	435	"RTN","IBJ DB21",50,0 )
	436	..S ENCTY P=$P(^IBE( 356.6,$P(I BN0,U,18), 0),U,3) S EPDT=$E($P (IBN0,U,6) ,1,7)
	437	"RTN","IBJ DB21",51,0 )
	438	..S EPIEN =$S(ENCTYP =3:$P(IBN0 ,U,8),ENCT YP=4:$P(IB N0,U,9),1: "")
	439	"RTN","IBJ DB21",52,0 )
	440	..S RELBI LL=$$RELBI L^IBTUTL5( EPIEN,EPDT ,DFN,ENCTY P)
	441	"RTN","IBJ DB21",53,0 )
	442	..;
	443	"RTN","IBJ DB21",54,0 )
	444	..; - Get totals fo r summary.
	445	"RTN","IBJ DB21",55,0 )
	446	..I '$D(I B(IBDIV,IB EP,IBRNB)) S IB(IBDI V,IBEP,IBR NB)="0^0"
	447	"RTN","IBJ DB21",56,0 )
	448	..S $P(IB (IBDIV,IBE P,IBRNB),U )=$P(IB(IB DIV,IBEP,I BRNB),U)+1
	449	"RTN","IBJ DB21",57,0 )
	450	..S $P(IB (IBDIV,IBE P,IBRNB),U ,2)=$P(IB( IBDIV,IBEP ,IBRNB),U, 2)+IBAMT
	451	"RTN","IBJ DB21",58,0 )
	452	..I IBRPT ="S" Q
	453	"RTN","IBJ DB21",59,0 )
	454	..;
	455	"RTN","IBJ DB21",60,0 )
	456	..S IBSOR T1=$S(IBSO RT="P":IBP RV,IBSORT= "S":IBSPC, 1:IBSORT1)
	457	"RTN","IBJ DB21",61,0 )
	458	..S:IBSOR T1="" IBSO RT1=" "
	459	"RTN","IBJ DB21",62,0 )
	460	..;
	461	"RTN","IBJ DB21",63,0 )
	462	..I $G(IB EXCEL) D Q
	463	"RTN","IBJ DB21",64,0 )
	464	...W !,$E ($P($G(^DG (40.8,IBDI V,0)),U),1 ,25),U
	465	"RTN","IBJ DB21",65,0 )
	466	...W $S(I BEP<4:$E(I BE(IBEP)), 1:"H"),U,I BPT,U,$E(I BSSN,6,10) ,U
	467	"RTN","IBJ DB21",66,0 )
	468	...W $E($ $INS^IBJD1 (+$P(IBN0, U,2),IBEPD ),1,25),U
	469	"RTN","IBJ DB21",67,0 )
	470	...W $$DT ^IBJD(IBEP D,1),U,$$D T^IBJD(IBD EN,1),U
	471	"RTN","IBJ DB21",68,0 )
	472	...W $$DT ^IBJD($P(I BN1,U,3),1 ),U,IBCLK, U,IBADMDT, U,$E(IBRNB 1,1,25),U
	473	"RTN","IBJ DB21",69,0 )
	474	...W $E(I BPRV,1,25) ,U,$E(IBSP C,1,25),U, IBAMT,U
	475	"RTN","IBJ DB21",70,0 )
	476	...I RELB ILL>0 F X= 2:1:$P(REL BILL,";",1 )+1 W $P(R ELBILL,";" ,X)_" "
	477	"RTN","IBJ DB21",71,0 )
	478	...I RELB ILL<0 W ""
	479	"RTN","IBJ DB21",72,0 )
	480	...W U,$P (IBN1,U,8)
	481	"RTN","IBJ DB21",73,0 )
	482	..;
	483	"RTN","IBJ DB21",74,0 )
	484	..S X=IBE PD_U_IBDEN _U_$P(IBN1 ,U,3)_U_IB CLK_U_IBRN B1
	485	"RTN","IBJ DB21",75,0 )
	486	..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
	487	"RTN","IBJ DB21",76,0 )
	488	..S ^TMP( "IBJDB2",$ J,IBDIV,IB EP,IBSORT1 ,IBPT_"@@" _$E(IBSSN, 6,10))=$$I NS^IBJD1(+
	489	$P(IBN0,U, 2),IBEPD)
	490	"RTN","IBJ DB21",77,0 )
	491	..S ^TMP( "IBJDB2",$ J,IBDIV,IB EP,IBSORT1 ,IBPT_"@@" _$E(IBSSN, 6,10),+IBN 0)=X
	492	"RTN","IBJ DB21",78,0 )
	493	;
	494	"RTN","IBJ DB21",79,0 )
	495	I '$G(IBE XCEL) D EN ^IBJDB22 ; Print rep ort(s).
	496	"RTN","IBJ DB21",80,0 )
	497	;
	498	"RTN","IBJ DB21",81,0 )
	499	ENQ K ^TMP ("IBJDB2")
	500	"RTN","IBJ DB21",82,0 )
	501	K DA,DIC, DIQ,DR,IB, IB0,IBAMT, IBCLK,IBDE N,IBDIV,IB DT,IBE,IBE P,IBEPD,IB I
	502	"RTN","IBJ DB21",83,0 )
	503	K IBN0,IB N1,IBN2,IB PRSP,IBPRV ,IBPT,IBQT ,IBRNB,IBR NB1,IBSORT 1,IBSPC
	504	"RTN","IBJ DB21",84,0 )
	505	K IBSSN,V ADM,X1,X2
	506	"RTN","IBJ DB21",85,0 )
	507	Q
	508	"RTN","IBJ DB21",86,0 )
	509	;
	510	"RTN","IBJ DB21",87,0 )
	511	AMOUNT(EPS ,CLM) ; Re turn the A mount not billed
	512	"RTN","IBJ DB21",88,0 )
	513	; Input: EPS - Epis ode(1=Inpa tient,2=Ou tpatient,3 =Prosthet. ,4=Prescr. )
	514	"RTN","IBJ DB21",89,0 )
	515	; CLM - Poin ter to Cla im Trackin g File (#3 56)
	516	"RTN","IBJ DB21",90,0 )
	517	;Output: AMOUNT not billed
	518	"RTN","IBJ DB21",91,0 )
	519	;
	520	"RTN","IBJ DB21",92,0 )
	521	N ADM,ADM DT,AMOUNT, BLBS,BLDT, CPT,CPTLST ,DA,DR,DCH D,DFN,DIC, DIQ,DIV,DR G,SPCLTY
	522	"RTN","IBJ DB21",93,0 )
	523	N IBRX,EN C,ENCDT,EP DT,PFT,PRS T,PTF,RIMB ,VCPT,TTCS T,X
	524	"RTN","IBJ DB21",94,0 )
	525	;
	526	"RTN","IBJ DB21",95,0 )
	527	S AMOUNT= 0,X=$G(^IB T(356,CLM, 0))
	528	"RTN","IBJ DB21",96,0 )
	529	S ENC=+$P (X,U,4) ; Encoun ter (Po inter to # 409.68)
	530	"RTN","IBJ DB21",97,0 )
	531	S ADM=+$P (X,U,5) ; Admiss ion (Po inter to # 405)
	532	"RTN","IBJ DB21",98,0 )
	533	S PRST=+$ P(X,U,9) ; Prothe tics (Po inter to # 660)
	534	"RTN","IBJ DB21",99,0 )
	535	S EPDT=$P (X,U,6) ; Episod e Date (FM format)
	536	"RTN","IBJ DB21",100, 0)
	537	S IBRX=+$ P(X,U,8)
	538	"RTN","IBJ DB21",101, 0)
	539	;
	540	"RTN","IBJ DB21",102, 0)
	541	; - Assum es REIMBUR SABLE INS. as the RA TE TYPE
	542	"RTN","IBJ DB21",103, 0)
	543	S RIMB=$O (^DGCR(399 .3,"B","RE IMBURSABLE INS.",0)) I 'RIMB S RIMB=8
	544	"RTN","IBJ DB21",104, 0)
	545	;
	546	"RTN","IBJ DB21",105, 0)
	547	G @("AMT" _EPS)
	548	"RTN","IBJ DB21",106, 0)
	549	;
	550	"RTN","IBJ DB21",107, 0)
	551	AMT1 ; - I npatient C harges
	552	"RTN","IBJ DB21",108, 0)
	553	I 'ADM S AMOUNT=-1 G QAMT
	554	"RTN","IBJ DB21",109, 0)
	555	S X=$G(^D GPM(ADM,0) ) I X="" S AMOUNT=-1 G QAMT
	556	"RTN","IBJ DB21",110, 0)
	557	S PTF=$P( X,U,16) I 'PTF S AMO UNT=-1 G Q AMT
	558	"RTN","IBJ DB21",111, 0)
	559	S ADMDT=$ P(X,U)\1,D FN=+$P(X,U ,3)
	560	"RTN","IBJ DB21",112, 0)
	561	I $P(X,U, 17) S DCHD =$P($G(^DG PM(+$P(X,U ,17),0)),U )\1
	562	"RTN","IBJ DB21",113, 0)
	563	I '$G(DCH D) S DCHD= $$DT^XLFDT ()
	564	"RTN","IBJ DB21",114, 0)
	565	;
	566	"RTN","IBJ DB21",115, 0)
	567	K ^TMP($J ,"IBCRC-PT F"),^TMP($ J,"IBCRC-D IV"),^TMP( $J,"IBCRC- INDT")
	568	"RTN","IBJ DB21",116, 0)
	569	D PTF^IBC RBG(PTF) I '$D(^TMP( $J,"IBCRC- PTF")) S A MOUNT=-1 G QAMT ;*5 68
	570	"RTN","IBJ DB21",117, 0)
	571	D PTFDV^I BCRBG(PTF) I '$D(^TM P($J,"IBCR C-DIV")) S AMOUNT=-1 G QAMT ; *568
	572	"RTN","IBJ DB21",118, 0)
	573	D BSLOS^I BCRBG(ADMD T,DCHD,1,A DM,0) I '$ D(^TMP($J, "IBCRC-IND T")) S AMO UNT=-1 G Q
	574	AMT ;*568
	575	"RTN","IBJ DB21",119, 0)
	576	;
	577	"RTN","IBJ DB21",120, 0)
	578	S BLDT=""
	579	"RTN","IBJ DB21",121, 0)
	580	F S BLDT =$O(^TMP($ J,"IBCRC-I NDT",BLDT) ) Q:BLDT=" " D
	581	"RTN","IBJ DB21",122, 0)
	582	.S X=^TMP ($J,"IBCRC -INDT",BLD T)
	583	"RTN","IBJ DB21",123, 0)
	584	.S BLBS=$ P(X,U,2),D RG=$P(X,U, 4),DIV=$P( X,U,5),SPC LTY=$P(X,U ,6)
	585	"RTN","IBJ DB21",124, 0)
	586	.;
	587	"RTN","IBJ DB21",125, 0)
	588	.; - Tort Liable Ch arge (prio r to 09/01 /99)
	589	"RTN","IBJ DB21",126, 0)
	590	.I BLDT<2 990901 D Q
	591	"RTN","IBJ DB21",127, 0)
	592	..S AMOUN T=AMOUNT+$ $BICOST^IB CRCI(RIMB, 1,BLDT,"IN PATIENT BE DSECTION S TAY",BLBS)
	593	"RTN","IBJ DB21",128, 0)
	594	.;
	595	"RTN","IBJ DB21",129, 0)
	596	.; - Reas onable Cha rges (on 0 9/01/99 or later)
	597	"RTN","IBJ DB21",130, 0)
	598	.I $$NODR G^IBCRBG2( SPCLTY)["O bservation " Q
	599	"RTN","IBJ DB21",131, 0)
	600	.I $$NODR G^IBCRBG2( SPCLTY)["N ursing Hom e Care" D Q
	601	"RTN","IBJ DB21",132, 0)
	602	..S BLBS= $$MCCRUTL^ IBCRU1("SK ILLED NURS ING CARE", 25)
	603	"RTN","IBJ DB21",133, 0)
	604	..S AMOUN T=AMOUNT+$ $BICOST^IB CRCI(RIMB, 1,BLDT,"IN PATIENT BE DSECTION S TAY",BLBS,
	605	"",DIV,"", 1)
	606	"RTN","IBJ DB21",134, 0)
	607	.;
	608	"RTN","IBJ DB21",135, 0)
	609	.S BLBS=$ $BSUPD^IBC RBG2(+SPCL TY,BLDT,1)
	610	"RTN","IBJ DB21",136, 0)
	611	.S AMOUNT =AMOUNT+$$ BICOST^IBC RCI(RIMB,1 ,BLDT,"INP ATIENT DRG ",DRG,"",D IV,"",1,BL
	612	BS)
	613	"RTN","IBJ DB21",137, 0)
	614	;
	615	"RTN","IBJ DB21",138, 0)
	616	; - Add t he Profess ional Aver age Amount per Episo de (Reason .Chg only)
	617	"RTN","IBJ DB21",139, 0)
	618	I EPDT'<2 990901 S A MOUNT=AMOU NT+$$AVG(E PDT)
	619	"RTN","IBJ DB21",140, 0)
	620	;
	621	"RTN","IBJ DB21",141, 0)
	622	; - Subtr act the am ount bille d for this Episode
	623	"RTN","IBJ DB21",142, 0)
	624	S AMOUNT= AMOUNT-$$C LAMT(DFN,E PDT,1) I A MOUNT=0 S AMOUNT=-1 ;*568
	625	"RTN","IBJ DB21",143, 0)
	626	;
	627	"RTN","IBJ DB21",144, 0)
	628	K ^TMP($J ,"IBCRC-PT F"),^TMP($ J,"IBCRC-D IV"),^TMP( $J,"IBCRC- INDT")
	629	"RTN","IBJ DB21",145, 0)
	630	;
	631	"RTN","IBJ DB21",146, 0)
	632	G QAMT
	633	"RTN","IBJ DB21",147, 0)
	634	;
	635	"RTN","IBJ DB21",148, 0)
	636	AMT2 ; - O utpatient Charges
	637	"RTN","IBJ DB21",149, 0)
	638	S X=$$GET OE^SDOE(EN C),ENCDT=+ $P(X,U),DF N=+$P(X,U, 2),DIV=$P( X,U,11)
	639	"RTN","IBJ DB21",150, 0)
	640	;
	641	"RTN","IBJ DB21",151, 0)
	642	; - Tort Liable Cha rge (prior to 09/01/ 99)
	643	"RTN","IBJ DB21",152, 0)
	644	I ENCDT<2 990901 D G QAMT
	645	"RTN","IBJ DB21",153, 0)
	646	. S AMOUN T=+$$BICOS T^IBCRCI(R IMB,3,ENCD T,"OUTPATI ENT VISIT DATE")
	647	"RTN","IBJ DB21",154, 0)
	648	;
	649	"RTN","IBJ DB21",155, 0)
	650	S AMOUNT= $$OPT(ENC, EPDT) ;*5 68
	651	"RTN","IBJ DB21",156, 0)
	652	G QAMT ; *568
	653	"RTN","IBJ DB21",157, 0)
	654	;
	655	"RTN","IBJ DB21",158, 0)
	656	AMT3 ; Pro sthetic Ch arges
	657	"RTN","IBJ DB21",159, 0)
	658	N NTBLD
	659	"RTN","IBJ DB21",160, 0)
	660	S NTBLD=$ $PRSAMT^IB TUTL5(EPDT ,PRST) I N TBLD=0 S A MOUNT=-1 G QAMT ;*5 68
	661	"RTN","IBJ DB21",161, 0)
	662	S DIC="^R MPR(660,", DA=PRST,DR ="14",DIQ= "TTCST" D EN^DIQ1
	663	"RTN","IBJ DB21",162, 0)
	664	S AMOUNT= +$G(TTCST( 660,DA,14) )
	665	"RTN","IBJ DB21",163, 0)
	666	G QAMT
	667	"RTN","IBJ DB21",164, 0)
	668	;
	669	"RTN","IBJ DB21",165, 0)
	670	AMT4 ; - P rescriptio n Charges
	671	"RTN","IBJ DB21",166, 0)
	672	;
	673	"RTN","IBJ DB21",167, 0)
	674	; Protect Rx intern al entry # before RX AMT call s witches to RX number
	675	"RTN","IBJ DB21",168, 0)
	676	N IBRXIEN ,NTBLD S I BRXIEN=IBR X
	677	"RTN","IBJ DB21",169, 0)
	678	;
	679	"RTN","IBJ DB21",170, 0)
	680	; - Tort Liable Cha rge & Reas onable Cha rge (same source)
	681	"RTN","IBJ DB21",171, 0)
	682	S NTBLD=$ $RXAMT^IBT UTL5(EPDT, IBRX) I NT BLD=0 S AM OUNT=-1 G QAMT ;*56 8
	683	"RTN","IBJ DB21",172, 0)
	684	;
	685	"RTN","IBJ DB21",173, 0)
	686	; Patch 4 37 update to call ch arge maste r with eno ugh inform ation
	687	"RTN","IBJ DB21",174, 0)
	688	; to look up actual cost of pr escription
	689	"RTN","IBJ DB21",175, 0)
	690	;
	691	"RTN","IBJ DB21",176, 0)
	692	N IBBI,IB RSNEW
	693	"RTN","IBJ DB21",177, 0)
	694	;
	695	"RTN","IBJ DB21",178, 0)
	696	; check c harge mast er for the type of b illing--VA Cost or n ot
	697	"RTN","IBJ DB21",179, 0)
	698	S IBBI=$$ EVNTITM^IB CRU3(+RIMB ,3,"PRESCR IPTION FIL L",EPDT,.I BRSNEW)
	699	"RTN","IBJ DB21",180, 0)
	700	;
	701	"RTN","IBJ DB21",181, 0)
	702	S DFN=$$F ILE^IBRXUT L(IBRXIEN, 2)
	703	"RTN","IBJ DB21",182, 0)
	704	I $G(DFN) >0&(IBBI[" VA COST") D
	705	"RTN","IBJ DB21",183, 0)
	706	. N IBQT Y,IBCOST,I BRFNUM,IBS UBND,IBFEE ,IBRXNODE
	707	"RTN","IBJ DB21",184, 0)
	708	.; if th is is a re fill look up the ref ill info f or cost an d quantity
	709	"RTN","IBJ DB21",185, 0)
	710	. S IBRF NUM=$$RFLN UM^IBRXUTL (IBRXIEN,E PDT,"")
	711	"RTN","IBJ DB21",186, 0)
	712	. I IBRF NUM>0 D
	713	"RTN","IBJ DB21",187, 0)
	714	.. S I BSUBND=$$Z EROSUB^IBR XUTL(DFN,I BRXIEN,IBR FNUM)
	715	"RTN","IBJ DB21",188, 0)
	716	.. S I BQTY=$P($G (IBSUBND), U,4)
	717	"RTN","IBJ DB21",189, 0)
	718	.. S I BCOST=$P($ G(IBSUBND) ,U,11)
	719	"RTN","IBJ DB21",190, 0)
	720	.;
	721	"RTN","IBJ DB21",191, 0)
	722	.; if th is was an original f ill look u p zero nod e for Rx i nfo
	723	"RTN","IBJ DB21",192, 0)
	724	. E D
	725	"RTN","IBJ DB21",193, 0)
	726	.. S I BRXNODE=$$ RXZERO^IBR XUTL(DFN,I BRXIEN)
	727	"RTN","IBJ DB21",194, 0)
	728	.. S I BQTY=$P($G (IBRXNODE) ,U,7)
	729	"RTN","IBJ DB21",195, 0)
	730	.. S I BCOST=$P($ G(IBRXNODE ),U,17)
	731	"RTN","IBJ DB21",196, 0)
	732	.;
	733	"RTN","IBJ DB21",197, 0)
	734	. S IBRS NEW=+$O(IB RSNEW($P(I BBI,";"),0 ))
	735	"RTN","IBJ DB21",198, 0)
	736	. S AMOU NT=$J(+$$R ATECHG^IBC RCC(+IBRSN EW,IBQTY*I BCOST,EPDT ,.IBFEE),0 ,2)
	737	"RTN","IBJ DB21",199, 0)
	738	E D
	739	"RTN","IBJ DB21",200, 0)
	740	. S AMOU NT=+$$BICO ST^IBCRCI( RIMB,3,EPD T,"PRESCRI PTION FILL ")
	741	"RTN","IBJ DB21",201, 0)
	742	;
	743	"RTN","IBJ DB21",202, 0)
	744	;
	745	"RTN","IBJ DB21",203, 0)
	746	QAMT I AMO UNT=0 S AM OUNT=-1 ;* 568
	747	"RTN","IBJ DB21",204, 0)
	748	Q AMOUNT
	749	"RTN","IBJ DB21",205, 0)
	750	;
	751	"RTN","IBJ DB21",206, 0)
	752	CLAMT(DFN, EPDT,PT) ; Returns t he Total A mount of C laims for Patient/Ep isode
	753	"RTN","IBJ DB21",207, 0)
	754	;
	755	"RTN","IBJ DB21",208, 0)
	756	; Input: DFN - Poi nter to th e Patient File #2
	757	"RTN","IBJ DB21",209, 0)
	758	; EPDT - Epi sode Date
	759	"RTN","IBJ DB21",210, 0)
	760	; PT - 0=O utpatient, 1=Inpatie nt
	761	"RTN","IBJ DB21",211, 0)
	762	;
	763	"RTN","IBJ DB21",212, 0)
	764	N CLAMT,C LM,DAY,IBD ,X
	765	"RTN","IBJ DB21",213, 0)
	766	S CLAMT=0 ,DAY=EPDT- 1,CLM=""
	767	"RTN","IBJ DB21",214, 0)
	768	F S CLM= $O(^DGCR(3 99,"C",DFN ,CLM)) Q:' CLM D
	769	"RTN","IBJ DB21",215, 0)
	770	.S X=$G(^ DGCR(399,C LM,0))
	771	"RTN","IBJ DB21",216, 0)
	772	.I $P($P( X,U,3),"." )=$P(EPDT, ".") D
	773	"RTN","IBJ DB21",217, 0)
	774	..S IBD=$ $CKBIL^IBT UBOU(CLM,P T) Q:IBD=" "
	775	"RTN","IBJ DB21",218, 0)
	776	..I '$P(I BD,U,3) Q ; Not aut horized
	777	"RTN","IBJ DB21",219, 0)
	778	..S CLAMT =CLAMT+$G( ^DGCR(399, CLM,"U1"))
	779	"RTN","IBJ DB21",220, 0)
	780	;
	781	"RTN","IBJ DB21",221, 0)
	782	QCLAMT Q C LAMT
	783	"RTN","IBJ DB21",222, 0)
	784	;
	785	"RTN","IBJ DB21",223, 0)
	786	OPT(IBOE,I BDT) ; - H as the out patient en counter be en billed?
	787	"RTN","IBJ DB21",224, 0)
	788	; Input : IBOE=poi nter to ou tpatient e ncounter i n file #40 9.68
	789	"RTN","IBJ DB21",225, 0)
	790	; IBDT=eve nt date CL AIMS TRACK ING(#356)
	791	"RTN","IBJ DB21",226, 0)
	792	;
	793	"RTN","IBJ DB21",227, 0)
	794	; ; *P re-set var iables: DF N=patient IEN, RIMB= bill rate
	795	"RTN","IBJ DB21",228, 0)
	796	;
	797	"RTN","IBJ DB21",229, 0)
	798	;
	799	"RTN","IBJ DB21",230, 0)
	800	I '$G(DFN )!('$G(IBD T))!('$G(R IMB))!('$G (IBOE)) S IBRTN=0 G OPTQ
	801	"RTN","IBJ DB21",231, 0)
	802	N IBCN,IB CPT,IBCT,I BDATA,IBDA Y,IBDIV,IB XX,IBYD,IB YY,IBZ,IBM RA,IBCPTSU M,IBTCHRG,
	803	IBRTN,IBAU TH
	804	"RTN","IBJ DB21",232, 0)
	805	; - Check to be sur e the enco unter is b illable.
	806	"RTN","IBJ DB21",233, 0)
	807	I $$INPT^ IBAMTS1(DF N,IBDT\1_. 2359) S IB RTN=-1 G O PTQ ; Bec ame inpati ent same d
	808	ay.
	809	"RTN","IBJ DB21",234, 0)
	810	I $$ENCL^ IBAMTS2(IB OE)["1" S IBRTN=-1 G OPTQ ; " ao^ir^sc^s wa^mst^hnc ^cv^shad"
	811	encounter.
	812	"RTN","IBJ DB21",235, 0)
	813	;
	814	"RTN","IBJ DB21",236, 0)
	815	;
	816	"RTN","IBJ DB21",237, 0)
	817	; - Gathe r all proc edures ass ociated wi th the enc ounter.
	818	"RTN","IBJ DB21",238, 0)
	819	D GETCPT^ SDOE(IBOE, "IBYY") I '$G(IBYY) S IBRTN=-1 G OPTQ ; Check CPT qty.
	820	"RTN","IBJ DB21",239, 0)
	821	;
	822	"RTN","IBJ DB21",240, 0)
	823	; - Deter mine the e ncounter d ivision.
	824	"RTN","IBJ DB21",241, 0)
	825	S IBDIV=+ $P($$GETOE ^SDOE(IBOE ),U,11) S: 'IBDIV IBD IV=+$$PRIM ^VASITE()
	826	"RTN","IBJ DB21",242, 0)
	827	;
	828	"RTN","IBJ DB21",243, 0)
	829	; - Build array of all billab le encount er procedu res.
	830	"RTN","IBJ DB21",244, 0)
	831	S IBXX=0 F S IBXX= $O(IBYY(IB XX)) Q:'IB XX D
	832	"RTN","IBJ DB21",245, 0)
	833	. ;
	834	"RTN","IBJ DB21",246, 0)
	835	. ; - Get procedure pointer a nd code.
	836	"RTN","IBJ DB21",247, 0)
	837	. S IBZ=+ IBYY(IBXX) ,IBCN=$P($ $CPT^ICPTC OD(IBZ),"^ ",2)
	838	"RTN","IBJ DB21",248, 0)
	839	. ;
	840	"RTN","IBJ DB21",249, 0)
	841	. ; - Ign ore LAB se rvices for vets with Medicare Supplement al coverag e.
	842	"RTN","IBJ DB21",250, 0)
	843	. I IBCN> 79999,IBCN <90000 Q
	844	"RTN","IBJ DB21",251, 0)
	845	. ;
	846	"RTN","IBJ DB21",252, 0)
	847	. ; - Get the insti tutional/p rofessiona l charge c omponents.
	848	"RTN","IBJ DB21",253, 0)
	849	. S IBCPT (IBZ,1)=+$ $BICOST^IB CRCI(RIMB, 3,IBDT,"PR OCEDURE",I BZ,"",IBDI V,"",1)
	850	"RTN","IBJ DB21",254, 0)
	851	. S IBCPT (IBZ,2)=+$ $BICOST^IB CRCI(RIMB, 3,IBDT,"PR OCEDURE",I BZ,"",IBDI V,"",2)
	852	"RTN","IBJ DB21",255, 0)
	853	. ;
	854	"RTN","IBJ DB21",256, 0)
	855	. ; - Eli minate com ponents wi thout a ch arge.
	856	"RTN","IBJ DB21",257, 0)
	857	. S IBCPT SUM(IBZ)=+ $G(IBCPT(I BZ,1))+$G( IBCPT(IBZ, 2))
	858	"RTN","IBJ DB21",258, 0)
	859	. I 'IBCP T(IBZ,1) K IBCPT(IBZ ,1)
	860	"RTN","IBJ DB21",259, 0)
	861	. I 'IBCP T(IBZ,2) K IBCPT(IBZ ,2)
	862	"RTN","IBJ DB21",260, 0)
	863	;
	864	"RTN","IBJ DB21",261, 0)
	865	I '$D(IBC PT) S IBRT N=-1 G OPT Q ; Quit i f no billa ble proced ures remai n.
	866	"RTN","IBJ DB21",262, 0)
	867	;
	868	"RTN","IBJ DB21",263, 0)
	869	; - Look at all of the vet's bills for the day an d eliminat e
	870	"RTN","IBJ DB21",264, 0)
	871	; from the array those proc edures tha t have bee n billed.
	872	"RTN","IBJ DB21",265, 0)
	873	S IBXX=0 S IBDAY=$E (IBDT,1,7)
	874	"RTN","IBJ DB21",266, 0)
	875	F S IBXX =$O(^DGCR( 399,"AOPV" ,DFN,IBDAY ,IBXX)) Q: 'IBXX D
	876	"RTN","IBJ DB21",267, 0)
	877	. ;
	878	"RTN","IBJ DB21",268, 0)
	879	. ; - Per form gener al checks on the cla im.
	880	"RTN","IBJ DB21",269, 0)
	881	. S IBDAT A=$$CKBIL^ IBTUBOU(IB XX) Q:IBDA TA=""
	882	"RTN","IBJ DB21",270, 0)
	883	. S IBAUT H=$P($G(IB DATA),U,2)
	884	"RTN","IBJ DB21",271, 0)
	885	. I $G(IB AUTH)<2&($ G(IBAUTH)> 5) Q
	886	"RTN","IBJ DB21",272, 0)
	887	. ; - The episode h as been bi lled. Chec k the reve nue code m ultiple fo r
	888	"RTN","IBJ DB21",273, 0)
	889	. ; all procedure s billed o n the clai m.
	890	"RTN","IBJ DB21",274, 0)
	891	. S IBYY= 0
	892	"RTN","IBJ DB21",275, 0)
	893	. F S IB YY=$O(^DGC R(399,IBXX ,"RC",IBYY )) Q:'IBYY S IBYD=^ (IBYY,0) D
	894	"RTN","IBJ DB21",276, 0)
	895	. . ;
	896	"RTN","IBJ DB21",277, 0)
	897	. . ; - G et the pro cedure cod e,charge t ype and to tal charge s for the revenue co
	898	de.
	899	"RTN","IBJ DB21",278, 0)
	900	. . S IBZ =$P(IBYD,U ,6)
	901	"RTN","IBJ DB21",279, 0)
	902	. . S IBC T=$S($P(IB YD,U,12):$ P(IBYD,U,1 2),1:$P(IB DATA,U,4))
	903	"RTN","IBJ DB21",280, 0)
	904	. . S IBT CHRG=$P(IB YD,U,4)
	905	"RTN","IBJ DB21",281, 0)
	906	. . I 'IB Z!('IBCT) Q ; Can't determine code/char ge type fo r procedur e.
	907	"RTN","IBJ DB21",282, 0)
	908	. . ; Del ete proced ure from u nbilled pr ocedures a rray.
	909	"RTN","IBJ DB21",283, 0)
	910	. . I $G( IBTCHRG)'< $G(IBCPTSU M(IBZ)) K IBCPT(IBZ)
	911	"RTN","IBJ DB21",284, 0)
	912	. . I $D( IBCPT(IBZ, IBCT)) K I BCPT(IBZ,I BCT)
	913	"RTN","IBJ DB21",285, 0)
	914	;
	915	"RTN","IBJ DB21",286, 0)
	916	; - Again , quit if no billabl e procedur es remain.
	917	"RTN","IBJ DB21",287, 0)
	918	I '$D(IBC PT) S IBRT N=-1 G OPT Q
	919	"RTN","IBJ DB21",288, 0)
	920	; - If th ere are bi llable pro cedures re turn TOTAL AMOUNT
	921	"RTN","IBJ DB21",289, 0)
	922	I $D(IBCP T) S (IBZ, IBCT,IBRTN )=0
	923	"RTN","IBJ DB21",290, 0)
	924	F S IBZ= $O(IBCPT(I BZ)) Q:'IB Z D
	925	"RTN","IBJ DB21",291, 0)
	926	.F S IBC T=$O(IBCPT (IBZ,IBCT) ) Q:'IBCT D
	927	"RTN","IBJ DB21",292, 0)
	928	..S IBRTN =IBRTN+IBC PT(IBZ,IBC T)
	929	"RTN","IBJ DB21",293, 0)
	930	I IBRTN=0 S IBRTN=- 1
	931	"RTN","IBJ DB21",294, 0)
	932	;
	933	"RTN","IBJ DB21",295, 0)
	934	OPTQ K IBC PT Q IBRTN
	935	"RTN","IBJ DB21",296, 0)
	936	;
	937	"RTN","IBJ DB21",297, 0)
	938	AVG(EPDT) ; Returns the Averag e Amount o f Inpatien t Professi onal per
	939	"RTN","IBJ DB21",298, 0)
	940	; Number of Episodes for the pr evious 12 months
	941	"RTN","IBJ DB21",299, 0)
	942	N AVG,M,Z
	943	"RTN","IBJ DB21",300, 0)
	944	S AVG=0,M =EPDT\100* 100
	945	"RTN","IBJ DB21",301, 0)
	946	I '$D(^IB E(356.19,M ,1)) S M=$ O(^IBE(356 .19,M),-1) I 'M G QA VG
	947	"RTN","IBJ DB21",302, 0)
	948	S Z=$G(^I BE(356.19, M,1)) I $P (Z,U,12) S AVG=$P(Z, U,11)/$P(Z ,U,12)
	949	"RTN","IBJ DB21",303, 0)
	950	QAVG Q $J( AVG,0,2)
	951	"RTN","IBJ DB21",304, 0)
	952	;
	953	"RTN","IBJ DB21",305, 0)
	954	PRVSPC(EPS ,CLM) ; Re turn the P rovider an d the Spec ialty
	955	"RTN","IBJ DB21",306, 0)
	956	; Input: EPS - Epi sode(1 = I npatient O R 2 = Outp atient)
	957	"RTN","IBJ DB21",307, 0)
	958	; CLM - Poi nter to Cl aim Tracki ng File (# 356)
	959	"RTN","IBJ DB21",308, 0)
	960	; Output: Provider Code (Poin ter to #20 0) ^ Provi der Name ^
	961	"RTN","IBJ DB21",309, 0)
	962	; Specialty Code (Poi nter to #4 0.7 or #45 .7) ^ Spec ialty Name
	963	"RTN","IBJ DB21",310, 0)
	964	;
	965	"RTN","IBJ DB21",311, 0)
	966	N ADM,DFN ,ENC,PRI,P RS,PRV,PRV LST,SPC,ST P,X,VAIN,V AINDT
	967	"RTN","IBJ DB21",312, 0)
	968	;
	969	"RTN","IBJ DB21",313, 0)
	970	S X=$G(^I BT(356,CLM ,0))
	971	"RTN","IBJ DB21",314, 0)
	972	S DFN=$P( X,U,2),ENC =$P(X,U,4) ,ADM=$P(X, U,5),PRS=$ P(X,U,8)
	973	"RTN","IBJ DB21",315, 0)
	974	;
	975	"RTN","IBJ DB21",316, 0)
	976	S (PRV,SP C)="^"
	977	"RTN","IBJ DB21",317, 0)
	978	I EPS=1,A DM D G QP S ; Inpat ient
	979	"RTN","IBJ DB21",318, 0)
	980	.S X=$G(^ DGPM(ADM,0 )),VAINDT= $P(X,U)\1 I 'VAINDT Q
	981	"RTN","IBJ DB21",319, 0)
	982	.D INP^VA DPT S PRV= $G(VAIN(11 )),SPC=$G( VAIN(3))
	983	"RTN","IBJ DB21",320, 0)
	984	.S:PRV="" PRV="^" S :SPC="" SP C="^"
	985	"RTN","IBJ DB21",321, 0)
	986	;
	987	"RTN","IBJ DB21",322, 0)
	988	I EPS=2,E NC D G QP S ; Outpa tient
	989	"RTN","IBJ DB21",323, 0)
	990	.D GETPRV ^SDOE(ENC, "PRVLST")
	991	"RTN","IBJ DB21",324, 0)
	992	.S (X,PRI )=""
	993	"RTN","IBJ DB21",325, 0)
	994	.F S X=$ O(PRVLST(X ),-1) Q:X= ""!PRI D
	995	"RTN","IBJ DB21",326, 0)
	996	..N IBX S PRV=+PRVL ST(X)
	997	"RTN","IBJ DB21",327, 0)
	998	..I $P(PR VLST(X),U, 4)="P" S P RI=1 ; Pri mary provi der
	999	"RTN","IBJ DB21",328, 0)
	1000	..I PRV S PRV=PRV_U _$P($G(^VA (200,+PRV, 0)),U)
	1001	"RTN","IBJ DB21",329, 0)
	1002	..S IBX=$ $GETOE^SDO E(ENC),STP =$P(IBX,U, 3)
	1003	"RTN","IBJ DB21",330, 0)
	1004	..I STP'= "" S SPC=S TP_U_$P($G (^DIC(40.7 ,STP,0)),U )
	1005	"RTN","IBJ DB21",331, 0)
	1006	;
	1007	"RTN","IBJ DB21",332, 0)
	1008	QPS Q (PRV _U_SPC)
	1009	"RTN","IBJ DB21",333, 0)
	1010	;
	1011	"RTN","IBJ DB21",334, 0)
	1012	PHDL ; - P rint the h eader line for the E xcel sprea dsheet
	1013	"RTN","IBJ DB21",335, 0)
	1014	N X
	1015	"RTN","IBJ DB21",336, 0)
	1016	S X="Divi sion^Svc^P atient^SSN ^Insurance ^Episode D t^Dt Enter ed^Dt Lst Edit^"
	1017	"RTN","IBJ DB21",337, 0)
	1018	S X=X_"Ls t Edited B y^Next Adm ission^RNB Cat^Provi der^Specia lty^Entry Amt^Relate
	1019	d Bills^Co mments"
	1020	"RTN","IBJ DB21",338, 0)
	1021	W !,X
	1022	"RTN","IBJ DB21",339, 0)
	1023	Q
	1024	"RTN","IBJ TLA1")
	1025	0^2^B13446 872
	1026	"RTN","IBJ TLA1",1,0)
	1027	IBJTLA1 ;A LB/ARH - T PI ACTIVE BILLS LIST BUILD ;2/ 14/95
	1028	"RTN","IBJ TLA1",2,0)
	1029	;;2.0;INT EGRATED BI LLING;39 ,80,61,51, 153,137,18 3,276,451, 516,530,56 8;21-MAR
	1030	-94;Build 1
	1031	"RTN","IBJ TLA1",3,0)
	1032	;;Per VA Directive 6402, this routine s hould not be modifie d.
	1033	"RTN","IBJ TLA1",4,0)
	1034	;
	1035	"RTN","IBJ TLA1",5,0)
	1036	BLDA ; bui ld active list for t hird party joint inq uiry activ e list
	1037	"RTN","IBJ TLA1",6,0)
	1038	N IBIFN,I BCNT S VAL MCNT=0,IBC NT=0
	1039	"RTN","IBJ TLA1",7,0)
	1040	S IBIFN=0 F S IBIF N=$O(^DGCR (399,"C",D FN,IBIFN)) Q:'IBIFN I $$ACTIV E^IBJTU4(I
	1041	BIFN) W ". " D SCRN
	1042	"RTN","IBJ TLA1",8,0)
	1043	;
	1044	"RTN","IBJ TLA1",9,0)
	1045	I VALMCNT =0 D SET(" ",0),SET( "No Active Bills for this Pati ent",0)
	1046	"RTN","IBJ TLA1",10,0 )
	1047	;
	1048	"RTN","IBJ TLA1",11,0 )
	1049	Q
	1050	"RTN","IBJ TLA1",12,0 )
	1051	;
	1052	"RTN","IBJ TLA1",13,0 )
	1053	SCRN ; add bill to s creen list (IBIFN,DF N must be defined)
	1054	"RTN","IBJ TLA1",14,0 )
	1055	N X,IBY,I BD0,IBDU,I BDM,TYPE,R EJFLAG,IND FLG,IBTYP S X=""
	1056	"RTN","IBJ TLA1",15,0 )
	1057	S IBCNT=I BCNT+1,IBD 0=$G(^DGCR (399,+IBIF N,0)),IBDU =$G(^DGCR( 399,+IBIFN ,"U")),IBD
	1058	M=$G(^DGCR (399,+IBIF N,"M"))
	1059	"RTN","IBJ TLA1",16,0 )
	1060	S IBY=IBC NT,X=$$SET FLD^VALM1( IBY,X,"NUM BER")
	1061	"RTN","IBJ TLA1",17,0 )
	1062	; IB2.0 451 - get EEOB indic ator for b ill # when applicabl e
	1063	"RTN","IBJ TLA1",18,0 )
	1064	S IBPFLAG =$$EEOB(+I BIFN)
	1065	"RTN","IBJ TLA1",19,0 )
	1066	S REJFLAG =+$$BILLRE J^IBJTU6($ P(IBD0,U)) ;IB2.05 30 Add ind icator for rejects
	1067	"RTN","IBJ TLA1",20,0 )
	1068	S INDFLG= $S($G(IBPF LAG)'="":" %",1:"")_$ S(REJFLAG: "c",1:"") S:INDFLG=" " INDFLG="
	1069	"
	1070	"RTN","IBJ TLA1",21,0 )
	1071	S IBY=IND FLG_$P(IBD 0,U,1)_$$E CME^IBTRE( IBIFN),X=$ $SETFLD^VA LM1(IBY,X, "BILL") ;a
	1072	dd EEOB in dicator '% ' to bill number whe n applicab le
	1073	"RTN","IBJ TLA1",22,0 )
	1074	S IBY=$S( $$REF^IBJT U31(+IBIFN ):"r",1:"" ),X=$$SETF LD^VALM1(I BY,X,"REFE R")
	1075	"RTN","IBJ TLA1",23,0 )
	1076	S IBY=$S( $$IB^IBRUT L(+IBIFN,0 ):"*",1:"" ),X=$$SETF LD^VALM1(I BY,X,"HD")
	1077	"RTN","IBJ TLA1",24,0 )
	1078	S IBY=$$D ATE($P(IBD U,U,1)),X= $$SETFLD^V ALM1(IBY,X ,"STFROM")
	1079	"RTN","IBJ TLA1",25,0 )
	1080	S IBY=$$D ATE($P(IBD U,U,2)),X= $$SETFLD^V ALM1(IBY,X ,"STTO")
	1081	"RTN","IBJ TLA1",26,0 )
	1082	;
	1083	"RTN","IBJ TLA1",27,0 )
	1084	S IBY=$P( $$LST^DGMT U(DFN,$P(I BDU,U)),U, 4),IBY=$S( IBY="C":"Y ES",IBY="P ":"PEN",IB
	1085	Y="R":"REQ ",IBY="G": "GMT",1:"N O"),X=$$SE TFLD^VALM1 (IBY,X,"MT ?")
	1086	"RTN","IBJ TLA1",28,0 )
	1087	;S IBY=$$ TYPE($P(IB D0,U,5))_$ $TF($P(IBD 0,U,6))_$S ($P(IBD0,U ,27)=1:"I" ,$P(IBD0,U
	1088	,27)=2:"P" ,1:""),X=$ $SETFLD^VA LM1(IBY,X, "TYPE") ; 516 - baa
	1089	"RTN","IBJ TLA1",29,0 )
	1090	S TYPE=$$ TYPE($P(IB D0,U,5)) I $E(TYPE,2 )="P" S TY PE=$E(TYPE ) ; 516 - baa
	1091	"RTN","IBJ TLA1",30,0 )
	1092	;S IBY=TY PE_"/"_$S( $P(IBD0,U, 27)=1:"I", $P(IBD0,U, 27)=2:"P", 1:""),X=$$ SETFLD^VAL
	1093	M1(IBY,X," TYPE") ; 516 - baa
	1094	"RTN","IBJ TLA1",31,0 )
	1095	S IBY=TYP E_"/"_$S($ P(IBD0,U,2 7)=1:"I",$ P(IBD0,U,2 7)=2:"P",1 :" "),X=$$ SETFLD^VAL
	1096	M1(IBY,X," TYPE") ; 5 68 - lmh r et space i f null
	1097	"RTN","IBJ TLA1",32,0 )
	1098	;
	1099	"RTN","IBJ TLA1",33,0 )
	1100	; Return care type for (I)npa t,(O)utpat , (R)x or (P)rosthet ics - add under TJPI
	1101	screen TY PE column - 568
	1102	"RTN","IBJ TLA1",34,0 )
	1103	S IBTYP=$ $TYP^IBRFN (IBIFN)
	1104	"RTN","IBJ TLA1",35,0 )
	1105	S IBTYP=$ S(IBTYP="" :-1,IBTYP= "PR":"P",I BTYP="PH": "R",1:IBTY P)
	1106	"RTN","IBJ TLA1",36,0 )
	1107	S IBY=IBY _"/"_IBTYP ,X=$$SETFL D^VALM1(IB Y,X,"TYPE" )
	1108	"RTN","IBJ TLA1",37,0 )
	1109	;
	1110	"RTN","IBJ TLA1",38,0 )
	1111	S IBY=" " _$P($$ARST ATA^IBJTU4 (IBIFN),U, 2),X=$$SET FLD^VALM1( IBY,X,"ARS T")
	1112	"RTN","IBJ TLA1",39,0 )
	1113	;
	1114	"RTN","IBJ TLA1",40,0 )
	1115	S IBY=$P( $G(^DGCR(3 99.3,+$P(I BD0,U,7),0 )),U,4),X= $$SETFLD^V ALM1(IBY,X ,"RATE")
	1116	"RTN","IBJ TLA1",41,0 )
	1117	S IBY=$S( $$MINS^IBJ TU31(+IBIF N):"+",1:" "),X=$$SET FLD^VALM1( IBY,X,"CB" )
	1118	"RTN","IBJ TLA1",42,0 )
	1119	S IBY=+$G (^DGCR(399 ,+IBIFN,"M P"))
	1120	"RTN","IBJ TLA1",43,0 )
	1121	I 'IBY,$$ MCRWNR^IBE FUNC($$CUR R^IBCEF2(I BIFN)) S I BY=+$$CURR ^IBCEF2(IB IFN)
	1122	"RTN","IBJ TLA1",44,0 )
	1123	S IBY=$P( $G(^DIC(36 ,+IBY,0)), U,1)
	1124	"RTN","IBJ TLA1",45,0 )
	1125	S X=$$SET FLD^VALM1( IBY,X,"INS UR")
	1126	"RTN","IBJ TLA1",46,0 )
	1127	S IBY=$$B ILL^RCJIBF N2(IBIFN)
	1128	"RTN","IBJ TLA1",47,0 )
	1129	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,1),8,2) ,X,"OAMT")
	1130	"RTN","IBJ TLA1",48,0 )
	1131	S X=$$SET FLD^VALM1( $J(+$P(IBY ,U,3),8,2) ,X,"CAMT")
	1132	"RTN","IBJ TLA1",49,0 )
	1133	D SET(X,I BCNT)
	1134	"RTN","IBJ TLA1",50,0 )
	1135	Q
	1136	"RTN","IBJ TLA1",51,0 )
	1137	;
	1138	"RTN","IBJ TLA1",52,0 )
	1139	DATE(X) ; date in ex ternal for mat
	1140	"RTN","IBJ TLA1",53,0 )
	1141	N Y S Y=" " I X?7N.E S Y=$E(X, 4,5)_"/"_$ E(X,6,7)_" /"_$E(X,2, 3)
	1142	"RTN","IBJ TLA1",54,0 )
	1143	Q Y
	1144	"RTN","IBJ TLA1",55,0 )
	1145	;
	1146	"RTN","IBJ TLA1",56,0 )
	1147	TYPE(X) ; return abb reviated f orm of Bil l Classifi cation (39 9,.05)
	1148	"RTN","IBJ TLA1",57,0 )
	1149	Q $S(X=1: "IP",X=2:" IH",X=3:"O P",X=4:"OH ",1:"")
	1150	"RTN","IBJ TLA1",58,0 )
	1151	;
	1152	"RTN","IBJ TLA1",59,0 )
	1153	TF(X) ; re turn abbre viated for m of Timef rame of Bi ll (399,.0 6)
	1154	"RTN","IBJ TLA1",60,0 )
	1155	Q $S(X=2: "-F",X=3:" -C",X=4:"- L",X'=1:"- O",1:"")
	1156	"RTN","IBJ TLA1",61,0 )
	1157	;
	1158	"RTN","IBJ TLA1",62,0 )
	1159	SET(X,CNT) ; set up list manag er screen array
	1160	"RTN","IBJ TLA1",63,0 )
	1161	S VALMCNT =VALMCNT+1
	1162	"RTN","IBJ TLA1",64,0 )
	1163	S ^TMP("I BJTLA",$J, VALMCNT,0) =X Q:'CNT
	1164	"RTN","IBJ TLA1",65,0 )
	1165	S ^TMP("I BJTLA",$J, "IDX",VALM CNT,+CNT)= ""
	1166	"RTN","IBJ TLA1",66,0 )
	1167	S ^TMP("I BJTLAX",$J ,CNT)=VALM CNT_U_IBIF N
	1168	"RTN","IBJ TLA1",67,0 )
	1169	Q
	1170	"RTN","IBJ TLA1",68,0 )
	1171	;
	1172	"RTN","IBJ TLA1",69,0 )
	1173	EEOB(IBIFN ) ; get pa yment info rmation
	1174	"RTN","IBJ TLA1",70,0 )
	1175	; IB2.0 451 - find an EOB pa yment for a bill
	1176	"RTN","IBJ TLA1",71,0 )
	1177	; input i s the IEN for the bi ll # in fi le #399 an d must be valid,
	1178	"RTN","IBJ TLA1",72,0 )
	1179	; output is the EEO B indicato r '%' if a payment i s found in file #361 .1,
	1180	"RTN","IBJ TLA1",73,0 )
	1181	; exclude EOB type MRA (Medic are).
	1182	"RTN","IBJ TLA1",74,0 )
	1183	N IBPFLAG ,IBVAL,Z
	1184	"RTN","IBJ TLA1",75,0 )
	1185	I $G(IBIF N)=0 Q ""
	1186	"RTN","IBJ TLA1",76,0 )
	1187	I '$O(^IB M(361.1,"B ",IBIFN,0) ) Q "" ; no entry h ere
	1188	"RTN","IBJ TLA1",77,0 )
	1189	I $P($G(^ DGCR(399,I BIFN,0))," ^",13)=1 Q "" ;avoi d 'ENTERED /NOT REVIE WED' statu
	1190	s
	1191	"RTN","IBJ TLA1",78,0 )
	1192	; handle both singl e and mult iple bill entries in file #361 .1
	1193	"RTN","IBJ TLA1",79,0 )
	1194	S Z=0 F S Z=$O(^IB M(361.1,"B ",IBIFN,Z) ) Q:'Z D Q:$G(IBPF LAG)="%"
	1195	"RTN","IBJ TLA1",80,0 )
	1196	. S IBVAL =$G(^IBM(3 61.1,Z,0))
	1197	"RTN","IBJ TLA1",81,0 )
	1198	. S IBPFL AG=$S($P(I BVAL,"^",4 )=1:"",$P( IBVAL,"^", 4)=0:"%",1 :"")
	1199	"RTN","IBJ TLA1",82,0 )
	1200	Q IBPFLAG ; EOB in dicator fo r either 1 st or 3rd payment on bill
	1201	"RTN","IBJ TLA1",83,0 )
	1202	;
	1203	"RTN","IBT RE2")
	1204	0^5^B41201 696
	1205	"RTN","IBT RE2",1,0)
	1206	IBTRE2 ;AL B/AAS - CL AIMS TRACK ING - ACTI ONS ;27-JU N-93
	1207	"RTN","IBT RE2",2,0)
	1208	;;2.0;INT EGRATED BI LLING;23 ,121,249,3 12,315,568 ;21-MAR- 94;Build 1
	1209	"RTN","IBT RE2",3,0)
	1210	;;Per VA Directive 6402, this routine s hould not be modifie d.
	1211	"RTN","IBT RE2",4,0)
	1212	;
	1213	"RTN","IBT RE2",5,0)
	1214	% G EN^IBT RE
	1215	"RTN","IBT RE2",6,0)
	1216	;
	1217	"RTN","IBT RE2",7,0)
	1218	AT ; -- Ad d tracking entry
	1219	"RTN","IBT RE2",8,0)
	1220	I '$$PFSS WARN^IBBSH DWN() S VA LMBCK="R" Q ;IB2.031 2
	1221	"RTN","IBT RE2",9,0)
	1222	D FULL^VA LM1
	1223	"RTN","IBT RE2",10,0)
	1224	N X,Y,DIC ,DA,DR,DD, DO,DIR,DIR UT,DTOUT,D UOUT,IBETY P,IBQUIT,I BTDT,VAIN, VAINDT,IBT
	1225	RN,IBTDTE
	1226	"RTN","IBT RE2",11,0)
	1227	;
	1228	"RTN","IBT RE2",12,0)
	1229	TEST S IBQ UIT=0
	1230	"RTN","IBT RE2",13,0)
	1231	S DIC(0)= "AEQMNZ",D IC="^IBE(3 56.6,",DIC ("S")="I $ P(^(0),U,3 )<3!($P(^( 0),U,3)=4)
	1232	",DIC("A") ="Select T racking Ty pe: " ;56 8
	1233	"RTN","IBT RE2",14,0)
	1234	D ^DIC K DIC S IBET YP=+Y I +Y <0 G ATQ
	1235	"RTN","IBT RE2",15,0)
	1236	W !
	1237	"RTN","IBT RE2",16,0)
	1238	;
	1239	"RTN","IBT RE2",17,0)
	1240	ADM I IBET YP=$O(^IBE (356.6,"AC ",1,0)) D I IBQUIT G ATQ
	1241	"RTN","IBT RE2",18,0)
	1242	.N DIR
	1243	"RTN","IBT RE2",19,0)
	1244	.S DIR("? ")=" "
	1245	"RTN","IBT RE2",20,0)
	1246	.S DIR("? ",1)=" Enter any Date!"
	1247	"RTN","IBT RE2",21,0)
	1248	.S DIR("? ",2)=" "
	1249	"RTN","IBT RE2",22,0)
	1250	.S DIR("? ",3)=" If the pat ient was a n inpatien t on that date the s ystem will
	1251	use the"
	1252	"RTN","IBT RE2",23,0)
	1253	.S DIR("? ",4)=" correct ad mission da te. If yo u are trac king an ad missions a
	1254	t another"
	1255	"RTN","IBT RE2",24,0)
	1256	.S DIR("? ",5)=" facility y ou may ent er that da te. Enter '??' to g et a list
	1257	of the"
	1258	"RTN","IBT RE2",25,0)
	1259	.S DIR("? ",6)=" last 10 ad missions f or this pa tient."
	1260	"RTN","IBT RE2",26,0)
	1261	.S DIR("? ?")="^D LI STA^IBTRE2 0"
	1262	"RTN","IBT RE2",27,0)
	1263	.S DIR(0) ="DO^::AEX TP",DIR("A ")="Admiss ion Date"
	1264	"RTN","IBT RE2",28,0)
	1265	.D ^DIR K DIR S (IB TDT,VAINDT )=+Y I $P( VAINDT,"." ,2)="" S V AINDT=VAIN DT+.24
	1266	"RTN","IBT RE2",29,0)
	1267	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	1268	"RTN","IBT RE2",30,0)
	1269	.; -- che ck for val id admissi on
	1270	"RTN","IBT RE2",31,0)
	1271	.S VA200= "" D INP^V ADPT I VAI N(1)="" D ;look for one day a dmission
	1272	"RTN","IBT RE2",32,0)
	1273	..S IBX=+ $O(^(+$O(^ DGPM("ATID 1",DFN,999 9999-IBTDT )),0)),IBX =+$G(^DGPM (IBX,0))
	1274	"RTN","IBT RE2",33,0)
	1275	..I $E(IB X,1,7)=IBT DT S VAIND T=IBX D IN P^VADPT ;9 999999.999 9999
	1276	"RTN","IBT RE2",34,0)
	1277	..I VAIN( 1) W !!,"W ARNING: Th is appears to be a o ne day sta y."
	1278	"RTN","IBT RE2",35,0)
	1279	.I VAIN(1 )="" D
	1280	"RTN","IBT RE2",36,0)
	1281	..W !!,*7 ,"WARNING: Patient d oes not ap pear to be an inpati ent on thi s date!",!
	1282	"RTN","IBT RE2",37,0)
	1283	..I VAIN( 7)="" S VA IN(7)=IBTD T,Y=IBTDT D D^DIQ S $P(VAIN(7) ,"^",2)=Y
	1284	"RTN","IBT RE2",38,0)
	1285	.;
	1286	"RTN","IBT RE2",39,0)
	1287	.S DIR("? ")="No adm ission was found for this date , enter 'Y es' if you want to a
	1288	dd this an yway, or ' No' if you do not wi sh to trac k this dat e."
	1289	"RTN","IBT RE2",40,0)
	1290	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Admissi on Date "_
	1291	$P(VAIN(7) ,"^",2),DI R("B")="NO "
	1292	"RTN","IBT RE2",41,0)
	1293	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	1294	"RTN","IBT RE2",42,0)
	1295	.I VAIN(1 ) D ADM^IB TUTL(VAIN( 1))
	1296	"RTN","IBT RE2",43,0)
	1297	.I 'VAIN( 1) D OTH^I BTUTL(DFN, IBETYP,IBT DT)
	1298	"RTN","IBT RE2",44,0)
	1299	.Q
	1300	"RTN","IBT RE2",45,0)
	1301	;
	1302	"RTN","IBT RE2",46,0)
	1303	OPT I IBET YP=$O(^IBE (356.6,"AC ",2,0)) D I IBQUIT G ATQ
	1304	"RTN","IBT RE2",47,0)
	1305	.;
	1306	"RTN","IBT RE2",48,0)
	1307	.N DIR,IB SD,IBARRAY
	1308	"RTN","IBT RE2",49,0)
	1309	.;get all possible scheduling data for patient
	1310	"RTN","IBT RE2",50,0)
	1311	.K ^TMP($ J,"SDAMA30 1")
	1312	"RTN","IBT RE2",51,0)
	1313	.S IBARRA Y(4)=DFN,I BARRAY("SO RT")="P",I BARRAY("FL DS")="1;2; 3;10;12",I BSD=$$SDAP
	1314	I^SDAMA301 (.IBARRAY)
	1315	"RTN","IBT RE2",52,0)
	1316	.;
	1317	"RTN","IBT RE2",53,0)
	1318	.S DIR("? ")="Time i s Required ."
	1319	"RTN","IBT RE2",54,0)
	1320	.S DIR("? ",1)=" Enter the Outpatient Visit Dat e."
	1321	"RTN","IBT RE2",55,0)
	1322	.S DIR("? ",2)=" If no sche duled visi t is found you will be given a warning.
	1323	Enter"
	1324	"RTN","IBT RE2",56,0)
	1325	.S DIR("? ",3)=" '??' to ge t a list o f schedule d visits b etween "_$ $DAT1^IBOU
	1326	TL(IBTBDT) _" and "_$ $DAT1^IBOU TL(IBTEDT) _"."
	1327	"RTN","IBT RE2",57,0)
	1328	.I '$D(IB TASS) S DI R("?",4)=" Use th e change d ate range action to change lis
	1329	ting of sc heduled Vi sits."
	1330	"RTN","IBT RE2",58,0)
	1331	.S DIR("? ?")="^D LI STO^IBTRE2 0"
	1332	"RTN","IBT RE2",59,0)
	1333	.S DIR(0) ="DO^::AEX TP",DIR("A ")="Outpat ient Visit Date"
	1334	"RTN","IBT RE2",60,0)
	1335	.D ^DIR K DIR S IBT DT=Y
	1336	"RTN","IBT RE2",61,0)
	1337	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	1338	"RTN","IBT RE2",62,0)
	1339	.;
	1340	"RTN","IBT RE2",63,0)
	1341	.; check scheduling and encou nters file for entri es
	1342	"RTN","IBT RE2",64,0)
	1343	.S X=$D(^ TMP($J,"SD AMA301",DF N,IBTDT))
	1344	"RTN","IBT RE2",65,0)
	1345	.;
	1346	"RTN","IBT RE2",66,0)
	1347	.I 'X,IBS D<0 W !!,* 7,"WARNING : Unable t o look up Visit info rmation fo r this Pat
	1348	ient" X "N IBX S IBX =0 F S IB X=$O(^TMP( $J,""SDAMA 301"",IBX) ) W !?5,IB X,?10,$G(^
	1349	(IBX))"
	1350	"RTN","IBT RE2",67,0)
	1351	.;
	1352	"RTN","IBT RE2",68,0)
	1353	.I 'X,IBS D S Y=$O(^ TMP($J,"SD AMA301",DF N,$P(IBTDT ,"."))) I $P(IBTDT," .")=$P(Y,"
	1354	.") S IBTD T=Y,X=1
	1355	"RTN","IBT RE2",69,0)
	1356	.;
	1357	"RTN","IBT RE2",70,0)
	1358	.; if non say so
	1359	"RTN","IBT RE2",71,0)
	1360	.I 'X,IBS D'=-1 W !! ,*7,"WARNI NG: No Vis it informa tion for t his Patien t for this
	1361	date.",!
	1362	"RTN","IBT RE2",72,0)
	1363	.;
	1364	"RTN","IBT RE2",73,0)
	1365	.; ask if okay to a dd entry.
	1366	"RTN","IBT RE2",74,0)
	1367	.S Y=IBTD T D D^DIQ S IBTDTE=Y
	1368	"RTN","IBT RE2",75,0)
	1369	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Visit D ate "_IBTD
	1370	TE,DIR("B" )="NO"
	1371	"RTN","IBT RE2",76,0)
	1372	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	1373	"RTN","IBT RE2",77,0)
	1374	.D OPT^IB TUTL1(DFN, IBETYP,IBT DT,$P($G(^ TMP($J,"SD AMA301",DF N,IBTDT)), "^",12))
	1375	"RTN","IBT RE2",78,0)
	1376	.K ^TMP($ J,"SDAMA30 1")
	1377	"RTN","IBT RE2",79,0)
	1378	.Q
	1379	"RTN","IBT RE2",80,0)
	1380	;
	1381	"RTN","IBT RE2",81,0)
	1382	SCH I IBET YP=$O(^IBE (356.6,"AC ",5,0)) D I IBQUIT G ATQ
	1383	"RTN","IBT RE2",82,0)
	1384	.N DIR
	1385	"RTN","IBT RE2",83,0)
	1386	.S DIR("? ")=" "
	1387	"RTN","IBT RE2",84,0)
	1388	.S DIR("? ",1)=" Enter date of the sc heduled ad mission."
	1389	"RTN","IBT RE2",85,0)
	1390	.S DIR("? ",2)=" If you use the sched uled admis sion packa ge to sche dule admis
	1391	sions"
	1392	"RTN","IBT RE2",86,0)
	1393	.S DIR("? ",3)=" you may en ter '??' t o get a li st of sche duled admi ssions bet
	1394	ween"
	1395	"RTN","IBT RE2",87,0)
	1396	.S DIR("? ",4)=" "_$$DAT1^I BOUTL(IBTB DT)_" and "_$$DAT1^I BOUTL(IBTE DT)_". Us
	1397	e the chan ge date ra nge action "
	1398	"RTN","IBT RE2",88,0)
	1399	.S DIR("? ",5)=" to change listing of scheduled admission s."
	1400	"RTN","IBT RE2",89,0)
	1401	.S DIR("? ",5)=" This shoul d be a fut ure schedu led admiss ion."
	1402	"RTN","IBT RE2",90,0)
	1403	.S DIR(0) ="DO^::AEX T",DIR("A" )="Schedul ed Admissi on Date"
	1404	"RTN","IBT RE2",91,0)
	1405	.S DIR("? ?")="^D LI STS^IBTRE2 0"
	1406	"RTN","IBT RE2",92,0)
	1407	.D ^DIR K DIR S IBT DT=+Y
	1408	"RTN","IBT RE2",93,0)
	1409	.I $D(DIR UT)!($P(IB TDT,".")'? 7N) S IBQU IT=1 Q
	1410	"RTN","IBT RE2",94,0)
	1411	.; ask if okay to a dd entry.
	1412	"RTN","IBT RE2",95,0)
	1413	.D FINDS^ IBTRE20
	1414	"RTN","IBT RE2",96,0)
	1415	.S Y=IBTD T D D^DIQ S IBTDTE=Y
	1416	"RTN","IBT RE2",97,0)
	1417	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Schedul ed Adm. Da
	1418	te "_IBTDT E,DIR("B") ="NO"
	1419	"RTN","IBT RE2",98,0)
	1420	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	1421	"RTN","IBT RE2",99,0)
	1422	.I IBTDT\ 1'>DT S VA INDT=IBTDT \1+.24 D I NP^VADPT I $G(VAIN(1 )) D Q
	1423	"RTN","IBT RE2",100,0 )
	1424	..W !!,"P atient an inpatient on this da te, using inpatient admission. "
	1425	"RTN","IBT RE2",101,0 )
	1426	..D ADM^I BTUTL(VAIN (1))
	1427	"RTN","IBT RE2",102,0 )
	1428	.D SCH^IB TUTL2(DFN, IBTDT)
	1429	"RTN","IBT RE2",103,0 )
	1430	.Q
	1431	"RTN","IBT RE2",104,0 )
	1432	;
	1433	"RTN","IBT RE2",105,0 )
	1434	PRO I IBET YP=$O(^IBE (356.6,"AC ",3,0)) D I IBQUIT G ATQ
	1435	"RTN","IBT RE2",106,0 )
	1436	.;
	1437	"RTN","IBT RE2",107,0 )
	1438	.N DIR,IB SD,IBARRAY ,C
	1439	"RTN","IBT RE2",108,0 )
	1440	.;get all possible scheduling data for patient
	1441	"RTN","IBT RE2",109,0 )
	1442	.S IBARRA Y(0)=DFN
	1443	"RTN","IBT RE2",110,0 )
	1444	.;
	1445	"RTN","IBT RE2",111,0 )
	1446	.D LISTP^ IBTRE20
	1447	"RTN","IBT RE2",112,0 )
	1448	.W !
	1449	"RTN","IBT RE2",113,0 )
	1450	.I C=0 S IBQUIT=1 Q
	1451	"RTN","IBT RE2",114,0 )
	1452	.S DIR("? ")="Prosth etics"
	1453	"RTN","IBT RE2",115,0 )
	1454	.S DIR(0) ="N",DIR(" A")="Prost hetics Ent ry"
	1455	"RTN","IBT RE2",116,0 )
	1456	.D ^DIR K DIR
	1457	"RTN","IBT RE2",117,0 )
	1458	.I $D(DIR UT) S IBQU IT=1 Q
	1459	"RTN","IBT RE2",118,0 )
	1460	.I Y>0 S RC=IBARRAY (Y),IBDEL= $P(RC,U,3) ,IBPRO=$P( RC,U,4),PI EN=$P(RC,U ,1),IBPR=$
	1461	P(RC,U,2), IBDELO=$P( RC,U,5)
	1462	"RTN","IBT RE2",119,0 )
	1463	.;
	1464	"RTN","IBT RE2",120,0 )
	1465	.; ask if okay to a dd entry.
	1466	"RTN","IBT RE2",121,0 )
	1467	.S Y=IBDE L D D^DIQ S IBTDTE=Y
	1468	"RTN","IBT RE2",122,0 )
	1469	.S DIR(0) ="Y",DIR(" A")="Okay to Add Cla ims Tracki ng entry f or Prosthe tics "_IBP
	1470	RO_" for " _IBDELO,DI R("B")="NO "
	1471	"RTN","IBT RE2",123,0 )
	1472	.D ^DIR K DIR I $D( DIRUT)!('Y ) S IBQUIT =1 Q
	1473	"RTN","IBT RE2",124,0 )
	1474	.S PCOV=$ $PTCOV^IBC NSU3(DFN,I BDEL,"PROS THETICS")
	1475	"RTN","IBT RE2",125,0 )
	1476	.S IBMARK ="" I 'PCO V S IBMARK ="NO PROST HETIC COVE RAGE"
	1477	"RTN","IBT RE2",126,0 )
	1478	.D PRO^IB TUTL1(DFN, IBDEL,PIEN ,IBMARK)
	1479	"RTN","IBT RE2",127,0 )
	1480	.Q
	1481	"RTN","IBT RE2",128,0 )
	1482	;
	1483	"RTN","IBT RE2",129,0 )
	1484	I $G(IBQU IT) G ATQ
	1485	"RTN","IBT RE2",130,0 )
	1486	I $D(IBTA SS) Q ; l eave prema turely if from assig n reason
	1487	"RTN","IBT RE2",131,0 )
	1488	;
	1489	"RTN","IBT RE2",132,0 )
	1490	I $G(IBTR N) N IBTAT RK S IBTAT RK=1 D QE1 ^IBTRE1
	1491	"RTN","IBT RE2",133,0 )
	1492	;
	1493	"RTN","IBT RE2",134,0 )
	1494	D BLD^IBT RE
	1495	"RTN","IBT RE2",135,0 )
	1496	;
	1497	"RTN","IBT RE2",136,0 )
	1498	ATQ Q:$D(I BTASS)
	1499	"RTN","IBT RE2",137,0 )
	1500	I $G(IBQU IT) W !,"N othing Add ed",! D PA USE^VALM1
	1501	"RTN","IBT RE2",138,0 )
	1502	S VALMBCK ="R"
	1503	"RTN","IBT RE2",139,0 )
	1504	Q
	1505	"RTN","IBT RE20")
	1506	0^6^B20248 565
	1507	"RTN","IBT RE20",1,0)
	1508	IBTRE20 ;A LB/AAS - C LAIMS TRAC KING EXECU TABLE HELP ;13-OCT-9 3
	1509	"RTN","IBT RE20",2,0)
	1510	;;2.0;INT EGRATED BI LLING;40 ,91,249; 21-MAR-94; Build 1
	1511	"RTN","IBT RE20",3,0)
	1512	;;Per VHA Directive 10-93-142 , this rou tine shoul d not be m odified.
	1513	"RTN","IBT RE20",4,0)
	1514	;
	1515	"RTN","IBT RE20",5,0)
	1516	;
	1517	"RTN","IBT RE20",6,0)
	1518	LISTA ; -- list inpa tient admi ssions for patient
	1519	"RTN","IBT RE20",7,0)
	1520	N C,I,J,N ,X,Y,IBX
	1521	"RTN","IBT RE20",8,0)
	1522	K ^TMP("I BM",$J)
	1523	"RTN","IBT RE20",9,0)
	1524	Q:'$D(DFN )
	1525	"RTN","IBT RE20",10,0 )
	1526	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
	1527	)) S D=^(0 ),C=C+1,^T MP("IBM",$ J,C)=N_"^" _D
	1528	"RTN","IBT RE20",11,0 )
	1529	;
	1530	"RTN","IBT RE20",12,0 )
	1531	I C=0 W ! !,"No Admi ssions to Choose Fro m." Q
	1532	"RTN","IBT RE20",13,0 )
	1533	;
	1534	"RTN","IBT RE20",14,0 )
	1535	W !!,"CHO OSE FROM:" F IBI=1:1 :10 Q:'$D( ^TMP("IBM" ,$J,IBI)) D WRA
	1536	"RTN","IBT RE20",15,0 )
	1537	K ^TMP("I BM",$J)
	1538	"RTN","IBT RE20",16,0 )
	1539	Q
	1540	"RTN","IBT RE20",17,0 )
	1541	;
	1542	"RTN","IBT RE20",18,0 )
	1543	WRA S IBX= $P(^TMP("I BM",$J,IBI ),"^",2,20 ),Y=+IBX X ^DD("DD")
	1544	"RTN","IBT RE20",19,0 )
	1545	W !," ",Y
	1546	"RTN","IBT RE20",20,0 )
	1547	W ?27,$S( '$D(^DG(40 5.1,+$P(IB X,"^",4),0 )):"",$P(^ (0),"^",7) ]"":$P(^(0 ),"^",7),1
	1548	:$E($P(^(0 ),"^",1),1 ,20))
	1549	"RTN","IBT RE20",21,0 )
	1550	;
	1551	"RTN","IBT RE20",22,0 )
	1552	W ?50,"TO : ",$E($P ($G(^DIC(4 2,+$P(IBX, "^",6),0)) ,"^"),1,17 )
	1553	"RTN","IBT RE20",23,0 )
	1554	I $D(^DG( 405.4,+$P( IBX,"^",7) ,0)) W " [ ",$E($P(^( 0),"^",1), 1,10),"]"
	1555	"RTN","IBT RE20",24,0 )
	1556	I $P(IBX, "^",18)=9 W !?23,"FR OM: ",$P( $G(^DIC(4, +$P(IBX,"^ ",5),0))," ^")
	1557	"RTN","IBT RE20",25,0 )
	1558	Q
	1559	"RTN","IBT RE20",26,0 )
	1560	;
	1561	"RTN","IBT RE20",27,0 )
	1562	LISTO ; -- list outp atient app ointments
	1563	"RTN","IBT RE20",28,0 )
	1564	N C,I,J,N ,X,Y,IBX,I BI,IBDT
	1565	"RTN","IBT RE20",29,0 )
	1566	; assumes ^TMP($J," SDAMA301", DFN,IBTDT) defined a nd IBSD(re sult from SD)
	1567	"RTN","IBT RE20",30,0 )
	1568	Q:'$D(DFN )
	1569	"RTN","IBT RE20",31,0 )
	1570	;
	1571	"RTN","IBT RE20",32,0 )
	1572	I IBSD<0 W !!,"Unab le to look -up Outpat ient Visit s to Choos e From." D Q
	1573	"RTN","IBT RE20",33,0 )
	1574	. N IBX F S IBX=$O (^TMP($J," SDAMA301", IBX)) Q:'I BX W !?5, IBX,?10,$G (^(IBX))
	1575	"RTN","IBT RE20",34,0 )
	1576	;
	1577	"RTN","IBT RE20",35,0 )
	1578	I IBSD=0 W !!,"No O utpatient Visits to Choose Fro m." Q
	1579	"RTN","IBT RE20",36,0 )
	1580	;
	1581	"RTN","IBT RE20",37,0 )
	1582	W !!,"CHO OSE FROM:" S IBI=0,I BDT=$G(IBT BDT) F S IBDT=$O(^T MP($J,"SDA MA301",DFN
	1583	,IBDT)),IB I=IBI+1 Q: 'IBDT!(IBI >12) D WR O
	1584	"RTN","IBT RE20",38,0 )
	1585	Q
	1586	"RTN","IBT RE20",39,0 )
	1587	;
	1588	"RTN","IBT RE20",40,0 )
	1589	WRO N IBSD D,Y
	1590	"RTN","IBT RE20",41,0 )
	1591	S Y=IBDT X ^DD("DD" ) W !," ",Y
	1592	"RTN","IBT RE20",42,0 )
	1593	S IBSDD=$ G(^TMP($J, "SDAMA301" ,DFN,IBDT) )
	1594	"RTN","IBT RE20",43,0 )
	1595	W ?27,"Cl inic: ",$P ($P(IBSDD, "^",2),";" ,2),?60," Type: ",$E ($P($P(IBS DD,"^",10)
	1596	,";",2),1, 12)
	1597	"RTN","IBT RE20",44,0 )
	1598	;
	1599	"RTN","IBT RE20",45,0 )
	1600	S IBSDD=$ P(IBSDD,"^ ",3) I $L( IBSDD),$P( IBSDD,";") '="R" W !, ?10," [Sta tus: ",$P(
	1601	IBSDD,";", 2),"]"
	1602	"RTN","IBT RE20",46,0 )
	1603	Q
	1604	"RTN","IBT RE20",47,0 )
	1605	;
	1606	"RTN","IBT RE20",48,0 )
	1607	LISTS ; -- list sche duled admi ssions
	1608	"RTN","IBT RE20",49,0 )
	1609	N C,I,J,N ,X,Y,IBX,I BI
	1610	"RTN","IBT RE20",50,0 )
	1611	K ^TMP("I BM",$J)
	1612	"RTN","IBT RE20",51,0 )
	1613	Q:'$D(DFN )
	1614	"RTN","IBT RE20",52,0 )
	1615	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(^
	1616	DGS(41.1,+ I,0)) I $P (D,"^",2)' <IBTBDT,$P (D,"^",2)' >IBTEDT S C=C+1,^TMP ("IBM",$J,
	1617	C)=I_"^"_D
	1618	"RTN","IBT RE20",53,0 )
	1619	;
	1620	"RTN","IBT RE20",54,0 )
	1621	I C=0 W ! !,"No Sche duled Admi ssions to Choose Fro m." Q
	1622	"RTN","IBT RE20",55,0 )
	1623	;
	1624	"RTN","IBT RE20",56,0 )
	1625	W !!,"CHO OSE FROM:" F IBI=1:1 :12 Q:'$D( ^TMP("IBM" ,$J,IBI)) D WRS
	1626	"RTN","IBT RE20",57,0 )
	1627	K ^TMP("I BM",$J)
	1628	"RTN","IBT RE20",58,0 )
	1629	Q
	1630	"RTN","IBT RE20",59,0 )
	1631	;
	1632	"RTN","IBT RE20",60,0 )
	1633	WRS S IBX= $P($G(^TMP ("IBM",$J, IBI)),"^", 2,20),Y=$P (IBX,"^",2 ) X ^DD("D D")
	1634	"RTN","IBT RE20",61,0 )
	1635	W !," ",Y
	1636	"RTN","IBT RE20",62,0 )
	1637	W ?27," S pec: ",$E( $P($G(^DIC (45.7,+$P( IBX,"^",9) ,0)),"^"), 1,25)
	1638	"RTN","IBT RE20",63,0 )
	1639	;
	1640	"RTN","IBT RE20",64,0 )
	1641	W ?58," T o: ",$E($P ($G(^DIC(4 2,+$P(IBX, "^",8),0)) ,"^"),1,16 )
	1642	"RTN","IBT RE20",65,0 )
	1643	Q
	1644	"RTN","IBT RE20",66,0 )
	1645	;
	1646	"RTN","IBT RE20",67,0 )
	1647	FINDS ; -- match a s cheduled a dmission
	1648	"RTN","IBT RE20",68,0 )
	1649	Q:'$D(DFN )
	1650	"RTN","IBT RE20",69,0 )
	1651	Q:'$D(IBT DT)
	1652	"RTN","IBT RE20",70,0 )
	1653	N I,J
	1654	"RTN","IBT RE20",71,0 )
	1655	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:
	1656	IBTDT=J I $P(IBTDT, ".")=$P(J, ".") S IBT DT=J Q
	1657	"RTN","IBT RE20",72,0 )
	1658	Q
	1659	"RTN","IBT RE20",73,0 )
	1660	;
	1661	"RTN","IBT RE20",74,0 )
	1662	ID ; -- wr ite out id entifier f or entry, called by ^dd(356,0, "id","writ e")
	1663	"RTN","IBT RE20",75,0 )
	1664	N IBOE,IB OE0
	1665	"RTN","IBT RE20",76,0 )
	1666	S IBOE=$P (^(0),"^", 4),IBOE0=$ $SCE^IBSDU (+IBOE) I IBOE,$P(IB OE0,U,4) W ?58,"["_$
	1667	E($P($G(^S C(+$P(IBOE 0,U,4),0)) ,U),1,20), "]"
	1668	"RTN","IBT RE20",77,0 )
	1669	Q
	1670	"RTN","IBT RE20",78,0 )
	1671	;
	1672	"RTN","IBT RE20",79,0 )
	1673	PRINT ; pa tch 40, cu stom look up. Input : IBX -- 0th node in file # 356.
	1674	"RTN","IBT RE20",80,0 )
	1675	Q:$D(IBX) [0
	1676	"RTN","IBT RE20",81,0 )
	1677	N NAM,EPI S,EVENT,DI SPL,CLIN
	1678	"RTN","IBT RE20",82,0 )
	1679	S NAM=$E( $P($G(^DPT (+$P(IBX,U ,2),0)),U) ,1,22)
	1680	"RTN","IBT RE20",83,0 )
	1681	S EPIS=$P ($P(IBX,U, 6),".")
	1682	"RTN","IBT RE20",84,0 )
	1683	I EPIS S EPIS=$E(EP IS,4,5)_"- "_$E(EPIS, 6,7)_"-"_$ E(EPIS,2,3 )
	1684	"RTN","IBT RE20",85,0 )
	1685	S EVENT=$ E($P($G(^I BE(356.6,+ $P(IBX,U,1 8),0)),U), 1,5)
	1686	"RTN","IBT RE20",86,0 )
	1687	S DISPL=$ $EXPAND^IB TRE(356,.0 7,$P(IBX,U ,7))
	1688	"RTN","IBT RE20",87,0 )
	1689	S CLIN=+$ $SCE^IBSDU (+$P(IBX," ^",4),4)
	1690	"RTN","IBT RE20",88,0 )
	1691	I CLIN S DISPL="["_ $E($P($G(^ SC(CLIN,0) ),U),1,22) _"]"
	1692	"RTN","IBT RE20",89,0 )
	1693	W ?13,NAM ,?37,EPIS, ?47,EVENT, ?54,DISPL
	1694	"RTN","IBT RE20",90,0 )
	1695	Q
	1696	"RTN","IBT RE20",91,0 )
	1697	;
	1698	"RTN","IBT RE20",92,0 )
	1699	LISTP ; -- list inpa tient admi ssions for patient
	1700	"RTN","IBT RE20",93,0 )
	1701	N I,X,Y,P ,P1,P2,DDT ,DDTO,IBX
	1702	"RTN","IBT RE20",94,0 )
	1703	K ^TMP("I BPRO",$J)
	1704	"RTN","IBT RE20",95,0 )
	1705	Q:'$D(DFN )
	1706	"RTN","IBT RE20",96,0 )
	1707	S (I,C)=0
	1708	"RTN","IBT RE20",97,0 )
	1709	F S I=$O (^RMPR(660 ,"C",DFN,I )) Q:'I I $D(^RMPR( 660,I,0)) S D=^(0) D
	1710	"RTN","IBT RE20",98,0 )
	1711	.S SDT=$P (D,U,12) I SDT<IBTBD T!(SDT>IBT EDT) Q
	1712	"RTN","IBT RE20",99,0 )
	1713	.I $O(^IB T(356,"APR O",I,0)) Q
	1714	"RTN","IBT RE20",100, 0)
	1715	.S C=C+1, ^TMP("IBPR O",$J,C)=I _"^"_D
	1716	"RTN","IBT RE20",101, 0)
	1717	;
	1718	"RTN","IBT RE20",102, 0)
	1719	I C=0 W ! !,"No Pros thetics to Choose Fr om." Q
	1720	"RTN","IBT RE20",103, 0)
	1721	;
	1722	"RTN","IBT RE20",104, 0)
	1723	W !!,"CHO OSE FROM:" F IBI=1:1 :10 Q:'$D( ^TMP("IBPR O",$J,IBI) ) D WRP
	1724	"RTN","IBT RE20",105, 0)
	1725	K ^TMP("I BPRO",$J)
	1726	"RTN","IBT RE20",106, 0)
	1727	Q
	1728	"RTN","IBT RE20",107, 0)
	1729	;
	1730	"RTN","IBT RE20",108, 0)
	1731	WRP S IBX= $P(^TMP("I BPRO",$J,I BI),"^",1, 20),N=$P(I BX,U,1),P= $P(IBX,U,7 ),P1=$P(^R
	1732	MPR(661,P, 0),U,1),P2 =$P(^PRC(4 41,P1,0),U ,2)
	1733	"RTN","IBT RE20",109, 0)
	1734	S DDT=$P( IBX,U,13), DDTO=$$FMT E^XLFDT(DD T,"2DZ"),I BARRAY(IBI )=N_U_P_U_ DDT_U_P2_U
	1735	_DDTO
	1736	"RTN","IBT RE20",110, 0)
	1737	S TP=$P(I BX,U,4),TY PE=$S(TP=" I":"INITIA L ISSUE",T P="R":"REP LACE",TP=" S":"SPARE"
	1738	,TP="X":"R EPAIR",1:" RENTAL")
	1739	"RTN","IBT RE20",111, 0)
	1740	W !," ", IBI,?10,$E (P2,1,25), ?40,TYPE,? 58,"DELIVE RED:",DDTO
	1741	"RTN","IBT RE20",112, 0)
	1742	;
	1743	"RTN","IBT RE20",113, 0)
	1744	Q
	1745	"RTN","IBT RKR5")
	1746	0^4^B36509 050
	1747	"RTN","IBT RKR5",1,0)
	1748	IBTRKR5 ;A LB/AAS - C LAIMS TRAC KING - ADD /TRACK PRO STHETICS ; 13-JAN-94
	1749	"RTN","IBT RKR5",2,0)
	1750	;;2.0;INT EGRATED BI LLING;13 ,260,312,3 39,389,474 ,498,568 ;21-MAR-94 ;Build 1
	1751	"RTN","IBT RKR5",3,0)
	1752	;;Per VA Directive 6402, this routine s hould not be modifie d.
	1753	"RTN","IBT RKR5",4,0)
	1754	;
	1755	"RTN","IBT RKR5",5,0)
	1756	% ; -- ent ry point f or nightly backgroun d job
	1757	"RTN","IBT RKR5",6,0)
	1758	N IBTSBDT ,IBTSEDT
	1759	"RTN","IBT RKR5",7,0)
	1760	S IBTSBDT =$$FMADD^X LFDT(DT,$S ($E(DT,6,7 )=10:-730, 1:-20))-.1 ;IB2.0 568
	1761	"RTN","IBT RKR5",8,0)
	1762	S IBTSEDT =$$FMADD^X LFDT(DT,-3 )+.9
	1763	"RTN","IBT RKR5",9,0)
	1764	D EN1
	1765	"RTN","IBT RKR5",10,0 )
	1766	Q
	1767	"RTN","IBT RKR5",11,0 )
	1768	;
	1769	"RTN","IBT RKR5",12,0 )
	1770	EN ; -- en try point to ask dat e range
	1771	"RTN","IBT RKR5",13,0 )
	1772	N IBSWINF O S IBSWIN FO=$$SWSTA T^IBBAPI() ; IB2.0312
	1773	"RTN","IBT RKR5",14,0 )
	1774	N IBBDT,I BEDT,IBTSB DT,IBTSEDT ,IBTALK
	1775	"RTN","IBT RKR5",15,0 )
	1776	S IBTALK= 1
	1777	"RTN","IBT RKR5",16,0 )
	1778	I '$P($G( ^IBE(350.9 ,1,6)),"^" ,4) W !!," I'm sorry, Tracking of Prosthe tics is cu
	1779	rrently tu rned off." G ENQ
	1780	"RTN","IBT RKR5",17,0 )
	1781	W !!!,"Se lect the D ate Range of Prosthe tics to Ad d to Claim s Tracking .",!
	1782	"RTN","IBT RKR5",18,0 )
	1783	D DATE^IB OUTL
	1784	"RTN","IBT RKR5",19,0 )
	1785	I IBBDT<1 !(IBEDT<1) G ENQ
	1786	"RTN","IBT RKR5",20,0 )
	1787	S IBTSBDT =IBBDT,IBT SEDT=IBEDT
	1788	"RTN","IBT RKR5",21,0 )
	1789	;
	1790	"RTN","IBT RKR5",22,0 )
	1791	; -- chec k selected dates ; IB2.0312
	1792	"RTN","IBT RKR5",23,0 )
	1793	; Do NOT PROCESS on VistA if Start or E nd>=Switch Eff Dt ; CCR-930
	1794	"RTN","IBT RKR5",24,0 )
	1795	I +IBSWIN FO,((IBTSB DT+1)>$P(I BSWINFO,"^ ",2))!((IB TSEDT+1)>$ P(IBSWINFO ,"^",2)) D
	1796	G EN
	1797	"RTN","IBT RKR5",25,0 )
	1798	.W !!,"T he Begin O R End Date CANNOT be on or aft er the PFS S Effectiv e date"
	1799	"RTN","IBT RKR5",26,0 )
	1800	.W ": ", $$FMTE^XLF DT($P(IBSW INFO,"^",2 ))
	1801	"RTN","IBT RKR5",27,0 )
	1802	;
	1803	"RTN","IBT RKR5",28,0 )
	1804	S IBTRKR= $G(^IBE(35 0.9,1,6))
	1805	"RTN","IBT RKR5",29,0 )
	1806	; start d ate can't be before parameters
	1807	"RTN","IBT RKR5",30,0 )
	1808	I +IBTRKR ,IBTSBDT<+ IBTRKR S I BTSBDT=IBT RKR W !!," Begin date is before Claims Tr
	1809	acking Sta rt Date, c hanged to ",$$DAT1^I BOUTL(IBTS BDT)
	1810	"RTN","IBT RKR5",31,0 )
	1811	; -- end date into future
	1812	"RTN","IBT RKR5",32,0 )
	1813	I IBTSEDT >$$FMADD^X LFDT(DT,-3 ) W !!,"I' ll automat ically cha nge the en d date to
	1814	3 days pri or to the date queue d to run."
	1815	"RTN","IBT RKR5",33,0 )
	1816	;
	1817	"RTN","IBT RKR5",34,0 )
	1818	W !!!,"I' m going to automatic ally queue this off and send y ou a"
	1819	"RTN","IBT RKR5",35,0 )
	1820	W !,"mail message w hen comple te.",!
	1821	"RTN","IBT RKR5",36,0 )
	1822	S ZTIO="" ,ZTRTN="EN 1^IBTRKR5" ,ZTSAVE("I B*")="",ZT DESC="IB - Add Prost hetics to
	1823	Claims Tra cking"
	1824	"RTN","IBT RKR5",37,0 )
	1825	D ^%ZTLOA D I $G(ZTS K) K ZTSK W !,"Reque st Queued"
	1826	"RTN","IBT RKR5",38,0 )
	1827	ENQ K ZTSK ,ZTIO,ZTSA VE,ZTDESC, ZTRTN
	1828	"RTN","IBT RKR5",39,0 )
	1829	D HOME^%Z IS
	1830	"RTN","IBT RKR5",40,0 )
	1831	Q
	1832	"RTN","IBT RKR5",41,0 )
	1833	;
	1834	"RTN","IBT RKR5",42,0 )
	1835	EN1 ; -- a dd prostet hics to cl aims track ing file
	1836	"RTN","IBT RKR5",43,0 )
	1837	N I,J,X,Y ,IBTRKR,IB DT,DFN,IBD ATA,IBCNT, IBCNT1,IBC NT2,IBDTS
	1838	"RTN","IBT RKR5",44,0 )
	1839	N IBSWINF O S IBSWIN FO=$$SWSTA T^IBBAPI() ; IB2.0312
	1840	"RTN","IBT RKR5",45,0 )
	1841	;
	1842	"RTN","IBT RKR5",46,0 )
	1843	; -- chec k paramete rs
	1844	"RTN","IBT RKR5",47,0 )
	1845	S IBTRKR= $G(^IBE(35 0.9,1,6))
	1846	"RTN","IBT RKR5",48,0 )
	1847	G:'$P(IBT RKR,"^",5) EN1Q ; qu it if prot hetics tra cking off
	1848	"RTN","IBT RKR5",49,0 )
	1849	I +IBTRKR ,IBTSBDT<+ IBTRKR S I BTSBDT=IBT RKR ; star t date can 't be befo re paramet
	1850	ers
	1851	"RTN","IBT RKR5",50,0 )
	1852	;
	1853	"RTN","IBT RKR5",51,0 )
	1854	; -- user s can queu e into fut ure, make sure dates not after date run
	1855	"RTN","IBT RKR5",52,0 )
	1856	I IBTSEDT >$$FMADD^X LFDT(DT,-3 ) S IBMESS ="(Selecte d end date of "_$$DA T1^IBOUTL(
	1857	IBTSEDT)_" automatic ally chang ed to "_$$ DAT1^IBOUT L($$FMADD^ XLFDT(DT,- 3))_".)",I
	1858	BTSEDT=$$F MADD^XLFDT (DT,-3)
	1859	"RTN","IBT RKR5",53,0 )
	1860	;
	1861	"RTN","IBT RKR5",54,0 )
	1862	;S IBPRTY P=$O(^IBE( 356.6,"AC" ,3,0)) ; t his is the event typ e pointer for prosth
	1863	etics
	1864	"RTN","IBT RKR5",55,0 )
	1865	;
	1866	"RTN","IBT RKR5",56,0 )
	1867	; -- cnt= total cou nt, cnt1=c ount added nsc, cnt2 =count of pending
	1868	"RTN","IBT RKR5",57,0 )
	1869	S (IBCNT, IBCNT1,IBC NT2)=0
	1870	"RTN","IBT RKR5",58,0 )
	1871	S (IBDTS, IBDT)=IBTS BDT-.0001
	1872	"RTN","IBT RKR5",59,0 )
	1873	;
	1874	"RTN","IBT RKR5",60,0 )
	1875	; loop tw ice, once for shipmn et date (n ew search) , and once for
	1876	"RTN","IBT RKR5",61,0 )
	1877	; deliver y date (ol d search) for backwa rd compati bility.
	1878	"RTN","IBT RKR5",62,0 )
	1879	F S IBDT =$O(^RMPR( 660,"AF",I BDT)) Q:'I BDT!(IBDT> IBTSEDT) D
	1880	"RTN","IBT RKR5",63,0 )
	1881	.; Do NOT PROCES S on VistA if IBDT>= Switch Eff Date ; CCR-930
	1882	"RTN","IBT RKR5",64,0 )
	1883	.I +IB SWINFO,(IB DT+1)>$P(I BSWINFO,"^ ",2) Q ; IB2.0312
	1884	"RTN","IBT RKR5",65,0 )
	1885	.S IBD A=0 F S I BDA=$O(^RM PR(660,"AF ",IBDT,IBD A)) Q:'IBD A D PRCHK
	1886	"RTN","IBT RKR5",66,0 )
	1887	;
	1888	"RTN","IBT RKR5",67,0 )
	1889	; reset d ate and do old check
	1890	"RTN","IBT RKR5",68,0 )
	1891	S IBDT=IB DTS
	1892	"RTN","IBT RKR5",69,0 )
	1893	F S IBDT =$O(^RMPR( 660,"CT",I BDT)) Q:'I BDT!(IBDT> IBTSEDT) D
	1894	"RTN","IBT RKR5",70,0 )
	1895	.; Do NOT PROCES S on VistA if IBDT>= Switch Eff Date ; CCR-930
	1896	"RTN","IBT RKR5",71,0 )
	1897	.I +IB SWINFO,(IB DT+1)>$P(I BSWINFO,"^ ",2) Q ; IB2.0312
	1898	"RTN","IBT RKR5",72,0 )
	1899	.S IBD A="" F S IBDA=$O(^R MPR(660,"C T",IBDT,IB DA)) Q:'IB DA D PRCH K
	1900	"RTN","IBT RKR5",73,0 )
	1901	;
	1902	"RTN","IBT RKR5",74,0 )
	1903	I $G(IBTA LK) D BULL ;^IBTRKR5 1
	1904	"RTN","IBT RKR5",75,0 )
	1905	EN1Q I $D( ZTQUEUED) S ZTREQ="@ "
	1906	"RTN","IBT RKR5",76,0 )
	1907	Q
	1908	"RTN","IBT RKR5",77,0 )
	1909	;
	1910	"RTN","IBT RKR5",78,0 )
	1911	PRCHK ; -- check and add item
	1912	"RTN","IBT RKR5",79,0 )
	1913	N IBE,IBP ,IBDX,IBRM ARK,IBARR, IBT,IBINS
	1914	"RTN","IBT RKR5",80,0 )
	1915	S IBCNT=I BCNT+1,IBR MARK=""
	1916	"RTN","IBT RKR5",81,0 )
	1917	I '$D(ZTQ UEUED),($G (IBTALK)) W "."
	1918	"RTN","IBT RKR5",82,0 )
	1919	;
	1920	"RTN","IBT RKR5",83,0 )
	1921	S IBDATA= $G(^RMPR(6 60,+IBDA,0 )) Q:IBDAT A=""
	1922	"RTN","IBT RKR5",84,0 )
	1923	S DFN=$P( IBDATA,"^" ,2) Q:'DFN
	1924	"RTN","IBT RKR5",85,0 )
	1925	; quit if non billa ble PSAS H CPCS code is found
	1926	"RTN","IBT RKR5",86,0 )
	1927	I $$IBPHP (IBDA) Q
	1928	"RTN","IBT RKR5",87,0 )
	1929	D CL^SDCO 21(DFN,IBD T,"",.IBAR R)
	1930	"RTN","IBT RKR5",88,0 )
	1931	;
	1932	"RTN","IBT RKR5",89,0 )
	1933	; -- chec ks copied from rmprb il v2.0 /f eb 2, 1994
	1934	"RTN","IBT RKR5",90,0 )
	1935	Q:'$D(^RM PR(660,+IB DA,"AM"))
	1936	"RTN","IBT RKR5",91,0 )
	1937	Q:$P(^RMP R(660,+IBD A,0),U,9)= ""!($P(^(0 ),U,12)="" )!($P(^(0) ,U,14)="V" )!($P(^(0)
	1938	,U,2)="")! ($P(^(0),U ,15)="*")
	1939	"RTN","IBT RKR5",92,0 )
	1940	;Q:($P(^R MPR(660,+I BDA,"AM"), U,3)=2)!($ P(^("AM"), U,3)=3)
	1941	"RTN","IBT RKR5",93,0 )
	1942	;
	1943	"RTN","IBT RKR5",94,0 )
	1944	;
	1945	"RTN","IBT RKR5",95,0 )
	1946	I $O(^IBT (356,"APRO ",IBDA,0)) G PRCHKQ ; already in claims tracking
	1947	"RTN","IBT RKR5",96,0 )
	1948	;
	1949	"RTN","IBT RKR5",97,0 )
	1950	; -- see if trackin g only ins ured and p t is insur ed
	1951	"RTN","IBT RKR5",98,0 )
	1952	I $P(IBTR KR,"^",5)= 1,'$$INSUR ED^IBCNS1( DFN,IBDT) G PRCHKQ ; patient n ot insured
	1953	"RTN","IBT RKR5",99,0 )
	1954	;
	1955	"RTN","IBT RKR5",100, 0)
	1956	; -- if c lasificati ons requir ed, check exemptions
	1957	"RTN","IBT RKR5",101, 0)
	1958	I '$D(IBA RR) G CLQ
	1959	"RTN","IBT RKR5",102, 0)
	1960	S IBE=0 F IBP=1:1:4 S IBDX(IB P)=$G(^RMP R(660,+IBD A,"BA"_IBP )) I IBDX( IBP) S IBE
	1961	=1
	1962	"RTN","IBT RKR5",103, 0)
	1963	I 'IBE S IBRMARK="N EEDS SC DE TERMINATIO N" G CLQ ; no ICD no de in RMPR , use old
	1964	method of determinin g status
	1965	"RTN","IBT RKR5",104, 0)
	1966	S IBE=0 F S IBE=$O (IBARR(IBE )) Q:'IBE! ($L($G(IBR MARK))) F IBP=1:1:4 Q:$L($G(I
	1967	BRMARK)) I IBDX(IBP ) S IBRMAR K=$S($P(IB DX(IBP),"^ ",IBE+1):$ P($T(CLTXT +IBE),";",
	1968	3),$P(IBDX (IBP),"^", IBE+1)=0:" ",1:"NEEDS SC DETERM INATION")
	1969	"RTN","IBT RKR5",105, 0)
	1970	;
	1971	"RTN","IBT RKR5",106, 0)
	1972	S PROCOV= 0
	1973	"RTN","IBT RKR5",107, 0)
	1974	S PROCOV= +$$PTCOV^I BCNSU3(DFN ,IBDT,"PRO STHETICS") ;IB2.0 568
	1975	"RTN","IBT RKR5",108, 0)
	1976	;
	1977	"RTN","IBT RKR5",109, 0)
	1978	CLQ ; -- o k to add t o tracking module
	1979	"RTN","IBT RKR5",110, 0)
	1980	I 'PROCOV S IBRMARK ="NO PROST HETIC COVE RAGE"
	1981	"RTN","IBT RKR5",111, 0)
	1982	D PRO^IBT UTL1(DFN,I BDT,IBDA,$ G(IBRMARK) ) I '$D(ZT QUEUED),$G (IBTALK) W "+"
	1983	"RTN","IBT RKR5",112, 0)
	1984	I $G(IBRM ARK)'="" S IBCNT2=IB CNT2+1
	1985	"RTN","IBT RKR5",113, 0)
	1986	I $G(IBRM ARK)="" S IBCNT1=IBC NT1+1
	1987	"RTN","IBT RKR5",114, 0)
	1988	K VAEL,VA ,IBDATA,DF N,X,Y
	1989	"RTN","IBT RKR5",115, 0)
	1990	PRCHKQ Q
	1991	"RTN","IBT RKR5",116, 0)
	1992	;
	1993	"RTN","IBT RKR5",117, 0)
	1994	IBPHP(IBDA ) ; non bi llable PSA S HCPCS co des
	1995	"RTN","IBT RKR5",118, 0)
	1996	; input-p atient ite m in #660
	1997	"RTN","IBT RKR5",119, 0)
	1998	; output- value if t he code wi th the fir st 2 chars in the st ring is fo und
	1999	"RTN","IBT RKR5",120, 0)
	2000	N IBPSAS, IBPIN S IB PIN=""
	2001	"RTN","IBT RKR5",121, 0)
	2002	S IBPSAS= ",BA,DI,DL ,EC,EV,FE, HI,HN,HS,N R,RE,SB,SI ,TH,TM,TR, VA,"
	2003	"RTN","IBT RKR5",122, 0)
	2004	; return the pointe r^descript ion^the co de (#661.1 ,.01)
	2005	"RTN","IBT RKR5",123, 0)
	2006	S IBPIN=$ $PIN^IBATU TL(+IBDA)
	2007	"RTN","IBT RKR5",124, 0)
	2008	S IBPIN=$ P(IBPIN,U, 3)
	2009	"RTN","IBT RKR5",125, 0)
	2010	S IBPIN=$ F(IBPSAS," ,"_$E(IBPI N,1,2)_"," )
	2011	"RTN","IBT RKR5",126, 0)
	2012	Q IBPIN
	2013	"RTN","IBT RKR5",127, 0)
	2014	;
	2015	"RTN","IBT RKR5",128, 0)
	2016	BULL ; -- send bulle tin
	2017	"RTN","IBT RKR5",129, 0)
	2018	;
	2019	"RTN","IBT RKR5",130, 0)
	2020	S XMSUB=" Prosthetic Items add ed to Clai ms Trackin g Complete "
	2021	"RTN","IBT RKR5",131, 0)
	2022	S IBT(1)= "The proce ss to auto matically add Prosth etic Items has succe ssfully co
	2023	mpleted."
	2024	"RTN","IBT RKR5",132, 0)
	2025	S IBT(1.1 )=""
	2026	"RTN","IBT RKR5",133, 0)
	2027	S IBT(2)= " Start D ate: "_$$D AT1^IBOUTL (IBTSBDT)
	2028	"RTN","IBT RKR5",134, 0)
	2029	S IBT(3)= " End D ate: "_$$D AT1^IBOUTL (IBTSEDT)
	2030	"RTN","IBT RKR5",135, 0)
	2031	I $D(IBME SS) S IBT( 3.1)=IBMES S
	2032	"RTN","IBT RKR5",136, 0)
	2033	S IBT(4)= ""
	2034	"RTN","IBT RKR5",137, 0)
	2035	S IBT(5)= " Total Pr osthetics Items chec ked: "_$G( IBCNT)
	2036	"RTN","IBT RKR5",138, 0)
	2037	S IBT(6)= "Total NSC Prostheti c Items Ad ded: "_$G( IBCNT1)
	2038	"RTN","IBT RKR5",139, 0)
	2039	S IBT(7)= " Total SC Prostheti c Items Ad ded: "_$G( IBCNT2)
	2040	"RTN","IBT RKR5",140, 0)
	2041	S IBT(8)= ""
	2042	"RTN","IBT RKR5",141, 0)
	2043	S IBT(9)= "*The item s added as SC requir e determin ation and editing to be billed
	2044	"
	2045	"RTN","IBT RKR5",142, 0)
	2046	D SEND^IB TRKR31
	2047	"RTN","IBT RKR5",143, 0)
	2048	BULLQ Q
	2049	"RTN","IBT RKR5",144, 0)
	2050	;
	2051	"RTN","IBT RKR5",145, 0)
	2052	CLTXT ; cl assificati on text fo r reason n ot billabl e
	2053	"RTN","IBT RKR5",146, 0)
	2054	;;AGENT O RANGE
	2055	"RTN","IBT RKR5",147, 0)
	2056	;;IONIZIN G RADIATIO N
	2057	"RTN","IBT RKR5",148, 0)
	2058	;;SC TREA TMENT
	2059	"RTN","IBT RKR5",149, 0)
	2060	;;SOUTHWE ST ASIA
	2061	"RTN","IBT RKR5",150, 0)
	2062	;;MILITAR Y SEXUAL T RAUMA
	2063	"RTN","IBT RKR5",151, 0)
	2064	;;HEAD/NE CK CANCER
	2065	"RTN","IBT RKR5",152, 0)
	2066	;;COMBAT VETERAN
	2067	"RTN","IBY 568PO")
	2068	0^^B320446 65
	2069	"RTN","IBY 568PO",1,0 )
	2070	IBY568PO ; ALB/BAA - Post insta ll routine for patch 568; 5-AU G-16
	2071	"RTN","IBY 568PO",2,0 )
	2072	;;2.0;INT EGRATED BI LLING;56 8;21-MAR -94;Build 1
	2073	"RTN","IBY 568PO",3,0 )
	2074	;;Per VA Directive 6402, this routine s hould not be modifie d.
	2075	"RTN","IBY 568PO",4,0 )
	2076	;
	2077	"RTN","IBY 568PO",5,0 )
	2078	Q
	2079	"RTN","IBY 568PO",6,0 )
	2080	; This po st-install routine w ill create a new sec urity key
	2081	"RTN","IBY 568PO",7,0 )
	2082	; called IB PARAMET ER EDIT.
	2083	"RTN","IBY 568PO",8,0 )
	2084	; It will be added to two men u options/
	2085	"RTN","IBY 568PO",9,0 )
	2086	;
	2087	"RTN","IBY 568PO",10, 0)
	2088	; The new IB PARAME TER EDIT k ey will be used to l ock
	2089	"RTN","IBY 568PO",11, 0)
	2090	;
	2091	"RTN","IBY 568PO",12, 0)
	2092	; IB T EDIT TRA CKING PARA METERS
	2093	"RTN","IBY 568PO",13, 0)
	2094	; IB J MCCR SIT E PARAMETE RS
	2095	"RTN","IBY 568PO",14, 0)
	2096	;
	2097	"RTN","IBY 568PO",15, 0)
	2098	; This ro utine will add PROST HETICS to Plan Cover age Limita tions file
	2099	"RTN","IBY 568PO",16, 0)
	2100	;
	2101	"RTN","IBY 568PO",17, 0)
	2102	; This ro utine will add three new rate types.
	2103	"RTN","IBY 568PO",18, 0)
	2104	;
	2105	"RTN","IBY 568PO",19, 0)
	2106	; HU MANITARIAN REIMB. IN S.
	2107	"RTN","IBY 568PO",20, 0)
	2108	; IN ELIGIBLE R EIMB. INS.
	2109	"RTN","IBY 568PO",21, 0)
	2110	; DE NTAL REIMB . INS
	2111	"RTN","IBY 568PO",22, 0)
	2112	;
	2113	"RTN","IBY 568PO",23, 0)
	2114	;
	2115	"RTN","IBY 568PO",24, 0)
	2116	START ; CA LL SECTION S
	2117	"RTN","IBY 568PO",25, 0)
	2118	D MES^XPD UTL(" Sta rting post -install f or IB2.0 528")
	2119	"RTN","IBY 568PO",26, 0)
	2120	D NEWKEY
	2121	"RTN","IBY 568PO",27, 0)
	2122	D KEYS
	2123	"RTN","IBY 568PO",28, 0)
	2124	D RIDER
	2125	"RTN","IBY 568PO",29, 0)
	2126	D PLAN
	2127	"RTN","IBY 568PO",30, 0)
	2128	;D ADDRT
	2129	"RTN","IBY 568PO",31, 0)
	2130	; Complet ion messag e
	2131	"RTN","IBY 568PO",32, 0)
	2132	D MES^XPD UTL(" Fin ished post -install f or IB2.0 568")
	2133	"RTN","IBY 568PO",33, 0)
	2134	Q
	2135	"RTN","IBY 568PO",34, 0)
	2136	;
	2137	"RTN","IBY 568PO",35, 0)
	2138	NEWKEY ; a dd new IB PARAMETER EDIT key
	2139	"RTN","IBY 568PO",36, 0)
	2140	N IBFLAG, IBOPT,DA,D IC,DIE,DR, X
	2141	"RTN","IBY 568PO",37, 0)
	2142	D MES^XPD UTL("New s ecurity ke y...")
	2143	"RTN","IBY 568PO",38, 0)
	2144	; Check w hether the key exist s
	2145	"RTN","IBY 568PO",39, 0)
	2146	I +$O(^DI C(19.1,"B" ,"IB PARAM ETER EDIT" ,0)) D MES ^XPDUTL("K ey IB PARA METER EDIT
	2147	already e xists.") Q
	2148	"RTN","IBY 568PO",40, 0)
	2149	;
	2150	"RTN","IBY 568PO",41, 0)
	2151	S IBKEY=" IB PARAMET ER EDIT"
	2152	"RTN","IBY 568PO",42, 0)
	2153	S IBIEN=$ $FIND1^DIC (19.1,""," X",IBKEY," ","","IBER R") I $D(I BERR) D BM ES^XPDUTL(
	2154	"Error in NEWKEY-IBY 568PO - Ca nnot add " _IBKEY_" t o Security Key file #19.1") Q
	2155	"RTN","IBY 568PO",43, 0)
	2156	I +IBIEN D BMES^XPD UTL("Secur ity Key "_ IBKEY_" al ready exis ts in the SECURITY K
	2157	EY file - not added" ) Q
	2158	"RTN","IBY 568PO",44, 0)
	2159	;
	2160	"RTN","IBY 568PO",45, 0)
	2161	D BMES^XP DUTL("Addi ng new sec urity key, "_IBKEY_" , to the S ECURITY KE Y file")
	2162	"RTN","IBY 568PO",46, 0)
	2163	S DIC(0)= "LMX"
	2164	"RTN","IBY 568PO",47, 0)
	2165	S IBARR(1 9.1,"+1,", .01)=IBKEY
	2166	"RTN","IBY 568PO",48, 0)
	2167	D UPDATE^ DIE("E","I BARR","IBI EN","IBERR ")
	2168	"RTN","IBY 568PO",49, 0)
	2169	;
	2170	"RTN","IBY 568PO",50, 0)
	2171	I '+$G(IB IEN(1))!($ D(IBERR)) D Q
	2172	"RTN","IBY 568PO",51, 0)
	2173	. D BMES^ XPDUTL("A problem wa s encounte red trying to add se curity key , "_IBKEY)
	2174	"RTN","IBY 568PO",52, 0)
	2175	. D BMES^ XPDUTL("Th e entry mu st be adde d manually to the SE CURITY KEY file")
	2176	"RTN","IBY 568PO",53, 0)
	2177	;
	2178	"RTN","IBY 568PO",54, 0)
	2179	D BMES^XP DUTL("Secu rity Key, "_IBKEY_", was succe ssfully ad ded to the SECURITY
	2180	KEY file")
	2181	"RTN","IBY 568PO",55, 0)
	2182	Q
	2183	"RTN","IBY 568PO",56, 0)
	2184	;
	2185	"RTN","IBY 568PO",57, 0)
	2186	KEYS ; Add security key to IBT EDIT TRAC KING PARAM ETERS and IBJ MCCR S ITE PARAME
	2187	TERS
	2188	"RTN","IBY 568PO",58, 0)
	2189	N IBFLAG, IBOPT,DA,D IC,DIE,DR, X
	2190	"RTN","IBY 568PO",59, 0)
	2191	D MES^XPD UTL("New s ecurity ke y...")
	2192	"RTN","IBY 568PO",60, 0)
	2193	; Check w hether the key exist s
	2194	"RTN","IBY 568PO",61, 0)
	2195	I '+$O(^D IC(19.1,"B ","IB PARA METER EDIT ",0)) D ME S^XPDUTL(" Key IB PAR AMETER EDI
	2196	T does not exists.") Q
	2197	"RTN","IBY 568PO",62, 0)
	2198	;
	2199	"RTN","IBY 568PO",63, 0)
	2200	; Lock op tions IBT EDIT TRACK ING PARAME TERS and I BJ MCCR SI TE PARAMET ERS with n
	2201	ewly named key
	2202	"RTN","IBY 568PO",64, 0)
	2203	D MES^XPD UTL("Assig ning key t o options. ..")
	2204	"RTN","IBY 568PO",65, 0)
	2205	F IBOPT=" IBT EDIT T RACKING PA RAMETERS", "IBJ MCCR SITE PARAM ETERS" D
	2206	"RTN","IBY 568PO",66, 0)
	2207	.S DA=$$F IND1^DIC(1 9,"","X",I BOPT,"B")
	2208	"RTN","IBY 568PO",67, 0)
	2209	.I 'DA D MES^XPDUTL ("Option " _IBOPT_" n ot found i n system." ) Q
	2210	"RTN","IBY 568PO",68, 0)
	2211	.S DIE=19 ,DR="3///I B PARAMETE R EDIT"
	2212	"RTN","IBY 568PO",69, 0)
	2213	.L +^DIC( 19,DA):0 I $T D ^DIE L -^DIC(1 9,DA) Q
	2214	"RTN","IBY 568PO",70, 0)
	2215	.D MES^XP DUTL("Opti on "_IBOPT _" is lock ed by anot her user." )
	2216	"RTN","IBY 568PO",71, 0)
	2217	Q
	2218	"RTN","IBY 568PO",72, 0)
	2219	;
	2220	"RTN","IBY 568PO",73, 0)
	2221	RIDER ; ad d Prostihe tic Insura nce Rider (355.6)
	2222	"RTN","IBY 568PO",74, 0)
	2223	N IBNAME, DD,DO,DLAY GO,DIC,X,Y ,IBDA,IBAR R,IBX
	2224	"RTN","IBY 568PO",75, 0)
	2225	D MES^XPD UTL(" ")
	2226	"RTN","IBY 568PO",76, 0)
	2227	;
	2228	"RTN","IBY 568PO",77, 0)
	2229	S IBNAME= "PROSTHETI CS COVERAG E"
	2230	"RTN","IBY 568PO",78, 0)
	2231	I $O(^IBE (355.6,"B" ,IBNAME,0) ) S IBX=" - "_IBNA ME_" Insur ance Rider (355.6) a
	2232	lready exi sts, no ch ange" D ME S^XPDUTL(I BX) Q
	2233	"RTN","IBY 568PO",79, 0)
	2234	;
	2235	"RTN","IBY 568PO",80, 0)
	2236	K DD,DO S DLAYGO=35 5.6,DIC="^ IBE(355.6, ",DIC(0)=" L",X=IBNAM E D FILE^D ICN K DIC
	2237	I Y<1 K X, Y Q
	2238	"RTN","IBY 568PO",81, 0)
	2239	S IBDA=+Y
	2240	"RTN","IBY 568PO",82, 0)
	2241	;
	2242	"RTN","IBY 568PO",83, 0)
	2243	S IBX=" * "_IBNAM E_" Insura nce Rider (355.6) ad ded" D MES ^XPDUTL(IB X)
	2244	"RTN","IBY 568PO",84, 0)
	2245	Q
	2246	"RTN","IBY 568PO",85, 0)
	2247	;
	2248	"RTN","IBY 568PO",86, 0)
	2249	PLAN ; add Prostheti cs to Plan Coverage Limitation s
	2250	"RTN","IBY 568PO",87, 0)
	2251	D MES^XPD UTL("Addin g PROSTHET ICS to Pla n Coverage Limitatio ns file... ")
	2252	"RTN","IBY 568PO",88, 0)
	2253	N IBA,IBN AME,IBRIDE R,IBRDA,IB X,DD,DO,DL AYGO,DIC,X ,Y,IBDA,DI E,DA,DR,IB FILE
	2254	"RTN","IBY 568PO",89, 0)
	2255	S IBFILE= " Plan Lim itation Ca tegory (#3 55.31) "
	2256	"RTN","IBY 568PO",90, 0)
	2257	;
	2258	"RTN","IBY 568PO",91, 0)
	2259	S IBNAME= "PROSTHETI CS",IBRIDE R="PROSTHE TICS COVER AGE"
	2260	"RTN","IBY 568PO",92, 0)
	2261	S IBRDA=$ O(^IBE(355 .6,"B",IBR IDER,0)) I 'IBRDA S IBX=" - "_IBNAME_I BFILE_"Not
	2262	Added, Ri der Missin g" D MES^X PDUTL(IBX) Q
	2263	"RTN","IBY 568PO",93, 0)
	2264	;
	2265	"RTN","IBY 568PO",94, 0)
	2266	I $O(^IBE (355.31,"B ",IBNAME,0 )) S IBA=" >> "_IBNAM E_IBFILE_" exists, no change" D
	2267	MES^XPDUT L(IBA) Q
	2268	"RTN","IBY 568PO",95, 0)
	2269	;
	2270	"RTN","IBY 568PO",96, 0)
	2271	K DD,DO S DLAYGO=35 5.31,DIC=" ^IBE(355.3 1,",DIC(0) ="L",X=IBN AME D FILE ^DICN K DI
	2272	C S IBDA=+ Y I Y<1 K X,Y Q
	2273	"RTN","IBY 568PO",97, 0)
	2274	;
	2275	"RTN","IBY 568PO",98, 0)
	2276	S DIE="^I BE(355.31, ",DA=+IBDA ,DR=".02// //Prosthet ics covera ge" D ^DIE K DIE,DA,
	2277	DR,X,Y
	2278	"RTN","IBY 568PO",99, 0)
	2279	;
	2280	"RTN","IBY 568PO",100 ,0)
	2281	D MES^XPD UTL("Prost hetics Pla n added... ..")
	2282	"RTN","IBY 568PO",101 ,0)
	2283	;
	2284	"RTN","IBY 568PO",102 ,0)
	2285	Q
	2286	"RTN","IBY 568PO",103 ,0)
	2287	;
	2288	"RTN","IBY 568PO",104 ,0)
	2289	ADDRT ; Ad d Rate Typ es (399.3)
	2290	"RTN","IBY 568PO",105 ,0)
	2291	N IBA,IBC NT,IBI,REC ,IBFN,IBAR ,DD,DO,DLA YGO,DIC,DI E,DA,DR,X, Y S IBCNT= 0
	2292	"RTN","IBY 568PO",106 ,0)
	2293	;
	2294	"RTN","IBY 568PO",107 ,0)
	2295	D MES^XPD UTL(" -> Adding new Rate T ype entrie s to file 399.3 ..." )
	2296	"RTN","IBY 568PO",108 ,0)
	2297	;
	2298	"RTN","IBY 568PO",109 ,0)
	2299	F RTNUM=1 9,20,21 D
	2300	"RTN","IBY 568PO",110 ,0)
	2301	. S REC=$ P($T(@RTNU M),";",3,9 9)
	2302	"RTN","IBY 568PO",111 ,0)
	2303	. S RTNAM =$P(REC,U, 1)
	2304	"RTN","IBY 568PO",112 ,0)
	2305	. I $O(^D GCR(399.3, "B",RTNAM, 0)) Q
	2306	"RTN","IBY 568PO",113 ,0)
	2307	. S IBAR= $P(IBLN,U, 6),IBAR=$O (^PRCA(430 .2,"B",IBA R,0)) I 'I BAR D Q
	2308	"RTN","IBY 568PO",114 ,0)
	2309	.. D MES^ XPDUTL(" * *** AR Cat egory "_IB AR_" does not exist, RT not ad ded.")
	2310	"RTN","IBY 568PO",115 ,0)
	2311	. ;
	2312	"RTN","IBY 568PO",116 ,0)
	2313	. K DD,DO S DLAYGO= 399.3,DIC= "^DGCR(399 .3,",DIC(0 )="L",X=RT NAM D FILE ^DICN K DI
	2314	C I Y<1 K X,Y Q
	2315	"RTN","IBY 568PO",117 ,0)
	2316	. S IBFN= +Y,IBCNT=I BCNT+1
	2317	"RTN","IBY 568PO",118 ,0)
	2318	. ;
	2319	"RTN","IBY 568PO",119 ,0)
	2320	. S DR=". 02////"_$P (REC,U,2)_ ";.04////" _$P(REC,U, 4)_";.05// //"_$P(REC ,U,5)_";.0
	2321	6////"_IBA R_";.07/// /"_$P(REC, U,7)_";.08 ////"_$P(R EC,U,8)_"; .09////"_$ P(REC,U,9)
	2322	_":1////"_ $P(REC,U,1 0)_";"
	2323	"RTN","IBY 568PO",120 ,0)
	2324	. S DIE=" ^DGCR(399. 3,",DA=+IB FN D ^DIE K DIE,DA,D R,X,Y
	2325	"RTN","IBY 568PO",121 ,0)
	2326	;
	2327	"RTN","IBY 568PO",122 ,0)
	2328	RTQ S IBA( 1)=" >> "_IBCNT _" Rate Ty pes added (399.3)... "
	2329	"RTN","IBY 568PO",123 ,0)
	2330	D MES^XPD UTL(.IBA)
	2331	"RTN","IBY 568PO",124 ,0)
	2332	Q
	2333	"RTN","IBY 568PO",125 ,0)
	2334	;
	2335	"RTN","IBY 568PO",126 ,0)
	2336	;RATE TYP ES TO BE A DDED
	2337	"RTN","IBY 568PO",127 ,0)
	2338	19 ;;HUMAN ITARIAN RE IMB. INS.; HUMANITARI AN REIMB. INS.;0;HUM REIM;1;EM ERGENCY/HU
	2339	MANITARIAN REIMB.;i; 1;0;1
	2340	"RTN","IBY 568PO",128 ,0)
	2341	20 ;;INELI GIBLE REIM B. INS.;IN ELIGIBLE R EIMB. INS. ;0;INE REI M;1;INELIG IBLE HOSP.
	2342	REIMB.;i; 1;0;1
	2343	"RTN","IBY 568PO",129 ,0)
	2344	21 ;;DENTA L REIMB. I NS;DENTAL REIMB. INS ;0;DEN REI M;1;EMERGE NCY/HUMANI TARIAN REI
	2345	MB.;i;1;0; 1
	2346	"VER")
	2347	8.0^22.0
	2348	END
	2349	END