LA7VRIN4 ;VA/DALOI/JMC - Process Incoming UI Msgs, continued ; 01/14/99
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;NOV 01, 1997
;This routine is a continuation of LA7VIN1 and is only called from there.
Q
;
OBR ; Process OBR segments
N I,LA7CUP,LA7ENTRY,LA7IDE,LA7INST,LA7PDUZ,LA7TRAY,LA7X,LA7Y
;
; 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 cmi/maw 3/2/10 split this line
;cmi/maw 3/2/10 modified for reference lab inbound next 3 lines
S LA7624=0
;S LA7INST=$P(LA7X,"^") ; extracting 1st piece
S LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
;cmi/maw 3/2/10 end of mods
; 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
. D CREATE^LA7LOG(LA7ERR)
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")
;
; Pull info from placer field #2 (OBR-19)
S LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS)
S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
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 ;cmi/maw 3/2/10 not used for ihs ref lab
S LA7AA=+$O(^LRO(68,"B","SO",0)) ; Accession Area ;cmi/maw 3/2/10 ihs reference lab
S LA7AD=$P(LA7X,"^",4) ; Accession Date
S LA7AN=$P(LA7X,"^",5) ; Accession Entry
S LA7ACC=$P(LA7X,"^",6) ; Accession
;cmi/maw 3/2/10 not used ihs ref lab next 2 lines
;S LA7UID=$P(LA7X,"^",7) ; Unique ID
;I LA7UID'?1(10UN,15UN) S LA7UID=""
;cmi/maw 3/2/10 ihs ref lab
S LA7UID=LA7SID ;cmi/maw 3/2/10 OBR-3 contains the UID
;
; 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="",LA7SID?1(10UN,15UN) 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))
. 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)
;
; 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)
. E D SETID^LA7VHLU1(LA76249,LA7ID,$S(LA7PNM]"":LA7PNM,LA7SSN]"":LA7SSN,1:"NO ID"))
;
; Zeroth node of acession 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 LA7SPTY=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
;
; Check if using HL7 table 0070
S LA7X=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4),3)
I LA7X=""!(LA7X="HL70070") S LA7SPEC=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4))
;
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
. I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
;
; Log error when specimen source does not match accession's specimen
I LA70070'="",LA7SPEC'="",LA70070'=LA7SPEC D
. N LA7OBR
. S LA7OBR(15)=LA7SPEC ; backward compatible with old code
. S LA7ERR=22,LA7QUIT=2
. D CREATE^LA7LOG(LA7ERR)
;
; 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^LA7VHLU4(LA7X,LA7ECH)
. I LA7POP="^^" S LA7POP=""
;
; Create entry in LAH for supported subscripts.
I LA7MTYP="ORR",$G(LA7OTYPE)'="OK","CHMI"[LA7SS D
. D LAGEN
. 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","CHMI"[LA7SS D
. D LAGEN
. I $G(LA7ISQN)<1 D CREATE^LA7LOG(14) 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_"^"_LA7OTYPE_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2)
. . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
;
I LA7INTYP=10,$G(LA7SM)'="",$G(LA7UID)'="" D SMUPDT
Q
;
;
LAGEN ; Sets 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
;
I LA7ENTRY="LOG" D
. I LA7INTYP>19,LA7INTYP<30 Q
. I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D CREATE^LA7LOG(13)
I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE ;cup=sequence number
;
K LA7ISQN,LADT,LAGEN
K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
;
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(LA7624(0),"^",12)
S METH=$P(LA7624(0),"^",10)
S LOG=LA7AN
S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6) ;identity field
S IDE=+LA7IDE
S LADT=LA7AD
;
; If POC interface call special entry point
D
. N LRDFN ; Protect LRDFN - call into LAGEN can set to 0
. I LA7INTYP>19,LA7INTYP<30 S IDE=LA76249 D POC^LAGEN Q
. D @(LA7ENTRY_"^LAGEN") ;this disregards the CROSS LINK field in 62.4
S LA7ISQN=$G(ISQN)
;
I LA7ISQN<1 Q
;
; Build/store patient demographics array
N I,J,LA7OBRA,LA7PIDA,X,Y
S J="DFN^DOB^ICN^LOC^LRDFN^LRTDFN^PNM^SEX^SSN"
S J(0)="DFN^LA7DOB^LA7ICN^LA7LOC^LRDFN^LRTDFN^LA7PNM^LA7SEX^LA7SSN"
F I=1:1 S X=$P(J,"^",I) Q:X="" D
. S Y=$P(J(0),"^",I)
. I $G(@Y)'="" S LA7PIDA(X)=@Y
I $D(LA7PIDA) D POI^LAGEN(LA7LWL,LA7ISQN,"PID",.LA7PIDA)
;
; Build/store order info array
N LA7ONLTS
I LA7POP'="" S LA7POP=$P(LA7POP," [")
S X=$G(^LAH(LA7LWL,1,LA7ISQN,.1,"OBR","ORDNLT"))
I X'="",LA7ONLT'="",X'[LA7ONLT S LA7ONLTS=X_"^"_LA7ONLT
E S LA7ONLTS=LA7ONLT
S J="EOL^FID^ORCDT^ORDNLT^ORDP^ORDSPEC^PON^SID^PEB^PVB"
S J(0)="LA7EOL^LA7FID^LA7CDT^LA7ONLTS^LA7POP^LA7SPEC^LA7PON^LA7SID^LA7PEB^LA7PVB"
F I=1:1 S X=$P(J,"^",I) Q:X="" D
. S Y=$P(J(0),"^",I)
. I $G(@Y)'="" S LA7OBRA(X)=@Y
I $D(LA7OBRA) D POI^LAGEN(LA7LWL,LA7ISQN,"OBR",.LA7OBRA)
;
; Store interface type with results
D LATYP^LAGEN(LA7LWL,LA7ISQN,LA7INTYP)
;
; Store #62.49 ien with results
D LAMSGID^LAGEN(LA7LWL,LA7ISQN,LA76249)
;
; Store method name with LAH entry
D METH^LAGEN(LA7LWL,LA7ISQN,METH)
;
; Set flag if POC interface to start POC processing routine when
; finished - tasked by LA7VIN before shutdown
I LA7INTYP>19,LA7INTYP<30 S LA7INTYP("LWL",LA7LWL)=""
;
Q
;
;
SMUPDT ; Update shipping manifest in shipping event file #62.85
N LA7DATA,LA7NCS,LA7TST,LA7USID
;
S LA7USID=$$P^LA7VHLU(.LA7SEG,5,LA7FS) ; Universal Service ID (OBR-4)
S LA7TST=$P(LA7USID,LA7CS,1) ; Test code
S LA7NCS=$P(LA7USID,LA7CS,3) ; Name of coding system
S LA7TST(2)=$P(LA7USID,LA7CS,4) ; Alternate test code
S LA7NCS(2)=$P(LA7USID,LA7CS,6) ; Alternate coding system
;
; Determine ordered test, check primary and alternate
S LA7OTST=$$DOT^LA7SMU1(LA7TST,LA7NCS,LA7UID,$P(LA7SM,"^"))
I 'LA7OTST,LA7TST(2)'="" S LA7OTST=$$DOT^LA7SMU1(LA7TST(2),LA7NCS(2),LA7UID,$P(LA7SM,"^"))
;
; Flag the Results Received Event in #62.85
I LA7MTYP="ORU" D
. S LA7DATA="SM70"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
. D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
;
; Flag the Test Received Event in #62.85
I LA7MTYP="ORR" D
. S LA7DATA="SM55"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
. D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
Q
LA7VRIN4 ;VA/DALOI/JMC - Process Incoming UI Msgs, continued ; 01/14/99
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;NOV 01, 1997
+2 ;This routine is a continuation of LA7VIN1 and is only called from there.
+3 QUIT
+4 ;
OBR ; Process OBR segments
+1 NEW I,LA7CUP,LA7ENTRY,LA7IDE,LA7INST,LA7PDUZ,LA7TRAY,LA7X,LA7Y
+2 ;
+3 ; OBR Set ID
+4 SET LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
+5 ;
+6 SET LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
+7 SET LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+8 ;S LA7624=0,LA7INST=$P(LA7X,"^") ; extracting 1st piece cmi/maw 3/2/10 split this line
+9 ;cmi/maw 3/2/10 modified for reference lab inbound next 3 lines
+10 SET LA7624=0
+11 ;S LA7INST=$P(LA7X,"^") ; extracting 1st piece
+12 SET LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
+13 ;cmi/maw 3/2/10 end of mods
+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 DO CREATE^LA7LOG(LA7ERR)
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 ; Pull info from placer field #2 (OBR-19)
+52 SET LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS)
+53 SET LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+54 ;Tray
SET LA7TRAY=+$PIECE(LA7X,"^",1)
+55 ; Cup
SET LA7CUP=+$PIECE(LA7X,"^",2)
+56 ; If POC interface set cup to file #62.49 ien
+57 IF LA7INTYP>19
IF LA7INTYP<30
SET LA7CUP=LA76249
+58 ;S LA7AA=$P(LA7X,"^",3) ; Accession Area ;cmi/maw 3/2/10 not used for ihs ref lab
+59 ; Accession Area ;cmi/maw 3/2/10 ihs reference lab
SET LA7AA=+$ORDER(^LRO(68,"B","SO",0))
+60 ; Accession Date
SET LA7AD=$PIECE(LA7X,"^",4)
+61 ; Accession Entry
SET LA7AN=$PIECE(LA7X,"^",5)
+62 ; Accession
SET LA7ACC=$PIECE(LA7X,"^",6)
+63 ;cmi/maw 3/2/10 not used ihs ref lab next 2 lines
+64 ;S LA7UID=$P(LA7X,"^",7) ; Unique ID
+65 ;I LA7UID'?1(10UN,15UN) S LA7UID=""
+66 ;cmi/maw 3/2/10 ihs ref lab
+67 ;cmi/maw 3/2/10 OBR-3 contains the UID
SET LA7UID=LA7SID
+68 ;
+69 ; Sequence Number
+70 ; If point of care interface (20-29) then use file #62.49 ien as IDE
+71 SET LA7IDE=$PIECE(LA7X,LA7CS,8)
+72 IF LA7INTYP>19
IF LA7INTYP<30
SET LA7IDE=LA76249
+73 ;
+74 ; UID might come as Sample ID
+75 IF LA7UID=""
IF LA7SID?1(10UN,15UN)
SET LA7UID=LA7SID
+76 ;
+77 ; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID)
+78 ; accession may have rolled over, use UID to get current accession info.
+79 IF LA7UID]""
Begin DoDot:1
+80 NEW X
+81 SET X=$QUERY(^LRO(68,"C",LA7UID))
+82 ; UID not on file.
IF $QSUBSCRIPT(X,3)'=LA7UID
SET LA7UID=""
QUIT
+83 SET LA7AA=+$QSUBSCRIPT(X,4)
SET LA7AD=+$QSUBSCRIPT(X,5)
SET LA7AN=+$QSUBSCRIPT(X,6)
+84 DO SETID^LA7VHLU1(LA76249,LA7ID,LA7UID)
End DoDot:1
+85 ;
+86 ; If still not known, compute from default accession date and area.
+87 ; Calculate accession date based on accession transform.
+88 IF LA7AA<1!(LA7AD<1)!(LA7AN<1)
Begin DoDot:1
+89 NEW X
+90 SET LA7AA=+$PIECE(LA7624(0),"^",11)
+91 SET X=$PIECE($GET(^LRO(68,LA7AA,0)),U,3)
+92 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)
+93 SET LA7AN=+LA7SID
+94 IF LA7AN>0
DO SETID^LA7VHLU1(LA76249,LA7ID,LA7AN)
+95 IF '$TEST
DO SETID^LA7VHLU1(LA76249,LA7ID,$SELECT(LA7PNM]"":LA7PNM,LA7SSN]"":LA7SSN,1:"NO ID"))
End DoDot:1
+96 ;
+97 ; Zeroth node of acession area.
+98 SET LA7AA(0)=$GET(^LRO(68,+LA7AA,0))
+99 ; Accession's subscript
+100 SET LA7SS=$PIECE(LA7AA(0),"^",2)
+101 ;
+102 ; Specimen action code
+103 SET LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
+104 ;
+105 ; Specimen(topography), collection sample, HL7 specimen source
+106 SET (LA761,LA762,LA70070,LA7SPEC)=""
+107 SET LA7SPTY=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
+108 ;
+109 ; Check if using HL7 table 0070
+110 SET LA7X=$PIECE($PIECE(LA7SPTY,LA7CS),$EXTRACT(LA7ECH,4),3)
+111 IF LA7X=""!(LA7X="HL70070")
SET LA7SPEC=$PIECE($PIECE(LA7SPTY,LA7CS),$EXTRACT(LA7ECH,4))
+112 ;
+113 IF $ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
Begin DoDot:1
+114 NEW X
+115 SET X=$ORDER(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
+116 ; specimen^collection sample
+117 SET X(0)=$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
+118 ; specimen
SET LA761=$PIECE(X(0),"^")
+119 ; collection sample
SET LA762=$PIECE(X(0),"^",2)
+120 ; HL7 code
+121 IF LA761
SET LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
End DoDot:1
+122 ;
+123 ; Log error when specimen source does not match accession's specimen
+124 IF LA70070'=""
IF LA7SPEC'=""
IF LA70070'=LA7SPEC
Begin DoDot:1
+125 NEW LA7OBR
+126 ; backward compatible with old code
SET LA7OBR(15)=LA7SPEC
+127 SET LA7ERR=22
SET LA7QUIT=2
+128 DO CREATE^LA7LOG(LA7ERR)
End DoDot:1
+129 ;
+130 ; Don't continue if flag set to skip this segment
+131 IF LA7QUIT
QUIT
+132 ;
+133 ; Placer's ordering provider (id^duz^last name, first name, mi [id])
+134 IF $GET(LA7POP)=""
Begin DoDot:1
+135 SET LA7POP=""
SET LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
+136 IF LA7X=""
QUIT
+137 SET LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
+138 IF LA7POP="^^"
SET LA7POP=""
End DoDot:1
+139 ;
+140 ; Create entry in LAH for supported subscripts.
+141 IF LA7MTYP="ORR"
IF $GET(LA7OTYPE)'="OK"
IF "CHMI"[LA7SS
Begin DoDot:1
+142 DO LAGEN
+143 IF $GET(LA7ISQN)=""
DO CREATE^LA7LOG(14)
QUIT
+144 SET LA7I=$ORDER(^TMP("LA7 ORDER STATUS",$JOB,""),-1)
SET LA7I=LA7I+1
+145 IF LA7ONLT=""
SET X=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
SET LA7X=$PIECE(X,LA7CS)
SET LA7X(0)=$PIECE(X,LA7CS,2)
+146 IF '$TEST
SET LA7X=LA7ONLT
SET LA7X(0)=LA7ONLT(0)
+147 SET X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$PIECE($GET(LA7SM),"^",2)
+148 SET ^TMP("LA7 ORDER STATUS",$JOB,LA7I)=X
+149 IF $GET(LA7OCR)'=""
SET ^TMP("LA7 ORDER STATUS",$JOB,LA7I,"OCR")=$TRANSLATE(LA7OCR,LA7CS,"^")
+150 IF $GET(LA7MSATM)'=""
SET ^TMP("LA7 ORDER STATUS",$JOB,LA7I,"MSA")=LA7MSATM
End DoDot:1
+151 ;
+152 IF LA7MTYP="ORU"
IF "CHMI"[LA7SS
Begin DoDot:1
+153 DO LAGEN
+154 IF $GET(LA7ISQN)<1
DO CREATE^LA7LOG(14)
QUIT
+155 IF LA7INTYP=10
IF LA7SAC?1(1"A",1"G")
Begin DoDot:2
+156 SET LA7I=$ORDER(^TMP("LA7 ORDER STATUS",$JOB,""),-1)
SET LA7I=LA7I+1
SET LA7SAC(0)=LA7I
+157 IF LA7ONLT=""
SET X=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
SET LA7X=$PIECE(X,LA7CS)
SET LA7X(0)=$PIECE(X,LA7CS,2)
+158 IF '$TEST
SET LA7X=LA7ONLT
SET LA7X(0)=LA7ONLT(0)
+159 SET X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^"_LA7SAC_"^"_$PIECE($GET(LA7SM),"^",2)
+160 SET ^TMP("LA7 ORDER STATUS",$JOB,LA7I)=X
End DoDot:2
End DoDot:1
+161 ;
+162 IF LA7INTYP=10
IF $GET(LA7SM)'=""
IF $GET(LA7UID)'=""
DO SMUPDT
+163 QUIT
+164 ;
+165 ;
LAGEN ; Sets 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 IF LA7ENTRY="LOG"
Begin DoDot:1
+5 IF LA7INTYP>19
IF LA7INTYP<30
QUIT
+6 IF '$DATA(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0))
DO CREATE^LA7LOG(13)
End DoDot:1
+7 ;cup=sequence number
IF LA7ENTRY="LLIST"
IF 'LA7CUP
SET LA7CUP=LA7IDE
+8 ;
+9 KILL LA7ISQN,LADT,LAGEN
+10 KILL TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
+11 ;
+12 SET LA7ISQN=""
+13 SET TRAY=+$GET(LA7TRAY)
IF 'TRAY
SET TRAY=1
+14 SET CUP=+$GET(LA7CUP)
IF 'CUP
SET CUP=1
+15 ;
+16 SET LWL=LA7LWL
+17 IF '$DATA(^LRO(68.2,+LWL,0))
Begin DoDot:1
+18 DO CREATE^LA7LOG(19)
End DoDot:1
QUIT
+19 ;
+20 ; Set accession area to area of specimen, allow multiple areas on same instrument.
+21 SET WL=LA7AA
+22 IF '$DATA(^LRO(68,+WL,0))
Begin DoDot:1
+23 DO CREATE^LA7LOG(20)
End DoDot:1
QUIT
+24 SET LROVER=$PIECE(LA7624(0),"^",12)
+25 SET METH=$PIECE(LA7624(0),"^",10)
+26 SET LOG=LA7AN
+27 ;identity field
SET IDENT=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6)
+28 SET IDE=+LA7IDE
+29 SET LADT=LA7AD
+30 ;
+31 ; If POC interface call special entry point
+32 Begin DoDot:1
+33 ; Protect LRDFN - call into LAGEN can set to 0
NEW LRDFN
+34 IF LA7INTYP>19
IF LA7INTYP<30
SET IDE=LA76249
DO POC^LAGEN
QUIT
+35 ;this disregards the CROSS LINK field in 62.4
DO @(LA7ENTRY_"^LAGEN")
End DoDot:1
+36 SET LA7ISQN=$GET(ISQN)
+37 ;
+38 IF LA7ISQN<1
QUIT
+39 ;
+40 ; Build/store patient demographics array
+41 NEW I,J,LA7OBRA,LA7PIDA,X,Y
+42 SET J="DFN^DOB^ICN^LOC^LRDFN^LRTDFN^PNM^SEX^SSN"
+43 SET J(0)="DFN^LA7DOB^LA7ICN^LA7LOC^LRDFN^LRTDFN^LA7PNM^LA7SEX^LA7SSN"
+44 FOR I=1:1
SET X=$PIECE(J,"^",I)
IF X=""
QUIT
Begin DoDot:1
+45 SET Y=$PIECE(J(0),"^",I)
+46 IF $GET(@Y)'=""
SET LA7PIDA(X)=@Y
End DoDot:1
+47 IF $DATA(LA7PIDA)
DO POI^LAGEN(LA7LWL,LA7ISQN,"PID",.LA7PIDA)
+48 ;
+49 ; Build/store order info array
+50 NEW LA7ONLTS
+51 IF LA7POP'=""
SET LA7POP=$PIECE(LA7POP," [")
+52 SET X=$GET(^LAH(LA7LWL,1,LA7ISQN,.1,"OBR","ORDNLT"))
+53 IF X'=""
IF LA7ONLT'=""
IF X'[LA7ONLT
SET LA7ONLTS=X_"^"_LA7ONLT
+54 IF '$TEST
SET LA7ONLTS=LA7ONLT
+55 SET J="EOL^FID^ORCDT^ORDNLT^ORDP^ORDSPEC^PON^SID^PEB^PVB"
+56 SET J(0)="LA7EOL^LA7FID^LA7CDT^LA7ONLTS^LA7POP^LA7SPEC^LA7PON^LA7SID^LA7PEB^LA7PVB"
+57 FOR I=1:1
SET X=$PIECE(J,"^",I)
IF X=""
QUIT
Begin DoDot:1
+58 SET Y=$PIECE(J(0),"^",I)
+59 IF $GET(@Y)'=""
SET LA7OBRA(X)=@Y
End DoDot:1
+60 IF $DATA(LA7OBRA)
DO POI^LAGEN(LA7LWL,LA7ISQN,"OBR",.LA7OBRA)
+61 ;
+62 ; Store interface type with results
+63 DO LATYP^LAGEN(LA7LWL,LA7ISQN,LA7INTYP)
+64 ;
+65 ; Store #62.49 ien with results
+66 DO LAMSGID^LAGEN(LA7LWL,LA7ISQN,LA76249)
+67 ;
+68 ; Store method name with LAH entry
+69 DO METH^LAGEN(LA7LWL,LA7ISQN,METH)
+70 ;
+71 ; Set flag if POC interface to start POC processing routine when
+72 ; finished - tasked by LA7VIN before shutdown
+73 IF LA7INTYP>19
IF LA7INTYP<30
SET LA7INTYP("LWL",LA7LWL)=""
+74 ;
+75 QUIT
+76 ;
+77 ;
SMUPDT ; Update shipping manifest in shipping event file #62.85
+1 NEW LA7DATA,LA7NCS,LA7TST,LA7USID
+2 ;
+3 ; Universal Service ID (OBR-4)
SET LA7USID=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
+4 ; Test code
SET LA7TST=$PIECE(LA7USID,LA7CS,1)
+5 ; Name of coding system
SET LA7NCS=$PIECE(LA7USID,LA7CS,3)
+6 ; Alternate test code
SET LA7TST(2)=$PIECE(LA7USID,LA7CS,4)
+7 ; Alternate coding system
SET LA7NCS(2)=$PIECE(LA7USID,LA7CS,6)
+8 ;
+9 ; Determine ordered test, check primary and alternate
+10 SET LA7OTST=$$DOT^LA7SMU1(LA7TST,LA7NCS,LA7UID,$PIECE(LA7SM,"^"))
+11 IF 'LA7OTST
IF LA7TST(2)'=""
SET LA7OTST=$$DOT^LA7SMU1(LA7TST(2),LA7NCS(2),LA7UID,$PIECE(LA7SM,"^"))
+12 ;
+13 ; Flag the Results Received Event in #62.85
+14 IF LA7MTYP="ORU"
Begin DoDot:1
+15 SET LA7DATA="SM70"_"^"_LA7MEDT_"^"_$GET(LA7OTST)_"^"_$PIECE(LA7SM,"^",2)
+16 DO SEUP^LA7SMU(LA7UID,"2",LA7DATA)
End DoDot:1
+17 ;
+18 ; Flag the Test Received Event in #62.85
+19 IF LA7MTYP="ORR"
Begin DoDot:1
+20 SET LA7DATA="SM55"_"^"_LA7MEDT_"^"_$GET(LA7OTST)_"^"_$PIECE(LA7SM,"^",2)
+21 DO SEUP^LA7SMU(LA7UID,"2",LA7DATA)
End DoDot:1
+22 QUIT
