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 Oct 16, 2024@18:06:48 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 ;
