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 Apr 09, 2024@21:21:35 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
