Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBTUBO2

IBTUBO2.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. 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
  1. ; ^TMP($J,"IBTUB",DIVISION,"INPT_MRA",NAME@@DFN,DATE,IBX)=1 if MRA request
  1. ; *Pre-set variables: DFN=patient IEN, DGPM=pointer to file #405,
  1. ; IBDT=event date, IBRT=bill rate,
  1. ; IBEDT=reporting period date
  1. ;
  1. I '$G(DFN)!('$G(DGPM))!('$G(IBDT))!('$G(IBRT)) G INPTQ
  1. N IBIP,IBDATA,IBNAME,IBNCF,IBXX,X,Y,IBMRA,IBDIV,IBWARD
  1. S IBNAME=$P($G(^DPT(DFN,0)),U)
  1. ;
  1. ; Get Division. Default to main Division if not in Ward location
  1. S IBWARD=$$GET1^DIQ(405,DGPM_",",.06,"I") ;Determine Ward location.
  1. S IBDIV=$$GET1^DIQ(42,IBWARD_",",.015,"I") I IBDIV="" S IBDIV=$$PRIM^VASITE()
  1. I $D(^TMP($J,"IBTUB-DIV")),'$D(^TMP($J,"IBTUB-DIV",IBDIV)) G INPTQ ; Not a selected Division
  1. ;
  1. ; If the IBSBD flag is not set, then reset the Division to be
  1. ; 999999. This data will still be included, but the report
  1. ; will not be sorted by Division.
  1. ;
  1. S:'$G(IBSBD) IBDIV=999999
  1. ;
  1. I $D(^TMP($J,"IBTUB",IBDIV,"INPT",IBNAME_"@@"_DFN,IBDT)) G INPTQ
  1. ;
  1. I $P($G(^DGPM(DGPM,0)),U,11) G INPTQ ; Admitted for SC condition.
  1. I $$SC^IBTUBOU($P($G(^DGPM(DGPM,0)),U,16)) G INPTQ ; Check PTF for SC.
  1. S (IBIP(1),IBIP(2))=0 ; Set claim flags.
  1. ;
  1. ; - Check patient's claims.
  1. S (IBNCF,X)=0
  1. F S X=$O(^DGCR(399,"C",DFN,X)) Q:'X D Q:IBIP(1)&(IBIP(2))
  1. . S IBDATA=$$CKBIL^IBTUBOU(X,1) Q:IBDATA=""
  1. . ;
  1. . ; The admission date on the bill is different from the Event date.
  1. . I $P(IBDATA,U,5)'=$P(IBDT,".") Q
  1. . S IBNCF=IBNCF+1 ; Increment the number of bills on file for episode
  1. . ;
  1. . ; If Compile/Store & Not authorized before reporting period - Quit.
  1. . I $G(IBCOMP),$S($P(IBDATA,U,2)'=2:$P(IBDATA,U,3),1:$P(IBDATA,U,6))>IBEDT Q
  1. . ;
  1. . S IBIP($P(IBDATA,U,4))=$S($P(IBDATA,U,2)'=2:1,1:2) ; Episode billed for inst/prof bill type
  1. . Q
  1. ;
  1. I IBIP(1)=1 G:IBIP(2)=1!(IBDT<2990901) INPTQ ; Episode is billed.
  1. ;
  1. ; - Add to episodes missing inst./prof. bills.
  1. S (IBXX,IBMRA)=""
  1. ;
  1. I IBIP(1)'=1 D
  1. . I 'IBIP(1) D
  1. . . S IBUNB(IBDIV,"EPISM-I")=$G(IBUNB(IBDIV,"EPISM-I"))+1
  1. . . S IBUNB("EPISM-I")=$G(IBUNB("EPISM-I"))+1
  1. . . I IBDET S IBXX="I"
  1. . . Q
  1. . I $G(IBXTRACT) S IB(1)=IB(1)+1 ; For DM extract.
  1. . I IBIP(1)=2 D
  1. . . S IBUNB(IBDIV,"EPISM-I-MRA")=$G(IBUNB(IBDIV,"EPISM-I-MRA"))+1
  1. . . S IBUNB("EPISM-I-MRA")=$G(IBUNB("EPISM-I-MRA"))+1
  1. . . I IBDET S IBMRA="I"
  1. . . Q
  1. . Q
  1. ;
  1. I IBIP(2)'=1,IBDT'<2990901 D
  1. . I 'IBIP(2) D
  1. . . S IBUNB(IBDIV,"EPISM-P")=$G(IBUNB(IBDIV,"EPISM-P"))+1
  1. . . S IBUNB("EPISM-P")=$G(IBUNB("EPISM-P"))+1
  1. . . I IBDET S IBXX=$S(IBXX="I":"I,P",1:"P")
  1. . . Q
  1. . I $G(IBXTRACT) S IB(3)=IB(3)+1 ; For DM extract.
  1. . I IBIP(2)=2 D
  1. . . S IBUNB(IBDIV,"EPISM-P-MRA")=$G(IBUNB(IBDIV,"EPISM-P-MRA"))+1
  1. . . S IBUNB("EPISM-P-MRA")=$G(IBUNB("EPISM-P-MRA"))+1
  1. . . I IBDET S IBMRA=$S(IBMRA="I":"I,P",1:"P")
  1. . . Q
  1. . Q
  1. ;
  1. I 'IBIP(1)!'IBIP(2) D ; Number of Admissions missing claims
  1. . S IBUNB(IBDIV,"EPISM-A")=$G(IBUNB(IBDIV,"EPISM-A"))+1
  1. . S IBUNB("EPISM-A")=$G(IBUNB("EPISM-A"))+1
  1. I IBIP(1)=2!(IBIP(2)=2) D
  1. . S IBUNB(IBDIV,"EPISM-A-MRA")=$G(IBUNB(IBDIV,"EPISM-A-MRA"))+1
  1. . S IBUNB("EPISM-A-MRA")=$G(IBUNB("EPISM-A-MRA"))+1
  1. I $G(IBXTRACT) S IB(5)=IB(5)+1 ; For DM extract.
  1. ;
  1. I '$G(IBINMRA),IBIP(1)=2 G:IBIP(2)=1 INPTQ
  1. I '$G(IBINMRA),IBIP(2)=2 G:IBIP(1)=1 INPTQ
  1. ;
  1. ; - Set global for report.
  1. 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)
  1. I IBMRA'="",$G(IBINMRA) S ^TMP($J,"IBTUB",IBDIV,"INPT_MRA",IBNAME_"@@"_DFN,IBDT,IBX)=1_U_IBMRA
  1. ;
  1. INPTQ Q
  1. ;
  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^
  1. ; original fill date
  1. ; ^TMP($J,"IBTUB",DIVISION,"RX_MRA",NAME@@DFN,DATE@RX#,IBX)=1 if req MRA
  1. ;
  1. ; *Pre-set variables: DFN=patient IEN, IBDT=refill date,
  1. ; IBRT=bill rate, IBRX=pointer to file #52,
  1. ; IBEDT=reporting period date
  1. I '$G(DFN)!('$G(IBDT))!('$G(IBRT))!('$G(IBRX)) G RXQ
  1. N IBDATA,IBDAY,IBDRX,IBFL,IBFLG,IBOFD,IBNAME,IBND,IBNO,IBNCF,RX,X,RXDT,IBMRA,IBCO,IBCLIN,IBDIV
  1. ;
  1. ; - Be sure prescription has an RX#.
  1. S IBND=$$RXZERO^IBRXUTL(DFN,IBRX),IBNO=$P(IBND,U) G:IBNO="" RXQ
  1. ;
  1. ; - Retrieve the Prescription Original Fill Date
  1. S IBOFD=$$FILE^IBRXUTL(IBRX,22)\1
  1. ;
  1. S IBDAY=$E(IBDT,1,7),IBDRX=IBDAY_"@@"_IBNO,IBNAME=$P($G(^DPT(DFN,0)),U)
  1. ;
  1. ; Get Division from Clinic associated with Rx. Default to VAMC
  1. S IBCLIN=$$FILE^IBRXUTL(IBRX,5)
  1. S IBDIV=$$GET1^DIQ(44,IBCLIN_",",3.5,"I") I IBDIV="" S IBDIV=999999
  1. I $D(^TMP($J,"IBTUB-DIV")),'$D(^TMP($J,"IBTUB-DIV",IBDIV)) G RXQ ; Not a selected Division
  1. ;
  1. ; If the IBSBD flag is not set, then reset the Division to be
  1. ; 999999. This data will still be included, but the report
  1. ; will not be sorted by Division.
  1. ;
  1. S:'$G(IBSBD) IBDIV=999999
  1. ;
  1. ; - Be sure that this fill was not already marked as unbilled.
  1. I $D(^TMP($J,"IBTUB",IBDIV,"RX",IBNAME_"@@"_DFN,IBDRX,IBX)) G RXQ
  1. ;
  1. ; - Look at all fills of the prescription that are on a claim.
  1. S (IBFL,X)="",(IBFLG,IBNCF,IBNCF(0),IBMRA)=0
  1. F S X=$O(^IBA(362.4,"B",IBNO,X)) Q:'X D Q:IBFL
  1. . S RX=$G(^IBA(362.4,X,0)),RXDT=$P(RX,U,3)\1
  1. . I RXDT=IBOFD S IBFLG=1 ; Original Fill Date Billed?
  1. . I RXDT'=IBDAY Q ; RX refill and claim refill dates not the same.
  1. . ;
  1. . ; - Skip bill if not authorized (and not meeting other criteria).
  1. . S IBDATA=$$CKBIL^IBTUBOU($P(RX,U,2)) Q:IBDATA=""
  1. . S IBNCF=IBNCF+1 ; Increment the number of bills on file for the episode
  1. . ; If Compile/Store & Not authorized before reporting period - Quit.
  1. . I $G(IBCOMP),$S($P(IBDATA,U,2)'=2:$P(IBDATA,U,3),1:$P(IBDATA,U,6))>IBEDT S IBNONMRA=0 Q
  1. . S:$P(IBDATA,U,2)'=2 IBFL=1,IBMRA=0 ; at least 1 non-MRA bill exists
  1. . S:$P(IBDATA,U,2)=2 IBMRA=1 ; at least 1 MRA bill exists
  1. . Q
  1. ;
  1. I IBFL G RXQ ; Refill has been billed.
  1. ;
  1. RX1 ; - Calculate unbilled amounts.
  1. I IBMRA D
  1. . S IBUNB(IBDIV,"PRESCRP-MRA")=$G(IBUNB(IBDIV,"PRESCRP-MRA"))+1
  1. . S IBUNB("PRESCRP-MRA")=$G(IBUNB("PRESCRP-MRA"))+1
  1. . Q
  1. E D
  1. . S IBUNB(IBDIV,"PRESCRP")=$G(IBUNB(IBDIV,"PRESCRP"))+1
  1. . S IBUNB("PRESCRP")=$G(IBUNB("PRESCRP"))+1
  1. . Q
  1. ;
  1. ; Patch 437 update to call charge master with enough information
  1. ; to lookup actual cost of prescription
  1. ;
  1. N IBBI,IBRSNEW,IBQTY,IBCOST,IBRFNUM,IBSUBND,IBFEE
  1. ;
  1. ; check charge master for the type of billing--VA Cost or not
  1. S IBBI=$$EVNTITM^IBCRU3(+IBRT,3,"PRESCRIPTION FILL",IBDAY,.IBRSNEW)
  1. ;
  1. I IBBI["VA COST" D
  1. . ; if this is a refill look up the refill info for cost and quantity
  1. . S IBRFNUM=$$RFLNUM^IBRXUTL(IBRX,IBDAY,"")
  1. . I IBRFNUM>0 D
  1. . . S IBSUBND=$$ZEROSUB^IBRXUTL(DFN,IBRX,IBRFNUM)
  1. . . S IBQTY=$P($G(IBSUBND),U,4)
  1. . . S IBCOST=$P($G(IBSUBND),U,11)
  1. . . Q
  1. . ;
  1. . ; if this was an original fill use the Rx info already in IBND
  1. . I $G(IBQTY)'>0 S IBQTY=$P($G(IBND),U,7)
  1. . I $G(IBCOST)'>0 S IBCOST=$P($G(IBND),U,17)
  1. . ;
  1. . S IBRSNEW=+$O(IBRSNEW($P(IBBI,";"),0))
  1. . S IBCO=$J($$RATECHG^IBCRCC(+IBRSNEW,IBQTY*IBCOST,IBDAY,.IBFEE),0,2)
  1. . Q
  1. E D
  1. . S IBCO=$$BICOST^IBCRCI(IBRT,3,IBDAY,"PRESCRIPTION FILL")
  1. . Q
  1. ;
  1. I IBMRA D
  1. . S IBUNB(IBDIV,"UNBILRX-MRA")=$G(IBUNB(IBDIV,"UNBILRX-MRA"))+IBCO
  1. . S IBUNB("UNBILRX-MRA")=$G(IBUNB("UNBILRX-MRA"))+IBCO
  1. . Q
  1. I 'IBMRA D
  1. . S IBUNB(IBDIV,"UNBILRX")=$G(IBUNB(IBDIV,"UNBILRX"))+IBCO
  1. . S IBUNB("UNBILRX")=$G(IBUNB("UNBILRX"))+IBCO
  1. . Q
  1. I $G(IBXTRACT) D ; For DM extract.
  1. . S IB(17)=IB(17)+1
  1. . S IB(18)=IB(18)+IBCO
  1. . Q
  1. ;
  1. ; - Set global for report.
  1. D ZERO^IBRXUTL(+$P(IBND,U,6))
  1. 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))
  1. I IBMRA,$G(IBINMRA) S ^TMP($J,"IBTUB",IBDIV,"RX_MRA",IBNAME_"@@"_DFN,IBDRX,IBX)=1
  1. K ^TMP($J,"IBDRUG")
  1. ;
  1. RXQ Q