source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGDGMRC.m@ 1096

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

initial load of WorldVistAEHR
File size: 6.7 KB
Line 
1MAGDGMRC ;WOIFO/PMK - Read a DICOM image file ; 12/15/2006 13:50
2 ;;3.0;IMAGING;**10,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 ; This is the set of GMRC APIs that are use by the VistA Imaging
19 ; DICOM Gateway
20 ;
21ANYREQ(DFN) ; check if any GMRC requests are present for the patient
22 N ADFN ; ---- array of DFNs to look up
23 N WRK ; ----- work array for our results
24 N IX ; ------ results lookup index
25 N FHIT ; ---- flag - any results for the pt?
26 ;
27 ; ask for requests for the patient
28 S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
29 S ADFN(1)=DFN
30 D FIND^DIC(123,,"@;.02I","QX",.ADFN,,"F",,,WRK,WRK)
31 ;
32 ; check returns to see if any are actually for this patient (see note
33 ; on SEARCH below)
34 S IX=0
35 F S IX=$O(@WRK@("DILIST","ID",IX)) Q:'IX D Q:$G(FHIT)
36 . I $G(@WRK@("DILIST","ID",IX,.02))=DFN S FHIT=1
37 . Q
38 K @WRK
39 Q +$G(FHIT)
40 ;
41TIULAST(GMRCIEN) ; find the ien of the most recent TIU note for this request
42 N TIUIEN
43 N WRK ; root of work global
44 S TIUIEN=0
45 I GMRCIEN D ; look for the most recent TIU note for this request
46 . ; set up the array to look through
47 . S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
48 . D LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
49 . ; traverse the array
50 . N TIUPTR
51 . S TIUPTR=" " ; setup for reverse $o from space (" ")
52 . F S TIUPTR=$O(@WRK@("DILIST","ID",TIUPTR),-1) Q:'TIUPTR D Q:TIUIEN
53 . . S TIUIEN=$P($G(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
54 . . I $P(TIUIEN,";",2)'="TIU(8925," S TIUIEN=0 ; not a TIU document
55 . . Q
56 . Q
57 K @WRK
58 Q +TIUIEN
59 ;
60TIUALL(GMRCIEN,RESULT) ; find all IENs for the TIU notes for this request
61 N MAGIEN,TIUIEN,TIUPTR,TIUXIEN,Y
62 N WRK ; root of work global
63 K RESULT
64 ; set up the array to look through
65 S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
66 D LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
67 ; traverse the array
68 S (RESULT,TIUPTR)=0
69 F S TIUPTR=$O(@WRK@("DILIST","ID",TIUPTR)) Q:'TIUPTR D
70 . S TIUIEN=$P($G(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
71 . I $P(TIUIEN,";",2)'="TIU(8925," Q ; not a TIU document
72 . S TIUIEN=+TIUIEN ; strip off variable pointer stuff
73 . S TIUXIEN=""
74 . F S TIUXIEN=$O(^TIU(8925.91,"B",TIUIEN,TIUXIEN)) Q:'TIUXIEN D
75 . . S Y=$G(^TIU(8925.91,TIUXIEN,0)) Q:'Y
76 . . S MAGIEN=$P(Y,"^",2)
77 . . S RESULT=RESULT+1
78 . . S RESULT(RESULT)=TIUIEN_"^GMRC-"_GMRCIEN_"^"_MAGIEN
79 . . Q
80 . Q
81 K @WRK
82 Q
83 ;
84FWDFROM(GMRCIEN) ; for a forwarded request, determine the FORWARD FROM service
85 N FWDFROM,I
86 N WRK ; root of work global
87 ; set up the array to look through
88 S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
89 D LIST^DIC(123.02,","_GMRCIEN_",",".01I;6I",,,,,,,,WRK,WRK)
90 ; traverse the array
91 S FWDFROM=0
92 I GMRCIEN D
93 . S I=$O(@WRK@("DILIST","ID"," "),-1)
94 . I I D ; get the FORWARDED FROM service
95 . . S FWDFROM=$G(@WRK@("DILIST","ID",I,6))
96 . . Q
97 . Q
98 K @WRK
99 Q +FWDFROM
100 ;
101UNSIGNED(GMRCIEN) ; check if there are any unsigned TIU notes for the request
102 N TIUPTR,NRESULTS,TIUSTAT,UNSIGNED,X
103 N WRK ; root of work global
104 ; set up the array to look through
105 S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
106 D LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
107 S UNSIGNED=0,TIUPTR=""
108 ; traverse the array, check all associated results, bail if any unsigned
109 F S TIUPTR=$O(@WRK@("DILIST","ID",TIUPTR)) Q:'TIUPTR D Q:UNSIGNED
110 . S X=$P($G(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
111 . ; if TIU note, check if unsigned
112 . I X?.N1";TIU(8925," D ; check status of TIU note for completion
113 . . ; status in ^TIU(8925.6) - use first 5 "UNs" per Margy McClenanhan
114 . . S TIUSTAT=$$GET1^DIQ(8925,+X,.05,"I")
115 . . I TIUSTAT,TIUSTAT<6 S UNSIGNED=1 ; got one!
116 . . Q
117 . Q
118 K @WRK
119 Q UNSIGNED
120 ;
121SEARCH(DFN,CUTOFF,CLINIC,REQUEST) ; search for requests for a given clinic
122 ;
123 ; It is a bit of a trick to determine if a given appointment is for
124 ; an existing GMRC request. This determination is performed by using
125 ; an association between the SERVICE for the request and the CLINIC
126 ; where the request is to be performed.
127 ;
128 ; This subroutine passes all of the (recent) requests for a patient and
129 ; builds a list of those that can be performed in the designated clinic.
130 ;
131 ; Maybe the replacement for Appointment Management and future versions
132 ; of CPRS Order Entry and Consult Request Tracking will capable of
133 ; correctly maintaining this essential association.
134 ;
135 N GMRIDX,GMRC0,GMRCDATE,GMRCIEN,SERVICE,STATUS
136 N WRK ; --- root of results global
137 N ADFN ; -- array for DFNs to look up
138 K REQUEST S REQUEST=0
139 I 'DFN Q ; no patient number provided
140 ; build the array of results
141 ; Note the use of the "Q[uick]" flag to allow lookup by *internal* DFN.
142 ; However, even though we define ADFN(1) to force lookup on the *first*
143 ; level subscript of the F index only, FileMan also looks up on the IEN
144 ; directly (because there is a .001 field defined in the DD of File
145 ; #123). So we grab the DFN in the .02 field for later double-
146 ; checking.
147 ;
148 S ADFN(1)=DFN
149 S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
150 D FIND^DIC(123,,"@;.02I;1I;3I;5I;8I","QX",.ADFN,,"F",,,WRK,WRK)
151 ; traverse the results
152 S GMRIDX=""
153 F S GMRIDX=$O(@WRK@("DILIST","ID",GMRIDX)) Q:'GMRIDX D
154 . S GMRCIEN=+$G(@WRK@("DILIST",2,GMRIDX))
155 . I $G(@WRK@("DILIST","ID",GMRIDX,.02))'=DFN Q ; not for this patient!
156 . I $G(@WRK@("DILIST","ID",GMRIDX,3))<CUTOFF Q ; too far back
157 . S SERVICE=$G(@WRK@("DILIST","ID",GMRIDX,1)) Q:SERVICE=""
158 . I '$$ISCLINIC^MAGDGMRC(SERVICE,CLINIC) Q ; not a service or clinic
159 . S STATUS=$G(@WRK@("DILIST","ID",GMRIDX,8)) ; CPRS status
160 . I STATUS S STATUS=$$GET1^DIQ(100.01,STATUS,.1) ; CPRS status abbrev
161 . S REQUEST=$G(REQUEST)+1
162 . S REQUEST(REQUEST)=GMRCIEN_"^"_SERVICE_"^"_STATUS
163 . Q
164 K @WRK
165 Q
166 ;
167ISCLINIC(SERVICE,CLINIC) ; is a particular clinic defined for a given service?
168 ; this entry point is called by ^MAGDGMRC as well as below
169 N ISCLINIC
170 S ISCLINIC=0
171 I SERVICE,CLINIC,$D(^MAG(2006.5831,SERVICE,1,"B",CLINIC)) S ISCLINIC=1
172 Q ISCLINIC
173 ;
Note: See TracBrowser for help on using the repository browser.