source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGDHWA.m@ 1147

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

initial load of WorldVistAEHR

File size: 7.6 KB
Line 
1MAGDHWA ;WOIFO/PMK - Capture Consult/Request data ; 12 Jul 2005 2:32 PM
2 ;;3.0;IMAGING;**10,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 ; entry points called by both ^MAGDHWC and ^MAGDHWS
20 ;
21MSH ; update MSH segment
22 S $P(HL7(1),DEL,5)="VI-CONSULT" ; receiving application
23 S $P(HL7(1),DEL,6)=$P(HL7(1),DEL,4) ; receiving facility
24 S $P(HL7(1),DEL,7)=$$FMTHL7^XLFDT(FMDATETM)
25 Q
26 ;
27PID ; update PID & PV1 segments
28 N ADDRESS,FIRSTNAM,GEOLOC,I,J,LASTNAME,MIDNAME,PNAME
29 N VA,VADM,VAIN,VAPA,VAERR,X,WARD,Z
30 ; update PID segment
31 S I=0 I $$FINDSEG^MAGDHW0(.HL7,"PID",.I,.X) D
32 . S DFN=$P(X,DEL,3) D ; protect I and X
33 . . N %,DIQUIET,I,IO,X
34 . . S DIQUIET=1 D DEM^VADPT,ADD^VADPT,INP^VADPT
35 . . Q
36 . S ADDRESS=VAPA(1) ; construct the patient's address string
37 . F J=2:1:3 I VAPA(J)'="" S ADDRESS=ADDRESS_"^"_VAPA(J)
38 . S GEOLOC=VAPA(4)_"^"_$P(VAPA(5),"^")_"^"_VAPA(6) ; city, state & zip
39 . ; stuff the data into the segment
40 . S $P(X,DEL,2)=VA("PID") ; patient id - ssn
41 . S $P(X,DEL,4)=$E(VADM(1))_VA("BID") ; alt. patient id - quick pid
42 . ; format patient name: last~first~middle
43 . S LASTNAME=$P(VADM(1),","),Z=$P(VADM(1),",",2,999)
44 . S FIRSTNAM=$P(Z," ",1),MIDNAME=$TR($P(Z," ",2,999),".")
45 . S $P(X,DEL,5)=LASTNAME_DEL2_FIRSTNAM_DEL2_MIDNAME ; patient name
46 . S $P(X,DEL,7)=17000000+VADM(3) ; dob
47 . S $P(X,DEL,8)=$P(VADM(5),"^") ; sex
48 . S $P(X,DEL,10)=DEL2_$P($G(VADM(12,1)),"^",2) ; race
49 . S $P(X,DEL,11)=$$HLADDR^HLFNC(ADDRESS,GEOLOC,DEL2)
50 . S $P(X,DEL,13)=VAPA(8)_DEL2_"PRN" ; primary phone number
51 . S $P(X,DEL,19)=$P(VADM(2),"^") ; ssn (without dashes)
52 . D SAVESEG^MAGDHW0(I,X)
53 . Q
54 ;
55 ; update PV1 segment for inpatients only
56 S I=0 I $$FINDSEG^MAGDHW0(.HL7,"PV1",.I,.X) D
57 . ; get assigned patient location
58 . I VAIN(1) D ; inpatient code
59 . . S $P(X,DEL,2)="I" ; inpatient flag
60 . . ; assigned patient location
61 . . S Z=$TR(VAIN(4),"^",DEL5)_DEL5_"VISTA42"
62 . . S $P(X,DEL,3)=Z_DEL2_$TR(VAIN(5),"-",DEL2)
63 . . ; attending physician
64 . . S $P(X,DEL,7)=$TR(VAIN(2),"^, ",DEL2_DEL2_DEL2)
65 . . ; referring (primary care) physician
66 . . S $P(X,DEL,8)=$TR(VAIN(11),"^, ",DEL2_DEL2_DEL2)
67 . . ; hospital service
68 . . S $P(X,DEL,10)=$TR(VAIN(3),"^",DEL2)
69 . . ; visit number
70 . . S $P(X,DEL,19)=VAIN(1)
71 . . Q
72 . E S $P(X,DEL,2)="O" ; outpatient flag
73 . D SAVESEG^MAGDHW0(I,X)
74 . Q
75 Q
76 ;
77ORC ; update ORC segment
78 N D0,I,J,NAME,X
79 S CONSULT=DEL2 ; consult always contains DEL2
80 S I=0 I $$FINDSEG^MAGDHW0(.HL7,"ORC",.I,.X) D
81 . ; get consult ien for OBR segment
82 . S CONSULT=$P(X,DEL,3)
83 . ; add names of order enterer and ordering provider
84 . F J=10,12 D
85 . . S D0=$P(X,DEL,J),NAME=$S(D0:$$GET1^DIQ(200,D0,.01),1:"")
86 . . S NAME=$TR(NAME,", ",DEL2_DEL2)
87 . . S $P(X,DEL,J)=D0_DEL2_NAME
88 . . Q
89 . D SAVESEG^MAGDHW0(I,X)
90 . Q
91 Q
92 ;
93OBR ; update OBR segment
94 N I,X,Z
95 S I=0 I $$FINDSEG^MAGDHW0(.HL7,"OBR",.I,.X) D
96 . S $P(X,DEL,3)=CONSULT_DEL2_"L",GMRCIEN=+CONSULT
97 . S Z=$$GET1^DIQ(123,GMRCIEN,5,"I") ; urgency
98 . I Z S $P(X,DEL,5)=$$GET1^DIQ(101,Z,1) ; priority
99 . ;
100 . S Z=$$GET1^DIQ(123,GMRCIEN,6,"I") ; place of consult
101 . I Z S $P(X,DEL,18)=$$GET1^DIQ(101,Z,1) ; placer field #1
102 . ;
103 . S Z=$$GET1^DIQ(123,GMRCIEN,13,"I") ; request type
104 . S Z=$S(Z="C":"CONSULT",Z="P":"PROCEDURE",1:"UNKNOWN")
105 . S $P(X,DEL,19)=Z ; consult/procedure flag - placer field #2
106 . ;
107 . ; store the current CPRS GMRC or Appointment Scheduling status
108 . ; FILLER1 is also set in ^MAGDHRS
109 . I '$D(FILLER1) S FILLER1="GMRC-"_$$GET1^DIQ(123,GMRCIEN,8)
110 . ; make linkage between the image group and the TIU note, if necessary
111 . I MSGTYPE["RESULT",$$NEWTIU(GMRCIEN) S $P(FILLER1,DEL2,2)="LINKED"
112 . S $P(X,DEL,20)=FILLER1
113 . ;
114 . ; store the clinic for the appointment in "filler field 2"
115 . I $D(APTSCHED("CLINIC IEN")),$D(APTSCHED("CLINIC NAME")) D
116 . . S $P(X,DEL,21)=APTSCHED("CLINIC IEN")_DEL2_APTSCHED("CLINIC NAME")
117 . . Q
118 . ;
119 . ; CPRS Attention - HL7 "Result Copies To" field
120 . S Z=$$GET1^DIQ(123,GMRCIEN,7,"I") ; pointer to ^VA(200)
121 . I Z S $P(X,DEL,28)=Z_DEL2_$TR($$GET1^DIQ(200,Z,.01),", ",DEL2_DEL2)
122 . ;
123 . ; date and time of scheduled appointment
124 . I $D(APTSCHED("FM DATETIME")) D
125 . . S $P(X,DEL,36)=$$FMTHL7^XLFDT(APTSCHED("FM DATETIME"))
126 . . Q
127 . ;
128 . ; from service (requesting service)
129 . S Z=$$GET1^DIQ(123,GMRCIEN,2,"I") ; pointer to ^SC(Z)
130 . I Z S $P(X,DEL,47)=Z_DEL2_$$GET1^DIQ(44,Z,.01)
131 . D SAVESEG^MAGDHW0(I,X)
132 . Q
133 Q
134 ;
135ZSV ; find ZSV segment and add imaging type code
136 N I,Z
137 S I=0 I $$FINDSEG^MAGDHW0(.HL7,"ZSV",.I,.X) D
138 . S $P(X,DEL,3)=ITYPCODE_DEL2_ITYPNAME_DEL2_DIVISION
139 . S $P(X,DEL,4)=$G(ORIGSERV) ; original service for a FORWARD request
140 . D SAVESEG^MAGDHW0(I,X)
141 . Q
142 Q
143 ;
144ALLERGY ; check to see if patient has any allergies
145 N GMRA,GMRAL,I,X
146 D EN1^GMRADPT
147 S I=0 F S I=$O(GMRAL(I)) Q:'I D ; include each allergy string as an HL7 OBX segment
148 . S OBXSEGNO=OBXSEGNO+1
149 . S X="OBX|"_OBXSEGNO_"|TX|A^ALLERGIES^L||",X=$TR(X,"|^",DEL_DEL2)
150 . S X=X_$P(GMRAL(I),"^",2)
151 . S X=X_DEL_DEL_DEL_DEL_DEL_DEL ; final six delimiters
152 . D ADDSEG^MAGDHW0(X)
153 . Q
154 Q
155 ;
156POSTINGS ; check if the patient has any other postings
157 N I,HIT,MSG
158 D ENCOVER^TIUPP3(DFN) I MSG Q ; MSG="0^Patient posting found"
159 S (I,HIT)=0
160 F S I=$O(^TMP("TIUPPCV",$J,I)) Q:'I I $P(^(I),"^",2)'="A" S HIT=1 Q
161 I HIT D
162 . S X="OBX|"_OBXSEGNO_"|TX|P^POSTINGS^L||"
163 . S X=$TR(X,"|^",DEL_DEL2)
164 . S X=X_"Please see CPRS for additional information about Postings."
165 . S X=X_DEL_DEL_DEL_DEL_DEL_DEL ; final six delimiters
166 . D ADDSEG^MAGDHW0(X)
167 . Q
168 Q
169 ;
170NEWTIU(GMRCIEN) ; check if this is a TIU note to be linked to an image group
171 ; if so, create the cross-linkages now
172 N CROSSREF,D0,FILEDATA,HIT,MAGGP,MAGIEN,NIMAGE,TIUIEN
173 S HIT=0
174 S D0=""
175 F S D0=$O(^MAG(2006.5839,"C",123,GMRCIEN,D0)) Q:'D0 D
176 . S MAGGP=$P($G(^MAG(2006.5839,D0,0)),"^",3) Q:'MAGGP
177 . S TIUIEN=$$TIULAST^MAGDGMRC(GMRCIEN) Q:'TIUIEN
178 . S $P(^MAG(2005,MAGGP,2),"^",6,7)="8925^"_TIUIEN
179 . D TIUXLINK ; create the cross-linkages to TIU
180 . ; update the parent file pointers for all the images
181 . S CROSSREF="8925^"_TIUIEN_"^"_FILEDATA("PARENT FILE PTR")
182 . S NIMAGE=0 F S NIMAGE=$O(^MAG(2005,MAGGP,1,NIMAGE)) Q:'NIMAGE D
183 . . S MAGIEN=$P(^MAG(2005,MAGGP,1,NIMAGE,0),"^")
184 . . S $P(^MAG(2005,MAGIEN,2),"^",6,8)=CROSSREF
185 . . Q
186 . ; remove entries from ^MAG(2006.5839) & decrement the counter
187 . K ^MAG(2006.5839,D0),^MAG(2006.5839,"C",123,GMRCIEN,D0)
188 . L +^MAG(2006.5839)
189 . S $P(^MAG(2006.5839,0),"^",4)=$P(^MAG(2006.5839,0),"^",4)-1
190 . L -^MAG(2006.5839)
191 . S HIT=1
192 . Q
193 Q HIT
194 ;
195TIUXLINK ; create the cross-linkages to TIU EXTERNAL DATA LINK file
196 N TIUXDIEN
197 D PUTIMAGE^TIUSRVPL(.TIUXDIEN,TIUIEN,MAGGP)
198 I TIUXDIEN D
199 . S FILEDATA("PARENT FILE PTR")=TIUXDIEN
200 . S $P(^MAG(2005,MAGGP,2),"^",8)=TIUXDIEN
201 . Q
202 E D ; fatal error
203 . N MSG
204 . S MSG(1)="ERROR ASSOCIATING WITH TIU EXTERNAL DATA LINK (file 8925.91):"
205 . S MSG(2)=$P(TIUXDIEN,"^",2,999)
206 . S X="ERR^MAGGTERR",@^%ZOSF("TRAP")
207 . Q
208 Q
Note: See TracBrowser for help on using the repository browser.