source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAECN1.m@ 1766

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

initial load of WorldVistAEHR

File size: 7.3 KB
Line 
1IBAECN1 ;WOIFO/SS-LTC PHASE 2 NIGHTLY JOB ; 20-FEB-02
2 ;;2.0;INTEGRATED BILLING;**176,188**;21-MAR-94
3 ;; Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5BILDATE() ;billing start date for Long Term Care Billing
6 ; Means Test for LTC care billing stopped on JUNE 17,2002 /see
7 ; STDATE^IBAECU1()/ . LTC billing for LTC care must start on
8 ; JULY 26,2002. There is no billing for LTC care in period
9 ; between JUNE 17,2002 and JULY 26,2002. That means LTC clock
10 ; will start on JULY 5,2002 (because of 21 "free" days)
11 Q 3020705 ;
12 ;
13NJ ;LTC Nightly job
14 N X I $D(^%ZOSF("TRAP")) S X="ERR^IBAECN1",@^("TRAP")
15 N IBPRMNTH S IBPRMNTH=$$PREVMNTH^IBAECM1() ;last day of previous month
16 Q:$$BILDATE()>IBPRMNTH
17 ;
18 N IBLSTMJ S IBLSTMJ=$$LASTMJ^IBAECU()
19 ;run code for the 1st monthly job
20 I IBLSTMJ=0 D MJ1ST^IBAECM3 Q
21 ;if was run & successfully completed this month- quit
22 Q:IBLSTMJ'<($E($$TODAY(),1,5)_"01")
23 ;------- local arrays
24 ;IBMDS1(0)-1st,IBMDS1(1) last day in the month,
25 ;IBMDS1(2)-year_month, IBMDS1 - number of days
26 N IBMDS1 S IBMDS1=""
27 ;dates,days for processing month which is normally
28 ; previous month because MJ runs 1stday of the month
29 S IBMDS1(1)=IBPRMNTH,IBMDS1(2)=$E(IBMDS1(1),1,5)
30 S IBMDS1(0)=IBMDS1(2)_"01",IBMDS1=$E(IBMDS1(1),6,7)
31 D MJT^IBAECM1
32 D RESET
33 Q
34 ;
35ERR ;Error trap for NJ
36 N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBT,XMDUZ,IBPAT,IBTODAY
37 N XMGROUP S XMGROUP=$$GET1^DIQ(350.9,"1,",.09)
38 Q:XMGROUP=""
39 S XMGROUP="G."_XMGROUP
40 S IBPAT="Unknown",IBTODAY=""
41 N Y D NOW^%DTC S Y=% X ^DD("DD") S IBTODAY=Y
42 I +$G(DFN)>0 D
43 . N VADM,VA,VAERR
44 . D DEM^VADPT
45 . S IBPAT=$G(VADM(1))_", SSN: "_$P($G(VADM(2)),"^",2)
46 S:IBPAT=", SSN: " IBPAT="Unknown"
47 S XMSUB="LTC Monthly Job Failure",XMY(XMGROUP)=""
48 S XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
49 S IBT(1,0)="**********************************************"
50 S IBT(2,0)="LTC Monthly Job crashed on "_IBTODAY
51 S IBT(3,0)="when the system was processing the following patient : "
52 S IBT(4,0)=" "_IBPAT
53 S IBT(5,0)="Please verify data for the patient, fix findings"
54 S IBT(6,0)="and then:"
55 S IBT(7,0)="- if today is the last day of the month then you"
56 S IBT(8,0)=" need to run NJ^IBAECN1 today manually from"
57 S IBT(9,0)=" programmer mode."
58 S IBT(10,0)="- otherwise let the system run the NJ^IBAECN1"
59 S IBT(11,0)=" automatically after midnight."
60 S IBT(12,0)=""
61 S IBT(13,0)="In both cases, please, check patient's charges and"
62 S IBT(14,0)="your e-mail again."
63 D ^XMD
64 Q
65 ;
66 ;checks if the most recent treating specialty of the admission
67 ;is related to LTC?
68 ;invoked from PROC^IBAMTC Exmpl:
69 ; I $$ISLTCADM(DFN,IBA)
70 ;to create entries in 351.81 if necessary
71 ;Input:
72 ;IBDFN - patient's ien in file (#2)
73 ;IB405 - ien of admission (#405)
74 ;Output:
75 ;returns 0 if the specialty for non-LTC care
76 ;otherwise - returns 1
77 ;
78ISLTCADM(IBDFN,IB405) ;
79 ;1) treat all LTC as Means Test if the legislation is not effective yet
80 I $$YESTRDAY()<$$BILDATE() Q 0
81 N IBSPEC,IBTS
82 S IBTS="M"
83 ;2) determine treating specialty (TS)
84 S IBSPEC=$$LASTTS(IBDFN,IB405) ;most recent TS (pointer #42.4)
85 I IBSPEC>0 S IBTS=$P($$TREATSP^IBAECU2(IBSPEC),"^",1) ;is it LTC or not?
86 I IBSPEC'>0 S IBTS="M" ;treat unknown as Means Test
87 I IBTS="L" D Q 1 ;if TS is LTC
88 . I $$CLOCK^IBAECU(IBDFN,$$YESTRDAY())
89 Q 0
90 ;finds the most recent parent entry in #350 related to admission
91 ;Input:
92 ;IBDFN - patient's dfn
93 ;IBDT - the date to seek from (today)
94 ;IBADM - admission we are seeking for
95 ;IBSTAT = status we are seeking for
96 ;output:
97 ;returns ien_of_350^IB_action_type
98 ;or "0^" if not found
99FIND350(IBDFN,IBDATE,IBADM,IBSTAT) ;
100 N IB350,IBDT,IBINF,IBFL
101 S IBFL=0,IBINF=""
102 S IBDT=-IBDATE F S IBDT=$O(^IB("AFDT",IBDFN,IBDT)) Q:IBFL!(+IBDT=0) D
103 . S IB350=0 F S IB350=$O(^IB("AFDT",IBDFN,IBDT,IB350)) Q:+IB350=0 D
104 . . Q:'$D(^IB("AC",IBSTAT,IB350))
105 . . S IBINF=$G(^IB(IB350,0))
106 . . Q:IB350'=$P(IBINF,"^",16) ;non parent
107 . . Q:$P($P(IBINF,"^",4),":",1)'="405" ;non inpatient
108 . . S:$P($P(IBINF,"^",4),":",2)=IBADM IBFL=IB350
109 Q IBFL_"^"_$P($G(IBINF),"^",3)
110 ;
111 ;edit #350 event entry
112 ;IBIENCL - ien of #350
113 ;IBLSTDT = DATE LAST BILLED
114 ;IBADM - ien in #405
115STAT350(IBIENCL,IBLSTDT,IBADM) ;
116 N IBIENS,IBFDA,IBERR,IBDFN1
117 S IBDFN1=$P($G(^IB(IBIENCL,0)),"^",2)
118 Q:+IBDFN1=0
119 S IBIENS=IBIENCL_"," ; "D0,"
120 S IBFDA(350,IBIENS,13)=+$G(DUZ)
121 S:'$P($G(^IB(IBIENCL,0)),"^",17) IBFDA(350,IBIENS,.17)=(+$G(^DGPM(IBADM,0)))\1
122 S IBFDA(350,IBIENS,.18)=(+$G(IBLSTDT))\1
123 D NOW^%DTC S IBD=%
124 S IBFDA(350,IBIENS,14)=IBD
125 D FILE^DIE("","IBFDA","IBERR")
126 I $D(IBERR) D
127 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"BILLING ACTION:","closing parent entry"_$G(IBERR("DIERR",1,"TEXT",1)))
128 Q
129 ;------
130 ;create a new inpatient parent event entry in #350
131 ;Input:
132 ;DFN - patient's ien #2
133 ;IBADMIEN - admission ien #405
134 ;IBEVDT - event date (piece 17) for parent entry must be an admission date,
135 ;IBNH:
136 ; 1 - for 56 (#350.1) NHCU ADMISSION
137 ; 93 - for 93 (#350.1) LTC ADMISSION
138 ; 0 - all other events
139 ;Returns:
140 ;New ien of #350 Or 0 if not created
141CREV350(DFN,IBADMIEN,IBEVDT,IBNH) ;
142 Q:IBEVDT=0 0
143 N IBEVDA,IBSL,IBSERV
144 S IBEVDA=0
145 D SERV^IBAUTL2
146 I '$D(IBSITE)!('$D(IBFAC)) D SITE^IBAUTL
147 S IBSL="405:"_IBADMIEN
148 ;if LTC ADMISSION set IBNHLTC
149 I IBNH=93 N IBNHLTC S IBNHLTC=93
150 D EVADD^IBAUTL3
151 Q IBEVDA
152 ;
153 ;Find original admission ien, considering ASIH movements
154 ;Input: ien of 405 that can be "child", for example
155 ; we have ien of Nursing Home admission
156 ; then patient moved to ASIH to hospital
157 ; if IBA is ASIH hospital admission ien then call will return
158 ; "original" Nursing Home admission's ien
159 ;Output: ien of 405 of "original" admission
160ORIGADM(IBA) ;
161 N X,Y,Z S Z=IBA
162 F S X=$G(^DGPM(Z,0)),Y=$P(X,"^",21) Q:Y="" S Z=+$P($G(^DGPM(Y,0)),"^",14)
163 Q +Z
164 ;
165 ;most recent treating specialty
166 ;input:
167 ;IBDFN - patient ien
168 ;IB405ADM - admission's #405 ien
169 ;output:
170 ;returns ien of SPECIALTY FILE (#42.4)
171LASTTS(IBDFN,IB405ADM) ;
172 N IBDT6,IBSPEC
173 S IBDT6=0
174 S IBDT6=+$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6))
175 Q:+IBDT6=0 -1 ;error
176 S IBSPEC=$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6,0))
177 Q:+IBSPEC=0 -1 ;error
178 ;convert fac spec (45.7) -> treat spec (#42.4)
179 S IBSPEC=+$P($G(^DIC(45.7,IBSPEC,0)),"^",2)
180 Q:+IBSPEC=0 -1
181 Q IBSPEC
182 ;returns today date
183TODAY() ;
184 N X
185 D NOW^%DTC
186 Q X
187 ;returns yesterday date
188YESTRDAY() ;
189 N X1,X2,X
190 S X1=$$TODAY()
191 S X2=-1
192 D C^%DTC
193 Q X
194 ;returns 1 if the most recent treating specialty for this billable
195 ;event and for this date was LTC
196 ;DFN -patient ien
197 ;IBEVDA - ien of event in #350
198 ;IBDT - date
199ASIHORG(DFN,IBEVDA,IBDT) ;
200 N IB405 S IB405=+$P($P($G(^IB(+IBEVDA,0)),"^",4),":",2)
201 Q:IB405=0 0
202 Q $$ISLTC4DT(DFN,IB405,IBDT_.2359)
203 ;
204 ;returns 1 if the most recent treating specialty for the admission
205 ;and the date was LTC specialty
206 ;otherwise returns 0 or -1
207 ;DFN -patient ien
208 ;IB405ADM - ien of #405
209 ;IBDT - date
210ISLTC4DT(IBDFN,IB405ADM,IBDT) ;
211 N IBDT6,IBSPEC,IBTS
212 S IBDT6=9999999.9999999-IBDT
213 S IBDT6=+$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6))
214 Q:+IBDT6=0 -1 ;error
215 S IBSPEC=$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6,0))
216 Q:+IBSPEC=0 -1 ;error
217 ;convert fac spec (45.7) -> treat spec (#42.4)
218 S IBSPEC=+$P($G(^DIC(45.7,IBSPEC,0)),"^",2)
219 I IBSPEC>0 S IBTS=$P($$TREATSP^IBAECU2(IBSPEC),"^",1) ;is it LTC or not?
220 I IBSPEC'>0 S IBTS="M" ;unknown as Means Test
221 I IBTS="L" Q 1 ;if TS is LTC
222 Q 0
223 ;
224RESET ; this will reset the ^xtmp global
225 K ^XTMP("IB1010EC")
226 S ^XTMP("IB1010EC",0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^LIST OF PATIENTS ALREADY REPORTED AS MISSING 1010EC INFO"
227 Q
228 ;
Note: See TracBrowser for help on using the repository browser.