source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

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