VistA-WorldVistAEHR/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UID2.m

178 lines
5.8 KiB
Mathematica

LA7UID2 ;DALOI/JRR - Process Download Message for an entry in 62.48 ; 12/3/1997
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,27,57**;Sep 27, 1994
Q
;
BUILD ; Build one accession into an HL7 message
;
; HL7 package expects the HLSDATA array to contain the msg
K HLSDATA
;
; Build segments
D MSH
Q:$D(LA7ERR)
D ORC
D PID
D PV1
D OBR
; Build entry in MESSAGE QUEUE file 62.49
D Q6249
S HLMTN="ORU"
; Send message
D EN1^HLTRANS
;
; Set status to purgeable
I $G(LA76249),$P($G(^LAHM(62.49,LA76249,0)),"^",3)'="E" D
. N DIE,DA,DR
. S DIE="^LAHM(62.49,",DA=LA76249,DR="2////X"
. D ^DIE
;
D KVAR^LRX
Q
;
;
MSH ;requires LA7NDAP= IEN in 770 HL7 NON-DHCP APPLICATION file
D KILL^HLTRANS ;kill HL variables
S HLNDAP=LA7NDAP ;required variable before calling INIT^HLTRANS
D INIT^HLTRANS ;set up required HL variables
K LA7ERR
I $D(HLERR) D CREATE^LA7LOG(4) S LA7ERR="" QUIT
S HLSDATA(0)=$$MSH^HLFNC1("ORM")
Q
ORC ;
K LA7ORC
S LA7ORC(1)="NW"
S LA7ORC(3)=$G(^LRO(68,LA768,1,LA76801,1,LA76802,.1))
S LA7ORC(12)=$P(LA7ACC0,"^",8) ;provider
S:LA7ORC(12) LA7ORC(12)=$E(HLECH)_$$HLNAME^HLFNC($$GET1^DIQ(200,LA7ORC(12)_",",.01))
F LA7=0:0 S LA7=$O(LA7ORC(LA7)) Q:'LA7 D
. S $P(LA7ORC,HLFS,LA7)=LA7ORC(LA7)
S HLSDATA(3)="ORC"_HLFS_LA7ORC
Q
PID K LA7PID
S LRDFN=+LA7ACC0 K LRDPF
D DEM^LRX
S LA7PID(3)=$$M11^HLFNC(LRDFN)
S LA7PID(5)=$$HLNAME^HLFNC(PNM)
I $L(SEX) S LA7PID(8)=$S("FM"[SEX:SEX,1:"U")
I $L(SSN) S LA7PID(19)=SSN
I DOB S LA7PID(7)=$$HLDATE^HLFNC(DOB,"DT")
S LA7PID=""
F LA7=0:0 S LA7=$O(LA7PID(LA7)) Q:'LA7 D
. S $P(LA7PID,HLFS,LA7)=LA7PID(LA7)
S HLSDATA(1)="PID"_HLFS_LA7PID
Q
PV1 K LA7PV1
S LA7PV1(3)=$P(LA7ACC0,"^",7)
S LA7PV1=""
F LA7=0:0 S LA7=$O(LA7PV1(LA7)) Q:'LA7 D
. S $P(LA7PV1,HLFS,LA7)=LA7PV1(LA7)
S HLSDATA(2)="PV1"_HLFS_LA7PV1
Q
OBR ;
I '$D(ZTQUEUED),$G(LRLL) W:$X+5>IOM !,$S($G(LRTYPE):"Cup",1:"Seq"),": " W LA76822,", "
N LA760,LA7CDT,LA7CMT,LA7I,LA7SPEC
K LA7OBR
S LA7CNT=0
; Get infection warning if any.
S LRINFW=$G(^LR(LRDFN,.091))
; Collection date/time node.
S LA7=$G(^LRO(68,LA768,1,LA76801,1,LA76802,3))
; Draw time - If time invalid adjust to next lower valid time
I LA7 D
. N LA7X
. S LA7X=$$CHKDT(+LA7)
. S LA7CDT=$$HLDATE^HLFNC(LA7X,"TS")
S LA7CMT=$TR($P(LA7,"^",6),"~") ; Specimen comment if any, strip "~".
S LA7=+$G(^LRO(68,LA768,1,LA76801,1,LA76802,5,1,0)) ;specimen
S LA7SPEC=$$GET1^DIQ(61,LA7_",","LEDI HL7:HL7 ABBR") ;HL7 code from Topography
S LA7UID=$P($G(^LRO(68,LA768,1,LA76801,1,LA76802,.3)),"^") ;unique ID
S LA7ACC=$P($G(^LRO(68,LA768,1,LA76801,1,LA76802,.2)),"^") ;accession
S LA7I=0
F S LA7I=$O(LA7ACC(LA7I)) Q:'LA7I D
. K LA7OBR
. S LA760=+LA7ACC(LA7I)
. S LA7TMP=$G(^TMP("LA7",$J,LA7INST,LA7I))
. Q:'LA7TMP
. S LA7CODE=$P(LA7TMP,"^",6)
. S LA7DATA=$P(LA7TMP,"^",7)
. S LA7CNT=LA7CNT+1,LA7OBR(1)=LA7CNT
. 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
. I $G(LA7CDT) S LA7OBR(7)=LA7CDT ; Draw time.
. I $L(LRINFW) S LA7OBR(12)=$E(HLECH)_LRINFW ; Infection warning.
. S LA7OBR(13)=LA7CMT ; Specimen comment
. S LA7OBR(15)=LA7SPEC ;HL7 code from Topography
. I LRDPF'=2 S $P(LA7OBR(15),$E(HLECH),3)=$S(LRDPF=62.3:"CONTROL",1:"")
. S LRCADR="" S LRCADR=$O(^LAB(62.4,"B",$P(LRAUTO,"^"),LRCADR))
. S LA7D0=+$G(LRCADR) ;KAT
. S LRCADR=$P($G(^LAB(62.4,+LRCADR,9)),U,9)
. S LA7OBR(18)=$P(LRAUTO,"^")_$E(HLECH)_LRCADR ;instrument name^card address
. K LRCADR ;KAT added instrument address
. S LA7OBR(19)=""
. F LA7="LA76821","LA76822","LA768","LA76801","LA76802","LA7ACC","LA7UID" D
. . I LA7="LA76821",'$G(LRFORCE),LA76821 N LA76821 S LA76821="" ; No tray if don't send tray/cup flag.
. . I LA7="LA76822",'$G(LRFORCE),LA76822 N LA76822 S LA76822="" ; No cup if don't send tray/cup flag.
. . S LA7OBR(19)=LA7OBR(19)_@LA7_$E(HLECH)
. . ; LA7OBR(19)=tray^cup^lraa^lrad^lran^lracc^lruid
. S LA7=+$P(LA7ACC(LA7I),"^",2) ; Test urgency.
. S LA7=$P($G(^LAB(62.05,LA7,0)),"^",4) ; HL7 priority from Urgency file.
. S $P(LA7OBR(27),$E(HLECH),6)=$S($L(LA7):LA7,1:"R") ; HL7 priority, default routine (R).
. S LA7=$P($G(^LRO(68,LA768,.4)),"^",2)
. ;KAT-Added using field .04 in Auto Instr file.
. S LA7D0=+$P($G(^LAB(62.4,+LA7D0,9)),U,10)
. S LA7OBR(2)=$S(LA7="L":LA7UID,1:$E("0000000000",1,LA7D0-$L(LA76802))_LA76802) ;long or short sample ID
. K LA7D0
. F LA7=0:0 S LA7=$O(LA7OBR(LA7)) Q:'LA7 D
. . S $P(LA7OBR,HLFS,LA7)=LA7OBR(LA7)
. S HLSDATA(3+LA7CNT)="OBR"_HLFS_LA7OBR
Q
;
;
CHKDT(LA7X) ; Check validity of date/time
; Adjust invalid times to closest valid time - correct for lab problem
; that generated invalid FileMan date/times.
; If hours>24 then set to 24 with no minutes/seconds
; If minutes greater than 59 then set to 59
; If seconds greater than 59 then set to 59
;
N I,LA7Y,X
;
S LA7Y=$P(LA7X,".",2)
;
; If time present then check otherwise skip and return input.
I $L(LA7Y) D
. F I=1:2:5 D
. . S LA7Y(I)=$E(LA7Y,I,I+1)
. . I $L(LA7Y(I))=1 S LA7Y(I)=LA7Y(I)_"0"
. . I LA7Y(I)>$S(I=1:24,1:59) S LA7Y(I)=$S(I=1:24,1:59)
. . I I=1,LA7Y(1)=24 S LA7Y=24
. S X="."_LA7Y(1)_LA7Y(3)_LA7Y(5),X=+X
. S $P(LA7X,".",2)=$P(X,".",2)
;
Q LA7X
;
;
Q6249 ; create an entry in the MESSAGE QUEUE file to store this message
;
N DIC,DINUM,DLAYGO
;
S LA7DTIM=$$NOW^XLFDT
L +^LAHM(62.49,0):9999999
F X=$P(^LAHM(62.49,0),"^",3):1 Q:'$D(^LAHM(62.49,X))
S LA76249=X
K DD,DO
S DIC="^LAHM(62.49,",DIC(0)="LF",DLAYGO=62.49
S DINUM=X
S DIC("DR")="1////O;3////3;4////"_LA7DTIM_";.5////"_LA76248
S DIC("DR")=DIC("DR")_";2////Q;5////"_$P(LRAUTO,"^",1)_"-O-"_LA7UID
D FILE^DICN
L -^LAHM(62.49,0)
S LA7MSH=HLSDATA(0)
I HLFS'="^" S LA7MSH=$TR(LA7MSH,"^"," "),LA7MSH=$TR(LA7MSH,HLFS,"^")
S ^LAHM(62.49,LA76249,100)=LA7MSH
S LA71=0,LA7=""
F S LA7=$O(HLSDATA(LA7)) Q:LA7="" D
. S LA71=LA7
. S ^LAHM(62.49,LA76249,150,LA7+1,0)=HLSDATA(LA7)
S ^LAHM(62.49,LA76249,150,0)="^^"_LA71_"^"_LA71_"^"_DT
Q