source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLOGX.m@ 1361

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

initial load of WorldVistAEHR

File size: 9.1 KB
Line 
1PXRMLOGX ; SLC/PKR - Clinical Reminders logic cross-reference routines. ;08/29/2005
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ;==================
5BLDAFL(IEN,KI,NODEP) ;Build a list of findings that can change the
6 ;frequency age range set. This is called by FileMan whenever the
7 ;minimum age, maximum age, or frequency fields of the findings
8 ;multiple are edited.
9 ;Do not execute as part of a verify fields.
10 I $G(DIUTIL)="VERIFY FIELDS" Q
11 ;Do not execute as part of exchange.
12 I $G(PXRMEXCH) Q
13 N FREQ,FLIST,FTYPE,IND,OK,NODE,NUM,STARTCHK
14 S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
15 S FLIST="",OK=1,NUM=0
16 F NODE=20,25 D
17 . S FTYPE=$S(NODE=25:"FF",1:"")
18 . S IND=0
19 . F S IND=$O(^PXD(811.9,IEN,NODE,IND)) Q:+IND=0 D
20 ..;If an entry is being deleted skip it.
21 .. I IND=$G(KI),NODE=NODEP Q
22 .. S FREQ=$P(^PXD(811.9,IEN,NODE,IND,0),U,4)
23 .. I FREQ'="" D
24 ... S NUM=NUM+1
25 ... I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
26 ... I NUM>1 S FLIST=FLIST_";"
27 ... I OK S FLIST=FLIST_FTYPE_IND
28 S OK=$$CHKSLEN(FLIST,NUM_U)
29 I OK S ^PXD(811.9,IEN,40)=NUM_U_FLIST
30 E D
31 . S ^PXD(811.9,IEN,40)=-1
32 . D ERRMSG("age")
33 Q
34 ;
35 ;==================
36BLDALL(IEN,KI,NODEP) ;Build all the findings lists.
37 ;Do not execute as part of a verify fields.
38 I $G(DIUTIL)="VERIFY FIELDS" Q
39 ;Do not execute as part of exchange.
40 I $G(PXRMEXCH) Q
41 I '$D(^PXD(811.9,IEN)) Q
42 D BLDPCLS^PXRMLOGX(IEN,KI,NODEP)
43 D BLDRESLS^PXRMLOGX(IEN,KI,NODEP)
44 D BLDAFL^PXRMLOGX(IEN,KI,NODEP)
45 D BLDINFL^PXRMLOGX(IEN,KI,NODEP)
46 Q
47 ;
48 ;==================
49BLDINFL(IEN,KI,NODEP) ;Build the list of findings that are information only.
50 ;This is called by the routines that build the resolution findings
51 ;list, the patient cohort findings list, and the age finding list.
52 ;Do not execute as part of a verify fields.
53 I $G(DIUTIL)="VERIFY FIELDS" Q
54 ;Do not execute as part of exchange.
55 I $G(PXRMEXCH) Q
56 N FIA,FLIST,FTYPE,IND,NODE,NUM,OK,SUB,STARTCHK,TEMP
57 S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
58 F NODE=20,25 D
59 . S FTYPE=$S(NODE=25:"FF",1:"")
60 . S IND=0
61 . F S IND=$O(^PXD(811.9,IEN,NODE,IND)) Q:+IND=0 D
62 ..;If an entry is being deleted skip it.
63 .. I IND=$G(KI),NODE=NODEP Q
64 .. S SUB=FTYPE_IND
65 .. S FIA(SUB)=""
66 ;Remove the patient cohort findings.
67 S TEMP=$G(^PXD(811.9,IEN,32))
68 S NUM=+$P(TEMP,U,1)
69 S FLIST=$P(TEMP,U,2)
70 F IND=1:1:NUM D
71 . S TEMP=$P(FLIST,";",IND)
72 . I $D(FIA(TEMP)) K FIA(TEMP)
73 ;Remove the resolution findings.
74 S TEMP=$G(^PXD(811.9,IEN,36))
75 S NUM=+$P(TEMP,U,1)
76 S FLIST=$P(TEMP,U,2)
77 F IND=1:1:NUM D
78 . S TEMP=$P(FLIST,";",IND)
79 . I $D(FIA(TEMP)) K FIA(TEMP)
80 ;Remove the age findings.
81 S TEMP=$G(^PXD(811.9,IEN,40))
82 S NUM=+$P(TEMP,U,1)
83 S FLIST=$P(TEMP,U,2)
84 F IND=1:1:NUM D
85 . S TEMP=$P(FLIST,";",IND)
86 . I $D(FIA(TEMP)) K FIA(TEMP)
87 ;What is left is the information findings.
88 S FLIST="",OK=1
89 S (IND,NUM)=0
90 F S IND=$O(FIA(IND)) Q:IND="" D
91 . S NUM=NUM+1
92 . I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
93 . I NUM>1 S FLIST=FLIST_";"
94 . I OK S FLIST=FLIST_IND
95 S OK=$$CHKSLEN(FLIST,NUM_U)
96 I OK S ^PXD(811.9,IEN,42)=NUM_U_FLIST
97 E D
98 . S ^PXD(811.9,IEN,42)=-1
99 . D ERRMSG("information")
100 Q
101 ;
102 ;==================
103BLDPCLS(IEN,KI,NODEP) ;Build the Internal Patient Cohort Logic string for a
104 ;reminder. This is called by FileMan whenever the USE IN PATIENT COHORT
105 ;LOGIC field is edited or the user defined Patient Cohort Logic is
106 ;killed. Also builds the patient cohort logic list.
107 ;If there is a user defined PATIENT COHORT LOGIC then don't do anything.
108 ;Do not execute as part of a verify fields.
109 I $G(DIUTIL)="VERIFY FIELDS" Q
110 ;Do not execute as part of exchange.
111 I $G(PXRMEXCH) Q
112 I $L($G(^PXD(811.9,IEN,30)))>0 Q
113 N FLIST,FTYPE,IND,NODE,NUM,OK,PCLOG,STARTCHK,TEMP,UPCLOG
114 S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
115 S OK=1
116 S PCLOG="(SEX)&(AGE)"
117 S FLIST="SEX;AGE",NUM=2
118 F NODE=20,25 D
119 . S FTYPE=$S(NODE=20:"FI",NODE=25:"FF")
120 . S IND=0
121 . F S IND=$O(^PXD(811.9,IEN,NODE,IND)) Q:+IND=0 D
122 ..;If an entry is being deleted skip it.
123 .. I IND=$G(KI),NODE=NODEP Q
124 .. S TEMP=^PXD(811.9,IEN,NODE,IND,0)
125 .. S UPCLOG=$P(TEMP,U,7)
126 .. I UPCLOG'="" D
127 ... S PCLOG=PCLOG_UPCLOG_FTYPE_"("_IND_")"
128 ... S NUM=NUM+1
129 ... I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
130 ... I OK S FLIST=FLIST_";"_$S(NODE=25:"FF"_IND,1:IND)
131 ;Save the internal string and the findings list.
132 S OK=$$CHKSLEN(FLIST,NUM_U)
133 I OK D
134 . S ^PXD(811.9,IEN,31)=PCLOG
135 . S ^PXD(811.9,IEN,32)=NUM_U_FLIST
136 E D
137 . S ^PXD(811.9,IEN,32)=-1
138 . D ERRMSG("cohort")
139 Q
140 ;
141 ;==================
142BLDRESLS(IEN,KI,NODEP) ;Build the Internal Resolution Logic string for a
143 ;reminder. This is called by FileMan whenever the USE IN RESOLUTION
144 ;LOGIC field is edited or the user defined Resolution Logic is killed.
145 ;If there is a user defined RESOLUTION LOGIC then don't do
146 ;anything.
147 ;Do not execute as part of a verify fields.
148 I $G(DIUTIL)="VERIFY FIELDS" Q
149 ;Do not execute as part of exchange.
150 I $G(PXRMEXCH) Q
151 I $L($G(^PXD(811.9,IEN,34)))>0 Q
152 N FLIST,FTYPE,IND,NODE,NUM,OK,RESLOG,STARTCHK,TEMP,URESLOG
153 S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
154 S OK=1
155 S (FLIST,RESLOG)="",NUM=0
156 F NODE=20,25 D
157 . S FTYPE=$S(NODE=20:"FI",NODE=25:"FF")
158 . S IND=0
159 . F S IND=$O(^PXD(811.9,IEN,NODE,IND)) Q:+IND=0 D
160 ..;If an entry is being deleted skip it.
161 .. I IND=$G(KI),NODE=NODEP Q
162 .. S TEMP=^PXD(811.9,IEN,NODE,IND,0)
163 .. S URESLOG=$P(TEMP,U,6)
164 .. I URESLOG'="" D
165 ... S RESLOG=RESLOG_URESLOG_FTYPE_"("_IND_")"
166 ... S NUM=NUM+1
167 ... I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
168 ... I NUM>1 S FLIST=FLIST_";"
169 ... I OK S FLIST=FLIST_$S(NODE=25:"FF"_IND,1:IND)
170 ;Save as the internal string and the findings list.
171 I RESLOG="" S ^PXD(811.9,IEN,35)=""
172 E D
173 . S TEMP=$E(RESLOG,1,1)
174 . S RESLOG=$S(TEMP="&":"(1)",TEMP="!":"(0)",1:"")_RESLOG
175 . S ^PXD(811.9,IEN,35)=RESLOG
176 S OK=$$CHKSLEN(FLIST,NUM_U)
177 I OK S ^PXD(811.9,IEN,36)=NUM_U_FLIST
178 I 'OK D
179 . S ^PXD(811.9,IEN,36)=-1
180 . D ERRMSG("resolution")
181 ;Check the resolution logic to see if it can be satisfied solely
182 ;by function findings.
183 I NUM>0,FLIST["FF",RESLOG'="" D CRESLOG^PXRMFFDB(NUM,FLIST,RESLOG)
184 Q
185 ;
186 ;==================
187CHKSLEN(STRING,WORD) ;Determine if appending WORD to STRING will cause
188 ;string to exceed the maximum string length.
189 N MAXSLEN S MAXSLEN=512
190 I ($L(STRING)+$L(WORD))>MAXSLEN Q 0
191 Q 1
192 ;
193 ;==================
194CPPCLS(IEN,X) ;Copy the user input Patient Cohort Logic string to the
195 ;Internal Patient Cohort Logic string.
196 ;Do not execute as part of a verify fields.
197 I $G(DIUTIL)="VERIFY FIELDS" Q
198 ;Do not execute as part of exchange.
199 I $G(PXRMEXCH) Q
200 S ^PXD(811.9,IEN,31)=X
201 ;Get the list of findings.
202 N FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
203 S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
204 S OPER="'!&<>,",NUM=0,OK=1,FLIST=""
205 D POSTFIX^PXRMSTAC(X,OPER,.STACK)
206 F IND=1:1:STACK(0) D
207 . S T1=STACK(IND)
208 . I OPER[T1 Q
209 . I (T1="AGE")!(T1="SEX") D Q
210 .. I NUM>0 S FLIST=FLIST_";"
211 .. S NUM=NUM+1,FLIST=FLIST_T1
212 . I (T1="FF")!(T1="FI") D
213 .. S IND=IND+1
214 .. S T2=STACK(IND)
215 .. I NUM>0 S FLIST=FLIST_";"
216 .. S NUM=NUM+1
217 .. I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
218 .. I OK S FLIST=FLIST_$S(T1="FF":"FF"_T2,1:T2)
219 S OK=$$CHKSLEN(FLIST,NUM_U)
220 I OK S ^PXD(811.9,IEN,32)=NUM_U_FLIST
221 E D
222 . S ^PXD(811.9,IEN,32)=-1
223 . D ERRMSG("cohort")
224 Q
225 ;
226 ;==================
227CPRESLS(IEN,X) ;Copy the user input Resolution Logic string to the
228 ;Internal Resolution Logic string.
229 ;Do not execute as part of a verify fields.
230 I $G(DIUTIL)="VERIFY FIELDS" Q
231 ;Do not execute as part of exchange.
232 I $G(PXRMEXCH) Q
233 S ^PXD(811.9,IEN,35)=X
234 ;Build the list of findings
235 ;Get the list of findings.
236 N FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
237 S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
238 S OPER="'!&<>",OK=1,NUM=0,FLIST=""
239 D POSTFIX^PXRMSTAC(X,OPER,.STACK)
240 F IND=1:1:STACK(0) D
241 . S T1=STACK(IND)
242 . I OPER[T1 Q
243 . S IND=IND+1
244 . S T2=STACK(IND)
245 . S NUM=NUM+1
246 . I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
247 . I NUM>1 S FLIST=FLIST_";"
248 . I OK S FLIST=FLIST_$S(T1="FF":"FF"_T2,1:T2)
249 S OK=$$CHKSLEN(FLIST,NUM_U)
250 I OK D
251 . S ^PXD(811.9,IEN,36)=NUM_U_FLIST
252 .;Check the resolution logic to see if it can be satisfied solely
253 .;by function findings.
254 . I NUM>0,FLIST["FF",X'="" D CRESLOG^PXRMFFDB(NUM,FLIST,X)
255 I 'OK D
256 . S ^PXD(811.9,IEN,40)=-1
257 . D ERRMSG("resolution")
258 Q
259 ;
260 ;==================
261DELNXR(X2) ;For a new style cross-reference check X2 to determine
262 ;if a delete is being done. If it is a delete all the X2 elements will
263 ;be null.
264 N IND,X2NULL
265 S X2NULL=1
266 S IND=0
267 F S IND=$O(X2(IND)) Q:(+IND=0)!('X2NULL) D
268 . I X2(IND)'="" S X2NULL=0
269 Q X2NULL
270 ;
271 ;==================
272EDITNXR(X1,X2) ;For a new style cross-reference check X1 and X2 to determine
273 ;if an edit is being done.
274 N ADD,AREDIFF,EDIT,IND,X1NULL,X2NULL
275 S AREDIFF=0
276 S (X1NULL,X2NULL)=1
277 S IND=0
278 F S IND=$O(X1(IND)) Q:+IND=0 D
279 . I X1(IND)'="" S X1NULL=0
280 . I X2(IND)'="" S X2NULL=0
281 . I X1(IND)'=X2(IND) S AREDIFF=1
282 I X1NULL&'X2NULL S ADD=1
283 E S ADD=0
284 I 'X1NULL&'X2NULL&AREDIFF S EDIT=1
285 E S EDIT=0
286 Q (ADD!EDIT)
287 ;
288 ;==================
289ERRMSG(FTYPE) ;Display too many findings error message.
290 N TEXT
291 S TEXT(1)=" "
292 S TEXT(2)="Error - The number of "_FTYPE_" findings exceeds the maximum allowed!"
293 S TEXT(3)="The reminder will not function properly until some are removed."
294 S TEXT(4)=" "
295 D EN^DDIOL(.TEXT)
296 Q
297 ;
Note: See TracBrowser for help on using the repository browser.