IBEFSMUT ;SLC/RM - OTH FSM and PP BILLING STATUS UTILITY ; Sep 29, 2020@3:51 pm
;;2.0;INTEGRATED BILLING;**688,697**;March 21, 1994;Build 12
;;Per VA Directive 6402, this routine should not be modified.
;
;Global References Supported by ICR# Type
;----------------- ----------------- ----------
; ^TMP($J SACC 2.3.2.5.1
; ^TMP("IBECEA" SACC 2.3.2.5.1
; ^TMP("IBRBT" SACC 2.3.2.5.1
;
;External References
;-------------------
; $$GET1^DIQ 2056 Supported
; GETS^DIQ 2056 Supported
; Y^DIQ 2056 Supported
; RX^PSO52API 4820 Supported
;
Q ;No direct access
;
EN(DFN,BEGDT,ENDDT,LIST) ;retrieve the IB STATUS from either File #399 and #350
;Input :
; DFN : Internal entry number from the PATIENT file (#2) [required]
; BEGDT : Date of Service [required]
; ENDDT : Date of Service [required]
; LIST : Subscript name used in ^TMP global [REQUIRED]
;Output :
; Return the requested data elements from either File #399 and #350
;
N IBABEG,IBAEND,IBCNT,IBOTHSTAT
S IBCNT=0
K ^TMP("IBECEA",$J) ;contain all date of service for the Visit/Encounter and Rx copayments
S IBOTHSTAT="^TMP($J,"""_LIST_""")" ;contain some IB data elements based on the user specified date range
S IBABEG=BEGDT,IBAEND=ENDDT
;check file #350 first if patient has a record
;if patient exist, collect all data and store it temporarily in ^TMP("IBECEA",$J)
I $D(@IBOTHSTAT@(350,DFN,0)) S IBCNT=@IBOTHSTAT@(350,DFN,0)
I $D(^IB("C",DFN)) D
. D APTDT^IBECEA0 ;Rx charges
. I $D(^IB("AFDT",DFN)) D APDT^IBECEA0 ;Means Test and CHAMPVA charges
. I $D(^TMP("IBECEA",$J)) D IB350
S @IBOTHSTAT@(350,DFN,0)=$S(IBCNT>0:IBCNT,1:"-1^NO DATA FOUND")
;
;check file #399 if patient also has a record
;if patient exist, collect all data and store it temporarily in ^TMP("IBECEA",$J)
N SUB1,SUB2,IBDTFRM,IBDTTO,IBTYP399,IBN,IBD,RXRF399,IBNARR399
S (IBCNT,RXRF399,IBTYP399)=0
I $D(@IBOTHSTAT@(399,DFN,0)) S IBCNT=@IBOTHSTAT@(399,DFN,0)
I $D(^DGCR(399,"C",DFN)) D
. K ^TMP("IBRBT",$J),IBNARR399
. D IB399 ;collects all related bill for a patient in file #399
. ;after collecting all the bills for this patient,
. ;determine whether bill is inpatient,outpatient, or rx refill
. ;1 - inpatient (as per business owner, no rx since it is a combined bill)
. ;0 - outpatient
. S SUB1="" F S SUB1=$O(^TMP("IBRBT",$J,SUB1)) Q:SUB1="" D
. . S SUB2="" F S SUB2=$O(^TMP("IBRBT",$J,SUB1,SUB2)) Q:SUB2="" D
. . . ;quit if this IBN already been evaluated
. . . Q:$D(IBNARR399(SUB2))
. . . S (RXRF399,IBTYP399,IBN,IBD)=0
. . . S IBDTFRM=$P(^TMP("IBRBT",$J,SUB1,SUB2),U) ;date billed from (event date or the admission date)
. . . S IBDTTO=$P(^TMP("IBRBT",$J,SUB1,SUB2),U,2) ;date billed to (discharge date for inpatient)
. . . S IBTYP399=$$INPAT^IBCEF(SUB2,1) ;determine if bill is inpatient,outpatient, or rx refill
. . . ;check if the records we are looking is in the date range
. . . I +IBTYP399>0,'$$CHKDATE(IBDTFRM) Q ;IBDTFRM<IBABEG!(IBDTTO>IBAEND) Q ;inpatient date range check
. . . I +IBTYP399<1,'$$CHKDATE(IBDTFRM) Q ;outpatient date range check
. . . I +IBTYP399<1 S:$D(^IBA(362.4,"C",SUB2)) RXRF399=3 ;check if there any Rx refill included for this bill
. . . ;extract other data for this patient's bill to be displayed in the report
. . . S IBN=SUB2,IBD=IBDTFRM D DATA399
. . . S IBNARR399(SUB2)=""
S @IBOTHSTAT@(399,DFN,0)=$S(IBCNT>0:IBCNT,1:"-1^NO DATA FOUND")
K ^TMP("IBRBT",$J),^TMP("IBECEA",$J),IBNARR399
Q
;
DATA399 ;IB Status in File #399
N I,IBBILLNO,IBRTYPNME,IBRTYPIEN,IBSTAT,IBBLCLS,IBRTYPNME,IBRTYPIEN
N IBSTAT,IBRSLTFRM,IBCHG,IBNDU1,IBLSTUSR,IBDIV,IBND0,IBNDU,IBOEIEN
K IBARR,IBERR
D GETS^DIQ(399,IBN_",",".01;.02;.05;.07;.11;.13;.22;2;42*","IE","IBARR","IBERR")
Q:$D(IBERR)
Q:'$D(IBARR)
S (IBBILLNO,IBRTYPNME,IBRTYPIEN,IBSTAT)=""
S IBBILLNO=IBARR(399,IBN_",",.01,"I") ;bill no
S IBBLCLS=IBARR(399,IBN_",",.05,"I") ;bill classification
S IBRTYPNME=IBARR(399,IBN_",",.07,"E") ;rate type name
S IBRTYPIEN=IBARR(399,IBN_",",.07,"I") ;rate type ien
S IBSTAT=IBARR(399,IBN_",",.13,"E") ;bill status
S IBDIV=$$DIV^IBJDF2(IBN)
S IBOEIEN=$$OE(IBN,IBD)
S IBLSTUSR=IBARR(399,IBN_",",2,"E") ;user entered/edited the bill
F I=0,"U","U1" S @("IBND"_I)=$G(^DGCR(399,IBN,I))
;if inpatient, disregard whatever in the REVENUE CODE multiple 399,42
;as per business owner, it is a combined bill
I +IBTYP399>0 D Q
. S IBCNT=IBCNT+1
. S IBRSLTFRM=+IBTYP399_":"_IBARR(399,IBN_",",.05,"E")
. S IBCHG=$P(IBNDU1,"^",1)
. S IBOEIEN=$P(^DGCR(399,IBN,0),U,8)
. S @IBOTHSTAT@(399,IBD,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR_U_IBOEIEN
;otherwise, the bill is outpatient and may have RX refill
D RCODE399
K IBARR,IBERR
Q
;
OE(IBN,EVNTDT) ;extract the Outpatient Encounter ien in file #409.68
;Note: A single EVENT DATE can have one or more procedure charges but belongs to only ONE IEN in file #409.68
;If TMPOEIEN remains equal to 0, that means the outpatient charges is not related to any outpatient encounter in file #409.68
N PRD399,PRDCNTR,TMPOEIEN
S TMPOEIEN=0
I $D(^DGCR(399,"ASD",-EVNTDT)) D
. S PRD399="" F S PRD399=$O(^DGCR(399,"ASD",-EVNTDT,PRD399)) Q:PRD399=""!(TMPOEIEN>0) D
. . S PRDCNTR="" F S PRDCNTR=$O(^DGCR(399,"ASD",-EVNTDT,PRD399,IBN,PRDCNTR)) Q:PRDCNTR=""!(TMPOEIEN>0) D
. . . S TMPOEIEN=$P(^DGCR(399,IBN,"CP",PRDCNTR,0),U,20) ; extract the IEN for FILE #409.68
Q TMPOEIEN
;
RCODE399 ;traverse the RC multiple to determine charges for this event date
N IBRVCD,IBRCCNT,IBCHG,IBBEDSEC,IBAIEN,IBRSLTFRM,IBRCTYP,RXSTATUS,IBARELDT,IBARXNUM,IBARFLDT
N IBARFNUM,IBARXIEN,RXRCCNT,OLDBD,TYP399,RCCHRG
S (RXRCCNT,OLDBD)=0
S IBRVCD=0 F S IBRVCD=$O(^DGCR(399,IBN,"RC","B",IBRVCD)) Q:'IBRVCD D
. S IBRCCNT=0 F S IBRCCNT=$O(^DGCR(399,IBN,"RC","B",IBRVCD,IBRCCNT)) Q:'IBRCCNT D
. . ;check if this is the charge we are looking for this bill
. . S IBCHG=$P(^DGCR(399,IBN,"RC",IBRCCNT,0),U,4) ;total charge for this RC 399.042,.04
. . S IBRCTYP=$P(^DGCR(399,IBN,"RC",IBRCCNT,0),U,10) ;type 399.042, .1 (this could be opt,inpt, etc.)
. . S IBBEDSEC=$P(^DGCR(399,IBN,"RC",IBRCCNT,0),U,5) ;bedsection 399.042,.05
. . S IBBEDSEC=$$GET1^DIQ(399.1,IBBEDSEC_",",.01,"E")
. . I IBBEDSEC["PRESCRIPTION" D Q
. . . Q:RXRCCNT
. . . D IBARX362 S RXRCCNT=1 ;process all RX at once
. . ;otherwise, extract the NON-PRESCRIPTION data
. . ;group together ALL NON-PRESCRIPTION charges regardless of TYPE and BEDSECTION into an array
. . I OLDBD'=IBBEDSEC S RCCHRG=0
. . S RCCHRG=$G(RCCHRG)+IBCHG
. . S OLDBD=IBBEDSEC
. I IBBEDSEC'["PRESCRIPTION" D
. . S IBRSLTFRM=$S(IBBEDSEC'["PRESCRIPTION":2,1:IBRCTYP)_":"_IBBEDSEC_":"_+IBTYP399
. . S TYP399("NONRX")=IBRSLTFRM_U_RCCHRG
I $D(TYP399) D
. Q:$P($P(TYP399("NONRX"),U),":",2)["PRESCRIPTION"
. S IBCNT=IBCNT+1
. S IBRSLTFRM=$P(TYP399("NONRX"),U)
. S IBCHG=$P(TYP399("NONRX"),U,2)
. S @IBOTHSTAT@(399,IBD\1,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR_U_IBOEIEN
;some of the RX is not captured in file #399 however it is captured in file#362.4,extract this information as well
I RXRF399=3,'RXRCCNT D
. S IBCHG=0,IBBEDSEC="PRESCRIPTION"
. D IBARX362 S RXRCCNT=1
;some bill number does not have RC record
I '$D(^DGCR(399,IBN,"RC","B")) D
. F I=0,"U","U1" S @("IBND"_I)=$G(^DGCR(399,IBN,I))
. S IBCNT=IBCNT+1,IBCHG=+$P(IBNDU1,"^",1)
. S IBRSLTFRM=$S(IBBLCLS=3:2,IBBLCLS=4:2,1:+IBTYP399)_":"_IBARR(399,IBN_",",.05,"E")
. S @IBOTHSTAT@(399,IBD\1,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR_U_IBOEIEN
K TYP399
Q
;
IBARX362 ;determine what Rx is charged for
N FLDT52,IBARXSUPLY,IBRXPRTLTOT,JJJ,PSO52DYSUP,PRTLRFNUM
S IBARXNUM="" F S IBARXNUM=$O(^IBA(362.4,"AIFN"_IBN,IBARXNUM)) Q:IBARXNUM="" D
. S IBAIEN="" F S IBAIEN=$O(^IBA(362.4,"AIFN"_IBN,IBARXNUM,IBAIEN)) Q:IBAIEN="" D
. . S IBARFLDT=$P(^IBA(362.4,IBAIEN,0),U,3) ;this is the released date, a charge is created when rx is released
. . S IBARFNUM=$P(^IBA(362.4,IBAIEN,0),U,10) ;fill number
. . S IBARXIEN=$P(^IBA(362.4,IBAIEN,0),U,5) ;rxien in file #52
. . S IBARXSUPLY=$P(^IBA(362.4,IBAIEN,0),U,6) ;rx days supply
. . S (IBARELDT,FLDT52,IBRXPRTLTOT,PSO52DYSUP,PRTLRFNUM)=0
. . K ^TMP($J,"IBRX339") D RX^PSO52API(DFN,"IBRX339",,IBARXNUM,"2,R,P",IBABEG,$$FMADD^XLFDT(IBAEND,366))
. . I +^TMP($J,"IBRX339",DFN,0)<1 D RXPSO52 ;invoking this API twice since this API sometimes work, sometimes doesn't.
. . I +^TMP($J,"IBRX339",DFN,0)<1,+IBARXIEN>0 D
. . . K ^TMP($J,"IBRX339") D RX^PSO52API(DFN,"IBRX339",IBARXIEN,,"2,R,P",IBABEG,$$FMADD^XLFDT(IBAEND,366))
. . . I +^TMP($J,"IBRX339",DFN,0)<1 D RXPSO52
. . I +^TMP($J,"IBRX339",DFN,0)>0 D
. . . I +IBARXIEN<1 S IBARXIEN=$O(^TMP($J,"IBRX339","B",IBARXNUM,""))
. . . S RXSTATUS=$P(^TMP($J,"IBRX339",DFN,IBARXIEN,100),U) ;the current status of the RX
. . . I IBARFNUM="" D Q ;check if this CHARGE is for original or partial fill
. . . . D RXORGNAL
. . . . I +^TMP($J,"IBRX339",DFN,IBARXIEN,"P",0)>0 D ;check if there are any Rx partial fill for the same date OR if the rx charge is for Partial fill
. . . . S IBRXPRTLTOT=+^TMP($J,"IBRX339",DFN,IBARXIEN,"P",0)
. . . . F JJJ=1:1:IBRXPRTLTOT D
. . . . . S FLDT52=$P(^TMP($J,"IBRX339",DFN,IBARXIEN,"P",JJJ,.01),U) ;rx partill fill date
. . . . . S IBARELDT=$P(^TMP($J,"IBRX339",DFN,IBARXIEN,"P",JJJ,8),U) ;rx partial released date
. . . . . S PSO52DYSUP=$P(^TMP($J,"IBRX339",DFN,IBARXIEN,"P",JJJ,.041),U) ;file #52 days supply
. . . . . I (+IBARFLDT\1)=(+IBARELDT\1)!((+IBARFLDT\1)=+FLDT52\1) D
. . . . . . I IBARXSUPLY=PSO52DYSUP,$$CHKDATE(+IBARELDT\1) D
. . . . . . . S PRTLRFNUM=JJJ_"P" ;concatenating "P" with the partial fill number in order to distinguished from original, refill and partial fill
. . . . . . . D IBARXREC
. . . I IBARFNUM=0 D RXORGNAL ;this charge is for the rx original fill
. . . I +IBARFNUM>0,+$P(^TMP($J,"IBRX339",DFN,IBARXIEN,"RF",0),U)>0 D ;this charge if for rx refill
. . . . S FLDT52=$P(^TMP($J,"IBRX339",DFN,IBARXIEN,"RF",IBARFNUM,.01),U) ;rx refill fill date
. . . . S IBARELDT=$P(^TMP($J,"IBRX339",DFN,IBARXIEN,"RF",IBARFNUM,17),U) ;rx refill released date
. . . . I (+IBARFLDT\1)=(+IBARELDT\1),$$CHKDATE(+IBARELDT\1) D IBARXREC
. . E I +IBARFLDT,'+FLDT52 D ;this is where the RX # is in text format and does not exist in file #52. Rx status will not be checked since we will not know if it is active or not
. . . Q:'$$CHKDATE(+IBARFLDT\1) ;check if the rx fill date is within the date range
. . . S IBARXSUPLY=$P(^IBA(362.4,IBAIEN,0),U,6)
. . . S IBRSLTFRM=RXRF399_":"_IBBEDSEC_":"_+IBARXIEN_":"_IBARXNUM_"-"_IBARXSUPLY_":"_+IBARFNUM_":"_$S($G(RXSTATUS)'="":RXSTATUS,1:"")
. . . S IBCNT=IBCNT+1
. . . S @IBOTHSTAT@(399,IBARFLDT\1,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR
. . K ^TMP($J,"IBRX339")
Q
;
RXPSO52 ;
K ^TMP($J,"IBRX339")
D RX^PSO52API(DFN,"IBRX339",,IBARXNUM,"2,R,P",IBABEG,$$FMADD^XLFDT(IBAEND,366))
Q
;
RXORGNAL ;
S FLDT52=$P(^TMP($J,"IBRX339",DFN,IBARXIEN,22),U) ;rx original fill date
S IBARELDT=$P(^TMP($J,"IBRX339",DFN,IBARXIEN,31),U) ;rx original fill released date
S PSO52DYSUP=$P(^TMP($J,"IBRX339",DFN,IBARXIEN,8),U) ;file #52 days supply
I (+IBARFLDT\1)=(+IBARELDT\1)!((+IBARFLDT\1)=+FLDT52\1) D
. I IBARXSUPLY=PSO52DYSUP,$$CHKDATE(+IBARELDT\1) S IBARFNUM=0 D IBARXREC ;this is the original fill rx charge
Q
;
IBARXREC ;capture Rx data
S IBRSLTFRM=RXRF399_":"_IBBEDSEC_":"_IBARXIEN_":"_IBARXNUM_":"_$S(+PRTLRFNUM>0:PRTLRFNUM,1:IBARFNUM)_":"_$S($G(RXSTATUS)'="":RXSTATUS,1:"")
S IBCNT=IBCNT+1
S @IBOTHSTAT@(399,IBARELDT\1,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR
Q
;
IB350 ;extract IB status found in File #350
N IBD,IBN,IBND,IBSTAT,IBATYP,IBCHG,IBRSLTFRM,IBBILLNO,BILGROUP,CNT
S IBD="" F S IBD=$O(^TMP("IBECEA",$J,IBD)) Q:'IBD D
. S IBN="" F S IBN=$O(^TMP("IBECEA",$J,IBD,IBN)) Q:'IBN D
. . D IBSTA350
Q
;
IBSTA350 ;IB status found in File #350
N Y,C,IBDTBILLFR,IBCPTIER,IBDIV,IBSTPCODE,IBLSTUSR,IBCDENME
S IBND=^IB(IBN,0) ;Q:$P(IBND,"^",7)=""
S IBCNT=IBCNT+1,Y=$P(IBND,"^",5),C=$P(^DD(350,.05,0),"^",2) D Y^DIQ S IBSTAT=Y
S IBATYP=$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^") S:$E(IBATYP,1,2)="DG" IBATYP=$E(IBATYP,4,99)
S (IBSTPCODE,IBCDENME)=""
;if outpatient charge and clinic stop, extract it
I $E(IBATYP,1,3)="OPT",$P(IBND,"^",20) D
. S IBSTPCODE=$P($G(^IBE(352.5,+$P(IBND,"^",20),0)),"^") ;stop code number
. I $D(^IBE(352.5,"B",+IBSTPCODE)) S IBCDENME=$O(^IBE(352.5,"B",+IBSTPCODE,"")),IBCDENME=$P(^IBE(352.5,IBCDENME,0),U,4)
. S IBSTPCODE=IBSTPCODE_"-"_IBCDENME
S IBCHG=$S(IBATYP["CANCEL":"(",1:"")_"$"_$S($P(IBND,"^",7)'="":$P(IBND,"^",7),1:0)_$S(IBATYP["CANCEL":")",1:"")
S IBRSLTFRM=$P(IBND,U,4)
S IBBILLNO=$P(IBND,U,11)
S IBCPTIER=$P(IBND,U,22)
S BILGROUP=$$GET1^DIQ(350.1,+$P(IBND,"^",3)_",",.11,"I")
S IBDIV=$P(IBND,U,13)_"-"_$$GET1^DIQ(350,IBN_",",.13,"E")
S IBLSTUSR=$$GET1^DIQ(350,IBN_",",13,"E")
I $P(IBRSLTFRM,":")=350 D
. S IBDTBILLFR=$P(IBND,U,14),IBRSLTFRM=IBRSLTFRM_";"_IBDTBILLFR_":"_IBCPTIER
S @IBOTHSTAT@(350,IBD,DFN,IBCNT)=IBATYP_U_BILGROUP_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBSTPCODE_U_IBLSTUSR
Q
;
IB399 ;collects all related bill for a patient in file #399
N IBIFN,IBEVDT,IB0,IBPTF,IBADM,IBDIS,IBOPV,IBPTF1,IBXRF,IBRXN,IBRXDT,IBX
S IBIFN=0 F S IBIFN=$O(^DGCR(399,"C",DFN,IBIFN)) Q:'IBIFN D
. S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBEVDT=$P(IB0,U,3),IBPTF=$P(IB0,U,8)
. ;check if the event date is within the date range (the time patient become OTH until PE has been VERIFIED to another PE)
. I IBEVDT\1<IBABEG!(IBEVDT\1>IBAEND) Q
. ;otherwise, find all bills with the Event Date (399,.03)
. I +IBEVDT D TPEVDT^IBEFURT(DFN,IBEVDT,IBIFN)
. ;find all bill with PTF number (399,.08)
. ;find any bills with Outpatient Visit Dates within the date range of the admission (PTF)
. ;find all bills that have one or more of the same Opt Visit Dates (399,43)
. ;find any bills for inpatient admissions whose date range includes one or more of the Opt Visit Dates
. ;find all bills that have one or more of the same Prescription: same Rx number and fill date (362.4,.01,.03)
. D IT^IBEFUR
Q
;
CHKDATE(DATE) ;
;check if dates fall within the Begin and End dates
Q (IBABEG<=DATE)&(IBAEND>=DATE)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBEFSMUT 14777 printed Apr 09, 2024@21:19:56 Page 2
IBEFSMUT ;SLC/RM - OTH FSM and PP BILLING STATUS UTILITY ; Sep 29, 2020@3:51 pm
+1 ;;2.0;INTEGRATED BILLING;**688,697**;March 21, 1994;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Global References Supported by ICR# Type
+5 ;----------------- ----------------- ----------
+6 ; ^TMP($J SACC 2.3.2.5.1
+7 ; ^TMP("IBECEA" SACC 2.3.2.5.1
+8 ; ^TMP("IBRBT" SACC 2.3.2.5.1
+9 ;
+10 ;External References
+11 ;-------------------
+12 ; $$GET1^DIQ 2056 Supported
+13 ; GETS^DIQ 2056 Supported
+14 ; Y^DIQ 2056 Supported
+15 ; RX^PSO52API 4820 Supported
+16 ;
+17 ;No direct access
QUIT
+18 ;
EN(DFN,BEGDT,ENDDT,LIST) ;retrieve the IB STATUS from either File #399 and #350
+1 ;Input :
+2 ; DFN : Internal entry number from the PATIENT file (#2) [required]
+3 ; BEGDT : Date of Service [required]
+4 ; ENDDT : Date of Service [required]
+5 ; LIST : Subscript name used in ^TMP global [REQUIRED]
+6 ;Output :
+7 ; Return the requested data elements from either File #399 and #350
+8 ;
+9 NEW IBABEG,IBAEND,IBCNT,IBOTHSTAT
+10 SET IBCNT=0
+11 ;contain all date of service for the Visit/Encounter and Rx copayments
KILL ^TMP("IBECEA",$JOB)
+12 ;contain some IB data elements based on the user specified date range
SET IBOTHSTAT="^TMP($J,"""_LIST_""")"
+13 SET IBABEG=BEGDT
SET IBAEND=ENDDT
+14 ;check file #350 first if patient has a record
+15 ;if patient exist, collect all data and store it temporarily in ^TMP("IBECEA",$J)
+16 IF $DATA(@IBOTHSTAT@(350,DFN,0))
SET IBCNT=@IBOTHSTAT@(350,DFN,0)
+17 IF $DATA(^IB("C",DFN))
Begin DoDot:1
+18 ;Rx charges
DO APTDT^IBECEA0
+19 ;Means Test and CHAMPVA charges
IF $DATA(^IB("AFDT",DFN))
DO APDT^IBECEA0
+20 IF $DATA(^TMP("IBECEA",$JOB))
DO IB350
End DoDot:1
+21 SET @IBOTHSTAT@(350,DFN,0)=$SELECT(IBCNT>0:IBCNT,1:"-1^NO DATA FOUND")
+22 ;
+23 ;check file #399 if patient also has a record
+24 ;if patient exist, collect all data and store it temporarily in ^TMP("IBECEA",$J)
+25 NEW SUB1,SUB2,IBDTFRM,IBDTTO,IBTYP399,IBN,IBD,RXRF399,IBNARR399
+26 SET (IBCNT,RXRF399,IBTYP399)=0
+27 IF $DATA(@IBOTHSTAT@(399,DFN,0))
SET IBCNT=@IBOTHSTAT@(399,DFN,0)
+28 IF $DATA(^DGCR(399,"C",DFN))
Begin DoDot:1
+29 KILL ^TMP("IBRBT",$JOB),IBNARR399
+30 ;collects all related bill for a patient in file #399
DO IB399
+31 ;after collecting all the bills for this patient,
+32 ;determine whether bill is inpatient,outpatient, or rx refill
+33 ;1 - inpatient (as per business owner, no rx since it is a combined bill)
+34 ;0 - outpatient
+35 SET SUB1=""
FOR
SET SUB1=$ORDER(^TMP("IBRBT",$JOB,SUB1))
if SUB1=""
QUIT
Begin DoDot:2
+36 SET SUB2=""
FOR
SET SUB2=$ORDER(^TMP("IBRBT",$JOB,SUB1,SUB2))
if SUB2=""
QUIT
Begin DoDot:3
+37 ;quit if this IBN already been evaluated
+38 if $DATA(IBNARR399(SUB2))
QUIT
+39 SET (RXRF399,IBTYP399,IBN,IBD)=0
+40 ;date billed from (event date or the admission date)
SET IBDTFRM=$PIECE(^TMP("IBRBT",$JOB,SUB1,SUB2),U)
+41 ;date billed to (discharge date for inpatient)
SET IBDTTO=$PIECE(^TMP("IBRBT",$JOB,SUB1,SUB2),U,2)
+42 ;determine if bill is inpatient,outpatient, or rx refill
SET IBTYP399=$$INPAT^IBCEF(SUB2,1)
+43 ;check if the records we are looking is in the date range
+44 ;IBDTFRM<IBABEG!(IBDTTO>IBAEND) Q ;inpatient date range check
IF +IBTYP399>0
IF '$$CHKDATE(IBDTFRM)
QUIT
+45 ;outpatient date range check
IF +IBTYP399<1
IF '$$CHKDATE(IBDTFRM)
QUIT
+46 ;check if there any Rx refill included for this bill
IF +IBTYP399<1
if $DATA(^IBA(362.4,"C",SUB2))
SET RXRF399=3
+47 ;extract other data for this patient's bill to be displayed in the report
+48 SET IBN=SUB2
SET IBD=IBDTFRM
DO DATA399
+49 SET IBNARR399(SUB2)=""
End DoDot:3
End DoDot:2
End DoDot:1
+50 SET @IBOTHSTAT@(399,DFN,0)=$SELECT(IBCNT>0:IBCNT,1:"-1^NO DATA FOUND")
+51 KILL ^TMP("IBRBT",$JOB),^TMP("IBECEA",$JOB),IBNARR399
+52 QUIT
+53 ;
DATA399 ;IB Status in File #399
+1 NEW I,IBBILLNO,IBRTYPNME,IBRTYPIEN,IBSTAT,IBBLCLS,IBRTYPNME,IBRTYPIEN
+2 NEW IBSTAT,IBRSLTFRM,IBCHG,IBNDU1,IBLSTUSR,IBDIV,IBND0,IBNDU,IBOEIEN
+3 KILL IBARR,IBERR
+4 DO GETS^DIQ(399,IBN_",",".01;.02;.05;.07;.11;.13;.22;2;42*","IE","IBARR","IBERR")
+5 if $DATA(IBERR)
QUIT
+6 if '$DATA(IBARR)
QUIT
+7 SET (IBBILLNO,IBRTYPNME,IBRTYPIEN,IBSTAT)=""
+8 ;bill no
SET IBBILLNO=IBARR(399,IBN_",",.01,"I")
+9 ;bill classification
SET IBBLCLS=IBARR(399,IBN_",",.05,"I")
+10 ;rate type name
SET IBRTYPNME=IBARR(399,IBN_",",.07,"E")
+11 ;rate type ien
SET IBRTYPIEN=IBARR(399,IBN_",",.07,"I")
+12 ;bill status
SET IBSTAT=IBARR(399,IBN_",",.13,"E")
+13 SET IBDIV=$$DIV^IBJDF2(IBN)
+14 SET IBOEIEN=$$OE(IBN,IBD)
+15 ;user entered/edited the bill
SET IBLSTUSR=IBARR(399,IBN_",",2,"E")
+16 FOR I=0,"U","U1"
SET @("IBND"_I)=$GET(^DGCR(399,IBN,I))
+17 ;if inpatient, disregard whatever in the REVENUE CODE multiple 399,42
+18 ;as per business owner, it is a combined bill
+19 IF +IBTYP399>0
Begin DoDot:1
+20 SET IBCNT=IBCNT+1
+21 SET IBRSLTFRM=+IBTYP399_":"_IBARR(399,IBN_",",.05,"E")
+22 SET IBCHG=$PIECE(IBNDU1,"^",1)
+23 SET IBOEIEN=$PIECE(^DGCR(399,IBN,0),U,8)
+24 SET @IBOTHSTAT@(399,IBD,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR_U_IBOEIEN
End DoDot:1
QUIT
+25 ;otherwise, the bill is outpatient and may have RX refill
+26 DO RCODE399
+27 KILL IBARR,IBERR
+28 QUIT
+29 ;
OE(IBN,EVNTDT) ;extract the Outpatient Encounter ien in file #409.68
+1 ;Note: A single EVENT DATE can have one or more procedure charges but belongs to only ONE IEN in file #409.68
+2 ;If TMPOEIEN remains equal to 0, that means the outpatient charges is not related to any outpatient encounter in file #409.68
+3 NEW PRD399,PRDCNTR,TMPOEIEN
+4 SET TMPOEIEN=0
+5 IF $DATA(^DGCR(399,"ASD",-EVNTDT))
Begin DoDot:1
+6 SET PRD399=""
FOR
SET PRD399=$ORDER(^DGCR(399,"ASD",-EVNTDT,PRD399))
if PRD399=""!(TMPOEIEN>0)
QUIT
Begin DoDot:2
+7 SET PRDCNTR=""
FOR
SET PRDCNTR=$ORDER(^DGCR(399,"ASD",-EVNTDT,PRD399,IBN,PRDCNTR))
if PRDCNTR=""!(TMPOEIEN>0)
QUIT
Begin DoDot:3
+8 ; extract the IEN for FILE #409.68
SET TMPOEIEN=$PIECE(^DGCR(399,IBN,"CP",PRDCNTR,0),U,20)
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT TMPOEIEN
+10 ;
RCODE399 ;traverse the RC multiple to determine charges for this event date
+1 NEW IBRVCD,IBRCCNT,IBCHG,IBBEDSEC,IBAIEN,IBRSLTFRM,IBRCTYP,RXSTATUS,IBARELDT,IBARXNUM,IBARFLDT
+2 NEW IBARFNUM,IBARXIEN,RXRCCNT,OLDBD,TYP399,RCCHRG
+3 SET (RXRCCNT,OLDBD)=0
+4 SET IBRVCD=0
FOR
SET IBRVCD=$ORDER(^DGCR(399,IBN,"RC","B",IBRVCD))
if 'IBRVCD
QUIT
Begin DoDot:1
+5 SET IBRCCNT=0
FOR
SET IBRCCNT=$ORDER(^DGCR(399,IBN,"RC","B",IBRVCD,IBRCCNT))
if 'IBRCCNT
QUIT
Begin DoDot:2
+6 ;check if this is the charge we are looking for this bill
+7 ;total charge for this RC 399.042,.04
SET IBCHG=$PIECE(^DGCR(399,IBN,"RC",IBRCCNT,0),U,4)
+8 ;type 399.042, .1 (this could be opt,inpt, etc.)
SET IBRCTYP=$PIECE(^DGCR(399,IBN,"RC",IBRCCNT,0),U,10)
+9 ;bedsection 399.042,.05
SET IBBEDSEC=$PIECE(^DGCR(399,IBN,"RC",IBRCCNT,0),U,5)
+10 SET IBBEDSEC=$$GET1^DIQ(399.1,IBBEDSEC_",",.01,"E")
+11 IF IBBEDSEC["PRESCRIPTION"
Begin DoDot:3
+12 if RXRCCNT
QUIT
+13 ;process all RX at once
DO IBARX362
SET RXRCCNT=1
End DoDot:3
QUIT
+14 ;otherwise, extract the NON-PRESCRIPTION data
+15 ;group together ALL NON-PRESCRIPTION charges regardless of TYPE and BEDSECTION into an array
+16 IF OLDBD'=IBBEDSEC
SET RCCHRG=0
+17 SET RCCHRG=$GET(RCCHRG)+IBCHG
+18 SET OLDBD=IBBEDSEC
End DoDot:2
+19 IF IBBEDSEC'["PRESCRIPTION"
Begin DoDot:2
+20 SET IBRSLTFRM=$SELECT(IBBEDSEC'["PRESCRIPTION":2,1:IBRCTYP)_":"_IBBEDSEC_":"_+IBTYP399
+21 SET TYP399("NONRX")=IBRSLTFRM_U_RCCHRG
End DoDot:2
End DoDot:1
+22 IF $DATA(TYP399)
Begin DoDot:1
+23 if $PIECE($PIECE(TYP399("NONRX"),U),"
QUIT
+24 SET IBCNT=IBCNT+1
+25 SET IBRSLTFRM=$PIECE(TYP399("NONRX"),U)
+26 SET IBCHG=$PIECE(TYP399("NONRX"),U,2)
+27 SET @IBOTHSTAT@(399,IBD\1,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR_U_IBOEIEN
End DoDot:1
+28 ;some of the RX is not captured in file #399 however it is captured in file#362.4,extract this information as well
+29 IF RXRF399=3
IF 'RXRCCNT
Begin DoDot:1
+30 SET IBCHG=0
SET IBBEDSEC="PRESCRIPTION"
+31 DO IBARX362
SET RXRCCNT=1
End DoDot:1
+32 ;some bill number does not have RC record
+33 IF '$DATA(^DGCR(399,IBN,"RC","B"))
Begin DoDot:1
+34 FOR I=0,"U","U1"
SET @("IBND"_I)=$GET(^DGCR(399,IBN,I))
+35 SET IBCNT=IBCNT+1
SET IBCHG=+$PIECE(IBNDU1,"^",1)
+36 SET IBRSLTFRM=$SELECT(IBBLCLS=3:2,IBBLCLS=4:2,1:+IBTYP399)_":"_IBARR(399,IBN_",",.05,"E")
+37 SET @IBOTHSTAT@(399,IBD\1,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR_U_IBOEIEN
End DoDot:1
+38 KILL TYP399
+39 QUIT
+40 ;
IBARX362 ;determine what Rx is charged for
+1 NEW FLDT52,IBARXSUPLY,IBRXPRTLTOT,JJJ,PSO52DYSUP,PRTLRFNUM
+2 SET IBARXNUM=""
FOR
SET IBARXNUM=$ORDER(^IBA(362.4,"AIFN"_IBN,IBARXNUM))
if IBARXNUM=""
QUIT
Begin DoDot:1
+3 SET IBAIEN=""
FOR
SET IBAIEN=$ORDER(^IBA(362.4,"AIFN"_IBN,IBARXNUM,IBAIEN))
if IBAIEN=""
QUIT
Begin DoDot:2
+4 ;this is the released date, a charge is created when rx is released
SET IBARFLDT=$PIECE(^IBA(362.4,IBAIEN,0),U,3)
+5 ;fill number
SET IBARFNUM=$PIECE(^IBA(362.4,IBAIEN,0),U,10)
+6 ;rxien in file #52
SET IBARXIEN=$PIECE(^IBA(362.4,IBAIEN,0),U,5)
+7 ;rx days supply
SET IBARXSUPLY=$PIECE(^IBA(362.4,IBAIEN,0),U,6)
+8 SET (IBARELDT,FLDT52,IBRXPRTLTOT,PSO52DYSUP,PRTLRFNUM)=0
+9 KILL ^TMP($JOB,"IBRX339")
DO RX^PSO52API(DFN,"IBRX339",,IBARXNUM,"2,R,P",IBABEG,$$FMADD^XLFDT(IBAEND,366))
+10 ;invoking this API twice since this API sometimes work, sometimes doesn't.
IF +^TMP($JOB,"IBRX339",DFN,0)<1
DO RXPSO52
+11 IF +^TMP($JOB,"IBRX339",DFN,0)<1
IF +IBARXIEN>0
Begin DoDot:3
+12 KILL ^TMP($JOB,"IBRX339")
DO RX^PSO52API(DFN,"IBRX339",IBARXIEN,,"2,R,P",IBABEG,$$FMADD^XLFDT(IBAEND,366))
+13 IF +^TMP($JOB,"IBRX339",DFN,0)<1
DO RXPSO52
End DoDot:3
+14 IF +^TMP($JOB,"IBRX339",DFN,0)>0
Begin DoDot:3
+15 IF +IBARXIEN<1
SET IBARXIEN=$ORDER(^TMP($JOB,"IBRX339","B",IBARXNUM,""))
+16 ;the current status of the RX
SET RXSTATUS=$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,100),U)
+17 ;check if this CHARGE is for original or partial fill
IF IBARFNUM=""
Begin DoDot:4
+18 DO RXORGNAL
+19 ;check if there are any Rx partial fill for the same date OR if the rx charge is for Partial fill
IF +^TMP($JOB,"IBRX339",DFN,IBARXIEN,"P",0)>0
Begin DoDot:5
End DoDot:5
+20 SET IBRXPRTLTOT=+^TMP($JOB,"IBRX339",DFN,IBARXIEN,"P",0)
+21 FOR JJJ=1:1:IBRXPRTLTOT
Begin DoDot:5
+22 ;rx partill fill date
SET FLDT52=$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,"P",JJJ,.01),U)
+23 ;rx partial released date
SET IBARELDT=$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,"P",JJJ,8),U)
+24 ;file #52 days supply
SET PSO52DYSUP=$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,"P",JJJ,.041),U)
+25 IF (+IBARFLDT\1)=(+IBARELDT\1)!((+IBARFLDT\1)=+FLDT52\1)
Begin DoDot:6
+26 IF IBARXSUPLY=PSO52DYSUP
IF $$CHKDATE(+IBARELDT\1)
Begin DoDot:7
+27 ;concatenating "P" with the partial fill number in order to distinguished from original, refill and partial fill
SET PRTLRFNUM=JJJ_"P"
+28 DO IBARXREC
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
QUIT
+29 ;this charge is for the rx original fill
IF IBARFNUM=0
DO RXORGNAL
+30 ;this charge if for rx refill
IF +IBARFNUM>0
IF +$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,"RF",0),U)>0
Begin DoDot:4
+31 ;rx refill fill date
SET FLDT52=$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,"RF",IBARFNUM,.01),U)
+32 ;rx refill released date
SET IBARELDT=$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,"RF",IBARFNUM,17),U)
+33 IF (+IBARFLDT\1)=(+IBARELDT\1)
IF $$CHKDATE(+IBARELDT\1)
DO IBARXREC
End DoDot:4
End DoDot:3
+34 ;this is where the RX # is in text format and does not exist in file #52. Rx status will not be checked since we will not know if it is active or not
IF '$TEST
IF +IBARFLDT
IF '+FLDT52
Begin DoDot:3
+35 ;check if the rx fill date is within the date range
if '$$CHKDATE(+IBARFLDT\1)
QUIT
+36 SET IBARXSUPLY=$PIECE(^IBA(362.4,IBAIEN,0),U,6)
+37 SET IBRSLTFRM=RXRF399_":"_IBBEDSEC_":"_+IBARXIEN_":"_IBARXNUM_"-"_IBARXSUPLY_":"_+IBARFNUM_":"_$SELECT($GET(RXSTATUS)'="":RXSTATUS,1:"")
+38 SET IBCNT=IBCNT+1
+39 SET @IBOTHSTAT@(399,IBARFLDT\1,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR
End DoDot:3
+40 KILL ^TMP($JOB,"IBRX339")
End DoDot:2
End DoDot:1
+41 QUIT
+42 ;
RXPSO52 ;
+1 KILL ^TMP($JOB,"IBRX339")
+2 DO RX^PSO52API(DFN,"IBRX339",,IBARXNUM,"2,R,P",IBABEG,$$FMADD^XLFDT(IBAEND,366))
+3 QUIT
+4 ;
RXORGNAL ;
+1 ;rx original fill date
SET FLDT52=$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,22),U)
+2 ;rx original fill released date
SET IBARELDT=$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,31),U)
+3 ;file #52 days supply
SET PSO52DYSUP=$PIECE(^TMP($JOB,"IBRX339",DFN,IBARXIEN,8),U)
+4 IF (+IBARFLDT\1)=(+IBARELDT\1)!((+IBARFLDT\1)=+FLDT52\1)
Begin DoDot:1
+5 ;this is the original fill rx charge
IF IBARXSUPLY=PSO52DYSUP
IF $$CHKDATE(+IBARELDT\1)
SET IBARFNUM=0
DO IBARXREC
End DoDot:1
+6 QUIT
+7 ;
IBARXREC ;capture Rx data
+1 SET IBRSLTFRM=RXRF399_":"_IBBEDSEC_":"_IBARXIEN_":"_IBARXNUM_":"_$SELECT(+PRTLRFNUM>0:PRTLRFNUM,1:IBARFNUM)_":"_$SELECT($GET(RXSTATUS)'="":RXSTATUS,1:"")
+2 SET IBCNT=IBCNT+1
+3 SET @IBOTHSTAT@(399,IBARELDT\1,DFN,IBCNT)=IBBLCLS_U_IBRTYPNME_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBLSTUSR
+4 QUIT
+5 ;
IB350 ;extract IB status found in File #350
+1 NEW IBD,IBN,IBND,IBSTAT,IBATYP,IBCHG,IBRSLTFRM,IBBILLNO,BILGROUP,CNT
+2 SET IBD=""
FOR
SET IBD=$ORDER(^TMP("IBECEA",$JOB,IBD))
if 'IBD
QUIT
Begin DoDot:1
+3 SET IBN=""
FOR
SET IBN=$ORDER(^TMP("IBECEA",$JOB,IBD,IBN))
if 'IBN
QUIT
Begin DoDot:2
+4 DO IBSTA350
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
IBSTA350 ;IB status found in File #350
+1 NEW Y,C,IBDTBILLFR,IBCPTIER,IBDIV,IBSTPCODE,IBLSTUSR,IBCDENME
+2 ;Q:$P(IBND,"^",7)=""
SET IBND=^IB(IBN,0)
+3 SET IBCNT=IBCNT+1
SET Y=$PIECE(IBND,"^",5)
SET C=$PIECE(^DD(350,.05,0),"^",2)
DO Y^DIQ
SET IBSTAT=Y
+4 SET IBATYP=$PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^")
if $EXTRACT(IBATYP,1,2)="DG"
SET IBATYP=$EXTRACT(IBATYP,4,99)
+5 SET (IBSTPCODE,IBCDENME)=""
+6 ;if outpatient charge and clinic stop, extract it
+7 IF $EXTRACT(IBATYP,1,3)="OPT"
IF $PIECE(IBND,"^",20)
Begin DoDot:1
+8 ;stop code number
SET IBSTPCODE=$PIECE($GET(^IBE(352.5,+$PIECE(IBND,"^",20),0)),"^")
+9 IF $DATA(^IBE(352.5,"B",+IBSTPCODE))
SET IBCDENME=$ORDER(^IBE(352.5,"B",+IBSTPCODE,""))
SET IBCDENME=$PIECE(^IBE(352.5,IBCDENME,0),U,4)
+10 SET IBSTPCODE=IBSTPCODE_"-"_IBCDENME
End DoDot:1
+11 SET IBCHG=$SELECT(IBATYP["CANCEL":"(",1:"")_"$"_$SELECT($PIECE(IBND,"^",7)'="":$PIECE(IBND,"^",7),1:0)_$SELECT(IBATYP["CANCEL":")",1:"")
+12 SET IBRSLTFRM=$PIECE(IBND,U,4)
+13 SET IBBILLNO=$PIECE(IBND,U,11)
+14 SET IBCPTIER=$PIECE(IBND,U,22)
+15 SET BILGROUP=$$GET1^DIQ(350.1,+$PIECE(IBND,"^",3)_",",.11,"I")
+16 SET IBDIV=$PIECE(IBND,U,13)_"-"_$$GET1^DIQ(350,IBN_",",.13,"E")
+17 SET IBLSTUSR=$$GET1^DIQ(350,IBN_",",13,"E")
+18 IF $PIECE(IBRSLTFRM,":")=350
Begin DoDot:1
+19 SET IBDTBILLFR=$PIECE(IBND,U,14)
SET IBRSLTFRM=IBRSLTFRM_";"_IBDTBILLFR_":"_IBCPTIER
End DoDot:1
+20 SET @IBOTHSTAT@(350,IBD,DFN,IBCNT)=IBATYP_U_BILGROUP_U_IBN_U_IBBILLNO_U_IBRSLTFRM_U_IBCHG_U_IBSTAT_U_IBDIV_U_IBSTPCODE_U_IBLSTUSR
+21 QUIT
+22 ;
IB399 ;collects all related bill for a patient in file #399
+1 NEW IBIFN,IBEVDT,IB0,IBPTF,IBADM,IBDIS,IBOPV,IBPTF1,IBXRF,IBRXN,IBRXDT,IBX
+2 SET IBIFN=0
FOR
SET IBIFN=$ORDER(^DGCR(399,"C",DFN,IBIFN))
if 'IBIFN
QUIT
Begin DoDot:1
+3 SET IB0=$GET(^DGCR(399,+IBIFN,0))
if IB0=""
QUIT
SET IBEVDT=$PIECE(IB0,U,3)
SET IBPTF=$PIECE(IB0,U,8)
+4 ;check if the event date is within the date range (the time patient become OTH until PE has been VERIFIED to another PE)
+5 IF IBEVDT\1<IBABEG!(IBEVDT\1>IBAEND)
QUIT
+6 ;otherwise, find all bills with the Event Date (399,.03)
+7 IF +IBEVDT
DO TPEVDT^IBEFURT(DFN,IBEVDT,IBIFN)
+8 ;find all bill with PTF number (399,.08)
+9 ;find any bills with Outpatient Visit Dates within the date range of the admission (PTF)
+10 ;find all bills that have one or more of the same Opt Visit Dates (399,43)
+11 ;find any bills for inpatient admissions whose date range includes one or more of the Opt Visit Dates
+12 ;find all bills that have one or more of the same Prescription: same Rx number and fill date (362.4,.01,.03)
+13 DO IT^IBEFUR
End DoDot:1
+14 QUIT
+15 ;
CHKDATE(DATE) ;
+1 ;check if dates fall within the Begin and End dates
+2 QUIT (IBABEG<=DATE)&(IBAEND>=DATE)
+3 ;
