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