- 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 Jan 18, 2025@03:23:07 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 ;