IBRFN ;ALB/AAS - Supported functions for AR ;5-MAY-1992
;;2.0;INTEGRATED BILLING;**52,130,183,223,309,276,347,411,435**;21-MAR-94;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
ERR(Y) ; Input Y = -1^error code[;error code...]^literal message
; Output IBRERR = error message 1
; if more than one code then
; IBRERR(n)=error code n
N N,X,X1,X2 K IBRERR S IBRERR=""
G:+Y>0 ERRQ
S X2=$P(Y,U,2) F N=1:1 S X=$P(X2,";",N) Q:X="" S X1=$P($G(^IBE(350.8,+$O(^IBE(350.8,"AC",X,0)),0)),U,2) D
.I N=1 S IBRERR=X1
.I $P(Y,U,3)]""!($P(X2,";",2,99)]"") S IBRERR(N)=X1
I $P(Y,U,3)]"" S N=N+1,IBRERR(N)=$P(Y,U,3)
ERRQ Q IBRERR
;
MESS(Y) ; -input y=error code - from file 350.8 (piece 3)
; output error message
Q $P($G(^IBE(350.8,+$O(^IBE(350.8,"AC",Y,0)),0)),U,2)
;
SVDT(BN,VDT) ;returns service dates for a specific bill
; Input: BN bill number (external form)
; VDT name of array to hold outpatient visit dates, pass by value (if needed)
; Output: X function value, string, = 0 if bill not found
; = 1 (Inpt) or 2 (Outpt)^event date^stmt from date^stmt to date^LOS (I)^Number of visit dates (O)
; all are internal form, any piece may be null if not defined for the bill
; array containing outpatient visit dates as subscripts/no data, if VDT passed by value
N X,Y,IFN S X=0,BN=$G(BN)
I BN'="" S IFN=+$O(^DGCR(399,"B",BN,0)),Y=$G(^DGCR(399,IFN,0)) I Y'="" D
. S X=$S(+$P(Y,U,5)<1:"",+$P(Y,U,5)<3:1,+$P(Y,U,5)<5:2,1:"")_U_$P(Y,U,3),Y=$G(^DGCR(399,IFN,"U"))
. S X=X_U_$P(Y,U,1)_U_$P(Y,U,2)_U_$P(Y,U,15)_U_$P($G(^DGCR(399,IFN,"OP",0)),U,4)
. S Y=0 F S Y=$O(^DGCR(399,IFN,"OP",Y)) Q:'Y S VDT(Y)=""
Q X
;
;
REC(IBSTR,IBTYPE,IBDISP) ; Find the AR for an Authorization or Rx number
; Input: IBSTR - FI Authorization Number or Rx Number
; Output: IBAR >0 => ptr to claim/AR in files 399/430
; -1 => No receivable found
; IBTYPE (by ref) - how the IBSTR was recognized: 1-Auth,2-ECME,3-Rx#,0-Unknown
; IBDISP (by ref) - external display of number (for example to include the leading zeros on the ECME#)
;
N IBAR,IBARR,IBRX,IBKEY,IBKEYS,IBREF,IBPREF
S IBTYPE=0
S IBAR=-1
I $G(IBSTR)="" G RECQ
;
; extended syntax to indicate the type:
; T.000000 for TRICARE, E.7000000 for ECME, R.50000000 for Rx
I $L($P(IBSTR,"."))=1,$P(IBSTR,".",2)'="" D
. S IBPREF=$TR($P(IBSTR,"."),"ter","TER")
. S IBSTR=$P(IBSTR,".",2,255)
. I $E(IBPREF)="T" S IBTYPE=1 ; TRICARE Auth#
. I $E(IBPREF)="E" S IBTYPE=2 ; ECME #
. I $E(IBPREF)="R" S IBTYPE=3 ; Rx #
;
; look for TRICARE number
I (IBTYPE=0)!(IBTYPE=1) S IBAR=$$AREC(IBSTR) I IBAR>0 S IBTYPE=1 G RECQ
;
; - look for ecme number
I (IBTYPE=0)!(IBTYPE=2) S IBAR=$$EREC(IBSTR) I IBAR>0 S IBTYPE=2 G RECQ
;
I IBTYPE,IBTYPE'=3 G RECQ
;
; - treat as an rx number
S IBAR=$$RXREC(IBSTR) I IBAR>0 S IBTYPE=3
;
RECQ Q IBAR
;
RXREC(IBRXN) ; Search the Rx
N IBR,IBX,IBARR,IBY,IBBIL,IBTRKN,IBFIL,IBRX
I $L(IBRXN)<5,'$D(^IBA(362.4,"B",IBRXN)) Q -1
; Scan 362.4
; 1) check the exact match:
S IBX=0 F S IBX=$O(^IBA(362.4,"B",IBRXN,IBX)) Q:'IBX D
. S IBBIL=$P($G(^IBA(362.4,IBX,0)),U,2) Q:'IBBIL
. I $P($G(^DGCR(399,IBBIL,0)),U,13)=7 Q ; ignore cancld
. S IBARR(IBBIL)=""
; 2) check Rx with postfixes like "A","B" etc
S IBR=IBRXN_" " F S IBR=$O(^IBA(362.4,"B",IBR)) Q:$E(IBR,1,$L(IBRXN))'=IBRXN D
. I $E(IBR,$L(IBRXN)+1)'?1A Q ; only letters in postfx
. S IBX=0 F S IBX=$O(^IBA(362.4,"B",IBR,IBX)) Q:'IBX D
. . S IBBIL=$P($G(^IBA(362.4,IBX,0)),U,2) Q:'IBBIL
. . I $P($G(^DGCR(399,IBBIL,0)),U,13)=7 Q ; ignore cancld
. . S IBARR(IBBIL)=""
; 3) Now scan CT (356):
S DIC=52,DIC(0)="BO",X=IBSTR D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y
I IBRX S IBFIL="" F S IBFIL=$O(^IBT(356,"ARXFL",IBRX,IBFIL)) Q:IBFIL="" D
. S IBTRKN="" F S IBTRKN=$O(^IBT(356,"ARXFL",IBRX,IBFIL,IBTRKN)) Q:IBTRKN="" D
.. S IBBIL=$P($G(^IBT(356,IBTRKN,0)),U,11) Q:'IBBIL
.. I $P($G(^DGCR(399,IBBIL,0)),U,13)=7 Q ; ignore cancld
.. S IBARR(IBBIL)=""
;
S IBY=$O(IBARR("")) I IBY'>0 Q -1 ;not found
I '$O(IBARR(IBY)) D DTL(+IBY,"Rx#",IBRXN) Q +IBY ;one only
W !!,"More than one claim for Rx# ",IBSTR," exists."
S IBY=$$SEL(.IBARR)
D DTL(IBY,"Rx#",IBRXN)
Q IBY
;
AREC(AUTH) ; Find the Receivable for a TRICARE FI Authorization Number
; Input: AUTH - Fiscal Intermediary Authorization Number
; Output: IBIFN >0 => ptr to claim/AR in files 399/430
; -1 => No receivable found
N IBIFN
S IBIFN=-1
I $G(AUTH)="" G ARECQ
S IBIFN=$P($G(^IBA(351.5,+$O(^IBA(351.5,"AUTH",AUTH,0)),0)),U,9)
S:'IBIFN IBIFN=-1
ARECQ ;
D DTL(IBIFN,"TRICARE#",AUTH)
Q IBIFN
;
;
EREC(AUTH) ; Find the Receivable for an ECME FI Number
; Input: AUTH - Fiscal Intermediary ECME Number
; Output: IBIFN >0 => ptr to claim/AR in files 399/430
; -1 => No receivable found
;
; the ECME# may be either 7 digits or 12 digits in length
; users are not forced to enter the leading zeros, but the "AG" xref stores the ECME#
; with the leading zeros. esg - 11/30/10 - IB*2*435
;
N IBIFN,IBC,IBX,IBA,IBE,IBES,ECMELEN,ECMENUM,ZLEN
S IBIFN=-1,IBC=0
I $G(AUTH)="" G ERECQ
;
F ECMELEN=12,7 D
. I $L(+AUTH)>ECMELEN Q ; if the passed in number is already too large just quit
. S ECMENUM=$$RJ^XLFSTR(+AUTH,ECMELEN,0) ; build the actual ECME# with leading zeros if necessary
. S (IBE,IBES)=ECMENUM_";" ; getting ready to hit the "AG" xref
. F S IBE=$O(^DGCR(399,"AG",IBE)) Q:IBE'[IBES D
.. S IBX=0 F S IBX=$O(^DGCR(399,"AG",IBE,IBX)) Q:'IBX D
... I $P($G(^DGCR(399,IBX,0)),U,13)=7 Q ; exclude cancelled claims
... S IBA(IBX)="",IBC=IBC+1
... S ZLEN=ECMELEN ; save the correct ECME# length for later display
... Q
.. Q
. Q
;
I $G(ZLEN) S (AUTH,IBDISP)=$$RJ^XLFSTR(+AUTH,ZLEN,0) ; reset AUTH for display
;
I IBC'>1 S IBIFN=$O(IBA(0)) G ERECQ ; only one or none found
;
W !!,"More than one claim for ECME# ",AUTH," exists."
S IBIFN=$$SEL(.IBA)
ERECQ ;
S:'IBIFN IBIFN=-1
D DTL(IBIFN,"ECME#",AUTH) ;details
Q IBIFN
;
DTL(IBIFN,TYPE,AUTH) ;Details
Q:IBIFN'>0 Q:AUTH=""
N IBZ,IBBIL,IBPAT,IBPATN,IBRX,IB3624,IBDRUG,IBQTY,IBDAT,DIR,IBFIL
S IBZ=$G(^DGCR(399,IBIFN,0))
S IBBIL=$P(IBZ,U),IBPAT=$P(IBZ,U,2),IBDAT=$P(IBZ,U,3)
S IBPATN=$P($G(^DPT(+IBPAT,0)),U)
S IB3624=$G(^IBA(362.4,+$O(^IBA(362.4,"C",IBIFN,"")),0))
D ZERO^IBRXUTL(+$P(IB3624,U,4))
S IBDRUG=$G(^TMP($J,"IBDRUG",+$P(IB3624,U,4),.01))
K ^TMP($J,"IBDRUG")
S IBRX=$$FILE^IBRXUTL(+$P(IB3624,U,5),.01)
S IBQTY=+$P(IB3624,U,7)
S IBFIL=+$P(IB3624,U,10)
W !!,"Found IB Bill ",IBBIL," matching to "_TYPE_" '",AUTH,"':"
W !,"Rx#",IBRX,"-",IBFIL," ",$$DAT3^IBOUTL(IBDAT),", ",IBPATN,", ",IBDRUG I IBQTY W " (",IBQTY,")"
Q
;
AUD(IBIFN) ; Does the Accounts Receivable need to be audited?
; Input: IBIFN - ptr to claim/AR in files 399/430
; Output: 0 => Claim does not have to be audited
; (claim was set up automatically)
; 1 => Claim must be audited
; (claim was established manually)
;
AUDQ Q $O(^IBA(351.5,"ACL",+$G(IBIFN),0))'>0
;
;
TYP(IBIFN) ; Determine the bill type for an Accounts Receivable.
; Input: IBIFN - ptr to claim/AR in files 399/430
; Output: I => Inpatient bill
; O => Outpatient bill
; PH => Pharmacy bill
; PR => Prosthetics bill
;
; or -1 if the bill type can't be determined.
;
N IBATYP,IBATYPN,IBBG,IBN,IBND,IBTYP,IBX
S IBTYP=-1
I '$G(IBIFN) G TYPQ
;
; - see if AR originated from file #399
S IBX=$G(^DGCR(399,IBIFN,0))
I IBX]"" D G TYPQ
.S IBTYP=$$BTYP^IBCOIVM1(IBIFN,IBX)
.S IBTYP=$S(IBTYP="":-1,IBTYP="P":"PR",IBTYP="R":"PH",1:IBTYP)
;
; - get the bill number
S IBX=$P($G(^PRCA(430,IBIFN,0)),U)
I IBX="" G TYPQ
;
; - AR must have originated from file #350
S IBN=$O(^IB("ABIL",IBX,0))
I 'IBN G TYPQ
S IBND=$G(^IB(IBN,0))
I 'IBND G TYPQ
S IBATYP=$G(^IBE(350.1,+$P(IBND,U,3),0)),IBBG=$P(IBATYP,U,11)
;
; - handle TRICARE charges first
I IBBG=7 D G TYPQ
.S IBATYPN=$P(IBATYP,U)
.S IBTYP=$S(IBATYPN["INPT":"I",IBATYPN["OPT":"O",1:"PH")
;
S IBTYP=$S(IBBG=4:"O",IBBG=5:"PH",IBBG=8:"O",1:"I")
TYPQ Q IBTYP
;
RELBILL(IBIFN) ; given a Third Party Bill, find all related Third Party bills,
; then find all First Party bills related to any of the Third Party bills
; Input: IBIFN = internal file number of a Third Party bill
; Output: Third Party Bills (#399)
; ^TMP("IBRBT", $J, selected bill ifn) = PATIENT HAS ANY RX COVERAGE ON FROM DATE OF BILL?
; ^TMP("IBRBT", $J, selected bill ifn, matching bill ifn) =
; BILL FROM ^ BILL TO ^ CANCELLED? ^ AR BILL NUMBER ^
; PAYER SEQUENCE ^ PAYER IS MEDICARE SUPPLEMENTAL (0/1) ^ PAYER NAME
; Output: First Party Bills (#350)
; ^TMP("IBRBF", $J , selected bill ifn ) = ""
; ^TMP("IBRBF", $J , selected bill ifn , charge ifn) =
; BILL FROM ^ BILL TO ^ CANCELLED? ^ AR BILL NUMBER ^
; TOTAL CHARGE ^ ACTION TYPE (SHORT) ^ # DAYS ON HOLD
;
N IBIFN1 I '$D(^DGCR(399,+$G(IBIFN),0)) Q
D TPTP^IBEFUR(IBIFN)
S IBIFN1=0 F S IBIFN1=$O(^TMP("IBRBT",$J,IBIFN,IBIFN1)) Q:'IBIFN1 D TPFP^IBEFUR(IBIFN1)
Q
;
SEL(IBARR) ; Select an rx bill
; Input: IBARR - Array of IBIFN
; Output: IBNUM - One of the bill iens, or -1
;
N DIR,IBIFN,IBRXN,IBDT,IBZ,IBY,IBC,IBBIL,IBLNK,DFN,IBPT,I,IBINS,IBCOB,IBFIL
;
S IBIFN=$O(IBARR(""))
I 'IBIFN Q -1
I '$O(IBARR(IBIFN)) Q IBIFN ; no choice
;
W !!?4,"Select one of the following:",!
W !?8,"BILL",?17,"RX",?31,"DATE",?42,"INSURANCE",?60,"COB",?65,"PATIENT"
W !?4 F I=1:1:75 W "-"
;
S (IBIFN,IBC)=0
F S IBIFN=$O(IBARR(IBIFN)) Q:'IBIFN D
. S IBZ=$G(^DGCR(399,IBIFN,0)) Q:IBZ=""
. S DFN=+$P(IBZ,U,2),IBPT=$P($G(^DPT(DFN,0)),U)
. S IBBIL=$P(IBZ,U)
. S IBDT=$P(IBZ,U,3)
. S IBY=$G(^IBA(362.4,+$O(^IBA(362.4,"C",IBIFN,0)),0))
. S IBRXN=$P(IBY,U,1) ; rx#
. S IBFIL=+$P(IBY,U,10) ; fill#
. S IBC=IBC+1
. S IBLNK(IBC)=IBIFN
. S IBCOB=$P(IBZ,U,21)
. S IBINS=$P($G(^DIC(36,+$P($G(^DGCR(399,IBIFN,"MP")),U),0)),U)
. W !?4,IBC,?8,IBBIL," ",?17,IBRXN,"-",IBFIL," ",?31,$$DAT1^IBOUTL(IBDT)," ",?42,$E(IBINS,1,18),?61,IBCOB,?65,$E(IBPT,1,14)
;
;
F R !!?4,"Select one of the bills by number: ",IBY:DTIME Q:'$T Q:"^"[IBY Q:$D(IBLNK(+IBY)) W:(IBY'="")&(IBY'["?") " ??" D
. W !!?8,"Enter numeric value from 1 to ",IBC
;
S IBIFN=$G(IBLNK(+IBY),-1)
Q IBIFN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBRFN 10759 printed Oct 16, 2024@18:27:30 Page 2
IBRFN ;ALB/AAS - Supported functions for AR ;5-MAY-1992
+1 ;;2.0;INTEGRATED BILLING;**52,130,183,223,309,276,347,411,435**;21-MAR-94;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
ERR(Y) ; Input Y = -1^error code[;error code...]^literal message
+1 ; Output IBRERR = error message 1
+2 ; if more than one code then
+3 ; IBRERR(n)=error code n
+4 NEW N,X,X1,X2
KILL IBRERR
SET IBRERR=""
+5 if +Y>0
GOTO ERRQ
+6 SET X2=$PIECE(Y,U,2)
FOR N=1:1
SET X=$PIECE(X2,";",N)
if X=""
QUIT
SET X1=$PIECE($GET(^IBE(350.8,+$ORDER(^IBE(350.8,"AC",X,0)),0)),U,2)
Begin DoDot:1
+7 IF N=1
SET IBRERR=X1
+8 IF $PIECE(Y,U,3)]""!($PIECE(X2,";",2,99)]"")
SET IBRERR(N)=X1
End DoDot:1
+9 IF $PIECE(Y,U,3)]""
SET N=N+1
SET IBRERR(N)=$PIECE(Y,U,3)
ERRQ QUIT IBRERR
+1 ;
MESS(Y) ; -input y=error code - from file 350.8 (piece 3)
+1 ; output error message
+2 QUIT $PIECE($GET(^IBE(350.8,+$ORDER(^IBE(350.8,"AC",Y,0)),0)),U,2)
+3 ;
SVDT(BN,VDT) ;returns service dates for a specific bill
+1 ; Input: BN bill number (external form)
+2 ; VDT name of array to hold outpatient visit dates, pass by value (if needed)
+3 ; Output: X function value, string, = 0 if bill not found
+4 ; = 1 (Inpt) or 2 (Outpt)^event date^stmt from date^stmt to date^LOS (I)^Number of visit dates (O)
+5 ; all are internal form, any piece may be null if not defined for the bill
+6 ; array containing outpatient visit dates as subscripts/no data, if VDT passed by value
+7 NEW X,Y,IFN
SET X=0
SET BN=$GET(BN)
+8 IF BN'=""
SET IFN=+$ORDER(^DGCR(399,"B",BN,0))
SET Y=$GET(^DGCR(399,IFN,0))
IF Y'=""
Begin DoDot:1
+9 SET X=$SELECT(+$PIECE(Y,U,5)<1:"",+$PIECE(Y,U,5)<3:1,+$PIECE(Y,U,5)<5:2,1:"")_U_$PIECE(Y,U,3)
SET Y=$GET(^DGCR(399,IFN,"U"))
+10 SET X=X_U_$PIECE(Y,U,1)_U_$PIECE(Y,U,2)_U_$PIECE(Y,U,15)_U_$PIECE($GET(^DGCR(399,IFN,"OP",0)),U,4)
+11 SET Y=0
FOR
SET Y=$ORDER(^DGCR(399,IFN,"OP",Y))
if 'Y
QUIT
SET VDT(Y)=""
End DoDot:1
+12 QUIT X
+13 ;
+14 ;
REC(IBSTR,IBTYPE,IBDISP) ; Find the AR for an Authorization or Rx number
+1 ; Input: IBSTR - FI Authorization Number or Rx Number
+2 ; Output: IBAR >0 => ptr to claim/AR in files 399/430
+3 ; -1 => No receivable found
+4 ; IBTYPE (by ref) - how the IBSTR was recognized: 1-Auth,2-ECME,3-Rx#,0-Unknown
+5 ; IBDISP (by ref) - external display of number (for example to include the leading zeros on the ECME#)
+6 ;
+7 NEW IBAR,IBARR,IBRX,IBKEY,IBKEYS,IBREF,IBPREF
+8 SET IBTYPE=0
+9 SET IBAR=-1
+10 IF $GET(IBSTR)=""
GOTO RECQ
+11 ;
+12 ; extended syntax to indicate the type:
+13 ; T.000000 for TRICARE, E.7000000 for ECME, R.50000000 for Rx
+14 IF $LENGTH($PIECE(IBSTR,"."))=1
IF $PIECE(IBSTR,".",2)'=""
Begin DoDot:1
+15 SET IBPREF=$TRANSLATE($PIECE(IBSTR,"."),"ter","TER")
+16 SET IBSTR=$PIECE(IBSTR,".",2,255)
+17 ; TRICARE Auth#
IF $EXTRACT(IBPREF)="T"
SET IBTYPE=1
+18 ; ECME #
IF $EXTRACT(IBPREF)="E"
SET IBTYPE=2
+19 ; Rx #
IF $EXTRACT(IBPREF)="R"
SET IBTYPE=3
End DoDot:1
+20 ;
+21 ; look for TRICARE number
+22 IF (IBTYPE=0)!(IBTYPE=1)
SET IBAR=$$AREC(IBSTR)
IF IBAR>0
SET IBTYPE=1
GOTO RECQ
+23 ;
+24 ; - look for ecme number
+25 IF (IBTYPE=0)!(IBTYPE=2)
SET IBAR=$$EREC(IBSTR)
IF IBAR>0
SET IBTYPE=2
GOTO RECQ
+26 ;
+27 IF IBTYPE
IF IBTYPE'=3
GOTO RECQ
+28 ;
+29 ; - treat as an rx number
+30 SET IBAR=$$RXREC(IBSTR)
IF IBAR>0
SET IBTYPE=3
+31 ;
RECQ QUIT IBAR
+1 ;
RXREC(IBRXN) ; Search the Rx
+1 NEW IBR,IBX,IBARR,IBY,IBBIL,IBTRKN,IBFIL,IBRX
+2 IF $LENGTH(IBRXN)<5
IF '$DATA(^IBA(362.4,"B",IBRXN))
QUIT -1
+3 ; Scan 362.4
+4 ; 1) check the exact match:
+5 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(362.4,"B",IBRXN,IBX))
if 'IBX
QUIT
Begin DoDot:1
+6 SET IBBIL=$PIECE($GET(^IBA(362.4,IBX,0)),U,2)
if 'IBBIL
QUIT
+7 ; ignore cancld
IF $PIECE($GET(^DGCR(399,IBBIL,0)),U,13)=7
QUIT
+8 SET IBARR(IBBIL)=""
End DoDot:1
+9 ; 2) check Rx with postfixes like "A","B" etc
+10 SET IBR=IBRXN_" "
FOR
SET IBR=$ORDER(^IBA(362.4,"B",IBR))
if $EXTRACT(IBR,1,$LENGTH(IBRXN))'=IBRXN
QUIT
Begin DoDot:1
+11 ; only letters in postfx
IF $EXTRACT(IBR,$LENGTH(IBRXN)+1)'?1A
QUIT
+12 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(362.4,"B",IBR,IBX))
if 'IBX
QUIT
Begin DoDot:2
+13 SET IBBIL=$PIECE($GET(^IBA(362.4,IBX,0)),U,2)
if 'IBBIL
QUIT
+14 ; ignore cancld
IF $PIECE($GET(^DGCR(399,IBBIL,0)),U,13)=7
QUIT
+15 SET IBARR(IBBIL)=""
End DoDot:2
End DoDot:1
+16 ; 3) Now scan CT (356):
+17 SET DIC=52
SET DIC(0)="BO"
SET X=IBSTR
DO DIC^PSODI(52,.DIC,X)
SET IBRX=+Y
KILL DIC,X,Y
+18 IF IBRX
SET IBFIL=""
FOR
SET IBFIL=$ORDER(^IBT(356,"ARXFL",IBRX,IBFIL))
if IBFIL=""
QUIT
Begin DoDot:1
+19 SET IBTRKN=""
FOR
SET IBTRKN=$ORDER(^IBT(356,"ARXFL",IBRX,IBFIL,IBTRKN))
if IBTRKN=""
QUIT
Begin DoDot:2
+20 SET IBBIL=$PIECE($GET(^IBT(356,IBTRKN,0)),U,11)
if 'IBBIL
QUIT
+21 ; ignore cancld
IF $PIECE($GET(^DGCR(399,IBBIL,0)),U,13)=7
QUIT
+22 SET IBARR(IBBIL)=""
End DoDot:2
End DoDot:1
+23 ;
+24 ;not found
SET IBY=$ORDER(IBARR(""))
IF IBY'>0
QUIT -1
+25 ;one only
IF '$ORDER(IBARR(IBY))
DO DTL(+IBY,"Rx#",IBRXN)
QUIT +IBY
+26 WRITE !!,"More than one claim for Rx# ",IBSTR," exists."
+27 SET IBY=$$SEL(.IBARR)
+28 DO DTL(IBY,"Rx#",IBRXN)
+29 QUIT IBY
+30 ;
AREC(AUTH) ; Find the Receivable for a TRICARE FI Authorization Number
+1 ; Input: AUTH - Fiscal Intermediary Authorization Number
+2 ; Output: IBIFN >0 => ptr to claim/AR in files 399/430
+3 ; -1 => No receivable found
+4 NEW IBIFN
+5 SET IBIFN=-1
+6 IF $GET(AUTH)=""
GOTO ARECQ
+7 SET IBIFN=$PIECE($GET(^IBA(351.5,+$ORDER(^IBA(351.5,"AUTH",AUTH,0)),0)),U,9)
+8 if 'IBIFN
SET IBIFN=-1
ARECQ ;
+1 DO DTL(IBIFN,"TRICARE#",AUTH)
+2 QUIT IBIFN
+3 ;
+4 ;
EREC(AUTH) ; Find the Receivable for an ECME FI Number
+1 ; Input: AUTH - Fiscal Intermediary ECME Number
+2 ; Output: IBIFN >0 => ptr to claim/AR in files 399/430
+3 ; -1 => No receivable found
+4 ;
+5 ; the ECME# may be either 7 digits or 12 digits in length
+6 ; users are not forced to enter the leading zeros, but the "AG" xref stores the ECME#
+7 ; with the leading zeros. esg - 11/30/10 - IB*2*435
+8 ;
+9 NEW IBIFN,IBC,IBX,IBA,IBE,IBES,ECMELEN,ECMENUM,ZLEN
+10 SET IBIFN=-1
SET IBC=0
+11 IF $GET(AUTH)=""
GOTO ERECQ
+12 ;
+13 FOR ECMELEN=12,7
Begin DoDot:1
+14 ; if the passed in number is already too large just quit
IF $LENGTH(+AUTH)>ECMELEN
QUIT
+15 ; build the actual ECME# with leading zeros if necessary
SET ECMENUM=$$RJ^XLFSTR(+AUTH,ECMELEN,0)
+16 ; getting ready to hit the "AG" xref
SET (IBE,IBES)=ECMENUM_";"
+17 FOR
SET IBE=$ORDER(^DGCR(399,"AG",IBE))
if IBE'[IBES
QUIT
Begin DoDot:2
+18 SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399,"AG",IBE,IBX))
if 'IBX
QUIT
Begin DoDot:3
+19 ; exclude cancelled claims
IF $PIECE($GET(^DGCR(399,IBX,0)),U,13)=7
QUIT
+20 SET IBA(IBX)=""
SET IBC=IBC+1
+21 ; save the correct ECME# length for later display
SET ZLEN=ECMELEN
+22 QUIT
End DoDot:3
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 ;
+26 ; reset AUTH for display
IF $GET(ZLEN)
SET (AUTH,IBDISP)=$$RJ^XLFSTR(+AUTH,ZLEN,0)
+27 ;
+28 ; only one or none found
IF IBC'>1
SET IBIFN=$ORDER(IBA(0))
GOTO ERECQ
+29 ;
+30 WRITE !!,"More than one claim for ECME# ",AUTH," exists."
+31 SET IBIFN=$$SEL(.IBA)
ERECQ ;
+1 if 'IBIFN
SET IBIFN=-1
+2 ;details
DO DTL(IBIFN,"ECME#",AUTH)
+3 QUIT IBIFN
+4 ;
DTL(IBIFN,TYPE,AUTH) ;Details
+1 if IBIFN'>0
QUIT
if AUTH=""
QUIT
+2 NEW IBZ,IBBIL,IBPAT,IBPATN,IBRX,IB3624,IBDRUG,IBQTY,IBDAT,DIR,IBFIL
+3 SET IBZ=$GET(^DGCR(399,IBIFN,0))
+4 SET IBBIL=$PIECE(IBZ,U)
SET IBPAT=$PIECE(IBZ,U,2)
SET IBDAT=$PIECE(IBZ,U,3)
+5 SET IBPATN=$PIECE($GET(^DPT(+IBPAT,0)),U)
+6 SET IB3624=$GET(^IBA(362.4,+$ORDER(^IBA(362.4,"C",IBIFN,"")),0))
+7 DO ZERO^IBRXUTL(+$PIECE(IB3624,U,4))
+8 SET IBDRUG=$GET(^TMP($JOB,"IBDRUG",+$PIECE(IB3624,U,4),.01))
+9 KILL ^TMP($JOB,"IBDRUG")
+10 SET IBRX=$$FILE^IBRXUTL(+$PIECE(IB3624,U,5),.01)
+11 SET IBQTY=+$PIECE(IB3624,U,7)
+12 SET IBFIL=+$PIECE(IB3624,U,10)
+13 WRITE !!,"Found IB Bill ",IBBIL," matching to "_TYPE_" '",AUTH,"':"
+14 WRITE !,"Rx#",IBRX,"-",IBFIL," ",$$DAT3^IBOUTL(IBDAT),", ",IBPATN,", ",IBDRUG
IF IBQTY
WRITE " (",IBQTY,")"
+15 QUIT
+16 ;
AUD(IBIFN) ; Does the Accounts Receivable need to be audited?
+1 ; Input: IBIFN - ptr to claim/AR in files 399/430
+2 ; Output: 0 => Claim does not have to be audited
+3 ; (claim was set up automatically)
+4 ; 1 => Claim must be audited
+5 ; (claim was established manually)
+6 ;
AUDQ QUIT $ORDER(^IBA(351.5,"ACL",+$GET(IBIFN),0))'>0
+1 ;
+2 ;
TYP(IBIFN) ; Determine the bill type for an Accounts Receivable.
+1 ; Input: IBIFN - ptr to claim/AR in files 399/430
+2 ; Output: I => Inpatient bill
+3 ; O => Outpatient bill
+4 ; PH => Pharmacy bill
+5 ; PR => Prosthetics bill
+6 ;
+7 ; or -1 if the bill type can't be determined.
+8 ;
+9 NEW IBATYP,IBATYPN,IBBG,IBN,IBND,IBTYP,IBX
+10 SET IBTYP=-1
+11 IF '$GET(IBIFN)
GOTO TYPQ
+12 ;
+13 ; - see if AR originated from file #399
+14 SET IBX=$GET(^DGCR(399,IBIFN,0))
+15 IF IBX]""
Begin DoDot:1
+16 SET IBTYP=$$BTYP^IBCOIVM1(IBIFN,IBX)
+17 SET IBTYP=$SELECT(IBTYP="":-1,IBTYP="P":"PR",IBTYP="R":"PH",1:IBTYP)
End DoDot:1
GOTO TYPQ
+18 ;
+19 ; - get the bill number
+20 SET IBX=$PIECE($GET(^PRCA(430,IBIFN,0)),U)
+21 IF IBX=""
GOTO TYPQ
+22 ;
+23 ; - AR must have originated from file #350
+24 SET IBN=$ORDER(^IB("ABIL",IBX,0))
+25 IF 'IBN
GOTO TYPQ
+26 SET IBND=$GET(^IB(IBN,0))
+27 IF 'IBND
GOTO TYPQ
+28 SET IBATYP=$GET(^IBE(350.1,+$PIECE(IBND,U,3),0))
SET IBBG=$PIECE(IBATYP,U,11)
+29 ;
+30 ; - handle TRICARE charges first
+31 IF IBBG=7
Begin DoDot:1
+32 SET IBATYPN=$PIECE(IBATYP,U)
+33 SET IBTYP=$SELECT(IBATYPN["INPT":"I",IBATYPN["OPT":"O",1:"PH")
End DoDot:1
GOTO TYPQ
+34 ;
+35 SET IBTYP=$SELECT(IBBG=4:"O",IBBG=5:"PH",IBBG=8:"O",1:"I")
TYPQ QUIT IBTYP
+1 ;
RELBILL(IBIFN) ; given a Third Party Bill, find all related Third Party bills,
+1 ; then find all First Party bills related to any of the Third Party bills
+2 ; Input: IBIFN = internal file number of a Third Party bill
+3 ; Output: Third Party Bills (#399)
+4 ; ^TMP("IBRBT", $J, selected bill ifn) = PATIENT HAS ANY RX COVERAGE ON FROM DATE OF BILL?
+5 ; ^TMP("IBRBT", $J, selected bill ifn, matching bill ifn) =
+6 ; BILL FROM ^ BILL TO ^ CANCELLED? ^ AR BILL NUMBER ^
+7 ; PAYER SEQUENCE ^ PAYER IS MEDICARE SUPPLEMENTAL (0/1) ^ PAYER NAME
+8 ; Output: First Party Bills (#350)
+9 ; ^TMP("IBRBF", $J , selected bill ifn ) = ""
+10 ; ^TMP("IBRBF", $J , selected bill ifn , charge ifn) =
+11 ; BILL FROM ^ BILL TO ^ CANCELLED? ^ AR BILL NUMBER ^
+12 ; TOTAL CHARGE ^ ACTION TYPE (SHORT) ^ # DAYS ON HOLD
+13 ;
+14 NEW IBIFN1
IF '$DATA(^DGCR(399,+$GET(IBIFN),0))
QUIT
+15 DO TPTP^IBEFUR(IBIFN)
+16 SET IBIFN1=0
FOR
SET IBIFN1=$ORDER(^TMP("IBRBT",$JOB,IBIFN,IBIFN1))
if 'IBIFN1
QUIT
DO TPFP^IBEFUR(IBIFN1)
+17 QUIT
+18 ;
SEL(IBARR) ; Select an rx bill
+1 ; Input: IBARR - Array of IBIFN
+2 ; Output: IBNUM - One of the bill iens, or -1
+3 ;
+4 NEW DIR,IBIFN,IBRXN,IBDT,IBZ,IBY,IBC,IBBIL,IBLNK,DFN,IBPT,I,IBINS,IBCOB,IBFIL
+5 ;
+6 SET IBIFN=$ORDER(IBARR(""))
+7 IF 'IBIFN
QUIT -1
+8 ; no choice
IF '$ORDER(IBARR(IBIFN))
QUIT IBIFN
+9 ;
+10 WRITE !!?4,"Select one of the following:",!
+11 WRITE !?8,"BILL",?17,"RX",?31,"DATE",?42,"INSURANCE",?60,"COB",?65,"PATIENT"
+12 WRITE !?4
FOR I=1:1:75
WRITE "-"
+13 ;
+14 SET (IBIFN,IBC)=0
+15 FOR
SET IBIFN=$ORDER(IBARR(IBIFN))
if 'IBIFN
QUIT
Begin DoDot:1
+16 SET IBZ=$GET(^DGCR(399,IBIFN,0))
if IBZ=""
QUIT
+17 SET DFN=+$PIECE(IBZ,U,2)
SET IBPT=$PIECE($GET(^DPT(DFN,0)),U)
+18 SET IBBIL=$PIECE(IBZ,U)
+19 SET IBDT=$PIECE(IBZ,U,3)
+20 SET IBY=$GET(^IBA(362.4,+$ORDER(^IBA(362.4,"C",IBIFN,0)),0))
+21 ; rx#
SET IBRXN=$PIECE(IBY,U,1)
+22 ; fill#
SET IBFIL=+$PIECE(IBY,U,10)
+23 SET IBC=IBC+1
+24 SET IBLNK(IBC)=IBIFN
+25 SET IBCOB=$PIECE(IBZ,U,21)
+26 SET IBINS=$PIECE($GET(^DIC(36,+$PIECE($GET(^DGCR(399,IBIFN,"MP")),U),0)),U)
+27 WRITE !?4,IBC,?8,IBBIL," ",?17,IBRXN,"-",IBFIL," ",?31,$$DAT1^IBOUTL(IBDT)," ",?42,$EXTRACT(IBINS,1,18),?61,IBCOB,?65,$EXTRACT(IBPT,1,14)
End DoDot:1
+28 ;
+29 ;
+30 FOR
READ !!?4,"Select one of the bills by number: ",IBY:DTIME
if '$TEST
QUIT
if "^"[IBY
QUIT
if $DATA(IBLNK(+IBY))
QUIT
if (IBY'="")&(IBY'["?")
WRITE " ??"
Begin DoDot:1
+31 WRITE !!?8,"Enter numeric value from 1 to ",IBC
End DoDot:1
+32 ;
+33 SET IBIFN=$GET(IBLNK(+IBY),-1)
+34 QUIT IBIFN
