LA7UIO1 ;DALOI/JMC - Process Download Message for an entry in 62.48 ;12/11/15 16:39
;;5.2;AUTOMATED LAB INSTRUMENTS;**66,74,88**;Sep 27, 1994;Build 10
;
; Reference to PROTOCOL file (#101) supported by ICR #872
;
Q
;
BUILD ; Build one accession into an HL7 message
;
N GBL,HL,I,LA760,LA761,LA7CDT,LA7CMT,LA7CS,LA7ERR,LA7FAC,LA7FS,LA7ECH,LA7HLP,LA7I,LA7ID,LA7LINK,LA7NVAF,LA7OBRSN,LA7PIDSN,LA7SCMT,LA7SID,LA7SPEC,LA7SUB,LA7X,LA7Y
S GBL="^TMP(""HLS"","_$J_")"
;
I '$D(ZTQUEUED),$G(LRLL) W:$X+5>IOM !,$S($G(LRTYPE):"Cup",1:"Seq"),": " W LA76822,", "
;
S LA7CNT=0
F I=0,.1,.2,.3,3 S LA76802(I)=$G(^LRO(68,LA768,1,LA76801,1,LA76802,I))
S LA7X=LA76802(3)
; Draw time
S LA7CDT=+LA7X
;
; Specimen comment if any, strip "~"
S LA7SCMT=$TR($P(LA7X,"^",6),"~")
;
; Specimen
S LA761=+$G(^LRO(68,LA768,1,LA76801,1,LA76802,5,1,0))
; Accession/unique ID - Long (UID) or short (accession #) sample ID
S LA7ACC=$P(LA76802(.2),"^"),LA7UID=$P(LA76802(.3),"^"),LA7X=$G(^LRO(68,LA768,.4))
I $P(LA7X,"^",2)="S" S LA7SID=$$RJ^XLFSTR(LA76802,+$P(LA7X,"^",3),"0")
E S LA7SID=LA7UID
;
; Start message
D INIT Q:$G(HL)
;
; Setup links and subscriber array for HL7 message generation
S LA76248(0)=$G(^LAHM(62.48,LA76248,0)),LA7Y=$P(LA76248(0),"^")
I $E(LA7Y,1,5)'="LA7UI"!($P(LA76248(0),"^",9)'=1) Q
;
; Check if interface has been updagraded to HL7 v2.5.1 otherwise use v2.2 protocol
S LA7SUB="LA7UI ORM-O01 SUBS"
S X=$O(^ORD(101,"B",LA7SUB,0))
I X<1 S LA7SUB="LA7UI ORM-O01 SUBS 2.2"
;
S LA7LINK=LA7SUB_"^"_LA7Y
S LA7FAC=$P($$SITE^VASITE(DT),"^",3)
S LA7HLP("SUBSCRIBER")="^^"_LA7FAC_"^"_LA7Y_"^"
; Following line used when debugging
;S $P(LA7HLP("SUBSCRIBER"),"^",8)="1-1-2"
;
; Build segments PID, PV1, and ORC/OBR segment for each test to be sent
D PID,PV1
S (LA7I,LA7OBRSN)=0
F S LA7I=$O(LA7ACC(LA7I)) Q:'LA7I D ORC,OBR
; Build entry in MESSAGE QUEUE file 62.49
D SENDMSG
L -^LAHM(62.49,LA76249)
D KVAR^LRX
Q
;
;
INIT ; Create/initialize HL message
;
N LA7EVENT,X
;
K @GBL
S (LA76249,LA7NVAF,LA7PIDSN)=0
;
; Check if interface has been updagraded to HL7 v2.5.1 otherwise use v2.2 protocol
S LA7EVENT="LA7UI ORM-O01 EVENT"
S X=$O(^ORD(101,"B",LA7EVENT,0))
I X<1 S LA7EVENT="LA7UI ORM-O01 EVENT 2.2"
D STARTMSG^LA7VHLU(LA7EVENT,.LA76249)
;
S LA7ID=$P(LRAUTO,"^",1)_"-O-"_LA7UID
;
K ^TMP("LA7-ID",$J)
D SETID^LA7VHLU1(LA76249,"",LA7ID,1)
D SETID^LA7VHLU1(LA76249,"",LA7UID,0)
D SETID^LA7VHLU1(LA76249,"",LA7ACC,0)
S LA7CS=$E(LA7ECH,1)
I $G(HL) S LA7ERR=28 D UPDT6249^LA7VORM1
Q
;
;
PID ; Build PID segment
N LA7DATA,LA7FLAG,NAME,PID
S LRDFN=+LA7ACC0,LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
D DEM^LRX
;
S PID(0)="PID"
S PID(1)=1
S PID(3)=$$M11^HLFNC(LRDFN)
;
; Pass patient and referral files through name standardization.
; Don't pass lab control and other file's "paient" names thru name standardization as it affects name order.
I LRDPF?1(1"2",1"67",1"200") S NAME("FILE")=LRDPF,NAME("FIELD")=.01,NAME("IENS")=DFN,LA7FLAG="S"
E S NAME("FAMILY")=$P(PNM,","),NAME("GIVEN")=$P(PNM,",",2),LA7FLAG=""
S PID(5)=$$HLNAME^XLFNAME(.NAME,LA7FLAG,LA7CS)
;
; Date of birth
I DOB S PID(7)=$$FMTHL7^XLFDT(DOB)
S PID(8)=$S(SEX'="":SEX,1:"U")
;
; Race
D RACE
;
; Patient's SSN
I SSN'="" S PID(19)=SSN
;
D BUILDSEG^LA7VHLU(.PID,.LA7DATA,LA7FS)
D FILESEG^LA7VHLU(GBL,.LA7DATA)
D FILE6249^LA7VHLU(LA76249,.LA7DATA)
D SETID^LA7VHLU1(LA76249,"",PNM,0)
Q
;
;
PV1 ; Build PV1 segment
N LA7PV1,LA7X
D PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)
; If not inpatient use patient location from Accession
I $P(LA7PV1(0),LA7FS,3)'="I" S LA7X=$P($G(LA76802(0)),"^",7) S LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH) S $P(LA7PV1(0),LA7FS,4)=LA7X
;
D FILESEG^LA7VHLU(GBL,.LA7PV1)
D FILE6249^LA7VHLU(LA76249,.LA7PV1)
Q
;
;
ORC ; Build ORC segment
N LA7DATA,ORC
S ORC(0)="ORC"
S ORC(1)="NW"
;
; Placer/filler order number - sample ID
S ORC(2)=$$ORC2^LA7VORC(LA7SID,LA7FS,LA7ECH)
S ORC(3)=$$ORC3^LA7VORC(LA7SID,LA7FS,LA7ECH)
;
; Order/draw time - if no order date/time then try draw time
I $P(LA76802(0),"^",4) S ORC(9)=$$ORC9^LA7VORC($P(LA76802(0),"^",4))
I '$P(LA76802(0),"^",4),$P(LA76802(3),"^") S ORC(9)=$$ORC9^LA7VORC($P(LA76802(3),"^"))
;
; Provider
S LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
S ORC(12)=$$ORC12^LA7VORC($P(LA76802(0),"^",8),$P(LA7X,"^",3),LA7FS,LA7ECH,2)
; Provider Callback Number ;**88
S ORC(14)=$$ORC14^LA7VORC($P(LA76802(0),"^",8),DT,LA7FS,LA7ECH)
D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
D FILESEG^LA7VHLU(GBL,.LA7DATA)
D FILE6249^LA7VHLU(LA76249,.LA7DATA)
Q
;
;
OBR ; Build OBR segment
N LA764,LA7ALT,LA7CADR,LA7NLT,LA7TCMT
K OBR
;
S LA760=+LA7ACC(LA7I)
S LA764=+$P($G(^LAB(60,LA760,64)),"^")
S LA7NLT=$P($G(^LAM(LA764,0)),"^",2)
S LA7TMP=$G(^TMP("LA7",$J,LA7INST,LA7I))
Q:'LA7TMP
;
S LA7CODE=$P(LA7TMP,"^",6),LA7DATA=$P(LA7TMP,"^",7)
S OBR(0)="OBR"
S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
; Placer/filler order number - sample ID
S OBR(2)=$$OBR2^LA7VOBR(LA7SID,LA7FS,LA7ECH)
S OBR(3)=$$OBR3^LA7VOBR(LA7SID,LA7FS,LA7ECH)
; Test order code
S LA7ALT=LA7CODE_"^"_$$GET1^DIQ(60,LA760_",",.01)_"^"_"99001"
S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,LA760,LA7ALT,LA7FS,LA7ECH)
; Draw time.
I $G(LA7CDT) S OBR(7)=$$OBR7^LA7VOBR(LA7CDT)
; Infection warning.
S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
;
; Specimen comment
; If no specimen comment
; then check order for test comments on test
; or parent test if panel exploded
I LA7SCMT'="" S OBR(13)=$$OBR13^LA7VOBR(LA7SCMT,LA7FS,LA7ECH)
I LA7SCMT="" D
. S LA7TCMT=$$TESTCMT(LA768,LA76801,LA76802,LA760)
. I LA7TCMT="" D
. . N LA760P
. . S LA760P=$P(LA7ACC(LA7I),"^",3)
. . I LA760P>0,LA760'=LA760P S LA7TCMT=$$TESTCMT(LA768,LA76801,LA76802,LA760P)
. I LA7TCMT'="" S OBR(13)=$$OBR13^LA7VOBR(LA7TCMT,LA7FS,LA7ECH)
;
; Lab Arrival Time
S OBR(14)=$$OBR14^LA7VOBR($P(LA76802(3),"^",3))
; HL7 code from Topography
S LA7X=$S(LRDPF=62.3:"^^^CONTROL",1:"")
S OBR(15)=$$OBR15^LA7VOBR(LA761,"",LA7X,LA7FS,LA7ECH)
; Ordering provider
S LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
S OBR(16)=$$ORC12^LA7VORC($P(LA76802(0),"^",8),$P(LA7X,"^",3),LA7FS,LA7ECH,2)
; Provider Callback Number ;**88
S OBR(17)=$$ORC14^LA7VORC($P(LA76802(0),"^",8),DT,LA7FS,LA7ECH)
; Placer's field #1 - instrument name^card address
K LA7X
S LA7X(1)=$P(LRAUTO,"^")
S LA7CADR=$P($G(^LAB(62.4,LRINST,9)),U,9)
I LA7CADR'="" S LA7X(2)=LA7CADR
S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
; Placer's field #2 - tray^cup^lraa^lrad^lran^lracc^lruid
K LA7X
; No tray/cup if don't send tray/cup flag.
I $G(LRFORCE) S:LA76821 LA7X(1)=LA76821 S:LA76822 LA7X(2)=LA76822
S LA7X(3)=LA768,LA7X(4)=LA76801,LA7X(5)=LA76802,LA7X(6)=LA7ACC,LA7X(7)=LA7UID
S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
;
; Test urgency
S OBR(27)=$$OBR27^LA7VOBR("","",+$P(LA7ACC(LA7I),"^",2),LA7FS,LA7ECH)
;
K LA7DATA
D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
D FILESEG^LA7VHLU(GBL,.LA7DATA)
D FILE6249^LA7VHLU(LA76249,.LA7DATA)
Q
;
;
SENDMSG ; Send the HL7 message.
N HLL,HLP
S HLL("LINKS",1)=LA7LINK
I $D(LA7HLP) M HLP=LA7HLP
D GEN^LA7VHLU,UPDT6249^LA7VORM1
Q
;
;
TESTCMT(LA768,LA76801,LA76802,LA760) ; Check and build order test comments
;
; Call with LA768 = IEN of accesseion area
; LA76801 = FM accession date
; LA76802 = accession number
; LA760 = IEN of file #60 test
;
; Returns LA7CMT = comments in a single string (truncated to 300 characters per HL7 standard)
;
N LA7CMT,LA7I,LA7QUIT,LA7X,LA7Y,LRIEN,LRODT,LRSN
;
S LA7CMT="",LRIEN=0
S LA7Y=$G(^LRO(68,LA768,1,LA76801,1,LA76802,0))
S LRODT=+$P(LA7Y,"^",4),LRSN=+$P(LA7Y,"^",5)
I LRODT>0,LRSN>0 S LRIEN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LA760,0))
;
I LRIEN D
. S (LA7I,LA7QUIT)=0,LA7X=""
. F S LA7I=$O(^LRO(69,LRODT,1,LRSN,2,LRIEN,1,LA7I)) Q:LA7I<1 D Q:LA7QUIT
. . S LA7X=$G(^LRO(69,LRODT,1,LRSN,2,LRIEN,1,LA7I,0))
. . I $E(LA7X,1,10)="~For Test:" Q
. . I LA7X'="" S LA7X=$TR(LA7X,"~","")
. . I LA7CMT'="" S LA7X=" "_LA7X
. . S LA7CMT=LA7CMT_LA7X
. . I $L(LA7CMT)>300 S LA7CMT=$E(LA7CMT,1,300),LA7QUIT=1
;
Q LA7CMT
;
;
RACE ; Build RACE field in PID segment
;
N CNT,IEN,LA7X,LA7Y,RACE,RACENUM,X,Y
;
S PID(10)=""
;
; if from PATIENT file (#2) then check RACE array (VADM(12).
I LRDPF=2,$G(VADM(12)) D Q
. ; Loop through all races (CNT is repetition location)
. S RACENUM=0
. F CNT=1:1 S RACENUM=+$O(VADM(12,RACENUM)) Q:'RACENUM D
. . ; Fabricate race value -> RACE-METHOD
. . S RACE=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,2)
. . S X=$$PTR2CODE^DGUTL4(+$G(VADM(12,RACENUM,1)),3,2)
. . S:X="" X="UNK"
. . S RACE=RACE_"-"_X
. . ; First triplet
. . S LA7Y(10,CNT,1)=RACE
. . S LA7Y(10,CNT,2)=$P(VADM(12,RACENUM),"^",2)
. . S LA7Y(10,CNT,3)="HL70005"
. . ; Second triplet
. . S X=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,3)
. . S LA7Y(10,CNT,4)=X
. . S LA7Y(10,CNT,5)=$P(VADM(12,RACENUM),"^",2)
. . S LA7Y(10,CNT,6)="CDC"
. S IEN=0
. F S IEN=$O(LA7Y(10,IEN)) Q:IEN="" D
. . S LA7X=""
. . F CNT=1:1:6 I LA7Y(10,IEN,CNT)'="" S $P(LA7X,$E(LA7ECH,1),CNT)=LA7Y(10,IEN,CNT)
. . I LA7X="" Q
. . I PID(10)'="" S PID(10)=PID(10)_$E(LA7ECH,2)
. . S PID(10)=PID(10)_LA7X
;
; if from REFERRAL PATIENT file (#67) then check RACE field.
I LRDPF=67 D Q
. S LA7X=$$GET1^DIQ(67,DFN_",",.06,"I")
. I LA7X<1 Q
. S PID(10)=$$PTR2CODE^DGUTL4(LA7X,1,2)
. S $P(PID(10),$E(LA7ECH,1),2)=$$PTR2TEXT^DGUTL4(LA7X,1)
. S $P(PID(10),$E(LA7ECH,1),3)="HL70005"
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7UIO1 9710 printed Apr 09, 2024@20:45:15 Page 2
LA7UIO1 ;DALOI/JMC - Process Download Message for an entry in 62.48 ;12/11/15 16:39
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**66,74,88**;Sep 27, 1994;Build 10
+2 ;
+3 ; Reference to PROTOCOL file (#101) supported by ICR #872
+4 ;
+5 QUIT
+6 ;
BUILD ; Build one accession into an HL7 message
+1 ;
+2 NEW GBL,HL,I,LA760,LA761,LA7CDT,LA7CMT,LA7CS,LA7ERR,LA7FAC,LA7FS,LA7ECH,LA7HLP,LA7I,LA7ID,LA7LINK,LA7NVAF,LA7OBRSN,LA7PIDSN,LA7SCMT,LA7SID,LA7SPEC,LA7SUB,LA7X,LA7Y
+3 SET GBL="^TMP(""HLS"","_$JOB_")"
+4 ;
+5 IF '$DATA(ZTQUEUED)
IF $GET(LRLL)
if $X+5>IOM
WRITE !,$SELECT($GET(LRTYPE):"Cup",1:"Seq"),": "
WRITE LA76822,", "
+6 ;
+7 SET LA7CNT=0
+8 FOR I=0,.1,.2,.3,3
SET LA76802(I)=$GET(^LRO(68,LA768,1,LA76801,1,LA76802,I))
+9 SET LA7X=LA76802(3)
+10 ; Draw time
+11 SET LA7CDT=+LA7X
+12 ;
+13 ; Specimen comment if any, strip "~"
+14 SET LA7SCMT=$TRANSLATE($PIECE(LA7X,"^",6),"~")
+15 ;
+16 ; Specimen
+17 SET LA761=+$GET(^LRO(68,LA768,1,LA76801,1,LA76802,5,1,0))
+18 ; Accession/unique ID - Long (UID) or short (accession #) sample ID
+19 SET LA7ACC=$PIECE(LA76802(.2),"^")
SET LA7UID=$PIECE(LA76802(.3),"^")
SET LA7X=$GET(^LRO(68,LA768,.4))
+20 IF $PIECE(LA7X,"^",2)="S"
SET LA7SID=$$RJ^XLFSTR(LA76802,+$PIECE(LA7X,"^",3),"0")
+21 IF '$TEST
SET LA7SID=LA7UID
+22 ;
+23 ; Start message
+24 DO INIT
if $GET(HL)
QUIT
+25 ;
+26 ; Setup links and subscriber array for HL7 message generation
+27 SET LA76248(0)=$GET(^LAHM(62.48,LA76248,0))
SET LA7Y=$PIECE(LA76248(0),"^")
+28 IF $EXTRACT(LA7Y,1,5)'="LA7UI"!($PIECE(LA76248(0),"^",9)'=1)
QUIT
+29 ;
+30 ; Check if interface has been updagraded to HL7 v2.5.1 otherwise use v2.2 protocol
+31 SET LA7SUB="LA7UI ORM-O01 SUBS"
+32 SET X=$ORDER(^ORD(101,"B",LA7SUB,0))
+33 IF X<1
SET LA7SUB="LA7UI ORM-O01 SUBS 2.2"
+34 ;
+35 SET LA7LINK=LA7SUB_"^"_LA7Y
+36 SET LA7FAC=$PIECE($$SITE^VASITE(DT),"^",3)
+37 SET LA7HLP("SUBSCRIBER")="^^"_LA7FAC_"^"_LA7Y_"^"
+38 ; Following line used when debugging
+39 ;S $P(LA7HLP("SUBSCRIBER"),"^",8)="1-1-2"
+40 ;
+41 ; Build segments PID, PV1, and ORC/OBR segment for each test to be sent
+42 DO PID
DO PV1
+43 SET (LA7I,LA7OBRSN)=0
+44 FOR
SET LA7I=$ORDER(LA7ACC(LA7I))
if 'LA7I
QUIT
DO ORC
DO OBR
+45 ; Build entry in MESSAGE QUEUE file 62.49
+46 DO SENDMSG
+47 LOCK -^LAHM(62.49,LA76249)
+48 DO KVAR^LRX
+49 QUIT
+50 ;
+51 ;
INIT ; Create/initialize HL message
+1 ;
+2 NEW LA7EVENT,X
+3 ;
+4 KILL @GBL
+5 SET (LA76249,LA7NVAF,LA7PIDSN)=0
+6 ;
+7 ; Check if interface has been updagraded to HL7 v2.5.1 otherwise use v2.2 protocol
+8 SET LA7EVENT="LA7UI ORM-O01 EVENT"
+9 SET X=$ORDER(^ORD(101,"B",LA7EVENT,0))
+10 IF X<1
SET LA7EVENT="LA7UI ORM-O01 EVENT 2.2"
+11 DO STARTMSG^LA7VHLU(LA7EVENT,.LA76249)
+12 ;
+13 SET LA7ID=$PIECE(LRAUTO,"^",1)_"-O-"_LA7UID
+14 ;
+15 KILL ^TMP("LA7-ID",$JOB)
+16 DO SETID^LA7VHLU1(LA76249,"",LA7ID,1)
+17 DO SETID^LA7VHLU1(LA76249,"",LA7UID,0)
+18 DO SETID^LA7VHLU1(LA76249,"",LA7ACC,0)
+19 SET LA7CS=$EXTRACT(LA7ECH,1)
+20 IF $GET(HL)
SET LA7ERR=28
DO UPDT6249^LA7VORM1
+21 QUIT
+22 ;
+23 ;
PID ; Build PID segment
+1 NEW LA7DATA,LA7FLAG,NAME,PID
+2 SET LRDFN=+LA7ACC0
SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)
SET DFN=$PIECE(^(0),"^",3)
+3 DO DEM^LRX
+4 ;
+5 SET PID(0)="PID"
+6 SET PID(1)=1
+7 SET PID(3)=$$M11^HLFNC(LRDFN)
+8 ;
+9 ; Pass patient and referral files through name standardization.
+10 ; Don't pass lab control and other file's "paient" names thru name standardization as it affects name order.
+11 IF LRDPF?1(1"2",1"67",1"200")
SET NAME("FILE")=LRDPF
SET NAME("FIELD")=.01
SET NAME("IENS")=DFN
SET LA7FLAG="S"
+12 IF '$TEST
SET NAME("FAMILY")=$PIECE(PNM,",")
SET NAME("GIVEN")=$PIECE(PNM,",",2)
SET LA7FLAG=""
+13 SET PID(5)=$$HLNAME^XLFNAME(.NAME,LA7FLAG,LA7CS)
+14 ;
+15 ; Date of birth
+16 IF DOB
SET PID(7)=$$FMTHL7^XLFDT(DOB)
+17 SET PID(8)=$SELECT(SEX'="":SEX,1:"U")
+18 ;
+19 ; Race
+20 DO RACE
+21 ;
+22 ; Patient's SSN
+23 IF SSN'=""
SET PID(19)=SSN
+24 ;
+25 DO BUILDSEG^LA7VHLU(.PID,.LA7DATA,LA7FS)
+26 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+27 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+28 DO SETID^LA7VHLU1(LA76249,"",PNM,0)
+29 QUIT
+30 ;
+31 ;
PV1 ; Build PV1 segment
+1 NEW LA7PV1,LA7X
+2 DO PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)
+3 ; If not inpatient use patient location from Accession
+4 IF $PIECE(LA7PV1(0),LA7FS,3)'="I"
SET LA7X=$PIECE($GET(LA76802(0)),"^",7)
SET LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
SET $PIECE(LA7PV1(0),LA7FS,4)=LA7X
+5 ;
+6 DO FILESEG^LA7VHLU(GBL,.LA7PV1)
+7 DO FILE6249^LA7VHLU(LA76249,.LA7PV1)
+8 QUIT
+9 ;
+10 ;
ORC ; Build ORC segment
+1 NEW LA7DATA,ORC
+2 SET ORC(0)="ORC"
+3 SET ORC(1)="NW"
+4 ;
+5 ; Placer/filler order number - sample ID
+6 SET ORC(2)=$$ORC2^LA7VORC(LA7SID,LA7FS,LA7ECH)
+7 SET ORC(3)=$$ORC3^LA7VORC(LA7SID,LA7FS,LA7ECH)
+8 ;
+9 ; Order/draw time - if no order date/time then try draw time
+10 IF $PIECE(LA76802(0),"^",4)
SET ORC(9)=$$ORC9^LA7VORC($PIECE(LA76802(0),"^",4))
+11 IF '$PIECE(LA76802(0),"^",4)
IF $PIECE(LA76802(3),"^")
SET ORC(9)=$$ORC9^LA7VORC($PIECE(LA76802(3),"^"))
+12 ;
+13 ; Provider
+14 SET LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
+15 SET ORC(12)=$$ORC12^LA7VORC($PIECE(LA76802(0),"^",8),$PIECE(LA7X,"^",3),LA7FS,LA7ECH,2)
+16 ; Provider Callback Number ;**88
+17 SET ORC(14)=$$ORC14^LA7VORC($PIECE(LA76802(0),"^",8),DT,LA7FS,LA7ECH)
+18 DO BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
+19 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+20 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+21 QUIT
+22 ;
+23 ;
OBR ; Build OBR segment
+1 NEW LA764,LA7ALT,LA7CADR,LA7NLT,LA7TCMT
+2 KILL OBR
+3 ;
+4 SET LA760=+LA7ACC(LA7I)
+5 SET LA764=+$PIECE($GET(^LAB(60,LA760,64)),"^")
+6 SET LA7NLT=$PIECE($GET(^LAM(LA764,0)),"^",2)
+7 SET LA7TMP=$GET(^TMP("LA7",$JOB,LA7INST,LA7I))
+8 if 'LA7TMP
QUIT
+9 ;
+10 SET LA7CODE=$PIECE(LA7TMP,"^",6)
SET LA7DATA=$PIECE(LA7TMP,"^",7)
+11 SET OBR(0)="OBR"
+12 SET OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
+13 ; Placer/filler order number - sample ID
+14 SET OBR(2)=$$OBR2^LA7VOBR(LA7SID,LA7FS,LA7ECH)
+15 SET OBR(3)=$$OBR3^LA7VOBR(LA7SID,LA7FS,LA7ECH)
+16 ; Test order code
+17 SET LA7ALT=LA7CODE_"^"_$$GET1^DIQ(60,LA760_",",.01)_"^"_"99001"
+18 SET OBR(4)=$$OBR4^LA7VOBR(LA7NLT,LA760,LA7ALT,LA7FS,LA7ECH)
+19 ; Draw time.
+20 IF $GET(LA7CDT)
SET OBR(7)=$$OBR7^LA7VOBR(LA7CDT)
+21 ; Infection warning.
+22 SET OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
+23 ;
+24 ; Specimen comment
+25 ; If no specimen comment
+26 ; then check order for test comments on test
+27 ; or parent test if panel exploded
+28 IF LA7SCMT'=""
SET OBR(13)=$$OBR13^LA7VOBR(LA7SCMT,LA7FS,LA7ECH)
+29 IF LA7SCMT=""
Begin DoDot:1
+30 SET LA7TCMT=$$TESTCMT(LA768,LA76801,LA76802,LA760)
+31 IF LA7TCMT=""
Begin DoDot:2
+32 NEW LA760P
+33 SET LA760P=$PIECE(LA7ACC(LA7I),"^",3)
+34 IF LA760P>0
IF LA760'=LA760P
SET LA7TCMT=$$TESTCMT(LA768,LA76801,LA76802,LA760P)
End DoDot:2
+35 IF LA7TCMT'=""
SET OBR(13)=$$OBR13^LA7VOBR(LA7TCMT,LA7FS,LA7ECH)
End DoDot:1
+36 ;
+37 ; Lab Arrival Time
+38 SET OBR(14)=$$OBR14^LA7VOBR($PIECE(LA76802(3),"^",3))
+39 ; HL7 code from Topography
+40 SET LA7X=$SELECT(LRDPF=62.3:"^^^CONTROL",1:"")
+41 SET OBR(15)=$$OBR15^LA7VOBR(LA761,"",LA7X,LA7FS,LA7ECH)
+42 ; Ordering provider
+43 SET LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
+44 SET OBR(16)=$$ORC12^LA7VORC($PIECE(LA76802(0),"^",8),$PIECE(LA7X,"^",3),LA7FS,LA7ECH,2)
+45 ; Provider Callback Number ;**88
+46 SET OBR(17)=$$ORC14^LA7VORC($PIECE(LA76802(0),"^",8),DT,LA7FS,LA7ECH)
+47 ; Placer's field #1 - instrument name^card address
+48 KILL LA7X
+49 SET LA7X(1)=$PIECE(LRAUTO,"^")
+50 SET LA7CADR=$PIECE($GET(^LAB(62.4,LRINST,9)),U,9)
+51 IF LA7CADR'=""
SET LA7X(2)=LA7CADR
+52 SET OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+53 ; Placer's field #2 - tray^cup^lraa^lrad^lran^lracc^lruid
+54 KILL LA7X
+55 ; No tray/cup if don't send tray/cup flag.
+56 IF $GET(LRFORCE)
if LA76821
SET LA7X(1)=LA76821
if LA76822
SET LA7X(2)=LA76822
+57 SET LA7X(3)=LA768
SET LA7X(4)=LA76801
SET LA7X(5)=LA76802
SET LA7X(6)=LA7ACC
SET LA7X(7)=LA7UID
+58 SET OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+59 ;
+60 ; Test urgency
+61 SET OBR(27)=$$OBR27^LA7VOBR("","",+$PIECE(LA7ACC(LA7I),"^",2),LA7FS,LA7ECH)
+62 ;
+63 KILL LA7DATA
+64 DO BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
+65 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+66 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+67 QUIT
+68 ;
+69 ;
SENDMSG ; Send the HL7 message.
+1 NEW HLL,HLP
+2 SET HLL("LINKS",1)=LA7LINK
+3 IF $DATA(LA7HLP)
MERGE HLP=LA7HLP
+4 DO GEN^LA7VHLU
DO UPDT6249^LA7VORM1
+5 QUIT
+6 ;
+7 ;
TESTCMT(LA768,LA76801,LA76802,LA760) ; Check and build order test comments
+1 ;
+2 ; Call with LA768 = IEN of accesseion area
+3 ; LA76801 = FM accession date
+4 ; LA76802 = accession number
+5 ; LA760 = IEN of file #60 test
+6 ;
+7 ; Returns LA7CMT = comments in a single string (truncated to 300 characters per HL7 standard)
+8 ;
+9 NEW LA7CMT,LA7I,LA7QUIT,LA7X,LA7Y,LRIEN,LRODT,LRSN
+10 ;
+11 SET LA7CMT=""
SET LRIEN=0
+12 SET LA7Y=$GET(^LRO(68,LA768,1,LA76801,1,LA76802,0))
+13 SET LRODT=+$PIECE(LA7Y,"^",4)
SET LRSN=+$PIECE(LA7Y,"^",5)
+14 IF LRODT>0
IF LRSN>0
SET LRIEN=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LA760,0))
+15 ;
+16 IF LRIEN
Begin DoDot:1
+17 SET (LA7I,LA7QUIT)=0
SET LA7X=""
+18 FOR
SET LA7I=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRIEN,1,LA7I))
if LA7I<1
QUIT
Begin DoDot:2
+19 SET LA7X=$GET(^LRO(69,LRODT,1,LRSN,2,LRIEN,1,LA7I,0))
+20 IF $EXTRACT(LA7X,1,10)="~For Test:"
QUIT
+21 IF LA7X'=""
SET LA7X=$TRANSLATE(LA7X,"~","")
+22 IF LA7CMT'=""
SET LA7X=" "_LA7X
+23 SET LA7CMT=LA7CMT_LA7X
+24 IF $LENGTH(LA7CMT)>300
SET LA7CMT=$EXTRACT(LA7CMT,1,300)
SET LA7QUIT=1
End DoDot:2
if LA7QUIT
QUIT
End DoDot:1
+25 ;
+26 QUIT LA7CMT
+27 ;
+28 ;
RACE ; Build RACE field in PID segment
+1 ;
+2 NEW CNT,IEN,LA7X,LA7Y,RACE,RACENUM,X,Y
+3 ;
+4 SET PID(10)=""
+5 ;
+6 ; if from PATIENT file (#2) then check RACE array (VADM(12).
+7 IF LRDPF=2
IF $GET(VADM(12))
Begin DoDot:1
+8 ; Loop through all races (CNT is repetition location)
+9 SET RACENUM=0
+10 FOR CNT=1:1
SET RACENUM=+$ORDER(VADM(12,RACENUM))
if 'RACENUM
QUIT
Begin DoDot:2
+11 ; Fabricate race value -> RACE-METHOD
+12 SET RACE=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,2)
+13 SET X=$$PTR2CODE^DGUTL4(+$GET(VADM(12,RACENUM,1)),3,2)
+14 if X=""
SET X="UNK"
+15 SET RACE=RACE_"-"_X
+16 ; First triplet
+17 SET LA7Y(10,CNT,1)=RACE
+18 SET LA7Y(10,CNT,2)=$PIECE(VADM(12,RACENUM),"^",2)
+19 SET LA7Y(10,CNT,3)="HL70005"
+20 ; Second triplet
+21 SET X=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,3)
+22 SET LA7Y(10,CNT,4)=X
+23 SET LA7Y(10,CNT,5)=$PIECE(VADM(12,RACENUM),"^",2)
+24 SET LA7Y(10,CNT,6)="CDC"
End DoDot:2
+25 SET IEN=0
+26 FOR
SET IEN=$ORDER(LA7Y(10,IEN))
if IEN=""
QUIT
Begin DoDot:2
+27 SET LA7X=""
+28 FOR CNT=1:1:6
IF LA7Y(10,IEN,CNT)'=""
SET $PIECE(LA7X,$EXTRACT(LA7ECH,1),CNT)=LA7Y(10,IEN,CNT)
+29 IF LA7X=""
QUIT
+30 IF PID(10)'=""
SET PID(10)=PID(10)_$EXTRACT(LA7ECH,2)
+31 SET PID(10)=PID(10)_LA7X
End DoDot:2
End DoDot:1
QUIT
+32 ;
+33 ; if from REFERRAL PATIENT file (#67) then check RACE field.
+34 IF LRDPF=67
Begin DoDot:1
+35 SET LA7X=$$GET1^DIQ(67,DFN_",",.06,"I")
+36 IF LA7X<1
QUIT
+37 SET PID(10)=$$PTR2CODE^DGUTL4(LA7X,1,2)
+38 SET $PIECE(PID(10),$EXTRACT(LA7ECH,1),2)=$$PTR2TEXT^DGUTL4(LA7X,1)
+39 SET $PIECE(PID(10),$EXTRACT(LA7ECH,1),3)="HL70005"
End DoDot:1
QUIT
+40 ;
+41 QUIT
