IBCRCC	;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996
	;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347,370**;21-MAR-94;Build 5
	;;Per VHA Directive 2004-038, this routine should not be modified.
	;
	; ITMCHG and RATECHG are basic item/set/rate charge functions, IBCRCI contains more standard callable functions
	;
ITMCHG(CS,ITEM,EVDT,MOD,ARR)	; get the base unit charges for a specific item, given a charge set, item and date
	; this is the primary function to get an item charge and works for all Charge Methods, given an Item
	; returns ARR = count of items in array ^ total charge for item ^ total base charge
	;         ARR(x) = charge item IFN (if any) ^ rev code (if any) ^ $ charge ^ $ base charge
	; checks Item effective and inactive dates, modifier match, and only sets array if the charge is non-zero
	; each item will be passed back separately in the array, no combination of charges
	;
	N IBCSBR,IBEVDT,IBEFDT,IBXREF,IBITEM,IBDA,IBLN,IBCHRG,IBITMFND K ARR S ARR=0
	S CS=+$G(CS),IBEVDT=$S(+$G(EVDT):+EVDT,1:DT),IBITEM=+$G(ITEM),MOD=$G(MOD) I 'CS!'IBITEM Q
	S IBCSBR=$$CSBR^IBCRU3(CS)
	;
	; va cost
	I $P(IBCSBR,U,5)=2 D  Q  ; va cost
	. I $P(IBCSBR,U,1)["PROSTHETICS" S IBCHRG=$$PICOST(IBITEM)  I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q
	. I $P(IBCSBR,U,1)["PRESCRIPTION" S IBCHRG=$$RXCOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q
	;
	; all others - have Charge Item entries
	;
	; find most recent Charge Item for the item, search until modifiers match (only BI=CPT should have mods defined)
	S IBXREF="AIVDTS"_CS,IBITMFND=0
	S IBEFDT=-(IBEVDT+.01) F  S IBEFDT=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT)) Q:'IBEFDT  D  Q:IBITMFND
	. S IBDA=0 F  S IBDA=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT,IBDA)) Q:'IBDA  D
	.. S IBLN=$G(^IBA(363.2,IBDA,0))
	.. I +$P(IBLN,U,7)'=+MOD Q  ; charge item modifier does not match modifier passed in
	.. S IBITMFND=1 ; item found
	.. I +$P(IBLN,U,4),+$P(IBLN,U,4)<IBEVDT Q  ; charge is inactive on event date
	.. I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8))
	Q
	;
SETARR(CI,RVCD,CHRG,ARR,CHRGB)	; set charges into an array, does not allow zero charge, a new entry is created each time,
	; no attempt to combine like items, the new item charge is added to any that may already be in the array 
	; returns ARR = count of items in array ^ total charge for item
	;         ARR(x) = charge item IFN (if any) ^ item rev code (if any) ^ $ charge
	;
	N CNT,TCHRG,TCHRGB
	S CNT=+$G(ARR)+1,TCHRG=$P($G(ARR),U,2)+$G(CHRG) I +$G(CHRGB) S TCHRGB=+$P($G(ARR),U,3)+CHRGB
	I +$G(CHRG) S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB)
	Q
	;
PICOST(PI)	; returns (PI=ptr 362.5): total VA cost of an item (660,14) ^ quantity (660,5) from prosthetics ^ bill IFN
	;
	N IBPIP,IBLN,IBX,IBIFN S (IBPIP,IBX)=0
	I +$G(PI) S IBLN=$G(^IBA(362.5,+PI,0)),IBPIP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2)
	I +IBPIP S IBLN=$G(^RMPR(660,+IBPIP,0)) I IBLN'="" S IBX=$P(IBLN,U,16)_U_$P(IBLN,U,7)_U_IBIFN
	Q IBX
	;
RATECHG(RS,CHG,EVDT,FEE)	; returns modifed item charge based on rate schedule:  check effective dates, apply adjustment
	; adjusted amount ^ comment (if there is an adjustment)
	; if FEE passed by reference, returns disp fee^admin fee
	;
	N IBX,IBRS0,IBRS10,IBEFDT,IBINADT,IBRTY,X S IBRTY=""
	S IBX=+$G(CHG),IBRS0=$G(^IBE(363,+$G(RS),0)),IBRS10=$G(^IBE(363,+$G(RS),10))
	S EVDT=$S(+$G(EVDT):EVDT,1:DT),IBEFDT=$P(IBRS0,U,5),IBINADT=$P(IBRS0,U,6)
	I +IBEFDT>EVDT!(+IBINADT&(IBINADT<EVDT)) S IBX=0
	I +IBX,IBRS10'="" S X=IBX X IBRS10 S IBX=X,IBRTY="^Rate Schedule Adjustment ("_$J(CHG,"",2)_")"
	S FEE=$P($G(^IBE(363,+$G(RS),1)),"^",1,2)
	Q IBX_IBRTY
	;
