| [613] | 1 | IBAECU ;ALB/BGA-LTC UTILITIES DETERMINE LTC ELIG ; 25-SEPT-01
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**164,171,176,198,188**;21-MAR-94
|
|---|
| 3 | ;; Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ; This routine contains the following utilities in support of the
|
|---|
| 6 | ; LTC initiative:
|
|---|
| 7 | ; 1. Determine if a patient is ELIGIBLE for the LTC COPAY
|
|---|
| 8 | ; 2. Determine if a inpatient episode is related to LTC
|
|---|
| 9 | ;
|
|---|
| 10 | ;LTCST(DFN,IBDT); - Returns '2' if LTC Eligible or else '1' Not Eligible
|
|---|
| 11 | ; ; -- Returns '-1' and a second piece if there is an ERROR
|
|---|
| 12 | ; ; -- If 2 LTC VET's Income Exceeds Pension Level <LTC ELIG>
|
|---|
| 13 | ; ; -- If 1 Not LTC Eligible = Exempt
|
|---|
| 14 | ;
|
|---|
| 15 | LTCST(DFN,IBDT,LOS) ; returns LTC status from API
|
|---|
| 16 | ; input: Patient's DFN, Date of Care, Length of stay
|
|---|
| 17 | ;
|
|---|
| 18 | ; format: exemption flag ^ exemption reason (714.1 pointer)
|
|---|
| 19 | ; ^ <181 $ amount ^ >180 $ amount ^ opt $ amount
|
|---|
| 20 | Q $$COPAY^EASECCAL(DFN,$$LASTDT(IBDT),LOS)
|
|---|
| 21 | ;
|
|---|
| 22 | ;
|
|---|
| 23 | MAXRATE(IBDT) ; returns the max rates for the effective date
|
|---|
| 24 | ; the rates retuned are the max daily rates for any and all LTC
|
|---|
| 25 | ; copayments. The return is: outpatient^inpatient
|
|---|
| 26 | ;
|
|---|
| 27 | N IBATYP,IBR,IBL,IBT,IBCHG
|
|---|
| 28 | ;
|
|---|
| 29 | S IBR=""
|
|---|
| 30 | ;
|
|---|
| 31 | ; if IBDT less than the starting date of LTC set to the starting date
|
|---|
| 32 | I IBDT<3020726 S IBDT=3020726
|
|---|
| 33 | ;
|
|---|
| 34 | 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
|
|---|
| 35 | 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
|
|---|
| 36 | Q IBR
|
|---|
| 37 | ;
|
|---|
| 38 | FACSPEC(IBSPEC) ; returns the treating specialty for 42.4 from a facility sp
|
|---|
| 39 | ;
|
|---|
| 40 | Q $P($G(^DIC(45.7,+$G(IBSPEC),0)),"^",2)
|
|---|
| 41 | ;
|
|---|
| 42 | ;
|
|---|
| 43 | LTCSPEC(IBSPEC) ; Determine if INPT Specialty is related to LTC.
|
|---|
| 44 | ; -- Input the ien of #42.4 Specialty
|
|---|
| 45 | ;
|
|---|
| 46 | ; -- Output: Piece 1: If a LTC Specialty Bedsection Pointer 399.1
|
|---|
| 47 | ; If not LTC Spec Return 0
|
|---|
| 48 | ; Piece 2: If LTC, type of LTC
|
|---|
| 49 | ;
|
|---|
| 50 | N IBTS
|
|---|
| 51 | ;
|
|---|
| 52 | ; get the LTC Treating Specialty type
|
|---|
| 53 | S IBTS=$T(@("T"_IBSPEC)^IBAECU1)
|
|---|
| 54 | ;
|
|---|
| 55 | Q $S($L(IBTS):+$E(IBTS,2,99)_"^"_$P(IBTS,";",3),1:0)
|
|---|
| 56 | ;
|
|---|
| 57 | ;
|
|---|
| 58 | LTCSTOP(IB407) ; Determine if the 'STOP CODE' is related to LTC.
|
|---|
| 59 | ;
|
|---|
| 60 | ; -- Input the ien of #40.7 Clinic Stop Code
|
|---|
| 61 | ;
|
|---|
| 62 | ; -- Output: 1st piece 1 - LTC STOP CODE
|
|---|
| 63 | ; 0 - Not LTC STOP CODE
|
|---|
| 64 | ;
|
|---|
| 65 | ; 2nd piece = if LTC, type of LTC
|
|---|
| 66 | ;
|
|---|
| 67 | N IBSTOP,IBSCDATA
|
|---|
| 68 | ;
|
|---|
| 69 | ; get the stop code in IBSCDATA(40.7,IB407,1,"E")
|
|---|
| 70 | D DIQ407^IBEMTSCU(IB407,1)
|
|---|
| 71 | I $G(IBSCDATA(40.7,IB407,1,"E"))="" Q 0
|
|---|
| 72 | ;
|
|---|
| 73 | ; get the LTC stop type
|
|---|
| 74 | S IBSTOP=$T(@("C"_IBSCDATA(40.7,IB407,1,"E"))^IBAECU1)
|
|---|
| 75 | ;
|
|---|
| 76 | Q $S($L(IBSTOP):+$E(IBSTOP,2,99)_"^"_$P(IBSTOP,";",3),1:0)
|
|---|
| 77 | ;
|
|---|
| 78 | ;
|
|---|
| 79 | CLOCK(DFN,IBDATE) ; verfiy a clock exists, if not, one will be added
|
|---|
| 80 | N X,Y,IBCL,IBX,DA,DIE,DR,IBFLG
|
|---|
| 81 | ;
|
|---|
| 82 | ; get last clock for patient
|
|---|
| 83 | S IBX=9999999,IBFLG=0
|
|---|
| 84 | F S IBX=$O(^IBA(351.81,"AE",DFN,IBX),-1) Q:+IBX=0!(IBFLG>0) D
|
|---|
| 85 | . S IBCL=0
|
|---|
| 86 | . F S IBCL=$O(^IBA(351.81,"AE",DFN,IBX,IBCL)) Q:+IBCL=0!(IBFLG>0) D
|
|---|
| 87 | . . Q:+$P(^IBA(351.81,IBCL,0),"^",5)'=1 ;if it is not OPEN
|
|---|
| 88 | . . S IBFLG=IBCL
|
|---|
| 89 | ;
|
|---|
| 90 | ; if has an OPEN clock already
|
|---|
| 91 | I IBFLG>0 D Q 1
|
|---|
| 92 | . I +$P(^IBA(351.81,IBFLG,0),"^",7)>0 Q ;already flagged - quit
|
|---|
| 93 | . S DIE="^IBA(351.81,",DR=".07////^S X=IBDATE",DA=IBFLG D ^DIE
|
|---|
| 94 | ; if there is no OPEN clock the add a new clock, and set CURRENT EVENTS DATE
|
|---|
| 95 | 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")
|
|---|
| 96 | Q +Y
|
|---|
| 97 | ;
|
|---|
| 98 | ;
|
|---|
| 99 | YR(IBRTED,IBFR) ; is the effective date of the clock too old?
|
|---|
| 100 | ; Input: IBRTED -- Effective Date
|
|---|
| 101 | ; IBFR -- Event Date
|
|---|
| 102 | ; Output: 1 -- Effective Date is too old
|
|---|
| 103 | ; 0 -- Not
|
|---|
| 104 | N IBNUM,IBYR
|
|---|
| 105 | S IBNUM=$$FMDIFF^XLFDT(IBFR,IBRTED),IBYR=$E(IBFR,1,3)
|
|---|
| 106 | Q IBYR#4&(IBNUM>364)!(IBYR#4=0&(IBNUM>365))
|
|---|
| 107 | ;
|
|---|
| 108 | ADDCL(DFN,IBADT) ; adds a LTC clock, returns LTC Clock IEN
|
|---|
| 109 | ; needs DFN and IBADT (clock begin date)
|
|---|
| 110 | ;
|
|---|
| 111 | N %DT,DD,DO,DIC,DR,X,Y,DA,DR,DIE,IBN,IBN1,IBSITE,IBFAC,DINUM,DLAYGO
|
|---|
| 112 | L +^IBA(351.81,0):10 I '$T S Y="-1^IB014" G ADDCLQ
|
|---|
| 113 | 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
|
|---|
| 114 | D SITE^IBAUTL
|
|---|
| 115 | N IBAEXDT S IBAEXDT=$$GETEXPDT^IBAECU4(IBADT\1) ;expiration date
|
|---|
| 116 | S DIC="^IBA(351.81,",DIC(0)="L",DLAYGO=351.81
|
|---|
| 117 | 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
|
|---|
| 118 | 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
|
|---|
| 119 | L -^IBA(351.81,IBN1)
|
|---|
| 120 | S Y=$S('$D(Y):1,1:"-1^IB028")
|
|---|
| 121 | ;
|
|---|
| 122 | ADDCLQ Q $S($G(IBN):IBN,1:Y)
|
|---|
| 123 | ;
|
|---|
| 124 | LTCENC(DFN,DATE) ; Did the patient have LTC on a specified date?
|
|---|
| 125 | ; Input: DFN -- Pointer to the patient in file #2
|
|---|
| 126 | ; DATE -- Date of the Outpatient Visit
|
|---|
| 127 | ; Output: 0 -- Patient did not have a LTC on the visit date
|
|---|
| 128 | ; 1 -- Patient had a LTC on the visit date
|
|---|
| 129 | N X,Y,Y0,IBVAL,IBCBK,IBFILTER,IBLTC
|
|---|
| 130 | I '$G(DFN)!('$G(DATE)) G LTCENCQ
|
|---|
| 131 | ; - check appts, stop codes
|
|---|
| 132 | S IBVAL("DFN")=DFN,IBVAL("BDT")=DATE,IBVAL("EDT")=DATE+.9999
|
|---|
| 133 | ; Only parent appt or add/edit encounters
|
|---|
| 134 | S IBFILTER=""
|
|---|
| 135 | 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"
|
|---|
| 136 | S IBLTC=0
|
|---|
| 137 | D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
|
|---|
| 138 | I IBLTC S Y=1
|
|---|
| 139 | LTCENCQ Q +$G(Y)
|
|---|
| 140 | ;
|
|---|
| 141 | ;
|
|---|
| 142 | XMBACK(DFN,IBM) ; send a message saying LTC processing has stoped for an event
|
|---|
| 143 | ;
|
|---|
| 144 | N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBX,IBT,XMDUZ
|
|---|
| 145 | ;
|
|---|
| 146 | D XMDEM(DFN,.IBT,.IBL)
|
|---|
| 147 | ;
|
|---|
| 148 | S XMSUB="LTC Copayment Back Billing/Error",XMY("G.IB LTC BACK BILLING")="",XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
|
|---|
| 149 | ;
|
|---|
| 150 | S IBX=0 F S IBX=$O(IBM(IBX)) Q:IBX<1 S IBL=IBL+1,IBT(IBL,0)=IBM(IBX)
|
|---|
| 151 | ;
|
|---|
| 152 | D ^XMD
|
|---|
| 153 | ;
|
|---|
| 154 | Q
|
|---|
| 155 | ;
|
|---|
| 156 | XMNOEC(DFN,IBDT,IBE) ; send a message saying no 1010EC on file for LTC pt.
|
|---|
| 157 | ; IBE is optional additional text
|
|---|
| 158 | ;
|
|---|
| 159 | N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBT,XMDUZ,X
|
|---|
| 160 | ;
|
|---|
| 161 | ; if already done for this patient and month, quit
|
|---|
| 162 | I $D(^XTMP("IB1010EC",DFN)) Q
|
|---|
| 163 | S ^XTMP("IB1010EC",DFN)=""
|
|---|
| 164 | ;
|
|---|
| 165 | D XMDEM(DFN,.IBT,.IBL)
|
|---|
| 166 | ;
|
|---|
| 167 | S XMSUB="1010EC Missing for LTC Patient",XMY("G.IB LTC 1010EC MISSING")="",XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
|
|---|
| 168 | ;
|
|---|
| 169 | S IBL=IBL+1,IBT(IBL,0)="The above patient has received LTC services on "_$$FMTE^XLFDT(IBDT)_" and"
|
|---|
| 170 | S IBL=IBL+1,IBT(IBL,0)="does not have a LTC Copayment Test on file. A LTC Copayment test needs to"
|
|---|
| 171 | S IBL=IBL+1,IBT(IBL,0)="be completed as soon as possible to determine the patient's eligibility"
|
|---|
| 172 | S IBL=IBL+1,IBT(IBL,0)="for exemption and/or copayment obligation. Billing cannot be processed"
|
|---|
| 173 | S IBL=IBL+1,IBT(IBL,0)="until this information is entered."
|
|---|
| 174 | S IBL=IBL+1,IBT(IBL,0)=""
|
|---|
| 175 | I $D(IBE)>9 S X=0 F S X=$O(IBE(X)) Q:'X S IBL=IBL+1,IBT(IBL,0)=IBE(X)
|
|---|
| 176 | ;
|
|---|
| 177 | D ^XMD
|
|---|
| 178 | ;
|
|---|
| 179 | Q
|
|---|
| 180 | ;
|
|---|
| 181 | XMDEM(DFN,IBT,IBL) ; Sets basic demographics in text
|
|---|
| 182 | ;
|
|---|
| 183 | N VADM,VA,VAERR
|
|---|
| 184 | ;
|
|---|
| 185 | D DEM^VADPT
|
|---|
| 186 | ;
|
|---|
| 187 | S IBT(1,0)=" Patient: "_VADM(1)
|
|---|
| 188 | S IBT(3,0)=" SSN: "_$P(VADM(2),"^",2)
|
|---|
| 189 | S (IBT(2,0),IBT(4,0))=" "
|
|---|
| 190 | S IBL=4
|
|---|
| 191 | ;
|
|---|
| 192 | Q
|
|---|
| 193 | ;
|
|---|
| 194 | LASTDT(X) ; compute the last day of the month in X
|
|---|
| 195 | N XM,X1,X2
|
|---|
| 196 | I $E(X,4,5)=12 Q $E(X,1,5)_"31"
|
|---|
| 197 | S XM=$E(X,4,5)+1
|
|---|
| 198 | S:XM<10 XM="0"_XM
|
|---|
| 199 | S X1=$E(X,1,3)_XM_"01"
|
|---|
| 200 | S X2=-1
|
|---|
| 201 | D C^%DTC
|
|---|
| 202 | Q X
|
|---|
| 203 | ;
|
|---|
| 204 | TOT ; calculates the total charged for a patient (for the month)
|
|---|
| 205 | ; requires IBFR, IBLTCST, DFN
|
|---|
| 206 | ; returns IBT (total amount already billed), IBTYP (inpt or opt)
|
|---|
| 207 | ;
|
|---|
| 208 | N IBDT,IBX,IBZ
|
|---|
| 209 | S IBTYP="O",IBT=0
|
|---|
| 210 | ;
|
|---|
| 211 | 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)) I $E($G(^IBE(350.1,+$P(IBZ,"^",3),0)),1,7)="DG LTC " D
|
|---|
| 212 | . ;
|
|---|
| 213 | . ; don't use bills that are cancelled.
|
|---|
| 214 | . I $P($G(^IBE(350.21,+$P(IBZ,"^",5),0)),"^",5) Q
|
|---|
| 215 | . ;
|
|---|
| 216 | . ; don't use cancellation action types either
|
|---|
| 217 | . I $P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^",5)=2 Q
|
|---|
| 218 | . ;
|
|---|
| 219 | . S IBT=IBT+$P(^IB(IBX,0),"^",7)
|
|---|
| 220 | . I $E(^IBE(350.1,$P(IBZ,"^",3),0),8,11)="INPT" S IBTYP="I"
|
|---|
| 221 | ;
|
|---|
| 222 | Q
|
|---|
| 223 | ;
|
|---|
| 224 | LASTMJ() ; function to return when the Monthly Job was last run or 0
|
|---|
| 225 | N IBLSTDT
|
|---|
| 226 | S IBLSTDT=$P($G(^IBE(350.9,1,0)),"^",16)
|
|---|
| 227 | Q $S(IBLSTDT>3:IBLSTDT,1:0)
|
|---|
| 228 | ;
|
|---|
