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

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

initial load of WorldVistAEHR
File size: 9.1 KB
Line 
1IBAECU2 ;WOIFO/SS-LTC PHASE 2 UTILITIES ; 20-FEB-02
2 ;;2.0;INTEGRATED BILLING;**171,176,198**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;****** Inpatient LTC related utilities *********
6 ;/*--
7 ;Returns info about all admissions via ^TMP($J,IBADM,IBDFN) global
8 ;
9 ;Input:
10 ;
11 ;IBFRBEG- first date (in FM format),must be a valid,
12 ; (wrong date like 3000231 will cause mistakes)
13 ;IBFREND- last date (in FM format),must be a valid date
14 ; if any of dates above > yesterday it will be set to yesterday
15 ;
16 ;IBDFN - patient's ien in file (#2)
17 ;IBADM - any string to identify results in ^TMP($J,IBADM
18 ;IBDETL - 1 if you need details of each stay day in ^TMP global
19 ; - 0 if you do not need it
20 ;Output:
21 ;
22 ;temp global array with inpatient info:
23 ; ^TMP($J,IBADM,IBDFN,IBIEN405)=
24 ; Pieces :
25 ; #1 - admission date
26 ; #2 - discharge date
27 ; #3 - last_date_of_admission
28 ; #4 - stay_days in specified date frame $$STAYDS()
29 ; #5 - days_on_leave in specified date frame $$LEAVDS()
30 ; #6 - total admission days
31 ;
32 ;Daily info for all stay days about LTC/MeansTest belonging,rate
33 ;and specialty (it may vary during the admission)
34 ; ^TMP($J,IBADM,IBDFN,IBIEN405,"SD",date)=L/M^rate^specialty
35 ; where pieces:
36 ; #1 - "L" for LTC, "M" for MeansTest
37 ; #2 - 0
38 ; #3 - specialty ptr to file #42.4
39 ; #4 - pointer to #350.1 IB action type
40 ;
41 ;Daily info about leave days
42 ; ^TMP($J,IBADM,IBDFN,IBIEN405,"LD") how many days on leave
43 ; ^TMP($J,IBADM,IBDFN,IBIEN405,"LD",date_on_leave)=""
44 ;
45 ;Returns:
46 ; 0 - none
47 ; 1 - if any leave or stay days in the period
48INPINFO(IBFRBEG,IBFREND,IBDFN,IBADM,IBDETL) ;
49 N IBRDT,IBDT6,IBDT6A,IBRDTBEG,IBRDTEND,IBIEN1,IBIEN3,IBIEN6,IBNODE01,IBSTRT,IBFL
50 N IBNODE03,IBTYP,IBSPEC,IBLASTD,IBSTAYDS,IBLEAVDS,IBDISCH,IBADMDS,IBADMDT
51 N IBYESTRD,IBTEMP
52 N IBRETVAL S IBRETVAL=0
53 S IBLEAVDS=0,IBSTAYDS=0
54 D NOW^%DTC S IBYESTRD=%\1,IBYESTRD=$$CHNGDATE^IBAECU4(IBYESTRD,-1)
55 S:IBYESTRD<IBFRBEG IBFRBEG=IBYESTRD
56 S:IBYESTRD<IBFREND IBFREND=IBYESTRD
57 ; go thru "reverse admissions starting from IBFREND thru all because
58 ; an active admission can start any time in the past
59 S IBRDT=9999999.9999999-(IBFREND_".9999999")
60 F S IBRDT=$O(^DGPM("ATID1",IBDFN,IBRDT)) Q:IBRDT="" D
61 . S IBIEN1=$O(^DGPM("ATID1",IBDFN,IBRDT,0))
62 . I IBIEN1=""!('$D(^DGPM(IBIEN1,0))) D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBIEN1),"Admission (INPINFO)","no admission") Q
63 . S IBNODE01=$G(^DGPM(IBIEN1,0))
64 . S IBADMDT=+IBNODE01\1
65 . S IBIEN3=+$P(IBNODE01,"^",17) ;discharge entry
66 . I IBIEN3>0 S IBDISCH=+$G(^DGPM(IBIEN3,0))\1
67 . I IBIEN3=0 S IBDISCH=0
68 . I IBDISCH>0 I IBDISCH<IBFRBEG Q ;was discharged before start date
69 . S:IBDISCH>0 IBLASTD=$$CHNGDATE^IBAECU4(IBDISCH,-1) ;do not count discharge
70 . S:IBDISCH=0 IBLASTD=IBFREND
71 . ; days on leave
72 . S IBLEAVDS=$$LEAVDS(IBFRBEG,IBFREND,IBIEN1,IBDFN,IBADM)
73 . ; treat speclty
74 . S IBFL=0
75 . S IBDT6=0,IBSTRT=$S(IBLASTD>IBFREND:IBFREND,1:IBLASTD)
76 . F S IBDT6=$O(^DGPM("ATS",IBDFN,IBIEN1,IBDT6)) Q:IBDT6="" D
77 . . S IBSPEC=+$O(^DGPM("ATS",IBDFN,IBIEN1,IBDT6,0)) ;pointer to #45.7
78 . . S IBDT6A=(9999999.9999999-IBDT6)\1
79 . . I IBDT6A<IBFRBEG Q:IBFL=1 S IBDT6A=IBFRBEG,IBFL=1 ;IBFL=1 - quit next time
80 . . S IBTEMP=""
81 . . I IBSPEC>0 D ;S IBSPEC=pointer to#42.4
82 . . . S IBSPEC=+$P($G(^DIC(45.7,IBSPEC,0)),"^",2) S:IBSPEC>0 IBTEMP=$$TREATSP(IBSPEC),IBTYP=$P(IBTEMP,"^",1)
83 . . S:IBSPEC=0 IBTYP="U"
84 . . S:IBTEMP="" IBTYP="U"
85 . . F Q:IBDT6A>IBSTRT D
86 . . . I IBDETL=1,'$D(^TMP($J,IBADM,IBDFN,IBIEN1,"LD",IBSTRT)) S ^TMP($J,IBADM,IBDFN,IBIEN1,"SD",IBSTRT)=IBTYP_"^0^"_IBSPEC_"^"_$P(IBTEMP,"^",3)
87 . . . S:$D(^TMP($J,IBADM,IBDFN,IBIEN1,"LD",IBSTRT)) ^TMP($J,IBADM,IBDFN,IBIEN1,"LD",IBSTRT)=IBTYP_"^0^"_IBSPEC_"^"_$P(IBTEMP,"^",3)
88 . . . S IBSTRT=$$CHNGDATE^IBAECU4(IBSTRT,-1)
89 . ; stay days
90 . S IBSTAYDS=$$STAYDS(IBFRBEG,IBFREND,IBIEN1,IBDISCH)
91 . S IBADMDS=$$FMDIFF^XLFDT(IBLASTD,IBADMDT,1)+1
92 . S ^TMP($J,IBADM,IBDFN,IBIEN1)=IBADMDT_"^"_IBDISCH_"^"_IBLASTD_"^"_IBSTAYDS_"^"_IBLEAVDS_"^"_IBADMDS
93 . I IBRETVAL=0 S:(IBSTAYDS+IBLEAVDS)>0 IBRETVAL=1
94 Q IBRETVAL
95 ;
96 ;Input:
97 ;How many days of stay in this month
98 ;IBDTB -begin date of date frame
99 ;IBDTE -end date of date frame
100 ;IBP405 - pointer to Admission entry in #405
101 ;DSDAY - discharge date, if patient is not duscharged then DSDAY=0
102STAYDS(IBDTB,IBDTE,IBP405,DSDAY) ;
103 S IBDTB=$S($$BILDATE^IBAECN1>IBDTB:$$BILDATE^IBAECN1,1:IBDTB)
104 I IBDTE<DSDAY!(DSDAY=0) Q $$LOS^IBCU64(IBDTB,IBDTE,2,IBP405)
105 Q $$LOS^IBCU64(IBDTB,IBDTE,1,IBP405)
106 ;
107 ;Input:
108 ;IBDTB -begin date of the given date range
109 ;IBDTE -end date of the given date frame
110 ;IBP405 - pointer to entry in #405
111 ;IBDFN1 - DFN of the patient
112 ;IBIDN - identifier for ^TMP node
113 ;Output :
114 ;returns as a return value: a number of days on leave
115 ;returns via ^TMP:
116 ; ^TMP($J,IBIDN,IBDFN1,IBP405,"LD")=total_days_on_leave_for_the_date_range
117 ; and for each of days on leave:
118 ; ^TMP($J,IBIDN,IBDFN1,IBP405,"LD",the_date_on_leave)=""
119LEAVDS(IBDTB,IBDTE,IBP405,IBDFN1,IBIDN) ;
120 N DFN,IBII,IBDT1,IBDT2,IBCNT,IBDS,IBVAR
121 S DFN=IBDFN1,IBCNT=0
122 I IBIDN'="" S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD")=0
123 N DT S DT=$$TODAY^IBAECN1()
124 N IBLDAYS S IBLDAYS=""
125 S:IBDTE>DT IBDTE=DT
126 I $$APLD^DGUTL2(IBP405,.IBLDAYS,IBDTB,IBDTE,"B")=-1 Q 0
127 ;if no days on leave
128 I +IBLDAYS(0)=0 Q 0
129 ;if there is no "movement node" in output of $$APLD^DGUTL2 is normal
130 I +$O(IBLDAYS(0))=0 D Q IBCNT
131 . S IBDT1=$P(IBLDAYS(0),"^",2)\1 ;begin
132 . S IBDT2=$P(IBLDAYS(0),"^",3)\1 ;end
133 . S IBDS=$P(IBLDAYS(0),"^",1) ;days
134 . I ($$FMDIFF^XLFDT(IBDT2,IBDT1)+1)'=IBDS S IBCNT=0 D
135 . . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBP405),"Leave days (LEAVDS), only 0-node","Possibly incorrect number of days on leave")
136 . S IBFL=0
137 . F IBVAR=1:1:IBDS Q:IBFL D
138 . . S IBCNT=IBCNT+1
139 . . I IBIDN'="" D
140 . . . S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD")=$G(^TMP($J,IBIDN,IBDFN1,IBP405,"LD"))+1
141 . . . S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD",IBDT1)=""
142 . . S:IBDT1=IBDT2 IBFL=1
143 . . S IBDT1=$$CHNGDATE^IBAECU4(IBDT1,+1)
144 ;if output of $$APLD^DGUTL2 has "movement node"
145 S IBII=0
146 F S IBII=$O(IBLDAYS(IBII)) Q:+IBII=0 D
147 . S IBDT1=$P(IBLDAYS(IBII),"^",1)\1 ;begin
148 . S IBDT2=$P(IBLDAYS(IBII),"^",2)\1 ;end
149 . S IBDS=$P(IBLDAYS(IBII),"^",3) ;days
150 . S IBFL=0
151 . F IBVAR=1:1:IBDS Q:IBFL D
152 . . S IBCNT=IBCNT+1
153 . . I IBIDN'="" D
154 . . . S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD")=$G(^TMP($J,IBIDN,IBDFN1,IBP405,"LD"))+1
155 . . . S ^TMP($J,IBIDN,IBDFN1,IBP405,"LD",IBDT1)=""
156 . . S:IBDT1=IBDT2 IBFL=1
157 . . S IBDT1=$$CHNGDATE^IBAECU4(IBDT1,+1)
158 Q IBCNT
159 ;
160 ;/*-----
161 ;
162 ;Input:
163 ;SPEC - the ien of #42.4 Specialty
164 ;Output:
165 ;If a LTC Specialty Returns "L^ien of #42.4^ien of 350.1"
166 ;If not LTC Spec Returns "M^ien of #42.4^"
167TREATSP(SPEC) ;
168 N IBRET,IBNAME,IBATYP
169 S IBRET=$$LTCSPEC^IBAECU(SPEC)
170 Q:IBRET=0 "M^"_SPEC_"^"
171 S IBNAME=$P(IBRET,"^",2)
172 S IBATYP=$O(^IBE(350.1,"B",IBNAME,0))
173 Q "L^"_SPEC_"^"_IBATYP
174 ;
175 ;/**
176 ;Goes thru all specialty changes and determines specialty
177 ;- if meets non-LTC then quits loop & returns 0
178 ;- if LTC then calculates a number of stay days between specialty
179 ; change and IBLSTDAY,if the number>180 then quits loop & returns 1
180 ;Input:
181 ;IBDFN - DFN of patient
182 ;IBAMD - ptr to #405 for the admission
183 ;IBLSTDAY - date from which we count 180 clock days toward the past
184 ;(these 180 days must include only stay days on LTC
185 ;and should not include any AA,UA and ASIH days)
186 ;IBDISCH - discharge date
187MORE180(IBDFN,IBADM,IBLSTDAY,IBDISCH) ;
188 N IBRVDT,IBNONLTC,IBDAYS,IB1,IB2,IBCUR,IBQFLG
189 S (IBNONLTC,IBDAYS,IBQFLG)=0
190 S IBRVDT=9999999.9999999-(IBLSTDAY_".9999999")
191 S IB1=IBRVDT
192 F S IB1=$O(^DGPM("ATS",IBDFN,IBADM,IB1)) Q:+IB1=0!(IBQFLG'=0) D
193 . S IBCUR=(9999999.9999999-IB1)\1
194 . S IB2=$O(^DGPM("ATS",IBDFN,IBADM,IB1,0))
195 . Q:+IB2=0
196 . S IB2=+$P($G(^DIC(45.7,IB2,0)),"^",2) I IB2<1 S IBQFLG=-1 Q
197 . I $P($$TREATSP(IB2),"^",1)="M" S IBQFLG=-1 Q
198 . S IBDAYS=$$STAYDS(IBCUR,IBLSTDAY,IBADM,IBDISCH)
199 . I IBDAYS>180 S IBQFLG=1 Q
200 Q IBQFLG=1
201 ;
202 ;/**
203 ;is there any inpatient episode with that day
204 ;Input:
205 ;IBDFN - dfn of the patient
206 ;IBDT1 - date
207 ;IBTMPLB - ^TMP global subscript like IBADM in $$INPINFO
208 ;Output:
209 ;Returns "a^b" where :
210 ;a - number of LTC admissions on this date
211 ;b - number of Means Test admissions on this date
212 ;if "" - nothing
213 ;means test & stay days:
214 ;.IBADMS("M","SD",#)=treating specialty^ien of 350.1 IB action type^admission date
215 ;means test & leave days
216 ;.IBADMS("M","LD",#)=treating specialty^ien of 350.1 IB action type^admission date
217 ;LTC & stay days
218 ;.IBADMS("L","SD",#)=treating specialty^ien of 350.1 IB action type^admission date
219 ;LTC & leave days
220 ;.IBADMS("L","LD",#)=treating specialty^ien of 350.1 IB action type^admission date
221ISINPAT(IBDFN,IBDT1,IBTMPLB,IBADMS) ;
222 N IBADM,IB1,IBRETV,IBSDLD,IBD
223 S IBADM=0,IBRETV=""
224 F S IBADM=$O(^TMP($J,IBTMPLB,IBDFN,IBADM)) Q:+IBADM=0 D
225 . S IBSDLD="SD",IBD=$G(^TMP($J,IBTMPLB,IBDFN,IBADM,"SD",IBDT1))
226 . I IBD="" S IBSDLD="LD",IBD=$G(^TMP($J,IBTMPLB,IBDFN,IBADM,"LD",IBDT1))
227 . S IB1=$P(IBD,"^",1)
228 . I IB1="L" D Q
229 . . S IBADMS("L",IBSDLD,IBADM)=$P(IBD,"^",3,4)_"^"_+$G(^TMP($J,IBTMPLB,IBDFN,IBADM))
230 . . S $P(IBRETV,"^",1)=$P($G(IBRETV),"^",1)+1
231 . I IB1="M" D
232 . . S IBADMS("M",IBSDLD,IBADM)=$P(IBD,"^",3,4)_"^"_+$G(^TMP($J,IBTMPLB,IBDFN,IBADM))
233 . . S $P(IBRETV,"^",2)=$P($G(IBRETV),"^",2)+1
234 Q IBRETV
235 ;
Note: See TracBrowser for help on using the repository browser.