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

IBCRU4 ;ALB/ARH - RATES: UTILITIES (RG/BILL/CI) ; 16-MAY-1996
 ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
 ;
RGEXT(RG) ; returns regions in external format (NAME ^ DIV1 ^ DIV 2 ^ ...)
 N IBX,IBY,IBZ,IBI,IBC S IBY="",IBX=0,IBC=""
 I +$G(RG) S IBZ=$P($G(^IBE(363.31,+RG,0)),U,1) I IBZ'="" S IBY=IBZ_U
 I IBY'="" S IBX=$$RGDV(+RG)
 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=", "
 Q IBY
 ;
RGDV(RG,DV) ; returns a Billing Regions Divisions (363.31):  div1 ^ div2 ^ ...
 ; if DV is passed in and covered by region it will be the first division in the set
 N IBX,IBI S IBX=""
 I +$G(RG),$G(^IBE(363.31,+RG,0))'="" D
 . I +$G(DV),$D(^IBE(363.31,+RG,11,"B",DV)) S IBX=DV_U
 . 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
 Q IBX
 ;
BILLCPT(IBIFN) ; returns true if any of the charges on the bill may be based on CPT
 ; ie. one of the Billing Rates of one of the Charge Sets defined for the Rate Type of the bill
 ; has a Billable Item of CPT
 ;
 N IBX,IB0,IBU,IBI,IBJ,IBBR,IBRSARR S IBX=0,IBRSARR=0
 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBU=$G(^DGCR(399,+$G(IBIFN),"U"))
 I IB0'="",+IBU D RT^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U,1,2),.IBRSARR)
 I +IBRSARR S IBI=0 F  S IBI=$O(IBRSARR(IBI)) Q:'IBI  D  Q:IBX
 . S IBJ=0 F  S IBJ=$O(IBRSARR(IBI,IBJ)) Q:'IBJ  D  Q:IBX
 .. 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
 Q IBX
 ;
BILLDV(IBIFN) ; returns true if one of the Billing Rates of the Charge Sets defined for the Rate Type of the bill
 ; is modifiable by Region and therefore may need division,  ie. has a Region defined
 ;
 N IBX,IB0,IBU,IBI,IBJ,IBCS0,IBRSARR S IBX=0,IBRSARR=0
 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBU=$G(^DGCR(399,+$G(IBIFN),"U"))
 I IB0'="",+IBU D RT^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U,1,2),.IBRSARR)
 I +IBRSARR S IBI=0 F  S IBI=$O(IBRSARR(IBI)) Q:'IBI  D  Q:IBX
 . S IBJ=0 F  S IBJ=$O(IBRSARR(IBI,IBJ)) Q:'IBJ  D  Q:IBX
 .. S IBCS0=$G(^IBE(363.1,IBJ,0)) I +$P(IBCS0,U,7) S IBX=1
 Q IBX
 ;
 ;
FINDCI(CS,ITEM,EFDT,MOD,RVCD,CHG,INAC,ARR,BASE) ; find charge item entries for a billable item (exact match on date)
 ; Input:  CS, ITEM, EFDT required, if the others are defined they will be used in the match (ARR-pass by ref)
 ; Output: returns string off all CI IFNs that match
 ;         ARR = count of matchs found
 ;         ARR(CI) = 0 node record of CI from 363.2
 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
 ;
 S IBXRF="AIVDTS"_CS,IBEFDT=-EFDT
 ;
 S IBCI=0 F  S IBCI=$O(^IBA(363.2,IBXRF,ITEM,IBEFDT,IBCI)) Q:'IBCI  D
 . ;
 . S IBLN=$G(^IBA(363.2,IBCI,0))
 . I $D(INAC),INAC'=$P(IBLN,U,4) Q
 . I $D(CHG),+CHG'=+$P(IBLN,U,5) Q
 . I $D(RVCD),RVCD'=$P(IBLN,U,6) Q
 . I $D(MOD),MOD'=$P(IBLN,U,7) Q
 . I $D(BASE),+BASE'=+$P(IBLN,U,8) Q
 . S IBX=IBX_IBCI_U,ARR=+$G(ARR)+1,ARR(IBCI)=IBLN
 ;
FINDCIQ Q IBX
 ;
