source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXRRPAPR.m@ 1742

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1PXRRPAPR ;ISL/PKR - Patient activity report print. ;8/26/97
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**18,47**;Aug 12, 1996
3 ;
4 N BMARG,C1S,C2S,C3S,C1HS,HEAD,INDENT,PAGE
5 N CLIEN,CSTOP,DATE,DISDATE,DFN,DONE,ED
6 N FACIEN,FACILITY,FACPNAME,HLOC,HLOCIEN,HLOCNAM
7 N IC,JC,LOC,LOS
8 N NAME,POV,SD,SSN,STATUS,TEMP
9 ;
10 ;Allow the task to be cleaned up upon successful completion.
11 S ZTREQ="@"
12 ;
13 U IO
14 S DONE=0
15 ;Setup the formatting parameters.
16 S INDENT=2
17 S C1HS=INDENT
18 S C1S=C1HS+1
19 S C2S=C1S+22
20 S C3S=C2S+32
21 ;
22 S HEAD=1
23 S PAGE=0
24 I ($E(IOST)="C")&(IO=IO(0)) S BMARG=3
25 E S BMARG=2
26 I 'PXRRLCNP D MHEAD(1)
27 ;
28 S STATUS(0)="CANCELED OR NO-SHOWED"
29 ;
30SET ;Set up print fields
31 S FACILITY=0
32NFAC S FACILITY=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY))
33 I FACILITY="" G FINAL
34 S HEAD=1
35 S FACIEN=$P(FACILITY,U,3)
36 S FACPNAME=$P(FACILITY,U,1)_" "_$P(FACILITY,U,2)
37 ;Keep track of the facilities that were found.
38 F IC=1:1:NFAC I $P(PXRRFAC(IC),U,1)=FACIEN D Q
39 . S $P(PXRRFAC(IC),U,4)="M"
40 ;
41 S HLOC=""
42NHLOC S HLOC=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC))
43 I HLOC="" G NFAC
44 S HLOCNAM=$P(HLOC,U,1)
45 S HLOCIEN=$P(HLOC,U,2)
46 S CLIEN=$P(^SC(HLOCIEN,0),U,7)
47 S CSTOP=" ("_$P(^DIC(40.7,CLIEN,0),U,2)_")"
48 ;If the user requested it start a new page.
49 I PXRRLCNP D MHEAD(1)
50 D HEAD(0)
51 ;
52 ;Check for a user request to stop the task.
53 I $$S^%ZTLOAD S ZTSTOP=1 G EXIT
54 ;
55 S NAME=""
56NPAT ;
57 S NAME=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME))
58 I NAME="" G NHLOC
59 S SSN="",SSN=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME,SSN))
60 S DFN=^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME,SSN)
61 D PPRINT
62 I DONE G EXIT
63 G NPAT
64 ;
65FINAL ;Check for facilities that were listed but had no encounters.
66 I $Y>(IOSL-BMARG-3) D PAGE
67 D FACNE^PXRRGPRT(INDENT)
68EXIT ;
69 D EXIT^PXRRGUT
70 D EOR^PXRRGUT
71 Q
72 ;
73 ;=======================================================================
74HEAD(NEWPAGE) ;
75 I NEWPAGE D PAGE
76 E I $Y>(IOSL-BMARG) D PAGE
77 I DONE Q
78 I HEAD D
79 . N CEN,LEN
80 . S LEN=$$MAX^XLFMTH($L(FACPNAME),$L(HLOCNAM))+10
81 . S CEN=(IOM-LEN)/2
82 . W !!,?CEN,"Facility: ",FACPNAME
83 . W !,?CEN,"Location: ",HLOCNAM,CSTOP
84 . S HEAD=0
85 Q
86 ;
87 ;=======================================================================
88MHEAD(NEWPAGE) ;Write the main report header.
89 I NEWPAGE D PAGE
90 E I $Y>(IOSL-BMARG) D PAGE
91 W !!,"Criteria for Patient Activity Report"
92 W !?INDENT,"Location selection criteria:",?35,$P(PXRRLCSC,U,2)
93 S SD=$$FMTE^XLFDT(PXRRBADT)
94 S ED=$$FMTE^XLFDT(PXRREADT)
95 W !?INDENT,"Patient appointment date range:",?35,SD," through ",ED
96 S SD=$$FMTE^XLFDT(PXRRBCDT)
97 S ED=$$FMTE^XLFDT(PXRRECDT)
98 W !?INDENT,"Patient activity date range:",?35,SD," through ",ED
99 S SD=$$FMTE^XLFDT(PXRRBFDT)
100 S ED=$$FMTE^XLFDT(PXRREFDT)
101 W !?INDENT,"Future appointment date range:",?35,SD," through ",ED
102 W !,"____________________________________________________________________"
103 Q
104 ;
105 ;=======================================================================
106PAGE ;form feed to new page
107 I ($E(IOST)="C")&(IO=IO(0)) D
108 . S DIR(0)="E"
109 . W !
110 . D ^DIR K DIR
111 I $D(DIROUT)!$D(DUOUT)!($D(DTOUT)) S DONE=1 Q
112 W:$D(IOF) @IOF
113 S PAGE=PAGE+1
114 D HDR^PXRRGPRT(PAGE)
115 S HEAD=1
116 Q
117 ;
118 ;=======================================================================
119PHEAD(NEWPAGE) ;Print the patient header
120 D HEAD(NEWPAGE)
121 I DONE Q
122 N C2S,C3S,T1,TEMP
123 S TEMP=^XTMP(PXRRXTMP,"PATIENT",DFN)
124 S C2S=$L(NAME)+5
125 S C3S=C2S+14
126 W !,"_______________________________________________________________________________"
127 W !,NAME,?C2S,$P(TEMP,U,1),?C3S,$P(TEMP,U,9)
128 W !
129 S T1=$P(TEMP,U,2)
130 I $L(T1)>0 W T1
131 S T1=$P(TEMP,U,3)
132 I $L(T1)>0 W " ",T1
133 S T1=$P(TEMP,U,4)
134 I $L(T1)>0 W " ",T1
135 S T1=$P(TEMP,U,5)
136 I $L(T1)>0 W " ",T1
137 S T1=$P(TEMP,U,7)
138 I $L(T1)>0 W " ",T1
139 S T1=$P(TEMP,U,8)
140 I $L(T1)>0 W " ",T1
141 Q
142 ;
143 ;=======================================================================
144PPRINT ;Print the information for a patient.
145 N DATE,DXLS,EM,IC,JC,NEWPAGE,PV,ST
146 I $Y>(IOSL-BMARG-5) S NEWPAGE=1
147 E S NEWPAGE=0
148 D PHEAD(NEWPAGE)
149 I DONE Q
150 ;Appointments
151 I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT")) D
152 . I $Y>(IOSL-BMARG-2) D PHEAD(1)
153 . I DONE Q
154 . W !!,?C1HS,"Appointment criteria met:"
155 . S IC=0
156 . F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)) Q:(+IC=0)!(DONE) D
157 .. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)
158 ..;We are not currently displaying status, but save this code in case
159 ..;it is needed later.
160 .. ;S ST=$P(TEMP,U,1)
161 .. ;I $L(ST)=0 S ST=0
162 .. ;I '$D(STATUS(ST)) S STATUS(ST)=$$EXTERNAL^DILFD(2.98,3,"",ST,.EM)
163 .. S PV=$P(TEMP,U,2)
164 .. I '$D(POV(PV)) S POV(PV)=$$EXTERNAL^DILFD(2.98,9,"",PV,.EM)
165 .. S DATE=$$FMTE^XLFDT(IC,"5F")
166 .. S DATE=$TR(DATE,"@"," ")
167 .. I $Y>(IOSL-BMARG) D
168 ... D PHEAD(1)
169 ... I 'DONE W !!,?C1HS,"Appointment criteria met:"
170 .. I 'DONE W !,?C1S,DATE,?C2S,HLOCNAM,?C3S,POV(PV)
171 I DONE Q
172 ;
173 ;Future appointments
174 I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT")) D
175 . I $Y>(IOSL-BMARG-2) D PHEAD(1)
176 . I DONE Q
177 . W !!,?C1HS,"Future Appointments:"
178 . S IC=0
179 . F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)) Q:(+IC=0)!(DONE) D
180 .. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)
181 .. S DATE=$P(TEMP,U,1)
182 .. S LOC=$P(TEMP,U,2)
183 .. S TYPE=$P(TEMP,U,4)
184 .. I $Y>(IOSL-BMARG) D
185 ... D PHEAD(1)
186 ... I 'DONE W !!,?C1HS,"Future Appointments:"
187 .. I 'DONE W !,?C1S,DATE,?C2S,LOC,?C3S,TYPE
188 I DONE Q
189 ;
190 ;Admission and discharge information.
191 I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS")) D
192 . N NEEDBL
193 . I $Y>(IOSL-BMARG-2) D PHEAD(1)
194 . I DONE Q
195 . W ! D SHEAD(C1HS,"Inpatient Stays","-")
196 . S NEEDBL=0
197 . S IC=""
198 . F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC)) Q:(+IC=0)!(DONE) D
199 .. S JC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC,""))
200 .. S DATE=$$FMTE^XLFDT(IC,"5DF")
201 .. I $L(JC)>0 S DISDATE=$$FMTE^XLFDT(JC,"5DF")
202 .. E S DISDATE=""
203 .. S LOS=$$FMDIFF^XLFDT(JC,IC,1)
204 ..;If IC<0 then we have a discharge without any admission informtion.
205 .. I IC["NA" D
206 ... S DATE=" Unknown"
207 ... S LOS=""
208 ..;A patient that has not been discharged will be flagged with a
209 ..;discharge date of DT+1.
210 .. I JC>DT D
211 ... S DISDATE="present"
212 ... S LOS=LOS-1
213 .. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC,JC)
214 .. I $Y>(IOSL-BMARG) D
215 ... D PHEAD(1)
216 ... I 'DONE D
217 .... W ! D SHEAD(C1HS,"Inpatient Stays","-")
218 .... S NEEDBL=0
219 .. I 'DONE D
220 ... I NEEDBL W !
221 ... W !,?C1S,DATE," - ",DISDATE,?C2S,$P(TEMP,U,1),?C3S,"LOS: ",LOS
222 ... W !,?C1S," Last Tr. Specialty: ",?C2S,$P(TEMP,U,2)
223 ... W ?C3S,"Last Prov: ",$P($P(TEMP,U,3),",",1)
224 ... W !,?C1S,"Admitting Diagnosis: ",?C2S,$P(TEMP,U,4)
225 ... S DXLS=$P(TEMP,U,5)
226 ... I $L(DXLS)>0 W !,?(C1S+15),"DXLS:",?C2S,DXLS
227 ... S NEEDBL=1
228 I DONE Q
229 ;
230 ;Emergency room visits
231 I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER")) D
232 . I $Y>(IOSL-BMARG-2) D PHEAD(1)
233 . I DONE Q
234 . W ! D SHEAD(C1HS,"Emergency Room Visits","-")
235 . S IC=0
236 . F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)) Q:(+IC=0)!(DONE) D
237 .. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)
238 .. S DATE=$$FMTE^XLFDT(IC,"5F")
239 .. S DATE=$TR(DATE,"@"," ")
240 .. I $Y>(IOSL-BMARG) D
241 ... D PHEAD(1)
242 ... I 'DONE W ! D SHEAD(C1HS,"Emergency Room Visits","-")
243 .. I 'DONE W !?C1S,DATE,?C2S,$P(TEMP,U,2)
244 I DONE Q
245 ;
246 ;Critical Lab values.
247 I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB")) D
248 . I $Y>(IOSL-BMARG-2) D PHEAD(1)
249 . I DONE Q
250 . W ! D SHEAD(C1HS,"Critical Lab Values","-")
251 . S IC=0
252 . F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC)) Q:(+IC=0)!(DONE) D
253 .. S JC=0
254 .. F S JC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC,JC)) Q:+JC=0 D
255 ... S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC,JC)
256 ... S DATE=$$FMTE^XLFDT(IC,"5F")
257 ... S DATE=$TR(DATE,"@"," ")
258 ... I $Y>(IOSL-BMARG) D
259 .... D PHEAD(1)
260 .... I 'DONE W ! D SHEAD(C1HS,"Critical Lab Values","-")
261 ... I 'DONE W !,?C1S,DATE,?C2S,$P(TEMP,U,1),?C3S,$P(TEMP,U,2)," ",$P(TEMP,U,4)
262 Q
263 ;
264 ;=======================================================================
265SHEAD(INDENT,TEXT,FC) ;Write a section header. INDENT is the number
266 ;of spaces to indent on both the left and right, TEXT is the text, and
267 ;FC is the fill character.
268 N FILLEND,FILLLEN,HEAD,IC,LINELEN,PTEXT,TEXTLEN
269 S PTEXT=" "_TEXT_" "
270 S TEXTLEN=$L(PTEXT)
271 S LINELEN=IOM-(2*INDENT)
272 S FILLLEN=LINELEN-TEXTLEN
273 S FILLEND=INDENT+(FILLLEN\2)
274 I FILLLEN>1 D
275 .S HEAD=""
276 .F IC=INDENT:1:FILLEND D
277 .. S HEAD=HEAD_FC
278 .S HEAD=HEAD_PTEXT
279 .F IC=($L(HEAD)+1):1:LINELEN D
280 .. S HEAD=HEAD_FC
281 . W !,?INDENT,HEAD
282 E D
283 . S IC=(IOM-$L(TEXT))\2
284 . W !,?IC,TEXT
285 Q
286 ;
Note: See TracBrowser for help on using the repository browser.