LA7UIIN1 ;DALOI/JRR - Process Incoming UI Msgs, continued ; 12/3/1997
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,23,27,57,59**;Sep 27, 1994
; This routine is a continuation of LA7UIIN and is only
; called from there. It is called with each message found
; in the incoming queue.
;
Q
;
NXTMSG ;
N LA70070,LA7150,LA761,LA762,LA7624,LA762495
N LA7AA,LA7AD,LA7ACC,LA7CNT,LA7CS,LA7CUP,LA7ECH,LA7ENTRY,LA7FS,LA7IDE,LA7LWL,LA7MSH,LA7OBR,LA7OBR3,LA7QUIT,LA7TRAY,LA7USID
N CUP,IDE,IDENT,ISQN
;
S (LA7CNT,LA7QUIT)=0
S (LA7AN,LA7INST,LA7OBR,LA7UID)=""
S DT=$$DT^XLFDT
; Message built but no text.
I '$O(^LAHM(62.49,LA76249,150,0)) D Q
. D CREATE^LA7LOG(6)
;
MSH S LA7MSH=$G(^($O(^LAHM(62.49,LA76249,150,0)),0))
; Bad first line of message
I $E(LA7MSH,1,3)'="MSH" D Q
. D CREATE^LA7LOG(7)
S LA7FS=$E(LA7MSH,4)
S LA7CS=$E(LA7MSH,5)
S LA7ECH=$E(LA7MSH,5,8)
; No field or component seperator
I LA7FS=""!(LA7CS="") D Q
. D CREATE^LA7LOG(8)
;
; Find the OBR segment
S LA762495=0
OBR F S LA762495=$O(^LAHM(62.49,LA76249,150,LA762495)) Q:'LA762495!($E($G(^(+LA762495,0)),1,3)="OBR")
S DT=$$DT^XLFDT
;
; No more OBR's, found at least 1.
I 'LA762495,$L($G(LA7OBR)) Q
;
S LA7OBR=$G(^LAHM(62.49,LA76249,150,+LA762495,0))
;
; Should only be working on OBR
I $E(LA7OBR,1,3)'="OBR" D Q
. D CREATE^LA7LOG(9)
;
; Extracting 1st piece
S LA7INST=$P($P(LA7OBR,LA7FS,19),LA7CS,1)
I LA7INST="" D Q
. D CREATE^LA7LOG(10)
S LA7624=+$O(^LAB(62.4,"B",LA7INST,0))
; Instrument name not found in xref
I 'LA7624 D Q
. D CREATE^LA7LOG(11)
S LA7INST=$G(^LAB(62.4,LA7624,0))
; Instrument entry not found in file
I LA7INST="" D Q
. D CREATE^LA7LOG(11)
;
S LA7ENTRY=$P(LA7INST,"^",6) ;LOG,LLIST,IDENT or SEQN
S:LA7ENTRY="" LA7ENTRY="LOG"
;
; Universal service id
S LA7USID=$P(LA7OBR,LA7FS,4)
;
S LA7TRAY=+$P($P(LA7OBR,LA7FS,20),LA7CS,1) ;Tray
S LA7CUP=+$P($P(LA7OBR,LA7FS,20),LA7CS,2) ; Cup
S LA7AA=+$P($P(LA7OBR,LA7FS,20),LA7CS,3) ; Accession Area
S LA7AD=+$P($P(LA7OBR,LA7FS,20),LA7CS,4) ; Accession Date
S LA7AN=+$P($P(LA7OBR,LA7FS,20),LA7CS,5) ; Accession Entry
S LA7ACC=$P($P(LA7OBR,LA7FS,20),LA7CS,6) ; Accession
S LA7UID=$P($P(LA7OBR,LA7FS,20),LA7CS,7) ; Unique ID
S LA7IDE=$P($P(LA7OBR,LA7FS,20),LA7CS,8) ; Sequence Number
S LA7LWL=$P(LA7INST,"^",4) ; Load/Work List
S LA7OBR3=$P(LA7OBR,LA7FS,3) ; Sample ID or Bar code
S LA7OBR(15)=$P(LA7OBR,LA7FS,16) ; Specimen source
;
; UID might come as Sample ID
I LA7UID="",LA7OBR3?10UN S LA7UID=LA7OBR3
;
; Try to figure out LRAA LRAD LRAN by using the unique ID (LRUID)
; accession may have rolled over, use UID to get current accession info.
I LA7UID]"" D
. N X
. S X=$Q(^LRO(68,"C",LA7UID))
. 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)
; If still not known, compute from default date and accession area
; Calculate accession date based on accession transform.
I '(LA7AA*LA7AD*LA7AN) D
. N X
. S DT=$$DT^XLFDT
. S LA7AA=+$P(LA7INST,"^",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=+LA7OBR3
; Log but cont
I LA7ENTRY="LOG",'$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D
. D CREATE^LA7LOG(13)
; cup=sequence number
I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE
;
; Create entry in ^LAH global
D LAGEN
; Couldn't create entry in ^LAH
I $G(LA7ISQN)="" D Q
. D CREATE^LA7LOG(14)
;
; specimen(topography), collection sample, HL7 specimen source
S (LA761,LA762,LA70070)=""
I $O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) D
. N X
. S X=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
. ; specimen^collection sample
. S X(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
. S LA761=$P(X(0),"^") ; specimen
. S LA762=$P(X(0),"^",2) ; collection sample
. ; HL7 code from Topography
. I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
;
; Log error when specimen source does not match accession's specimen
I $L(LA70070),$L($P($P(LA7OBR(15),LA7CS),$E(LA7ECH,4))) D
. ; Check if using HL7 table 0070
. I $P($P(LA7OBR(15),LA7CS),$E(LA7ECH,4),3)'["0070" Q
. ; Message matches accession
. I LA70070=$P($P(LA7OBR(15),LA7CS),$E(LA7ECH,4)) Q
. D CREATE^LA7LOG(22)
. S LA7QUIT=1
;
; Something wrong, process next OBR
I LA7QUIT S LA7QUIT=0 G OBR
;
; Zeroth node of acession area.
S LA7AA(0)=$G(^LRO(68,+LA7AA,0))
;
; No subscript defined for this area.
I $P(LA7AA(0),"^",2)="" G OBR
;
; Processing of this subscript not supported.
I "CHMI"'[$P(LA7AA(0),"^",2) G OBR
;
S LA7150=LA762495
; Process "CH" subscript results - NTE and OBX segments.
I $P(LA7AA(0),"^",2)="CH" D NTE^LA7UIIN2
;
; Process "MI" subscript results.
I $P(LA7AA(0),"^",2)="MI" D
. N X
. S X="LA7UIIN3" X ^%ZOSF("TEST") Q:'$T
. D MI^LA7UIIN3
;
; No more segments to process, reached end of global array.
I 'LA762495 Q
;
; Reset subscript variable.
I LA762495>LA7150 S LA762495=LA762495-1
;
; Go back to find/process additional OBR segments.
G OBR
;
;
LAGEN ; subroutine to set up variables for call to ^LAGEN, build entry in LAH
; requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL
; returns LA7ISQN=subscript to store results in ^LAH global
;
K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
K LADT,LAGEN,LA7ISQN
;
S LA7ISQN=""
S TRAY=+$G(LA7TRAY) S:'TRAY TRAY=1
S CUP=+$G(LA7CUP) S:'CUP CUP=1
S LWL=LA7LWL
I '$D(^LRO(68.2,+LWL,0)) D Q
. D CREATE^LA7LOG(19)
;
; Set accession area to area of specimen, allow multiple areas on same instrument.
S WL=LA7AA
I '$D(^LRO(68,+WL,0)) D Q
. D CREATE^LA7LOG(20)
;
S LROVER=$P(LA7INST,"^",12)
S METH=$P(LA7INST,"^",10)
S LOG=LA7AN
; Identity field
S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6)
S IDE=+LA7IDE
S LADT=LA7AD
;
; This disregards the CROSS LINK field in 62.4
D @(LA7ENTRY_"^LAGEN")
S LA7ISQN=$G(ISQN)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7UIIN1 6086 printed Apr 09, 2024@20:45:46 Page 2
LA7UIIN1 ;DALOI/JRR - Process Incoming UI Msgs, continued ; 12/3/1997
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,23,27,57,59**;Sep 27, 1994
+2 ; This routine is a continuation of LA7UIIN and is only
+3 ; called from there. It is called with each message found
+4 ; in the incoming queue.
+5 ;
+6 QUIT
+7 ;
NXTMSG ;
+1 NEW LA70070,LA7150,LA761,LA762,LA7624,LA762495
+2 NEW LA7AA,LA7AD,LA7ACC,LA7CNT,LA7CS,LA7CUP,LA7ECH,LA7ENTRY,LA7FS,LA7IDE,LA7LWL,LA7MSH,LA7OBR,LA7OBR3,LA7QUIT,LA7TRAY,LA7USID
+3 NEW CUP,IDE,IDENT,ISQN
+4 ;
+5 SET (LA7CNT,LA7QUIT)=0
+6 SET (LA7AN,LA7INST,LA7OBR,LA7UID)=""
+7 SET DT=$$DT^XLFDT
+8 ; Message built but no text.
+9 IF '$ORDER(^LAHM(62.49,LA76249,150,0))
Begin DoDot:1
+10 DO CREATE^LA7LOG(6)
End DoDot:1
QUIT
+11 ;
MSH SET LA7MSH=$GET(^($ORDER(^LAHM(62.49,LA76249,150,0)),0))
+1 ; Bad first line of message
+2 IF $EXTRACT(LA7MSH,1,3)'="MSH"
Begin DoDot:1
+3 DO CREATE^LA7LOG(7)
End DoDot:1
QUIT
+4 SET LA7FS=$EXTRACT(LA7MSH,4)
+5 SET LA7CS=$EXTRACT(LA7MSH,5)
+6 SET LA7ECH=$EXTRACT(LA7MSH,5,8)
+7 ; No field or component seperator
+8 IF LA7FS=""!(LA7CS="")
Begin DoDot:1
+9 DO CREATE^LA7LOG(8)
End DoDot:1
QUIT
+10 ;
+11 ; Find the OBR segment
+12 SET LA762495=0
OBR FOR
SET LA762495=$ORDER(^LAHM(62.49,LA76249,150,LA762495))
if 'LA762495!($EXTRACT($GET(^(+LA762495,0)),1,3)="OBR")
QUIT
+1 SET DT=$$DT^XLFDT
+2 ;
+3 ; No more OBR's, found at least 1.
+4 IF 'LA762495
IF $LENGTH($GET(LA7OBR))
QUIT
+5 ;
+6 SET LA7OBR=$GET(^LAHM(62.49,LA76249,150,+LA762495,0))
+7 ;
+8 ; Should only be working on OBR
+9 IF $EXTRACT(LA7OBR,1,3)'="OBR"
Begin DoDot:1
+10 DO CREATE^LA7LOG(9)
End DoDot:1
QUIT
+11 ;
+12 ; Extracting 1st piece
+13 SET LA7INST=$PIECE($PIECE(LA7OBR,LA7FS,19),LA7CS,1)
+14 IF LA7INST=""
Begin DoDot:1
+15 DO CREATE^LA7LOG(10)
End DoDot:1
QUIT
+16 SET LA7624=+$ORDER(^LAB(62.4,"B",LA7INST,0))
+17 ; Instrument name not found in xref
+18 IF 'LA7624
Begin DoDot:1
+19 DO CREATE^LA7LOG(11)
End DoDot:1
QUIT
+20 SET LA7INST=$GET(^LAB(62.4,LA7624,0))
+21 ; Instrument entry not found in file
+22 IF LA7INST=""
Begin DoDot:1
+23 DO CREATE^LA7LOG(11)
End DoDot:1
QUIT
+24 ;
+25 ;LOG,LLIST,IDENT or SEQN
SET LA7ENTRY=$PIECE(LA7INST,"^",6)
+26 if LA7ENTRY=""
SET LA7ENTRY="LOG"
+27 ;
+28 ; Universal service id
+29 SET LA7USID=$PIECE(LA7OBR,LA7FS,4)
+30 ;
+31 ;Tray
SET LA7TRAY=+$PIECE($PIECE(LA7OBR,LA7FS,20),LA7CS,1)
+32 ; Cup
SET LA7CUP=+$PIECE($PIECE(LA7OBR,LA7FS,20),LA7CS,2)
+33 ; Accession Area
SET LA7AA=+$PIECE($PIECE(LA7OBR,LA7FS,20),LA7CS,3)
+34 ; Accession Date
SET LA7AD=+$PIECE($PIECE(LA7OBR,LA7FS,20),LA7CS,4)
+35 ; Accession Entry
SET LA7AN=+$PIECE($PIECE(LA7OBR,LA7FS,20),LA7CS,5)
+36 ; Accession
SET LA7ACC=$PIECE($PIECE(LA7OBR,LA7FS,20),LA7CS,6)
+37 ; Unique ID
SET LA7UID=$PIECE($PIECE(LA7OBR,LA7FS,20),LA7CS,7)
+38 ; Sequence Number
SET LA7IDE=$PIECE($PIECE(LA7OBR,LA7FS,20),LA7CS,8)
+39 ; Load/Work List
SET LA7LWL=$PIECE(LA7INST,"^",4)
+40 ; Sample ID or Bar code
SET LA7OBR3=$PIECE(LA7OBR,LA7FS,3)
+41 ; Specimen source
SET LA7OBR(15)=$PIECE(LA7OBR,LA7FS,16)
+42 ;
+43 ; UID might come as Sample ID
+44 IF LA7UID=""
IF LA7OBR3?10UN
SET LA7UID=LA7OBR3
+45 ;
+46 ; Try to figure out LRAA LRAD LRAN by using the unique ID (LRUID)
+47 ; accession may have rolled over, use UID to get current accession info.
+48 IF LA7UID]""
Begin DoDot:1
+49 NEW X
+50 SET X=$QUERY(^LRO(68,"C",LA7UID))
+51 ; UID not on file.
IF $QSUBSCRIPT(X,3)'=LA7UID
SET LA7UID=""
QUIT
+52 SET LA7AA=+$QSUBSCRIPT(X,4)
SET LA7AD=+$QSUBSCRIPT(X,5)
SET LA7AN=+$QSUBSCRIPT(X,6)
End DoDot:1
+53 ; If still not known, compute from default date and accession area
+54 ; Calculate accession date based on accession transform.
+55 IF '(LA7AA*LA7AD*LA7AN)
Begin DoDot:1
+56 NEW X
+57 SET DT=$$DT^XLFDT
+58 SET LA7AA=+$PIECE(LA7INST,"^",11)
+59 SET X=$PIECE($GET(^LRO(68,LA7AA,0)),U,3)
+60 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)
+61 SET LA7AN=+LA7OBR3
End DoDot:1
+62 ; Log but cont
+63 IF LA7ENTRY="LOG"
IF '$DATA(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0))
Begin DoDot:1
+64 DO CREATE^LA7LOG(13)
End DoDot:1
+65 ; cup=sequence number
+66 IF LA7ENTRY="LLIST"
if 'LA7CUP
SET LA7CUP=LA7IDE
+67 ;
+68 ; Create entry in ^LAH global
+69 DO LAGEN
+70 ; Couldn't create entry in ^LAH
+71 IF $GET(LA7ISQN)=""
Begin DoDot:1
+72 DO CREATE^LA7LOG(14)
End DoDot:1
QUIT
+73 ;
+74 ; specimen(topography), collection sample, HL7 specimen source
+75 SET (LA761,LA762,LA70070)=""
+76 IF $ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
Begin DoDot:1
+77 NEW X
+78 SET X=$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
+79 ; specimen^collection sample
+80 SET X(0)=$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
+81 ; specimen
SET LA761=$PIECE(X(0),"^")
+82 ; collection sample
SET LA762=$PIECE(X(0),"^",2)
+83 ; HL7 code from Topography
+84 IF LA761
SET LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
End DoDot:1
+85 ;
+86 ; Log error when specimen source does not match accession's specimen
+87 IF $LENGTH(LA70070)
IF $LENGTH($PIECE($PIECE(LA7OBR(15),LA7CS),$EXTRACT(LA7ECH,4)))
Begin DoDot:1
+88 ; Check if using HL7 table 0070
+89 IF $PIECE($PIECE(LA7OBR(15),LA7CS),$EXTRACT(LA7ECH,4),3)'["0070"
QUIT
+90 ; Message matches accession
+91 IF LA70070=$PIECE($PIECE(LA7OBR(15),LA7CS),$EXTRACT(LA7ECH,4))
QUIT
+92 DO CREATE^LA7LOG(22)
+93 SET LA7QUIT=1
End DoDot:1
+94 ;
+95 ; Something wrong, process next OBR
+96 IF LA7QUIT
SET LA7QUIT=0
GOTO OBR
+97 ;
+98 ; Zeroth node of acession area.
+99 SET LA7AA(0)=$GET(^LRO(68,+LA7AA,0))
+100 ;
+101 ; No subscript defined for this area.
+102 IF $PIECE(LA7AA(0),"^",2)=""
GOTO OBR
+103 ;
+104 ; Processing of this subscript not supported.
+105 IF "CHMI"'[$PIECE(LA7AA(0),"^",2)
GOTO OBR
+106 ;
+107 SET LA7150=LA762495
+108 ; Process "CH" subscript results - NTE and OBX segments.
+109 IF $PIECE(LA7AA(0),"^",2)="CH"
DO NTE^LA7UIIN2
+110 ;
+111 ; Process "MI" subscript results.
+112 IF $PIECE(LA7AA(0),"^",2)="MI"
Begin DoDot:1
+113 NEW X
+114 SET X="LA7UIIN3"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+115 DO MI^LA7UIIN3
End DoDot:1
+116 ;
+117 ; No more segments to process, reached end of global array.
+118 IF 'LA762495
QUIT
+119 ;
+120 ; Reset subscript variable.
+121 IF LA762495>LA7150
SET LA762495=LA762495-1
+122 ;
+123 ; Go back to find/process additional OBR segments.
+124 GOTO OBR
+125 ;
+126 ;
LAGEN ; subroutine to set up variables for call to ^LAGEN, build entry in LAH
+1 ; requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL
+2 ; returns LA7ISQN=subscript to store results in ^LAH global
+3 ;
+4 KILL TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
+5 KILL LADT,LAGEN,LA7ISQN
+6 ;
+7 SET LA7ISQN=""
+8 SET TRAY=+$GET(LA7TRAY)
if 'TRAY
SET TRAY=1
+9 SET CUP=+$GET(LA7CUP)
if 'CUP
SET CUP=1
+10 SET LWL=LA7LWL
+11 IF '$DATA(^LRO(68.2,+LWL,0))
Begin DoDot:1
+12 DO CREATE^LA7LOG(19)
End DoDot:1
QUIT
+13 ;
+14 ; Set accession area to area of specimen, allow multiple areas on same instrument.
+15 SET WL=LA7AA
+16 IF '$DATA(^LRO(68,+WL,0))
Begin DoDot:1
+17 DO CREATE^LA7LOG(20)
End DoDot:1
QUIT
+18 ;
+19 SET LROVER=$PIECE(LA7INST,"^",12)
+20 SET METH=$PIECE(LA7INST,"^",10)
+21 SET LOG=LA7AN
+22 ; Identity field
+23 SET IDENT=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6)
+24 SET IDE=+LA7IDE
+25 SET LADT=LA7AD
+26 ;
+27 ; This disregards the CROSS LINK field in 62.4
+28 DO @(LA7ENTRY_"^LAGEN")
+29 SET LA7ISQN=$GET(ISQN)
+30 ;
+31 QUIT
