source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGDQR04.m@ 1421

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

initial load of WorldVistAEHR

File size: 7.9 KB
Line 
1MAGDQR04 ;WOIFO/EdM - Imaging RPCs for Query/Retrieve ; 05/16/2005 09:30
2 ;;3.0;IMAGING;**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 ;
20TIM ; Overflow from MAGDQR02
21 N SDT,V
22 ; The references below to ^RADPT are permitted according to the
23 ; existing Integration Agreement # 1172
24 S V="" F S V=$O(^RADPT("ADC",V)) Q:V="" D
25 . S MAGD0="" F S MAGD0=$O(^RADPT("ADC",V,MAGD0)) Q:MAGD0="" D
26 . . S MAGD1="" F S MAGD1=$O(^RADPT("ADC",V,MAGD0,MAGD1)) Q:MAGD1="" D
27 . . . S SDT=9999999.9999-MAGD1 Q:SDT<FD Q:SDT>LD
28 . . . S MAGD2="" F S MAGD2=$O(^RADPT("ADC",V,MAGD0,MAGD1,MAGD2)) Q:MAGD2="" D
29 . . . . S ^TMP("MAG",$J,"QR",10,MAGD0_"^"_MAGD1_"^"_MAGD2)="",TIM=2
30 . . . . S ANY=1,SID=1
31 . . . . Q
32 . . . Q
33 . . Q
34 . Q
35 I TIM=1 D Q
36 . D ERR^MAGDQR01("No matches for tag 0008,0020 / 0008,0030")
37 . D ERRSAV^MAGDQR01
38 . Q
39 ;
40 Q
41 ;
42STUDY(OUT,UID) ; RPC = MAG STUDY UID QUERY
43 N D1,F1,F2,F3,IMAGE,N,NET,PASS,SERIES,USER,X
44 I $G(UID)="" S OUT(1)="-1,No UID specified." Q
45 I UID'?1.64(1N,1".") S OUT(1)="-2,Invalid UID format: """_UID_"""." Q
46 S N=1
47 S SERIES="" F S SERIES=$O(^MAG(2005,"P",UID,SERIES)) Q:SERIES="" D
48 . Q:$P($G(^MAG(2005,SERIES,0)),"^",10)
49 . S D1=0 F S D1=$O(^MAG(2005,SERIES,1,D1)) Q:'D1 D
50 . . S IMAGE=+$G(^MAG(2005,SERIES,1,D1,0)) Q:'IMAGE
51 . . S NET=$P($G(^MAG(2005,IMAGE,0)),"^",3),(USER,PASS)=""
52 . . I NET S X=$G(^MAG(2005.2,NET,2)),USER=$P(X,"^",1),PASS=$P(X,"^",2)
53 . . D FILEFIND^MAGDFB(IMAGE,"FULL",0,0,.F1,.F2,.F3)
54 . . S N=N+1,OUT(N)=IMAGE_"^"_F2_"^"_USER_"^"_PASS
55 . . Q
56 . Q
57 S X=" image" S:N'=2 X=X_"s" S X=X_" found"
58 S OUT(1)=(N-1)_X
59 Q
60 ;
61INFO(OUT,IMAGE) ; RPC = MAG IMAGE CURRENT INFO
62 ;
63 ; 0008,0020 Study Date
64 ; 0008,0050 Accession Number
65 ; 0008,0060 Modality
66 ; 0008,0090 Referring Physician's Name
67 ; 0008,1030 Study Description (may be VA procedure name)
68 ; 0008,1050 Performing (attending) Physician
69 ; 0010,0010 Patient Name
70 ; 0010,0020 Patient ID
71 ; 0010,0030 Patient's Birth Date
72 ; 0010,0040 Patient's Sex
73 ; 0010,1000 Other Patient IDs (= ICN, Integration Control Number)
74 ; 0010,1040 Address
75 ; 0010,2160 Ethnic Group
76 ; 0010,2000 Medical Alerts
77 ; 0020,000D Study Instance UID
78 ; 0032,1032 Requesting Physician
79 ; 0032,1033 Requesting Service
80 ; 0032,1060 Requested Procedure Description (CPT name)
81 ; 0032,1064 Requested Procedure Code Sequence
82 ; 0008,0100 > Code Value (CPT code)
83 ; 0008,0102 > Coding Scheme Designator ("C4")
84 ; 0008,0104 > Code Meaning (CPT name)
85 ; 0038,0300 Current Patient Location (ward)
86 ;
87 N ACN,ATP,CPT,D0,D1,D2,D3,DFN,I,MO,N,P,REQP,RFP,RQL,T,TAG,UID,V,WRD,X
88 I '$G(IMAGE) S OUT(1)="-1,No Image Specified." Q
89 I '$D(^MAG(2005,IMAGE)) S OUT(1)="-2,No Such Image ("_IMAGE_")." Q
90 ;
91 S X=$G(^MAG(2005,IMAGE,0)),P=$P(X,"^",10)
92 S TAG("0008,1030")=$P(X,"^",8) ; Procedure
93 S DFN=$P(X,"^",7) D:DFN
94 . ; The following references to ^DPT are allowed according to
95 . ; PIMS V5.3 Technical Manual, Section II.
96 . S TAG("0010,0010")=$P(^DPT(DFN,0),"^",1) ; Patient Name
97 . S TAG("0010,0020")=$P(^DPT(DFN,0),"^",9) ; Patient ID (SSN)
98 . S TAG("0010,0030")=$P(^DPT(DFN,0),"^",3)\1+17000000 ; Patient's Birth Date
99 . S TAG("0010,0032")=$TR($J("."_$P($P(^DPT(DFN,0),"^",3),".",2)*1E6,6)," ",0) ; Patient's Birth Time [probably always blank]
100 . S TAG("0010,2160")=$P(^DPT(DFN,0),"^",6) ; Patient's Race
101 . S TAG("0010,0040")=$P(^DPT(DFN,0),"^",2) ; Patient's Sex
102 . S X=$$GETICN^MPIF001(DFN)
103 . S:X'="" TAG("0010,1000")=X ; Other Patient ID
104 . S X=$G(^DPT(DFN,0.11)) D:X'=""
105 . . S P=$P(X,"^",5) S:P V=$P($G(^DIC(5,+P,0)),"^",1) ; IA # 10056
106 . . S:V'="" $P(X,"^",5)=V ; State
107 . . S TAG("0010,1040")=$P(X,"^",1,6) ; Patient's Address
108 . . Q
109 . Q
110 ;
111 S UID=$S(P:$G(^MAG(2005,+P,"PACS")),1:$G(^MAG(2005,IMAGE,"PACS")))
112 S TAG("0020,000D")=UID ; Study Instance UID
113 ; The following references to ^RADPT are allowed according to IA # 1172
114 S I=0
115 I UID'="" S D0="" F S D0=$O(^RADPT("ADC",UID,D0)) Q:D0="" D
116 . S D1="" F S D1=$O(^RADPT("ADC",UID,D0,D1)) Q:D1="" D
117 . . N VAINDT
118 . . S I=I+1,TAG("0008,0020",I)=9999999.9999-D1\1+17000000 ; Study Date
119 . . S VAINDT=9999999.9999-D1 D INP^VADPT ; Supported reference
120 . . S:$G(VAIN(2))'="" RFP(VAIN(2))="" ; Referring Physician's Name
121 . . S:$G(VAIN(4))'="" RFP(VAIN(4))="" ; Current Ward
122 . . S:$G(VAIN(11))'="" ATP(VAIN(11))="" ; Performing (attending) Physician
123 . . S D2="" F S D2=$O(^RADPT("ADC",UID,D0,D1,D2)) Q:D2="" D
124 . . . S X=$G(^RADPT(D0,"DT",D1,"P",D2,0))
125 . . . S P=$P(X,"^",2) D:P
126 . . . . S M1=0 F S M1=$O(^RAMIS(71,+P,"MDL",M1)) Q:'M1 D ; IA # 1174
127 . . . . . S V=$P($G(^RAMIS(71,+P,"MDL",M1,0)),"^",1) S:V'="" MO(V)="" ; IA # 1174
128 . . . . . Q
129 . . . . S V=$P($G(^RAMIS(71,+P,0)),"^",9) S:V CPT(+V)="" ; IA # 1174
130 . . . . Q
131 . . . S P=$P(X,"^",14) D:P
132 . . . . S V=$P($G(^VA(200,+P,0)),"^",1)
133 . . . . S:V'="" REQP(V)=""
134 . . . . Q
135 . . . S P=$P(X,"^",17) D:P
136 . . . . S X=$G(^RARPT(+P,0)) Q:X="" ; IA # 1171
137 . . . . S V=$P(X,"^",1) S:V'="" ACN(V)=""
138 . . . . Q
139 . . . S P=$P(X,"^",22) D:P
140 . . . . S X=$G(^SC(+P,0)) Q:X="" ; IA # 10040
141 . . . . S V=$P(X,"^",1) S:V'="" RQL(V)=""
142 . . . . Q
143 . . . S P=0,D3=0 F S D3=$O(^RADPT(D0,"P",D1,"DT",D2,"H",D3)) Q:'D3 D
144 . . . . S X=$G(^RADPT(D0,"P",D1,"DT",D2,"H",D3,0)) Q:X=""
145 . . . . S P=P+1,TAG("0010,2000 "_$J(P,5))=X
146 . . . . Q
147 . . . Q
148 . . Q
149 . Q
150 S V="" F S V=$O(ACN(V)) Q:V="" D
151 . S I=I+1,TAG("0008,0050",I)=ACN(V) ; Accession Number
152 . Q
153 S V="" F S V=$O(WRD(V)) Q:V="" D
154 . S I=I+1,TAG("0038,0300",I)=$P(V,"^",2) ; Current Patient Location
155 . Q
156 S V="" F S V=$O(RFP(V)) Q:V="" D
157 . S I=I+1,TAG("0008,0090",I)=$P(V,"^",2) ; Referring Physician's Name
158 . Q
159 S V="" F S V=$O(ATP(V)) Q:V="" D
160 . S I=I+1,TAG("0008,1050",I)=$P(V,"^",2) ; Performing (attending) Physician
161 . Q
162 S V="" F S V=$O(RQL(V)) Q:V="" D
163 . S I=I+1,TAG("0032,1033",I)=RQL(V) ; Requesting Service
164 . Q
165 S V="" F S V=$O(MO(V)) Q:V="" D
166 . S I=I+1,TAG("0008,0060",I)=MO(V) ; Modality
167 . Q
168 S V="" F S V=$O(REQP(V)) Q:V="" D
169 . S I=I+1,TAG("0032,1032",I)=REQP(V) ; Requesting Physician
170 . Q
171 S V="" F S V=$O(CPT(V)) Q:V="" D
172 . S X=$$CPT^ICPTCOD(V) ; IA # 1995, supported reference
173 . Q:$P(X,"^",2)=""
174 . S I=I+1
175 . S TAG("0031,1064 0008,0100",I)=$P(X,"^",2) ; CPT Code
176 . S TAG("0031,1064 0008,0104",I)=$P(X,"^",3) ; Code Meaning
177 . S TAG("0031,1060",I)=$P(X,"^",3) ; Requested Procedure Description
178 . S TAG("0031,1064 0008,0102",I)="C4" ; Coding Scheme Designator
179 . Q
180 ;
181 S N=1,T="" F S T=$O(TAG(T)) Q:T="" D
182 . S V=""
183 . S:$D(TAG(T))#2 V=TAG(T)
184 . S I="" F S I=$O(TAG(T,I)) Q:I="" S:V'="" V=V_"\" S V=V_TAG(T,I)
185 . S:V'="" N=N+1,OUT(N)=T_"^"_V
186 . Q
187 ;
188 S OUT(1)=(N-1)_" data fields returned."
189 Q
190 ;
191CLEAN(OUT) ; RPC = MAG DICOM QUERY CLEANUP
192 N D0,H,N,STAMP
193 L +^MAGDQR(2006.5732,0):1E6 ; Background task MUST wait
194 S D0=0 F S D0=$O(^MAGDQR(2006.5732,D0)) Q:'D0 D
195 . S X=$G(^MAGDQR(2006.5732,D0,0)),STAMP=$P(X,"^",3)
196 . Q:DT-STAMP<5
197 . K ^MAGDQR(2006.5732,D0)
198 . K ^MAGDQR(2006.5732,"B",D0)
199 . Q
200 S (D0,N,H)=0 F S D0=$O(^MAGDQR(2006.5732,D0)) Q:'D0 S N=N+1,H=D0
201 S X="DICOM QUERY RETRIEVE RESULT^2006.2006.5732^"_H_"^"_N
202 S ^MAGDQR(2006.5732,0)=X
203 L -^MAGDQR(2006.5732,0)
204 Q
205 ;
Note: See TracBrowser for help on using the repository browser.