LA7CORU ;VA/DALOI/JMC - Builder of HL7 Lab Results OBR/OBX/NTE ; 22-Oct-2013 09:22 ; MAW
;;5.2;AUTOMATED LAB INSTRUMENTS;**1002,27,46,61,1018,64,71,1027,68,1033**;NOV 01, 1997
;
; Cloned from LA7VORU
;
EN(LA) ; called from IN^LA7VMSG(...)
; variables
; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
; LA("LRDFN") - IEN in LAB DATA file (#63)
; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
; LA("AUTO-INST") - Auto-Instrument
;
N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY
;
S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
I $G(PRIMARY)'="" D
. S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
. S PRIMARY=$P(PRIMARY,U,3)
. S LA("AUTO-INST")="LA7V HOST "_PRIMARY
;
I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q
. ; need to add error logging when no entry in 63.
;
S LRDFN=LA("LRDFN"),LRSS=LA("SUB"),LRIDT=LA("LRIDT")
;
; Get zeroth node of entry in #63.
S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
S LA7NLT=$G(LA("NLT"))
;
S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
S LA7NTESN=0
D ORC
;
I $G(LA("SUB"))="CH" D CH
I $G(LA("SUB"))="MI" D MI^LA7VORU1
I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
Q
;
;
CH ; Build segments for "CH" subscript
;
D OBR
D NTE
S LA7OBXSN=0
D OBX
;
Q
;
;
ORC ; Build ORC segment
;
N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,LADFINST,ORC
;
S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
;
; Default institution from Kernel
S LADFINST=+$$KSP^XUPARAM("INST")
;
S ORC(0)="ORC"
;
; Order control
S ORC(1)=$$ORC1^LA7VORC("RE")
;
; Remote UID
K LA7X
M LA7X=LA("RUID")
S ORC(2)=$$ORC2^LA7CORC(.LA7X,LA7FS,LA7ECH)
;
; Host UID
K LA7X
M LA7X=LA("HUID")
S ORC(3)=ORC(2)
I $G(LA7INPT),$G(LRSS)="MI" D
. Q:'$G(LA7ORCSN)
. S $P(ORC(3),$E(LA7ECH))=$S(LA7ORCSN>1:LA7UID_$$SUFFIX^LA7CORUB(LA7ORCSN),1:LA7UID)
. S $P(ORC(3),$E(LA7ECH),2)="LR"
. I $G(LA7INPT),$G(LRSS)'="MI" S $P(ORC(3),$E(LA7ECH),3)="2.16.840.1.113883.3.72.5.24"
. I $G(LA7INPT),$G(LRSS)'="MI" S $P(ORC(3),$E(LA7ECH),4)="ISO"
I $G(LA7INPT),$G(LA7ADDON) D
. Q:'$G(LA7ORCSN)
. S $P(ORC(3),$E(LA7ECH))=$S(LA7ORCSN>1:LA7UID_$$SUFFIX^LA7CORUB(LA7ORCSN),1:LA7UID)
. S $P(ORC(3),$E(LA7ECH),2)="LR"
;S ORC(3)=$$ORC3^LA7CORC(.LA7X,LA7FS,LA7ECH)
S ORC(4)=ORC(3) ;ihs/cmi/maw mu2
;
; Return shipping manifest if found
S LA7SM="",LA7696=0
I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
;
; Order status
; DoD/CHCS requires ORC-5 valued otherwise will not process message
I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
;
; Ordering provider
K LA7X,LA7Y
S (LA7X,LA7Y)=""
; "CH" and "MI" subscript store requesting provider and requesting div/location.
I "CHMI"[LA("SUB") D
. N LA7J
. S LA7J=$P(LA763(0),"^",13)
. I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
. I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
. I LA("SUB")="CH" S LA7X=$P(LA763(0),"^",10)
. I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",7)
;
; Other subscripts only store requesting provider
I "CYEMSP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
;
I LA7Y="" S LA7Y=LADFINST
S LA7OP=LA7X
;S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$S($G(LA7INTYP)=30:2,$G(LA7NVAF)=1:0,1:1))
S ORC(12)=$$ORC12^LA7CORC(LA7X,LA7Y,LA7FS,LA7ECH,2)
S $P(ORC(12),$E(LA7ECH),9)="NPI"_$E(LA7ECH,4)_"2.16.840.1.113883.4.6"_$E(LA7ECH,4)_"ISO"
S $P(ORC(12),$E(LA7ECH),10)="L"
S $P(ORC(12),$E(LA7ECH),13)="NPI"
S $P(ORC(12),$E(LA7ECH),14)=LA7FAC_$E(LA7ECH,4)_"2.16.840.1.113883.3.72.5.26"_$E(LA7ECH,4)_"ISO"
S $P(ORC(12),$E(LA7ECH),21)=$P(ORC(12),$E(LA7ECH),6)
I $G(LA7INPT) S $P(ORC(12),$E(LA7ECH),7)="" ;mu2 inpatient
;
;provider call back number
;S ORC(14)=$$ORC14^LA7CORC(LA7X,LA7Y,LA7FS,LA7ECH)
S ORC(14)=$$OBR17^LA7COBR(LA7FS,LA7ECH) ;MU2 order call back number
;
; Enterer's location
;not used in MU2
;S LA7X=""
;I "CHMI"[LA("SUB") S LA7X=$P(LA763(0),"^",13)
;I LA7X'="" S ORC(13)=$$ORC13^LA7VORC(LA7X,LA7FS,LA7ECH)
;
; Entering organization
S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
;
; Ordering facility/address
S LA7X=$P($G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")),"^",3)
I 'LA7X,"CHMI"[LA("SUB") S LA7X=$P(LA763(0),"^",14)
I LA7X D
. S ORC(21)=$$ORC21^LA7CORC(LA7X,LA7FS,LA7ECH)
. S $P(ORC(21),$E(LA7ECH,1),6)="NIST Sending App"_$E(LA7ECH,4)_"2.16.840.1.113883.3.72.5.21"_$E(LA7ECH,4)_"ISO"
. S $P(ORC(21),$E(LA7ECH,1),10)=$P($G(^DIC(4,LA7X,99)),U)
. S ORC(22)=$$ORC22^LA7CORC(LA7X,$P(LA763(0),"^"),LA7FS,LA7ECH)
;
S ORC(23)=$$ORC23^LA7CORC(DUZ(2),DT,LA7FS,LA7ECH)
S ORC(24)=$$ORC24^LA7CORC(LA7OP,DT,LA7FS,LA7ECH)
D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
D FILESEG^LA7VHLU(GBL,.LA7DATA)
;
; Check for flag to only build message but do not file
I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA)
;
Q
;
;
OBR ;Observation Request segment for Lab Order
;
D OBR^LA7CORUB
Q
;
;
OBX ;Observation/Result segment for Lab Results
;
N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
;
S LA7VTIEN=0
F S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN D
. S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
. ; Build OBX segment
. K LA7DATA
. D OBX^LA7COBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF))
. ; If OBX failed to build then don't store
. I '$D(LA7DATA) Q
. ;
. D FILESEG^LA7VHLU(GBL,.LA7DATA)
. I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
. ;
. ; Send performing lab comment and interpretation from file #60
. S LA7NTESN=0
. I LA7NVAF=1 D PLC^LA7VORUA
. D INTRP^LA7VORUA
. ;
. ; Mark result as sent - set to 1, if corrected results set to 2
. I LA("SUB")="CH" D
. . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
. . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
;
Q
;
;
NTE ; Build NTE segment
;
D NTE^LA7CORUA
Q
;
TQ1(FS,ECH,ACC,LDFN,LIDT) ; build the TQ1 segment for MU2
N SPM,CS,RS,SC,TQ1
S CS=$E(ECH,1,1)
S RS=$E(ECH,2,2)
S SC=$E(ECH,3,3)
F I=1:1:14 S TQ1(I)=""
S TQ1="TQ1"
S TQ1(1)=1
S TQ1(7)=$$FMTHL7^XLFDT($P($G(^LR(LDFN,LRSS,LIDT,0)),U))
S TQ1(8)=$$FMTHL7^XLFDT($P($G(^LR(LDFN,LRSS,LIDT,0)),U,3))
F J=1:1:14 S $P(TQ1,FS,J+1)=TQ1(J)
Q TQ1
;
SPM(FS,ECH,ACC) ; build the SPM segment for MU2
N SPM,CS,RS,SC
S CS=$E(ECH,1,1)
S RS=$E(ECH,2,2)
S SC=$E(ECH,4,4)
F I=1:1:29 S SPM(I)=""
S SPM="SPM"
S SPM(1)=1
S SPM(2)=$$SPM2^LA7MUSPM(CS,SC,ACC)
S SPM(4)=$$SPM4^LA7MUSPM(CS,ACC,LRSPEC)
N ROI
S ROI=$O(^BLRRLO("ACC",ACC,0))
I ROI S SPM(5)=$$SPM5^LA7MUSPM(CS,ACC,LRSPEC,ROI) ;TODO
I $G(LRSAMP) S SPM(6)=$$SPM6^LA7MUSPM(CS,ACC,LRSPEC) ;TODO LOOK AT FILE 62
I $G(LRSAMP) S SPM(7)=$$SPM7^LA7MUSPM(CS,ACC,LRSPEC) ;TODO LOOK AT FILE 62
I $G(LRSAMP) S SPM(8)=$$SPM8^LA7MUSPM(CS,ACC,LRSPEC) ;TODO LOOK AT FILE 62
I ROI S SPM(9)=$$SPM9^LA7MUSPM(CS,ACC,LRSPEC,ROI) ;TODO
S SPM(11)=$$SPM11^LA7MUSPM(CS,ACC,LRSPEC) ;TODO FILE 61 TIME ASPECT FIELD
S SPM(12)=$$SPM12^LA7MUSPM(CS,SC,ACC,LRSPEC) ;TODO LOOKS LIKE HARD CODE RIGHT NOW
S SPM(17)=$$SPM17^LA7MUSPM(CS,LRDFN,LRIDT)
S SPM(18)=$$SPM18^LA7MUSPM(CS,LRDFN,LRIDT)
S SPM(21)=$$SPM21^LA7MUSPM(CS,ACC,LRSPEC)
F J=1:1:29 S $P(SPM,FS,J+1)=SPM(J)
Q SPM
;
LA7CORU ;VA/DALOI/JMC - Builder of HL7 Lab Results OBR/OBX/NTE ; 22-Oct-2013 09:22 ; MAW
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1002,27,46,61,1018,64,71,1027,68,1033**;NOV 01, 1997
+2 ;
+3 ; Cloned from LA7VORU
+4 ;
EN(LA) ; called from IN^LA7VMSG(...)
+1 ; variables
+2 ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
+3 ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
+4 ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
+5 ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
+6 ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
+7 ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
+8 ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
+9 ; LA("LRDFN") - IEN in LAB DATA file (#63)
+10 ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
+11 ; LA("AUTO-INST") - Auto-Instrument
+12 ;
+13 NEW LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY
+14 ;
+15 SET PRIMARY=$$PRIM^VASITE(DT)
SET LA("AUTO-INST")=""
+16 IF $GET(PRIMARY)'=""
Begin DoDot:1
+17 SET PRIMARY=$$SITE^VASITE(DT,PRIMARY)
+18 SET PRIMARY=$PIECE(PRIMARY,U,3)
+19 SET LA("AUTO-INST")="LA7V HOST "_PRIMARY
End DoDot:1
+20 ;
+21 IF '$ORDER(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
Begin DoDot:1
+22 ; need to add error logging when no entry in 63.
End DoDot:1
QUIT
+23 ;
+24 SET LRDFN=LA("LRDFN")
SET LRSS=LA("SUB")
SET LRIDT=LA("LRIDT")
+25 ;
+26 ; Get zeroth node of entry in #63.
+27 SET LA763(0)=$GET(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
+28 SET LA7NLT=$GET(LA("NLT"))
+29 ;
+30 SET LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
+31 SET LA7NTESN=0
+32 DO ORC
+33 ;
+34 IF $GET(LA("SUB"))="CH"
DO CH
+35 IF $GET(LA("SUB"))="MI"
DO MI^LA7VORU1
+36 IF "SPCYEM"[$GET(LA("SUB"))
DO AP^LA7VORU2
+37 QUIT
+38 ;
+39 ;
CH ; Build segments for "CH" subscript
+1 ;
+2 DO OBR
+3 DO NTE
+4 SET LA7OBXSN=0
+5 DO OBX
+6 ;
+7 QUIT
+8 ;
+9 ;
ORC ; Build ORC segment
+1 ;
+2 NEW LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,LADFINST,ORC
+3 ;
+4 SET LA763(0)=$GET(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
+5 ;
+6 ; Default institution from Kernel
+7 SET LADFINST=+$$KSP^XUPARAM("INST")
+8 ;
+9 SET ORC(0)="ORC"
+10 ;
+11 ; Order control
+12 SET ORC(1)=$$ORC1^LA7VORC("RE")
+13 ;
+14 ; Remote UID
+15 KILL LA7X
+16 MERGE LA7X=LA("RUID")
+17 SET ORC(2)=$$ORC2^LA7CORC(.LA7X,LA7FS,LA7ECH)
+18 ;
+19 ; Host UID
+20 KILL LA7X
+21 MERGE LA7X=LA("HUID")
+22 SET ORC(3)=ORC(2)
+23 IF $GET(LA7INPT)
IF $GET(LRSS)="MI"
Begin DoDot:1
+24 IF '$GET(LA7ORCSN)
QUIT
+25 SET $PIECE(ORC(3),$EXTRACT(LA7ECH))=$SELECT(LA7ORCSN>1:LA7UID_$$SUFFIX^LA7CORUB(LA7ORCSN),1:LA7UID)
+26 SET $PIECE(ORC(3),$EXTRACT(LA7ECH),2)="LR"
+27 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(ORC(3),$EXTRACT(LA7ECH),3)="2.16.840.1.113883.3.72.5.24"
+28 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(ORC(3),$EXTRACT(LA7ECH),4)="ISO"
End DoDot:1
+29 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
Begin DoDot:1
+30 IF '$GET(LA7ORCSN)
QUIT
+31 SET $PIECE(ORC(3),$EXTRACT(LA7ECH))=$SELECT(LA7ORCSN>1:LA7UID_$$SUFFIX^LA7CORUB(LA7ORCSN),1:LA7UID)
+32 SET $PIECE(ORC(3),$EXTRACT(LA7ECH),2)="LR"
End DoDot:1
+33 ;S ORC(3)=$$ORC3^LA7CORC(.LA7X,LA7FS,LA7ECH)
+34 ;ihs/cmi/maw mu2
SET ORC(4)=ORC(3)
+35 ;
+36 ; Return shipping manifest if found
+37 SET LA7SM=""
SET LA7696=0
+38 IF LA("SITE")'=""
IF LA("RUID")'=""
SET LA7696=$ORDER(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
+39 IF LA7696
SET LA7SM=$PIECE($GET(^LRO(69.6,LA7696,0)),U,14)
+40 IF LA7SM'=""
SET ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
+41 ;
+42 ; Order status
+43 ; DoD/CHCS requires ORC-5 valued otherwise will not process message
+44 IF LA7NVAF=1
SET ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
+45 ;
+46 ; Ordering provider
+47 KILL LA7X,LA7Y
+48 SET (LA7X,LA7Y)=""
+49 ; "CH" and "MI" subscript store requesting provider and requesting div/location.
+50 IF "CHMI"[LA("SUB")
Begin DoDot:1
+51 NEW LA7J
+52 SET LA7J=$PIECE(LA763(0),"^",13)
+53 IF $PIECE(LA7J,";",2)="SC("
SET LA7Y=$$GET1^DIQ(44,$PIECE(LA7J,";")_",",3,"I")
+54 IF $PIECE(LA7J,";",2)="DIC(4,"
SET LA7Y=$PIECE(LA7J,";")
+55 IF LA("SUB")="CH"
SET LA7X=$PIECE(LA763(0),"^",10)
+56 IF LA("SUB")="MI"
SET LA7X=$PIECE(LA763(0),"^",7)
End DoDot:1
+57 ;
+58 ; Other subscripts only store requesting provider
+59 IF "CYEMSP"[LA("SUB")
SET LA7X=$PIECE(LA763(0),"^",7)
+60 ;
+61 IF LA7Y=""
SET LA7Y=LADFINST
+62 SET LA7OP=LA7X
+63 ;S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$S($G(LA7INTYP)=30:2,$G(LA7NVAF)=1:0,1:1))
+64 SET ORC(12)=$$ORC12^LA7CORC(LA7X,LA7Y,LA7FS,LA7ECH,2)
+65 SET $PIECE(ORC(12),$EXTRACT(LA7ECH),9)="NPI"_$EXTRACT(LA7ECH,4)_"2.16.840.1.113883.4.6"_$EXTRACT(LA7ECH,4)_"ISO"
+66 SET $PIECE(ORC(12),$EXTRACT(LA7ECH),10)="L"
+67 SET $PIECE(ORC(12),$EXTRACT(LA7ECH),13)="NPI"
+68 SET $PIECE(ORC(12),$EXTRACT(LA7ECH),14)=LA7FAC_$EXTRACT(LA7ECH,4)_"2.16.840.1.113883.3.72.5.26"_$EXTRACT(LA7ECH,4)_"ISO"
+69 SET $PIECE(ORC(12),$EXTRACT(LA7ECH),21)=$PIECE(ORC(12),$EXTRACT(LA7ECH),6)
+70 ;mu2 inpatient
IF $GET(LA7INPT)
SET $PIECE(ORC(12),$EXTRACT(LA7ECH),7)=""
+71 ;
+72 ;provider call back number
+73 ;S ORC(14)=$$ORC14^LA7CORC(LA7X,LA7Y,LA7FS,LA7ECH)
+74 ;MU2 order call back number
SET ORC(14)=$$OBR17^LA7COBR(LA7FS,LA7ECH)
+75 ;
+76 ; Enterer's location
+77 ;not used in MU2
+78 ;S LA7X=""
+79 ;I "CHMI"[LA("SUB") S LA7X=$P(LA763(0),"^",13)
+80 ;I LA7X'="" S ORC(13)=$$ORC13^LA7VORC(LA7X,LA7FS,LA7ECH)
+81 ;
+82 ; Entering organization
+83 SET ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
+84 ;
+85 ; Ordering facility/address
+86 SET LA7X=$PIECE($GET(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")),"^",3)
+87 IF 'LA7X
IF "CHMI"[LA("SUB")
SET LA7X=$PIECE(LA763(0),"^",14)
+88 IF LA7X
Begin DoDot:1
+89 SET ORC(21)=$$ORC21^LA7CORC(LA7X,LA7FS,LA7ECH)
+90 SET $PIECE(ORC(21),$EXTRACT(LA7ECH,1),6)="NIST Sending App"_$EXTRACT(LA7ECH,4)_"2.16.840.1.113883.3.72.5.21"_$EXTRACT(LA7ECH,4)_"ISO"
+91 SET $PIECE(ORC(21),$EXTRACT(LA7ECH,1),10)=$PIECE($GET(^DIC(4,LA7X,99)),U)
+92 SET ORC(22)=$$ORC22^LA7CORC(LA7X,$PIECE(LA763(0),"^"),LA7FS,LA7ECH)
End DoDot:1
+93 ;
+94 SET ORC(23)=$$ORC23^LA7CORC(DUZ(2),DT,LA7FS,LA7ECH)
+95 SET ORC(24)=$$ORC24^LA7CORC(LA7OP,DT,LA7FS,LA7ECH)
+96 DO BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
+97 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+98 ;
+99 ; Check for flag to only build message but do not file
+100 IF '$GET(LA7NOMSG)
DO FILE6249^LA7VHLU(LA76249P,.LA7DATA)
+101 ;
+102 QUIT
+103 ;
+104 ;
OBR ;Observation Request segment for Lab Order
+1 ;
+2 DO OBR^LA7CORUB
+3 QUIT
+4 ;
+5 ;
OBX ;Observation/Result segment for Lab Results
+1 ;
+2 NEW LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
+3 ;
+4 SET LA7VTIEN=0
+5 FOR
SET LA7VTIEN=$ORDER(^LAHM(62.49,LA(62.49),1,LA7VTIEN))
IF 'LA7VTIEN
QUIT
Begin DoDot:1
+6 SET LA7VT=$PIECE(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
+7 ; Build OBX segment
+8 KILL LA7DATA
+9 DO OBX^LA7COBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$PIECE(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$GET(LA7NVAF))
+10 ; If OBX failed to build then don't store
+11 IF '$DATA(LA7DATA)
QUIT
+12 ;
+13 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+14 IF '$GET(LA7NOMSG)
DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+15 ;
+16 ; Send performing lab comment and interpretation from file #60
+17 SET LA7NTESN=0
+18 IF LA7NVAF=1
DO PLC^LA7VORUA
+19 DO INTRP^LA7VORUA
+20 ;
+21 ; Mark result as sent - set to 1, if corrected results set to 2
+22 IF LA("SUB")="CH"
Begin DoDot:2
+23 IF $PIECE(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$PIECE(LA7VT,"^")),"^",10)>1
QUIT
+24 SET $PIECE(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$PIECE(LA7VT,"^")),"^",10)=$SELECT($PIECE(LA7VT,"^",2)="C":2,1:1)
End DoDot:2
End DoDot:1
+25 ;
+26 QUIT
+27 ;
+28 ;
NTE ; Build NTE segment
+1 ;
+2 DO NTE^LA7CORUA
+3 QUIT
+4 ;
TQ1(FS,ECH,ACC,LDFN,LIDT) ; build the TQ1 segment for MU2
+1 NEW SPM,CS,RS,SC,TQ1
+2 SET CS=$EXTRACT(ECH,1,1)
+3 SET RS=$EXTRACT(ECH,2,2)
+4 SET SC=$EXTRACT(ECH,3,3)
+5 FOR I=1:1:14
SET TQ1(I)=""
+6 SET TQ1="TQ1"
+7 SET TQ1(1)=1
+8 SET TQ1(7)=$$FMTHL7^XLFDT($PIECE($GET(^LR(LDFN,LRSS,LIDT,0)),U))
+9 SET TQ1(8)=$$FMTHL7^XLFDT($PIECE($GET(^LR(LDFN,LRSS,LIDT,0)),U,3))
+10 FOR J=1:1:14
SET $PIECE(TQ1,FS,J+1)=TQ1(J)
+11 QUIT TQ1
+12 ;
SPM(FS,ECH,ACC) ; build the SPM segment for MU2
+1 NEW SPM,CS,RS,SC
+2 SET CS=$EXTRACT(ECH,1,1)
+3 SET RS=$EXTRACT(ECH,2,2)
+4 SET SC=$EXTRACT(ECH,4,4)
+5 FOR I=1:1:29
SET SPM(I)=""
+6 SET SPM="SPM"
+7 SET SPM(1)=1
+8 SET SPM(2)=$$SPM2^LA7MUSPM(CS,SC,ACC)
+9 SET SPM(4)=$$SPM4^LA7MUSPM(CS,ACC,LRSPEC)
+10 NEW ROI
+11 SET ROI=$ORDER(^BLRRLO("ACC",ACC,0))
+12 ;TODO
IF ROI
SET SPM(5)=$$SPM5^LA7MUSPM(CS,ACC,LRSPEC,ROI)
+13 ;TODO LOOK AT FILE 62
IF $GET(LRSAMP)
SET SPM(6)=$$SPM6^LA7MUSPM(CS,ACC,LRSPEC)
+14 ;TODO LOOK AT FILE 62
IF $GET(LRSAMP)
SET SPM(7)=$$SPM7^LA7MUSPM(CS,ACC,LRSPEC)
+15 ;TODO LOOK AT FILE 62
IF $GET(LRSAMP)
SET SPM(8)=$$SPM8^LA7MUSPM(CS,ACC,LRSPEC)
+16 ;TODO
IF ROI
SET SPM(9)=$$SPM9^LA7MUSPM(CS,ACC,LRSPEC,ROI)
+17 ;TODO FILE 61 TIME ASPECT FIELD
SET SPM(11)=$$SPM11^LA7MUSPM(CS,ACC,LRSPEC)
+18 ;TODO LOOKS LIKE HARD CODE RIGHT NOW
SET SPM(12)=$$SPM12^LA7MUSPM(CS,SC,ACC,LRSPEC)
+19 SET SPM(17)=$$SPM17^LA7MUSPM(CS,LRDFN,LRIDT)
+20 SET SPM(18)=$$SPM18^LA7MUSPM(CS,LRDFN,LRIDT)
+21 SET SPM(21)=$$SPM21^LA7MUSPM(CS,ACC,LRSPEC)
+22 FOR J=1:1:29
SET $PIECE(SPM,FS,J+1)=SPM(J)
+23 QUIT SPM
+24 ;
