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

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1IBCRU4 ;ALB/ARH - RATES: UTILITIES (RG/BILL/CI) ; 16-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 ;
6 ;
7RGEXT(RG) ; returns regions in external format (NAME ^ DIV1 ^ DIV 2 ^ ...)
8 N IBX,IBY,IBZ,IBI,IBC S IBY="",IBX=0,IBC=""
9 I +$G(RG) S IBZ=$P($G(^IBE(363.31,+RG,0)),U,1) I IBZ'="" S IBY=IBZ_U
10 I IBY'="" S IBX=$$RGDV(+RG)
11 I +IBX F IBI=1:1 S IBZ=$P(IBX,U,IBI) Q:'IBZ S IBY=IBY_IBC_$P($G(^DG(40.8,+IBZ,0)),U,1),IBC=", "
12 Q IBY
13 ;
14RGDV(RG,DV) ; returns a Billing Regions Divisions (363.31): div1 ^ div2 ^ ...
15 ; if DV is passed in and covered by region it will be the first division in the set
16 N IBX,IBI S IBX=""
17 I +$G(RG),$G(^IBE(363.31,+RG,0))'="" D
18 . I +$G(DV),$D(^IBE(363.31,+RG,11,"B",DV)) S IBX=DV_U
19 . S IBI=0 F S IBI=$O(^IBE(363.31,+RG,11,"B",IBI)) Q:'IBI I $G(DV)'=IBI S IBX=IBX_IBI_U
20 Q IBX
21 ;
22BILLCPT(IBIFN) ; returns true if any of the charges on the bill may be based on CPT
23 ; ie. one of the Billing Rates of one of the Charge Sets defined for the Rate Type of the bill
24 ; has a Billable Item of CPT
25 ;
26 N IBX,IB0,IBU,IBI,IBJ,IBBR,IBRSARR S IBX=0,IBRSARR=0
27 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBU=$G(^DGCR(399,+$G(IBIFN),"U"))
28 I IB0'="",+IBU D RT^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U,1,2),.IBRSARR)
29 I +IBRSARR S IBI=0 F S IBI=$O(IBRSARR(IBI)) Q:'IBI D Q:IBX
30 . S IBJ=0 F S IBJ=$O(IBRSARR(IBI,IBJ)) Q:'IBJ D Q:IBX
31 .. S IBBR=$P($G(^IBE(363.1,IBJ,0)),U,2) I $P($G(^IBE(363.3,IBBR,0)),U,4)=2 S IBX=1
32 Q IBX
33 ;
34BILLDV(IBIFN) ; returns true if one of the Billing Rates of the Charge Sets defined for the Rate Type of the bill
35 ; is modifiable by Region and therefore may need division, ie. has a Region defined
36 ;
37 N IBX,IB0,IBU,IBI,IBJ,IBCS0,IBRSARR S IBX=0,IBRSARR=0
38 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBU=$G(^DGCR(399,+$G(IBIFN),"U"))
39 I IB0'="",+IBU D RT^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U,1,2),.IBRSARR)
40 I +IBRSARR S IBI=0 F S IBI=$O(IBRSARR(IBI)) Q:'IBI D Q:IBX
41 . S IBJ=0 F S IBJ=$O(IBRSARR(IBI,IBJ)) Q:'IBJ D Q:IBX
42 .. S IBCS0=$G(^IBE(363.1,IBJ,0)) I +$P(IBCS0,U,7) S IBX=1
43 Q IBX
44 ;
45 ;
46FINDCI(CS,ITEM,EFDT,MOD,RVCD,CHG,INAC,ARR,BASE) ; find charge item entries for a billable item (exact match on date)
47 ; Input: CS, ITEM, EFDT required, if the others are defined they will be used in the match (ARR-pass by ref)
48 ; Output: returns string off all CI IFNs that match
49 ; ARR = count of matchs found
50 ; ARR(CI) = 0 node record of CI from 363.2
51 N IBX,IBXRF,IBEFDT,IBCI,IBLN K ARR S ARR=0,IBX="",EFDT=$G(EFDT)\1 I '$G(CS)!'$G(ITEM)!(EFDT'?7N) G FINDCIQ
52 ;
53 S IBXRF="AIVDTS"_CS,IBEFDT=-EFDT
54 ;
55 S IBCI=0 F S IBCI=$O(^IBA(363.2,IBXRF,ITEM,IBEFDT,IBCI)) Q:'IBCI D
56 . ;
57 . S IBLN=$G(^IBA(363.2,IBCI,0))
58 . I $D(INAC),INAC'=$P(IBLN,U,4) Q
59 . I $D(CHG),+CHG'=+$P(IBLN,U,5) Q
60 . I $D(RVCD),RVCD'=$P(IBLN,U,6) Q
61 . I $D(MOD),MOD'=$P(IBLN,U,7) Q
62 . I $D(BASE),+BASE'=+$P(IBLN,U,8) Q
63 . S IBX=IBX_IBCI_U,ARR=+$G(ARR)+1,ARR(IBCI)=IBLN
64 ;
65FINDCIQ Q IBX
66 ;
67FNDCI(CS,ITEM,EFDT,ARR,MOD) ; find charge item entries effective for a billable item on a given date
68 ; Input: CS, ITEM, EFDT required, if MOD defined it will be used in the match (ARR-pass by ref)
69 ; Output: returns string of all CI IFNs that are effective for item on date
70 ; ARR = count of effective charge items found
71 ; ARR(CI) = 0 node record of CI from 363.2
72 N IBX,IBXRF,IBEFDT,IBCI,IBLN,IBITMFND K ARR S ARR=0,IBX="",EFDT=$G(EFDT)\1
73 I '$G(CS)!'$G(ITEM)!(EFDT'?7N) G FNDCIQ
74 ;
75 S IBXRF="AIVDTS"_CS,IBITMFND=0
76 S IBEFDT=-(EFDT+.01) F S IBEFDT=$O(^IBA(363.2,IBXRF,ITEM,IBEFDT)) Q:'IBEFDT D Q:IBITMFND
77 . S IBCI=0 F S IBCI=$O(^IBA(363.2,IBXRF,ITEM,IBEFDT,IBCI)) Q:'IBCI D
78 .. ;
79 .. S IBLN=$G(^IBA(363.2,IBCI,0))
80 .. I $D(MOD),MOD'=$P(IBLN,U,7) Q ; charge item modifier does not match modifier passed in
81 .. S IBITMFND=1 ; item found
82 .. I +$P(IBLN,U,4),+$P(IBLN,U,4)<EFDT Q ; charge is inactive on date
83 .. I +$P(IBLN,U,5) S IBX=IBX_IBCI_U,ARR=+$G(ARR)+1,ARR(IBCI)=IBLN
84 ;
85FNDCIQ Q IBX
86 ;
87INACTCI(CI) ; returns date Charge Item becomes inactive: either Inactive Date or replaced (ie last active date)
88 ; returns: -1: not found, 0: not inactive, Date: date inactive or last active date before replaced
89 ;
90 N IBX,IBCI0,IBEFDT,IBITEM,IBXRF,IBNEXT,IBNCI,IBNCI0,IBINDT1,IBINDT2 S (IBINDT1,IBINDT2,IBX)=0
91 S IBCI0=$G(^IBA(363.2,+$G(CI),0)) I IBCI0="" S IBX=-1 G ACTCIQ
92 ;
93 S IBINDT1=+$P(IBCI0,U,4) ; charge item inactive date
94 ;
95 ; check previous entries for the item to see if it has been replaced
96 S IBEFDT=$P(IBCI0,U,3),IBITEM=+IBCI0,IBXRF="AIVDTS"_+$P(IBCI0,U,2)
97 S IBNEXT=-IBEFDT F S IBNEXT=$O(^IBA(363.2,IBXRF,IBITEM,IBNEXT),-1) Q:'IBNEXT D Q:+IBINDT2
98 . S IBNCI=0 F S IBNCI=$O(^IBA(363.2,IBXRF,IBITEM,IBNEXT,IBNCI)) Q:'IBNCI D Q:+IBINDT2
99 .. S IBNCI0=$G(^IBA(363.2,IBNCI,0)) I '$P(IBNCI0,U,3) Q
100 .. I $P(IBCI0,U,7)=$P(IBNCI0,U,7) S IBINDT2=$$FMADD^XLFDT(+$P(IBNCI0,U,3),-1)
101 ;
102 S IBX=IBINDT1 I 'IBX S IBX=IBINDT2
103 I +IBINDT2,+IBINDT1,IBINDT2<IBINDT1 S IBX=IBINDT2
104 ;
105ACTCIQ Q IBX
106 ;
107ITMUNIT(ITM,UNIT,CT) ; return true if the Item has the requested type of units or Charge Method
108 ; Input: ITM - pointer to Item Code
109 ; UNIT - Number of type of unit, or Charge Method, 4 - Miles, etc
110 ; CT - Charge Type (optional) 1 for Inst, 2 for Prof (363.1,.04)
111 ;
112 N IBFND,IBCS,IBCSN S IBFND=0 S ITM=+$G(ITM),UNIT=+$G(UNIT)
113 ;
114 I +ITM,+UNIT S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D I +IBFND Q
115 . S IBCSN=$G(^IBE(363.1,IBCS,0))
116 . ;
117 . I +$G(CT),+$P(IBCSN,U,4),$P(IBCSN,U,4)'=CT Q
118 . I +$P($G(^IBE(363.3,+$P(IBCSN,U,2),0)),U,5)'=UNIT Q
119 . ;
120 . I $O(^IBA(363.2,"AIVDTS"_IBCS,+ITM,"")) S IBFND=1
121 ;
122 Q IBFND
Note: See TracBrowser for help on using the repository browser.