source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m@ 1310

Last change on this file since 1310 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1IBCRCC ;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 ;
7ITMCHG(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 ;
36SETARR(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 ;
46PICOST(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 ;
53RATECHG(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 ;
65RXCOST(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 ;
75PRVCHG(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 ;
93MODCHG(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 ;
112HRUNIT(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 ;
117MLUNIT(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 ;
122MNUNIT(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
Note: See TracBrowser for help on using the repository browser.