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

IBAECU.m

Go to the documentation of this file.
  1. IBAECU ;ALB/BGA - LTC UTILITIES DETERMINE LTC ELIG ; 25-SEPT-01
  1. ;;2.0;INTEGRATED BILLING;**164,171,176,198,188,454,660,728**;21-MAR-94;Build 14
  1. ;; Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ; This routine contains the following utilities in support of the
  1. ; LTC initiative:
  1. ; 1. Determine if a patient is ELIGIBLE for the LTC COPAY
  1. ; 2. Determine if a inpatient episode is related to LTC
  1. ;
  1. ;LTCST(DFN,IBDT); - Returns '2' if LTC Eligible or else '1' Not Eligible
  1. ; ; -- Returns '-1' and a second piece if there is an ERROR
  1. ; ; -- If 2 LTC VET's Income Exceeds Pension Level <LTC ELIG>
  1. ; ; -- If 1 Not LTC Eligible = Exempt
  1. ;
  1. LTCST(DFN,IBDT,LOS) ; returns LTC status from API
  1. ; input: Patient's DFN, Date of Care, Length of stay
  1. ;
  1. ; format: exemption flag ^ exemption reason (714.1 pointer)
  1. ; ^ <181 $ amount ^ >180 $ amount ^ opt $ amount
  1. Q $$COPAY^EASECCAL(DFN,$$LASTDT(IBDT),LOS)
  1. ;
  1. ;
  1. MAXRATE(IBDT) ; returns the max rates for the effective date
  1. ; the rates retuned are the max daily rates for any and all LTC
  1. ; copayments. The return is: outpatient^inpatient
  1. ;
  1. N IBATYP,IBR,IBL,IBT,IBCHG
  1. ;
  1. S IBR=""
  1. ;
  1. ; if IBDT less than the starting date of LTC set to the starting date
  1. I IBDT<3020726 S IBDT=3020726
  1. ;
  1. F IBL=1:1 S IBT=$P($T(STOP+IBL^IBAECU1),";",3) Q:IBT="" S IBATYP=$O(^IBE(350.1,"B",IBT,0)) I IBATYP D COST^IBAUTL2 I IBCHG>IBR S IBR=IBCHG
  1. F IBL=1:1 S IBT=$P($T(SPEC+IBL^IBAECU1),";",3) Q:IBT="" S IBATYP=$O(^IBE(350.1,"B",IBT,0)) I IBATYP D COST^IBAUTL2 I IBCHG>$P(IBR,"^",2) S $P(IBR,"^",2)=IBCHG
  1. Q IBR
  1. ;
  1. FACSPEC(IBSPEC) ; returns the treating specialty for 42.4 from a facility sp
  1. ;
  1. Q $P($G(^DIC(45.7,+$G(IBSPEC),0)),"^",2)
  1. ;
  1. ;
  1. LTCSPEC(IBSPEC) ; Determine if INPT Specialty is related to LTC.
  1. ; -- Input the ien of #42.4 Specialty
  1. ;
  1. ; -- Output: Piece 1: If a LTC Specialty Bedsection Pointer 399.1
  1. ; If not LTC Spec Return 0
  1. ; Piece 2: If LTC, type of LTC
  1. ;
  1. N IBTS
  1. ;
  1. ; get the LTC Treating Specialty type
  1. S IBTS=$T(@("T"_IBSPEC)^IBAECU1)
  1. ;
  1. Q $S($L(IBTS):+$E(IBTS,2,99)_"^"_$P(IBTS,";",3),1:0)
  1. ;
  1. ;
  1. LTCSTOP(IB407) ; Determine if the 'STOP CODE' is related to LTC.
  1. ;
  1. ; -- Input the ien of #40.7 Clinic Stop Code
  1. ;
  1. ; -- Output: 1st piece 1 - LTC STOP CODE
  1. ; 0 - Not LTC STOP CODE
  1. ;
  1. ; 2nd piece = if LTC, type of LTC
  1. ;
  1. N IBSTOP,IBSCDATA
  1. ;
  1. ; get the stop code in IBSCDATA(40.7,IB407,1,"E")
  1. D DIQ407^IBEMTSCU(IB407,1)
  1. I $G(IBSCDATA(40.7,IB407,1,"E"))="" Q 0
  1. ;
  1. ; get the LTC stop type
  1. S IBSTOP=$T(@("C"_IBSCDATA(40.7,IB407,1,"E"))^IBAECU1)
  1. ;
  1. Q $S($L(IBSTOP):+$E(IBSTOP,2,99)_"^"_$P(IBSTOP,";",3),1:0)
  1. ;
  1. ;
  1. CLOCK(DFN,IBDATE) ; verfiy a clock exists, if not, one will be added
  1. N X,Y,IBCL,IBX,DA,DIE,DR,IBFLG
  1. ;
  1. ; get last clock for patient
  1. S IBX=9999999,IBFLG=0
  1. F S IBX=$O(^IBA(351.81,"AE",DFN,IBX),-1) Q:+IBX=0!(IBFLG>0) D
  1. . S IBCL=0
  1. . F S IBCL=$O(^IBA(351.81,"AE",DFN,IBX,IBCL)) Q:+IBCL=0!(IBFLG>0) D
  1. . . Q:+$P(^IBA(351.81,IBCL,0),"^",5)'=1 ;if it is not OPEN
  1. . . S IBFLG=IBCL
  1. ;
  1. ; if has an OPEN clock already
  1. I IBFLG>0 D Q 1
  1. . I +$P(^IBA(351.81,IBFLG,0),"^",7)>0 Q ;already flagged - quit
  1. . S DIE="^IBA(351.81,",DR=".07////^S X=IBDATE",DA=IBFLG D ^DIE
  1. ; if there is no OPEN clock the add a new clock, and set CURRENT EVENTS DATE
  1. S DIE="^IBA(351.81,",DA=+$$ADDCL(DFN,IBDATE),DR=".07////^S X=IBDATE" X $S(DA>0:"D ^DIE S Y=DA",1:"S Y=-1")
  1. Q +Y
  1. ;
  1. ;
  1. YR(IBRTED,IBFR) ; is the effective date of the clock too old?
  1. ; Input: IBRTED -- Effective Date
  1. ; IBFR -- Event Date
  1. ; Output: 1 -- Effective Date is too old
  1. ; 0 -- Not
  1. N IBNUM,IBYR
  1. S IBNUM=$$FMDIFF^XLFDT(IBFR,IBRTED),IBYR=$E(IBFR,1,3)
  1. Q IBYR#4&(IBNUM>364)!(IBYR#4=0&(IBNUM>365))
  1. ;
  1. ADDCL(DFN,IBADT) ; adds a LTC clock, returns LTC Clock IEN
  1. ; needs DFN and IBADT (clock begin date)
  1. ;
  1. N %DT,DD,DO,DIC,DR,X,Y,DA,DR,DIE,IBN,IBN1,IBSITE,IBFAC,DINUM,DLAYGO
  1. L +^IBA(351.81,0):10 I '$T S Y="-1^IB014" G ADDCLQ
  1. S X=$P($S($D(^IBA(351.81,0)):^(0),1:"^^-1"),"^",3)+1 L -^IBA(351.81,0) I 'X S Y="-1^IB015" G ADDCLQ
  1. D SITE^IBAUTL
  1. N IBAEXDT S IBAEXDT=$$GETEXPDT^IBAECU4(IBADT\1) ;expiration date
  1. S DIC="^IBA(351.81,",DIC(0)="L",DLAYGO=351.81
  1. F X=X:1 L:$D(IBN1) -^IBA(351.81,IBN1) I X>0,'$D(^IBA(351.81,X)) S IBN1=X L +^IBA(351.81,IBN1):1 I $T,'$D(^IBA(351.81,X)) S DINUM=X,X=+IBSITE_X D FILE^DICN I +Y>0 Q
  1. S IBN=+Y,DIE="^IBA(351.81,",DA=IBN,DR=".02////"_$S($D(DFN):DFN,1:"")_";.03////"_$S($D(IBADT):IBADT,1:"")_";.04////"_$S($D(IBAEXDT):IBAEXDT,1:"")_";.05////1;.06////21;"_$S(DUZ:"4.01///"_DUZ_";",1:"")_"4.02///NOW" D ^DIE
  1. L -^IBA(351.81,IBN1)
  1. S Y=$S('$D(Y):1,1:"-1^IB028")
  1. ;
  1. ADDCLQ Q $S($G(IBN):IBN,1:Y)
  1. ;
  1. LTCENC(DFN,DATE) ; Did the patient have LTC on a specified date?
  1. ; Input: DFN -- Pointer to the patient in file #2
  1. ; DATE -- Date of the Outpatient Visit
  1. ; Output: 0 -- Patient did not have a LTC on the visit date
  1. ; 1 -- Patient had a LTC on the visit date
  1. N X,Y,Y0,IBVAL,IBCBK,IBFILTER,IBLTC
  1. I '$G(DFN)!('$G(DATE)) G LTCENCQ
  1. ; - check appts, stop codes
  1. S IBVAL("DFN")=DFN,IBVAL("BDT")=DATE,IBVAL("EDT")=DATE+.9999
  1. ; Only parent appt or add/edit encounters
  1. S IBFILTER=""
  1. S IBCBK="I '$P(Y0,U,6),$P(Y0,U,8)<3,$P(Y0,U,3),$$LTCSTOP^IBAECU($P(Y0,U,3)),$P(Y0,U)'<$$STDATE^IBAECU1 S (IBLTC,SDSTOP)=1"
  1. S IBLTC=0
  1. D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
  1. I IBLTC S Y=1
  1. LTCENCQ Q +$G(Y)
  1. ;
  1. ;
  1. XMBACK(DFN,IBM) ; send a message saying LTC processing has stoped for an event
  1. ;
  1. N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBX,IBT,XMDUZ
  1. ;
  1. D XMDEM(DFN,.IBT,.IBL)
  1. ;
  1. S XMSUB="LTC Copayment Back Billing/Error",XMY("G.IB LTC BACK BILLING")="",XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
  1. ;
  1. S IBX=0 F S IBX=$O(IBM(IBX)) Q:IBX<1 S IBL=IBL+1,IBT(IBL,0)=IBM(IBX)
  1. ;
  1. D ^XMD
  1. ;
  1. Q
  1. ;
  1. XMNOEC(DFN,IBDT,IBE) ; send a message saying no 1010EC on file for LTC pt.
  1. ; IBE is optional additional text
  1. ;
  1. N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBT,XMDUZ,X
  1. ;
  1. ; if already done for this patient and month, quit
  1. I $D(^XTMP("IB1010EC",DFN)) Q
  1. S ^XTMP("IB1010EC",DFN)=""
  1. ;
  1. D XMDEM(DFN,.IBT,.IBL)
  1. ;
  1. S XMSUB="1010EC Missing for LTC Patient",XMY("G.IB LTC 1010EC MISSING")="",XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
  1. ;
  1. S IBL=IBL+1,IBT(IBL,0)="The above patient has received LTC services on "_$$FMTE^XLFDT(IBDT)_" and"
  1. S IBL=IBL+1,IBT(IBL,0)="does not have a LTC Copayment Test on file. A LTC Copayment test needs to"
  1. S IBL=IBL+1,IBT(IBL,0)="be completed as soon as possible to determine the patient's eligibility"
  1. S IBL=IBL+1,IBT(IBL,0)="for exemption and/or copayment obligation. Billing cannot be processed"
  1. S IBL=IBL+1,IBT(IBL,0)="until this information is entered."
  1. S IBL=IBL+1,IBT(IBL,0)=""
  1. I $D(IBE)>9 S X=0 F S X=$O(IBE(X)) Q:'X S IBL=IBL+1,IBT(IBL,0)=IBE(X)
  1. ;
  1. D ^XMD
  1. ;
  1. Q
  1. ;
  1. XMDEM(DFN,IBT,IBL) ; Sets basic demographics in text
  1. ;
  1. N VADM,VA,VAERR
  1. ;
  1. D DEM^VADPT
  1. ;
  1. S IBT(1,0)=" Patient: "_VADM(1)
  1. S IBT(3,0)=" SSN: "_$P(VADM(2),"^",2)
  1. S (IBT(2,0),IBT(4,0))=" "
  1. S IBL=4
  1. ;
  1. Q
  1. ;
  1. LASTDT(X) ; compute the last day of the month in X
  1. N XM,X1,X2
  1. I $E(X,4,5)=12 Q $E(X,1,5)_"31"
  1. S XM=$E(X,4,5)+1
  1. S:XM<10 XM="0"_XM
  1. S X1=$E(X,1,3)_XM_"01"
  1. S X2=-1
  1. D C^%DTC
  1. Q X
  1. ;
  1. TOT ; calculates the total charged for a patient (for the month)
  1. ; requires IBFR, IBLTCST, DFN
  1. ; returns IBT (total amount already billed), IBTYP (inpt or opt)
  1. ;
  1. N IBDT,IBX,IBZ,IBAT
  1. S IBTYP="O",IBT=0
  1. ;
  1. ;IB*2.0*660 - Modify LTC Screen to look at Billing groups instead of Action Type Name in new LTCCHK function.
  1. S IBDT=-$E(IBFR,1,5)_"00" F S IBDT=$O(^IB("AFDT",DFN,IBDT),-1) Q:IBDT=""!($E(IBDT,2,6)'=$E(IBFR,1,5)) S IBX=0 F S IBX=$O(^IB("AFDT",DFN,IBDT,IBX)) Q:IBX<1 S IBZ=$G(^IB(IBX,0)),IBAT=+$P(IBZ,"^",3) I $$LTCCHK(IBAT) D
  1. . ;
  1. . ; don't use bills that are cancelled.
  1. . I $P($G(^IBE(350.21,+$P(IBZ,"^",5),0)),"^",5) Q
  1. . ;
  1. . ; don't use cancellation action types either
  1. . I $P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^",5)=2 Q
  1. . ;
  1. . S IBT=IBT+$P(^IB(IBX,0),"^",7)
  1. . I $P(^IBE(350.1,IBAT,0),U,11)=9 S IBTYP="I" ; IB*2.0*728
  1. ;
  1. Q
  1. ;
  1. LASTMJ() ; function to return when the Monthly Job was last run or 0
  1. N IBLSTDT
  1. S IBLSTDT=$P($G(^IBE(350.9,1,0)),"^",16)
  1. Q $S(IBLSTDT>3:IBLSTDT,1:0)
  1. ;
  1. CDEXMPT(DFN,IBDT) ; determine if the patient is exempt from non-institutional
  1. ; ltc charges because of Catastrophically Disabled status
  1. ; 0 - not exempt from LTC, 1 - exempt from LTC
  1. N IBDG
  1. S IBDG=$$GET^DGENCDA(DFN,.IBDG) ; IA# 4969
  1. I $G(IBDG("VCD"))'="Y" Q 0 ; cd indicator
  1. Q $S(IBDT<$G(IBDG("DATE")):0,1:1)
  1. ;
  1. ;IB*2.0*660 - Check to see if Action Type is an LTC Action Type.
  1. LTCCHK(IBAT) ; Check to see if the action type is an LTC Action Type
  1. ; Input: IBZ - Action type data from IBE(350.1,,0)
  1. N IBATDT,IBBG
  1. Q:IBAT="" 0 ;Improperly defined Action Type, not an LTC
  1. S IBATDT=$G(^IBE(350.1,IBAT,0))
  1. S IBBG=$P(IBATDT,U,11)
  1. Q:IBBG=9 1 ;LTC INPT Billing Group
  1. Q:IBBG=8 1 ;LTC OPT Billing Group
  1. Q 0 ;A non LTC Billing Group
  1. ;