source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m@ 1250

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1PXRMLOCF ; SLC/PKR - Handle location findings. ;10/11/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;This routine is for location list patient findings.
4 ;=================================================
5ALL(FILENUM,DFN,PFINDPA,FIEVAL) ;Get all Visits with a location
6 ;for a patient.
7 N BDT,BTIME,CASESEN,COND,CONVAL,DAS,DATE,DEND,DONE,DS,EDT,FIEVD
8 N ICOND,INVBD,INVDATE,INVDT,INVED,NFOUND,NOCC
9 N SAVE,SDIR,TEMP,TIME,UCIFS
10 ;Set the finding search parameters.
11 D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
12 S SDIR=$S(NOCC<0:-1,1:1)
13 S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
14 D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
15 S (DONE,NFOUND)=0
16 S DEND=$S(EDT[".":EDT,1:EDT+.235959)
17 S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
18 S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
19 I SDIR=1 S DS=INVED-.000001
20 I SDIR=-1 S DS=INVBD+.000001
21 S INVDT=DS,(DONE,NFOUND)=0
22 ;DBIA 2028
23 F S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(DONE)!(INVDT="") D
24 . S INVDATE=$P(INVDT,".",1)
25 . I (SDIR=1),INVDATE>INVBD S DONE=1 Q
26 . I (SDIR=-1),INVDATE<INVED S DONE=1 Q
27 . S TIME="."_$P(INVDT,".",2)
28 . I INVDATE=INVED,TIME>ETIME Q
29 . I INVDATE=INVBD,TIME<BTIME Q
30 . S DAS=0
31 . F S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE) D
32 .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
33 .. S CONVAL=$S(COND="":1,1:$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD))
34 .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
35 .. I SAVE D
36 ... S TEMP=^AUPNVSIT(DAS,0)
37 ... S NFOUND=NFOUND+1
38 ... S FIEVAL(NFOUND)=CONVAL
39 ... I COND'="" S FIEVAL(NFOUND,"CONDITION")=CONVAL
40 ... S FIEVAL(NFOUND,"DAS")=DAS
41 ... S FIEVAL(NFOUND,"DATE")=$P(TEMP,U,1)
42 ... M FIEVAL(NFOUND)=FIEVD
43 ... I $G(PXRMDEBG) M FIEVAL(NFOUND,"CSUB")=FIEVD
44 ... I NFOUND=NOCC S DONE=1
45 ;Save the finding result.
46 D SFRES^PXRMUTIL(-SDIR,NFOUND,.FIEVAL)
47 S FIEVAL("FILE NUMBER")=FILENUM
48 Q
49 ;
50 ;=================================================
51EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate location findings.
52 N BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM
53 S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
54 S ITEM=""
55 F S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0 D
56 . S FINDING=""
57 . F S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0 D
58 .. K FINDPA
59 .. M FINDPA=DEFARR(20,FINDING)
60 .. K FIEVT
61 .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT)
62 .. M FIEVAL(FINDING)=FIEVT
63 .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
64 Q
65 ;
66 ;=================================================
67EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate location terms.
68 N FIEVT,FILENUM,ITEM,PFINDPA
69 N TEMP,TFINDING,TFINDPA
70 S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
71 S ITEM=""
72 F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D
73 . S TFINDING=""
74 . F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D
75 .. K FIEVT,PFINDPA,TFINDPA
76 .. M TFINDPA=TERMARR(20,TFINDING)
77 ..;Set the finding parameters.
78 .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
79 .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)
80 .. M TFIEVAL(TFINDING)=FIEVT
81 .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
82 Q
83 ;
84 ;=================================================
85FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) ;
86 ;Evaluate regular patient findings.
87 N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,FIEVD,FLIST,HLOC
88 N ICOND,IND,LNAME,NFOUND,NGET,NOCC,NP
89 N SAVE,SDIR,STATUSA,TEMP,UCIFS,VSLIST
90 S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)
91 I LNAME="VA-ALL LOCATIONS" D ALL(FILENUM,DFN,.PFINDPA,.FIEVAL) Q
92 ;Set the finding search parameters.
93 D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
94 S SDIR=$S(NOCC<0:-1,1:1)
95 D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
96 S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
97 S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
98 ;Get a list of unique locations.
99 D LOCLIST(ITEM,"HLOCL")
100 D FPDAT(DFN,"HLOCL",NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
101 I NFOUND=0 S FIEVAL=0 Q
102 S NP=0
103 F IND=1:1:NFOUND Q:NP=NOCC D
104 . S DAS=$P(FLIST(IND),U,1)
105 . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
106 . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
107 . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
108 . I SAVE D
109 .. S NP=NP+1
110 .. S FIEVAL(NP)=CONVAL
111 .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
112 .. S FIEVAL(NP,"DAS")=$P(FLIST(IND),U,1)
113 .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2)
114 .. M FIEVAL(NP)=FIEVD
115 .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVD
116 ;
117 ;Save the finding result.
118 D SFRES^PXRMUTIL(NOCC,NP,.FIEVAL)
119 S FIEVAL("FILE NUMBER")=FILENUM
120 Q
121 ;
122 ;=================================================
123FPDAT(DFN,HLOCL,NOCC,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient data for
124 ;visits at a specified hospital location. Return up to NOCC most
125 ;recent entries in FLIST where FLIST(1) is the most recent.
126 ;"AA" in Visit file is inverse date_.time instead of a full inverse
127 ;date and time. For example if the date/time is 3030704.104449 then
128 ;"AA" has 6969295.104449 instead of 6969295.89555
129 N BTIME,DAS,DATE,DEND,DLIST,DONE,DS,ETIME,HLOC
130 N INVBD,INVDATE,INVDT,INVED,NF,TEMP,TIME
131 S DEND=$S(EDT[".":EDT,1:EDT+.235959)
132 S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
133 S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
134 I SDIR=1 S DS=INVED-.000001
135 I SDIR=-1 S DS=INVBD+.000001
136 ;DBIA #2028
137 S INVDT=DS,(DONE,NFOUND)=0
138 F S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(INVDT="")!(DONE) D
139 . S NF=0
140 . S INVDATE=$P(INVDT,".",1)
141 . I (SDIR=1),INVDATE>INVBD S DONE=1 Q
142 . I (SDIR=-1),INVDATE<INVED S DONE=1 Q
143 . S TIME="."_$P(INVDT,".",2)
144 . I INVDATE=INVED,TIME>ETIME Q
145 . I INVDATE=INVBD,TIME<BTIME Q
146 . S DAS=0
147 . F S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE) D
148 .. S TEMP=^AUPNVSIT(DAS,0)
149 .. S HLOC=$P(TEMP,U,22)
150 .. I HLOC="" Q
151 .. I '$D(^TMP($J,HLOCL,HLOC)) Q
152 ..;Check the associated appointment for a valid status.
153 .. I '$$VAPSTAT^PXRMVSIT(DAS) Q
154 .. S DATE=$P(TEMP,U,1)
155 .. S NF=NF+1,NFOUND=NFOUND+1
156 .. I NFOUND=NOCC S DONE=1
157 .. S DLIST(INVDT,NF)=DAS_U_DATE
158 S INVDT="",NFOUND=0
159 F S INVDT=$O(DLIST(INVDT)) Q:INVDT="" D
160 . S NF=0
161 . F S NF=$O(DLIST(INVDT,NF)) Q:NF="" D
162 .. S NFOUND=NFOUND+1
163 .. S FLIST(NFOUND)=DLIST(INVDT,NF)
164 K ^TMP($J,"HLOCL")
165 Q
166 ;
167 ;=================================================
168LOCLIST(ITEM,SUB) ;Build a list of unique locations based on stop code
169 ;and/or hospital location. Reads of ^SC covered by DBIA #4482.
170 N CS,EXCL,IND,JND,HLOC,SC
171 K ^TMP($J,SUB)
172 ;Process stop codes. EXCL is the list of credit stops to exclude.
173 S IND=0
174 F S IND=+$O(^PXRMD(810.9,ITEM,40.7,IND)) Q:IND=0 D
175 . S SC=$P(^PXRMD(810.9,ITEM,40.7,IND,0),U,1)
176 . K EXCL
177 . S JND=0
178 . F S JND=+$O(^PXRMD(810.9,ITEM,40.7,IND,1,JND)) Q:JND=0 D
179 .. S EXCL=^PXRMD(810.9,ITEM,40.7,IND,1,JND,0)
180 .. S EXCL(EXCL)=""
181 . S HLOC=""
182 . F S HLOC=$O(^SC("AST",SC,HLOC)) Q:HLOC="" D
183 .. ;See if there are any to exclude.
184 .. S CS=$P(^SC(HLOC,0),U,18)
185 .. I CS'="",$D(EXCL(CS)) Q
186 .. S ^TMP($J,SUB,HLOC)=""
187 ;Process locations.
188 S IND=0
189 F S IND=+$O(^PXRMD(810.9,ITEM,44,IND)) Q:IND=0 D
190 . S HLOC=^PXRMD(810.9,ITEM,44,IND,0)
191 . S ^TMP($J,SUB,HLOC)=""
192 Q
193 ;
194 ;=================================================
195MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
196 ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)
197 N HLOC,IND,JND,LOC,NAME,NIN,NOUT,SC,TEMP,TEXTIN,TEXTOUT,VDATE
198 S NAME="Outpatient Encounter = "
199 S IND=0
200 F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
201 . S NIN=0
202 . S VDATE=IFIEVAL(IND,"DATE")
203 . S LOC=$G(IFIEVAL(IND,"LOC. OF ENCOUNTER"))
204 . S LOC=$S(LOC="":"?",1:$P($G(^DIC(4,LOC,0)),U,1))
205 . S SC=$G(IFIEVAL(IND,"DSS ID"))
206 . S SC=$S(SC="":"?",1:" "_$P($G(^DIC(40.7,SC,0)),U,1))
207 . S HLOC=$G(IFIEVAL(IND,"HOSPITAL LOCATION"))
208 . S HLOC=$S(HLOC="":"?",1:" "_$P($G(^SC(HLOC,0)),U,1))
209 . S TEMP=NAME_LOC_HLOC_SC_" ("_$$EDATE^PXRMDATE(VDATE)_")"
210 . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
211 . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
212 S NLINES=NLINES+1,TEXT(NLINES)=""
213 Q
214 ;
215 ;=================================================
216OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
217 ;maintenance output.
218 ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)
219 N EM,HLOC,IND,JND,LOC,NIN,NOUT,SC,STATUS,TEMP,TEXTIN,TEXTOUT,VDATE
220 S NLINES=NLINES+1
221 S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"PCE Encounter:"
222 S IND=0
223 F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
224 . S NIN=0
225 . S VDATE=IFIEVAL(IND,"DATE")
226 . S TEMP=$$EDATE^PXRMDATE(VDATE)
227 . S LOC=$G(IFIEVAL(IND,"LOC. OF ENCOUNTER"))
228 . S LOC=$S(LOC="":"?",1:$P($G(^DIC(4,LOC,0)),U,1))
229 . S TEMP=TEMP_" Facility - "_LOC
230 . D FORMATS^PXRMTEXT(INDENT+1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
231 . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
232 . S HLOC=$G(IFIEVAL(IND,"HLOC"))
233 . I HLOC="" S HLOC="?"
234 . S TEMP="Hospital Location: "_HLOC
235 . S SC=$G(IFIEVAL(IND,"STOP CODE"))
236 . I SC="" S SC="?"
237 . S TEMP=TEMP_"; Clinic Stop: "_SC
238 . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"
239 . S SC=$G(IFIEVAL(IND,"SERVICE CATEGORY"))
240 . S TEMP="Service Category: "_SC_"="_$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM)
241 . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"
242 . S STATUS=$P($G(IFIEVAL(IND,"STATUS")),U,2)
243 . I STATUS="" S STATUS="?"
244 . S TEMP="Appointment Status: "_STATUS
245 . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"
246 . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)
247 . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
248 . I IFIEVAL(IND,"COMMENTS")'="" D
249 .. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
250 .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
251 .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
252 S NLINES=NLINES+1,TEXT(NLINES)=""
253 Q
254 ;
Note: See TracBrowser for help on using the repository browser.