source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGDHWC.m@ 1046

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

initial load of WorldVistAEHR
File size: 7.2 KB
Line 
1MAGDHWC ;WOIFO/PMK - Capture Consult/Procedure Request data ; 24 Jan 2006 11:50 AM
2 ;;3.0;IMAGING;**10,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 ;;
18ENTRY ;
19 ; determine the kind of message and branch appropriately
20 N %,APTSCHED,CONSULT,DATETIME,DEL,DEL2,DEL3,DEL4,DEL5,DFN
21 N DIVISION,FILLER1,FWDFROM,FMDATE,FMDATETM,GMRCIEN,HL,HL7,HL7ORC,HL7REC
22 N I,IGNORE,ITYPCODE,ITYPNAME,IGNORE,MSGTYPE,OBXSEGNO,ORIGSERV,SERVICE,X,Y,Z
23 I $D(GMRCMSG) M HL7=GMRCMSG
24 E I $D(XQORHSTK(0)) M HL7=XQORHSTK(0)
25 E Q ; can't find HL7 data to handle this!
26 S HL7REC=HL7(1)
27 S DEL=$E(HL7REC,4),X=$P(HL7REC,DEL,2)
28 F I=1:1:$L(X) S @("DEL"_(I+1))=$E(X,I)
29 D NOW^%DTC S FMDATE=%\1,FMDATETM=%
30 ;
31 ; find PID segment and get the DFN
32 S I=0 I '$$FINDSEG^MAGDHW0(.HL7,"PID",.I,.X) Q ; no PID segment
33 S DFN=$P(X,DEL,3)
34 ;
35 ; find ORC segment and get GMRCIEN
36 S I=0 I '$$FINDSEG^MAGDHW0(.HL7,"ORC",.I,.HL7ORC) Q ; no ORC segment
37 S GMRCIEN=+$P(HL7ORC,DEL,3) ; GMRC request is in ^GMR(123,GMRCIEN,...)
38 ;
39 D ^MAGDTR01 ; update the Read/Unread list with the data from the HL7 message
40 ;
41 S IGNORE=1 ; decide if service is one that requires HL7->DICOM gateway
42 ;
43 ; find ORC segment and check for an "OK" order control value
44 I $P(HL7ORC,DEL)="OK" D Q ; generate message by ^MAGDHWS
45 . S SERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
46 . D SERVICE ; send this transaction to the DICOM gateway?
47 . I 'IGNORE D
48 . . D INIT^MAGDHW0 ; initialize variables
49 . . S DATETIME=""
50 . . D MESSAGE^MAGDHWS("O") ; indicates new order
51 . . Q
52 . Q
53 ;
54 I " CA CR DR OC OD "[(" "_$P(HL7ORC,DEL)_" ") D Q ; Discontinued order
55 . S SERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
56 . D SERVICE ; send this transaction to the DICOM gateway?
57 . I 'IGNORE D
58 . . D INIT^MAGDHW0 ; initialize variables
59 . . S DATETIME=""
60 . . D MESSAGE^MAGDHWS("C") ; Cancelled/Discontinued order
61 . . Q
62 . Q
63 ;
64 ; check for a FORWARD in the ORC segment
65 I $P($P(HL7ORC,DEL,16),DEL2,5)="FORWARD" D
66 . ; get previous service from REQUEST PROCESSING ACTIVITY
67 . S FWDFROM=$$FWDFROM^MAGDGMRC(GMRCIEN) ; FORWARDED FROM service
68 . S Y=0 I FWDFROM S Y=$G(^MAG(2006.5831,FWDFROM,0))
69 . I Y D ; forwarded from location was one in the service group
70 . . N DIVISION,Z
71 . . ; original service request probably was sent to DICOM Gateway
72 . . S ORIGSERV=DEL2_DEL2_DEL2_FWDFROM_DEL2
73 . . S ORIGSERV=ORIGSERV_$S(FWDFROM:$$GET1^DIQ(123.5,FWDFROM,.01),1:"")
74 . . S ORIGSERV=ORIGSERV_DEL2_"99CON"
75 . . D DIVISION(Y)
76 . . S Z=$P(Y,"^",2)
77 . . S ITYPNAME=$P(^MAG(2005.84,Z,0),"^",1)
78 . . S ITYPCODE=$P(^MAG(2005.84,Z,2),"^",1)
79 . . S ORIGSERV=ORIGSERV_DEL_ITYPCODE_DEL2_ITYPNAME_DEL2_DIVISION
80 . . S (ITYPCODE,ITYPNAME)="" ; may need them nulled in ZSV^MAGDHWA
81 . . S IGNORE=0
82 . . Q
83 . Q
84 ;
85 ; find ZSV segment and requested service - check if appropriate
86 S I=0 I '$$FINDSEG^MAGDHW0(.HL7,"ZSV",.I,.X) Q ; no ZSV segment
87 S SERVICE=$P($P(X,DEL),DEL2,4)
88 D SERVICE ; send this transaction to the DICOM gateway?
89 I IGNORE Q ; just ignore HL7 message, don't send it to DICOM gateway
90 ;
91 S Z=$P(HL7ORC,DEL,1) ; Order Control
92 S Y=$P(HL7ORC,DEL,5) ; Order Status
93 I Z="SC" S MSGTYPE="RECEIVED" ; received
94 E I Z="RE" D ; result
95 . I Y="A" S MSGTYPE="PARTIAL RESULT" ; unsigned TIU note
96 . E I Y="CM" D ; check for a new unsigned note
97 . . I $$UNSIGNED^MAGDGMRC(GMRCIEN) D
98 . . . S MSGTYPE="PARTIAL RESULT" ; unsigned TIU note
99 . . . S FILLER1="GMRC-NEW UNSIGNED RESULT"
100 . . . Q
101 . . E S MSGTYPE="COMPLETE RESULT" ; signed TIU note
102 . . Q
103 . Q
104 E S MSGTYPE="UNKNOWN"
105 D MSH^MAGDHWA,PID^MAGDHWA,ORC^MAGDHWA,OBR^MAGDHWA,ZSV^MAGDHWA
106 I '$$OBX() D ; get OBX segment from database
107 . S I=$O(HL7(""),-1)+1 S I=$$OBX^MAGDHWS(I)
108 . Q
109 E D ; process existing OBX segment
110 . D OBX1
111 . Q
112 D ALLERGY^MAGDHWA,POSTINGS^MAGDHWA
113 D OUTPUT^MAGDHW0
114 Q
115 ;
116SERVICE ; check if the service is in the DICOM Clinical Service dictionary
117 N Y
118 I SERVICE D ; ignore SERVICE if it is null
119 . S Y=$G(^MAG(2006.5831,SERVICE,0))
120 . S DIVISION=DEL2
121 . I Y D ; new service is of interest to DICOM Gateway
122 . . D DIVISION(Y)
123 . . S Z=$P(Y,"^",2)
124 . . S ITYPNAME=$P(^MAG(2005.84,Z,0),"^",1)
125 . . S ITYPCODE=$P(^MAG(2005.84,Z,2),"^",1)
126 . . S IGNORE=0
127 . . D APPOINT
128 . . Q
129 . Q
130 Q
131 ;
132DIVISION(Y) ;
133 S DIVISION=$P(Y,"^",3)
134 S DIVISION=DIVISION_DEL2_$S(DIVISION:$$GET1^DIQ(4,DIVISION,.01),1:"")
135 Q
136 ;
137APPOINT ; quite often the appointment is entered before the order is entered
138 ; if this is the case, see if we can find the corresponding appointment
139 N CLINIC,HIT,I,LOCIEN,ORDERIEN,VASD,XE,XI
140 ; look for appointments for today or later - don't need VASD parameters
141 D SDA^VADPT ; get the list of the appointments
142 ; first check the order record for the patient location
143 ; it might be the clinic for the appointment
144 S HIT=0 ; indicator for finding an appointment match
145 S ORDERIEN=$$GET1^DIQ(123,GMRCIEN,.03,"I")
146 S LOCIEN=$S(ORDERIEN:$$GET1^DIQ(100,ORDERIEN,6,"I"),1:"")
147 I LOCIEN?1N.N1";SC(" D
148 . S CLINIC=+LOCIEN
149 . I $$ISCLINIC^MAGDGMRC(SERVICE,CLINIC) D
150 . . S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I Q:HIT D
151 . . . S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E")
152 . . . ; check if there is an appointment in this clinic
153 . . . I CLINIC=$P(XI,"^",2) D APPOINT1 ; select first apt. in clinic
154 . . . Q
155 . . Q
156 . Q
157 I 'HIT D ; no appointment for the pt. location, look for other clinics
158 . S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I Q:HIT D
159 . . S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E")
160 . . S CLINIC=$P(XI,"^",2)
161 . . I $$ISCLINIC^MAGDGMRC(SERVICE,CLINIC) D APPOINT1
162 . . Q
163 . Q
164 K ^UTILITY("VASD",$J)
165 Q
166 ;
167APPOINT1 ; fill the appointment schedule array
168 S APTSCHED("FM DATETIME")=$P(XI,"^")
169 S APTSCHED("CLINIC IEN")=CLINIC
170 S APTSCHED("DATETIME")=$P(XE,"^")
171 S APTSCHED("CLINIC NAME")=$P(XE,"^",2)
172 S HIT=1 ; to exit loop
173 Q
174 ;
175OBX() ; find OBX segments to determine the highest value of OBXSEGNO
176 N I,X
177 S OBXSEGNO=0
178 S I=0 F D Q:I="" ; $o through HL7 message - quit when at end
179 . I $$FINDSEG^MAGDHW0(.HL7,"OBX",.I,.X) S OBXSEGNO=$P(X,DEL,1)
180 . Q
181 Q OBXSEGNO
182 ;
183OBX1 ; if there are second level OBX data, add OBX segment prefix
184 N I,J
185 ; add additional OBX segments to convey the Reason for the Request
186 ; more than one, so can't use "I $$FINDSEG^MAGDHW0(.HL7,"OBX",.I) D "
187 S I="" F S I=$O(HL7(I)) Q:I="" I $P(HL7(I),DEL)="OBX" D
188 . I '$D(HL7(I,1)) Q ; no additional OBX segments needed
189 . S X=$P(HL7(I),DEL,1,5) ; copy pieces 1-5 to other segments
190 . S J="" F S J=$O(HL7(I,J)) Q:'J S HL7(I,J)=X_DEL_HL7(I,J)
191 . Q
192 Q
Note: See TracBrowser for help on using the repository browser.