LA7UID2 ;VA/DALOI/JRR - Process Download Message for an entry in 62.48 ; O3/16/2005
;;5.2;AUTOMATED LAB INSTRUMENTS;**1002,1019,1031**;NOV 01, 1997
;
;;VA LA Patche(s): 17,27,57
;
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
;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 IHS/OIT/MKK -- Use HRCN, not LRDFN
; S LA7PID(3)=$$M11^HLFNC(LRDFN)
; S LA7PID(3)=$G(HRCN)
S LA7PID(3)=$$GETHRCN^BLRUTIL4(LRDFN,$G(HRCN)) ; IHS/MSC/MKK - LR*5.2*1031
;----- END IHS MODIFICATIONS LR*5.2*1019 IHS/OIT/MKK -- Use HRCN, not 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
LA7UID2 ;VA/DALOI/JRR - Process Download Message for an entry in 62.48 ; O3/16/2005
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1002,1019,1031**;NOV 01, 1997
+2 ;
+3 ;;VA LA Patche(s): 17,27,57
+4 ;
+5 QUIT
+6 ;
BUILD ; Build one accession into an HL7 message
+1 ;
+2 ; HL7 package expects the HLSDATA array to contain the msg
+3 KILL HLSDATA
+4 ;
+5 ; Build segments
+6 DO MSH
+7 IF $DATA(LA7ERR)
QUIT
+8 DO ORC
+9 DO PID
+10 DO PV1
+11 DO OBR
+12 ; Build entry in MESSAGE QUEUE file 62.49
+13 DO Q6249
+14 SET HLMTN="ORU"
+15 ; Send message
+16 DO EN1^HLTRANS
+17 ;
+18 ; Set status to purgeable
+19 IF $GET(LA76249)
IF $PIECE($GET(^LAHM(62.49,LA76249,0)),"^",3)'="E"
Begin DoDot:1
+20 NEW DIE,DA,DR
+21 SET DIE="^LAHM(62.49,"
SET DA=LA76249
SET DR="2////X"
+22 DO ^DIE
End DoDot:1
+23 ;
+24 DO KVAR^LRX
+25 QUIT
+26 ;
+27 ;
MSH ;requires LA7NDAP= IEN in 770 HL7 NON-DHCP APPLICATION file
+1 ;kill HL variables
DO KILL^HLTRANS
+2 ;required variable before calling INIT^HLTRANS
SET HLNDAP=LA7NDAP
+3 ;set up required HL variables
DO INIT^HLTRANS
+4 KILL LA7ERR
+5 IF $DATA(HLERR)
DO CREATE^LA7LOG(4)
SET LA7ERR=""
QUIT
+6 SET HLSDATA(0)=$$MSH^HLFNC1("ORM")
+7 QUIT
ORC ;
+1 KILL LA7ORC
+2 SET LA7ORC(1)="NW"
+3 SET LA7ORC(3)=$GET(^LRO(68,LA768,1,LA76801,1,LA76802,.1))
+4 ;provider
SET LA7ORC(12)=$PIECE(LA7ACC0,"^",8)
+5 IF LA7ORC(12)
SET LA7ORC(12)=$EXTRACT(HLECH)_$$HLNAME^HLFNC($$GET1^DIQ(200,LA7ORC(12)_",",.01))
+6 FOR LA7=0:0
SET LA7=$ORDER(LA7ORC(LA7))
IF 'LA7
QUIT
Begin DoDot:1
+7 SET $PIECE(LA7ORC,HLFS,LA7)=LA7ORC(LA7)
End DoDot:1
+8 SET HLSDATA(3)="ORC"_HLFS_LA7ORC
+9 QUIT
PID KILL LA7PID
+1 SET LRDFN=+LA7ACC0
KILL LRDPF
+2 DO DEM^LRX
+3 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 IHS/OIT/MKK -- Use HRCN, not LRDFN
+4 ; S LA7PID(3)=$$M11^HLFNC(LRDFN)
+5 ; S LA7PID(3)=$G(HRCN)
+6 ; IHS/MSC/MKK - LR*5.2*1031
SET LA7PID(3)=$$GETHRCN^BLRUTIL4(LRDFN,$GET(HRCN))
+7 ;----- END IHS MODIFICATIONS LR*5.2*1019 IHS/OIT/MKK -- Use HRCN, not LRDFN
+8 SET LA7PID(5)=$$HLNAME^HLFNC(PNM)
+9 IF $LENGTH(SEX)
SET LA7PID(8)=$SELECT("FM"[SEX:SEX,1:"U")
+10 IF $LENGTH(SSN)
SET LA7PID(19)=SSN
+11 IF DOB
SET LA7PID(7)=$$HLDATE^HLFNC(DOB,"DT")
+12 SET LA7PID=""
+13 FOR LA7=0:0
SET LA7=$ORDER(LA7PID(LA7))
IF 'LA7
QUIT
Begin DoDot:1
+14 SET $PIECE(LA7PID,HLFS,LA7)=LA7PID(LA7)
End DoDot:1
+15 SET HLSDATA(1)="PID"_HLFS_LA7PID
+16 QUIT
PV1 KILL LA7PV1
+1 SET LA7PV1(3)=$PIECE(LA7ACC0,"^",7)
+2 SET LA7PV1=""
+3 FOR LA7=0:0
SET LA7=$ORDER(LA7PV1(LA7))
IF 'LA7
QUIT
Begin DoDot:1
+4 SET $PIECE(LA7PV1,HLFS,LA7)=LA7PV1(LA7)
End DoDot:1
+5 SET HLSDATA(2)="PV1"_HLFS_LA7PV1
+6 QUIT
OBR ;
+1 IF '$DATA(ZTQUEUED)
IF $GET(LRLL)
IF $X+5>IOM
WRITE !,$SELECT($GET(LRTYPE):"Cup",1:"Seq"),": "
WRITE LA76822,", "
+2 NEW LA760,LA7CDT,LA7CMT,LA7I,LA7SPEC
+3 KILL LA7OBR
+4 SET LA7CNT=0
+5 ; Get infection warning if any.
+6 SET LRINFW=$GET(^LR(LRDFN,.091))
+7 ; Collection date/time node.
+8 SET LA7=$GET(^LRO(68,LA768,1,LA76801,1,LA76802,3))
+9 ; Draw time - If time invalid adjust to next lower valid time
+10 IF LA7
Begin DoDot:1
+11 NEW LA7X
+12 SET LA7X=$$CHKDT(+LA7)
+13 SET LA7CDT=$$HLDATE^HLFNC(LA7X,"TS")
End DoDot:1
+14 ; Specimen comment if any, strip "~".
SET LA7CMT=$TRANSLATE($PIECE(LA7,"^",6),"~")
+15 ;specimen
SET LA7=+$GET(^LRO(68,LA768,1,LA76801,1,LA76802,5,1,0))
+16 ;HL7 code from Topography
SET LA7SPEC=$$GET1^DIQ(61,LA7_",","LEDI HL7:HL7 ABBR")
+17 ;unique ID
SET LA7UID=$PIECE($GET(^LRO(68,LA768,1,LA76801,1,LA76802,.3)),"^")
+18 ;accession
SET LA7ACC=$PIECE($GET(^LRO(68,LA768,1,LA76801,1,LA76802,.2)),"^")
+19 SET LA7I=0
+20 FOR
SET LA7I=$ORDER(LA7ACC(LA7I))
IF 'LA7I
QUIT
Begin DoDot:1
+21 KILL LA7OBR
+22 SET LA760=+LA7ACC(LA7I)
+23 SET LA7TMP=$GET(^TMP("LA7",$JOB,LA7INST,LA7I))
+24 IF 'LA7TMP
QUIT
+25 SET LA7CODE=$PIECE(LA7TMP,"^",6)
+26 SET LA7DATA=$PIECE(LA7TMP,"^",7)
+27 SET LA7CNT=LA7CNT+1
SET LA7OBR(1)=LA7CNT
+28 SET LA7OBR(4)=LA7CODE_$EXTRACT(HLECH)_$PIECE(LA7TMP,"^",4)_$EXTRACT(HLECH)_99001_$EXTRACT(HLECH)_LA760_"X"_LA7DATA_$EXTRACT(HLECH)_$PIECE(^LAB(60,LA760,0),"^")_$EXTRACT(HLECH)_99002
+29 ; Draw time.
IF $GET(LA7CDT)
SET LA7OBR(7)=LA7CDT
+30 ; Infection warning.
IF $LENGTH(LRINFW)
SET LA7OBR(12)=$EXTRACT(HLECH)_LRINFW
+31 ; Specimen comment
SET LA7OBR(13)=LA7CMT
+32 ;HL7 code from Topography
SET LA7OBR(15)=LA7SPEC
+33 IF LRDPF'=2
SET $PIECE(LA7OBR(15),$EXTRACT(HLECH),3)=$SELECT(LRDPF=62.3:"CONTROL",1:"")
+34 SET LRCADR=""
SET LRCADR=$ORDER(^LAB(62.4,"B",$PIECE(LRAUTO,"^"),LRCADR))
+35 ;KAT
SET LA7D0=+$GET(LRCADR)
+36 SET LRCADR=$PIECE($GET(^LAB(62.4,+LRCADR,9)),U,9)
+37 ;instrument name^card address
SET LA7OBR(18)=$PIECE(LRAUTO,"^")_$EXTRACT(HLECH)_LRCADR
+38 ;KAT added instrument address
KILL LRCADR
+39 SET LA7OBR(19)=""
+40 FOR LA7="LA76821","LA76822","LA768","LA76801","LA76802","LA7ACC","LA7UID"
Begin DoDot:2
+41 ; No tray if don't send tray/cup flag.
IF LA7="LA76821"
IF '$GET(LRFORCE)
IF LA76821
NEW LA76821
SET LA76821=""
+42 ; No cup if don't send tray/cup flag.
IF LA7="LA76822"
IF '$GET(LRFORCE)
IF LA76822
NEW LA76822
SET LA76822=""
+43 SET LA7OBR(19)=LA7OBR(19)_@LA7_$EXTRACT(HLECH)
+44 ; LA7OBR(19)=tray^cup^lraa^lrad^lran^lracc^lruid
End DoDot:2
+45 ; Test urgency.
SET LA7=+$PIECE(LA7ACC(LA7I),"^",2)
+46 ; HL7 priority from Urgency file.
SET LA7=$PIECE($GET(^LAB(62.05,LA7,0)),"^",4)
+47 ; HL7 priority, default routine (R).
SET $PIECE(LA7OBR(27),$EXTRACT(HLECH),6)=$SELECT($LENGTH(LA7):LA7,1:"R")
+48 SET LA7=$PIECE($GET(^LRO(68,LA768,.4)),"^",2)
+49 ;KAT-Added using field .04 in Auto Instr file.
+50 SET LA7D0=+$PIECE($GET(^LAB(62.4,+LA7D0,9)),U,10)
+51 ;long or short sample ID
SET LA7OBR(2)=$SELECT(LA7="L":LA7UID,1:$EXTRACT("0000000000",1,LA7D0-$LENGTH(LA76802))_LA76802)
+52 KILL LA7D0
+53 FOR LA7=0:0
SET LA7=$ORDER(LA7OBR(LA7))
IF 'LA7
QUIT
Begin DoDot:2
+54 SET $PIECE(LA7OBR,HLFS,LA7)=LA7OBR(LA7)
End DoDot:2
+55 SET HLSDATA(3+LA7CNT)="OBR"_HLFS_LA7OBR
End DoDot:1
+56 QUIT
+57 ;
+58 ;
CHKDT(LA7X) ; Check validity of date/time
+1 ; Adjust invalid times to closest valid time - correct for lab problem
+2 ; that generated invalid FileMan date/times.
+3 ; If hours>24 then set to 24 with no minutes/seconds
+4 ; If minutes greater than 59 then set to 59
+5 ; If seconds greater than 59 then set to 59
+6 ;
+7 NEW I,LA7Y,X
+8 ;
+9 SET LA7Y=$PIECE(LA7X,".",2)
+10 ;
+11 ; If time present then check otherwise skip and return input.
+12 IF $LENGTH(LA7Y)
Begin DoDot:1
+13 FOR I=1:2:5
Begin DoDot:2
+14 SET LA7Y(I)=$EXTRACT(LA7Y,I,I+1)
+15 IF $LENGTH(LA7Y(I))=1
SET LA7Y(I)=LA7Y(I)_"0"
+16 IF LA7Y(I)>$SELECT(I=1:24,1:59)
SET LA7Y(I)=$SELECT(I=1:24,1:59)
+17 IF I=1
IF LA7Y(1)=24
SET LA7Y=24
End DoDot:2
+18 SET X="."_LA7Y(1)_LA7Y(3)_LA7Y(5)
SET X=+X
+19 SET $PIECE(LA7X,".",2)=$PIECE(X,".",2)
End DoDot:1
+20 ;
+21 QUIT LA7X
+22 ;
+23 ;
Q6249 ; create an entry in the MESSAGE QUEUE file to store this message
+1 ;
+2 NEW DIC,DINUM,DLAYGO
+3 ;
+4 SET LA7DTIM=$$NOW^XLFDT
+5 LOCK +^LAHM(62.49,0):9999999
+6 FOR X=$PIECE(^LAHM(62.49,0),"^",3):1
IF '$DATA(^LAHM(62.49,X))
QUIT
+7 SET LA76249=X
+8 KILL DD,DO
+9 SET DIC="^LAHM(62.49,"
SET DIC(0)="LF"
SET DLAYGO=62.49
+10 SET DINUM=X
+11 SET DIC("DR")="1////O;3////3;4////"_LA7DTIM_";.5////"_LA76248
+12 SET DIC("DR")=DIC("DR")_";2////Q;5////"_$PIECE(LRAUTO,"^",1)_"-O-"_LA7UID
+13 DO FILE^DICN
+14 LOCK -^LAHM(62.49,0)
+15 SET LA7MSH=HLSDATA(0)
+16 IF HLFS'="^"
SET LA7MSH=$TRANSLATE(LA7MSH,"^"," ")
SET LA7MSH=$TRANSLATE(LA7MSH,HLFS,"^")
+17 SET ^LAHM(62.49,LA76249,100)=LA7MSH
+18 SET LA71=0
SET LA7=""
+19 FOR
SET LA7=$ORDER(HLSDATA(LA7))
IF LA7=""
QUIT
Begin DoDot:1
+20 SET LA71=LA7
+21 SET ^LAHM(62.49,LA76249,150,LA7+1,0)=HLSDATA(LA7)
End DoDot:1
+22 SET ^LAHM(62.49,LA76249,150,0)="^^"_LA71_"^"_LA71_"^"_DT
+23 QUIT
