source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPX.m@ 1765

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

initial load of FOIAVistA 6/30/08 version

File size: 8.8 KB
Line 
1ORQQPX ; SLC/JM - PCE and Reminder routines ;11/16/2004
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,184,187,190,226**;Dec 17, 1997
3 Q
4IMMLIST(ORY,ORPT) ;return pt's immunization list:
5 ;id^name^date/time^reaction^inverse d/t
6 I $L($T(IMMUN^PXRHS03))<1 S ORY(1)="^Immunizations not available." Q
7 K ^TMP("PXI",$J)
8 D IMMUN^PXRHS03(ORPT)
9 N ORI,IMM,IVDT,IEN,X
10 S ORI=0,IMM="",IVDT="",IEN=0
11 F S IMM=$O(^TMP("PXI",$J,IMM)) Q:IMM="" D
12 .F S IVDT=$O(^TMP("PXI",$J,IMM,IVDT)) Q:IVDT="" D
13 ..F S IEN=$O(^TMP("PXI",$J,IMM,IVDT,IEN)) Q:IEN<1 D
14 ...S ORI=ORI+1,X=$G(^TMP("PXI",$J,IMM,IVDT,IEN,0)) Q:'$L(X)
15 ...S ORY(ORI)=IEN_U_IMM_U_$P(X,U,3)
16 ...I $P(X,U,7)=1 S ORY(ORI)=ORY(ORI)_U_$P(X,U,6)_U_IVDT
17 ...E S ORY(ORI)=ORY(ORI)_U_U_IVDT
18 S:+$G(ORY(1))<1 ORY(1)="^No immunizations found.^2900101^^9999999"
19 K ^TMP("PXI",$J)
20 Q
21DETAIL(ORY,IMM) ; return detailed information for an immunization
22 S ORY(1)="Detailed information on immunizations is not available."
23 Q
24REMIND(ORY,ORPT) ;return pt's currently due PCE clinical reminders
25 ; in the format file 811.9 ien^reminder print name^date due^last occur.
26 N ORTMPLST,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT,ORLOC
27 S ORJ=0
28 ;
29 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
30 ;reliably determined, and many simultaneous outpt locations can occur):
31 I +$G(ORPT)>0 D
32 .N DFN S DFN=ORPT,VA200="" D OERR^VADPT
33 .I +$G(VAIN(4))>0 S ORLOC=+$G(^DIC(42,+$G(VAIN(4)),44))
34 .K VA200,VAIN
35 ;
36 D REMLIST(.ORTMPLST,$G(ORLOC))
37 ;D GETLST^XPAR(.ORTMPLST,"USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR)
38 ;I ORERR>0 S ORY(1)=U_"Error: "_$P(ORERR,U,2) Q
39 S ORI=0 F S ORI=$O(ORTMPLST(ORI)) Q:'ORI D
40 .S ORIEN=$P(ORTMPLST(ORI),U,2)
41 .K ^TMP("PXRHM",$J)
42 .N ORPRI,ORDUE,ORSTA
43 .D MAIN^PXRM(ORPT,ORIEN,0)
44 .S ORTXT="",ORTXT=$O(^TMP("PXRHM",$J,ORIEN,ORTXT)) Q:ORTXT="" D
45 ..S ORX=^TMP("PXRHM",$J,ORIEN,ORTXT)
46 ..S ORSTA=$P(ORX,U)
47 ..S ORDUEDT=$P(ORX,U,2),ORLASTDT=$P(ORX,U,3)
48 ..S ORLASTDT=$S(+$G(ORLASTDT)>0:ORLASTDT,1:"") ;null if not a date
49 ..S ORJ=ORJ+1
50 ..S ORDUE=$S(ORSTA["DUE":1,ORSTA["ERROR":3,ORSTA["CNBD":4,1:2)
51 ..I ORDUE'=2 D
52 ...S ORPRI=$P($G(^PXD(811.9,ORIEN,0)),U,10) I ORPRI="" S ORPRI=2
53 ...S ORY(ORJ)=ORIEN_U_ORTXT_U_ORDUEDT_U_ORLASTDT_U_ORPRI_U_ORDUE_U_$$DLG^PXRMRPCA(ORIEN)_U_U_U_U_$$DLGWIPE^PXRMRPCA(ORIEN)
54 ..I ORDUE=2 D
55 ...S ORY(ORJ)=ORIEN_U_ORTXT_U_U_U_U_ORDUE_U_$$DLG^PXRMRPCA(ORIEN)_U_U_U_U_$$DLGWIPE^PXRMRPCA(ORIEN)
56 .K ^TMP("PXRHM",$J)
57 Q
58REMDET(ORY,ORPT,ORIEN) ;return detail for a pt's clinical reminder
59 ; ORY - return array
60 ; ORPT - patient DFN
61 ; ORIEN - clinical reminder (811.9 ien)
62 K ^TMP("PXRHM",$J)
63 D MAIN^PXRM(ORPT,ORIEN,5) ; 5 returns all reminder info
64 N CR,I,J,ORTXT S I=1
65 S ORTXT="",ORTXT=$O(^TMP("PXRHM",$J,ORIEN,ORTXT)) Q:ORTXT="" D
66 .S J=0 F S J=$O(^TMP("PXRHM",$J,ORIEN,ORTXT,"TXT",J)) Q:J="" D
67 ..S ORY(I)=^TMP("PXRHM",$J,ORIEN,ORTXT,"TXT",J),I=I+1
68 K ^TMP("PXRHM",$J)
69 Q
70NEWACTIV(ORY) ;Return true if Interactive Reminders are active
71 S ORY=0
72 I $T(APPL^PXRMRPCA)'="",+$G(DUZ) D
73 . N SRV
74 . ;S SRV=$P($G(^VA(200,DUZ,5)),U)
75 . S SRV=$$GET1^DIQ(200,DUZ,29,"I")
76 . S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM GUI REMINDERS ACTIVE",1,"Q")
77 . I +ORY S ORY=1
78 . E S ORY=0
79 Q
80HISTLOC(LST) ;Returns a list of historical locations
81 N IDX,PTR,LINE,NAME
82 K ^TMP("OR",$J,"LOC")
83 S LST=$NA(^TMP("OR",$J,"LOC"))
84 S (LINE,IDX)=0
85 F S IDX=$O(^AUTTLOC(IDX)) Q:'IDX D
86 .S PTR=+$G(^AUTTLOC(IDX,0))
87 .I +PTR D
88 ..;S NAME=$P($G(^DIC(4,PTR,0)),U)
89 ..S NAME=$$GET1^DIQ(4,PTR,.01,"I")
90 ..I NAME'="" D
91 ...S LINE=LINE+1
92 ...S ^TMP("OR",$J,"LOC",LINE)=PTR_U_NAME
93 Q
94GETFLDRS(ORFLDRS) ;Return Visible Reminder Folders
95 ; Codes: D=Due, A=Applicable, N=Not Applicable, E=Evaluated, O=Other
96 N SRV,ORERR,ORTMP
97 ;S SRV=$P($G(^VA(200,DUZ,5)),U)
98 S SRV=$$GET1^DIQ(200,DUZ,29,"I")
99 D GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER FOLDERS","Q",.ORERR)
100 I +ORTMP S ORFLDRS=$P($G(ORTMP(1)),U,2)
101 E S ORFLDRS="DAO"
102 Q
103SETFLDRS(ORY,ORFLDRS) ;Sets Visible Reminder Folders for the current user
104 N ORERR
105 D EN^XPAR(DUZ_";VA(200,","ORQQPX REMINDER FOLDERS",1,ORFLDRS,.ORERR)
106 S ORY=1
107 Q
108GETDEFOL(ORDEFLOC) ;Return Default Outside Locations
109 N SRV,ORERR
110 ;S SRV=$P($G(^VA(200,DUZ,5)),U)
111 S SRV=$$GET1^DIQ(200,DUZ,29,"I")
112 D GETLST^XPAR(.ORDEFLOC,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX DEFAULT LOCATIONS","Q",.ORERR)
113 Q
114INSCURS(ORY) ; Returns status of ORQQPX REMINDER TEXT AT CURSOR
115 N SRV,ORERR,ORTMP
116 ;S ORY=0,SRV=$P($G(^VA(200,DUZ,5)),U)
117 S ORY=0,SRV=$$GET1^DIQ(200,DUZ,29,"I")
118 D GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER TEXT AT CURSOR","Q",.ORERR)
119 I +ORTMP S ORY=$P($G(ORTMP(1)),U,2)
120 Q
121NEWCVOK(ORY) ; Returns status of
122 N SRV,ORERR,ORTMP
123 ;S ORY=0,SRV=$P($G(^VA(200,DUZ,5)),U)
124 S ORY=0,SRV=$$GET1^DIQ(200,DUZ,29,"I")
125 D GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.ORERR)
126 I +ORTMP S ORY=$P($G(ORTMP(1)),U,2)
127 Q
128ADDNAME(ORX) ; Add Reminder or Category Name as 3rd piece
129 N CAT,IEN
130 S CAT=$E($P(ORX,U,2),2)
131 S IEN=$E($P(ORX,U,2),3,99)
132 I +IEN D
133 .I CAT="R" S $P(ORX,U,3)=$P($G(^PXD(811.9,IEN,0)),U,3)
134 .I CAT="C" S $P(ORX,U,3)=$P($G(^PXRMD(811.7,IEN,0)),U)
135 Q ORX
136REMACCUM(ORY,LVL,TYP,SORT,CLASS) ; Accumulates ORTMP into ORY
137 ; Format of entries in ORQQPX COVER SHEET REMINDERS:
138 ; L:Lock;R:Remove;N:Normal / C:Category;R:Reminder / Cat or Rem IEN
139 N IDX,I,J,K,M,FOUND,ORERR,ORTMP,FLAG,IEN
140 N FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
141 I LVL="CLASS" D I 1
142 .N ORLST,ORCLS,ORCLSPRM,ORWP
143 .S ORCLSPRM="ORQQPX COVER SHEET REM CLASSES"
144 .D GETLST^XPAR(.ORLST,"SYS",ORCLSPRM,"Q",.ORERR)
145 .S I=0,M=0,CLASS=$G(CLASS)
146 .F S I=$O(ORLST(I)) Q:'I D
147 ..S ORCLS=$P(ORLST(I),U,1)
148 ..I +CLASS S ADD=(ORCLS=+CLASS) I 1
149 ..E S ADD=$$ISA^USRLM(DUZ,ORCLS,.ORERR)
150 ..I +ADD D
151 ...D GETWP^XPAR(.ORWP,"SYS",ORCLSPRM,ORCLS,.ORERR)
152 ...S K=0
153 ...F S K=$O(ORWP(K)) Q:'K D
154 ....S M=M+1
155 ....S J=$P(ORWP(K,0),";",1)
156 ....S ORTMP(M)=J_U_$P(ORWP(K,0),";",2)
157 E D GETLST^XPAR(.ORTMP,LVL,"ORQQPX COVER SHEET REMINDERS",TYP,.ORERR)
158 S I=0,IDX=$O(ORY(999999),-1)+1,ADD=(SORT="")
159 F S I=$O(ORTMP(I)) Q:'I D
160 .S (FOUND,J)=0,P2=$P(ORTMP(I),U,2)
161 .S FLAG=$E(P2),IEN=$E(P2,2,999)
162 .I ADD S DOADD=1
163 .E D
164 ..S DOADD=0
165 ..F S J=$O(ORY(J)) Q:'J D Q:FOUND
166 ...S P2=$P(ORY(J),U,2)
167 ...S FIEN=$E(P2,2,999)
168 ...I FIEN=IEN S FOUND=J,FFLAG=$E(P2)
169 ..I FOUND D I 1
170 ...I FLAG="R",FFLAG'="L" K ORY(FOUND)
171 ...I FLAG'=FFLAG,(FLAG_FFLAG)["L" S $E(P2)="L",$P(ORY(FOUND),U,2)=P2
172 ..E I (FLAG'="R") S DOADD=1
173 .I DOADD D
174 ..S OUT(IDX)=ORTMP(I)
175 ..S $P(OUT(IDX),U)=$P(OUT(IDX),U)_SORT
176 ..I SORT="" S OUT(IDX)=$$ADDNAME(OUT(IDX))
177 ..S IDX=IDX+1
178 M ORY=OUT
179 Q
180ADDREM(ORY,IDX,IEN) ; Add Reminder to ORY list
181 I $D(ORY("B",IEN)) Q ; See if it's in the list
182 I '$D(^PXD(811.9,IEN)) Q ; Check if Exists
183 I $P($G(^PXD(811.9,IEN,0)),U,6)'="" Q ; Check if Active
184 ;check to see if the reminder is assigned to CPRS
185 I $P($G(^PXD(811.9,IEN,100)),U,4)["L" Q
186 I $P($G(^PXD(811.9,IEN,100)),U,4)'["C",$P($G(^PXD(811.9,IEN,100)),U,4)'="*" Q
187 S ORY(IDX)=IDX_U_IEN
188 S ORY("B",IEN)=""
189 Q
190ADDCAT(ORY,IDX,IEN) ; Add Category Reminders to ORY list
191 N ORREM,I,IDX2,NREM
192 D CATREM^PXRMAPI0(IEN,.ORREM)
193 S I=0
194 F S I=$O(ORREM(I)) Q:'I D
195 . S IDX2="00000"_I
196 . S IDX2=$E(IDX2,$L(IDX2)-5,99)
197 . D ADDREM(.ORY,+(IDX_"."_IDX2),$P(ORREM(I),U,1))
198 Q
199REMLIST(ORY,LOC) ;Returns a list of all cover sheet reminders
200 N SRV,I,J,ORLST,CODE,IDX,IEN,NEWP
201 ;S SRV=$P($G(^VA(200,DUZ,5)),U)
202 S SRV=$$GET1^DIQ(200,DUZ,29,"I")
203 D NEWCVOK(.NEWP)
204 I 'NEWP D GETLST^XPAR(.ORY,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR) Q
205 D REMACCUM(.ORLST,"PKG","Q",1000)
206 D REMACCUM(.ORLST,"SYS","Q",2000)
207 D REMACCUM(.ORLST,"DIV","Q",3000)
208 I +SRV D REMACCUM(.ORLST,"SRV.`"_+$G(SRV),"Q",4000)
209 I +LOC D REMACCUM(.ORLST,"LOC.`"_+$G(LOC),"Q",5000)
210 D REMACCUM(.ORLST,"CLASS","Q",6000)
211 D REMACCUM(.ORLST,"USR","Q",7000)
212 S I=0
213 F S I=$O(ORLST(I)) Q:'I D
214 .S IDX=$P(ORLST(I),U,1)
215 .F Q:'$D(ORY(IDX)) S IDX=IDX+1
216 .S CODE=$E($P(ORLST(I),U,2),2)
217 .S IEN=$E($P(ORLST(I),U,2),3,999)
218 .I CODE="R" D ADDREM(.ORY,IDX,IEN)
219 .I CODE="C" D ADDCAT(.ORY,IDX,IEN)
220 K ORY("B")
221 Q
222LVREMLST(ORY,LVL,CLASS) ;Returns cover sheet reminders at a specified level
223 D REMACCUM(.ORY,LVL,"Q","",$G(CLASS))
224 Q
225SAVELVL(ORY,LVL,CLASS,DATA) ;Save cover sheet reminders at a specified level
226 N ORERR,PARAM,I
227 I LVL="CLASS" D I 1
228 .S PARAM="ORQQPX COVER SHEET REM CLASSES"
229 .S LVL="SYS"
230 .D DEL^XPAR(LVL,PARAM,"`"_CLASS,.ORERR)
231 .D EN^XPAR(LVL,PARAM,"`"_CLASS,.DATA,.ORERR)
232 E D
233 .S PARAM="ORQQPX COVER SHEET REMINDERS"
234 .D NDEL^XPAR(LVL,PARAM,.ORERR)
235 .S I=0
236 .F S I=$O(DATA(I)) Q:'I D
237 ..D EN^XPAR(LVL,PARAM,$P(DATA(I),U,1),$P(DATA(I),U,2),.ORERR)
238 S ORY=1
239 Q
240GETLIST(ORY,ORLOC) ;Returns a list of all cover sheet reminders
241 N I
242 D REMLIST(.ORY,$G(ORLOC))
243 S I=0
244 F S I=$O(ORY(I)) Q:'I D
245 .S ORY(I)=$P(ORY(I),U,2)
246 Q
247EVALCOVR(ORY,ORPT,ORLOC) ; Evaluate Cover Sheet Reminders
248 N ORTMP
249 D GETLIST(.ORTMP,$G(ORLOC))
250 D ALIST^ORQQPXRM(.ORY,ORPT,.ORTMP)
251 Q
Note: See TracBrowser for help on using the repository browser.