- 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 Feb 18, 2025@23:45:19 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
