| 1 | MAGDHWC ;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 | ;;
|
|---|
| 18 | ENTRY ;
|
|---|
| 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 | ;
|
|---|
| 116 | SERVICE ; 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 | ;
|
|---|
| 132 | DIVISION(Y) ;
|
|---|
| 133 | S DIVISION=$P(Y,"^",3)
|
|---|
| 134 | S DIVISION=DIVISION_DEL2_$S(DIVISION:$$GET1^DIQ(4,DIVISION,.01),1:"")
|
|---|
| 135 | Q
|
|---|
| 136 | ;
|
|---|
| 137 | APPOINT ; 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 | ;
|
|---|
| 167 | APPOINT1 ; 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 | ;
|
|---|
| 175 | OBX() ; 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 | ;
|
|---|
| 183 | OBX1 ; 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
|
|---|
