source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRPCA.m@ 841

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

initial load of WorldVistAEHR
File size: 8.0 KB
Line 
1PXRMRPCA ; SLC/PJH - Functions returning REMINDER data ;01/18/2005
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 Q
4 ;
5ALL(ORY) ;All active reminders
6 ;print name^ien
7 N ARR,DATA,NAME,ORREM,OCNT,SUB,USAGE
8 S ORREM=0
9 F S ORREM=$O(^PXD(811.9,ORREM)) Q:'ORREM D
10 .;Include only CPRS reminders
11 .S USAGE=$P($G(^PXD(811.9,ORREM,100)),U,4) I USAGE["L" Q
12 .I USAGE'["C",USAGE'["*" Q
13 .S DATA=$G(^PXD(811.9,ORREM,0)) Q:DATA=""
14 .;Skip inactive reminders
15 .I $P(DATA,U,6) Q
16 .;Skip reminders with no name
17 .S NAME=$P(DATA,U,3) I NAME="" Q
18 .;Sort by name
19 .S ARR(NAME_U_ORREM)=""
20 ; Build output arrray
21 S SUB="",OCNT=0
22 F S SUB=$O(ARR(SUB)) Q:SUB="" D
23 .S OCNT=OCNT+1
24 .S ORY(OCNT)=SUB
25 Q
26 ;
27APPL(ORY,ORPT,ORLOC) ;Applicable reminders for cover sheet
28 ;format file 811.9 ien^reminder print name^date due^last occur^prty^due.
29 N ORSRV,TMPLST,ERR,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT
30 N ORDUE,ORPRI,ORSTA,PASS
31 S ORJ=0
32 S ORSRV=$$GET1^DIQ(200,DUZ,29)
33 I ORLOC S PASS="USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
34 I 'ORLOC S PASS="USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
35 D GETLST^XPAR(.TMPLST,PASS,"ORQQPX SEARCH ITEMS","Q",.ERR) ; DBIA #3076
36 I ERR>0 S ORY(1)=U_"Error: "_$P(ERR,U,2) Q
37 D AVAL(.TMPLST,2) ;Evaluate reminders
38 Q
39 ;
40ALIST(ORY,ORPT,LIST) ;Evaluate specific reminders
41 N ORSRV,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT,ORLOC
42 N ORDUE,ORPRI,ORSTA
43 S ORJ=0
44 D AVAL(.LIST,1)
45 Q
46 ;
47AVAL(ARRAY,POS) ;Evaluate array of reminders
48 S ORI=0 F S ORI=$O(ARRAY(ORI)) Q:'ORI D
49 .S ORIEN=$P(ARRAY(ORI),U,POS)
50 .K ^TMP("PXRHM",$J)
51 . I $$INACTIVE^PXRM(ORIEN) Q
52 .;Evaluate reminder
53 .D MAIN^PXRM(ORPT,ORIEN,1,1)
54 .;Not applicable is default
55 .S ORDUE=2 D Q:ORTXT=""
56 ..S ORTXT="",ORTXT=$O(^TMP("PXRHM",$J,ORIEN,ORTXT)) Q:ORTXT=""
57 ..;Determine status
58 ..S ORX=^TMP("PXRHM",$J,ORIEN,ORTXT) Q:ORX=""
59 ..S ORSTA=$P(ORX,U)
60 ..;Ignore reminders that are not applicable
61 ..I (ORSTA=" ")!(ORSTA["NEVER")!(ORSTA="N/A") Q
62 ..;Differentiate due and applicable
63 ..S ORDUE=0 I ORSTA["DUE" S ORDUE=1
64 ..I ORSTA["ERROR" S ORDUE=3
65 ..I ORSTA["CNBD" S ORDUE=4
66 ..;Get next due and last done dates
67 ..S ORDUEDT=$P(ORX,U,2),ORLASTDT=$P(ORX,U,3)
68 ..S ORLASTDT=$S(+$G(ORLASTDT)>0:ORLASTDT,1:"") ;null if not a date
69 ..;Reminder priority
70 ..S ORPRI=$P($G(^PXD(811.9,ORIEN,0)),U,10)
71 ..;Default is 2 for medium
72 ..I ORPRI="" S ORPRI=2
73 ..S ORJ=ORJ+1
74 ..S ORY(ORJ)=ORIEN_U_ORTXT_U_ORDUEDT_U_ORLASTDT_U_ORPRI_U_ORDUE_U_$$DLG(ORIEN)_U_U_U_U_$$DLGWIPE(ORIEN)
75 .;Save not applicables also (IF a valid reminder)
76 .I ORDUE=2 D
77 ..S ORJ=ORJ+1
78 ..S ORY(ORJ)=ORIEN_U_ORTXT_U_U_U_U_ORDUE_U_$$DLG(ORIEN)_U_U_U_U_$$DLGWIPE(ORIEN)
79 K ^TMP("PXRHM",$J)
80 Q
81 ;
82CATEGORY(ORY,ORPT,ORLOC) ;Reminder Categories
83 ;type^name^ien^parent^child^etc
84 N ERR,IC,ORSRV,PASS,TEMPLST
85 ;Get user's service
86 ;S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
87 S ORSRV=$$GET1^DIQ(200,DUZ,29)
88 ;Build list of locations and services required
89 I ORLOC S PASS="USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
90 I 'ORLOC S PASS="USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
91 ;
92 ;Get list of categories from GUI parameters file
93 D GETLST^XPAR(.TMPLST,PASS,"PXRM CPRS LOOKUP CATEGORIES","Q",.ERR)
94 ;If error return error type
95 I ERR>0 S ORY(1)=U_"Error: "_$P(ERR,U,2) Q
96 ;
97 ;For each category build tree of reminders/subcategories
98 N CNT,LEVEL,ORCAT,UNIQ
99 S CNT="",IC=0,LEVEL=0,UNIQ=0
100 ;For each category in 'PXRM CPRS LOOKUP CATEGORIES'
101 F S CNT=$O(TMPLST(CNT)) Q:'CNT D
102 .;Get category ien
103 .S ORCAT=$P(TMPLST(CNT),U,2)
104 .;Update unique number
105 .S UNIQ=UNIQ+1
106 .;Add category and associated reminders/subcategories to output array
107 .D GETLST(0,ORCAT,0,UNIQ)
108 Q
109 ;
110DLG(REM) ;Dialog check
111 N DATA,DIEN,DOK
112 S DIEN=$P($G(^PXD(811.9,REM,51)),U) Q:'DIEN 0
113 S DATA=$G(^PXRMD(801.41,DIEN,0))
114 I $P(DATA,U,4)="R",$P(DATA,U,3)="" Q 1
115 Q 0
116 ;
117DLGWIPE(REM) ;Dialog check
118 N DATA,DIEN,DOK
119 S DIEN=$P($G(^PXD(811.9,REM,51)),U) Q:'DIEN 0
120 I $P($G(^PXRMD(801.41,DIEN,0)),U,17)=1 Q 1
121 Q 0
122 ;
123GETLST(D0,D1,LEVEL,PARENT) ;Add to output array
124 N DATA,NAME,ORREM,ORSCAT,PCAT,SEQ,SUB,TEMP,USAGE
125 ;Get category ien if this is a sub-category
126 S PCAT=0 I LEVEL>0 D Q:ORSCAT="" S UNIQ=UNIQ+1,PARENT=UNIQ
127 .S ORSCAT=$P($G(^PXRMD(811.7,D0,10,D1,0)),U),PCAT=PARENT
128 ;Otherwise use passed ien
129 I LEVEL=0 S ORSCAT=D1
130 ;Get category name
131 S NAME=$G(^PXRMD(811.7,ORSCAT,0)) I NAME="" Q
132 ;
133 ;Create category entry in output array
134 ;unique number^type^name^parent^reminder ien
135 ;
136 S IC=IC+1,ORY(IC)=PARENT_U_"C"_U_NAME_U_PCAT_U
137 ;Increment tab
138 S LEVEL=LEVEL+1
139 ;
140 ;Sort Reminders from this category into display sequence
141 S SUB=0 K TEMP
142 F S SUB=$O(^PXRMD(811.7,ORSCAT,2,SUB)) Q:SUB="" D
143 .S DATA=$G(^PXRMD(811.7,ORSCAT,2,SUB,0)) Q:DATA=""
144 .S ORREM=$P(DATA,U) Q:ORREM=""
145 .S SEQ=$P(DATA,U,2)_0
146 .;Skip inactive reminders
147 .S DATA=$G(^PXD(811.9,ORREM,0)) Q:DATA="" Q:$P(DATA,U,6)
148 .;Include only CPRS reminders
149 .S USAGE=$P($G(^PXD(811.9,ORREM,100)),U,4) I USAGE'["C",USAGE'["*" Q
150 .S NAME=$P(DATA,U) I NAME="" S NAME="Unknown"
151 .;or printname
152 .S NAME=$P(DATA,U,3)
153 .S TEMP(SEQ)=NAME_U_ORREM
154 ;
155 ;Re-save reminders in output array for display
156 ;unique number^type^name^parent^reminder ien
157 ;
158 S SEQ=""
159 F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
160 .S NAME=$P(TEMP(SEQ),U),ORREM=$P(TEMP(SEQ),U,2)
161 .S UNIQ=UNIQ+1
162 .S IC=IC+1,ORY(IC)=UNIQ_U_"R"_U_NAME_U_PARENT_U_ORREM_U_$$DLG(ORREM)
163 ;
164 ;Sort Sub-Categories for this category into display order
165 S SUB=0 K TEMP
166 F S SUB=$O(^PXRMD(811.7,ORSCAT,10,SUB)) Q:SUB="" D
167 .S DATA=$G(^PXRMD(811.7,ORSCAT,10,SUB,0)) Q:DATA=""
168 .S SEQ=$P(DATA,U,2),TEMP(SEQ)=SUB
169 ;
170 ;Process sub-sub categories in the same manner
171 S SEQ=""
172 F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
173 .S SUB=TEMP(SEQ)
174 .D GETLST(ORSCAT,SUB,LEVEL,PARENT)
175 Q
176 ;
177LIST(ORY,ORPT,ORLOC) ;Reminders for this patient location (not evaluated)
178 ;format file 811.9 ien
179 N ORSRV,TMPLST,ERR,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT
180 N CNT,ORIEN,ORDUE,ORPRI,ORSTA,PASS,SUB
181 S ORJ=0
182 ;
183 S ORSRV=$$GET1^DIQ(200,DUZ,29)
184 I ORLOC S PASS="USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
185 I 'ORLOC S PASS="USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
186 D GETLST^XPAR(.TMPLST,PASS,"ORQQPX SEARCH ITEMS","Q",.ERR) ; DBIA #3076
187 I ERR>0 S ORY(1)=U_"Error: "_$P(ERR,U,2) Q
188 ;
189 S CNT=0,SUB=""
190 F S SUB=$O(TMPLST(SUB)) Q:'SUB D
191 .S ORIEN=$P(TMPLST(SUB),U,2) Q:'ORIEN Q:'$D(^PXD(811.9,ORIEN,0))
192 .S CNT=CNT+1,ORY(CNT)=ORIEN
193 Q
194 ;
195REMDET(ORY,ORPT,ORIEN) ;return detail for a pt's clinical reminder
196 ; ORY - return array
197 ; ORPT - patient DFN
198 ; ORIEN - clinical reminder (811.9 ien)
199 K ^TMP("PXRHM",$J)
200 D MAIN^PXRM(ORPT,ORIEN,5,1) ; 5 returns all reminder info
201 N CR,I,J,ORTXT,SCT,STA,STA1,STA2,STA3 S I=1,J=0
202 S ORTXT="",ORTXT=$O(^TMP("PXRHM",$J,ORIEN,ORTXT)) Q:ORTXT=""
203 S STA=$G(^TMP("PXRHM",$J,ORIEN,ORTXT)) I STA'="" D
204 .S STA(1)=$P(STA,U),STA(2)=$P(STA,U,2),STA(3)=$P(STA,U,3)
205 .F SCT=1,2,3 I STA(SCT) S STA(SCT)=$$FMTE^XLFDT(STA(SCT),"5D")
206 .S ORY(I)=" --STATUS-- --DUE DATE-- --LAST DONE--",I=I+1
207 .S ORY(I)=$J(STA(1),10)_$J(STA(2),13)_$J(STA(3),14),I=I+1
208 F S J=$O(^TMP("PXRHM",$J,ORIEN,ORTXT,"TXT",J)) Q:J="" D
209 .S ORY(I)=^TMP("PXRHM",$J,ORIEN,ORTXT,"TXT",J),I=I+1
210 K ^TMP("PXRHM",$J)
211 Q
212 ;
213WEB(ORY,ORRM) ;web page call
214 ;web site description^address
215 N ADDR,CNT,DATA,DESC,LINE,SUB,TITLE,TXT,UNIQ
216 S DESC="",CNT=0,UNIQ=0
217 ;Get the reminder specific web sites in alpha order
218 I ORRM]"" D
219 .F S DESC=$O(^PXD(811.9,ORRM,50,"B",DESC)) Q:DESC="" D
220 ..S SUB=0
221 ..F S SUB=$O(^PXD(811.9,ORRM,50,"B",DESC,SUB)) Q:'SUB D
222 ...S ADDR=$P($G(^PXD(811.9,ORRM,50,SUB,0)),U) Q:ADDR=""
223 ...S TITLE=$P($G(^PXD(811.9,ORRM,50,SUB,0)),U,2)
224 ...S UNIQ=UNIQ+1,CNT=CNT+1,ORY(CNT)=1_U_UNIQ_U_ADDR_U_TITLE,LINE=0
225 ...F S LINE=$O(^PXD(811.9,ORRM,50,SUB,1,LINE)) Q:'LINE D
226 ....S TXT=$G(^PXD(811.9,ORRM,50,SUB,1,LINE,0)) Q:TXT=""
227 ....S CNT=CNT+1,ORY(CNT)=2_U_UNIQ_U_TXT
228 ;Get the general web sites in alpha order
229 F S DESC=$O(^PXRM(800,1,1,"B",DESC)) Q:DESC="" D
230 .S SUB=0
231 .F S SUB=$O(^PXRM(800,1,1,"B",DESC,SUB)) Q:'SUB D
232 ..S ADDR=$P($G(^PXRM(800,1,1,SUB,0)),U) Q:ADDR=""
233 ..S TITLE=$P($G(^PXRM(800,1,1,SUB,0)),U,2)
234 ..S UNIQ=UNIQ+1,CNT=CNT+1,ORY(CNT)=1_U_UNIQ_U_ADDR_U_TITLE,LINE=0
235 ..F S LINE=$O(^PXRM(800,1,1,SUB,1,LINE)) Q:'LINE D
236 ...S TXT=$G(^PXRM(800,1,1,SUB,1,LINE,0)) Q:TXT=""
237 ...S CNT=CNT+1,ORY(CNT)=2_U_UNIQ_U_TXT
238 Q
Note: See TracBrowser for help on using the repository browser.