- 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 Jan 18, 2025@03:30:18 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