source: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAG7RS.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1MAG7RS ;WOIFO/PMK,MLH - copy radiology message from HLSDATA to ^MAGDHL7 - add segment data ; 30 Jun 2004 4:32 PM
2 ;;3.0;IMAGING;**11,40,30**;16-September-2004
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 ;
19PIDADD ; SUBROUTINE - called by ADDDTA^MAGDHL7
20 ; Add PID info for DICOM Gateway.
21 ; Uses multi-tier array structure MAG7WRK produced by call to MAG7UP.
22 ;
23 N DIQUIET ; -------------- FileMan verbose/silent variable
24 N IXPID ; ---------------- index to PID segment in MAG7WRK array
25 N VADM,VAPA ; ------------ VADPT return arrays
26 ;
27 ; ====================================================
28 ; Get patient DFN and retrieve demo data.
29 S IXPID=$O(MAG7WRK("B","PID","")) I 'IXPID Q
30 S DFN=MAG7WRK(IXPID,3,1,1,1) I 'DFN Q
31 ;
32 ; ================================================
33 ; load demo information into HL7 PID segment
34 S DIQUIET=1
35 D DEM^VADPT ; demo into VADM()
36 I '$G(VAERR),VADM(3)]"" D
37 . S MAG7WRK(IXPID,7,1,1,1)=$P(VADM(3),"^")+17000000 ; DOB
38 . Q
39 ;
40 ; ================================================
41 ; load address information into HL7 PID segment
42 S DIQUIET=1
43 D ADD^VADPT ; address & phone into VAPA()
44 I '$G(VAERR) D
45 . S MAG7WRK(IXPID,10,1,2,1)=$P(VADM(8),"^",2) ; race
46 . S MAG7WRK(IXPID,11,1,1,1)=VAPA(1) ; street address 1st line
47 . S MAG7WRK(IXPID,11,1,2,1)=VAPA(2)_$S(VAPA(3)="":"",1:", "_VAPA(3)) ; lns 2-3
48 . S MAG7WRK(IXPID,11,1,3,1)=VAPA(4) ; city
49 . S MAG7WRK(IXPID,11,1,4,1)=VAPA(5) ; 2-letter state
50 . S MAG7WRK(IXPID,11,1,5,1)=VAPA(6) ; ZIP
51 . ; phone
52 . S MAG7WRK(IXPID,13,1,1,1)=VAPA(8)
53 . S MAG7WRK(IXPID,13,1,2,1)="PRN" ; phone
54 . Q
55 Q
56 ;
57ADDVSDG ; SUBROUTINE - called by ADDDTA^MAGDHL7
58 ; Add visit and diagnosis info for DICOM Gateway.
59 ;
60 N DIQUIET ; ------ FileMan verbose/silent variable
61 N I,IX,IX1 ; ----- scratch index vars
62 N IXPID,IXPV1 ; -- indices to PID, PV1 segs in MAG7WRK array
63 N IXDG1,IXOBR ; -- indices to DG1, OBR segs in MAG7WRK array
64 N IXVAEL ; ------- index of entries in VAEL()
65 N VAIN,VAEL ; ---- VADPT return arrays
66 N MAGPHYNM ; ----- physician name
67 N ELCODE ; ------- eligibility code
68 ;
69 ; ====================================================
70 ; Get patient DFN and retrieve inpatient data.
71 S IXPID=$O(MAG7WRK("B","PID","")) I 'IXPID Q
72 S DFN=MAG7WRK(IXPID,3,1,1,1) I 'DFN Q
73 S DIQUIET=1
74 D INP^VADPT Q:VAERR ; inpatient data in VAIN()
75 D ELIG^VADPT Q:VAERR ; eligibility data in VAEL()
76 D PV1ADD($S($G(VAIN(1))]"":"IN",1:"OUT"))
77 ; add pregnancy status and modalities if not already part of order
78 ; message
79 I $G(MAG7WRK(1,9,1,1,1))="ORM" D
80 . S IXOBR=$O(MAG7WRK("B","OBR",""))
81 . I IXOBR D PV1RAD ; pregnancy status & modality info from Radiology
82 . Q
83 Q
84 ;
85PV1ADD(XPTSTA) ; SUBROUTINE - called by ADDVSDG
86 ; Get the index of the PV1 segment - create one for the order message
87 ; if we need to.
88 ;
89 ; input: XPTSTA patient status { IN | OUT }
90 ;
91 ; Expects: VAEL() eligibility array from ELIG^VADPT
92 ; VAIN() inpatient data array from INP^VADPT
93 ;
94 N FSTAT ; -- status flag returned by MAG7UDR
95 N IXSEG ; -- segment index in message
96 N IXPRED ; -- index to predecessor segment
97 N IXSUCC ; -- index to successor segment
98 ;
99 S IXPV1=$O(MAG7WRK("B","PV1",""))
100 I 'IXPV1 Q:MAG7WRK(1,9,1,1,1)'="ORM" D
101 . S (IXSEG,IXPRED)=$O(MAG7WRK("B","PID","")) Q:'IXSEG
102 . F S IXSEG=$O(MAG7WRK(IXSEG)) Q:"^PD1^NTE^"'[("^"_$G(MAG7WRK(IXSEG,0))_"^") S IXPRED=IXSEG
103 . S IXSUCC=$O(MAG7WRK(IXPRED)),IXPV1=$S(IXSUCC:IXPRED+IXSUCC/2,1:IXPRED+1)
104 . S MAG7WRK(IXPV1,0)="PV1"
105 . Q
106 ;
107 ; pt status
108 I XPTSTA="OUT" D ; if op, just status for now
109 . S MAG7WRK(IXPV1,2,1,1,1)="O"
110 . Q
111 E I XPTSTA'="IN" D ; not applicable
112 . S MAG7WRK(IXPV1,2,1,1,1)="N"
113 . Q
114 E D ; get visit information too
115 . S MAG7WRK(IXPV1,2,1,1,1)="I" ; -- class - always inpatient
116 . ; location
117 . ; point of care <--- ward -- needs to be a triplet for Pete's DICOM msg
118 . S MAG7WRK(IXPV1,3,1,1,1)=$P(VAIN(4),U)
119 . S MAG7WRK(IXPV1,3,1,1,2)=$P(VAIN(4),U,2)
120 . S MAG7WRK(IXPV1,3,1,1,3)="VISTA42"
121 . S MAG7WRK(IXPV1,3,1,2,1)=$P(VAIN(5),"-") ; -------- room
122 . S MAG7WRK(IXPV1,3,1,3,1)=$P(VAIN(5),"-",2) ; ------ bed
123 . ; add segment for admitting dx to ADT and ORM messages
124 . I $G(VAIN(9))]"" D DG1DGADM^MAG7RSD
125 . Q
126 ;
127 ; add PV1 fields and ROL segments for the attending and referring DRs
128 S FSTAT=$$PRCTADD^MAG7UDR($NA(MAG7WRK(IXPV1,7)),"ATT") ; attending DR
129 I $G(MAG7WRK(IXPV1,7,1,1,1)),$G(MAG7WRK(1,9,1,1,1))="ADT" D
130 . D ROLADD^MAG7RSR($NA(MAG7WRK(IXPV1,7,1)),"AT")
131 . Q
132 S FSTAT=$$PRCTADD^MAG7UDR($NA(MAG7WRK(IXPV1,8)),"REF") ; referring DR
133 I $G(MAG7WRK(IXPV1,8,1,1,1)),$G(MAG7WRK(1,9,1,1,1))="ADT" D
134 . D ROLADD^MAG7RSR($NA(MAG7WRK(IXPV1,8,1)),"RP")
135 . Q
136 I $D(VAEL) D ; add VIP flag if applicable and not yet present
137 . S VAEL(1,0)=VAEL(1) ; for easy array navigation
138 . S IXVAEL=""
139 . F Q:$D(IXPV1(16)) S IXVAEL=$O(VAEL(1,IXVAEL)) Q:IXVAEL="" D
140 . . S ELCODE=$P($G(VAEL(1,IXVAEL)),"^")
141 . . I "^6^15^"[("^"_ELCODE_"^") S IXPV1(16,1,1,1,1)=ELCODE
142 . . Q
143 . Q
144 Q
145 ;
146PV1RAD ; SUBROUTINE - called by ADDVSDG
147 ; Add "pregnant" to Ambulatory Status if patient is pregnant.
148 ; Add modalities to Diagnostic Service Section ID.
149 ;
150 ; Expects: MAG7WRK() HL7 message array
151 ; IXOBR Index of OBR segment on MAG7WRK()
152 ; IXPV1 Index of PV1 segment on MAG7WRK()
153 ;
154 N RADPT2 ; ------- FileMan date of rad order
155 N RADPT3 ; ------- index of order under date on Rad/NM pt file
156 N RADPT0 ; ------- data for order on Rad/NM pt file
157 N RAOIEN ; ------- index of order on Rad/NM order file
158 N RAO0 ; --------- data for order on Rad/NM order file
159 N PROCIEN ; ------ ien of procedure on Rad/NM procedure file
160 N PROCMOD ; ------ ien of modality on Rad/NM procedure file
161 N MODIEN ; ------- ien of modality on modality defined terms file
162 N MODTERM ; ------ term for the modality
163 N PREGSTAT ; ----- pregnancy status on order
164 N REPIX ; -------- repetition index
165 N EDTA ; --------- element data
166 N AAMBMSG ; ------ ambulatory status array (from message data)
167 N AMODMSG ; ------ modality array (from message data)
168 ;
169 ; get data from Rad/NM pt and order files
170 S RADPT2=$P(MAG7WRK(IXOBR,3,1,1,1),"-")
171 S RADPT3=$P(MAG7WRK(IXOBR,3,1,1,1),"-",2)
172 S RADPT0=$G(^RADPT(DFN,"DT",RADPT2,"P",RADPT3,0))
173 S RAOIEN=$P(RADPT0,"^",11) ; IEN for ^RAO(75.1)
174 S RAO0="" I RAOIEN S RAO0=$G(^RAO(75.1,RAOIEN,0))
175 ;
176 ; add "pregnant" to ambulatory status if needed
177 ; get data from message
178 S REPIX=""
179 F S REPIX=$O(MAG7WRK(IXPV1,15,REPIX)) Q:'REPIX D
180 . S EDTA=$G(MAG7WRK(IXPV1,15,REPIX,1,1)) I EDTA]"" S AAMBMSG(EDTA)=""
181 . Q
182 ; get data from Radiology and add to message if needed and not present
183 S PREGSTAT=$P(RAO0,"^",13) I PREGSTAT="" S PREGSTAT="u"
184 I '$D(AAMBMSG("B6")),PREGSTAT="y" D
185 . S MAG7WRK(IXPV1,15,$O(MAG7WRK(IXPV1,15," "),-1)+1,1,1)="B6"
186 . Q
187 ;
188 ; add modalities to Diagnostic Service Section ID
189 ; get data from message
190 F S REPIX=$O(MAG7WRK(IXOBR,24,REPIX)) Q:'REPIX D
191 . S EDTA=$G(MAG7WRK(IXOBR,24,REPIX,1,1)) I EDTA]"" S AMODMSG(EDTA)=""
192 . Q
193 ; get data from Radiology and add to message if needed and not present
194 S PROCIEN=$P(RADPT0,U,2)
195 I PROCIEN D
196 . S PROCMOD=0
197 . F S PROCMOD=$O(^RAMIS(71,PROCIEN,"MDL",PROCMOD)) Q:'PROCMOD D
198 . . S MODIEN=$P($G(^RAMIS(71,PROCIEN,"MDL",PROCMOD,0)),U)
199 . . I MODIEN,$D(^RAMIS(73.1,MODIEN,0)) D
200 . . . S MODTERM=$P($G(^RAMIS(73.1,MODIEN,0)),U)
201 . . . I MODTERM]"",'$D(AMODMSG(MODTERM)) D
202 . . . . S MAG7WRK(IXOBR,24,$O(MAG7WRK(IXOBR,24," "),-1)+1,1,1)=MODTERM
203 . . . . Q
204 . . . Q
205 . . Q
206 . Q
207 Q
Note: See TracBrowser for help on using the repository browser.