FNDCI(CS,ITEM,EFDT,ARR,MOD) ; find charge item entries effective for a billable item on a given date
 ; Input:  CS, ITEM, EFDT required, if MOD defined it will be used in the match (ARR-pass by ref)
 ; Output: returns string of all CI IFNs that are effective for item on date
 ;         ARR = count of effective charge items found
 ;         ARR(CI) = 0 node record of CI from 363.2
 N IBX,IBXRF,IBEFDT,IBCI,IBLN,IBITMFND K ARR S ARR=0,IBX="",EFDT=$G(EFDT)\1
 I '$G(CS)!'$G(ITEM)!(EFDT'?7N) G FNDCIQ
 ;
 S IBXRF="AIVDTS"_CS,IBITMFND=0
 S IBEFDT=-(EFDT+.01) F  S IBEFDT=$O(^IBA(363.2,IBXRF,ITEM,IBEFDT)) Q:'IBEFDT  D  Q:IBITMFND
 . S IBCI=0 F  S IBCI=$O(^IBA(363.2,IBXRF,ITEM,IBEFDT,IBCI)) Q:'IBCI  D
 .. ;
 .. S IBLN=$G(^IBA(363.2,IBCI,0))
 .. I $D(MOD),MOD'=$P(IBLN,U,7) Q  ; charge item modifier does not match modifier passed in
 .. S IBITMFND=1 ; item found
 .. I +$P(IBLN,U,4),+$P(IBLN,U,4)<EFDT Q  ; charge is inactive on date
 .. I +$P(IBLN,U,5) S IBX=IBX_IBCI_U,ARR=+$G(ARR)+1,ARR(IBCI)=IBLN
 ;
FNDCIQ Q IBX
 ;
INACTCI(CI) ; returns date Charge Item becomes inactive: either Inactive Date or replaced (ie last active date)
 ; returns: -1: not found, 0: not inactive, Date: date inactive or last active date before replaced
 ;
 N IBX,IBCI0,IBEFDT,IBITEM,IBXRF,IBNEXT,IBNCI,IBNCI0,IBINDT1,IBINDT2 S (IBINDT1,IBINDT2,IBX)=0
 S IBCI0=$G(^IBA(363.2,+$G(CI),0)) I IBCI0="" S IBX=-1 G ACTCIQ
 ;
 S IBINDT1=+$P(IBCI0,U,4) ; charge item inactive date
 ;
 ; check previous entries for the item to see if it has been replaced
 S IBEFDT=$P(IBCI0,U,3),IBITEM=+IBCI0,IBXRF="AIVDTS"_+$P(IBCI0,U,2)
 S IBNEXT=-IBEFDT F  S IBNEXT=$O(^IBA(363.2,IBXRF,IBITEM,IBNEXT),-1) Q:'IBNEXT  D  Q:+IBINDT2
 . S IBNCI=0 F  S IBNCI=$O(^IBA(363.2,IBXRF,IBITEM,IBNEXT,IBNCI)) Q:'IBNCI  D  Q:+IBINDT2
 .. S IBNCI0=$G(^IBA(363.2,IBNCI,0)) I '$P(IBNCI0,U,3) Q
 .. I $P(IBCI0,U,7)=$P(IBNCI0,U,7) S IBINDT2=$$FMADD^XLFDT(+$P(IBNCI0,U,3),-1)
 ;
 S IBX=IBINDT1 I 'IBX S IBX=IBINDT2
 I +IBINDT2,+IBINDT1,IBINDT2<IBINDT1 S IBX=IBINDT2
 ;
ACTCIQ Q IBX
 ;
ITMUNIT(ITM,UNIT,CT) ; return true if the Item has the requested type of units or Charge Method
 ; Input: ITM  - pointer to Item Code
 ;        UNIT - Number of type of unit, or Charge Method, 4 - Miles, etc
 ;        CT   - Charge Type (optional) 1 for Inst, 2 for Prof (363.1,.04)
 ;
 N IBFND,IBCS,IBCSN S IBFND=0 S ITM=+$G(ITM),UNIT=+$G(UNIT)
 ;
 I +ITM,+UNIT S IBCS=0 F  S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS  D  I +IBFND Q
 . S IBCSN=$G(^IBE(363.1,IBCS,0))
 . ;
 . I +$G(CT),+$P(IBCSN,U,4),$P(IBCSN,U,4)'=CT Q
 . I +$P($G(^IBE(363.3,+$P(IBCSN,U,2),0)),U,5)'=UNIT Q
 . ;
 . I $O(^IBA(363.2,"AIVDTS"_IBCS,+ITM,"")) S IBFND=1
 ;
 Q IBFND