source: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGDRPC3.m@ 1120

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

WorldVistAEHR overlayed on FOIAVistA
File size: 8.3 KB
Line 
1MAGDRPC3 ;WOIFO/EdM - Imaging RPCs ; 12/15/2006 13:50
2 ;;3.0;IMAGING;**11,30,51,50,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 ;
20RADLKUP(OUT,CASENUMB,STUDYDAT) ; RPC = MAG DICOM LOOKUP RAD STUDY
21 ; Radiology patient/study lookup
22 N ACCNUM ;--- Accession Number
23 N CPTCODE ;-- CPT code for the procedure
24 N CPTNAME ;-- CPT name for the procedure
25 N DATETIME ;- Timestamp
26 N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
27 N PROCDESC ;- Procedure description
28 N PROCIEN ;-- radiology procedure ien in ^RAMIS(71)
29 N RAIX ;----- cross reference subscript for case number lookup
30 N RADPT1 ;--- first level subscript in ^RADPT
31 N RADPT2 ;--- second level subscript in ^RADPT (after "DT")
32 N RADPT3 ;--- third level subscript in ^RADPT (after "P")
33 N D1,I,LIST,X,Z
34 ;
35 ; find the patient/study in ^RADPT using the Radiology Case Number
36 K OUT
37 D
38 . I $G(CASENUMB)="" S OUT(1)="-1,No Case Number Specified" Q
39 . S RAIX=$S($D(^RADPT("C")):"C",1:"AE") ; for Radiology Patch RA*5*7
40 . S RAIX=$S(CASENUMB["-":"ADC",1:RAIX) ; select the cross-reference
41 . S RADPT1=$O(^RADPT(RAIX,CASENUMB,"")) I 'RADPT1 D Q:'RADPT1
42 . . I '$G(STUDYDAT) S OUT(1)="-2,No Study Date Specified",RADPT1=0 Q
43 . . ;
44 . . ; Search 1-3 days prior the study date OR a day in advance but only
45 . . ; if the study date is not equal to today or greater than today.
46 . . ; Has to be long case number or must have an image study date
47 . . ;
48 . . N II,RCASE,SDATE,TODAY,X,Y,%,%I
49 . . ;
50 . . S RCASE=$S(CASENUMB["-":$P(CASENUMB,"-",2),1:CASENUMB)
51 . . I 'RCASE S RADPT1=0 Q
52 . . ;
53 . . D NOW^%DTC S TODAY=X
54 . . S X=$P(STUDYDAT,"."),SDATE=$E(X,1,4)-1700_$E(X,5,8) ; FileMan date
55 . . ;
56 . . ; 1-3 days prior study date
57 . . F II=1:1:3 S RADPT1=$$FIND(SDATE,RCASE,-II) Q:RADPT1
58 . . Q:RADPT1
59 . . ;
60 . . ; Wild goose chase, but check for today's case
61 . . S RADPT1=$O(^RADPT("ADC",$$MMDDYY(TODAY)_"-"_RCASE,"")) Q:RADPT1
62 . . ;
63 . . I SDATE'<TODAY S RADPT1=0 Q
64 . . ;
65 . . ; One day in advance?
66 . . S RADPT1=$$FIND(SDATE,RCASE,1) Q:RADPT1
67 . . ;
68 . . ; Finally just check the "C" or "AE" x-reference for the case number
69 . . S X=$S($O(^RADPT("C","")):"C",1:"AE") ; RA*5*7 patch
70 . . S RADPT1=$O(^RADPT(X,RCASE,""))
71 . . Q
72 . S RADPT2=$O(^RADPT(RAIX,CASENUMB,RADPT1,"")) Q:'RADPT2
73 . S RADPT3=$O(^RADPT(RAIX,CASENUMB,RADPT1,RADPT2,"")) Q:'RADPT3
74 . Q:'$D(^RADPT(RADPT1,0)) ; no patient demographics file pointer
75 . ; get patient demographics file pointer
76 . S DFN=$P(^RADPT(RADPT1,0),"^",1)
77 . Q:'$D(^RADPT(RADPT1,"DT",RADPT2,0)) ; no datetime level
78 . ; get date and time of examination
79 . S DATETIME=$P($G(^RADPT(RADPT1,"DT",RADPT2,0)),"^",1)
80 . ; get case info
81 . S X=$G(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0))
82 . S Z=$P(X,"^",17) I Z S Z=$P($G(^RARPT(Z,0)),"^",1) S:Z'="" ACCNUM=Z
83 . S PROCIEN=$P(X,"^",2),EXAMSTS=$P(X,"^",3)
84 . S:EXAMSTS EXAMSTS=$$GET1^DIQ(72,EXAMSTS,.01)
85 . S (PROCDESC,CPTNAME,CPTCODE)=""
86 . Q:'PROCIEN ; need PROCIEN to do lookup in ^RAMIS
87 . S Z=$G(^RAMIS(71,PROCIEN,0))
88 . S PROCDESC=$P(Z,"^",1),CPTCODE=$P(Z,"^",9)
89 . S CPTNAME=$P($$CPT^ICPTCOD(+CPTCODE),"^",3) ; IA 1995
90 . S:CPTNAME="" CPTNAME=PROCDESC
91 . Q
92 S OUT(2)=$G(RADPT1)
93 S OUT(3)=$G(RADPT2)
94 S OUT(4)=$G(RADPT3)
95 S OUT(5)=$G(PROCIEN)
96 S OUT(6)=$G(CPTCODE)
97 S OUT(7)=$G(CPTNAME)
98 S OUT(8)=$G(Z)
99 S OUT(9)=$G(EXAMSTS)
100 S OUT(10)=$G(DFN)
101 S OUT(11)=$G(DATETIME)
102 S OUT(12)=$G(PROCDESC)
103 S X=""
104 I $G(PROCIEN) S D1=0 F S D1=$O(^RAMIS(71,PROCIEN,"MDL",D1)) Q:'D1 D
105 . S Z=+$P($G(^RAMIS(71,PROCIEN,"MDL",D1,0)),"^",1) Q:'Z
106 . S Z=$P($G(^RAMIS(73.1,Z,0)),"^",1) Q:Z=""
107 . S:X'="" X=X_"," S X=X_Z
108 . Q
109 S OUT(13)=X ; List of Modality-codes
110 S X="" I $G(RADPT1),$G(RADPT2) S X=$G(^RADPT(RADPT1,"DT",RADPT2,0))
111 S OUT(14)=$P(X,"^",3) ; Site
112 ; Patient's pregnancy status at the time of the exam
113 S X="" I $G(DFN),$G(RADPT2),$G(RADPT3) S X=$G(^RADPT(DFN,"DT",RADPT2,"P",RADPT3,0))
114 S OUT(15)=$P($G(^RAO(75.1,+$P(X,"^",11),0)),"^",13)
115 S OUT(16)=$G(ACCNUM)
116 S OUT(1)=1 ; OK
117 Q
118 ;
119QUEUE(OUT,IMAGE,APPNAM,LOCATION,ACCNUM,REASON,EMAIL,PRIOR,JBTOHD) ; RPC = MAG DICOM QUEUE IMAGE
120 ; Add the DICOM study send image request to the queue
121 N COUNT,D0,D1,DFN,LOG,OK,PROBLEM,TYPE,X
122 ;
123 I '$G(IMAGE) S OUT="-1,No Image specified" Q
124 I $G(APPNAM)="" S OUT="-2,No Destination specified" Q
125 I '$G(LOCATION) S OUT="-3,No Origin specified" Q
126 S PRIOR=+$G(PRIOR) S:'PRIOR PRIOR=500
127 S JBTOHD=$S($G(JBTOHD):1,1:0)
128 ;
129 S X=$G(^MAG(2005,IMAGE,0))
130 S TYPE=+$P(X,"^",6),DFN=$P(X,"^",7)
131 I " 0 11 3 100 "'[(" "_TYPE_" ") D Q
132 . S OUT="-4,Cannot Queue Image Object Type """_TYPE_"""."
133 . Q
134 ;
135 L +^MAGDOUTP(2006.574,0):19 ; Background process MUST wait
136 S P=$P($G(^MAG(2005,IMAGE,0)),"^",10),P=$S(P:P,1:IMAGE)
137 S STUID=$P($G(^MAG(2005,P,"PACS")),"^",1) S:STUID="" STUID="?"
138 S OK=0,D0="" F S D0=$O(^MAGDOUTP(2006.574,"STUDY",STUID,D0)) Q:'D0 D Q:OK
139 . Q:'$D(^MAGDOUTP(2006.574,"STS",LOCATION,PRIOR,"WAITING",D0))
140 . Q:$P($G(^MAGDOUTP(2006.574,D0,0)),"^",1)'=APPNAM
141 . S OK=D0
142 . Q
143 S D0=OK D:'D0
144 . S X=$G(^MAGDOUTP(2006.574,0))
145 . S $P(X,"^",1,2)="DICOM IMAGE OUTPUT FILE^2006.574"
146 . S D0=$O(^MAGDOUTP(2006.574," "),-1)+1 ; Next number
147 . S $P(X,"^",3)=D0
148 . S $P(X,"^",4)=$P(X,"^",4)+1 ; Total count
149 . S ^MAGDOUTP(2006.574,0)=X
150 . ;
151 . S ^MAGDOUTP(2006.574,D0,0)=APPNAM_"^"_P_"^"_$G(ACCNUM)_"^"_LOCATION_"^"_PRIOR_"^"_JBTOHD
152 . S ^MAGDOUTP(2006.574,D0,2)=STUID
153 . S ^MAGDOUTP(2006.574,"STUDY",STUID,D0)=""
154 . Q
155 L -^MAGDOUTP(2006.574,0)
156 ;
157 S COUNT=0,PROBLEM=3
158 I (TYPE=3)!(TYPE=100) D ; Single XRAY or DICOM image
159 . S COUNT=COUNT+$$ENQUEUE(IMAGE,D0,PRIOR)
160 . Q
161 I TYPE=11 D ; Process all the images in an XRAY group
162 . S D1=0 F S D1=$O(^MAG(2005,IMAGE,1,D1)) Q:'D1 D
163 . . S COUNT=COUNT+$$ENQUEUE($P($G(^MAG(2005,IMAGE,1,D1,0)),"^",1),D0,PRIOR)
164 . . Q
165 . Q
166 ;
167 S LOG="DICOM transmit to "_APPNAM_" for reason "_REASON
168 D:COUNT ENTRY^MAGLOG($C(REASON+64),DUZ,IMAGE,"DICOM Gateway",DFN,COUNT,LOG)
169 D:PROBLEM>3
170 . N XMERR,XMID,XMSUB,XMY
171 . S PROBLEM(1)="Error while queueing image for Transmission:"
172 . S PROBLEM(2)=LOG
173 . S PROBLEM(3)=" "
174 . ; --- send MailMan message...
175 . S XMID=$G(DUZ) S:'XMID XMID=.5
176 . S XMY(XMID)=""
177 . S:$G(EMAIL)'="" XMY(EMAIL)=""
178 . S XMSUB=$E("Cannot transmit image(s) to "_APPNAM,1,63)
179 . D SENDMSG^XMXAPI(XMID,XMSUB,"PROBLEM",.XMY,,.XMZ,)
180 . Q:'$G(XMERR)
181 . M XMERR=^TMP("XMERR",$J) S $EC=",U13-Cannot send MailMan message,"
182 . Q
183 S OUT=1
184 Q
185 ;
186ENQUEUE(IMAGE,D0,PRIOR) ; Add an image to the DICOM send image request queue sub-file
187 Q:'IMAGE 0
188 N D1,I,OLD,X
189 D CHK^MAGGSQI(.X,IMAGE) I +$G(X(0))'=1 D Q 0
190 . S PROBLEM=PROBLEM+1,PROBLEM(PROBLEM)=" "
191 . S PROBLEM=PROBLEM+1,PROBLEM(PROBLEM)="Image # "_IMAGE_":"
192 . S I="" F S I=$O(X(I)) Q:I="" S PROBLEM=PROBLEM+1,PROBLEM(PROBLEM)=X(I)
193 . Q
194 ;
195 ; Enter each image at most once in each transmission request
196 S (D1,OLD)=0 F S D1=$O(^MAGDOUTP(2006.574,D0,1,D1)) Q:'D1 D Q:OLD
197 . S:$P($G(^MAGDOUTP(2006.574,D0,1,D1,0)),"^",1)=IMAGE OLD=1
198 . Q
199 Q:OLD 1
200 ;
201 L +^MAGDOUTP(2006.574,D0,1,0):19 ; Background Process MUST wait
202 S X=$G(^MAGDOUTP(2006.574,D0,1,0))
203 S $P(X,"^",1,2)="^2006.5744"
204 S D1=$O(^MAGDOUTP(2006.574,D0,1," "),-1)+1,$P(X,"^",3)=D1
205 S $P(X,"^",4)=$P(X,"^",4)+1,OUT=$P(X,"^",4)
206 S ^MAGDOUTP(2006.574,D0,1,0)=X
207 S ^MAGDOUTP(2006.574,D0,1,D1,0)=IMAGE_"^WAITING^"_$H
208 S ^MAGDOUTP(2006.574,"STS",LOCATION,PRIOR,"WAITING",D0,D1)=""
209 L -^MAGDOUTP(2006.574,D0,1,0)
210 Q 1
211 ;
212FIND(DATE,CASE,NUM) ; ADC x-reference (Radiology patient file)
213 N X,X1,X2,Y
214 Q:'$G(DATE) 0
215 S (X,X1)=DATE,X2=NUM D:NUM C^%DTC Q:X<1 0
216 Q $O(^RADPT("ADC",$$MMDDYY(X)_"-"_CASE,""))
217 ;
218MMDDYY(DAY) ; YYYMMDD --> MMDDYY
219 I DAY'?7N Q 0
220 Q $E(DAY,4,7)_$E(DAY,2,3)
221 ;
Note: See TracBrowser for help on using the repository browser.