source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGBRTE4.m@ 861

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

initial load of WorldVistAEHR
File size: 9.5 KB
Line 
1MAGBRTE4 ;WOIFO/EdM - Process Routing Rule Evaluation Queue ; 12/15/2006 13:49
2 ;;3.0;IMAGING;**11,30,51,85**;16-March-2007;;Build 1039
3 ;; Per VHA Directive 2004-038, this routine should not be modified.
4 ;; +---------------------------------------------------------------+
5 ;; | Property of the US Government. |
6 ;; | No permission to copy or redistribute this software is given. |
7 ;; | Use of unreleased versions of this software requires the user |
8 ;; | to execute a written test agreement with the VistA Imaging |
9 ;; | Development Office of the Department of Veterans Affairs, |
10 ;; | telephone (301) 734-0100. |
11 ;; | The Food and Drug Administration classifies this software as |
12 ;; | a medical device. As such, it may not be changed in any way. |
13 ;; | Modifications to this software may result in an adulterated |
14 ;; | medical device under 21CFR820, the use of which is considered |
15 ;; | to be a violation of US Federal Statutes. |
16 ;; +---------------------------------------------------------------+
17 ;;
18 Q
19 ;
20EVAL ;
21 N ACTIVE ;- Switch that controls start/stop queue processor
22 N ANY ;---- Flag: processed any rule
23 N CONS ;--- Switch that indicates whether or not site has "consolidated" code
24 N XMSG ;--- Message counter
25 ;
26 K ^XTMP("MAGEVAL",ZTSK)
27 D LOG("Started at "_$H)
28 S XMSG=1,CONS=$$CONSOLID^MAGBAPI()
29 S PLACE=$S(CONS:$O(^MAG(2006.1,"B",LOCATION,"")),1:1)
30 L +^MAGDICOM(2006.563,1,"EVAL",LOCATION):0 E D Q
31 . D LOG("A rule evaluator is already running for "_$$GET1^DIQ(4,LOCATION,.01))
32 . Q
33 S ^MAGDICOM(2006.563,1,"EVAL")=1
34 ;
35 S I="" F S I=$O(RULES(I)) Q:I="" D
36 . N D0,D1,D2,L,Q1
37 . S X=RULES(I),D0=$P(X,"^",1),Q1=$P(X,"^",2),L=$L(X,"^")
38 . I L=3 S RULE(D0,Q1)=$P(X,"^",3) Q
39 . I Q1="ACTION" S RULE(D0,Q1,$P(X,"^",3))=$P(X,"^",4,L) Q
40 . I Q1'="CONDITION" D LOG("Rule "_D0_" has a qualifier """_Q1_""".") Q
41 . I L=5 S RULE(D0,Q1,$P(X,"^",3),$P(X,"^",4))=$P(X,"^",5) Q
42 . S RULE(D0,Q1,$P(X,"^",3),$P(X,"^",4),$P(X,"^",6),$P(X,"^",5))=$P(X,"^",7)
43 . Q
44 K RULES
45 ;
46 S ACTIVE=1 F D Q:'ACTIVE
47 . S ANY=0
48 . S ACTIVE=+$G(^MAGDICOM(2006.563,1,"EVAL")) I 'ACTIVE D Q
49 . . D LOG("Stopped at "_$H)
50 . . Q
51 . D
52 . . N IMAGE,QPTR,QPTR2,STATUS,X
53 . . D:'CONS ADD^MAGBAPI(0,"EVAL")
54 . . D:CONS ADD^MAGBAPI(0,"EVAL",PLACE)
55 . . S QPTR2=$O(^MAGQUEUE(2006.031,"B","EVAL",""))
56 . . S QPTR=$S(QPTR2:$P(^MAGQUEUE(2006.031,QPTR2,0),"^",2),1:"")
57 . . ; Get next queue pointer value
58 . . S:'CONS QPTR=$O(^MAGQUEUE(2006.03,"B","EVAL",QPTR))
59 . . S:CONS QPTR=$O(^MAGQUEUE(2006.03,"C",PLACE,"EVAL",QPTR))
60 . . I QPTR="" Q ; Nothing to do
61 . . ;
62 . . S X=$G(^MAGQUEUE(2006.03,QPTR,0))
63 . . ; After an error, sometimes the entry is purged,
64 . . ; but the cross reference is still present.
65 . . ; In such a case, remove the cross reference.
66 . . I X="" D Q
67 . . . K:'CONS ^MAGQUEUE(2006.03,"B","EVAL",QPTR)
68 . . . K:CONS ^MAGQUEUE(2006.03,"C",PLACE,"EVAL",QPTR)
69 . . . Q
70 . . ;
71 . . S IMAGE=$P(X,"^",7),ANY=1
72 . . I IMAGE,$D(^MAG(2005,IMAGE,0)) D
73 . . . S STATUS=$$RULES() Q:STATUS'<0
74 . . . I STATUS["NO NETWORK LOCATION" D Q
75 . . . . D LOG("Image "_IMAGE_" has no files associated with it")
76 . . . . Q
77 . . . D LOG("*** EVAL queue error: "_STATUS_" ***")
78 . . . Q
79 . . K ^MAGQUEUE(2006.03,QPTR)
80 . . K:'CONS ^MAGQUEUE(2006.03,"B","EVAL",QPTR)
81 . . K:CONS ^MAGQUEUE(2006.03,"C",PLACE,"EVAL",QPTR)
82 . . S $P(^MAGQUEUE(2006.03,0),"^",4)=$P(^MAGQUEUE(2006.03,0),"^",4)-1
83 . . Q
84 . H:'ANY 1
85 . D:'$D(^XTMP("MAGEVAL",ZTSK)) XTINIT^MAGDRPC5,LOG("^XTMP was cleaned up.")
86 . Q
87 L -^MAGDICOM(2006.563,1,"EVAL",LOCATION)
88 Q
89 ;
90LOG(X) N D,H,I,M,T
91 S I=$O(^XTMP("MAGEVAL",ZTSK," "),-1)+1
92 S XMSG=$G(XMSG)+1 S:I>XMSG XMSG=I
93 S D=$P("Thu Fri Sat Sun Mon Tue Wed"," ",$H#7+1)
94 S T=$P($H,",",2),H=T\3600,M=T\60#60 S:H<10 H=0_H S:M<10 M=0_M
95 S ^XTMP("MAGEVAL",ZTSK,XMSG)=D_" "_H_":"_M_" "_X
96 Q
97 ;
98RULES() ; To be called from above
99 ; IMAGE ;---- IEN for image (2005)
100 ; LOCATION ;- Location from which queue entry originates
101 N ACTION ;--- Action to be taken (SEND)
102 N C ;-------- Loop-variable for looping through parameters and conditions
103 N D ;-------- Data type
104 N DS ;------- Data type enclosed in space-characters
105 N F ;-------- ...
106 N METMSG ;--- Message to be issued when rule is evaluated
107 N O ;-------- Operator
108 N OK ;------- Flag: indicates whether or not rule is met
109 N RDT ;------ Current date (don't use DT, process might run over midnight)
110 N V ;-------- Value for property as specified in rule
111 N VAL ;------ Actual value of property
112 N VRS ;------ String of Queue Entry numbers when rule(s) are met
113 N X ;-------- Scratch variable
114 ;
115 S VRS=""
116 ;
117 D KEYWORD^MAGBRTK
118 ;
119 D FILEFIND^MAGDFB(IMAGE,"FULL",0,0,.MAGFILE1)
120 Q:MAGFILE1<0 MAGFILE1
121 ;
122 S RULE=0 F S RULE=$O(RULE(RULE)) Q:'RULE D
123 . S METMSG=$G(RULE(RULE,"ACTION"))
124 . S X=" (",C=0 F S C=$O(RULE(RULE,"ACTION",C)) Q:'C D
125 . . S METMSG=METMSG_X_$G(RULE(RULE,"ACTION",C)),X=", "
126 . . Q
127 . S:X'=" (" METMSG=METMSG_")"
128 . S:METMSG="" METMSG="Rule #"_RULE
129 . S OK=1,C=0 F S C=$O(RULE(RULE,"CONDITION",C)) Q:'C D Q:'OK
130 . . S F=$G(RULE(RULE,"CONDITION",C,"KW")) Q:F=""
131 . . S X=$G(KEYWORD("CONDITION",F),"^DICOM^MAGBRTE3(F,""OUT"",.VAL)")
132 . . K VAL D @$P(X,"^",2,9)
133 . . ; If the field is not defined, the test passes...
134 . . Q:$D(VAL)'=1 ; We won't deal with multiple values just yet...
135 . . ;
136 . . S V=$G(RULE(RULE,"CONDITION",C,"VA"))
137 . . S D=$G(RULE(RULE,"CONDITION",C,"DT"))
138 . . S O=$G(RULE(RULE,"CONDITION",C,"OP"))
139 . . S:D="" D="S"
140 . . S DS=" "_D_" "
141 . . D:" S CS DS IS LO LT OB OW PN SH ST "[DS
142 . . . N WILD ;-- Wildcard to be matched
143 . . . S WILD=$$WLDMATCH(VAL,V)
144 . . . I O="=",'WILD S OK=0 Q
145 . . . I O="!=",WILD S OK=0 Q
146 . . . Q
147 . . D:" DT DA TM "[DS
148 . . . Q:O'="=" ; Only "within range" comparisons allowed currently
149 . . . ;
150 . . . N A ;--- Flag: indicates whether at least one time-frame matches
151 . . . N B ;--- Begin date/time
152 . . . N E ;--- End date/time
153 . . . N %H ;-- FileMan API parameter value -- date
154 . . . N I ;--- Loopcounter
155 . . . N M ;--- Date/time mask
156 . . . N N ;--- Loopcounter (time-frames)
157 . . . N %T ;-- FileMan internal variable
158 . . . N VV ;-- Actual value
159 . . . N WD ;-- Weekday
160 . . . N X1 ;-- FileMan API parameter value -- date
161 . . . N X2 ;-- FileMan API parameter value -- date
162 . . . ;
163 . . . ; convert the literal date/time field into the format for comparison
164 . . . S VV=VAL
165 . . . ;
166 . . . S (A,N)=0 F S N=$O(RULE(RULE,"CONDITION",C,"VA",N)) Q:'N D
167 . . . . N T,VB,VC,VE
168 . . . . S M=$G(RULE(RULE,"CONDITION",C,"VA",N,"M"))
169 . . . . S B=$G(RULE(RULE,"CONDITION",C,"VA",N,"B"))
170 . . . . S E=$G(RULE(RULE,"CONDITION",C,"VA",N,"E"))
171 . . . . S T=1
172 . . . . I $E(M,1,3)="HOL" S:$$GET1^DIQ(40.5,+$E(VV,5,11),.01)="" T=0 ; IA 10038
173 . . . . I $E(M,1,3)="DDD",$E(B,1,3)'=$E(VAL,1,3) S T=0
174 . . . . S (VB,VC,VE)=""
175 . . . . F I=4:1:$L(M) S:$E(M,I)?1U VC=VC_$E(VV,I),VB=VB_$E(B,I),VE=VE_$E(E,I)
176 . . . . S:VB>VC T=0
177 . . . . S:VE<VC T=0
178 . . . . S:T A=1
179 . . . . Q
180 . . . S:'A OK=0
181 . . . Q
182 . . Q
183 . S METMSG(OK,METMSG)=""
184 . D NOW^%DTC S RDT=%\1
185 . Q:'OK
186 . S ACTION=$G(RULE(RULE,"ACTION"))
187 . Q:ACTION=""
188 . I ACTION="SEND" D Q
189 . . N %,D,PRI,X
190 . . S X=$G(RULE(RULE,"ACTION",1))
191 . . I X="" S METMSG(0,"No location for rule "_RULE)="" Q
192 . . D VALDEST^MAGDRPC1(.D,X)
193 . . I D<0 S METMSG(0,"Cannot find location """_X_""".")="" Q
194 . . S PRI=$$PRI($G(RULE(RULE,"PRIORITY")),IMAGE)
195 . . S VRS=$$VRS^MAGBRTE5(VRS,$$SEND^MAGBRTE5(IMAGE,D,PRI,1,LOCATION))
196 . . Q
197 . I ACTION="DICOM" D Q
198 . . N %,D,PRI,X
199 . . S X=$G(RULE(RULE,"ACTION",1))
200 . . I X="" S METMSG(0,"No location for rule "_RULE)="" Q
201 . . S D=$O(^MAG(2006.587,"B",X,""))
202 . . I D="" S METMSG(0,"Cannot find location """_X_""".")="" Q
203 . . S PRI=$$PRI($G(RULE(RULE,"PRIORITY")),IMAGE)
204 . . S VRS=$$VRS^MAGBRTE5(VRS,$$SEND^MAGBRTE5(IMAGE,D,PRI,2,LOCATION))
205 . . Q
206 . I ACTION="BALANCE" D BALANCE^MAGBRTE5(IMAGE,.RULE) Q
207 . ;
208 . ; Other actions to be inserted here...
209 . ;
210 . Q
211 ;
212 ; Note: we may have:
213 ; Rule 1: If CR, send to XXX
214 ; Rule 2: If CT, send to XXX
215 ; For a CR, this would cause an entry of
216 ; METMSG(0,"SEND(XXX)") for rule 2
217 ; and an entry of
218 ; METMSG(1,"SEND(XXX)") for rule 1
219 ; and for a CT it would be the other way around.
220 ; So, first remove all "failed" entries that were successful
221 ; for a different rule.
222 ;
223 S X="" F S X=$O(METMSG(1,X)) Q:X="" D
224 . D LOG("Image "_IMAGE_": "_X)
225 . K METMSG(0,X)
226 . Q
227 S X="" F S X=$O(METMSG(0,X)) Q:X="" D
228 . D LOG("Image "_IMAGE_": Do not "_X)
229 . Q
230 Q VRS
231 ;
232 ;
233PRI(PRI,IMAGE) N C,D0,D1,D2,O,P,R,X
234 S PRI=$S(PRI="HIGH":750,PRI="NORMAL":500,PRI="LOW":250,1:500)
235 S X=$G(^MAG(2005,IMAGE,2))
236 S P=$P(X,"^",6) Q:P'=74 PRI
237 S R=$P(X,"^",7) Q:'R PRI
238 S C=$P($G(^RARPT(R,0)),"^",1) Q:C="" PRI ; IA 1171
239 S D0=$O(^RADPT("ADC",C,"")) Q:'D0 PRI ; IA 1172
240 S D1=$O(^RADPT("ADC",C,D0,"")) Q:'D1 PRI ; IA 1172
241 S D2=$O(^RADPT("ADC",C,D0,D1,"")) Q:'D2 PRI ; IA 1172
242 S O=$P($G(^RADPT(D0,"DT",D1,"P",D2,0)),"^",11) Q:'O PRI ; IA 1172
243 S X=$P($G(^RAO(75.1,O,0)),"^",6) ; IA 3074
244 Q PRI+$S(X=1:20,X=2:10,1:0)
245 ;
246WLDMATCH(VAL,WILD) ;
247 ;
248 ; Returns true if VAL=WILD (Val=Actual value, Wild=Wildcard)
249 ;
250 ; Wild characters are:
251 ; ? matches any single character
252 ; * matches any string of characters
253 ;
254 N I,M
255 F Q:VAL="" Q:WILD="" D
256 . I $E(VAL,1)=$E(WILD,1) S VAL=$E(VAL,2,$L(VAL)),WILD=$E(WILD,2,$L(WILD)) Q
257 . I $E(WILD,1)="?" S VAL=$E(VAL,2,$L(VAL)),WILD=$E(WILD,2,$L(WILD)) Q
258 . I $E(WILD,1)="*" D Q:M
259 . . I WILD="*" S (VAL,WILD)="",M=1 Q
260 . . S WILD=$E(WILD,2,$L(WILD)),M=0
261 . . F I=1:1:$L(VAL) I $$WLDMATCH($E(VAL,I,$L(VAL)),WILD) S M=1,VAL=$E(VAL,I,$L(VAL)) Q
262 . . Q
263 . S VAL="!",WILD=""
264 . Q
265 Q:VAL'="" 0 Q:WILD'="" 0 Q 1
266 ;
Note: See TracBrowser for help on using the repository browser.