source: FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGDRPC1.m@ 1154

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

initial load of FOIAVistA 6/30/08 version
File size: 7.9 KB
Line 
1MAGDRPC1 ;WOIFO/EdM - Imaging RPCs ; 01/09/2006 07:41
2 ;;3.0;IMAGING;**11,30,51,50**;26-May-2006
3 ;; +---------------------------------------------------------------+
4 ;; | Property of the US Government. |
5 ;; | No permission to copy or redistribute this software is given. |
6 ;; | Use of unreleased versions of this software requires the user |
7 ;; | to execute a written test agreement with the VistA Imaging |
8 ;; | Development Office of the Department of Veterans Affairs, |
9 ;; | telephone (301) 734-0100. |
10 ;; | |
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 ;
20CHECKID(OUT,ID,HOSTNAME) ; RPC = MAG DICOM CHECK MACHINE ID
21 N D0,H0,I0,N,NH,NI,S,X
22 S OUT=0,ID=$GET(ID)
23 I $G(HOSTNAME)="" S OUT="-1,No Hostname Specified" Q
24 I ID'?1U S OUT="-2,No valid ID specified ("""_ID_""")" Q
25 S (NH,NI)=0
26 S D0="" F S D0=$O(^MAGDICOM(2006.5641,"B",ID,D0)) Q:D0="" S NI=NI+1,I0=D0
27 S D0="" F S D0=$O(^MAGDICOM(2006.5641,"C",HOSTNAME,D0)) Q:D0="" S NH=NH+1,H0=D0
28 I NH=1,NI=1,I0=H0 S OUT=1 Q ; This ID belongs to this hostname
29 I 'NI S OUT=1 Q ; This ID is still unused
30 S OUT="-1,Machine ID """_ID_""" is already used by",S=" "
31 S D0="" F S D0=$O(^MAGDICOM(2006.5641,"B",ID,D0)) Q:D0="" D
32 . I S=", ",$O(^MAGDICOM(2006.5641,"B",ID,D0))="" S S=" and "
33 . S X=$P($G(^MAGDICOM(2006.5641,D0,0)),"^",2)
34 . S OUT=OUT_S_""""_X_"""",S=", "
35 . Q
36 S OUT=OUT_"."
37 Q
38 ;
39UPDTID(OUT,ID,HOSTNAME) ; RPC = MAG DICOM UPDATE MACHINE ID
40 N D0,I,N,X
41 I $G(HOSTNAME)="" S OUT="-1,No Hostname Specified" Q
42 I $G(ID)'?1U S OUT="-2,No valid ID specified ("""_$G(ID)_""")" Q
43 L +^MAGDICOM(2006.5641,0):1E9 ; Background process MUST wait
44 S N=0,D0="" F S D0=$O(^MAGDICOM(2006.5641,"C",HOSTNAME,D0)) Q:D0="" D
45 . S X=$G(^MAGDICOM(2006.5641,D0,0)),N=N+1
46 . D:N=1
47 . . S I=$P(X,"^",1) I I'="" K ^MAGDICOM(2006.5641,"B",I,D0)
48 . . S $P(X,"^",1)=ID,$P(X,"^",2)=HOSTNAME,$P(X,"^",3)=$H
49 . . S ^MAGDICOM(2006.5641,D0,0)=X
50 . . S ^MAGDICOM(2006.5641,"B",ID,D0)=""
51 . . S ^MAGDICOM(2006.5641,"C",HOSTNAME,D0)=""
52 . . Q
53 . D:N>1
54 . . S I=$P(X,"^",1) I I'="" K ^MAGDICOM(2006.5641,"B",I,D0)
55 . . K ^MAGDICOM(2006.5641,"C",HOSTNAME,D0)
56 . . K ^MAGDICOM(2006.5641,D0)
57 . . Q
58 . Q
59 D:'N
60 . S D0=$O(^MAGDICOM(2006.5641," "),-1)+1
61 . S ^MAGDICOM(2006.5641,D0,0)=ID_"^"_HOSTNAME_"^"_$H
62 . S ^MAGDICOM(2006.5641,"B",ID,D0)=""
63 . S ^MAGDICOM(2006.5641,"C",HOSTNAME,D0)=""
64 . Q
65 S (N,I,D0)=0 F S D0=$O(^MAGDICOM(2006.5641,D0)) Q:'D0 S N=N+1,I=D0
66 S ^MAGDICOM(2006.5641,0)="DICOM GATEWAY MACHINE ID^2006.5641^"_I_"^"_N
67 L -^MAGDICOM(2006.5641,0)
68 S OUT=""
69 S N=0,D0="" F S D0=$O(^MAGDICOM(2006.5641,"B",ID,D0)) Q:D0="" D
70 . S N=N+1,X=$G(^MAGDICOM(2006.5641,D0,0)),I=$P(X,"^",2)
71 . I I'=HOSTNAME,I'="" S OUT=OUT_", """_I_""""
72 . Q
73 I N=1 S OUT=1 Q
74 S OUT=N_OUT
75 Q
76 ;
77DOMAIN(OUT) ; RPC = MAG DICOM GET DOMAIN
78 N X
79 I $T(WHERE^XUPARAM)'="" S OUT=$$KSP^XUPARAM("WHERE") Q
80 ; The coding standards frown upon the line below,
81 ; but it is the best we can do when the line above cannot be used.
82 S X=^DD("SITE") S:X'[".VA.GOV" X=X_".VA.GOV"
83 S OUT=X
84 Q
85 ;
86INFO(OUT,LOCATION) ; RPC = MAG DICOM ET PHONE HOME
87 N FST,N,X
88 K OUT
89 S X1=DT,X2=-25 D C^%DTC S FST=X
90 S N=2
91 ;
92 ; Site-ID
93 D DOMAIN(.X)
94 S OUT(N)=X
95 ;
96 D ROUTEDAY^MAGDRPC2 ; Get routing statistics
97 ;
98 D ; Text Gateway Statistics
99 . N A,C,D0,D2,M,X
100 . S A=0,D0=FST F S D0=$O(^MAGDAUDT(2006.5761,D0)) Q:'D0 D
101 . . S D2=0 F S D2=$O(^MAGDAUDT(2006.5761,D0,1,LOCATION,1,D2)) Q:'D2 D
102 . . . S X=$G(^MAGDAUDT(2006.5761,D0,1,LOCATION,1,D2,0))
103 . . . S M=$P(X,"^",2) Q:'M
104 . . . S:'A N=N+1,OUT(N)="Audit",A=1
105 . . . S N=N+1,OUT(N)="STTX="_D0_"^"_$P(X,"^",1)_"^"_M
106 . . . Q
107 . . Q
108 . Q
109 ;
110 S OUT(1)=N-1
111 Q
112 ;
113STATION(OUT,STATION,VERSION) ; RPC = MAG DICOM WORKSTATION VERSION
114 N %,D0,%H,%I,X
115 I $G(STATION)="" S OUT="-1,No Station Identifier Specified" Q
116 ;
117 S D0=$O(^MAG(2006.83,"B",STATION,"")) D:'D0
118 . L +^MAG(2006.83,0):1E9 ; Background process must wait for LOCK
119 . S X=$G(^MAG(2006.83,0))
120 . S $P(X,"^",1,2)="DICOM WORKSTATION^2006.83"
121 . S D0=$O(^MAG(2006.83," "),-1)+1
122 . S $P(X,"^",3)=D0
123 . S $P(X,"^",4)=$P(X,"^",4)+1
124 . S ^MAG(2006.83,0)=X,^MAG(2006.83,D0,0)=STATION
125 . S ^MAG(2006.83,"B",STATION,D0)=""
126 . L -^MAG(2006.83,0)
127 . Q
128 S $P(^MAG(2006.83,D0,0),"^",3)=VERSION
129 S X=$P(^MAG(2006.83,D0,0),"^",2)
130 D NOW^%DTC
131 S $P(^MAG(2006.83,D0,0),"^",2)=%
132 S OUT=D0
133 Q
134 ;
135FMGET(OUT,FILE,D0,FIELD) ; RPC = MAG DICOM FILEMAN GET
136 ; Get the value of a data field
137 S OUT=$$GET1^DIQ(FILE,D0,FIELD)
138 Q
139 ;
140CUTOFF(OUT,D0) ; RPC = MAG DICOM PACS CUTOFF DATE
141 ; Retention Period for PACS
142 N X
143 I '$$CONSOLID^MAGBAPI() D Q
144 . ; Non-consolidated site
145 . I '$D(^MAG(2006.1,"APACS")) S OUT="-2,No PACS Installed" Q
146 . ;
147 . S X=$G(^MAG(2006.1,"AIMDELPACS"))
148 . I X="" S OUT="-3,PACS Retention Parameter not defined" Q
149 . S OUT=X
150 . Q
151 ; Consolidated site:
152 I '$P($G(^MAG(2006.1,D0,"PACS")),"^",1) S OUT="-2,No PACS Installed" Q
153 ;
154 S X=$P($G(^MAG(2006.1,D0,1)),"^",5)
155 I X="" S OUT="-3,PACS Retention Parameter not defined" Q
156 S OUT=X
157 Q
158 ;
159MINSPACE(OUT,D0) ; RPC = MAG DICOM PACS MINIMUM SPACE
160 ; Minimum Percentage of Free Disk Space
161 N X
162 I '$$CONSOLID^MAGBAPI() D Q
163 . ; Non-consolidated site
164 . I '$D(^MAG(2006.1,"APACS")) S OUT="-2,No PACS Installed" Q
165 . ;
166 . S X=$G(^MAG(2006.1,"AIMDELPACS2"))
167 . I X="" S OUT="-3,PACS Minimum Space Percentage Parameter not defined" Q
168 . S OUT=X
169 . Q
170 ; Consolidated site:
171 I '$P($G(^MAG(2006.1,D0,"PACS")),"^",1) S OUT="-2,No PACS Installed" Q
172 ;
173 S X=$P($G(^MAG(2006.1,D0,3)),"^",5)
174 I X="" S OUT="-3,PACS Minimum Space Percentage Parameter not defined" Q
175 S OUT=X
176 Q
177 ;
178HL7PURGE(OUT,CUTOFF) ; RPC = MAG DICOM PURGE HL7
179 ; Purge HL7 transactions
180 N D,D0,P,T,X
181 S OUT=0
182 S D="" F S D=$O(^MAGDHL7(2006.5,"B",D)) Q:'D Q:D'<CUTOFF D
183 . S D0="" F S D0=$O(^MAGDHL7(2006.5,"B",D,D0)) Q:'D0 D
184 . . S X=$G(^MAGDHL7(2006.5,D0,0)),P=$P(X,"^",4),T=$P(X,"^",3)
185 . . K ^MAGDHL7(2006.5,D0)
186 . . K ^MAGDHL7(2006.5,"B",D,D0)
187 . . K:T'="" ^MAGDHL7(2006.5,"C",T,D0)
188 . . K:P'="" ^MAGDHL7(2006.5,"D",P,D0)
189 . . S OUT=OUT+1
190 . . Q
191 . Q
192 D:OUT
193 . L +^MAGDHL7(2006.5,0):1E9
194 . S X=$G(^MAGDHL7(2006.5,0))
195 . S $P(X,"^",1,2)="PACS MESSAGES^2006.5D"
196 . S $P(X,"^",4)=$P(X,"^",4)-OUT
197 . S ^MAGDHL7(2006.5,0)=X
198 . L -^MAGDHL7(2006.5,0)
199 . Q
200 Q
201 ;
202VALDEST(OUT,NAME) ; RPC = MAG DICOM ROUTE VALID DEST
203 N D0,PLACE,X
204 ; This function is also called from various routines
205 ; that belong to automated routing.
206 ;
207 S OUT="-1,"""_NAME_""" is not a valid destination"
208 ;
209 I $D(^MAG(2005.2,"B")) D Q
210 . S D0=$O(^MAG(2005.2,"B",NAME,"")) Q:'D0
211 . S:$P($G(^MAG(2005.2,D0,0)),"^",9) OUT=D0
212 . Q
213 ;
214 S D0=""
215 S PLACE="" F S PLACE=$O(^MAG(2005.2,"D",PLACE)) Q:PLACE="" D Q:OUT>0
216 . S D0=$O(^MAG(2005.2,"D",PLACE,NAME,""))
217 . S:$P($G(^MAG(2005.2,D0,0)),"^",9) OUT=D0
218 . Q
219 Q
220 ;
221PAT(OUT,DFN) ; RPC = MAG DICOM GET PATIENT
222 N DIQUIET,I,N,VADM,VAIN,VAPA,VASD
223 K OUT
224 I '$G(DFN) S OUT(1)="-1,No Patient Identified" Q
225 S N=1,DIQUIET=1
226 D DEM^VADPT,VA("DEM","VADM","")
227 D ADD^VADPT,VA("ADD","VAPA","")
228 D INP^VADPT,VA("INP","VAIN","")
229 D SDA^VADPT,VA("SDA","VASD","")
230 S X=$$GETICN^MPIF001(DFN) S:X'<0 N=N+1,OUT(N)="ICN^1^"_X
231 S OUT(1)=N-1
232 Q
233 ;
234VA(PRE,ARR,SUB) N A,I,X
235 S I="" F S I=$O(@ARR@(I)) Q:I="" D
236 . S A=$NAME(@ARR@(I))
237 . S X=$G(@A) S:X'="" N=N+1,OUT(N)=PRE_"^"_SUB_I_"^"_X
238 . D:$D(@A)>9 VA(PRE,A,SUB_I_",")
239 . Q
240 Q
241 ;
242RARPTO(OUT,TYPE,D0,F,D1) ; RPC = MAG DICOM GET RAD RPT INFO
243 S TYPE=$G(TYPE),D0=$G(D0),F=$G(F,1),D1=+$G(D1)
244 I TYPE="O1" S OUT=+$O(^RARPT(D0),F) Q
245 I TYPE="O2" S OUT=+$O(^RARPT(D0,F,D1)) Q
246 I TYPE="G1" S OUT=$G(^RARPT(D0,0)) Q
247 I TYPE="G2" S OUT=$G(^RARPT(D0,F,D1,0)) Q
248 S OUT="-1,Invalid request type ("""_TYPE_""")"
249 Q
250 ;
Note: See TracBrowser for help on using the repository browser.