- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m
r613 r623 1 IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996 2 ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347,370**;21-MAR-94;Build 5 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; ITMCHG and RATECHG are basic item/set/rate charge functions, IBCRCI contains more standard callable functions 6 ; 7 ITMCHG(CS,ITEM,EVDT,MOD,ARR) ; get the base unit charges for a specific item, given a charge set, item and date 8 ; this is the primary function to get an item charge and works for all Charge Methods, given an Item 9 ; returns ARR = count of items in array ^ total charge for item ^ total base charge 10 ; ARR(x) = charge item IFN (if any) ^ rev code (if any) ^ $ charge ^ $ base charge 11 ; checks Item effective and inactive dates, modifier match, and only sets array if the charge is non-zero 12 ; each item will be passed back separately in the array, no combination of charges 13 ; 14 N IBCSBR,IBEVDT,IBEFDT,IBXREF,IBITEM,IBDA,IBLN,IBCHRG,IBITMFND K ARR S ARR=0 15 S CS=+$G(CS),IBEVDT=$S(+$G(EVDT):+EVDT,1:DT),IBITEM=+$G(ITEM),MOD=$G(MOD) I 'CS!'IBITEM Q 16 S IBCSBR=$$CSBR^IBCRU3(CS) 17 ; 18 ; va cost 19 I $P(IBCSBR,U,5)=2 D Q ; va cost 20 . I $P(IBCSBR,U,1)["PROSTHETICS" S IBCHRG=$$PICOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q 21 . I $P(IBCSBR,U,1)["PRESCRIPTION" S IBCHRG=$$RXCOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q 22 ; 23 ; all others - have Charge Item entries 24 ; 25 ; find most recent Charge Item for the item, search until modifiers match (only BI=CPT should have mods defined) 26 S IBXREF="AIVDTS"_CS,IBITMFND=0 27 S IBEFDT=-(IBEVDT+.01) F S IBEFDT=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT)) Q:'IBEFDT D Q:IBITMFND 28 . S IBDA=0 F S IBDA=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT,IBDA)) Q:'IBDA D 29 .. S IBLN=$G(^IBA(363.2,IBDA,0)) 30 .. I +$P(IBLN,U,7)'=+MOD Q ; charge item modifier does not match modifier passed in 31 .. S IBITMFND=1 ; item found 32 .. I +$P(IBLN,U,4),+$P(IBLN,U,4)<IBEVDT Q ; charge is inactive on event date 33 .. I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8)) 34 Q 35 ; 36 SETARR(CI,RVCD,CHRG,ARR,CHRGB) ; set charges into an array, does not allow zero charge, a new entry is created each time, 37 ; no attempt to combine like items, the new item charge is added to any that may already be in the array 38 ; returns ARR = count of items in array ^ total charge for item 39 ; ARR(x) = charge item IFN (if any) ^ item rev code (if any) ^ $ charge 40 ; 41 N CNT,TCHRG,TCHRGB 42 S CNT=+$G(ARR)+1,TCHRG=$P($G(ARR),U,2)+$G(CHRG) I +$G(CHRGB) S TCHRGB=+$P($G(ARR),U,3)+CHRGB 43 I +$G(CHRG) S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB) 44 Q 45 ; 46 PICOST(PI) ; returns (PI=ptr 362.5): total VA cost of an item (660,14) ^ quantity (660,5) from prosthetics ^ bill IFN 47 ; 48 N IBPIP,IBLN,IBX,IBIFN S (IBPIP,IBX)=0 49 I +$G(PI) S IBLN=$G(^IBA(362.5,+PI,0)),IBPIP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2) 50 I +IBPIP S IBLN=$G(^RMPR(660,+IBPIP,0)) I IBLN'="" S IBX=$P(IBLN,U,16)_U_$P(IBLN,U,7)_U_IBIFN 51 Q IBX 52 ; 53 RATECHG(RS,CHG,EVDT,FEE) ; returns modifed item charge based on rate schedule: check effective dates, apply adjustment 54 ; adjusted amount ^ comment (if there is an adjustment) 55 ; if FEE passed by reference, returns disp fee^admin fee 56 ; 57 N IBX,IBRS0,IBRS10,IBEFDT,IBINADT,IBRTY,X S IBRTY="" 58 S IBX=+$G(CHG),IBRS0=$G(^IBE(363,+$G(RS),0)),IBRS10=$G(^IBE(363,+$G(RS),10)) 59 S EVDT=$S(+$G(EVDT):EVDT,1:DT),IBEFDT=$P(IBRS0,U,5),IBINADT=$P(IBRS0,U,6) 60 I +IBEFDT>EVDT!(+IBINADT&(IBINADT<EVDT)) S IBX=0 61 I +IBX,IBRS10'="" S X=IBX X IBRS10 S IBX=X,IBRTY="^Rate Schedule Adjustment ("_$J(CHG,"",2)_")" 62 S FEE=$P($G(^IBE(363,+$G(RS),1)),"^",1,2) 63 Q IBX_IBRTY 64 ; 65 RXCOST(RX) ; returns (RX=ptr 362.4): VA Cost of an Rx - Per Unit Cost ^ bill IFN 66 ; w/ Per Unit Cost = RX (Unit Price of Drug - 52,17) or Drug (Price Per Dispense Unit 50,16) cost 67 ; 68 N IBRXP,IBDGP,IBLN,IBX,IBIFN S (IBRXP,IBX)=0 69 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) 70 I +IBRXP S IBX=$$FILE^IBRXUTL(IBRXP,17)_U_IBIFN 71 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 72 K ^TMP($J,"IBDRUG") 73 Q IBX 74 ; 75 PRVCHG(CS,CHG,PRV,EVDT,ITEM) ; return discounted amount, based on total charge for a the care, the provider and Charge Set (BR) 76 ; if no discount record found for the Charge Set or the provider then returns original amount 77 ; no provider discount for Lab charges (80000-89999) 78 ; discounted amount ^ comment (if discounted) ^ percent discount 79 ; 80 N IBPC,IBSGFN,IBSG,IBPDFN,IBPD0,IBPDTY,IBI,IBX,IBY S IBX=+$G(CHG),(IBSGFN,IBPDTY)="" I '$G(EVDT) S EVDT=DT 81 I +$G(ITEM),ITEM>79999,ITEM<90000 S (CS,PRV)="" 82 I +$G(CS) S IBSGFN=+$$CSSG^IBCRU6(+CS,"",2,.IBSG) 83 I +$G(PRV),+IBSGFN S IBPC=$$GET^XUA4A72(PRV,EVDT) 84 ; 85 S IBI=0 F S IBI=$O(IBSG(IBI)) Q:'IBI S IBSGFN=+IBSG(IBI) I +IBSGFN D 86 . S IBPDFN=0 F S IBPDFN=$O(^IBE(363.34,"C",+IBSGFN,IBPDFN)) Q:'IBPDFN D Q:IBPDTY'="" 87 .. I '$O(^IBE(363.34,+IBPDFN,11,"B",+IBPC,0)) Q 88 .. S IBPD0=$G(^IBE(363.34,+IBPDFN,0)),IBY=$P(IBPD0,U,3) Q:IBY="" 89 .. S IBY=+IBY/100,IBX=IBY*IBX 90 .. 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 91 Q IBX_IBPDTY 92 ; 93 MODCHG(CS,CHG,MODS) ; return adjusted amount due to RC modifier adjustment 94 ; straight adjustment for RC Physician charges by modifier, if no modifier adjustment returns original amount 95 ; Input: Charge Set, Procedure Charge, Modifiers - list with modifier IEN's separated by ',' 96 ; Output: discounted amount ^ comment (if discounted) ^ percent discount 97 ; 98 N IBCS0,IBBR0,IBMOD,IBMODS,IBMODE,IBDSCNT,IBPDTY,IBI,IBX,IBY 99 S CHG=+$G(CHG),MODS=$G(MODS),(IBBR0,IBPDTY,IBMODS)="",IBDSCNT=1,IBX=+CHG 100 I +$G(CS) S IBCS0=$G(^IBE(363.1,+CS,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0)) 101 I $P(IBBR0,U,1)'["RC PHYSICIAN" S MODS="" ; professional charge only 102 I $P(IBBR0,U,4)'=2 S MODS="" ; CPT item only 103 I 'CHG S MODS="" 104 ; 105 I +MODS F IBI=1:1 S IBMOD=$P(MODS,",",IBI) Q:'IBMOD S IBY=0 D 106 . I IBMOD=3 S IBMODE=22,IBY=1.2,IBX=IBX*IBY ; modifier 22 at 120% adjustment 107 . I IBMOD=10 S IBMODE=50,IBY=1.54,IBX=IBX*IBY ; modifier 50 at 154% adjustment 108 . I +IBY S IBMODS=IBMODS_$S(IBMODS="":"",1:",")_IBMODE,IBDSCNT=IBDSCNT*IBY ; allow for multiple discounts 109 I IBMODS'="" S IBPDTY=U_"Modifier "_IBMODS_" Adjustment "_(IBDSCNT*100)_"% of "_$J(CHG,0,2)_U_+IBDSCNT 110 Q IBX_IBPDTY 111 ; 112 HRUNIT(HRS) ; returns Hour Units based on the Hours passed in 113 ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units) 114 N IBX S IBX=0 I +$G(HRS) S IBX=$J(HRS,0,0) 115 Q IBX 116 ; 117 MLUNIT(MLS) ; returns Miles Units based on the Miles passed in 118 ; Mile Units are the miles rounded to the nearest whole mile 119 N IBX S IBX=0 I +$G(MLS) S IBX=$J(MLS,0,0) I 'IBX S IBX=1 120 Q IBX 121 ; 122 MNUNIT(MNS) ; return Minute Units based on the Minutes passed in 123 ; Minute Units are 15 minute intervals, rounded up after any minutes 124 N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:+(MNS#15) IBX=IBX+1 I 'IBX S IBX=1 125 Q IBX 1 IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996 2 ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347**;21-MAR-94;Build 24 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; ITMCHG and RATECHG are basic item/set/rate charge functions, IBCRCI contains more standard callable functions 6 ; 7 ITMCHG(CS,ITEM,EVDT,MOD,ARR) ; get the base unit charges for a specific item, given a charge set, item and date 8 ; this is the primary function to get an item charge and works for all Charge Methods, given an Item 9 ; returns ARR = count of items in array ^ total charge for item ^ total base charge 10 ; ARR(x) = charge item IFN (if any) ^ rev code (if any) ^ $ charge ^ $ base charge 11 ; checks Item effective and inactive dates, modifier match, and only sets array if the charge is non-zero 12 ; each item will be passed back separately in the array, no combination of charges 13 ; 14 N IBCSBR,IBEVDT,IBEFDT,IBXREF,IBITEM,IBDA,IBLN,IBCHRG,IBITMFND K ARR S ARR=0 15 S CS=+$G(CS),IBEVDT=$S(+$G(EVDT):+EVDT,1:DT),IBITEM=+$G(ITEM),MOD=$G(MOD) I 'CS!'IBITEM Q 16 S IBCSBR=$$CSBR^IBCRU3(CS) 17 ; 18 ; va cost 19 I $P(IBCSBR,U,5)=2 D Q ; va cost 20 . I $P(IBCSBR,U,1)["PROSTHETICS" S IBCHRG=$$PICOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q 21 . I $P(IBCSBR,U,1)["PRESCRIPTION" S IBCHRG=$$RXCOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q 22 ; 23 ; all others - have Charge Item entries 24 ; 25 ; find most recent Charge Item for the item, search until modifiers match (only BI=CPT should have mods defined) 26 S IBXREF="AIVDTS"_CS,IBITMFND=0 27 S IBEFDT=-(IBEVDT+.01) F S IBEFDT=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT)) Q:'IBEFDT D Q:IBITMFND 28 . S IBDA=0 F S IBDA=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT,IBDA)) Q:'IBDA D 29 .. S IBLN=$G(^IBA(363.2,IBDA,0)) 30 .. I +$P(IBLN,U,7)'=+MOD Q ; charge item modifier does not match modifier passed in 31 .. S IBITMFND=1 ; item found 32 .. I +$P(IBLN,U,4),+$P(IBLN,U,4)<IBEVDT Q ; charge is inactive on event date 33 .. I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8)) 34 Q 35 ; 36 SETARR(CI,RVCD,CHRG,ARR,CHRGB) ; set charges into an array, does not allow zero charge, a new entry is created each time, 37 ; no attempt to combine like items, the new item charge is added to any that may already be in the array 38 ; returns ARR = count of items in array ^ total charge for item 39 ; ARR(x) = charge item IFN (if any) ^ item rev code (if any) ^ $ charge 40 ; 41 N CNT,TCHRG,TCHRGB 42 S CNT=+$G(ARR)+1,TCHRG=$P($G(ARR),U,2)+$G(CHRG) I +$G(CHRGB) S TCHRGB=+$P($G(ARR),U,3)+CHRGB 43 I +$G(CHRG) S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB) 44 Q 45 ; 46 PICOST(PI) ; returns (PI=ptr 362.5): total VA cost of an item (660,14) ^ quantity (660,5) from prosthetics ^ bill IFN 47 ; 48 N IBPIP,IBLN,IBX,IBIFN S (IBPIP,IBX)=0 49 I +$G(PI) S IBLN=$G(^IBA(362.5,+PI,0)),IBPIP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2) 50 I +IBPIP S IBLN=$G(^RMPR(660,+IBPIP,0)) I IBLN'="" S IBX=$P(IBLN,U,16)_U_$P(IBLN,U,7)_U_IBIFN 51 Q IBX 52 ; 53 RATECHG(RS,CHG,EVDT,FEE) ; returns modifed item charge based on rate schedule: check effective dates, apply adjustment 54 ; adjusted amount ^ comment (if there is an adjustment) 55 ; if FEE passed by reference, returns disp fee^admin fee 56 ; 57 N IBX,IBRS0,IBRS10,IBEFDT,IBINADT,IBRTY,X S IBRTY="" 58 S IBX=+$G(CHG),IBRS0=$G(^IBE(363,+$G(RS),0)),IBRS10=$G(^IBE(363,+$G(RS),10)) 59 S EVDT=$S(+$G(EVDT):EVDT,1:DT),IBEFDT=$P(IBRS0,U,5),IBINADT=$P(IBRS0,U,6) 60 I +IBEFDT>EVDT!(+IBINADT&(IBINADT<EVDT)) S IBX=0 61 I +IBX,IBRS10'="" S X=IBX X IBRS10 S IBX=X,IBRTY="^Rate Schedule Adjustment ("_$J(CHG,"",2)_")" 62 S FEE=$P($G(^IBE(363,+$G(RS),1)),"^",1,2) 63 Q IBX_IBRTY 64 ; 65 RXCOST(RX) ; returns (RX=ptr 362.4): VA Cost of an Rx - Per Unit Cost ^ bill IFN 66 ; w/ Per Unit Cost = RX (Unit Price of Drug - 52,17) or Drug (Price Per Dispense Unit 50,16) cost 67 ; 68 N IBRXP,IBDGP,IBLN,IBX,IBIFN S (IBRXP,IBX)=0 69 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) 70 I +IBRXP S IBX=$$FILE^IBRXUTL(IBRXP,17)_U_IBIFN 71 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 72 K ^TMP($J,"IBDRUG") 73 Q IBX 74 ; 75 PRVCHG(CS,CHG,PRV,EVDT,ITEM) ; return discounted amount, based on total charge for a the care, the provider and Charge Set (BR) 76 ; if no discount record found for the Charge Set or the provider then returns original amount 77 ; no provider discount for Lab charges (80000-89999) 78 ; discounted amount ^ comment (if discounted) ^ percent discount 79 ; 80 N IBPC,IBSGFN,IBSG,IBPDFN,IBPD0,IBPDTY,IBI,IBX,IBY S IBX=+$G(CHG),(IBSGFN,IBPDTY)="" I '$G(EVDT) S EVDT=DT 81 I +$G(ITEM),ITEM>79999,ITEM<90000 S (CS,PRV)="" 82 I +$G(CS) S IBSGFN=+$$CSSG^IBCRU6(+CS,"",2,.IBSG) 83 I +$G(PRV),+IBSGFN S IBPC=$$GET^XUA4A72(PRV,EVDT) 84 ; 85 S IBI=0 F S IBI=$O(IBSG(IBI)) Q:'IBI S IBSGFN=+IBSG(IBI) I +IBSGFN D 86 . S IBPDFN=0 F S IBPDFN=$O(^IBE(363.34,"C",+IBSGFN,IBPDFN)) Q:'IBPDFN D Q:IBPDTY'="" 87 .. I '$O(^IBE(363.34,+IBPDFN,11,"B",+IBPC,0)) Q 88 .. S IBPD0=$G(^IBE(363.34,+IBPDFN,0)),IBY=$P(IBPD0,U,3) Q:IBY="" 89 .. S IBY=+IBY/100,IBX=IBY*IBX 90 .. 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 91 Q IBX_IBPDTY 92 ; 93 HRUNIT(HRS) ; returns Hour Units based on the Hours passed in 94 ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units) 95 N IBX S IBX=0 I +$G(HRS) S IBX=$J(HRS,0,0) 96 Q IBX 97 ; 98 MLUNIT(MLS) ; returns Miles Units based on the Miles passed in 99 ; Mile Units are the miles rounded to the nearest whole mile 100 N IBX S IBX=0 I +$G(MLS) S IBX=$J(MLS,0,0) I 'IBX S IBX=1 101 Q IBX 102 ; 103 MNUNIT(MNS) ; return Minute Units based on the Minutes passed in 104 ; Minute Units are 15 minute intervals, rounded down for less than 5 minutes 105 N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:(MNS#15)>4 IBX=IBX+1 I 'IBX S IBX=1 106 Q IBX
Note:
See TracChangeset
for help on using the changeset viewer.
