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