source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UID2.m@ 1553

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1LA7UID2 ;DALOI/JRR - Process Download Message for an entry in 62.48 ; 12/3/1997
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,27,57**;Sep 27, 1994
3 Q
4 ;
5BUILD ; Build one accession into an HL7 message
6 ;
7 ; HL7 package expects the HLSDATA array to contain the msg
8 K HLSDATA
9 ;
10 ; Build segments
11 D MSH
12 Q:$D(LA7ERR)
13 D ORC
14 D PID
15 D PV1
16 D OBR
17 ; Build entry in MESSAGE QUEUE file 62.49
18 D Q6249
19 S HLMTN="ORU"
20 ; Send message
21 D EN1^HLTRANS
22 ;
23 ; Set status to purgeable
24 I $G(LA76249),$P($G(^LAHM(62.49,LA76249,0)),"^",3)'="E" D
25 . N DIE,DA,DR
26 . S DIE="^LAHM(62.49,",DA=LA76249,DR="2////X"
27 . D ^DIE
28 ;
29 D KVAR^LRX
30 Q
31 ;
32 ;
33MSH ;requires LA7NDAP= IEN in 770 HL7 NON-DHCP APPLICATION file
34 D KILL^HLTRANS ;kill HL variables
35 S HLNDAP=LA7NDAP ;required variable before calling INIT^HLTRANS
36 D INIT^HLTRANS ;set up required HL variables
37 K LA7ERR
38 I $D(HLERR) D CREATE^LA7LOG(4) S LA7ERR="" QUIT
39 S HLSDATA(0)=$$MSH^HLFNC1("ORM")
40 Q
41ORC ;
42 K LA7ORC
43 S LA7ORC(1)="NW"
44 S LA7ORC(3)=$G(^LRO(68,LA768,1,LA76801,1,LA76802,.1))
45 S LA7ORC(12)=$P(LA7ACC0,"^",8) ;provider
46 S:LA7ORC(12) LA7ORC(12)=$E(HLECH)_$$HLNAME^HLFNC($$GET1^DIQ(200,LA7ORC(12)_",",.01))
47 F LA7=0:0 S LA7=$O(LA7ORC(LA7)) Q:'LA7 D
48 . S $P(LA7ORC,HLFS,LA7)=LA7ORC(LA7)
49 S HLSDATA(3)="ORC"_HLFS_LA7ORC
50 Q
51PID K LA7PID
52 S LRDFN=+LA7ACC0 K LRDPF
53 D DEM^LRX
54 S LA7PID(3)=$$M11^HLFNC(LRDFN)
55 S LA7PID(5)=$$HLNAME^HLFNC(PNM)
56 I $L(SEX) S LA7PID(8)=$S("FM"[SEX:SEX,1:"U")
57 I $L(SSN) S LA7PID(19)=SSN
58 I DOB S LA7PID(7)=$$HLDATE^HLFNC(DOB,"DT")
59 S LA7PID=""
60 F LA7=0:0 S LA7=$O(LA7PID(LA7)) Q:'LA7 D
61 . S $P(LA7PID,HLFS,LA7)=LA7PID(LA7)
62 S HLSDATA(1)="PID"_HLFS_LA7PID
63 Q
64PV1 K LA7PV1
65 S LA7PV1(3)=$P(LA7ACC0,"^",7)
66 S LA7PV1=""
67 F LA7=0:0 S LA7=$O(LA7PV1(LA7)) Q:'LA7 D
68 . S $P(LA7PV1,HLFS,LA7)=LA7PV1(LA7)
69 S HLSDATA(2)="PV1"_HLFS_LA7PV1
70 Q
71OBR ;
72 I '$D(ZTQUEUED),$G(LRLL) W:$X+5>IOM !,$S($G(LRTYPE):"Cup",1:"Seq"),": " W LA76822,", "
73 N LA760,LA7CDT,LA7CMT,LA7I,LA7SPEC
74 K LA7OBR
75 S LA7CNT=0
76 ; Get infection warning if any.
77 S LRINFW=$G(^LR(LRDFN,.091))
78 ; Collection date/time node.
79 S LA7=$G(^LRO(68,LA768,1,LA76801,1,LA76802,3))
80 ; Draw time - If time invalid adjust to next lower valid time
81 I LA7 D
82 . N LA7X
83 . S LA7X=$$CHKDT(+LA7)
84 . S LA7CDT=$$HLDATE^HLFNC(LA7X,"TS")
85 S LA7CMT=$TR($P(LA7,"^",6),"~") ; Specimen comment if any, strip "~".
86 S LA7=+$G(^LRO(68,LA768,1,LA76801,1,LA76802,5,1,0)) ;specimen
87 S LA7SPEC=$$GET1^DIQ(61,LA7_",","LEDI HL7:HL7 ABBR") ;HL7 code from Topography
88 S LA7UID=$P($G(^LRO(68,LA768,1,LA76801,1,LA76802,.3)),"^") ;unique ID
89 S LA7ACC=$P($G(^LRO(68,LA768,1,LA76801,1,LA76802,.2)),"^") ;accession
90 S LA7I=0
91 F S LA7I=$O(LA7ACC(LA7I)) Q:'LA7I D
92 . K LA7OBR
93 . S LA760=+LA7ACC(LA7I)
94 . S LA7TMP=$G(^TMP("LA7",$J,LA7INST,LA7I))
95 . Q:'LA7TMP
96 . S LA7CODE=$P(LA7TMP,"^",6)
97 . S LA7DATA=$P(LA7TMP,"^",7)
98 . S LA7CNT=LA7CNT+1,LA7OBR(1)=LA7CNT
99 . S LA7OBR(4)=LA7CODE_$E(HLECH)_$P(LA7TMP,"^",4)_$E(HLECH)_99001_$E(HLECH)_LA760_"X"_LA7DATA_$E(HLECH)_$P(^LAB(60,LA760,0),"^")_$E(HLECH)_99002
100 . I $G(LA7CDT) S LA7OBR(7)=LA7CDT ; Draw time.
101 . I $L(LRINFW) S LA7OBR(12)=$E(HLECH)_LRINFW ; Infection warning.
102 . S LA7OBR(13)=LA7CMT ; Specimen comment
103 . S LA7OBR(15)=LA7SPEC ;HL7 code from Topography
104 . I LRDPF'=2 S $P(LA7OBR(15),$E(HLECH),3)=$S(LRDPF=62.3:"CONTROL",1:"")
105 . S LRCADR="" S LRCADR=$O(^LAB(62.4,"B",$P(LRAUTO,"^"),LRCADR))
106 . S LA7D0=+$G(LRCADR) ;KAT
107 . S LRCADR=$P($G(^LAB(62.4,+LRCADR,9)),U,9)
108 . S LA7OBR(18)=$P(LRAUTO,"^")_$E(HLECH)_LRCADR ;instrument name^card address
109 . K LRCADR ;KAT added instrument address
110 . S LA7OBR(19)=""
111 . F LA7="LA76821","LA76822","LA768","LA76801","LA76802","LA7ACC","LA7UID" D
112 . . I LA7="LA76821",'$G(LRFORCE),LA76821 N LA76821 S LA76821="" ; No tray if don't send tray/cup flag.
113 . . I LA7="LA76822",'$G(LRFORCE),LA76822 N LA76822 S LA76822="" ; No cup if don't send tray/cup flag.
114 . . S LA7OBR(19)=LA7OBR(19)_@LA7_$E(HLECH)
115 . . ; LA7OBR(19)=tray^cup^lraa^lrad^lran^lracc^lruid
116 . S LA7=+$P(LA7ACC(LA7I),"^",2) ; Test urgency.
117 . S LA7=$P($G(^LAB(62.05,LA7,0)),"^",4) ; HL7 priority from Urgency file.
118 . S $P(LA7OBR(27),$E(HLECH),6)=$S($L(LA7):LA7,1:"R") ; HL7 priority, default routine (R).
119 . S LA7=$P($G(^LRO(68,LA768,.4)),"^",2)
120 . ;KAT-Added using field .04 in Auto Instr file.
121 . S LA7D0=+$P($G(^LAB(62.4,+LA7D0,9)),U,10)
122 . S LA7OBR(2)=$S(LA7="L":LA7UID,1:$E("0000000000",1,LA7D0-$L(LA76802))_LA76802) ;long or short sample ID
123 . K LA7D0
124 . F LA7=0:0 S LA7=$O(LA7OBR(LA7)) Q:'LA7 D
125 . . S $P(LA7OBR,HLFS,LA7)=LA7OBR(LA7)
126 . S HLSDATA(3+LA7CNT)="OBR"_HLFS_LA7OBR
127 Q
128 ;
129 ;
130CHKDT(LA7X) ; Check validity of date/time
131 ; Adjust invalid times to closest valid time - correct for lab problem
132 ; that generated invalid FileMan date/times.
133 ; If hours>24 then set to 24 with no minutes/seconds
134 ; If minutes greater than 59 then set to 59
135 ; If seconds greater than 59 then set to 59
136 ;
137 N I,LA7Y,X
138 ;
139 S LA7Y=$P(LA7X,".",2)
140 ;
141 ; If time present then check otherwise skip and return input.
142 I $L(LA7Y) D
143 . F I=1:2:5 D
144 . . S LA7Y(I)=$E(LA7Y,I,I+1)
145 . . I $L(LA7Y(I))=1 S LA7Y(I)=LA7Y(I)_"0"
146 . . I LA7Y(I)>$S(I=1:24,1:59) S LA7Y(I)=$S(I=1:24,1:59)
147 . . I I=1,LA7Y(1)=24 S LA7Y=24
148 . S X="."_LA7Y(1)_LA7Y(3)_LA7Y(5),X=+X
149 . S $P(LA7X,".",2)=$P(X,".",2)
150 ;
151 Q LA7X
152 ;
153 ;
154Q6249 ; create an entry in the MESSAGE QUEUE file to store this message
155 ;
156 N DIC,DINUM,DLAYGO
157 ;
158 S LA7DTIM=$$NOW^XLFDT
159 L +^LAHM(62.49,0):9999999
160 F X=$P(^LAHM(62.49,0),"^",3):1 Q:'$D(^LAHM(62.49,X))
161 S LA76249=X
162 K DD,DO
163 S DIC="^LAHM(62.49,",DIC(0)="LF",DLAYGO=62.49
164 S DINUM=X
165 S DIC("DR")="1////O;3////3;4////"_LA7DTIM_";.5////"_LA76248
166 S DIC("DR")=DIC("DR")_";2////Q;5////"_$P(LRAUTO,"^",1)_"-O-"_LA7UID
167 D FILE^DICN
168 L -^LAHM(62.49,0)
169 S LA7MSH=HLSDATA(0)
170 I HLFS'="^" S LA7MSH=$TR(LA7MSH,"^"," "),LA7MSH=$TR(LA7MSH,HLFS,"^")
171 S ^LAHM(62.49,LA76249,100)=LA7MSH
172 S LA71=0,LA7=""
173 F S LA7=$O(HLSDATA(LA7)) Q:LA7="" D
174 . S LA71=LA7
175 . S ^LAHM(62.49,LA76249,150,LA7+1,0)=HLSDATA(LA7)
176 S ^LAHM(62.49,LA76249,150,0)="^^"_LA71_"^"_LA71_"^"_DT
177 Q
Note: See TracBrowser for help on using the repository browser.