IBTUBO2 ;ALB/AAS - UNBILLED AMOUNTS - GENERATE UNBILLED REPORTS ;03 Aug 2004 8:21 AM
;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,192,155,309,347,437,516,547**;21-MAR-94;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
INPT(DGPM) ; - Check if inpatient episode has bills or final bill; if not,
; ^TMP($J,"IBTUB",DIVISION,"INPT",NAME@@DFN,DATE,IBX)=bill status
; ^TMP($J,"IBTUB",DIVISION,"INPT_MRA",NAME@@DFN,DATE,IBX)=1 if MRA request
; *Pre-set variables: DFN=patient IEN, DGPM=pointer to file #405,
; IBDT=event date, IBRT=bill rate,
; IBEDT=reporting period date
;
I '$G(DFN)!('$G(DGPM))!('$G(IBDT))!('$G(IBRT)) G INPTQ
N IBIP,IBDATA,IBNAME,IBNCF,IBXX,X,Y,IBMRA,IBDIV,IBWARD
S IBNAME=$P($G(^DPT(DFN,0)),U)
;
; Get Division. Default to main Division if not in Ward location
S IBWARD=$$GET1^DIQ(405,DGPM_",",.06,"I") ;Determine Ward location.
S IBDIV=$$GET1^DIQ(42,IBWARD_",",.015,"I") I IBDIV="" S IBDIV=$$PRIM^VASITE()
I $D(^TMP($J,"IBTUB-DIV")),'$D(^TMP($J,"IBTUB-DIV",IBDIV)) G INPTQ ; Not a selected Division
;
; If the IBSBD flag is not set, then reset the Division to be
; 999999. This data will still be included, but the report
; will not be sorted by Division.
;
S:'$G(IBSBD) IBDIV=999999
;
I $D(^TMP($J,"IBTUB",IBDIV,"INPT",IBNAME_"@@"_DFN,IBDT)) G INPTQ
;
I $P($G(^DGPM(DGPM,0)),U,11) G INPTQ ; Admitted for SC condition.
I $$SC^IBTUBOU($P($G(^DGPM(DGPM,0)),U,16)) G INPTQ ; Check PTF for SC.
S (IBIP(1),IBIP(2))=0 ; Set claim flags.
;
; - Check patient's claims.
S (IBNCF,X)=0
F S X=$O(^DGCR(399,"C",DFN,X)) Q:'X D Q:IBIP(1)&(IBIP(2))
. S IBDATA=$$CKBIL^IBTUBOU(X,1) Q:IBDATA=""
. ;
. ; The admission date on the bill is different from the Event date.
. I $P(IBDATA,U,5)'=$P(IBDT,".") Q
. S IBNCF=IBNCF+1 ; Increment the number of bills on file for episode
. ;
. ; If Compile/Store & Not authorized before reporting period - Quit.
. I $G(IBCOMP),$S($P(IBDATA,U,2)'=2:$P(IBDATA,U,3),1:$P(IBDATA,U,6))>IBEDT Q
. ;
. S IBIP($P(IBDATA,U,4))=$S($P(IBDATA,U,2)'=2:1,1:2) ; Episode billed for inst/prof bill type
. Q
;
I IBIP(1)=1 G:IBIP(2)=1!(IBDT<2990901) INPTQ ; Episode is billed.
;
; - Add to episodes missing inst./prof. bills.
S (IBXX,IBMRA)=""
;
I IBIP(1)'=1 D
. I 'IBIP(1) D
. . S IBUNB(IBDIV,"EPISM-I")=$G(IBUNB(IBDIV,"EPISM-I"))+1
. . S IBUNB("EPISM-I")=$G(IBUNB("EPISM-I"))+1
. . I IBDET S IBXX="I"
. . Q
. I $G(IBXTRACT) S IB(1)=IB(1)+1 ; For DM extract.
. I IBIP(1)=2 D
. . S IBUNB(IBDIV,"EPISM-I-MRA")=$G(IBUNB(IBDIV,"EPISM-I-MRA"))+1
. . S IBUNB("EPISM-I-MRA")=$G(IBUNB("EPISM-I-MRA"))+1
. . I IBDET S IBMRA="I"
. . Q
. Q
;
I IBIP(2)'=1,IBDT'<2990901 D
. I 'IBIP(2) D
. . S IBUNB(IBDIV,"EPISM-P")=$G(IBUNB(IBDIV,"EPISM-P"))+1
. . S IBUNB("EPISM-P")=$G(IBUNB("EPISM-P"))+1
. . I IBDET S IBXX=$S(IBXX="I":"I,P",1:"P")
. . Q
. I $G(IBXTRACT) S IB(3)=IB(3)+1 ; For DM extract.
. I IBIP(2)=2 D
. . S IBUNB(IBDIV,"EPISM-P-MRA")=$G(IBUNB(IBDIV,"EPISM-P-MRA"))+1
. . S IBUNB("EPISM-P-MRA")=$G(IBUNB("EPISM-P-MRA"))+1
. . I IBDET S IBMRA=$S(IBMRA="I":"I,P",1:"P")
. . Q
. Q
;
I 'IBIP(1)!'IBIP(2) D ; Number of Admissions missing claims
. S IBUNB(IBDIV,"EPISM-A")=$G(IBUNB(IBDIV,"EPISM-A"))+1
. S IBUNB("EPISM-A")=$G(IBUNB("EPISM-A"))+1
I IBIP(1)=2!(IBIP(2)=2) D
. S IBUNB(IBDIV,"EPISM-A-MRA")=$G(IBUNB(IBDIV,"EPISM-A-MRA"))+1
. S IBUNB("EPISM-A-MRA")=$G(IBUNB("EPISM-A-MRA"))+1
I $G(IBXTRACT) S IB(5)=IB(5)+1 ; For DM extract.
;
I '$G(IBINMRA),IBIP(1)=2 G:IBIP(2)=1 INPTQ
I '$G(IBINMRA),IBIP(2)=2 G:IBIP(1)=1 INPTQ
;
; - Set global for report.
I $S($G(IBINMRA):1,1:IBXX'="") S ^TMP($J,"IBTUB",IBDIV,"INPT",IBNAME_"@@"_DFN,IBDT,IBX)=IBNCF_U_IBXX_U_U_U_$$HOSP^IBTUBOU(DGPM)
I IBMRA'="",$G(IBINMRA) S ^TMP($J,"IBTUB",IBDIV,"INPT_MRA",IBNAME_"@@"_DFN,IBDT,IBX)=1_U_IBMRA
;
INPTQ Q
;
RX(IBRX) ; - Check if prescription has been billed; if not,
; ^TMP($J,"IBTUB",DIVISION,"RX",NAME@@DFN,DATE@RX#,IBX)=bill status^drug name^
; original fill date
; ^TMP($J,"IBTUB",DIVISION,"RX_MRA",NAME@@DFN,DATE@RX#,IBX)=1 if req MRA
;
; *Pre-set variables: DFN=patient IEN, IBDT=refill date,
; IBRT=bill rate, IBRX=pointer to file #52,
; IBEDT=reporting period date
I '$G(DFN)!('$G(IBDT))!('$G(IBRT))!('$G(IBRX)) G RXQ
N IBDATA,IBDAY,IBDRX,IBFL,IBFLG,IBOFD,IBNAME,IBND,IBNO,IBNCF,RX,X,RXDT,IBMRA,IBCO,IBCLIN,IBDIV
;
; - Be sure prescription has an RX#.
S IBND=$$RXZERO^IBRXUTL(DFN,IBRX),IBNO=$P(IBND,U) G:IBNO="" RXQ
;
; - Retrieve the Prescription Original Fill Date
S IBOFD=$$FILE^IBRXUTL(IBRX,22)\1
;
S IBDAY=$E(IBDT,1,7),IBDRX=IBDAY_"@@"_IBNO,IBNAME=$P($G(^DPT(DFN,0)),U)
;
; Get Division from Clinic associated with Rx. Default to VAMC
S IBCLIN=$$FILE^IBRXUTL(IBRX,5)
S IBDIV=$$GET1^DIQ(44,IBCLIN_",",3.5,"I") I IBDIV="" S IBDIV=999999
I $D(^TMP($J,"IBTUB-DIV")),'$D(^TMP($J,"IBTUB-DIV",IBDIV)) G RXQ ; Not a selected Division
;
; If the IBSBD flag is not set, then reset the Division to be
; 999999. This data will still be included, but the report
; will not be sorted by Division.
;
S:'$G(IBSBD) IBDIV=999999
;
; - Be sure that this fill was not already marked as unbilled.
I $D(^TMP($J,"IBTUB",IBDIV,"RX",IBNAME_"@@"_DFN,IBDRX,IBX)) G RXQ
;
; - Look at all fills of the prescription that are on a claim.
S (IBFL,X)="",(IBFLG,IBNCF,IBNCF(0),IBMRA)=0
F S X=$O(^IBA(362.4,"B",IBNO,X)) Q:'X D Q:IBFL
. S RX=$G(^IBA(362.4,X,0)),RXDT=$P(RX,U,3)\1
. I RXDT=IBOFD S IBFLG=1 ; Original Fill Date Billed?
. I RXDT'=IBDAY Q ; RX refill and claim refill dates not the same.
. ;
. ; - Skip bill if not authorized (and not meeting other criteria).
. S IBDATA=$$CKBIL^IBTUBOU($P(RX,U,2)) Q:IBDATA=""
. S IBNCF=IBNCF+1 ; Increment the number of bills on file for the episode
. ; If Compile/Store & Not authorized before reporting period - Quit.
. I $G(IBCOMP),$S($P(IBDATA,U,2)'=2:$P(IBDATA,U,3),1:$P(IBDATA,U,6))>IBEDT S IBNONMRA=0 Q
. S:$P(IBDATA,U,2)'=2 IBFL=1,IBMRA=0 ; at least 1 non-MRA bill exists
. S:$P(IBDATA,U,2)=2 IBMRA=1 ; at least 1 MRA bill exists
. Q
;
I IBFL G RXQ ; Refill has been billed.
;
RX1 ; - Calculate unbilled amounts.
I IBMRA D
. S IBUNB(IBDIV,"PRESCRP-MRA")=$G(IBUNB(IBDIV,"PRESCRP-MRA"))+1
. S IBUNB("PRESCRP-MRA")=$G(IBUNB("PRESCRP-MRA"))+1
. Q
E D
. S IBUNB(IBDIV,"PRESCRP")=$G(IBUNB(IBDIV,"PRESCRP"))+1
. S IBUNB("PRESCRP")=$G(IBUNB("PRESCRP"))+1
. Q
;
; Patch 437 update to call charge master with enough information
; to lookup actual cost of prescription
;
N IBBI,IBRSNEW,IBQTY,IBCOST,IBRFNUM,IBSUBND,IBFEE
;
; check charge master for the type of billing--VA Cost or not
S IBBI=$$EVNTITM^IBCRU3(+IBRT,3,"PRESCRIPTION FILL",IBDAY,.IBRSNEW)
;
I IBBI["VA COST" D
. ; if this is a refill look up the refill info for cost and quantity
. S IBRFNUM=$$RFLNUM^IBRXUTL(IBRX,IBDAY,"")
. I IBRFNUM>0 D
. . S IBSUBND=$$ZEROSUB^IBRXUTL(DFN,IBRX,IBRFNUM)
. . S IBQTY=$P($G(IBSUBND),U,4)
. . S IBCOST=$P($G(IBSUBND),U,11)
. . Q
. ;
. ; if this was an original fill use the Rx info already in IBND
. I $G(IBQTY)'>0 S IBQTY=$P($G(IBND),U,7)
. I $G(IBCOST)'>0 S IBCOST=$P($G(IBND),U,17)
. ;
. S IBRSNEW=+$O(IBRSNEW($P(IBBI,";"),0))
. S IBCO=$J($$RATECHG^IBCRCC(+IBRSNEW,IBQTY*IBCOST,IBDAY,.IBFEE),0,2)
. Q
E D
. S IBCO=$$BICOST^IBCRCI(IBRT,3,IBDAY,"PRESCRIPTION FILL")
. Q
;
I IBMRA D
. S IBUNB(IBDIV,"UNBILRX-MRA")=$G(IBUNB(IBDIV,"UNBILRX-MRA"))+IBCO
. S IBUNB("UNBILRX-MRA")=$G(IBUNB("UNBILRX-MRA"))+IBCO
. Q
I 'IBMRA D
. S IBUNB(IBDIV,"UNBILRX")=$G(IBUNB(IBDIV,"UNBILRX"))+IBCO
. S IBUNB("UNBILRX")=$G(IBUNB("UNBILRX"))+IBCO
. Q
I $G(IBXTRACT) D ; For DM extract.
. S IB(17)=IB(17)+1
. S IB(18)=IB(18)+IBCO
. Q
;
; - Set global for report.
D ZERO^IBRXUTL(+$P(IBND,U,6))
I $S($G(IBINMRA):1,1:'IBMRA) S ^TMP($J,"IBTUB",IBDIV,"RX",IBNAME_"@@"_DFN,IBDRX,IBX)=IBNCF_U_$P($G(^VA(200,+$P(IBND,U,4),0)),U)_U_$$FILE^IBRXUTL(IBRX,22)_U_U_IBFLG_U_$G(^TMP($J,"IBDRUG",+$P(IBND,U,6),.01))
I IBMRA,$G(IBINMRA) S ^TMP($J,"IBTUB",IBDIV,"RX_MRA",IBNAME_"@@"_DFN,IBDRX,IBX)=1
K ^TMP($J,"IBDRUG")
;
RXQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTUBO2 8394 printed Sep 23, 2025@20:05:28 Page 2
IBTUBO2 ;ALB/AAS - UNBILLED AMOUNTS - GENERATE UNBILLED REPORTS ;03 Aug 2004 8:21 AM
+1 ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,192,155,309,347,437,516,547**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
INPT(DGPM) ; - Check if inpatient episode has bills or final bill; if not,
+1 ; ^TMP($J,"IBTUB",DIVISION,"INPT",NAME@@DFN,DATE,IBX)=bill status
+2 ; ^TMP($J,"IBTUB",DIVISION,"INPT_MRA",NAME@@DFN,DATE,IBX)=1 if MRA request
+3 ; *Pre-set variables: DFN=patient IEN, DGPM=pointer to file #405,
+4 ; IBDT=event date, IBRT=bill rate,
+5 ; IBEDT=reporting period date
+6 ;
+7 IF '$GET(DFN)!('$GET(DGPM))!('$GET(IBDT))!('$GET(IBRT))
GOTO INPTQ
+8 NEW IBIP,IBDATA,IBNAME,IBNCF,IBXX,X,Y,IBMRA,IBDIV,IBWARD
+9 SET IBNAME=$PIECE($GET(^DPT(DFN,0)),U)
+10 ;
+11 ; Get Division. Default to main Division if not in Ward location
+12 ;Determine Ward location.
SET IBWARD=$$GET1^DIQ(405,DGPM_",",.06,"I")
+13 SET IBDIV=$$GET1^DIQ(42,IBWARD_",",.015,"I")
IF IBDIV=""
SET IBDIV=$$PRIM^VASITE()
+14 ; Not a selected Division
IF $DATA(^TMP($JOB,"IBTUB-DIV"))
IF '$DATA(^TMP($JOB,"IBTUB-DIV",IBDIV))
GOTO INPTQ
+15 ;
+16 ; If the IBSBD flag is not set, then reset the Division to be
+17 ; 999999. This data will still be included, but the report
+18 ; will not be sorted by Division.
+19 ;
+20 if '$GET(IBSBD)
SET IBDIV=999999
+21 ;
+22 IF $DATA(^TMP($JOB,"IBTUB",IBDIV,"INPT",IBNAME_"@@"_DFN,IBDT))
GOTO INPTQ
+23 ;
+24 ; Admitted for SC condition.
IF $PIECE($GET(^DGPM(DGPM,0)),U,11)
GOTO INPTQ
+25 ; Check PTF for SC.
IF $$SC^IBTUBOU($PIECE($GET(^DGPM(DGPM,0)),U,16))
GOTO INPTQ
+26 ; Set claim flags.
SET (IBIP(1),IBIP(2))=0
+27 ;
+28 ; - Check patient's claims.
+29 SET (IBNCF,X)=0
+30 FOR
SET X=$ORDER(^DGCR(399,"C",DFN,X))
if 'X
QUIT
Begin DoDot:1
+31 SET IBDATA=$$CKBIL^IBTUBOU(X,1)
if IBDATA=""
QUIT
+32 ;
+33 ; The admission date on the bill is different from the Event date.
+34 IF $PIECE(IBDATA,U,5)'=$PIECE(IBDT,".")
QUIT
+35 ; Increment the number of bills on file for episode
SET IBNCF=IBNCF+1
+36 ;
+37 ; If Compile/Store & Not authorized before reporting period - Quit.
+38 IF $GET(IBCOMP)
IF $SELECT($PIECE(IBDATA,U,2)'=2:$PIECE(IBDATA,U,3),1:$PIECE(IBDATA,U,6))>IBEDT
QUIT
+39 ;
+40 ; Episode billed for inst/prof bill type
SET IBIP($PIECE(IBDATA,U,4))=$SELECT($PIECE(IBDATA,U,2)'=2:1,1:2)
+41 QUIT
End DoDot:1
if IBIP(1)&(IBIP(2))
QUIT
+42 ;
+43 ; Episode is billed.
IF IBIP(1)=1
if IBIP(2)=1!(IBDT<2990901)
GOTO INPTQ
+44 ;
+45 ; - Add to episodes missing inst./prof. bills.
+46 SET (IBXX,IBMRA)=""
+47 ;
+48 IF IBIP(1)'=1
Begin DoDot:1
+49 IF 'IBIP(1)
Begin DoDot:2
+50 SET IBUNB(IBDIV,"EPISM-I")=$GET(IBUNB(IBDIV,"EPISM-I"))+1
+51 SET IBUNB("EPISM-I")=$GET(IBUNB("EPISM-I"))+1
+52 IF IBDET
SET IBXX="I"
+53 QUIT
End DoDot:2
+54 ; For DM extract.
IF $GET(IBXTRACT)
SET IB(1)=IB(1)+1
+55 IF IBIP(1)=2
Begin DoDot:2
+56 SET IBUNB(IBDIV,"EPISM-I-MRA")=$GET(IBUNB(IBDIV,"EPISM-I-MRA"))+1
+57 SET IBUNB("EPISM-I-MRA")=$GET(IBUNB("EPISM-I-MRA"))+1
+58 IF IBDET
SET IBMRA="I"
+59 QUIT
End DoDot:2
+60 QUIT
End DoDot:1
+61 ;
+62 IF IBIP(2)'=1
IF IBDT'<2990901
Begin DoDot:1
+63 IF 'IBIP(2)
Begin DoDot:2
+64 SET IBUNB(IBDIV,"EPISM-P")=$GET(IBUNB(IBDIV,"EPISM-P"))+1
+65 SET IBUNB("EPISM-P")=$GET(IBUNB("EPISM-P"))+1
+66 IF IBDET
SET IBXX=$SELECT(IBXX="I":"I,P",1:"P")
+67 QUIT
End DoDot:2
+68 ; For DM extract.
IF $GET(IBXTRACT)
SET IB(3)=IB(3)+1
+69 IF IBIP(2)=2
Begin DoDot:2
+70 SET IBUNB(IBDIV,"EPISM-P-MRA")=$GET(IBUNB(IBDIV,"EPISM-P-MRA"))+1
+71 SET IBUNB("EPISM-P-MRA")=$GET(IBUNB("EPISM-P-MRA"))+1
+72 IF IBDET
SET IBMRA=$SELECT(IBMRA="I":"I,P",1:"P")
+73 QUIT
End DoDot:2
+74 QUIT
End DoDot:1
+75 ;
+76 ; Number of Admissions missing claims
IF 'IBIP(1)!'IBIP(2)
Begin DoDot:1
+77 SET IBUNB(IBDIV,"EPISM-A")=$GET(IBUNB(IBDIV,"EPISM-A"))+1
+78 SET IBUNB("EPISM-A")=$GET(IBUNB("EPISM-A"))+1
End DoDot:1
+79 IF IBIP(1)=2!(IBIP(2)=2)
Begin DoDot:1
+80 SET IBUNB(IBDIV,"EPISM-A-MRA")=$GET(IBUNB(IBDIV,"EPISM-A-MRA"))+1
+81 SET IBUNB("EPISM-A-MRA")=$GET(IBUNB("EPISM-A-MRA"))+1
End DoDot:1
+82 ; For DM extract.
IF $GET(IBXTRACT)
SET IB(5)=IB(5)+1
+83 ;
+84 IF '$GET(IBINMRA)
IF IBIP(1)=2
if IBIP(2)=1
GOTO INPTQ
+85 IF '$GET(IBINMRA)
IF IBIP(2)=2
if IBIP(1)=1
GOTO INPTQ
+86 ;
+87 ; - Set global for report.
+88 IF $SELECT($GET(IBINMRA):1,1:IBXX'="")
SET ^TMP($JOB,"IBTUB",IBDIV,"INPT",IBNAME_"@@"_DFN,IBDT,IBX)=IBNCF_U_IBXX_U_U_U_$$HOSP^IBTUBOU(DGPM)
+89 IF IBMRA'=""
IF $GET(IBINMRA)
SET ^TMP($JOB,"IBTUB",IBDIV,"INPT_MRA",IBNAME_"@@"_DFN,IBDT,IBX)=1_U_IBMRA
+90 ;
INPTQ QUIT
+1 ;
RX(IBRX) ; - Check if prescription has been billed; if not,
+1 ; ^TMP($J,"IBTUB",DIVISION,"RX",NAME@@DFN,DATE@RX#,IBX)=bill status^drug name^
+2 ; original fill date
+3 ; ^TMP($J,"IBTUB",DIVISION,"RX_MRA",NAME@@DFN,DATE@RX#,IBX)=1 if req MRA
+4 ;
+5 ; *Pre-set variables: DFN=patient IEN, IBDT=refill date,
+6 ; IBRT=bill rate, IBRX=pointer to file #52,
+7 ; IBEDT=reporting period date
+8 IF '$GET(DFN)!('$GET(IBDT))!('$GET(IBRT))!('$GET(IBRX))
GOTO RXQ
+9 NEW IBDATA,IBDAY,IBDRX,IBFL,IBFLG,IBOFD,IBNAME,IBND,IBNO,IBNCF,RX,X,RXDT,IBMRA,IBCO,IBCLIN,IBDIV
+10 ;
+11 ; - Be sure prescription has an RX#.
+12 SET IBND=$$RXZERO^IBRXUTL(DFN,IBRX)
SET IBNO=$PIECE(IBND,U)
if IBNO=""
GOTO RXQ
+13 ;
+14 ; - Retrieve the Prescription Original Fill Date
+15 SET IBOFD=$$FILE^IBRXUTL(IBRX,22)\1
+16 ;
+17 SET IBDAY=$EXTRACT(IBDT,1,7)
SET IBDRX=IBDAY_"@@"_IBNO
SET IBNAME=$PIECE($GET(^DPT(DFN,0)),U)
+18 ;
+19 ; Get Division from Clinic associated with Rx. Default to VAMC
+20 SET IBCLIN=$$FILE^IBRXUTL(IBRX,5)
+21 SET IBDIV=$$GET1^DIQ(44,IBCLIN_",",3.5,"I")
IF IBDIV=""
SET IBDIV=999999
+22 ; Not a selected Division
IF $DATA(^TMP($JOB,"IBTUB-DIV"))
IF '$DATA(^TMP($JOB,"IBTUB-DIV",IBDIV))
GOTO RXQ
+23 ;
+24 ; If the IBSBD flag is not set, then reset the Division to be
+25 ; 999999. This data will still be included, but the report
+26 ; will not be sorted by Division.
+27 ;
+28 if '$GET(IBSBD)
SET IBDIV=999999
+29 ;
+30 ; - Be sure that this fill was not already marked as unbilled.
+31 IF $DATA(^TMP($JOB,"IBTUB",IBDIV,"RX",IBNAME_"@@"_DFN,IBDRX,IBX))
GOTO RXQ
+32 ;
+33 ; - Look at all fills of the prescription that are on a claim.
+34 SET (IBFL,X)=""
SET (IBFLG,IBNCF,IBNCF(0),IBMRA)=0
+35 FOR
SET X=$ORDER(^IBA(362.4,"B",IBNO,X))
if 'X
QUIT
Begin DoDot:1
+36 SET RX=$GET(^IBA(362.4,X,0))
SET RXDT=$PIECE(RX,U,3)\1
+37 ; Original Fill Date Billed?
IF RXDT=IBOFD
SET IBFLG=1
+38 ; RX refill and claim refill dates not the same.
IF RXDT'=IBDAY
QUIT
+39 ;
+40 ; - Skip bill if not authorized (and not meeting other criteria).
+41 SET IBDATA=$$CKBIL^IBTUBOU($PIECE(RX,U,2))
if IBDATA=""
QUIT
+42 ; Increment the number of bills on file for the episode
SET IBNCF=IBNCF+1
+43 ; If Compile/Store & Not authorized before reporting period - Quit.
+44 IF $GET(IBCOMP)
IF $SELECT($PIECE(IBDATA,U,2)'=2:$PIECE(IBDATA,U,3),1:$PIECE(IBDATA,U,6))>IBEDT
SET IBNONMRA=0
QUIT
+45 ; at least 1 non-MRA bill exists
if $PIECE(IBDATA,U,2)'=2
SET IBFL=1
SET IBMRA=0
+46 ; at least 1 MRA bill exists
if $PIECE(IBDATA,U,2)=2
SET IBMRA=1
+47 QUIT
End DoDot:1
if IBFL
QUIT
+48 ;
+49 ; Refill has been billed.
IF IBFL
GOTO RXQ
+50 ;
RX1 ; - Calculate unbilled amounts.
+1 IF IBMRA
Begin DoDot:1
+2 SET IBUNB(IBDIV,"PRESCRP-MRA")=$GET(IBUNB(IBDIV,"PRESCRP-MRA"))+1
+3 SET IBUNB("PRESCRP-MRA")=$GET(IBUNB("PRESCRP-MRA"))+1
+4 QUIT
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET IBUNB(IBDIV,"PRESCRP")=$GET(IBUNB(IBDIV,"PRESCRP"))+1
+7 SET IBUNB("PRESCRP")=$GET(IBUNB("PRESCRP"))+1
+8 QUIT
End DoDot:1
+9 ;
+10 ; Patch 437 update to call charge master with enough information
+11 ; to lookup actual cost of prescription
+12 ;
+13 NEW IBBI,IBRSNEW,IBQTY,IBCOST,IBRFNUM,IBSUBND,IBFEE
+14 ;
+15 ; check charge master for the type of billing--VA Cost or not
+16 SET IBBI=$$EVNTITM^IBCRU3(+IBRT,3,"PRESCRIPTION FILL",IBDAY,.IBRSNEW)
+17 ;
+18 IF IBBI["VA COST"
Begin DoDot:1
+19 ; if this is a refill look up the refill info for cost and quantity
+20 SET IBRFNUM=$$RFLNUM^IBRXUTL(IBRX,IBDAY,"")
+21 IF IBRFNUM>0
Begin DoDot:2
+22 SET IBSUBND=$$ZEROSUB^IBRXUTL(DFN,IBRX,IBRFNUM)
+23 SET IBQTY=$PIECE($GET(IBSUBND),U,4)
+24 SET IBCOST=$PIECE($GET(IBSUBND),U,11)
+25 QUIT
End DoDot:2
+26 ;
+27 ; if this was an original fill use the Rx info already in IBND
+28 IF $GET(IBQTY)'>0
SET IBQTY=$PIECE($GET(IBND),U,7)
+29 IF $GET(IBCOST)'>0
SET IBCOST=$PIECE($GET(IBND),U,17)
+30 ;
+31 SET IBRSNEW=+$ORDER(IBRSNEW($PIECE(IBBI,";"),0))
+32 SET IBCO=$JUSTIFY($$RATECHG^IBCRCC(+IBRSNEW,IBQTY*IBCOST,IBDAY,.IBFEE),0,2)
+33 QUIT
End DoDot:1
+34 IF '$TEST
Begin DoDot:1
+35 SET IBCO=$$BICOST^IBCRCI(IBRT,3,IBDAY,"PRESCRIPTION FILL")
+36 QUIT
End DoDot:1
+37 ;
+38 IF IBMRA
Begin DoDot:1
+39 SET IBUNB(IBDIV,"UNBILRX-MRA")=$GET(IBUNB(IBDIV,"UNBILRX-MRA"))+IBCO
+40 SET IBUNB("UNBILRX-MRA")=$GET(IBUNB("UNBILRX-MRA"))+IBCO
+41 QUIT
End DoDot:1
+42 IF 'IBMRA
Begin DoDot:1
+43 SET IBUNB(IBDIV,"UNBILRX")=$GET(IBUNB(IBDIV,"UNBILRX"))+IBCO
+44 SET IBUNB("UNBILRX")=$GET(IBUNB("UNBILRX"))+IBCO
+45 QUIT
End DoDot:1
+46 ; For DM extract.
IF $GET(IBXTRACT)
Begin DoDot:1
+47 SET IB(17)=IB(17)+1
+48 SET IB(18)=IB(18)+IBCO
+49 QUIT
End DoDot:1
+50 ;
+51 ; - Set global for report.
+52 DO ZERO^IBRXUTL(+$PIECE(IBND,U,6))
+53 IF $SELECT($GET(IBINMRA):1,1:'IBMRA)
SET ^TMP($JOB,"IBTUB",IBDIV,"RX",IBNAME_"@@"_DFN,IBDRX,IBX)=IBNCF_U_$PIECE($GET(^VA(200,+$PIECE(IBND,U,4),0)),U)_U_$$FILE^IBRXUTL(IBRX,22)_U_U_IBFLG_U_$GET(^TMP($JOB,"IBDRUG",+$PIECE(IBND,U,6),.01))
+54 IF IBMRA
IF $GET(IBINMRA)
SET ^TMP($JOB,"IBTUB",IBDIV,"RX_MRA",IBNAME_"@@"_DFN,IBDRX,IBX)=1
+55 KILL ^TMP($JOB,"IBDRUG")
+56 ;
RXQ QUIT
