source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCU1.m@ 699

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

initial load of WorldVistAEHR
File size: 6.4 KB
Line 
1IBCRCU1 ;ALB/ARH - RATES: CALCULATION UTILITIES ; 22-MAY-1996
2 ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; there are two types of Charge Sets (363.1) that have Charge Item entries (363.2):
6 ; 1 - ITEM: each item has an individual charge: an item on the bill has corresponding charge item entries,
7 ; the item may have more than one Charge Item entry but they are specifically defined for that item
8 ; ex: an inpt bs, a CPT, or a drug
9 ; 2 - EVENT: the charge is for an event not an item: all charge items active on a date in the Set
10 ; combine to give the charge for the item on the bill for that date
11 ; all items in the set define the event charge - the total charges for a set on a date is the event charge
12 ; the item does not have to match an item on the bill and is only relevant because it is then added
13 ; to the RC multiple of the bill as one of the bills charge lines
14 ; ex: the charge for a bills opt visit date is the combined charge of all items active in the Set
15 ; on the visit date (this may be more than simply the Outpatient Visit Date bedsection charge if
16 ; there is another bedsection charge defined for that date)
17 ;
18CSITMS(CS) ; returns 1 (ITEM) if the CS requires a single billable item or 2 (EVENT) if all active items for date are used
19 ;
20 N IBX,IBCSBR,IBBEVNT,IBBLITEM,IBCHGMTH S IBX=0 I '$G(CS) G CSITMSQ
21 S IBCSBR=$$CSBR^IBCRU3(+CS) I IBCSBR="" G CSITMSQ
22 S IBBEVNT=$P(IBCSBR,U,1),IBBLITEM=$P(IBCSBR,U,4),IBCHGMTH=$P(IBCSBR,U,5)
23 ;
24 I IBBEVNT["INPATIENT BEDSECTION STAY",IBBLITEM=1,IBCHGMTH=1 S IBX=1 G CSITMSQ
25 I IBBEVNT["OUTPATIENT VISIT DATE",IBBLITEM=1,IBCHGMTH=1 S IBX=2 G CSITMSQ
26 I IBBEVNT["PRESCRIPTION",IBBLITEM=1,IBCHGMTH=1 S IBX=2 G CSITMSQ
27 I IBBEVNT["PRESCRIPTION",IBBLITEM=3,IBCHGMTH=3 S IBX=1 G CSITMSQ
28 I IBBEVNT["PRESCRIPTION",IBCHGMTH=2 S IBX=1 G CSITMSQ
29 I IBBEVNT["PROSTHETICS",IBBLITEM=1,IBCHGMTH=1 S IBX=2 G CSITMSQ
30 I IBBEVNT["PROSTHETICS",IBCHGMTH=2 S IBX=1 G CSITMSQ
31 I IBBEVNT["PROCEDURE",IBBLITEM=2,IBCHGMTH=1 S IBX=1 G CSITMSQ
32 I IBBEVNT["PROCEDURE",IBBLITEM=2,IBCHGMTH=4 S IBX=1 G CSITMSQ
33 I IBBEVNT["PROCEDURE",IBBLITEM=2,IBCHGMTH=5 S IBX=1 G CSITMSQ
34 I IBBEVNT["PROCEDURE",IBBLITEM=2,IBCHGMTH=6 S IBX=1 G CSITMSQ
35 I IBBEVNT["INPATIENT DRG",IBBLITEM=4,IBCHGMTH=1 S IBX=1 G CSITMSQ
36 I IBBEVNT["UNASSOCIATED",IBBLITEM=9,IBCHGMTH=1 S IBX=1 G CSITMSQ
37CSITMSQ Q IBX
38 ;
39CSALL(CS,EVDT,ARR) ; returns all items billable on a given effective date for charge sets where all active items are billed (EVENT)
40 ; finds most recent effective date, returns all items active on that date ie. does not check item inactive date
41 ; first get all active items on date then get only those items active on most recent effective date
42 ; Ouput: ARR = chg effective date
43 ; ARR(source item pointer) =""
44 ;
45 N IBXRF,IBITM,IBEVDT,ARR1 K ARR S ARR=0,EVDT=$G(EVDT)\1 I '$G(CS)!(EVDT'?7N) G CSALLQ
46 I +$$CSITMS(CS)'=2 G CSALLQ
47 ;
48 S IBXRF="AIVDTS"_CS
49 S IBITM=0 F S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM D
50 . S IBEVDT=$O(^IBA(363.2,IBXRF,IBITM,-(EVDT+.01))) Q:'IBEVDT
51 . S ARR1(IBEVDT,IBITM)=""
52 ;
53 S IBEVDT=$O(ARR1(""))
54 I +IBEVDT S IBITM=0 F S IBITM=$O(ARR1(IBEVDT,IBITM)) Q:'IBITM S ARR(IBITM)="",ARR=-IBEVDT
55 ;
56CSALLQ Q
57 ;
58CPTUNITS(CS,UNIT) ; return raw data returns CPT units based on Charge Set and item
59 ; Input: CS - Charge Set of charge determines Charge Method
60 ; UNIT - total miles/minutes/hours of item
61 ; Output: UNIT or calculated for miles/minutes/hours
62 N IBUNITS,IBCSBR,IBCHGMTH S IBUNITS=+$G(UNIT) I 'IBUNITS G CPTUNITQ
63 S CS=$G(CS) S IBCSBR=$$CSBR^IBCRU3(CS),IBCHGMTH=$P(IBCSBR,U,5)
64 I +IBCHGMTH=4 S IBUNITS=$$MLUNIT^IBCRCC(UNIT) ; miles
65 I +IBCHGMTH=5 S IBUNITS=$$MNUNIT^IBCRCC(UNIT) ; minutes
66 I +IBCHGMTH=6 S IBUNITS=$$HRUNIT^IBCRCC(UNIT) ; hours
67CPTUNITQ Q IBUNITS
68 ;
69CPTMOD(CS,CPT,MODS,DATE) ; check to see if a CPT-Modifier combination has a charge in this Charge Set, returns "" or CI IFN
70 ; Input MODS is a list of modifiers to check separated by ','
71 ; Output "" or list of modifiers with active charges in the set on date
72 N IBMOD,IBI,IBX,IBY S (IBX,IBY)="" I '$G(CS)!'$G(CPT)!'$G(MODS)!'$G(DATE) G CPTMODQ
73 F IBI=1:1 S IBMOD=$P(MODS,",",IBI) Q:IBMOD="" D
74 . I +$$FNDCI^IBCRU4(CS,CPT,DATE,,IBMOD) S IBX=IBX_IBY_IBMOD S IBY=","
75 ;
76CPTMODQ Q IBX
77 ;
78CHGMOD(IBIFN,CPT,EFFDT,CT) ; find charges for a procedure and a date for a bill
79 ; returns: count of charges ':' list of charge items ':' list of charge modifiers
80 N IB0,IBU,IBBDV,IBBCT,ARRCS,IBRS,IBCS,ARRCHG,IBFND,IBCIS,IBMODS,IBX S IBFND=0,(IBCIS,IBMODS)=""
81 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBU=$G(^DGCR(399,+$G(IBIFN),"U")),IBBDV=$P(IB0,U,22),IBBCT=$S($D(CT):CT,1:$P(IB0,U,27))
82 I IB0'="",+IBU,+IBBDV,+$G(CPT),+$G(EFFDT) D RT^IBCRU3($P(IB0,U,7),$P(IB0,U,5),EFFDT,.ARRCS,"PROCEDURE",IBBCT) D
83 . S IBRS=0 F S IBRS=$O(ARRCS(IBRS)) Q:'IBRS D
84 .. S IBCS=0 F S IBCS=$O(ARRCS(IBRS,IBCS)) Q:'IBCS I +ARRCS(IBRS,IBCS) D
85 ... I $$CSDV^IBCRU3(IBCS,IBBDV)<0 Q ; check division
86 ... I '$$CHGOTH^IBCRBC2(IBIFN,IBRS,EFFDT) Q ; ckeck snf/non-snf
87 ... I +$$FNDCI^IBCRU4(IBCS,CPT,EFFDT,.ARRCHG) S IBFND=IBFND+ARRCHG D
88 .... S IBX=0 F S IBX=$O(ARRCHG(IBX)) Q:'IBX S IBCIS=IBCIS_IBX_U,IBMODS=IBMODS_$P(ARRCHG(IBX),U,7)_U
89 I +IBFND S IBFND=IBFND_":"_IBCIS_":"_IBMODS
90CHGMODQ Q IBFND
91 ;
92CPTCHG(IBIFN,CT) ; return true if bill has auto add CPT charges for the Charge Type passed in (regardless of modifier)
93 N IBFND,IB0,IBU,IBBILLDV,IBBCT,IBCT,ARRCPT,ARRCS,IBRS,IBCS,IBCPT,IBCPTDA,IBCPT0 S IBFND=0,CT=$G(CT)
94 ;
95 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I IB0="" G CPTCHGQ
96 S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) I 'IBU G CPTCHGQ
97 S IBBILLDV=$P(IB0,U,22),IBBCT=$P(IB0,U,27)
98 ;
99 S IBCT=$S(CT="BILL":IBBCT,CT="INST":1,CT="PROF":2,CT="OPST"&(IBBCT=1):2,CT="OPST"&(IBBCT=2):1,CT="":"",1:-1)
100 I IBCT<0 G CPTCHGQ
101 ;
102 D CPT^IBCRBG1(IBIFN,.ARRCPT) I '$O(ARRCPT(0)) G CPTCHGQ
103 D RT^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U,1,2),.ARRCS,"PROCEDURE",IBCT)
104 ;
105 S IBRS=0 F S IBRS=$O(ARRCS(IBRS)) Q:'IBRS D I +IBFND Q
106 . S IBCS=0 F S IBCS=$O(ARRCS(IBRS,IBCS)) Q:'IBCS I +ARRCS(IBRS,IBCS) D I +IBFND Q
107 .. ;
108 .. S IBCPT=0 F S IBCPT=$O(ARRCPT(IBCPT)) Q:'IBCPT D I +IBFND Q
109 ... S IBCPTDA=0 F S IBCPTDA=$O(ARRCPT(IBCPT,IBCPTDA)) Q:'IBCPTDA D I +IBFND Q
110 .... ;
111 .... S IBCPT0=ARRCPT(IBCPT,IBCPTDA)
112 .... I $$CSDV^IBCRU3(IBCS,$P(IBCPT0,U,3),IBBILLDV)<0 Q ; check division
113 .... ;
114 .... I +$$CHKIPB^IBCU7A1(IBCPT,IBCT) S IBFND=1 Q
115 .... I +$$FNDCI^IBCRU4(IBCS,IBCPT,$P(IBCPT0,U,1)) S IBFND=1
116 ;
117CPTCHGQ Q IBFND
Note: See TracBrowser for help on using the repository browser.