IBEFURT ;ALB/ARH - UTILITY: FIND RELATED THIRD PARTY BILLS ; 3/7/00
;;2.0;INTEGRATED BILLING;**130**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; the following procedures search for Third Party bills with specific data defined, matchs are returned in ^TMP
;
; ^TMP("IBRBT", $J, XRF, matching bill ifn) =
; BILL FROM ^ BILL TO ^ CANCELLED (0/1) ^ AR BILL NUMBER ^
; PAYER SEQUENCE ^ PAYER IS MEDICARE SUPPLEMENTAL (0/1) ^ PAYER NAME
;
TPEVDT(DFN,EVDT,XRF) ; find all bills for a patient with a specific Event Date (399,.03)
N IBIFN,IBDT
I +$G(DFN),+$G(EVDT) S IBDT=(EVDT\1)-.001 F S IBDT=$O(^DGCR(399,"D",IBDT)) Q:'IBDT!((IBDT\1)>(EVDT\1)) D
. S IBIFN=0 F S IBIFN=$O(^DGCR(399,"D",IBDT,IBIFN)) Q:'IBIFN D
.. ;
.. I DFN=$P($G(^DGCR(399,IBIFN,0)),U,2) D SAVELN2(IBIFN,$G(XRF))
Q
;
TPPTF(PTF,XRF) ; find all bills for a specific PTF number (399,.08)
N IBIFN
I +$G(PTF) S IBIFN=0 F S IBIFN=$O(^DGCR(399,"APTF",PTF,IBIFN)) Q:'IBIFN D SAVELN2(IBIFN,$G(XRF))
Q
;
TPOPV(DFN,DT1,DT2,XRF) ; find all bills for a patient with any Opt Visit Dates within a range (399,43)
N IBIFN,IBOPV I '$G(DT2) S DT2=+$G(DT1)
I +$G(DFN),+$G(DT1) S IBOPV=DT1-1 F S IBOPV=$O(^DGCR(399,"AOPV",DFN,IBOPV)) Q:'IBOPV!(IBOPV>DT2) D
. ;
. S IBIFN=0 F S IBIFN=$O(^DGCR(399,"AOPV",DFN,IBOPV,IBIFN)) Q:'IBIFN D SAVELN2(IBIFN,$G(XRF))
Q
;
TPRX(DFN,RXN,RXDT,XRF) ; find all bills for a patient with a specific Rx fill (Rx number and fill date) (362.4,.01,.03)
N IBX,IBX0,IBIFN,IBRXDT S RXDT=$G(RXDT) ; if either fill date not set then take all fills for rx
I +$G(DFN),$G(RXN)'="" S IBX="" F S IBX=$O(^IBA(362.4,"B",RXN,IBX)) Q:'IBX D
. S IBX0=$G(^IBA(362.4,IBX,0)),IBIFN=$P(IBX0,U,2),IBRXDT=$P(IBX0,U,3)
. ;
. I +RXDT,+IBRXDT,RXDT'=IBRXDT Q
. I DFN=$P($G(^DGCR(399,+IBIFN,0)),U,2) D SAVELN2(IBIFN,$G(XRF))
Q
;
; ==============================================================================================================
;
SAVELN1(XRF,DATA) ; set bill into array: ^TMP("IBRBT",$J,XRF) = DATA (from $$LN1)
S XRF=$S($G(XRF)="":"TP",1:XRF) S ^TMP("IBRBT",$J,XRF)=$G(DATA)
Q
;
SAVELN2(IBIFN,XRF) ; set bills found into array: ^TMP("IBRBT",$J,XRF,IBIFN)= BILL FROM ^ BILL TO ^ CANCELLED (0/1) ^ AR BILL NUMBER ^ PAYER SEQUENCE ^ PAYER IS MEDICARE SUPPLEMENTAL (0/1) ^ PAYER NAME
I +$G(IBIFN),$D(^DGCR(399,IBIFN,0)) S XRF=$S($G(XRF)="":"TP",1:XRF),^TMP("IBRBT",$J,XRF,IBIFN)=$$LN2(IBIFN)
Q
;
LN1(IBIFN) ; based on the bill passed in returns: PATIENT HAS ANY RX COVERAGE ON FROM DATE OF BILL (0/1)
N IBX,IBY,IB0,DFN S IBX="",IB0=$G(^DGCR(399,+$G(IBIFN),0)) I IB0="" G LN1Q
S DFN=$P(IB0,U,2),IBY=+$G(^DGCR(399,+IBIFN,"U")) S IBX=$$PTCOV^IBCNSU3(+DFN,+IBY,"PHARMACY")
LN1Q Q IBX
;
LN2(IBIFN) ; based on the bill passed in returns:
; BILL FROM ^ BILL TO ^ CANCELLED (0/1) ^ AR BILL NUMBER ^ PAYER SEQUENCE ^ PAYER IS MEDICARE SUPPLEMENTAL (0/1) ^ PAYER NAME
N IBX,IBY,IB0,IBU,IBMP S IBX="",IB0=$G(^DGCR(399,+$G(IBIFN),0)) I IB0="" G LN2Q
S IBU=$G(^DGCR(399,+IBIFN,"U")),IBMP=$G(^DGCR(399,+IBIFN,"MP"))
S $P(IBX,U,1)=$P(IBU,U,1)
S $P(IBX,U,2)=$P(IBU,U,2)
S $P(IBX,U,3)=$S($P(IB0,U,13)=7:1,1:"")
S $P(IBX,U,4)=$$BN1^PRCAFN(IBIFN)
S $P(IBX,U,5)=$P(IB0,U,21)
S $P(IBX,U,6)=$$TPLAN(IBIFN)
S $P(IBX,U,7)=$P($G(^DIC(36,+IBMP,0)),U,1)
LN2Q Q IBX
;
; ==============================================================================================================
;
; the following procedures return Third Party bill specific data and status
;
TPLAN(IBIFN) ; check if bills payer policy is a Med Supp or whatever type requires Third Party reimbursment to be applied to First Party charges on a 1-1 basis
; returns true if Bill Payer Policy's Type of Plan is Med Supp (399,136 > 2.312,18 > 355.3,.09 > 355.1,.03)
N IBX,IBY,DFN,PLAN S IBX="" I '$G(IBIFN) G TPLANQ
S DFN=+$P($G(^DGCR(399,+IBIFN,0)),U,2),PLAN=+$P($G(^DGCR(399,+IBIFN,"MP")),U,2) I 'PLAN G TPLANQ
S IBY=+$P($G(^DPT(DFN,.312,PLAN,0)),U,18) I 'IBY G TPLANQ
S IBY=+$P($G(^IBA(355.3,IBY,0)),U,9),IBY=$G(^IBE(355.1,+IBY,0)) I $P(IBY,U,3)=11 S IBX=1
TPLANQ Q IBX
;
RXTP(DFN,RXN,RXDT,SAVE) ; check if a particular Prescription fill has been billed on a Third Party bill, Rx # and fill date
; if SAVE is passed in then the list of bills for the Rx is returned in ^TMP("IBRBT",$J,SAVE,IBIFN)=data
N IBX,XRF,XRF1 S IBX="",XRF="IBRBT",XRF1=$G(SAVE) I XRF1="" S XRF1="TEMP"_$J
I +$G(DFN),$G(RXN)'="",+$G(RXDT) K ^TMP(XRF,$J,XRF1) D TPRX(DFN,RXN,RXDT,XRF1) I $D(^TMP(XRF,$J,XRF1)) S IBX=1
I $G(SAVE)="" K ^TMP(XRF,$J,XRF1)
Q IBX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBEFURT 4705 printed Sep 23, 2025@19:58:18 Page 2
IBEFURT ;ALB/ARH - UTILITY: FIND RELATED THIRD PARTY BILLS ; 3/7/00
+1 ;;2.0;INTEGRATED BILLING;**130**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; the following procedures search for Third Party bills with specific data defined, matchs are returned in ^TMP
+5 ;
+6 ; ^TMP("IBRBT", $J, XRF, matching bill ifn) =
+7 ; BILL FROM ^ BILL TO ^ CANCELLED (0/1) ^ AR BILL NUMBER ^
+8 ; PAYER SEQUENCE ^ PAYER IS MEDICARE SUPPLEMENTAL (0/1) ^ PAYER NAME
+9 ;
TPEVDT(DFN,EVDT,XRF) ; find all bills for a patient with a specific Event Date (399,.03)
+1 NEW IBIFN,IBDT
+2 IF +$GET(DFN)
IF +$GET(EVDT)
SET IBDT=(EVDT\1)-.001
FOR
SET IBDT=$ORDER(^DGCR(399,"D",IBDT))
if 'IBDT!((IBDT\1)>(EVDT\1))
QUIT
Begin DoDot:1
+3 SET IBIFN=0
FOR
SET IBIFN=$ORDER(^DGCR(399,"D",IBDT,IBIFN))
if 'IBIFN
QUIT
Begin DoDot:2
+4 ;
+5 IF DFN=$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
DO SAVELN2(IBIFN,$GET(XRF))
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
TPPTF(PTF,XRF) ; find all bills for a specific PTF number (399,.08)
+1 NEW IBIFN
+2 IF +$GET(PTF)
SET IBIFN=0
FOR
SET IBIFN=$ORDER(^DGCR(399,"APTF",PTF,IBIFN))
if 'IBIFN
QUIT
DO SAVELN2(IBIFN,$GET(XRF))
+3 QUIT
+4 ;
TPOPV(DFN,DT1,DT2,XRF) ; find all bills for a patient with any Opt Visit Dates within a range (399,43)
+1 NEW IBIFN,IBOPV
IF '$GET(DT2)
SET DT2=+$GET(DT1)
+2 IF +$GET(DFN)
IF +$GET(DT1)
SET IBOPV=DT1-1
FOR
SET IBOPV=$ORDER(^DGCR(399,"AOPV",DFN,IBOPV))
if 'IBOPV!(IBOPV>DT2)
QUIT
Begin DoDot:1
+3 ;
+4 SET IBIFN=0
FOR
SET IBIFN=$ORDER(^DGCR(399,"AOPV",DFN,IBOPV,IBIFN))
if 'IBIFN
QUIT
DO SAVELN2(IBIFN,$GET(XRF))
End DoDot:1
+5 QUIT
+6 ;
TPRX(DFN,RXN,RXDT,XRF) ; find all bills for a patient with a specific Rx fill (Rx number and fill date) (362.4,.01,.03)
+1 ; if either fill date not set then take all fills for rx
NEW IBX,IBX0,IBIFN,IBRXDT
SET RXDT=$GET(RXDT)
+2 IF +$GET(DFN)
IF $GET(RXN)'=""
SET IBX=""
FOR
SET IBX=$ORDER(^IBA(362.4,"B",RXN,IBX))
if 'IBX
QUIT
Begin DoDot:1
+3 SET IBX0=$GET(^IBA(362.4,IBX,0))
SET IBIFN=$PIECE(IBX0,U,2)
SET IBRXDT=$PIECE(IBX0,U,3)
+4 ;
+5 IF +RXDT
IF +IBRXDT
IF RXDT'=IBRXDT
QUIT
+6 IF DFN=$PIECE($GET(^DGCR(399,+IBIFN,0)),U,2)
DO SAVELN2(IBIFN,$GET(XRF))
End DoDot:1
+7 QUIT
+8 ;
+9 ; ==============================================================================================================
+10 ;
SAVELN1(XRF,DATA) ; set bill into array: ^TMP("IBRBT",$J,XRF) = DATA (from $$LN1)
+1 SET XRF=$SELECT($GET(XRF)="":"TP",1:XRF)
SET ^TMP("IBRBT",$JOB,XRF)=$GET(DATA)
+2 QUIT
+3 ;
SAVELN2(IBIFN,XRF) ; set bills found into array: ^TMP("IBRBT",$J,XRF,IBIFN)= BILL FROM ^ BILL TO ^ CANCELLED (0/1) ^ AR BILL NUMBER ^ PAYER SEQUENCE ^ PAYER IS MEDICARE SUPPLEMENTAL (0/1) ^ PAYER NAME
+1 IF +$GET(IBIFN)
IF $DATA(^DGCR(399,IBIFN,0))
SET XRF=$SELECT($GET(XRF)="":"TP",1:XRF)
SET ^TMP("IBRBT",$JOB,XRF,IBIFN)=$$LN2(IBIFN)
+2 QUIT
+3 ;
LN1(IBIFN) ; based on the bill passed in returns: PATIENT HAS ANY RX COVERAGE ON FROM DATE OF BILL (0/1)
+1 NEW IBX,IBY,IB0,DFN
SET IBX=""
SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
IF IB0=""
GOTO LN1Q
+2 SET DFN=$PIECE(IB0,U,2)
SET IBY=+$GET(^DGCR(399,+IBIFN,"U"))
SET IBX=$$PTCOV^IBCNSU3(+DFN,+IBY,"PHARMACY")
LN1Q QUIT IBX
+1 ;
LN2(IBIFN) ; based on the bill passed in returns:
+1 ; BILL FROM ^ BILL TO ^ CANCELLED (0/1) ^ AR BILL NUMBER ^ PAYER SEQUENCE ^ PAYER IS MEDICARE SUPPLEMENTAL (0/1) ^ PAYER NAME
+2 NEW IBX,IBY,IB0,IBU,IBMP
SET IBX=""
SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
IF IB0=""
GOTO LN2Q
+3 SET IBU=$GET(^DGCR(399,+IBIFN,"U"))
SET IBMP=$GET(^DGCR(399,+IBIFN,"MP"))
+4 SET $PIECE(IBX,U,1)=$PIECE(IBU,U,1)
+5 SET $PIECE(IBX,U,2)=$PIECE(IBU,U,2)
+6 SET $PIECE(IBX,U,3)=$SELECT($PIECE(IB0,U,13)=7:1,1:"")
+7 SET $PIECE(IBX,U,4)=$$BN1^PRCAFN(IBIFN)
+8 SET $PIECE(IBX,U,5)=$PIECE(IB0,U,21)
+9 SET $PIECE(IBX,U,6)=$$TPLAN(IBIFN)
+10 SET $PIECE(IBX,U,7)=$PIECE($GET(^DIC(36,+IBMP,0)),U,1)
LN2Q QUIT IBX
+1 ;
+2 ; ==============================================================================================================
+3 ;
+4 ; the following procedures return Third Party bill specific data and status
+5 ;
TPLAN(IBIFN) ; check if bills payer policy is a Med Supp or whatever type requires Third Party reimbursment to be applied to First Party charges on a 1-1 basis
+1 ; returns true if Bill Payer Policy's Type of Plan is Med Supp (399,136 > 2.312,18 > 355.3,.09 > 355.1,.03)
+2 NEW IBX,IBY,DFN,PLAN
SET IBX=""
IF '$GET(IBIFN)
GOTO TPLANQ
+3 SET DFN=+$PIECE($GET(^DGCR(399,+IBIFN,0)),U,2)
SET PLAN=+$PIECE($GET(^DGCR(399,+IBIFN,"MP")),U,2)
IF 'PLAN
GOTO TPLANQ
+4 SET IBY=+$PIECE($GET(^DPT(DFN,.312,PLAN,0)),U,18)
IF 'IBY
GOTO TPLANQ
+5 SET IBY=+$PIECE($GET(^IBA(355.3,IBY,0)),U,9)
SET IBY=$GET(^IBE(355.1,+IBY,0))
IF $PIECE(IBY,U,3)=11
SET IBX=1
TPLANQ QUIT IBX
+1 ;
RXTP(DFN,RXN,RXDT,SAVE) ; check if a particular Prescription fill has been billed on a Third Party bill, Rx # and fill date
+1 ; if SAVE is passed in then the list of bills for the Rx is returned in ^TMP("IBRBT",$J,SAVE,IBIFN)=data
+2 NEW IBX,XRF,XRF1
SET IBX=""
SET XRF="IBRBT"
SET XRF1=$GET(SAVE)
IF XRF1=""
SET XRF1="TEMP"_$JOB
+3 IF +$GET(DFN)
IF $GET(RXN)'=""
IF +$GET(RXDT)
KILL ^TMP(XRF,$JOB,XRF1)
DO TPRX(DFN,RXN,RXDT,XRF1)
IF $DATA(^TMP(XRF,$JOB,XRF1))
SET IBX=1
+4 IF $GET(SAVE)=""
KILL ^TMP(XRF,$JOB,XRF1)
+5 QUIT IBX
