source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGDIR9E.m@ 1578

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

initial load of WorldVistAEHR
File size: 8.9 KB
Line 
1MAGDIR9E ;WOIFO/PMK - Read a DICOM image file ; 15 Feb 2006 10:49 AM
2 ;;3.0;IMAGING;**11,51,46**;16-February-2007;;Build 1023
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 ;
19 ; M2MB server
20 ;
21 ; This routine creates the group entry in ^MAG(2005) and links it
22 ; to the consult/procedure request in GMRC.
23 ;
24 ; XXXX XXX X
25 ; XX XX XX XX
26 ; XX XXXX XX XXX XXXXXXX XX XXX XX XXXXX
27 ; XX XX XX XXX XX XX XX XX XX XX
28 ; XX X XX XX XX XX XXXXXXX XX XX XX XX
29 ; XX XX XX XX XX XX XX XX XX XX XX XX
30 ; XXXX XXXX XX XX XXXXXXX XXX XX XXXX XXX
31 ;
32 ;
33GROUP() ; entry point from ^MAGDIR8 for consult/procedure groups
34 N ACQDEVP ;-- pointer to acquisition device file (#2006.04)
35 N D0 ;------- fileman variable
36 N ERRCODE ;-- error trap code
37 N GROUP ;---- array to pass group data to ^MAGGTIA
38 N MAGGPP ;--- pointer to group in DICOM GMRC TEMP LIST ^MAG(20006.5839)
39 N P ;-------- scratch variable (pointer to ACQUISITION DEVICE file)
40 N RESULT ;--- scratch variable
41 N SERVICE ;-- service performing the consult/procedure - ^GMR(123.5)
42 N SOPCLASP ;- pointer to SOP Class file (#2006.532)
43 N TIUIEN ;--- TIU file 8925 IEN value
44 ;
45 S ERRCODE=""
46 ;
47 I STUDYDAT,STUDYTIM D ; get study date/time from image header
48 . S DATETIME=(STUDYDAT_"."_STUDYTIM)-17000000 ; FileMan date.time fmt
49 . Q
50 E D ; use current date/time
51 . N %,%H,%I,X
52 . D NOW^%DTC S DATETIME=%
53 . Q
54 ;
55 ; initialize FILEDATA for GROUP and IMAGE
56 ; get the acquisition device pointer (file 2005, field 107)
57 S ACQDEVP=$$ACQDEV^MAGDFCNV(MFGR,MODEL,INSTLOC)
58 S FILEDATA("ACQUISITION DEVICE")=ACQDEVP
59 ; get the SOP Class pointer (file 2005, field 251)
60 S SOPCLASP=$O(^MAG(2006.532,"B",SOPCLASS,""))
61 S FILEDATA("SOP CLASS POINTER")=SOPCLASP
62 ;
63 S MAGGP="" ; initialize pointer to the image group
64 ;
65 ; check if there already is a TIU note attached to this request
66 ;
67 S TIUIEN=$$TIULAST^MAGDGMRC(GMRCIEN)
68 I TIUIEN D Q:ERRCODE ERRCODE ; there is TIU note already
69 . ; double check TIU note DFN to make sure that it matches
70 . N HIT ; scratch variable used in finding corresponding image group
71 . N TIUDFN ; DFN value from ^TIU for double checking
72 . N TIUXDIEN ; TIU External Data File IEN
73 . S TIUDFN=$P($G(^TIU(8925,TIUIEN,0)),"^",2)
74 . I TIUDFN'=DFN D Q ; fatal error
75 . . D TIUMISS^MAGDIRVE($T(+0),DFN,TIUIEN,TIUDFN)
76 . . S ERRCODE=-501
77 . . Q
78 . ;
79 . S FILEDATA("PARENT FILE")=8925 ; TIU file
80 . S FILEDATA("PARENT IEN")=TIUIEN
81 . ;
82 . ; is there an entry in TIU External Data File for this note
83 . S (HIT,TIUXDIEN)=0
84 . F S TIUXDIEN=$O(^TIU(8925.91,"B",TIUIEN,TIUXDIEN)) Q:'TIUXDIEN D Q:HIT Q:ERRCODE
85 . . N MAG2 ;----- data value for getting parent file attributes
86 . . N GROUPDFN ;- DFN value from image group entry for double checking
87 . . ; there is a TIU External Data File
88 . . ; does the TIU External Data File entry point to an image group?
89 . . S MAGGP=$$GET1^DIQ(8925.91,TIUXDIEN,.02,"I") Q:'MAGGP
90 . . ; double check image group entry DFN
91 . . S GROUPDFN=$P($G(^MAG(2005,MAGGP,0)),"^",7)
92 . . I GROUPDFN'=DFN D Q ; fatal error
93 . . . D MISMATCH^MAGDIRVE($T(+0),DFN,MAGGP)
94 . . . S ERRCODE=-502
95 . . . Q
96 . . I $P($G(^MAG(2005,MAGGP,0)),"^",6)'=11 D Q ; 11=XRAY GROUP
97 . . . S MAGGP="" ; wrong object type - skip this image group
98 . . . Q
99 . . S P=$P($G(^MAG(2005,MAGGP,"SOP")),"^",1)
100 . . ; skip this image group if wrong SOP Class
101 . . I '$$EQUIVGRP^MAGDFCNV(P,SOPCLASP) S MAGGP="" Q
102 . . ; add the new image to this existing image group
103 . . S HIT=1,MAG2=$G(^MAG(2005,MAGGP,2))
104 . . S FILEDATA("PARENT FILE")=$P(MAG2,"^",6)
105 . . S FILEDATA("PARENT IEN")=$P(MAG2,"^",7)
106 . . S FILEDATA("PARENT FILE PTR")=$P(MAG2,"^",8)
107 . . I FILEDATA("PARENT IEN")'=TIUIEN D ; fatal error
108 . . . D TIUMISS2^MAGDIRVE($T(+0),TIUIEN,FILEDATA("PARENT IEN"),TIUXDIEN,MAGGP)
109 . . . S ERRCODE=-503
110 . . . Q
111 . . Q
112 . Q
113 ;
114 ; need a temporary association for the consult/procedure request
115 ;
116 E D Q:ERRCODE ERRCODE ; check if there is a temporary association
117 . ;
118 . ; Note: this algorithm creates multiple groups for a study,
119 . ; for instance a GI fluoroscopy + color images
120 . ;
121 . S MAGGPP=""
122 . F S MAGGPP=$O(^MAG(2006.5839,"C",123,GMRCIEN,MAGGPP)) Q:'MAGGPP D Q:ERRCODE
123 . . N GROUPDFN ; DFN value from image group entry for double checking
124 . . S MAGGP=$P(^MAG(2006.5839,MAGGPP,0),"^",3)
125 . . ; double check image group entry DFN in existing 2005 group node
126 . . S GROUPDFN=$P($G(^MAG(2005,MAGGP,0)),"^",7)
127 . . I GROUPDFN'=DFN D ; fatal error
128 . . . D MISMATCH^MAGDIRVE($T(+0),DFN,MAGGP)
129 . . . S MAGGP="" ; bad group
130 . . . S ERRCODE=-504
131 . . . Q
132 . . E S P=$P($G(^MAG(2005,MAGGP,100)),"^",4) I P,P'=ACQDEVP D ; wrong device
133 . . . S MAGGP="" ; wrong acquisition device - skip this image group
134 . . . Q
135 . . E D ; add the new image to this existing image group
136 . . . N MAG2 ; data value for getting parent file attributes
137 . . . S MAG2=$G(^MAG(2005,MAGGP,2))
138 . . . S FILEDATA("PARENT FILE")=$P(MAG2,"^",6)
139 . . . S FILEDATA("PARENT IEN")=$P(MAG2,"^",7)
140 . . . S FILEDATA("PARENT FILE PTR")=$P(MAG2,"^",8) ; should be null
141 . . . I FILEDATA("PARENT FILE")'=2006.5839 D ; fatal error
142 . . . . D TMPMISS^MAGDIRVE($T(+0),FILEDATA("PARENT FILE"),MAGGP)
143 . . . . S ERRCODE=-505
144 . . . . Q
145 . . . Q
146 . . Q
147 . ;
148 . I 'MAGGP D ; no group exists yet create a temporary association
149 . . S FILEDATA("PARENT FILE")=2006.5839 ; GMRC file
150 . . S FILEDATA("PARENT IEN")=GMRCIEN
151 . . Q
152 . Q
153 ;
154 S FILEDATA("MODALITY")=MODALITY
155 S FILEDATA("PACKAGE")="CONS"
156 ;
157 ; add the study to the Consult Unread List, if necessary
158 D ADD^MAGDTR03(.RESULT,GMRCIEN,"I",1) ; add if "on image" is set
159 ;
160 ; lookup study in ^GMR(123) and get FILEDATA variables
161 S SERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
162 I SERVICE D
163 . N ISPECIDX,IPROCIDX,UNREAD,X,Y
164 . S UNREAD=$O(^MAG(2006.5849,"B",GMRCIEN,""))
165 . I UNREAD D ; get indices from Unread List
166 . . S X=^MAG(2006.5849,UNREAD,0)
167 . . S ISPECIDX=$P(X,"^",3),IPROCIDX=$P(X,"^",4)
168 . . S FILEDATA("SPEC/SUBSPEC")=ISPECIDX
169 . . I "A"[$P(^MAG(2005.85,IPROCIDX,0),"^",3) D
170 . . . S FILEDATA("PROC/EVENT")=IPROCIDX
171 . . . Q
172 . . E D ; inactive index to procedure
173 . . . S X=$$FIELD43^MAGXMA(MODALITY,ISPECIDX,.Y)
174 . . . S FILEDATA("PROC/EVENT")=$S(X=0:Y,1:"")
175 . . . Q
176 . . Q
177 . E I $D(^MAG(2006.5831,SERVICE,0)) D
178 . . S ISPECIDX=$P(^MAG(2006.5831,SERVICE,0),"^",2)
179 . . S X=$$FIELD43^MAGXMA(MODALITY,ISPECIDX,.Y)
180 . . S FILEDATA("PROC/EVENT")=$S(X=0:Y,1:"")
181 . . S FILEDATA("SPEC/SUBSPEC")=ISPECIDX
182 . . Q
183 . E D ; service was removed from ^MAG(2006.5831)
184 . . S FILEDATA("PROC/EVENT")=""
185 . . S FILEDATA("SPEC/SUBSPEC")=""
186 . . Q
187 . Q
188 E D
189 . S FILEDATA("PROC/EVENT")=""
190 . S FILEDATA("SPEC/SUBSPEC")=""
191 . Q
192 ;
193 ; if the 2005 group node does not yet exist, create it
194 ;
195 I 'MAGGP D Q:ERRCODE ERRCODE ; create the imaging group
196 . D NEWGROUP^MAGDIR9A("CON/PROC") Q:ERRCODE
197 . ;
198 . I FILEDATA("PARENT FILE")=8925 D Q:ERRCODE ; fix for ^TIU
199 . . S ERRCODE=$$TIUXLINK^MAGDIR9E()
200 . . Q
201 . E I FILEDATA("PARENT FILE")=2006.5839 D ; fix for ^GMR
202 . . L +^MAG(2006.5839)
203 . . I '$D(^MAG(2006.5839,0)) D
204 . . . S ^MAG(2006.5839,0)="DICOM GMRC TEMP LIST^^0^0"
205 . . . Q
206 . . S D0=$P(^MAG(2006.5839,0),"^",3)+1
207 . . S $P(^MAG(2006.5839,0),"^",3)=D0,$P(^(0),"^",4)=$P(^(0),"^",4)+1
208 . . L -^MAG(2006.5839)
209 . . S ^MAG(2006.5839,D0,0)="123^"_GMRCIEN_"^"_MAGGP
210 . . S ^MAG(2006.5839,"C",123,GMRCIEN,D0)=""
211 . . Q
212 . Q
213 ;
214 ; check for intra-oral x-ray images & get tooth number(s)
215 I IMAGNAME'="" S FILEDATA("SHORT DESCRIPTION")=IMAGNAME
216 ;
217 Q 0
218 ;
219TIUXLINK() ; create the cross-linkages to TIU EXTERNAL DATA LINK file
220 N TIUXDIEN
221 D PUTIMAGE^TIUSRVPL(.TIUXDIEN,TIUIEN,MAGGP)
222 I TIUXDIEN D
223 . S FILEDATA("PARENT FILE PTR")=TIUXDIEN
224 . S $P(^MAG(2005,MAGGP,2),"^",8)=TIUXDIEN
225 . Q
226 E D Q ERRCODE ; fatal error
227 . K MSG
228 . S MSG(1)="ERROR ASSOCIATING WITH TIU EXTERNAL DATA LINK (file 8925.91):"
229 . S MSG(2)=$P(TIUXDIEN,"^",2,999)
230 . D BADERROR^MAGDIRVE($T(+0),"DICOM IMAGE PROCESSING ERROR",.MSG)
231 . S ERRCODE=-508
232 . Q
233 Q 0
234 ;
Note: See TracBrowser for help on using the repository browser.