LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ;Jun 14, 2022@18:38
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,66,74,85,88,101**;Sep 27, 1994;Build 6
;
; This routine is a continuation of LA7VIN1 and is only called from there.
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
Q
;
OBR ; Process OBR segments
N I,LA7CUP,LA7ENTRY,LA7FF1,LA7FF2,LA7I,LA7IDE,LA7INST,LA7OK,LA7PDUZ,LA7PF1,LA7PF2,LA7TRAY,LA7X,LA7Y
;
;ZEXCEPT: A,CH,CY,EM,G,LA70070,LA761,LA762,LA7624,LA76248,LA76249
;ZEXCEPT: LA7AA,LA7ACC,LA7AD,LA7AERR,LA7AN,LA7ARI,LA7AUTORELEASE,LA7CDT,LA7CS,LA7ECH,LA7ERR,LA7FID,LA7FS,LA7ID,LA7INTYP,LA7ISQN,LA7LWL,LA7MSATM,LA7MTYP
;ZEXCEPT: LA7OBR,LA7OBR25,LA7OBR26,LA7OBR29,LA7OBR32,LA7OBR33,LA7OBR34,LA7OBR49,LA7OCR,LA7ONLT,LA7OTYPE,LA7POP,LA7PRI,LA7QUIT
;ZEXCEPT: LA7RSDT,LA7SAC,LA7SAP,LA7SEG,LA7SFAC,LA7SID,LA7SM,LA7SOBR,LA7SPEC,LA7SPTY,LA7SS,LA7TECH,LA7UID,LAPSUBID,MI,N,SP
;
; OBR Set ID
S LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
;
S LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
S LA7624=0,LA7INST=$P(LA7X,"^") ; extracting 1st piece
; Look up #62.4 entry from instrument name.
I LA7INST'="" S LA7624=+$O(^LAB(62.4,"B",LA7INST,0))
;
; If none then use sending application name to look up #62.4 entry.
I 'LA7624 S LA7624=+$O(^LAB(62.4,"B",LA7SAP,0))
;
; Instrument name not found in xref
I 'LA7624 D Q
. I LA7INST="" D Q
. . S LA7ERR=10,LA7QUIT=2
. . D CREATE^LA7LOG(LA7ERR)
. S LA7ERR=11,LA7QUIT=2
. S LA7AERR=$$CREATE^LA7LOG(LA7ERR,1)
S LA7624(0)=$G(^LAB(62.4,LA7624,0))
S LA7ID=$P(LA7624(0),"^")_"-I-"
;
S LA7LWL=+$P(LA7624(0),"^",4) ; Load/Work List
S LA7ENTRY=$P(LA7624(0),"^",6) ;LOG,LLIST,IDENT or SEQN
S:LA7ENTRY="" LA7ENTRY="LOG"
;
; Placer(sender)/filler order numbers
S LA7X=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
S LA7SID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7SID(I)=$P(LA7X,$E(LA7ECH),I)
S LA7X=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
S LA7FID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7FID(I)=$P(LA7X,$E(LA7ECH),I)
;
; Test order code - find order NLT code
; If POC interface then see if NLT is used for ordering code
S LA7X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7ONLT=""
F I=1,4 D Q:LA7ONLT'=""
. I $P(LA7X,LA7CS,I)'?5N1"."4N Q
. I $P(LA7X,LA7CS,I+2)="99VA64" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
. I LA7INTYP>19,LA7INTYP<30,$P(LA7X,LA7CS,I+2)="" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
;
; Specimen collection date/time
S LA7CDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L")
;
; Extract filler fields #1&2 and placer fields #1&2
F LA7I=18:1:21 D
. S LA7X=$$P^LA7VHLU(.LA7SEG,LA7I+1,LA7FS)
. S LA7OBR(LA7I)=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
;
; Pull info from placer field #2 (OBR-19)
S LA7X=LA7OBR(19)
S LA7TRAY=+$P(LA7X,"^",1) ;Tray
S LA7CUP=+$P(LA7X,"^",2) ; Cup
; If POC interface set cup to file #62.49 ien
I LA7INTYP>19,LA7INTYP<30 S LA7CUP=LA76249
S LA7AA=$P(LA7X,"^",3) ; Accession Area
S LA7AD=$P(LA7X,"^",4) ; Accession Date
S LA7AN=$P(LA7X,"^",5) ; Accession Entry
S LA7ACC=$P(LA7X,"^",6) ; Accession
I LA7ACC'="" D SETID^LA7VHLU1(LA76249,LA7ID,LA7ACC,0)
S LA7UID=$P(LA7X,"^",7) ; Unique ID
I $L(LA7UID)<10 S LA7UID=""
;
; Sequence Number
; If point of care interface (20-29) then use file #62.49 ien as IDE
S LA7IDE=$P(LA7X,LA7CS,8)
I LA7INTYP>19,LA7INTYP<30 S LA7IDE=LA76249
;
; UID might come as Sample ID
I LA7UID="",$L(LA7SID)>9 S LA7UID=LA7SID
;
; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID)
; accession may have rolled over, use UID to get current accession info.
I LA7UID'="" D
. N X
. S X=$Q(^LRO(68,"C",LA7UID)) Q:X="" ; UID not on file
. I $QS(X,3)'=LA7UID S LA7UID="" Q ; UID not on file.
. S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
. D SETID^LA7VHLU1(LA76249,LA7ID,LA7UID,1)
. D SETID^LA7VHLU1(LA76249,"",LA7UID,0)
;
; If still not known, compute from default accession date and area.
; Calculate accession date based on accession transform.
I LA7AA<1!(LA7AD<1)!(LA7AN<1) D
. N X
. S LA7AA=+$P(LA7624(0),"^",11)
. S X=$P($G(^LRO(68,LA7AA,0)),U,3)
. S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
. S LA7AN=+LA7SID
. I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN,1)
. I LA7SID'="" D SETID^LA7VHLU1(LA76249,LA7ID,LA7SID,0)
;
; Zeroth node of accession area.
S LA7AA(0)=$G(^LRO(68,+LA7AA,0))
; Accession's subscript
S LA7SS=$P(LA7AA(0),"^",2)
;
; Specimen action code
S LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
;
; Specimen(topography), collection sample, HL7 specimen source
S (LA761,LA762,LA70070,LA7SPEC)=""
S LA7X=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
D FLD2ARR^LA7VHLU7(.LA7X,LA7FS_LA7ECH)
M LA7SPTY=LA7X(1)
;
; Look for HL7 Table 0070 code.
; If coding system blank then default to table 0070 as coding system per HL7 standard for OBR-15.
; If no code and not a standard code set then ignore (remove).
F I=1,4 D
. I $G(LA7SPTY(I))="",$G(LA7SPTY(I+2))'?1(1"99".E,1"L") K LA7SPTY(I),LA7SPTY(I+1),LA7SPTY(I+2),LA7SPTY($S(I=1:7,1:8)) Q
. I $G(LA7SPTY(I+2))="" S LA7SPTY(I+2)="HL70070"
. I LA7SPTY(I+2)="HL70070" S LA7SPEC=LA7SPTY(I)
I LA7SPEC="" S LA7SPEC=$G(LA7SPTY)
;
; Retrieve related specimen/collection sample from accession
; Create specimen array to handle multiple AP specimens on orders.
S I=0
F S I=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,I)) Q:'I D
. S X=^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,I,0)
. I $P(X,"^") D
. . S LA761($P(X,"^"))="" ;spec array
. . I LA761="" S LA761=$P(X,"^")
. I $P(X,"^",2) D
. . S LA762($P(X,"^",2))="" ;sample array
. . I LA762="" S LA762=$P(X,"^",2)
;
; Log error when specimen source does not match accession's specimen
; Ignore if specimen related to lab control file #62.3
S LA7OK=1
I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)'=62.3 D
. N DIERR,LA7MSG
. F LA7I=1,4 I $G(LA7SPTY(LA7I))'="" D Q:'LA7OK
. . I $G(LA7SPTY(LA7I+2))="HL70070" D Q
. . . K DIERR,LA7MSG
. . . S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR",,,"LA7MSG")
. . . I LA70070'="",LA70070'=LA7SPTY(LA7I) S LA7OK=0,LA7OK(0)="HL7 "_LA7SPTY(LA7I)
. . I $G(LA7SPTY(LA7I+2))="SCT" D OBRSCT Q
;
I 'LA7OK D
. N LA7MSG
. S LA7ERR=49,LA7QUIT=2,LA7MSG=LA7OK(0)
. S LA7AERR=$$CREATE^LA7LOG(LA7ERR,1)
;
; Don't continue if flag set to skip this segment
I LA7QUIT Q
;
; Placer's ordering provider (id^duz^last name, first name, mi [id])
I $G(LA7POP)="" D
. S LA7POP="",LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
. I LA7X="" Q
. S LA7POP=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
. I LA7POP="^^" S LA7POP=""
;
; Results rpt/status chng - date/time
S LA7X=$$P^LA7VHLU(.LA7SEG,23,LA7FS),LA7RSDT=""
I LA7X'="" S LA7RSDT=$$HL7TFM^XLFDT(LA7X,"L")
;
; Result status
S LA7OBR25=$$P^LA7VHLU(.LA7SEG,26,LA7FS)
;
; Parent result - CM data type.
; Save OBX-4 (sub-id) of parent result in LAPSUBID for subsequent usage by OBX/NTE's.
S LA7OBR26=$$FIELD^LA7VHLU7(26)
D FLD2ARR^LA7VHLU7(.LA7OBR26)
S LAPSUBID=$G(LA7OBR26(2))
;
; Parent
S LA7OBR29=$$FIELD^LA7VHLU7(29)
D FLD2ARR^LA7VHLU7(.LA7OBR29)
;
; Principle Result interpreter
S LA7OBR32=$$FIELD^LA7VHLU7(32),LA7PRI=""
D FLD2ARR^LA7VHLU7(.LA7OBR32)
I $G(LA7OBR32(1))'="" D
. S LA7X=$TR(LA7OBR32(1),$E(LA7ECH,4),$E(LA7ECH))
. S LA7PRI=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
. I LA7PRI="^^" S LA7PRI=""
;
; Assistant Result Interpreter
S LA7OBR33=$$FIELD^LA7VHLU7(33),LA7ARI=""
D FLD2ARR^LA7VHLU7(.LA7OBR33)
I $G(LA7OBR33(1))'="" D
. S LA7X=$TR(LA7OBR33(1),$E(LA7ECH,4),$E(LA7ECH))
. S LA7ARI=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
. I LA7ARI="^^" S LA7ARI=""
;
; Technician
S LA7OBR34=$$FIELD^LA7VHLU7(34),LA7TECH=""
D FLD2ARR^LA7VHLU7(.LA7OBR34)
I $G(LA7OBR34(1))'="" D
. S LA7X=$TR(LA7OBR34(1),$E(LA7ECH,4),$E(LA7ECH))
. S LA7TECH=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
. I LA7TECH="^^" S LA7TECH=""
;
; Results handling
; Usually IS data type however later HL7 versions use CWE data type. Attempt to handle either format.
S LA7X=$$P^LA7VHLU(.LA7SEG,50,LA7FS)
S LA7OBR49=$P(LA7X,LA7CS,1)
;
; Set Auto Release flag at OBR level for comments (NTE segments) before processing OBX segment, use "-.0000" in lieu of OBX.17 suffix value
I LA7MTYP="ORU" S LA7AUTORELEASE=$$ARSTATUS^LA7VIN5(LA7OBR49,"-.0000",LA7624)
;
; Create entry in LAH for supported subscripts.
I LA7MTYP="ORR",$G(LA7OTYPE)'="OK",LA7SS?1(1"CH",1"MI",1"SP",1"CY",1"EM") D
. D LAGEN^LA7VIN4A
. I $G(LA7ISQN)="" D CREATE^LA7LOG(14) Q
. S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1
. I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
. E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
. S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$P($G(LA7SM),"^",2)
. S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
. I $G(LA7OCR)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"OCR")=$TR(LA7OCR,LA7CS,"^")
. I $G(LA7MSATM)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"MSA")=LA7MSATM
;
I LA7MTYP="ORU",LA7SS?1(1"CH",1"MI",1"SP",1"CY",1"EM") D
. D LAGEN^LA7VIN4A
. I $G(LA7ISQN)<1 S LA7ERR=14,LA7AERR=$$CREATE^LA7LOG(LA7ERR,1) Q
. I LA7INTYP=10,LA7SAC?1(1"A",1"G") D
. . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1,LA7SAC(0)=LA7I
. . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
. . E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
. . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2)
. . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
. I LA7INTYP=10,LA7OBR25?1(1"A",1"X") D
. . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1
. . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
. . E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
. . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2)_"^"_LA7OBR25
. . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
. I LA7INTYP=10,LA7SS?1(1"MI",1"SP",1"CY",1"EM") S ^TMP("LA7-PL-NTE",$J,LA7LWL,LA7ISQN,LA7SS)=LA7SFAC
;
;LA*5.2*101: Do not require that LA7SM (shipping manifest identifier) not be null
I LA7INTYP=10,$G(LA7UID)'="" D SMUPDT^LA7VIN4A
Q
;
;
OBRSCT ; check if SCT doesn't match any specimen in #68
;
;ZEXCEPT: LA761,LA76248,LA7I,LA7OK,LA7SPTY
;
N LA761SCT,R61,SCTOK
S (R61,SCTOK)=0
F S R61=$O(LA761(R61)) Q:'R61 D
. I $D(^LAHM(62.48,LA76248,"SCT","AD1",LA7SPTY(LA7I),R61_";LAB(61,")) S SCTOK=1 Q
. S LA761SCT=$$IEN2SCT^LA7VHLU6(61,R61,DT,"")
. I LA761SCT'>0 S SCTOK=1
. I $P(LA761SCT,"^")=LA7SPTY(LA7I) S SCTOK=1
;
; If no topography found on accession with a SCT mapping that matches SCT code then flag as error.
; Also if SCT code in message has Lexicon exception then record as a separate error.
I 'SCTOK D
. N LA7SCT,LA7X,LA7Z
. S LA7OK=0,LA7OK(0)="SCTID "_LA7SPTY(LA7I)
. S LA7Z=$$CODE^LEXTRAN(LA7SPTY(LA7I),"SCT",DT,"LA7SCT")
. I $P(LA7Z,"^",5) D
. . S LA7X=$P(LA7Z,"^",6)
. . D CREATE^LA7LOG(37)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN4 11284 printed Sep 23, 2025@19:16:25 Page 2
LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ;Jun 14, 2022@18:38
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,66,74,85,88,101**;Sep 27, 1994;Build 6
+2 ;
+3 ; This routine is a continuation of LA7VIN1 and is only called from there.
+4 ;
+5 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+6 ; used in conjunction with Eclipse M-editor.
+7 ;
+8 QUIT
+9 ;
OBR ; Process OBR segments
+1 NEW I,LA7CUP,LA7ENTRY,LA7FF1,LA7FF2,LA7I,LA7IDE,LA7INST,LA7OK,LA7PDUZ,LA7PF1,LA7PF2,LA7TRAY,LA7X,LA7Y
+2 ;
+3 ;ZEXCEPT: A,CH,CY,EM,G,LA70070,LA761,LA762,LA7624,LA76248,LA76249
+4 ;ZEXCEPT: LA7AA,LA7ACC,LA7AD,LA7AERR,LA7AN,LA7ARI,LA7AUTORELEASE,LA7CDT,LA7CS,LA7ECH,LA7ERR,LA7FID,LA7FS,LA7ID,LA7INTYP,LA7ISQN,LA7LWL,LA7MSATM,LA7MTYP
+5 ;ZEXCEPT: LA7OBR,LA7OBR25,LA7OBR26,LA7OBR29,LA7OBR32,LA7OBR33,LA7OBR34,LA7OBR49,LA7OCR,LA7ONLT,LA7OTYPE,LA7POP,LA7PRI,LA7QUIT
+6 ;ZEXCEPT: LA7RSDT,LA7SAC,LA7SAP,LA7SEG,LA7SFAC,LA7SID,LA7SM,LA7SOBR,LA7SPEC,LA7SPTY,LA7SS,LA7TECH,LA7UID,LAPSUBID,MI,N,SP
+7 ;
+8 ; OBR Set ID
+9 SET LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
+10 ;
+11 SET LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
+12 SET LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+13 ; extracting 1st piece
SET LA7624=0
SET LA7INST=$PIECE(LA7X,"^")
+14 ; Look up #62.4 entry from instrument name.
+15 IF LA7INST'=""
SET LA7624=+$ORDER(^LAB(62.4,"B",LA7INST,0))
+16 ;
+17 ; If none then use sending application name to look up #62.4 entry.
+18 IF 'LA7624
SET LA7624=+$ORDER(^LAB(62.4,"B",LA7SAP,0))
+19 ;
+20 ; Instrument name not found in xref
+21 IF 'LA7624
Begin DoDot:1
+22 IF LA7INST=""
Begin DoDot:2
+23 SET LA7ERR=10
SET LA7QUIT=2
+24 DO CREATE^LA7LOG(LA7ERR)
End DoDot:2
QUIT
+25 SET LA7ERR=11
SET LA7QUIT=2
+26 SET LA7AERR=$$CREATE^LA7LOG(LA7ERR,1)
End DoDot:1
QUIT
+27 SET LA7624(0)=$GET(^LAB(62.4,LA7624,0))
+28 SET LA7ID=$PIECE(LA7624(0),"^")_"-I-"
+29 ;
+30 ; Load/Work List
SET LA7LWL=+$PIECE(LA7624(0),"^",4)
+31 ;LOG,LLIST,IDENT or SEQN
SET LA7ENTRY=$PIECE(LA7624(0),"^",6)
+32 if LA7ENTRY=""
SET LA7ENTRY="LOG"
+33 ;
+34 ; Placer(sender)/filler order numbers
+35 SET LA7X=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
+36 SET LA7SID=$PIECE(LA7X,$EXTRACT(LA7ECH))
FOR I=2:1:4
SET LA7SID(I)=$PIECE(LA7X,$EXTRACT(LA7ECH),I)
+37 SET LA7X=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
+38 SET LA7FID=$PIECE(LA7X,$EXTRACT(LA7ECH))
FOR I=2:1:4
SET LA7FID(I)=$PIECE(LA7X,$EXTRACT(LA7ECH),I)
+39 ;
+40 ; Test order code - find order NLT code
+41 ; If POC interface then see if NLT is used for ordering code
+42 SET LA7X=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
SET LA7ONLT=""
+43 FOR I=1,4
Begin DoDot:1
+44 IF $PIECE(LA7X,LA7CS,I)'?5N1"."4N
QUIT
+45 IF $PIECE(LA7X,LA7CS,I+2)="99VA64"
SET LA7ONLT=$PIECE(LA7X,LA7CS,I)
SET LA7ONLT(0)=$PIECE(LA7X,LA7CS,I+1)
QUIT
+46 IF LA7INTYP>19
IF LA7INTYP<30
IF $PIECE(LA7X,LA7CS,I+2)=""
SET LA7ONLT=$PIECE(LA7X,LA7CS,I)
SET LA7ONLT(0)=$PIECE(LA7X,LA7CS,I+1)
QUIT
End DoDot:1
if LA7ONLT'=""
QUIT
+47 ;
+48 ; Specimen collection date/time
+49 SET LA7CDT=$$HL7TFM^XLFDT($PIECE($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L")
+50 ;
+51 ; Extract filler fields #1&2 and placer fields #1&2
+52 FOR LA7I=18:1:21
Begin DoDot:1
+53 SET LA7X=$$P^LA7VHLU(.LA7SEG,LA7I+1,LA7FS)
+54 SET LA7OBR(LA7I)=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
End DoDot:1
+55 ;
+56 ; Pull info from placer field #2 (OBR-19)
+57 SET LA7X=LA7OBR(19)
+58 ;Tray
SET LA7TRAY=+$PIECE(LA7X,"^",1)
+59 ; Cup
SET LA7CUP=+$PIECE(LA7X,"^",2)
+60 ; If POC interface set cup to file #62.49 ien
+61 IF LA7INTYP>19
IF LA7INTYP<30
SET LA7CUP=LA76249
+62 ; Accession Area
SET LA7AA=$PIECE(LA7X,"^",3)
+63 ; Accession Date
SET LA7AD=$PIECE(LA7X,"^",4)
+64 ; Accession Entry
SET LA7AN=$PIECE(LA7X,"^",5)
+65 ; Accession
SET LA7ACC=$PIECE(LA7X,"^",6)
+66 IF LA7ACC'=""
DO SETID^LA7VHLU1(LA76249,LA7ID,LA7ACC,0)
+67 ; Unique ID
SET LA7UID=$PIECE(LA7X,"^",7)
+68 IF $LENGTH(LA7UID)<10
SET LA7UID=""
+69 ;
+70 ; Sequence Number
+71 ; If point of care interface (20-29) then use file #62.49 ien as IDE
+72 SET LA7IDE=$PIECE(LA7X,LA7CS,8)
+73 IF LA7INTYP>19
IF LA7INTYP<30
SET LA7IDE=LA76249
+74 ;
+75 ; UID might come as Sample ID
+76 IF LA7UID=""
IF $LENGTH(LA7SID)>9
SET LA7UID=LA7SID
+77 ;
+78 ; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID)
+79 ; accession may have rolled over, use UID to get current accession info.
+80 IF LA7UID'=""
Begin DoDot:1
+81 NEW X
+82 ; UID not on file
SET X=$QUERY(^LRO(68,"C",LA7UID))
if X=""
QUIT
+83 ; UID not on file.
IF $QSUBSCRIPT(X,3)'=LA7UID
SET LA7UID=""
QUIT
+84 SET LA7AA=+$QSUBSCRIPT(X,4)
SET LA7AD=+$QSUBSCRIPT(X,5)
SET LA7AN=+$QSUBSCRIPT(X,6)
+85 DO SETID^LA7VHLU1(LA76249,LA7ID,LA7UID,1)
+86 DO SETID^LA7VHLU1(LA76249,"",LA7UID,0)
End DoDot:1
+87 ;
+88 ; If still not known, compute from default accession date and area.
+89 ; Calculate accession date based on accession transform.
+90 IF LA7AA<1!(LA7AD<1)!(LA7AN<1)
Begin DoDot:1
+91 NEW X
+92 SET LA7AA=+$PIECE(LA7624(0),"^",11)
+93 SET X=$PIECE($GET(^LRO(68,LA7AA,0)),U,3)
+94 SET LA7AD=$SELECT(X="D":DT,X="M":$EXTRACT(DT,1,5)_"00",X="Y":$EXTRACT(DT,1,3)_"0000",X="Q":$EXTRACT(DT,1,3)_"0000"+(($EXTRACT(DT,4,5)-1)\3*300+100),1:DT)
+95 SET LA7AN=+LA7SID
+96 IF LA7AN>0
DO SETID^LA7VHLU1(LA76249,LA7ID,LA7AN,1)
+97 IF LA7SID'=""
DO SETID^LA7VHLU1(LA76249,LA7ID,LA7SID,0)
End DoDot:1
+98 ;
+99 ; Zeroth node of accession area.
+100 SET LA7AA(0)=$GET(^LRO(68,+LA7AA,0))
+101 ; Accession's subscript
+102 SET LA7SS=$PIECE(LA7AA(0),"^",2)
+103 ;
+104 ; Specimen action code
+105 SET LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
+106 ;
+107 ; Specimen(topography), collection sample, HL7 specimen source
+108 SET (LA761,LA762,LA70070,LA7SPEC)=""
+109 SET LA7X=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
+110 DO FLD2ARR^LA7VHLU7(.LA7X,LA7FS_LA7ECH)
+111 MERGE LA7SPTY=LA7X(1)
+112 ;
+113 ; Look for HL7 Table 0070 code.
+114 ; If coding system blank then default to table 0070 as coding system per HL7 standard for OBR-15.
+115 ; If no code and not a standard code set then ignore (remove).
+116 FOR I=1,4
Begin DoDot:1
+117 IF $GET(LA7SPTY(I))=""
IF $GET(LA7SPTY(I+2))'?1(1"99".E,1"L")
KILL LA7SPTY(I),LA7SPTY(I+1),LA7SPTY(I+2),LA7SPTY($SELECT(I=1:7,1:8))
QUIT
+118 IF $GET(LA7SPTY(I+2))=""
SET LA7SPTY(I+2)="HL70070"
+119 IF LA7SPTY(I+2)="HL70070"
SET LA7SPEC=LA7SPTY(I)
End DoDot:1
+120 IF LA7SPEC=""
SET LA7SPEC=$GET(LA7SPTY)
+121 ;
+122 ; Retrieve related specimen/collection sample from accession
+123 ; Create specimen array to handle multiple AP specimens on orders.
+124 SET I=0
+125 FOR
SET I=$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,I))
if 'I
QUIT
Begin DoDot:1
+126 SET X=^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,I,0)
+127 IF $PIECE(X,"^")
Begin DoDot:2
+128 ;spec array
SET LA761($PIECE(X,"^"))=""
+129 IF LA761=""
SET LA761=$PIECE(X,"^")
End DoDot:2
+130 IF $PIECE(X,"^",2)
Begin DoDot:2
+131 ;sample array
SET LA762($PIECE(X,"^",2))=""
+132 IF LA762=""
SET LA762=$PIECE(X,"^",2)
End DoDot:2
End DoDot:1
+133 ;
+134 ; Log error when specimen source does not match accession's specimen
+135 ; Ignore if specimen related to lab control file #62.3
+136 SET LA7OK=1
+137 IF $PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)'=62.3
Begin DoDot:1
+138 NEW DIERR,LA7MSG
+139 FOR LA7I=1,4
IF $GET(LA7SPTY(LA7I))'=""
Begin DoDot:2
+140 IF $GET(LA7SPTY(LA7I+2))="HL70070"
Begin DoDot:3
+141 KILL DIERR,LA7MSG
+142 SET LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR",,,"LA7MSG")
+143 IF LA70070'=""
IF LA70070'=LA7SPTY(LA7I)
SET LA7OK=0
SET LA7OK(0)="HL7 "_LA7SPTY(LA7I)
End DoDot:3
QUIT
+144 IF $GET(LA7SPTY(LA7I+2))="SCT"
DO OBRSCT
QUIT
End DoDot:2
if 'LA7OK
QUIT
End DoDot:1
+145 ;
+146 IF 'LA7OK
Begin DoDot:1
+147 NEW LA7MSG
+148 SET LA7ERR=49
SET LA7QUIT=2
SET LA7MSG=LA7OK(0)
+149 SET LA7AERR=$$CREATE^LA7LOG(LA7ERR,1)
End DoDot:1
+150 ;
+151 ; Don't continue if flag set to skip this segment
+152 IF LA7QUIT
QUIT
+153 ;
+154 ; Placer's ordering provider (id^duz^last name, first name, mi [id])
+155 IF $GET(LA7POP)=""
Begin DoDot:1
+156 SET LA7POP=""
SET LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
+157 IF LA7X=""
QUIT
+158 SET LA7POP=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
+159 IF LA7POP="^^"
SET LA7POP=""
End DoDot:1
+160 ;
+161 ; Results rpt/status chng - date/time
+162 SET LA7X=$$P^LA7VHLU(.LA7SEG,23,LA7FS)
SET LA7RSDT=""
+163 IF LA7X'=""
SET LA7RSDT=$$HL7TFM^XLFDT(LA7X,"L")
+164 ;
+165 ; Result status
+166 SET LA7OBR25=$$P^LA7VHLU(.LA7SEG,26,LA7FS)
+167 ;
+168 ; Parent result - CM data type.
+169 ; Save OBX-4 (sub-id) of parent result in LAPSUBID for subsequent usage by OBX/NTE's.
+170 SET LA7OBR26=$$FIELD^LA7VHLU7(26)
+171 DO FLD2ARR^LA7VHLU7(.LA7OBR26)
+172 SET LAPSUBID=$GET(LA7OBR26(2))
+173 ;
+174 ; Parent
+175 SET LA7OBR29=$$FIELD^LA7VHLU7(29)
+176 DO FLD2ARR^LA7VHLU7(.LA7OBR29)
+177 ;
+178 ; Principle Result interpreter
+179 SET LA7OBR32=$$FIELD^LA7VHLU7(32)
SET LA7PRI=""
+180 DO FLD2ARR^LA7VHLU7(.LA7OBR32)
+181 IF $GET(LA7OBR32(1))'=""
Begin DoDot:1
+182 SET LA7X=$TRANSLATE(LA7OBR32(1),$EXTRACT(LA7ECH,4),$EXTRACT(LA7ECH))
+183 SET LA7PRI=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
+184 IF LA7PRI="^^"
SET LA7PRI=""
End DoDot:1
+185 ;
+186 ; Assistant Result Interpreter
+187 SET LA7OBR33=$$FIELD^LA7VHLU7(33)
SET LA7ARI=""
+188 DO FLD2ARR^LA7VHLU7(.LA7OBR33)
+189 IF $GET(LA7OBR33(1))'=""
Begin DoDot:1
+190 SET LA7X=$TRANSLATE(LA7OBR33(1),$EXTRACT(LA7ECH,4),$EXTRACT(LA7ECH))
+191 SET LA7ARI=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
+192 IF LA7ARI="^^"
SET LA7ARI=""
End DoDot:1
+193 ;
+194 ; Technician
+195 SET LA7OBR34=$$FIELD^LA7VHLU7(34)
SET LA7TECH=""
+196 DO FLD2ARR^LA7VHLU7(.LA7OBR34)
+197 IF $GET(LA7OBR34(1))'=""
Begin DoDot:1
+198 SET LA7X=$TRANSLATE(LA7OBR34(1),$EXTRACT(LA7ECH,4),$EXTRACT(LA7ECH))
+199 SET LA7TECH=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
+200 IF LA7TECH="^^"
SET LA7TECH=""
End DoDot:1
+201 ;
+202 ; Results handling
+203 ; Usually IS data type however later HL7 versions use CWE data type. Attempt to handle either format.
+204 SET LA7X=$$P^LA7VHLU(.LA7SEG,50,LA7FS)
+205 SET LA7OBR49=$PIECE(LA7X,LA7CS,1)
+206 ;
+207 ; Set Auto Release flag at OBR level for comments (NTE segments) before processing OBX segment, use "-.0000" in lieu of OBX.17 suffix value
+208 IF LA7MTYP="ORU"
SET LA7AUTORELEASE=$$ARSTATUS^LA7VIN5(LA7OBR49,"-.0000",LA7624)
+209 ;
+210 ; Create entry in LAH for supported subscripts.
+211 IF LA7MTYP="ORR"
IF $GET(LA7OTYPE)'="OK"
IF LA7SS?1(1"CH",1"MI",1"SP",1"CY",1"EM")
Begin DoDot:1
+212 DO LAGEN^LA7VIN4A
+213 IF $GET(LA7ISQN)=""
DO CREATE^LA7LOG(14)
QUIT
+214 SET LA7I=$ORDER(^TMP("LA7 ORDER STATUS",$JOB,""),-1)
SET LA7I=LA7I+1
+215 IF LA7ONLT=""
SET X=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
SET LA7X=$PIECE(X,LA7CS)
SET LA7X(0)=$PIECE(X,LA7CS,2)
+216 IF '$TEST
SET LA7X=LA7ONLT
SET LA7X(0)=LA7ONLT(0)
+217 SET X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$PIECE($GET(LA7SM),"^",2)
+218 SET ^TMP("LA7 ORDER STATUS",$JOB,LA7I)=X
+219 IF $GET(LA7OCR)'=""
SET ^TMP("LA7 ORDER STATUS",$JOB,LA7I,"OCR")=$TRANSLATE(LA7OCR,LA7CS,"^")
+220 IF $GET(LA7MSATM)'=""
SET ^TMP("LA7 ORDER STATUS",$JOB,LA7I,"MSA")=LA7MSATM
End DoDot:1
+221 ;
+222 IF LA7MTYP="ORU"
IF LA7SS?1(1"CH",1"MI",1"SP",1"CY",1"EM")
Begin DoDot:1
+223 DO LAGEN^LA7VIN4A
+224 IF $GET(LA7ISQN)<1
SET LA7ERR=14
SET LA7AERR=$$CREATE^LA7LOG(LA7ERR,1)
QUIT
+225 IF LA7INTYP=10
IF LA7SAC?1(1"A",1"G")
Begin DoDot:2
+226 SET LA7I=$ORDER(^TMP("LA7 ORDER STATUS",$JOB,""),-1)
SET LA7I=LA7I+1
SET LA7SAC(0)=LA7I
+227 IF LA7ONLT=""
SET X=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
SET LA7X=$PIECE(X,LA7CS)
SET LA7X(0)=$PIECE(X,LA7CS,2)
+228 IF '$TEST
SET LA7X=LA7ONLT
SET LA7X(0)=LA7ONLT(0)
+229 SET X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$GET(LA7OTYPE)_"^"_LA7SAC_"^"_$PIECE($GET(LA7SM),"^",2)
+230 SET ^TMP("LA7 ORDER STATUS",$JOB,LA7I)=X
End DoDot:2
+231 IF LA7INTYP=10
IF LA7OBR25?1(1"A",1"X")
Begin DoDot:2
+232 SET LA7I=$ORDER(^TMP("LA7 ORDER STATUS",$JOB,""),-1)
SET LA7I=LA7I+1
+233 IF LA7ONLT=""
SET X=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
SET LA7X=$PIECE(X,LA7CS)
SET LA7X(0)=$PIECE(X,LA7CS,2)
+234 IF '$TEST
SET LA7X=LA7ONLT
SET LA7X(0)=LA7ONLT(0)
+235 SET X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$GET(LA7OTYPE)_"^"_LA7SAC_"^"_$PIECE($GET(LA7SM),"^",2)_"^"_LA7OBR25
+236 SET ^TMP("LA7 ORDER STATUS",$JOB,LA7I)=X
End DoDot:2
+237 IF LA7INTYP=10
IF LA7SS?1(1"MI",1"SP",1"CY",1"EM")
SET ^TMP("LA7-PL-NTE",$JOB,LA7LWL,LA7ISQN,LA7SS)=LA7SFAC
End DoDot:1
+238 ;
+239 ;LA*5.2*101: Do not require that LA7SM (shipping manifest identifier) not be null
+240 IF LA7INTYP=10
IF $GET(LA7UID)'=""
DO SMUPDT^LA7VIN4A
+241 QUIT
+242 ;
+243 ;
OBRSCT ; check if SCT doesn't match any specimen in #68
+1 ;
+2 ;ZEXCEPT: LA761,LA76248,LA7I,LA7OK,LA7SPTY
+3 ;
+4 NEW LA761SCT,R61,SCTOK
+5 SET (R61,SCTOK)=0
+6 FOR
SET R61=$ORDER(LA761(R61))
if 'R61
QUIT
Begin DoDot:1
+7 IF $DATA(^LAHM(62.48,LA76248,"SCT","AD1",LA7SPTY(LA7I),R61_";LAB(61,"))
SET SCTOK=1
QUIT
+8 SET LA761SCT=$$IEN2SCT^LA7VHLU6(61,R61,DT,"")
+9 IF LA761SCT'>0
SET SCTOK=1
+10 IF $PIECE(LA761SCT,"^")=LA7SPTY(LA7I)
SET SCTOK=1
End DoDot:1
+11 ;
+12 ; If no topography found on accession with a SCT mapping that matches SCT code then flag as error.
+13 ; Also if SCT code in message has Lexicon exception then record as a separate error.
+14 IF 'SCTOK
Begin DoDot:1
+15 NEW LA7SCT,LA7X,LA7Z
+16 SET LA7OK=0
SET LA7OK(0)="SCTID "_LA7SPTY(LA7I)
+17 SET LA7Z=$$CODE^LEXTRAN(LA7SPTY(LA7I),"SCT",DT,"LA7SCT")
+18 IF $PIECE(LA7Z,"^",5)
Begin DoDot:2
+19 SET LA7X=$PIECE(LA7Z,"^",6)
+20 DO CREATE^LA7LOG(37)
End DoDot:2
End DoDot:1
+21 ;
+22 QUIT