RXCOST(RX)	; returns (RX=ptr 362.4): VA Cost of an Rx - Per Unit Cost ^ bill IFN
	; w/ Per Unit Cost = RX (Unit Price of Drug - 52,17) or Drug (Price Per Dispense Unit 50,16) cost
	;
	N IBRXP,IBDGP,IBLN,IBX,IBIFN S (IBRXP,IBX)=0
	I +$G(RX) S IBLN=$G(^IBA(362.4,+RX,0)),IBRXP=$P(IBLN,U,5),IBDGP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2)
	I +IBRXP S IBX=$$FILE^IBRXUTL(IBRXP,17)_U_IBIFN
	I 'IBRXP,+IBDGP D DATA^IBRXUTL(+IBDGP) S IBLN=$G(^TMP($J,"IBDRUG",0)) I IBLN'="" S IBX=$G(^TMP($J,"IBDRUG",+IBDGP,16))_U_IBIFN
	K ^TMP($J,"IBDRUG")
	Q IBX
	;
PRVCHG(CS,CHG,PRV,EVDT,ITEM)	; return discounted amount, based on total charge for a the care, the provider and Charge Set (BR)
	; if no discount record found for the Charge Set or the provider then returns original amount
	; no provider discount for Lab charges (80000-89999)
	;   discounted amount ^ comment (if discounted) ^ percent discount
	;
	N IBPC,IBSGFN,IBSG,IBPDFN,IBPD0,IBPDTY,IBI,IBX,IBY S IBX=+$G(CHG),(IBSGFN,IBPDTY)="" I '$G(EVDT) S EVDT=DT
	I +$G(ITEM),ITEM>79999,ITEM<90000 S (CS,PRV)=""
	I +$G(CS) S IBSGFN=+$$CSSG^IBCRU6(+CS,"",2,.IBSG)
	I +$G(PRV),+IBSGFN S IBPC=$$GET^XUA4A72(PRV,EVDT)
	;
	S IBI=0 F  S IBI=$O(IBSG(IBI)) Q:'IBI  S IBSGFN=+IBSG(IBI) I +IBSGFN D
	. S IBPDFN=0 F  S IBPDFN=$O(^IBE(363.34,"C",+IBSGFN,IBPDFN)) Q:'IBPDFN  D  Q:IBPDTY'=""
	.. I '$O(^IBE(363.34,+IBPDFN,11,"B",+IBPC,0)) Q
	.. S IBPD0=$G(^IBE(363.34,+IBPDFN,0)),IBY=$P(IBPD0,U,3) Q:IBY=""
	.. S IBY=+IBY/100,IBX=IBY*IBX
	.. S IBPDTY=U_$P($G(^VA(200,+PRV,0)),U,1)_" - "_$P(IBPD0,U,1)_" "_$P(IBPD0,U,3)_"% of "_$J(CHG,0,2)_U_+IBY
	Q IBX_IBPDTY
	;
MODCHG(CS,CHG,MODS)	; return adjusted amount due to RC modifier adjustment
	; straight adjustment for RC Physician charges by modifier, if no modifier adjustment returns original amount
	; Input:  Charge Set, Procedure Charge, Modifiers - list with modifier IEN's separated by ','
	; Output: discounted amount ^ comment (if discounted) ^ percent discount
	;
	N IBCS0,IBBR0,IBMOD,IBMODS,IBMODE,IBDSCNT,IBPDTY,IBI,IBX,IBY
	S CHG=+$G(CHG),MODS=$G(MODS),(IBBR0,IBPDTY,IBMODS)="",IBDSCNT=1,IBX=+CHG
	I +$G(CS) S IBCS0=$G(^IBE(363.1,+CS,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0))
	I $P(IBBR0,U,1)'["RC PHYSICIAN" S MODS="" ; professional charge only
	I $P(IBBR0,U,4)'=2 S MODS="" ; CPT item only
	I 'CHG S MODS=""
	;
	I +MODS F IBI=1:1 S IBMOD=$P(MODS,",",IBI) Q:'IBMOD  S IBY=0 D
	. I IBMOD=3 S IBMODE=22,IBY=1.2,IBX=IBX*IBY ; modifier 22 at 120% adjustment
	. I IBMOD=10 S IBMODE=50,IBY=1.54,IBX=IBX*IBY ; modifier 50 at 154% adjustment
	. I +IBY S IBMODS=IBMODS_$S(IBMODS="":"",1:",")_IBMODE,IBDSCNT=IBDSCNT*IBY ; allow for multiple discounts
	I IBMODS'="" S IBPDTY=U_"Modifier "_IBMODS_" Adjustment "_(IBDSCNT*100)_"% of "_$J(CHG,0,2)_U_+IBDSCNT
	Q IBX_IBPDTY
	;
HRUNIT(HRS)	; returns Hour Units based on the Hours passed in
	; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units)
	N IBX S IBX=0 I +$G(HRS) S IBX=$J(HRS,0,0)
	Q IBX
	;
MLUNIT(MLS)	; returns Miles Units based on the Miles passed in
	; Mile Units are the miles rounded to the nearest whole mile
	N IBX S IBX=0 I +$G(MLS) S IBX=$J(MLS,0,0) I 'IBX S IBX=1
	Q IBX
	;
MNUNIT(MNS)	; return Minute Units based on the Minutes passed in
	; Minute Units are 15 minute intervals, rounded up after any minutes
	N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:+(MNS#15) IBX=IBX+1 I 'IBX S IBX=1
	Q IBX
