source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAECU.m@ 812

Last change on this file since 812 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.0 KB
Line 
1IBAECU ;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 ;
15LTCST(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 ;
23MAXRATE(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 ;
38FACSPEC(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 ;
43LTCSPEC(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 ;
58LTCSTOP(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 ;
79CLOCK(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 ;
99YR(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 ;
108ADDCL(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 ;
122ADDCLQ Q $S($G(IBN):IBN,1:Y)
123 ;
124LTCENC(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
139LTCENCQ Q +$G(Y)
140 ;
141 ;
142XMBACK(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 ;
156XMNOEC(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 ;
181XMDEM(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 ;
194LASTDT(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 ;
204TOT ; 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 ;
224LASTMJ() ; 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 ;
Note: See TracBrowser for help on using the repository browser.