source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGDRPC4.m@ 701

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

initial load of WorldVistAEHR
File size: 9.0 KB
Line 
1MAGDRPC4 ;WOIFO/EdM - Imaging RPCs ; 13 Feb 2006 1:42 PM
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 ;
20LOOKUP(OUT,NUMBER) ; RPC = MAG DICOM LOOKUP STUDY
21 ; Look Up for both Radiology and Consults
22 N ACCNUM ;--- Accession Number
23 N CPTCODE ;-- CPT code for the procedure
24 N CPTNAME ;-- CPT name for the procedure
25 N DFN ;------ Patient pointer
26 N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
27 N EXAMTYP ;-- Type of exam (Rad or Con)
28 N GMRCIEN ;-- Pointer for GMRC
29 N PROCDESC ;- Procedure description
30 N PROCIEN ;-- Radiology procedure IEN in ^RAMIS(71)
31 N RAIX ;----- cross reference subscript for case number lookup
32 N RADFN ;---- first level subscript in ^RADPT
33 N RADTI ;---- second level subscript in ^RADPT (after "DT")
34 N RACNI ;---- third level subscript in ^RADPT (after "P")
35 N RARPT ;---- Radiology Report pointer
36 N I,LIST,NOUT,X,Z
37 ;
38 K OUT S NOUT=1
39 I $G(NUMBER)="" S OUT(1)="-1,No Case or Consult Number Specified" Q
40 I $E(NUMBER,2)="`" D Q
41 . ; lookup the image by the IEN
42 . D IENLOOK^MAGDRPC9
43 . Q
44 ;
45 S EXAMTYP=$E(NUMBER,1)
46 I "RC"[EXAMTYP S NUMBER=$E(NUMBER,2,$L(NUMBER))
47 E S EXAMTYP=""
48 K DFN
49 D ; First try Radiology candidates
50 . I EXAMTYP'="",EXAMTYP'="R" Q
51 . D ; Look for the patient/study in ^RADPT using the Radiology Case Number
52 . . N RAIX ;----- cross reference subscript for case number lookup
53 . . S RAIX=$S($D(^RADPT("C")):"C",1:"AE") ; for Radiology Patch RA*5*7
54 . . S RAIX=$S(NUMBER["-":"ADC",1:RAIX) ; select the cross-reference
55 . . S RADFN=$O(^RADPT(RAIX,NUMBER,"")) I 'RADFN D Q:'RADFN
56 . . . I NUMBER'["-" S OUT(1)="-2,No Study Date Specified" Q
57 . . . S X=$P(NUMBER,"-",1)
58 . . . I $L(X)'=6 S OUT(1)="-3,Invalid study date """_X_"""." Q
59 . . . S SDATE=$S($E(X,5,6)<30:3,1:2)_$E(X,5,6)_$E(X,1,4)
60 . . . D:SDATE
61 . . . . ; Search 1-3 days prior the study date OR a day in advance but only
62 . . . . ; if the study date is not equal to today or greater than today.
63 . . . . ; Has to be long case number or must have an image study date
64 . . . . N %,%I,II,RCASE,TODAY,X,Y
65 . . . . S RCASE=$S(NUMBER["-":$P(NUMBER,"-",2),1:NUMBER) Q:'RCASE
66 . . . . D NOW^%DTC S TODAY=X
67 . . . . ;
68 . . . . ; 1-3 days prior study date
69 . . . . F II=1:1:3 S RADFN=$$FIND(SDATE,RCASE,-II) Q:RADFN
70 . . . . Q:RADFN
71 . . . . ;
72 . . . . ; Wild goose chase but check for today's case
73 . . . . S RADFN=$O(^RADPT("ADC",$$MMDDYY(TODAY)_"-"_RCASE,"")) Q:RADFN
74 . . . . ;
75 . . . . Q:SDATE'<TODAY
76 . . . . S RADFN=$$FIND(SDATE,RCASE,1) Q:RADFN ; Advance a day
77 . . . . ;
78 . . . . ; Finally just check the "C" or "AE" x-reference for the case number
79 . . . . ; based on RA*5*7 patch
80 . . . . S RADFN=$O(^RADPT($S($O(^RADPT("C","")):"C",1:"AE"),RCASE,""))
81 . . . . Q
82 . . . Q
83 . . S RADTI=$O(^RADPT(RAIX,NUMBER,RADFN,"")) Q:'RADTI
84 . . S RACNI=$O(^RADPT(RAIX,NUMBER,RADFN,RADTI,"")) Q:'RACNI
85 . . Q:'$D(^RADPT(RADFN,0)) ; No patient demographics file pointer
86 . . S DFN=$P(^RADPT(RADFN,0),"^",1)
87 . . Q
88 . Q:'$G(DFN)
89 . Q:'$D(^RADPT(DFN,"DT",RADTI,0))
90 . S RARPT=$P($G(^RADPT(DFN,"DT",RADTI,"P",RACNI,0)),"^",17) Q:'RARPT
91 . S ACCNUM=$P($G(^RARPT(RARPT,0)),"^",1)
92 . S I=0 F S I=$O(^RARPT(RARPT,2005,I)) Q:'I D
93 . . S X="74^"_RARPT_"^"_$P($G(^RARPT(RARPT,2005,I,0)),"^",1)_"^"_ACCNUM
94 . . S NOUT=NOUT+1,OUT(NOUT)=X
95 . . Q
96 . Q
97 ;
98 K DFN
99 D ; Now look for any consults that might qualify
100 . N ACCNUM,MAGIEN,MAGPTR,REPORTF,REPORTI,TIUIEN,TIUPTR,TIUXIEN
101 . I EXAMTYP'="",EXAMTYP'="C" Q
102 . S ACCNUM="GMRC-"_$S(NUMBER?1"GMRC-"1.N:$P(NUMBER,"GMRC-",2),1:NUMBER)
103 . S GMRCIEN=$P(ACCNUM,"-",2)
104 . D
105 . . N D0,Z
106 . . S D0=$P(ACCNUM,"-",2)
107 . . S DFN=$$GET1^DIQ(123,D0,.02,"I") Q:'DFN
108 . . S EXAMSTS=$$GET1^DIQ(123,D0,8) ; check for cancelled exam
109 . . I EXAMSTS="CANCELLED" S OUT(1)="-4,Consult is cancelled" Q
110 . . S PROCDESC=$$GET1^DIQ(123,D0,1)
111 . . S Z=$$GET1^DIQ(123,D0,13,"I") ; request type
112 . . Q
113 . I '$G(DFN) S OUT(1)="-5,Consult/procedure not on file" Q
114 . ; Find the images - they can be linked to TIU or imaging file 2006.5839
115 . S MAGPTR=$O(^MAG(2006.5839,"C",123,GMRCIEN,0))
116 . I MAGPTR D Q ; Found it in ^MAG(2006.5839 - not in ^TIU yet
117 . . S X=^MAG(2006.5839,MAGPTR,0)
118 . . S X=$P(X,"^",1)_"^"_$P(X,"^",2)_"^"_$P(X,"^",3)_"^"_ACCNUM
119 . . S NOUT=NOUT+1,OUT(NOUT)=X
120 . . Q
121 . D ; Otherwise find images in ^TIU
122 . . N I,X
123 . . D TIUALL^MAGDGMRC(GMRCIEN,.RESULT)
124 . . S I="" F S I=$O(RESULT(I)) Q:I="" D
125 . . . S X="8925^"_$P(RESULT(I),"^",1)_"^"_$P(RESULT(I),"^",3)_"^"_$P(RESULT(I),"^",2)
126 . . . S NOUT=NOUT+1,OUT(NOUT)=X
127 . . . Q
128 . . Q
129 . Q
130 S OUT(1)=NOUT-1
131 Q
132 ;
133NEXTIMG(OUT,FROM,SENT,CHECK) ; RPC = MAG DICOM GET NEXT QUEUE ENTRY
134 ; Get next file to be DICOM transmitted
135 N H,F1,F2,F3,I,JBTOHD,LOC,N,PRI,S0,S1,STS,TYPE,X
136 I $G(FROM)="" S OUT(1)="-1,No Origin Specified"
137 ; First clean up transmitted queue entries
138 S I="" F S I=$O(SENT(I)) Q:I="" D CLEAN^MAGDRPC9
139 S H=$$SECOND($H)
140 L +^MAGDOUTP(2006.574,"STS"):1E9 ; Background process MUST wait
141 I '$G(CHECK) D ; do only when called from a transmission process
142 . S PRI="" F S PRI=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI)) Q:PRI="" D
143 . . S S0="" F S S0=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI,"XMIT",S0)) Q:S0="" D
144 . . . S S1="" F S S1=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI,"XMIT",S0,S1)) Q:S1="" D
145 . . . . S X=$$SECOND($P($G(^MAGDOUTP(2006.574,S0,1,S1,0),"^^"_$H),"^",3))
146 . . . . Q:H-X<300
147 . . . . S $P(^MAGDOUTP(2006.574,S0,1,S1,0),"^",2)="WAITING"
148 . . . . K ^MAGDOUTP(2006.574,"STS",FROM,PRI,"XMIT",S0,S1)
149 . . . . S ^MAGDOUTP(2006.574,"STS",FROM,PRI,"WAITING",S0,S1)=""
150 . . . . Q
151 . . . Q
152 . . Q
153 . Q
154 S OUT(1)="",PRI=$O(^MAGDOUTP(2006.574,"STS",FROM,""),-1)
155 D:PRI'=""
156 . S S0="" F S S0=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI,"WAITING",S0)) Q:S0="" D Q:OUT(1)'=""
157 . . S S1="" F S S1=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI,"WAITING",S0,S1)) Q:S1="" D Q:OUT(1)'=""
158 . . . I '$G(CHECK) D ; do only when called from a transmission process
159 . . . . S $P(^MAGDOUTP(2006.574,S0,1,S1,0),"^",2,3)="XMIT^"_$H
160 . . . . K ^MAGDOUTP(2006.574,"STS",FROM,PRI,"WAITING",S0,S1)
161 . . . . S ^MAGDOUTP(2006.574,"STS",FROM,PRI,"XMIT",S0,S1)=""
162 . . . . Q
163 . . . S OUT(1)=1
164 . . . S OUT(2)=S0
165 . . . S OUT(3)=S1
166 . . . S X=$G(^MAGDOUTP(2006.574,S0,0))
167 . . . S OUT(4)=$P(X,"^",1) ; Application
168 . . . S OUT(5)=$P(X,"^",2) ; Group
169 . . . S OUT(6)=$P(X,"^",3) ; Accession Number
170 . . . S JBTOHD=+$P(X,"^",6)
171 . . . S OUT(7)=+$G(^MAGDOUTP(2006.574,S0,1,S1,0)) ; Image
172 . . . S OUT(8)=$P($G(^MAG(2005,+OUT(7),0)),"^",6)
173 . . . S TYPE=$S($G(^MAG(2005,+OUT(7),"FBIG"))'="":"BIG",1:"FULL")
174 . . . ; 3rd parameter set to 1 to allow retrieval from jukebox
175 . . . D FILEFIND^MAGDFB(+OUT(7),TYPE,1,0,.F1,.F2)
176 . . . S OUT(9)=F1
177 . . . S OUT(10)=F2
178 . . . S OUT(11)=$P($G(^MAG(2005,+OUT(5),0)),"^",7) ; get DFN
179 . . . ; get path for *.TXT, always the same as the FULL file
180 . . . D FILEFIND^MAGDFB(+OUT(7),"FULL",JBTOHD,0,.F1,.F3)
181 . . . S OUT(12)=F3
182 . . . Q
183 . . Q
184 . Q
185 S:OUT(1)="" OUT(1)="-2,Nothing to be transmitted."
186 L -^MAGDOUTP(2006.574,"STS")
187 Q
188 ;
189FIND(DATE,CASE,NUM) ;
190 ; Use the ADC x-reference in the radiology patient file
191 N NDATE,X,X1,X2,Y
192 S X1=DATE,X2=NUM D C^%DTC S NDATE=X
193 I NDATE<1 Q 0
194 S NDATE=$$MMDDYY(NDATE)
195 Q $O(^RADPT("ADC",NDATE_"-"_CASE,""))
196 ;
197MMDDYY(DAY) ; Convert Fileman date to mmddyy
198 I DAY'?7N Q 0
199 Q $E(DAY,4,7)_$E(DAY,2,3)
200 ;
201INIT(OUT,LOCATION) ; RPC = MAG DICOM QUEUE INIT
202 N D0,N,PRI,STS,STUID
203 I '$G(LOCATION) S OUT="-3,No origin specified." Q
204 I '$D(^MAGDOUTP(2006.574,0)) S OUT="-1,No entries at all in queue." Q
205 ;
206 S N=0
207 S PRI="" F S PRI=$O(^MAGDOUTP(2006.574,"STS",LOCATION,PRI)) Q:PRI="" D
208 . S STS="" F S STS=$O(^MAGDOUTP(2006.574,"STS",LOCATION,PRI,STS)) Q:STS="" D
209 . . S D0="" F S D0=$O(^MAGDOUTP(2006.574,"STS",LOCATION,PRI,STS,D0)) Q:D0="" D
210 . . . S STUID=$G(^MAGDOUTP(2006.574,D0,2))
211 . . . K ^MAGDOUTP(2006.574,D0)
212 . . . K:STUID'="" ^MAGDOUTP(2006.574,"STUDY",STUID,D0)
213 . . . K ^MAGDOUTP(2006.574,"STS",LOCATION,PRI,STS,D0)
214 . . . S N=N+1
215 . . . Q
216 . . Q
217 . Q
218 ;
219 I 'N S OUT="-2,No entries present for "_$$GET1^DIQ(4,LOCATION,.01)_"." Q
220 ;
221 S $P(^MAGDOUTP(2006.574,0),"^",4)=$P(^MAGDOUTP(2006.574,0),"^",4)-N
222 S OUT=N_" entr"_$S(N=1:"y",1:"ies")_" removed from Image Transmission Queue."
223 Q
224 ;
225SECOND(H) Q H*86400+$P(H,",",2)
226 ;
Note: See TracBrowser for help on using the repository browser.