IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996
;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347,370,383,427,455,447,482,634**;21-MAR-94;Build 57
;;Per VA Directive 6402, 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=$$RXIBCNR(.IBD,IBITEM) S:'+IBCHRG 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
.. ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
.. ;I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8))
.. D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8))
.. ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
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
; START IB*2.0*447 BI ZERO DOLLAR CHANGES
;I +$G(CHRG) S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB)
S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB)
; END IB*2.0*447 BI ZERO DOLLAR CHANGES
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
;
RXIBCNR(IBD,IBITEM) ; returns the unit cost for the drug
; input: IBD array, RX#
; output: unit cost (.304/366.141) ^ bill's IEN in (.02/362.4)
;
N IBDA,IBDB,IBDAR,IBDRX,IBDRC,IBDCT,IBIFN
S (IBDCT,IBIFN,IBDRX)=0
I +$G(IBITEM) S IBDA=$G(^IBA(362.4,+IBITEM,0)),IBIFN=$P(IBDA,U,2),IBDRX=$P(IBDA,U,5)
S:'IBDRX IBDRX=$G(IBD("PRESCRIPTION"))
S:'IBDRX IBDRX=$G(IBD("CLAIMID")) Q:'IBDRX 0
S IBDA=0 F S IBDA=$O(^IBCNR(366.14,"I",IBDRX,IBDA)) Q:'IBDA D
. S IBDB=0 F S IBDB=$O(^IBCNR(366.14,"I",IBDRX,IBDA,IBDB)) Q:'IBDB D
.. S IBDRC=$G(^IBCNR(366.14,IBDA,1,IBDB,2))
.. ; event type 1 = billable status check
.. Q:+$G(^IBCNR(366.14,IBDA,1,IBDB,0))'=1
.. Q:$G(IBD("NDC"))'=$P(IBDRC,U,5)
.. Q:$G(IBD("FILL NUMBER"))'=$P(IBDRC,U,3)
.. Q:+$G(IBD("RXCOB"))'=+$G(^IBCNR(366.14,IBDA,1,IBDB,7))
.. S IBDAR(IBDA,IBDB)=$P($G(^IBCNR(366.14,IBDA,1,IBDB,3)),U,4)
; latest one
S IBDA=$O(IBDAR(""),-1)
I IBDA'="" S IBDB=$O(IBDAR(IBDA,""),-1) S IBDCT=IBDAR(IBDA,IBDB)
;
S IBDA=$S(IBDCT:IBDCT_U_IBIFN,1:0)
Q IBDA
;
RXCOST(RX) ; returns (RX=ptr 362.4): VA Cost of an Rx - Per Unit Cost ^ bill IFN
; w/ Per Unit Cost = Refill (Current Unit Price of Drug - 52.1,1.2) or RX (Unit Price of Drug - 52,17) or Drug (Price Per Dispense Unit - 50,16)
;
N IBRXP,IBDGP,IBLN,IBX,IBIFN,IBDT,IBY
S (IBRXP,IBX,IBDGP,IBDT,IBIFN)=0,IBY=""
; fill number (362.4,.1)
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),IBDT=$P(IBLN,U,3),IBY=$P(IBLN,U,10)
I IBY="" S IBY=$$RFLNUM^IBRXUTL(IBRXP,IBDT)
;
I IBRXP,IBY S IBX=$$SUBFILE^IBRXUTL(IBRXP,+IBY,52,1.2)_U_IBIFN
I IBRXP,'IBX 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
;
; penny drug cost is 0
I $P(IBX,U,1)=0 S IBX=$$DRGCT(IBDGP)_U_IBIFN
K ^TMP($J,"IBDRUG")
Q IBX
;
;
DRGCT(IBDGP) ;Penny drug cost calculation
; Input - IEN
; Output - true value of unit price (50-13/15)
N IBCUT,IBX,IBY S IBCUT=0
G:'IBDGP DRGCTQ
D:'$D(^TMP($J,"IBDRUG")) DATA^IBRXUTL(+IBDGP)
S IBX=$G(^TMP($J,"IBDRUG",+IBDGP,13))
S IBY=$G(^TMP($J,"IBDRUG",+IBDGP,15))
I IBX,IBY S IBCUT=$J(IBX/IBY,1,4),IBCUT=$S(IBCUT>0:IBCUT,1:0.0001)
DRGCTQ Q IBCUT
;
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.25,IBX=IBX*IBY ; modifier 22 at 125% adjustment
. I IBMOD=10 S IBMODE=50,IBY=1.50,IBX=IBX*IBY ; modifier 50 at 150% 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRCC 9269 printed Apr 09, 2024@21:21:27 Page 2
IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996
+1 ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347,370,383,427,455,447,482,634**;21-MAR-94;Build 57
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; ITMCHG and RATECHG are basic item/set/rate charge functions, IBCRCI contains more standard callable functions
+5 ;
ITMCHG(CS,ITEM,EVDT,MOD,ARR) ; get the base unit charges for a specific item, given a charge set, item and date
+1 ; this is the primary function to get an item charge and works for all Charge Methods, given an Item
+2 ; returns ARR = count of items in array ^ total charge for item ^ total base charge
+3 ; ARR(x) = charge item IFN (if any) ^ rev code (if any) ^ $ charge ^ $ base charge
+4 ; checks Item effective and inactive dates, modifier match, and only sets array if the charge is non-zero
+5 ; each item will be passed back separately in the array, no combination of charges
+6 ;
+7 NEW IBCSBR,IBEVDT,IBEFDT,IBXREF,IBITEM,IBDA,IBLN,IBCHRG,IBITMFND
KILL ARR
SET ARR=0
+8 SET CS=+$GET(CS)
SET IBEVDT=$SELECT(+$GET(EVDT):+EVDT,1:DT)
SET IBITEM=+$GET(ITEM)
SET MOD=$GET(MOD)
IF 'CS!'IBITEM
QUIT
+9 SET IBCSBR=$$CSBR^IBCRU3(CS)
+10 ;
+11 ; va cost
+12 ; va cost
IF $PIECE(IBCSBR,U,5)=2
Begin DoDot:1
+13 IF $PIECE(IBCSBR,U,1)["PROSTHETICS"
SET IBCHRG=$$PICOST(IBITEM)
IF +IBCHRG
DO SETARR(0,0,+IBCHRG,.ARR)
QUIT
+14 IF $PIECE(IBCSBR,U,1)["PRESCRIPTION"
SET IBCHRG=$$RXIBCNR(.IBD,IBITEM)
if '+IBCHRG
SET IBCHRG=$$RXCOST(IBITEM)
IF +IBCHRG
DO SETARR(0,0,+IBCHRG,.ARR)
QUIT
End DoDot:1
QUIT
+15 ;
+16 ; all others - have Charge Item entries
+17 ;
+18 ; find most recent Charge Item for the item, search until modifiers match (only BI=CPT should have mods defined)
+19 SET IBXREF="AIVDTS"_CS
SET IBITMFND=0
+20 SET IBEFDT=-(IBEVDT+.01)
FOR
SET IBEFDT=$ORDER(^IBA(363.2,IBXREF,IBITEM,IBEFDT))
if 'IBEFDT
QUIT
Begin DoDot:1
+21 SET IBDA=0
FOR
SET IBDA=$ORDER(^IBA(363.2,IBXREF,IBITEM,IBEFDT,IBDA))
if 'IBDA
QUIT
Begin DoDot:2
+22 SET IBLN=$GET(^IBA(363.2,IBDA,0))
+23 ; charge item modifier does not match modifier passed in
IF +$PIECE(IBLN,U,7)'=+MOD
QUIT
+24 ; item found
SET IBITMFND=1
+25 ; charge is inactive on event date
IF +$PIECE(IBLN,U,4)
IF +$PIECE(IBLN,U,4)<IBEVDT
QUIT
+26 ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
+27 ;I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8))
+28 DO SETARR(IBDA,+$PIECE(IBLN,U,6),+$PIECE(IBLN,U,5),.ARR,$PIECE(IBLN,U,8))
+29 ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
End DoDot:2
End DoDot:1
if IBITMFND
QUIT
+30 QUIT
+31 ;
SETARR(CI,RVCD,CHRG,ARR,CHRGB) ; set charges into an array, does not allow zero charge, a new entry is created each time,
+1 ; no attempt to combine like items, the new item charge is added to any that may already be in the array
+2 ; returns ARR = count of items in array ^ total charge for item
+3 ; ARR(x) = charge item IFN (if any) ^ item rev code (if any) ^ $ charge
+4 ;
+5 NEW CNT,TCHRG,TCHRGB
+6 SET CNT=+$GET(ARR)+1
SET TCHRG=$PIECE($GET(ARR),U,2)+$GET(CHRG)
IF +$GET(CHRGB)
SET TCHRGB=+$PIECE($GET(ARR),U,3)+CHRGB
+7 ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
+8 ;I +$G(CHRG) S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB)
+9 SET ARR=CNT_U_+TCHRG_U_$GET(TCHRGB)
SET ARR(CNT)=$GET(CI)_U_+$GET(RVCD)_U_+CHRG_U_$GET(TCHRGB)
+10 ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
+11 QUIT
+12 ;
PICOST(PI) ; returns (PI=ptr 362.5): total VA cost of an item (660,14) ^ quantity (660,5) from prosthetics ^ bill IFN
+1 ;
+2 NEW IBPIP,IBLN,IBX,IBIFN
SET (IBPIP,IBX)=0
+3 IF +$GET(PI)
SET IBLN=$GET(^IBA(362.5,+PI,0))
SET IBPIP=$PIECE(IBLN,U,4)
SET IBIFN=$PIECE(IBLN,U,2)
+4 IF +IBPIP
SET IBLN=$GET(^RMPR(660,+IBPIP,0))
IF IBLN'=""
SET IBX=$PIECE(IBLN,U,16)_U_$PIECE(IBLN,U,7)_U_IBIFN
+5 QUIT IBX
+6 ;
RATECHG(RS,CHG,EVDT,FEE) ; returns modifed item charge based on rate schedule: check effective dates, apply adjustment
+1 ; adjusted amount ^ comment (if there is an adjustment)
+2 ; if FEE passed by reference, returns disp fee^admin fee
+3 ;
+4 NEW IBX,IBRS0,IBRS10,IBEFDT,IBINADT,IBRTY,X
SET IBRTY=""
+5 SET IBX=+$GET(CHG)
SET IBRS0=$GET(^IBE(363,+$GET(RS),0))
SET IBRS10=$GET(^IBE(363,+$GET(RS),10))
+6 SET EVDT=$SELECT(+$GET(EVDT):EVDT,1:DT)
SET IBEFDT=$PIECE(IBRS0,U,5)
SET IBINADT=$PIECE(IBRS0,U,6)
+7 IF +IBEFDT>EVDT!(+IBINADT&(IBINADT<EVDT))
SET IBX=0
+8 IF +IBX
IF IBRS10'=""
SET X=IBX
XECUTE IBRS10
SET IBX=X
SET IBRTY="^Rate Schedule Adjustment ("_$JUSTIFY(CHG,"",2)_")"
+9 SET FEE=$PIECE($GET(^IBE(363,+$GET(RS),1)),"^",1,2)
+10 QUIT IBX_IBRTY
+11 ;
RXIBCNR(IBD,IBITEM) ; returns the unit cost for the drug
+1 ; input: IBD array, RX#
+2 ; output: unit cost (.304/366.141) ^ bill's IEN in (.02/362.4)
+3 ;
+4 NEW IBDA,IBDB,IBDAR,IBDRX,IBDRC,IBDCT,IBIFN
+5 SET (IBDCT,IBIFN,IBDRX)=0
+6 IF +$GET(IBITEM)
SET IBDA=$GET(^IBA(362.4,+IBITEM,0))
SET IBIFN=$PIECE(IBDA,U,2)
SET IBDRX=$PIECE(IBDA,U,5)
+7 if 'IBDRX
SET IBDRX=$GET(IBD("PRESCRIPTION"))
+8 if 'IBDRX
SET IBDRX=$GET(IBD("CLAIMID"))
if 'IBDRX
QUIT 0
+9 SET IBDA=0
FOR
SET IBDA=$ORDER(^IBCNR(366.14,"I",IBDRX,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+10 SET IBDB=0
FOR
SET IBDB=$ORDER(^IBCNR(366.14,"I",IBDRX,IBDA,IBDB))
if 'IBDB
QUIT
Begin DoDot:2
+11 SET IBDRC=$GET(^IBCNR(366.14,IBDA,1,IBDB,2))
+12 ; event type 1 = billable status check
+13 if +$GET(^IBCNR(366.14,IBDA,1,IBDB,0))'=1
QUIT
+14 if $GET(IBD("NDC"))'=$PIECE(IBDRC,U,5)
QUIT
+15 if $GET(IBD("FILL NUMBER"))'=$PIECE(IBDRC,U,3)
QUIT
+16 if +$GET(IBD("RXCOB"))'=+$GET(^IBCNR(366.14,IBDA,1,IBDB,7))
QUIT
+17 SET IBDAR(IBDA,IBDB)=$PIECE($GET(^IBCNR(366.14,IBDA,1,IBDB,3)),U,4)
End DoDot:2
End DoDot:1
+18 ; latest one
+19 SET IBDA=$ORDER(IBDAR(""),-1)
+20 IF IBDA'=""
SET IBDB=$ORDER(IBDAR(IBDA,""),-1)
SET IBDCT=IBDAR(IBDA,IBDB)
+21 ;
+22 SET IBDA=$SELECT(IBDCT:IBDCT_U_IBIFN,1:0)
+23 QUIT IBDA
+24 ;
RXCOST(RX) ; returns (RX=ptr 362.4): VA Cost of an Rx - Per Unit Cost ^ bill IFN
+1 ; w/ Per Unit Cost = Refill (Current Unit Price of Drug - 52.1,1.2) or RX (Unit Price of Drug - 52,17) or Drug (Price Per Dispense Unit - 50,16)
+2 ;
+3 NEW IBRXP,IBDGP,IBLN,IBX,IBIFN,IBDT,IBY
+4 SET (IBRXP,IBX,IBDGP,IBDT,IBIFN)=0
SET IBY=""
+5 ; fill number (362.4,.1)
+6 IF +$GET(RX)
SET IBLN=$GET(^IBA(362.4,+RX,0))
SET IBRXP=$PIECE(IBLN,U,5)
SET IBDGP=$PIECE(IBLN,U,4)
SET IBIFN=$PIECE(IBLN,U,2)
SET IBDT=$PIECE(IBLN,U,3)
SET IBY=$PIECE(IBLN,U,10)
+7 IF IBY=""
SET IBY=$$RFLNUM^IBRXUTL(IBRXP,IBDT)
+8 ;
+9 IF IBRXP
IF IBY
SET IBX=$$SUBFILE^IBRXUTL(IBRXP,+IBY,52,1.2)_U_IBIFN
+10 IF IBRXP
IF 'IBX
SET IBX=$$FILE^IBRXUTL(IBRXP,17)_U_IBIFN
+11 IF 'IBRXP
IF IBDGP
DO DATA^IBRXUTL(+IBDGP)
SET IBLN=$GET(^TMP($JOB,"IBDRUG",0))
IF IBLN'=""
SET IBX=$GET(^TMP($JOB,"IBDRUG",+IBDGP,16))_U_IBIFN
+12 ;
+13 ; penny drug cost is 0
+14 IF $PIECE(IBX,U,1)=0
SET IBX=$$DRGCT(IBDGP)_U_IBIFN
+15 KILL ^TMP($JOB,"IBDRUG")
+16 QUIT IBX
+17 ;
+18 ;
DRGCT(IBDGP) ;Penny drug cost calculation
+1 ; Input - IEN
+2 ; Output - true value of unit price (50-13/15)
+3 NEW IBCUT,IBX,IBY
SET IBCUT=0
+4 if 'IBDGP
GOTO DRGCTQ
+5 if '$DATA(^TMP($JOB,"IBDRUG"))
DO DATA^IBRXUTL(+IBDGP)
+6 SET IBX=$GET(^TMP($JOB,"IBDRUG",+IBDGP,13))
+7 SET IBY=$GET(^TMP($JOB,"IBDRUG",+IBDGP,15))
+8 IF IBX
IF IBY
SET IBCUT=$JUSTIFY(IBX/IBY,1,4)
SET IBCUT=$SELECT(IBCUT>0:IBCUT,1:0.0001)
DRGCTQ QUIT IBCUT
+1 ;
PRVCHG(CS,CHG,PRV,EVDT,ITEM) ; return discounted amount, based on total charge for a the care, the provider and Charge Set (BR)
+1 ; if no discount record found for the Charge Set or the provider then returns original amount
+2 ; no provider discount for Lab charges (80000-89999)
+3 ; discounted amount ^ comment (if discounted) ^ percent discount
+4 ;
+5 NEW IBPC,IBSGFN,IBSG,IBPDFN,IBPD0,IBPDTY,IBI,IBX,IBY
SET IBX=+$GET(CHG)
SET (IBSGFN,IBPDTY)=""
IF '$GET(EVDT)
SET EVDT=DT
+6 IF +$GET(ITEM)
IF ITEM>79999
IF ITEM<90000
SET (CS,PRV)=""
+7 IF +$GET(CS)
SET IBSGFN=+$$CSSG^IBCRU6(+CS,"",2,.IBSG)
+8 IF +$GET(PRV)
IF +IBSGFN
SET IBPC=$$GET^XUA4A72(PRV,EVDT)
+9 ;
+10 SET IBI=0
FOR
SET IBI=$ORDER(IBSG(IBI))
if 'IBI
QUIT
SET IBSGFN=+IBSG(IBI)
IF +IBSGFN
Begin DoDot:1
+11 SET IBPDFN=0
FOR
SET IBPDFN=$ORDER(^IBE(363.34,"C",+IBSGFN,IBPDFN))
if 'IBPDFN
QUIT
Begin DoDot:2
+12 IF '$ORDER(^IBE(363.34,+IBPDFN,11,"B",+IBPC,0))
QUIT
+13 SET IBPD0=$GET(^IBE(363.34,+IBPDFN,0))
SET IBY=$PIECE(IBPD0,U,3)
if IBY=""
QUIT
+14 SET IBY=+IBY/100
SET IBX=IBY*IBX
+15 SET IBPDTY=U_$PIECE($GET(^VA(200,+PRV,0)),U,1)_" - "_$PIECE(IBPD0,U,1)_" "_$PIECE(IBPD0,U,3)_"% of "_$JUSTIFY(CHG,0,2)_U_+IBY
End DoDot:2
if IBPDTY'=""
QUIT
End DoDot:1
+16 QUIT IBX_IBPDTY
+17 ;
MODCHG(CS,CHG,MODS) ; return adjusted amount due to RC modifier adjustment
+1 ; straight adjustment for RC Physician charges by modifier, if no modifier adjustment returns original amount
+2 ; Input: Charge Set, Procedure Charge, Modifiers - list with modifier IEN's separated by ','
+3 ; Output: discounted amount ^ comment (if discounted) ^ percent discount
+4 ;
+5 NEW IBCS0,IBBR0,IBMOD,IBMODS,IBMODE,IBDSCNT,IBPDTY,IBI,IBX,IBY
+6 SET CHG=+$GET(CHG)
SET MODS=$GET(MODS)
SET (IBBR0,IBPDTY,IBMODS)=""
SET IBDSCNT=1
SET IBX=+CHG
+7 IF +$GET(CS)
SET IBCS0=$GET(^IBE(363.1,+CS,0))
SET IBBR0=$GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0))
+8 ; professional charge only
IF $PIECE(IBBR0,U,1)'["RC PHYSICIAN"
SET MODS=""
+9 ; CPT item only
IF $PIECE(IBBR0,U,4)'=2
SET MODS=""
+10 IF 'CHG
SET MODS=""
+11 ;
+12 IF +MODS
FOR IBI=1:1
SET IBMOD=$PIECE(MODS,",",IBI)
if 'IBMOD
QUIT
SET IBY=0
Begin DoDot:1
+13 ; modifier 22 at 125% adjustment
IF IBMOD=3
SET IBMODE=22
SET IBY=1.25
SET IBX=IBX*IBY
+14 ; modifier 50 at 150% adjustment
IF IBMOD=10
SET IBMODE=50
SET IBY=1.50
SET IBX=IBX*IBY
+15 ; allow for multiple discounts
IF +IBY
SET IBMODS=IBMODS_$SELECT(IBMODS="":"",1:",")_IBMODE
SET IBDSCNT=IBDSCNT*IBY
End DoDot:1
+16 IF IBMODS'=""
SET IBPDTY=U_"Modifier "_IBMODS_" Adjustment "_(IBDSCNT*100)_"% of "_$JUSTIFY(CHG,0,2)_U_+IBDSCNT
+17 QUIT IBX_IBPDTY
+18 ;
HRUNIT(HRS) ; returns Hour Units based on the Hours passed in
+1 ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units)
+2 NEW IBX
SET IBX=0
IF +$GET(HRS)
SET IBX=$JUSTIFY(HRS,0,0)
+3 QUIT IBX
+4 ;
MLUNIT(MLS) ; returns Miles Units based on the Miles passed in
+1 ; Mile Units are the miles rounded to the nearest whole mile
+2 NEW IBX
SET IBX=0
IF +$GET(MLS)
SET IBX=$JUSTIFY(MLS,0,0)
IF 'IBX
SET IBX=1
+3 QUIT IBX
+4 ;
MNUNIT(MNS) ; return Minute Units based on the Minutes passed in
+1 ; Minute Units are 15 minute intervals, rounded up after any minutes
+2 NEW IBX
SET IBX=0
IF +$GET(MNS)
SET IBX=(MNS\15)
if +(MNS#15)
SET IBX=IBX+1
IF 'IBX
SET IBX=1
+3 QUIT IBX
