source: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGBRTE5.m@ 1746

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

WorldVistAEHR overlayed on FOIAVistA

File size: 6.0 KB
Line 
1MAGBRTE5 ;WOIFO/PMK - Background Routing - Load Balance ; 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 ;
20BALANCE(IMAGE,RULE) N %,D,DEST,PARENT,PRI,X
21 S PARENT=$P(^MAG(2005,IMAGE,0),"^",10) ; ~~~
22 D:'$D(^MAGRT(2006.5906,RULE,1,PARENT))
23 . N CP,M1,M2,MAX,B,E,L,RD,T
24 . ;
25 . L +^MAGRT(2006.5906,0):19 ; Background task must wait for lock
26 . ;
27 . ; Clean up old info
28 . ; Allow for a study to cross one day boundary,
29 . ; and remove everything that is older than a day.
30 . ;
31 . S RD=RDT-1 F S RD=$O(^MAGRT(2006.5906,"D",RD),-1) Q:'RD D
32 . . N DE,RU,PA
33 . . S DE="" F S DE=$O(^MAGRT(2006.5906,"D",RD,DE)) Q:DE="" D
34 . . . S RU="" F S RU=$O(^MAGRT(2006.5906,"D",RD,DE,RU)) Q:RU="" D
35 . . . . S PA="" F S PA=$O(^MAGRT(2006.5906,"D",RD,DE,RU,PA)) Q:PA="" D
36 . . . . . K ^MAGRT(2006.5906,"D",RD,DE,RU,PA)
37 . . . . . K ^MAGRT(2006.5906,RU,1,PA)
38 . . . . . S X=^MAGRT(2006.5906,RU,1,0)
39 . . . . . S $P(X,"^",4)=$P(X,"^",4)-1
40 . . . . . S ^MAGRT(2006.5906,RU,1,0)=X
41 . . . . . Q
42 . . . . Q
43 . . . Q
44 . . Q
45 . ;
46 . D:'$D(^MAGRT(2006.5906,RULE))
47 . . S X=$G(^MAGRT(2006.5906,0))
48 . . S $P(X,"^",1,2)="ROUTE LOAD BALANCE^2006.5906"
49 . . S:RULE>$P(X,"^",3) $P(X,"^",3)=RULE
50 . . S $P(X,"^",4)=$P(X,"^",4)+1
51 . . S:RULE>$P(X,"^",3) $P(X,"^",3)=RULE
52 . . S ^MAGRT(2006.5906,0)=X
53 . . S ^MAGRT(2006.5906,RULE,0)=RULE
54 . . Q
55 . ;
56 . M CP=^MAGRT(2006.5906,"D",RDT)
57 . S (B,DEST,L,M1,M2,MAX)=0
58 . F S DEST=$O(RULE(RULE,"ACTION",DEST)) Q:'DEST D
59 . . N I,T
60 . . S B=B+1,B(B)=DEST
61 . . S X=RULE(RULE,"ACTION",DEST)
62 . . S M(B)=$P(X,"^",2),MAX=MAX+M(B)
63 . . ; Don't exceed maximum number of studies per day days
64 . . S T=0,I="" F S I=$O(CP(DEST,I)) Q:I="" S T=T+1
65 . . I $P(X,"^",3),T'<$P(X,"^",3) S M2=M2+M(B),M(B)=-1,M1=M1+1
66 . . Q
67 . ; If one destination has reached its cap, redistribute...
68 . D:M1
69 . . N I,L,R
70 . . S R=M2#M1,L=0
71 . . F I=1:1:B S:M(I)>0 M(I)=M2\M1+M(I),L=I
72 . . S M(L)=M(L)+R
73 . . Q
74 . ;
75 . S X=$G(^MAGRT(2006.5906,RULE,2))
76 . ; X = LAST ^ TOTAL ^ COUNT(DEST) ^ COUNT(DEST) ^ ...
77 . F L=1:1:B S E(L)=+$P(X,"^",L+2)
78 . S L=$P(X,"^",1) F S L=L+1 S:L>B L=1 Q:E(L)<M(L)
79 . S T=$P(X,"^",2)+1,E(L)=E(L)+1,DEST=B(L)
80 . I T'<MAX S T=0 F L=1:1:B S E(L)=0
81 . S X=L_"^"_T F L=1:1:B S X=X_"^"_E(L)
82 . S ^MAGRT(2006.5906,RULE,2)=X
83 . ;
84 . ; Note: on consolidated sites 'origins' and 'destinations'
85 . ; matter even more than on non-consolidated ones.
86 . ; In the case of load-balancing, however, the 'destinations'
87 . ; part is taken care of by the balancing parameters, and the
88 . ; origin is moot, because each study has one (and only one)
89 . ; origin.
90 . ;
91 . D:'$D(^MAGRT(2006.5906,RULE,1,PARENT))
92 . . S X=$G(^MAGRT(2006.5906,RULE,1,0))
93 . . S $P(X,"^",1,2)="^2006.59061"
94 . . S:PARENT>$P(X,"^",3) $P(X,"^",3)=PARENT
95 . . S $P(X,"^",4)=$P(X,"^",4)+1
96 . . S ^MAGRT(2006.5906,RULE,1,0)=X
97 . . S ^MAGRT(2006.5906,RULE,1,PARENT,0)=PARENT_"^"_RDT_"^"_DEST
98 . . Q
99 . L -^MAGRT(2006.5906,0)
100 . Q
101 S DEST=$P(^MAGRT(2006.5906,RULE,1,PARENT,0),"^",3)
102 S X=$G(RULE(RULE,"ACTION",DEST))
103 I X="" S METMSG(0,"No location for rule "_RULE_", alternative "_DEST)="" Q
104 S X=$P(X,"^",1) Q:X="<LOCAL>"
105 S DEST=0
106 S D=0 F S D=$O(RULE(RULE,"ACTION",D)) Q:'D D Q:DEST
107 . Q:$P($G(RULE(RULE,"ACTION",D)),"^",1)'=X
108 . S DEST=D
109 . Q
110 I 'DEST S METMSG(0,"Cannot find location """_X_""".")="" Q
111 S ^MAGRT(2006.5906,"D",RDT,DEST,RULE,PARENT)=""
112 ;
113 ; Current version assumes that BALANCE means DOS-Copy, not DICOM...
114 D VALDEST^MAGDRPC1(.DEST,X)
115 D LOG^MAGBRTE4("Load-Balance Destination is "_X)
116 S PRI=$$PRI^MAGBRTE4($G(RULE(RULE,"PRIORITY")),IMAGE)
117 S VRS=$$VRS(VRS,$$SEND(IMAGE,DEST,PRI,1,LOCATION))
118 Q
119 ;
120VARNAME(F) ;
121 S F=$TR(F," !""#$%&'()*+,-./:;<=>?@[\]^_`{|}~","_________________________________")
122 F Q:F'["__" S F=$P(F,"__",1)_"_"_$P(F,"__",2,$L(F)+2)
123 F Q:$E(F,1)'="_" S F=$E(F,2,$L(F))
124 F Q:$E(F,$L(F))'="_" S F=$E(F,1,$L(F)-1)
125 S F=$TR(F,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
126 Q F
127 ;
128SEND(IMAGE,DEST,PRI,MECH,LOCATION) N D1,D2,IM,IMG,O,OUT,PRE,RADFN,RADTI,RACNI,RARPT,VRS,X
129 S VRS=$$VRS("",$$SEND^MAGBRTUT(IMAGE,DEST,PRI,MECH,LOCATION))
130 Q:$G(RULE(RULE,"PRIORSTUDY"))'="YES" VRS
131 Q:'$G(IMAGE) VRS
132 S X=$G(^MAG(2005,IMAGE,2))
133 I $P(X,"^",6)'=74 Q VRS
134 S RARPT=$P(X,"^",7) I 'RARPT Q VRS
135 S X=$G(^RARPT(RARPT,0)) ; IA # 1171
136 S RADFN=$P(X,"^",2),RADTI=9999999.9999-$P(X,"^",3),RACNI=$P(X,"^",4)
137 S:RACNI RACNI=$O(^RADPT(+RADFN,"DT",+RADTI,"P","B",RACNI,"")) ; IA # 1172
138 S PRE="A^"_RADFN_"^"_RADTI_"^"_RACNI_"^"_RARPT
139 D PRIOR1^MAGJEX2(.OUT,PRE)
140 S O=0 F S O=$O(OUT(O)) Q:O="" D
141 . S X=$G(OUT(O)) Q:'$P(X,"^",2)
142 . S X=$P(X,"|",2) Q:'X
143 . S RARPT=$P(X,"^",4) Q:'RARPT
144 . S D1=0 F S D1=$O(^RARPT(RARPT,2005,D1)) Q:'D1 D ; IA # 1171
145 . . S IM=+$G(^RARPT(RARPT,2005,D1,0)) Q:'IM ; IA # 1171
146 . . S D2=0 F S D2=$O(^MAG(2005,IM,1,D2)) Q:'D2 D
147 . . . S IMG=+$G(^MAG(2005,IM,1,D2,0)) Q:'IMG
148 . . . S VRS=$$VRS(VRS,$$SEND^MAGBRTUT(IMG,DEST,PRI,MECH,LOCATION))
149 . . . S METMSG(1,"SEND also image #"_IMG_" from prior study")=""
150 . . . Q
151 . . Q
152 . Q
153 Q VRS
154 ;
155VRS(OLD,NEW) N OUT
156 S OUT=""
157 S:OLD OUT=OLD_"^"
158 S:NEW OUT=OUT_NEW
159 F Q:OUT'["^^" S OUT=$P(OUT,"^^",1)_"^"_$P(OUT,"^^",2,$L(OUT)+2)
160 Q:$L(OUT)<100 OUT
161 Q $P(OUT,"^",1)_"^...^"_$P(OUT,"^",$L(OUT,"^"))
162 ;
Note: See TracBrowser for help on using the repository browser.