source: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGDRPC5.m@ 1671

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1MAGDRPC5 ;WOIFO/EdM - Routing RPCs ; 12/15/2006 13:50
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 ;
20START(OUT,LOCATION,RULES) ; RPC = MAG DICOM ROUTE EVAL START
21 N I,LOC,X,ZTDESC,ZTDTH,ZTRTN,ZTSAVE
22 ;
23 D XTINIT
24 ;
25 I '$G(LOCATION) S OUT="-1,No Location Specified" Q
26 I '$O(RULES("")) S OUT="-2,No Routing Rules Specified" Q
27 ;
28 S LOC=$$GET1^DIQ(4,LOCATION,.01)
29 L +^MAGDICOM(2006.563,1,"EVAL",LOCATION):0 E D Q
30 . S OUT="-3,A Rule Evaluator is Already Running for "_LOC
31 . Q
32 ;
33 S ^MAGDICOM(2006.563,1,"EVAL")=1
34 S ZTRTN="EVAL^MAGBRTE4"
35 S ZTDESC="Evaluate Routing Rules for Origin="_LOC
36 S ZTDTH=$H
37 S ZTSAVE("LOCATION")=LOCATION
38 S I="" F S I=$O(RULES(I)) Q:I="" S:+I=I ZTSAVE("RULES("_I_")")=RULES(I)
39 D ^%ZTLOAD,HOME^%ZIS
40 L -^MAGDICOM(2006.563,1,"EVAL",LOCATION)
41 I '$D(ZTSK) S OUT="-4,TaskMan did not Accept Request" Q
42 S OUT="0,TaskMan task#="_ZTSK
43 Q
44 ;
45STOP(OUT) ; RPC = MAG DICOM ROUTE EVAL STOP
46 S ^MAGDICOM(2006.563,1,"EVAL")=0,OUT=1
47 Q
48 ;
49XMIT(OUT,LOCATION,DEST,PRIOR,MECH,DESTS) ; RPC = MAG DICOM ROUTE NEXT FILE
50 N D0,DIR,DL,IM,M,OK,PLACE,TP,VP,X
51 ;
52 S PLACE=$$PLACE^MAGDRPC2(LOCATION)
53 S $P(^MAG(2006.1,PLACE,"LASTROUTE"),"^",1)=DT
54 ;
55 K OUT S OUT(1)=0,OK=0
56 S:'$G(MECH) MECH=1 I MECH'=1,MECH'=2 S MECH=1
57 I '$G(LOCATION) S OUT(1)="-1,No Location Specified" Q
58 S VP(1)=";MAG(2005.2,"
59 S VP(2)=";MAG(2006.587,"
60 S:$G(DEST) DEST=+DEST_VP(MECH)
61 S M="" F S M=$O(DESTS(M)) Q:M="" D
62 . S X=DESTS(M) Q:X'["^" Q:$P(X,"^",1)'=MECH Q:'$P(X,"^",2)
63 . S DL($P(X,"^",2)_VP(MECH))=""
64 . Q
65 I $O(DL(""))="" S OUT(1)="-2,No Valid Destinations Specified" Q
66 S:'$G(DEST) (PRIOR,DEST)=""
67 I $G(PRIOR) D
68 . I DEST S X=0 F D Q:X
69 . . N NXT
70 . . I $P($G(^MAG(2005.2,+DEST,0)),"^",6) S X=1 Q
71 . . D NOW^%DTC S %=%*1E6
72 . . S X=$P($G(^MAG(2005.2,+DEST,3)),"^",6)*1E6
73 . . I %-X>1500 D ONOFLINE(.X,+DEST,1) Q
74 . . S X=0,NXT=0
75 . . F S DEST=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST)) Q:DEST="" D Q:NXT
76 . . . S:$D(DL(DEST)) NXT=1
77 . . . Q
78 . . S:'DEST X=1
79 . . Q
80 . I 'DEST S (PRIOR,DEST)="" Q
81 . F D Q:OK
82 . . S D0=+$G(D0)
83 . . S D0=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST,D0))
84 . . I 'D0 S OK=1 Q
85 . . S M=$P($G(^MAGQUEUE(2006.035,D0,0)),"^",4) I M'=1,M'=2 S M=1
86 . . I M=MECH S OK=1 Q
87 . . S (PRIOR,DEST)=""
88 . . Q
89 . Q
90 I OK D:$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR))
91 . ;
92 . ; Ignore higher priority items for destinations that are not accessible
93 . ;
94 . N A,D,P,T,X
95 . S P=PRIOR F S P=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",P)) Q:'P D Q:'PRIOR
96 . . S D="" F S D=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",P,D)) Q:D="" D Q:'PRIOR
97 . . . ; Interrupt only if we're transmitting there
98 . . . Q:'$D(DL(D))
99 . . . ;
100 . . . D:'$P(^MAG(2005.2,+D,0),"^",6)
101 . . . . D NOW^%DTC S %=%*1E6
102 . . . . S X=$P($G(^MAG(2005.2,+D,3)),"^",6)*1E6 Q:%-X<1500
103 . . . . D ONOFLINE(.X,+D,1)
104 . . . . Q
105 . . . S:$P(^MAG(2005.2,+D,0),"^",6) PRIOR=0
106 . . . Q
107 . . Q
108 . Q
109 I '$G(PRIOR) F D Q:OK Q:'PRIOR
110 . S PRIOR=" " F S PRIOR=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR),-1) Q:'PRIOR D Q:OK
111 . . S DEST="" F S DEST=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST)) Q:DEST="" D:$D(DL(DEST)) Q:OK
112 . . . D:'$P(^MAG(2005.2,+DEST,0),"^",6)
113 . . . . D NOW^%DTC S %=%*1E6
114 . . . . S X=$P($G(^MAG(2005.2,+DEST,3)),"^",6)*1E6 Q:%-X<1500
115 . . . . D ONOFLINE(.X,+DEST,1)
116 . . . . Q
117 . . . Q:'$P(^MAG(2005.2,+DEST,0),"^",6)
118 . . . S D0="" F S D0=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST,D0)) Q:D0="" D Q:OK
119 . . . . S M=$P($G(^MAGQUEUE(2006.035,D0,0)),"^",4) I M'=1,M'=2 S M=1
120 . . . . I M=MECH S OK=1 Q
121 . . . . Q
122 . . . Q
123 . . Q
124 . Q
125 Q:'PRIOR
126 Q:'OK
127 I 'D0 S OUT(1)=0 Q ; All files transmitted
128 ;
129 S X=^MAGQUEUE(2006.035,D0,0),IM=$P(X,"^",1),TP=$P(X,"^",3)
130 I 'IM D STATUS(X,D0,"SENT",LOCATION) S OUT(1)=2 Q
131 S OUT(2)=+DEST,OUT(3)=PRIOR,OUT(4)=MECH,OUT(9)=D0
132 S X=$G(^MAG(2005.2,+DEST,2)),OUT(5)=$P(X,"^",1),OUT(6)=$P(X,"^",2)
133 D STATUS(X,D0,"SENDING",LOCATION)
134 S OUT(10)=$P(^MAG(2005.2,+DEST,0),"^",2)
135 S DIR=$P($G(^MAG(2005.2,+DEST,4)),"^",2)
136 S OUT(11)=$G(^MAG(2005.2,+DEST,3))
137 S OUT(12)=IM
138 S OUT(13)=$P($G(^MAGQUEUE(2006.035,D0,1)),"^",3)
139 S OUT(14)=$P($G(^MAG(2005.2,+DEST,1)),"^",7) S:OUT(14)="" OUT(14)="NONE"
140 D XMIT^MAGDRPC6 ; Routine grew over 10,000 characters
141 I MECH=2 S OUT(2)=OUT(2)_"^"_$P($G(^MAG(2006.587,+DEST,0)),"^",1)
142 Q
143 ;
144PURGE(OUT,LOCATION,DEST,MAX,DONE) ; RPC = MAG DICOM ROUTE GET PURGE
145 N D0,D1,FILE,FMFILE,I,LIMIT,MORE,NOW,RETAIN,STAMP,STATUS,X
146 ;
147 D NOW^%DTC S NOW=%
148 K OUT S OUT(1)=1
149 S:$D(^MAG(2005.2,DEST,0)) $P(^MAG(2005.2,DEST,3),"^",4)=DT
150 S X=^MAG(2005.2,DEST,3)
151 S RETAIN=$P(X,"^",1) S:RETAIN="" RETAIN=32 S:RETAIN<0 RETAIN=0
152 S LIMIT=$H-RETAIN
153 ;
154 S X=$G(DONE(1)),MORE="" S:$E(X,1)="^" MORE=$P(X,"^",4,6)
155 ;
156 S I="" F S I=$O(DONE(I)) Q:I="" D
157 . N D41,D61
158 . S X=$G(DONE(I))
159 . S D0=$P(X,"^",2),D41=$P(X,"^",3)
160 . S STAMP=$P(X,"^",4)
161 . Q:'D0 Q:'D41
162 . ; Just in case the image is being deleted as this purge is taking place
163 . F FMFILE=2005,2005.1 D
164 . . K ^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D41)
165 . . S D61=$P($G(^MAG(FMFILE,D0,4,D41,0)),"^",7)
166 . . K ^MAG(FMFILE,D0,4,"LOC",DEST,D41)
167 . . K ^MAG(FMFILE,D0,4,D41,0)
168 . . S:D61 $P(^MAG(FMFILE,D0,6,D61,0),"^",5)=NOW
169 . . Q
170 . S MORE=""
171 . Q
172 ;
173 D
174 . N %,%H,%I
175 . S %H=LIMIT D TT^%DTC S LIMIT=X
176 . Q
177 ;
178 S MAX=$G(MAX) S:MAX<1 MAX=100
179 F FMFILE=2005,2005.1 D Q:OUT(1)'<MAX
180 . S STAMP="" F S STAMP=$O(^MAG(FMFILE,"ROUTE",DEST,STAMP)) Q:STAMP="" Q:STAMP'<LIMIT D Q:OUT(1)'<MAX
181 . . S D0="" F S D0=$O(^MAG(FMFILE,"ROUTE",DEST,STAMP,D0)) Q:D0="" D Q:OUT(1)'<MAX
182 . . . S D1="" F S D1=$O(^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D1)) Q:D1="" D Q:OUT(1)'<MAX
183 . . . . I MORE'="",FMFILE_"^"_D0_"^"_D1'=MORE Q
184 . . . . S MORE=""
185 . . . . S FILE=$P($G(^MAG(FMFILE,D0,4,D1,0)),"^",4),STATUS=0
186 . . . . S:FILE="" FILE=$P($G(^MAG(2005.1,D0,4,D1,0)),"^",4)
187 . . . . I FILE="" D Q
188 . . . . . K ^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D1)
189 . . . . . K ^MAG(FMFILE,D0,4,"LOC",DEST,D1)
190 . . . . . K ^MAG(FMFILE,D0,4,D1,0)
191 . . . . . Q
192 . . . . S OUT(1)=OUT(1)+1,OUT(OUT(1))=FMFILE_"^"_D0_"^"_D1_"^"_STAMP_"^"_FILE
193 . . . . Q
194 . . . Q
195 . . Q
196 . Q
197 Q
198 ;
199STATUS(OUT,D0,STATUS,LOCATION) ; RPC = MAG DICOM ROUTE STATUS
200 ; D0 ------- Internal Entry Number of Send Queue Entry
201 ; STATUS --- New Status
202 N DEST ;---- Internal Entry Number of destination
203 N IMAGE ;--- Internal Entry Number of image
204 N OLD ;----- Old Status Value
205 N ORIGIN ;-- Origin of image
206 N PRIOR ;--- Priority
207 N TYPE ;---- File Type (Big, Text, DICOM, etc)
208 N X0,X1 ;--- Queue data
209 ;
210 I '$G(D0) S OUT="-1,Invalid queue identifier: """_$G(D0)_"""." Q
211 ;
212 S X0=$G(^MAGQUEUE(2006.035,D0,0))
213 S X1=$G(^MAGQUEUE(2006.035,D0,1))
214 S OUT=0
215 ;
216 S DEST=$P(X0,"^",2) Q:DEST=""
217 S PRIOR=$P(X1,"^",2) Q:PRIOR=""
218 S ORIGIN=$P(X0,"^",5)
219 S:'ORIGIN ORIGIN=$G(LOCATION) Q:'ORIGIN
220 S OLD=$P(X1,"^",1),IMAGE=$P(X0,"^",1),TYPE=$P(X0,"^",3)
221 ;
222 K:OLD'="" ^MAGQUEUE(2006.035,"DEST",DEST,OLD,IMAGE,TYPE,D0)
223 K:OLD'="" ^MAGQUEUE(2006.035,"STS",ORIGIN,OLD,PRIOR,DEST,D0)
224 Q:STATUS=""
225 S $P(^MAGQUEUE(2006.035,D0,0),"^",5)=ORIGIN
226 S $P(^MAGQUEUE(2006.035,D0,1),"^",1)=STATUS
227 S ^MAGQUEUE(2006.035,"DEST",DEST,STATUS,IMAGE,TYPE,D0)=""
228 S ^MAGQUEUE(2006.035,"STS",ORIGIN,STATUS,PRIOR,DEST,D0)=""
229 S OUT=1
230 Q
231 ;
232LISTDEST(OUT,LOCATION) ; RPC = MAG DICOM ROUTE LIST DESTI
233 N D0,F,I,X
234 ; Return list of possible routing destinations
235 K OUT
236 S I=1,D0=0 F S D0=$O(^MAG(2005.2,D0)) Q:'D0 D
237 . S X=$G(^MAG(2005.2,D0,0)) Q:'$P(X,"^",9)
238 . L +^MAGQUEUE("ROUTE",LOCATION,D0):0 S F='$T
239 . L:'F -^MAGQUEUE("ROUTE",LOCATION,D0)
240 . S I=I+1,OUT(I)=D0_"^"_F_"^"_$P(X,"^",1,2)
241 . Q
242 S OUT(1)=I-1
243 Q
244 ;
245LOCK(OUT,D0,LOCATION,PLUSMIN) ; RPC = MAG DICOM ROUTE LOCK TRANSMIT
246 S OUT=0
247 I $G(PLUSMIN) L +^MAGQUEUE("ROUTE",LOCATION,D0):0 S OUT=$T Q
248 L -^MAGQUEUE("ROUTE",LOCATION,D0) S OUT=2
249 Q
250 ;
251ONOFLINE(OUT,DEST,STATUS) ; RPC = MAG DICOM NETWORK STATUS
252 N NET
253 I '$G(DEST) S OUT="-1,No Network Location Specified" Q
254 S STATUS=''$G(STATUS)
255 S NET=$P($G(^MAG(2005.2,DEST,0)),"^",2)
256 K ^MAG(2005.2,"C",NET,0,DEST)
257 K ^MAG(2005.2,"C",NET,1,DEST)
258 S ^MAG(2005.2,"C",NET,STATUS,DEST)=""
259 S $P(^MAG(2005.2,DEST,0),"^",6)=STATUS
260 D NOW^%DTC
261 S $P(^MAG(2005.2,DEST,3),"^",6)=$S(STATUS:"",1:%)
262 S OUT=1
263 Q
264 ;
265XTINIT ;
266 D DT^DICRW
267 S X=$G(^XTMP("MAGEVAL",0))
268 S $P(X,"^",2)=DT
269 S $P(X,"^",3)="Routing Rule Evaluator Log - Can be purged at any time"
270 S ^XTMP("MAGEVAL",0)=X
271 Q
272 ;
Note: See TracBrowser for help on using the repository browser.