source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGDRPC8.m@ 1604

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

initial load of WorldVistAEHR
File size: 7.3 KB
Line 
1MAGDRPC8 ;WOIFO/EdM - RPCs for Master Files ; 06/09/2005 09:07
2 ;;3.0;IMAGING;**11,30,51**;26-August-2005
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 ;
20UPDTAPP(OUT,APP) ; RPC = MAG DICOM UPDATE SCU LIST
21 N A,D0,GWLOC,GWNAM,HDR,I,MIN,N,NOW,P5,P7,PLUS,SERVNAM,UP,X
22 S (GWNAM,GWLOC)="",N=0
23 S A="" F S A=$O(APP(A)) Q:A="" D
24 . S X=APP(A) F I=1:1:7 S:$P(X,"^",I)="" N=N+1
25 . S:GWNAM="" GWNAM=$P(X,"^",5)
26 . S:GWLOC="" GWLOC=$P(X,"^",7)
27 . S:GWNAM'=$P(X,"^",5) N=N+1
28 . S:GWLOC'=$P(X,"^",7) N=N+1
29 . S:'N A($P(X,"^",1))=A ; ^MAGDMFBS guarantees unique names
30 . Q
31 I N S OUT="-1,Missing or Inconsistent Parameters." Q
32 ;
33 L +^MAG(2006.587,0):1E9 ; Background task MUST wait
34 S HDR=$G(^MAG(2006.587,0))
35 S $P(HDR,"^",1,2)="DICOM TRANSMIT DESTINATION^2006.587"
36 ;
37 D NOW^%DTC S NOW=%,(MIN,PLUS,UP)=0
38 ;
39 S D0="" F S D0=$O(^MAG(2006.587,"D",GWNAM,GWLOC,D0)) Q:D0="" D
40 . S X=$G(^MAG(2006.587,D0,0)),SERVNAM=$P(X,"^",1) Q:SERVNAM=""
41 . S P5=$P(X,"^",5),P7=$P(X,"^",7)
42 . I P5'="",P7'="" K ^MAG(2006.587,"C",SERVNAM,P7,P5,D0),^MAG(2006.587,"D",P5,P7,D0)
43 . I '$D(A(SERVNAM)) D Q
44 . . K ^MAG(2006.587,D0),^MAG(2006.587,"B",SERVNAM,D0) S MIN=MIN+1
45 . . Q
46 . S X=APP(A(SERVNAM)),$P(X,"^",8)=NOW K APP(A(SERVNAM))
47 . S ^MAG(2006.587,D0,0)=$P(X,"^",1,8),UP=UP+1
48 . S ^MAG(2006.587,"C",SERVNAM,GWLOC,GWNAM,D0)=""
49 . S ^MAG(2006.587,"D",GWNAM,GWLOC,D0)=""
50 . Q
51 S $P(HDR,"^",4)=$P(HDR,"^",4)-MIN
52 ;
53 S A="" F S A=$O(APP(A)) Q:A="" D
54 . S X=APP(A),$P(X,"^",8)=NOW
55 . S D0=$O(^MAG(2006.587," "),-1)+1,PLUS=PLUS+1,$P(HDR,"^",3)=D0
56 . S ^MAG(2006.587,D0,0)=$P(X,"^",1,8),SERVNAM=$P(X,"^",1)
57 . S ^MAG(2006.587,"B",SERVNAM,D0)=""
58 . S ^MAG(2006.587,"C",SERVNAM,GWLOC,GWNAM,D0)=""
59 . S ^MAG(2006.587,"D",GWNAM,GWLOC,D0)=""
60 . Q
61 S $P(HDR,"^",4)=$P(HDR,"^",4)+PLUS
62 S ^MAG(2006.587,0)=HDR
63 L -^MAG(2006.587,0)
64 S OUT="1"
65 S:PLUS OUT=OUT_", "_PLUS_" added"
66 S:MIN OUT=OUT_", "_MIN_" removed"
67 S:UP OUT=OUT_", "_UP_" updated"
68 Q
69 ;
70UPDTGW(OUT,ONAM,NNAM,OLOC,NLOC) ; RPC = MAG DICOM UPDATE GATEWAY NAME
71 N D0,P1,P5,P7,N
72 I $G(NNAM)="" S OUT="-1,No Gateway Name specified" Q
73 I '$G(NLOC) S OUT="-2,No Gateway Location specified" Q
74 S OLOC=$G(OLOC),ONAM=$G(ONAM)
75 S (N,D0)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
76 . S X=$G(^MAG(2006.587,D0,0)),P5=$P(X,"^",5) Q:P5'=ONAM
77 . S P1=$P(X,"^",1),P7=$P(X,"^",7)
78 . I OLOC'="",P5'="" K ^MAG(2006.587,"C",P1,OLOC,P5,D0),^MAG(2006.587,"D",P5,OLOC,D0)
79 . S $P(X,"^",5)=NNAM,$P(X,"^",7)=NLOC
80 . S ^MAG(2006.587,D0,0)=X
81 . S ^MAG(2006.587,"C",P1,NLOC,NNAM,D0)=""
82 . S ^MAG(2006.587,"D",NNAM,NLOC,D0)=""
83 . S N=N+1
84 . Q
85 S OUT=N
86 Q
87 ;
88SIBS(P0,T) N MAGLOC,P1,P2
89 S T(P0)=""
90 D SIBLING^XUAF4("MAGLOC",P0,"PARENT FACILITY") ; General API, IA #2171
91 S P1="" F S P1=$O(MAGLOC("P",P1)) Q:P1="" D
92 . S P2="" F S P2=$O(MAGLOC("P",P1,"C",P2)) Q:P2="" S T(P2)=""
93 . Q
94 Q
95 ;
96LOCS(OUT) ; RPC = MAG DICOM VALID LOCATIONS
97 N D0,I,M,N,P1,R,T
98 S N=1
99 S D0=0 F S D0=$O(^MAG(2006.1,D0)) Q:'D0 D
100 . S X=$G(^MAG(2006.1,D0,0)),P1=$P(X,"^",1) Q:P1=""
101 . I +P1=P1 S T(P1)="" Q
102 . D FIND^DIC(4,"","","BX",P1,"*","","","","R","M") ; IA #4389
103 . S I=0 F S I=$O(R("DILIST",2,I)) Q:'I D
104 . . S P1=R("DILIST",2,I) I P1 K R S T(P1)=""
105 . . Q
106 . Q
107 I $T(+1^XUPARAM)'="" S P1=$$KSP^XUPARAM("INST") D:P1 SIBS(P1,.T)
108 S P1=+$G(^DD("SITE",1)) D:P1 SIBS(P1,.T)
109 ;
110 S P1="" F S P1=$O(T(P1)) Q:P1="" D
111 . S N=N+1,OUT(N)=P1_"^"_$$GET1^DIQ(4,P1,.01)_"^"_$$GET1^DIQ(4,P1,99)
112 . Q
113 S OUT(1)=N-1
114 Q
115 ;
116GETPLACE(OUT,LOCATION) ; RPC = MAG DICOM GET PLACE
117 N D0,P1,M,R,X
118 S LOCATION=+$G(LOCATION)
119 S OUT="-1,Location """_LOCATION_""" not found."
120 S D0=0 F S D0=$O(^MAG(2006.1,D0)) Q:'D0 D Q:OUT>0
121 . S X=$G(^MAG(2006.1,D0,0)),P1=$P(X,"^",1) Q:P1=""
122 . I +P1=P1,LOCATION=P1 S OUT=D0 Q
123 . D FIND^DIC(4,"","","BX",P1,"*","","","","R","M")
124 . S I=0 F S I=$O(R("DILIST",2,I)) Q:'I D
125 . . I LOCATION=R("DILIST",2,I) S OUT=D0
126 . . Q
127 . Q
128 Q
129 ;
130SETPACS(OUT,D0) ; RPC = MAG DICOM SET PACS PARAMS
131 N X
132 I '$G(D0) S OUT="-1,No Place Specified." Q
133 I '$D(^MAG(2006.1,D0)) S OUT="-2,Invalid Place Specified." Q
134 ;
135 ; There is a PACS
136 S $P(^MAG(2006.1,D0,"PACS"),"^",1)=1
137 ;
138 ; Number of days to retain "PACS" images
139 S X=$P($G(^MAG(2006.1,D0,1)),"^",5)
140 S:'X $P(^MAG(2006.1,D0,1),"^",5)=30
141 ;
142 ; Set minimum % of free disk space to trigger automatic file delete
143 S X=$P($G(^MAG(2006.1,D0,3)),"^",6)
144 S:'X $P(^MAG(2006.1,D0,3),"^",6)=25
145 S OUT=1
146 Q
147 ;
148HIGHHL7(OUT) ; RPC = MAG DICOM GET HIGHEST HL7
149 S OUT=+$O(^MAGDHL7(2006.5," "),-1)
150 Q
151 ;
152FINDLOC(OUT,NAME) ; RPC = MAG DICOM FIND LOCATION
153 N I,M,P1,R,X
154 S OUT="-1,Invalid location """_NAME_"""."
155 D FIND^DIC(4,"",.01,"BXA",NAME,"*","","","","R","M")
156 S I=0 F S I=$O(R("DILIST",2,I)) Q:'I D
157 . S P1=R("DILIST",2,I) I P1 K R S OUT=P1
158 . Q
159 Q
160 ;
161VALIMGT(OUT) ; RPC = MAG DICOM GET IMAGING TYPES
162 N N,X
163 S N=1
164 ; Lists of valid imaging types
165 S X="" F S X=$O(^RA(79.2,"C",X)) Q:X="" S N=N+1,OUT(N)="RAD^"_X
166 S X="" F S X=$O(^MAG(2005.84,"C",X)) Q:X="" S N=N+1,OUT(N)="CON^"_X
167 S OUT(1)=N-1
168 Q
169 ;
170CORRECT(OUT,LOCATION,MACHID) ; RPC = MAG DICOM INCORRECT IMAGE CT
171 ; Check for images needing corrections
172 N CNT,D0,STUDY
173 I '$G(LOCATION) S OUT="-1,No Location Specified" Q
174 I $G(MACHID)="" S OUT="-2,No Gateway Specified" Q
175 S OUT=0
176 Q:'$O(^MAGD(2006.575,0))
177 Q:'$D(^MAGD(2006.575,"F",LOCATION))
178 S STUDY="" F S STUDY=$O(^MAGD(2006.575,"F",LOCATION,STUDY)) Q:STUDY="" D
179 . S D0=0 S D0=$O(^MAGD(2006.575,"F",LOCATION,STUDY,D0)) Q:'D0 D
180 . . Q:'$D(^MAGD(2006.575,D0,0))
181 . . S:MACHID=$P($G(^MAGD(2006.575,D0,1)),"^",4) OUT=OUT+1
182 . . Q
183 . Q
184 Q
185 ;
186HL7PTR(OUT,ACTION,VALUE) ; RPC = MAG DICOM HL7 POINTER ACTION
187 ; Manipulate HL7 Pointer
188 N D0,P1,P2,X,Y
189 S ACTION=$G(ACTION),VALUE=$G(VALUE)
190 S OUT="-2,Invalid Request: """_ACTION_"""."
191 I ACTION="GetDate" D Q
192 . S X=$G(^MAGDHL7(2006.5,+VALUE,0))
193 . I X="" S OUT="-1,Invalid Pointer """_VALUE_"""." Q
194 . S Y=$P(X,"^",3) D DD^%DT S OUT=Y
195 . Q
196 I ACTION="DatePtr" D Q
197 . S Y=$O(^MAGDHL7(2006.5,"C",VALUE),-1)
198 . I 'Y D ; before any date on file
199 . . ; if the requested date is before the first entry,
200 . . ; move the pointer to the first entry
201 . . S OUT=0
202 . . Q
203 . E D ; if the requested date is in the cross reference, use it.
204 . . S Y=$O(^MAGDHL7(2006.5,"C",Y,""))
205 . . I Y S OUT=Y ; found date
206 . . E D
207 . . . ; otherwise, find the appropriate entry the hard way
208 . . . S D0=$O(^MAGDHL7(2006.5,0))
209 . . . S Y=$P($G(^MAGDHL7(2006.5,D0,0)),"^",3) I Y'<X S OUT=0 Q
210 . . . S D0=" " F S D0=$O(^MAGDHL7(2006.5,D0),-1) Q:'D0 D Q:OUT
211 . . . . S Y=$P($G(^MAGDHL7(2006.5,D0,0)),"^",3) S:Y<X OUT=D0
212 . . . . Q
213 . . . Q
214 . . Q
215 . Q
216 Q
217 ;
Note: See TracBrowser for help on using the repository browser.