Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LA7VIN4

LA7VIN4.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; This routine is a continuation of LA7VIN1 and is only called from there.
  1.  ;
  1.  ; ZEXCEPT is used to identify variables which are external to a specific TAG
  1.  ;         used in conjunction with Eclipse M-editor.
  1.  ;
  1.  Q
  1.  ;
  1. OBR ; Process OBR segments
  1.  N I,LA7CUP,LA7ENTRY,LA7FF1,LA7FF2,LA7I,LA7IDE,LA7INST,LA7OK,LA7PDUZ,LA7PF1,LA7PF2,LA7TRAY,LA7X,LA7Y
  1.  ;
  1.  ;ZEXCEPT: A,CH,CY,EM,G,LA70070,LA761,LA762,LA7624,LA76248,LA76249
  1.  ;ZEXCEPT: LA7AA,LA7ACC,LA7AD,LA7AERR,LA7AN,LA7ARI,LA7AUTORELEASE,LA7CDT,LA7CS,LA7ECH,LA7ERR,LA7FID,LA7FS,LA7ID,LA7INTYP,LA7ISQN,LA7LWL,LA7MSATM,LA7MTYP
  1.  ;ZEXCEPT: LA7OBR,LA7OBR25,LA7OBR26,LA7OBR29,LA7OBR32,LA7OBR33,LA7OBR34,LA7OBR49,LA7OCR,LA7ONLT,LA7OTYPE,LA7POP,LA7PRI,LA7QUIT
  1.  ;ZEXCEPT: LA7RSDT,LA7SAC,LA7SAP,LA7SEG,LA7SFAC,LA7SID,LA7SM,LA7SOBR,LA7SPEC,LA7SPTY,LA7SS,LA7TECH,LA7UID,LAPSUBID,MI,N,SP
  1.  ;
  1.  ; OBR Set ID
  1.  S LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
  1.  ;
  1.  S LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
  1.  S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
  1.  S LA7624=0,LA7INST=$P(LA7X,"^") ; extracting 1st piece
  1.  ; Look up #62.4 entry from instrument name.
  1.  I LA7INST'="" S LA7624=+$O(^LAB(62.4,"B",LA7INST,0))
  1.  ;
  1.  ; If none then use sending application name to look up #62.4 entry.
  1.  I 'LA7624 S LA7624=+$O(^LAB(62.4,"B",LA7SAP,0))
  1.  ;
  1.  ; Instrument name not found in xref
  1.  I 'LA7624 D  Q
  1.  . I LA7INST="" D  Q
  1.  . . S LA7ERR=10,LA7QUIT=2
  1.  . . D CREATE^LA7LOG(LA7ERR)
  1.  . S LA7ERR=11,LA7QUIT=2
  1.  . S LA7AERR=$$CREATE^LA7LOG(LA7ERR,1)
  1.  S LA7624(0)=$G(^LAB(62.4,LA7624,0))
  1.  S LA7ID=$P(LA7624(0),"^")_"-I-"
  1.  ;
  1.  S LA7LWL=+$P(LA7624(0),"^",4) ;  Load/Work List
  1.  S LA7ENTRY=$P(LA7624(0),"^",6) ;LOG,LLIST,IDENT or SEQN
  1.  S:LA7ENTRY="" LA7ENTRY="LOG"
  1.  ;
  1.  ; Placer(sender)/filler order numbers
  1.  S LA7X=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
  1.  S LA7SID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7SID(I)=$P(LA7X,$E(LA7ECH),I)
  1.  S LA7X=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
  1.  S LA7FID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7FID(I)=$P(LA7X,$E(LA7ECH),I)
  1.  ;
  1.  ; Test order code - find order NLT code
  1.  ; If POC interface then see if NLT is used for ordering code
  1.  S LA7X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7ONLT=""
  1.  F I=1,4 D  Q:LA7ONLT'=""
  1.  . I $P(LA7X,LA7CS,I)'?5N1"."4N Q
  1.  . I $P(LA7X,LA7CS,I+2)="99VA64" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
  1.  . I LA7INTYP>19,LA7INTYP<30,$P(LA7X,LA7CS,I+2)="" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
  1.  ;
  1.  ; Specimen collection date/time
  1.  S LA7CDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L")
  1.  ;
  1.  ; Extract filler fields #1&2 and placer fields #1&2
  1.  F LA7I=18:1:21 D
  1.  . S LA7X=$$P^LA7VHLU(.LA7SEG,LA7I+1,LA7FS)
  1.  . S LA7OBR(LA7I)=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
  1.  ;
  1.  ; Pull info from placer field #2 (OBR-19)
  1.  S LA7X=LA7OBR(19)
  1.  S LA7TRAY=+$P(LA7X,"^",1) ;Tray
  1.  S LA7CUP=+$P(LA7X,"^",2) ; Cup
  1.  ; If POC interface set cup to file #62.49 ien
  1.  I LA7INTYP>19,LA7INTYP<30 S LA7CUP=LA76249
  1.  S LA7AA=$P(LA7X,"^",3) ;  Accession Area
  1.  S LA7AD=$P(LA7X,"^",4) ;  Accession Date
  1.  S LA7AN=$P(LA7X,"^",5) ;  Accession Entry
  1.  S LA7ACC=$P(LA7X,"^",6) ;  Accession
  1.  I LA7ACC'="" D SETID^LA7VHLU1(LA76249,LA7ID,LA7ACC,0)
  1.  S LA7UID=$P(LA7X,"^",7) ;  Unique ID
  1.  I $L(LA7UID)<10 S LA7UID=""
  1.  ;
  1.  ; Sequence Number
  1.  ; If point of care interface (20-29) then use file #62.49 ien as IDE
  1.  S LA7IDE=$P(LA7X,LA7CS,8)
  1.  I LA7INTYP>19,LA7INTYP<30 S LA7IDE=LA76249
  1.  ;
  1.  ; UID might come as Sample ID
  1.  I LA7UID="",$L(LA7SID)>9 S LA7UID=LA7SID
  1.  ;
  1.  ; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID)
  1.  ; accession may have rolled over, use UID to get current accession info.
  1.  I LA7UID'="" D
  1.  . N X
  1.  . S X=$Q(^LRO(68,"C",LA7UID)) Q:X=""  ; UID not on file
  1.  . I $QS(X,3)'=LA7UID S LA7UID="" Q  ; UID not on file.
  1.  . S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
  1.  . D SETID^LA7VHLU1(LA76249,LA7ID,LA7UID,1)
  1.  . D SETID^LA7VHLU1(LA76249,"",LA7UID,0)
  1.  ;
  1.  ; If still not known, compute from default accession date and area.
  1.  ; Calculate accession date based on accession transform.
  1.  I LA7AA<1!(LA7AD<1)!(LA7AN<1) D
  1.  . N X
  1.  . S LA7AA=+$P(LA7624(0),"^",11)
  1.  . S X=$P($G(^LRO(68,LA7AA,0)),U,3)
  1.  . 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)
  1.  . S LA7AN=+LA7SID
  1.  . I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN,1)
  1.  . I LA7SID'="" D SETID^LA7VHLU1(LA76249,LA7ID,LA7SID,0)
  1.  ;
  1.  ; Zeroth node of accession area.
  1.  S LA7AA(0)=$G(^LRO(68,+LA7AA,0))
  1.  ; Accession's subscript
  1.  S LA7SS=$P(LA7AA(0),"^",2)
  1.  ;
  1.  ; Specimen action code
  1.  S LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
  1.  ;
  1.  ; Specimen(topography), collection sample, HL7 specimen source
  1.  S (LA761,LA762,LA70070,LA7SPEC)=""
  1.  S LA7X=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
  1.  D FLD2ARR^LA7VHLU7(.LA7X,LA7FS_LA7ECH)
  1.  M LA7SPTY=LA7X(1)
  1.  ;
  1.  ; Look for HL7 Table 0070 code.
  1.  ; If coding system blank then default to table 0070 as coding system per HL7 standard for OBR-15.
  1.  ; If no code and not a standard code set then ignore (remove).
  1.  F I=1,4 D
  1.  . 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
  1.  . I $G(LA7SPTY(I+2))="" S LA7SPTY(I+2)="HL70070"
  1.  . I LA7SPTY(I+2)="HL70070" S LA7SPEC=LA7SPTY(I)
  1.  I LA7SPEC="" S LA7SPEC=$G(LA7SPTY)
  1.  ;
  1.  ; Retrieve related specimen/collection sample from accession
  1.  ; Create specimen array to handle multiple AP specimens on orders.
  1.  S I=0
  1.  F  S I=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,I)) Q:'I  D
  1.  . S X=^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,I,0)
  1.  . I $P(X,"^") D
  1.  . . S LA761($P(X,"^"))="" ;spec array
  1.  . . I LA761="" S LA761=$P(X,"^")
  1.  . I $P(X,"^",2) D
  1.  . . S LA762($P(X,"^",2))="" ;sample array
  1.  . . I LA762="" S LA762=$P(X,"^",2)
  1.  ;
  1.  ; Log error when specimen source does not match accession's specimen
  1.  ; Ignore if specimen related to lab control file #62.3
  1.  S LA7OK=1
  1.  I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)'=62.3 D
  1.  . N DIERR,LA7MSG
  1.  . F LA7I=1,4 I $G(LA7SPTY(LA7I))'="" D  Q:'LA7OK
  1.  . . I $G(LA7SPTY(LA7I+2))="HL70070" D  Q
  1.  . . . K DIERR,LA7MSG
  1.  . . . S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR",,,"LA7MSG")
  1.  . . . I LA70070'="",LA70070'=LA7SPTY(LA7I) S LA7OK=0,LA7OK(0)="HL7 "_LA7SPTY(LA7I)
  1.  . . I $G(LA7SPTY(LA7I+2))="SCT" D OBRSCT Q
  1.  ;
  1.  I 'LA7OK D
  1.  . N LA7MSG
  1.  . S LA7ERR=49,LA7QUIT=2,LA7MSG=LA7OK(0)
  1.  . S LA7AERR=$$CREATE^LA7LOG(LA7ERR,1)
  1.  ;
  1.  ; Don't continue if flag set to skip this segment
  1.  I LA7QUIT Q
  1.  ;
  1.  ; Placer's ordering provider (id^duz^last name, first name, mi [id])
  1.  I $G(LA7POP)="" D
  1.  . S LA7POP="",LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
  1.  . I LA7X="" Q
  1.  . S LA7POP=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
  1.  . I LA7POP="^^" S LA7POP=""
  1.  ;
  1.  ; Results rpt/status chng -  date/time
  1.  S LA7X=$$P^LA7VHLU(.LA7SEG,23,LA7FS),LA7RSDT=""
  1.  I LA7X'="" S LA7RSDT=$$HL7TFM^XLFDT(LA7X,"L")
  1.  ;
  1.  ; Result status
  1.  S LA7OBR25=$$P^LA7VHLU(.LA7SEG,26,LA7FS)
  1.  ;
  1.  ; Parent result - CM data type.
  1.  ; Save OBX-4 (sub-id) of parent result in LAPSUBID for subsequent usage by OBX/NTE's.
  1.  S LA7OBR26=$$FIELD^LA7VHLU7(26)
  1.  D FLD2ARR^LA7VHLU7(.LA7OBR26)
  1.  S LAPSUBID=$G(LA7OBR26(2))
  1.  ;
  1.  ; Parent
  1.  S LA7OBR29=$$FIELD^LA7VHLU7(29)
  1.  D FLD2ARR^LA7VHLU7(.LA7OBR29)
  1.  ;
  1.  ; Principle Result interpreter
  1.  S LA7OBR32=$$FIELD^LA7VHLU7(32),LA7PRI=""
  1.  D FLD2ARR^LA7VHLU7(.LA7OBR32)
  1.  I $G(LA7OBR32(1))'="" D
  1.  . S LA7X=$TR(LA7OBR32(1),$E(LA7ECH,4),$E(LA7ECH))
  1.  . S LA7PRI=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
  1.  . I LA7PRI="^^" S LA7PRI=""
  1.  ;
  1.  ; Assistant Result Interpreter
  1.  S LA7OBR33=$$FIELD^LA7VHLU7(33),LA7ARI=""
  1.  D FLD2ARR^LA7VHLU7(.LA7OBR33)
  1.  I $G(LA7OBR33(1))'="" D
  1.  . S LA7X=$TR(LA7OBR33(1),$E(LA7ECH,4),$E(LA7ECH))
  1.  . S LA7ARI=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
  1.  . I LA7ARI="^^" S LA7ARI=""
  1.  ;
  1.  ; Technician
  1.  S LA7OBR34=$$FIELD^LA7VHLU7(34),LA7TECH=""
  1.  D FLD2ARR^LA7VHLU7(.LA7OBR34)
  1.  I $G(LA7OBR34(1))'="" D
  1.  . S LA7X=$TR(LA7OBR34(1),$E(LA7ECH,4),$E(LA7ECH))
  1.  . S LA7TECH=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
  1.  . I LA7TECH="^^" S LA7TECH=""
  1.  ;
  1.  ; Results handling
  1.  ; Usually IS data type however later HL7 versions use CWE data type. Attempt to handle either format.
  1.  S LA7X=$$P^LA7VHLU(.LA7SEG,50,LA7FS)
  1.  S LA7OBR49=$P(LA7X,LA7CS,1)
  1.  ;
  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
  1.  I LA7MTYP="ORU" S LA7AUTORELEASE=$$ARSTATUS^LA7VIN5(LA7OBR49,"-.0000",LA7624)
  1.  ;
  1.  ; Create entry in LAH for supported subscripts.
  1.  I LA7MTYP="ORR",$G(LA7OTYPE)'="OK",LA7SS?1(1"CH",1"MI",1"SP",1"CY",1"EM") D
  1.  . D LAGEN^LA7VIN4A
  1.  . I $G(LA7ISQN)="" D CREATE^LA7LOG(14) Q
  1.  . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1
  1.  . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
  1.  . E  S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
  1.  . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$P($G(LA7SM),"^",2)
  1.  . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
  1.  . I $G(LA7OCR)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"OCR")=$TR(LA7OCR,LA7CS,"^")
  1.  . I $G(LA7MSATM)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"MSA")=LA7MSATM
  1.  ;
  1.  I LA7MTYP="ORU",LA7SS?1(1"CH",1"MI",1"SP",1"CY",1"EM") D
  1.  . D LAGEN^LA7VIN4A
  1.  . I $G(LA7ISQN)<1 S LA7ERR=14,LA7AERR=$$CREATE^LA7LOG(LA7ERR,1) Q
  1.  . I LA7INTYP=10,LA7SAC?1(1"A",1"G") D
  1.  . . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1,LA7SAC(0)=LA7I
  1.  . . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
  1.  . . E  S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
  1.  . . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2)
  1.  . . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
  1.  . I LA7INTYP=10,LA7OBR25?1(1"A",1"X") D
  1.  . . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1
  1.  . . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
  1.  . . E  S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
  1.  . . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2)_"^"_LA7OBR25
  1.  . . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
  1.  . I LA7INTYP=10,LA7SS?1(1"MI",1"SP",1"CY",1"EM") S ^TMP("LA7-PL-NTE",$J,LA7LWL,LA7ISQN,LA7SS)=LA7SFAC
  1.  ;
  1.  ;LA*5.2*101: Do not require that LA7SM (shipping manifest identifier) not be null
  1.  I LA7INTYP=10,$G(LA7UID)'="" D SMUPDT^LA7VIN4A
  1.  Q
  1.  ;
  1.  ;
  1. OBRSCT   ; check if SCT doesn't match any specimen in #68
  1.  ;
  1.  ;ZEXCEPT: LA761,LA76248,LA7I,LA7OK,LA7SPTY
  1.  ;
  1.  N LA761SCT,R61,SCTOK
  1.  S (R61,SCTOK)=0
  1.  F  S R61=$O(LA761(R61)) Q:'R61  D
  1.  . I $D(^LAHM(62.48,LA76248,"SCT","AD1",LA7SPTY(LA7I),R61_";LAB(61,")) S SCTOK=1 Q
  1.  . S LA761SCT=$$IEN2SCT^LA7VHLU6(61,R61,DT,"")
  1.  . I LA761SCT'>0 S SCTOK=1
  1.  . I $P(LA761SCT,"^")=LA7SPTY(LA7I) S SCTOK=1
  1.  ;
  1.  ; If no topography found on accession with a SCT mapping that matches SCT code then flag as error.
  1.  ; Also if SCT code in message has Lexicon exception then record as a separate error.
  1.  I 'SCTOK D
  1.  . N LA7SCT,LA7X,LA7Z
  1.  . S LA7OK=0,LA7OK(0)="SCTID "_LA7SPTY(LA7I)
  1.  . S LA7Z=$$CODE^LEXTRAN(LA7SPTY(LA7I),"SCT",DT,"LA7SCT")
  1.  . I $P(LA7Z,"^",5) D
  1.  . . S LA7X=$P(LA7Z,"^",6)
  1.  . . D CREATE^LA7LOG(37)
  1.  ;
  1.  Q