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

LA7CQRY1.m

Go to the documentation of this file. 
  1. LA7CQRY1 ;VA/DALOI/JMC - Lab HL7 Query Utility ; 11-Apr-2014 13:52 ; MAW
  1.  ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,1027,68,1033**;NOV 1, 1997
  1.  ;
  1.  ;;VA Patches:  46,61,68     ;Sep 27, 1994;Build 56
  1.  ;
  1.  ; Reference to ADM^VADPT2 supported by DBIA #325
  1.  ; Reference to BLDPID^VAFCQRY supported by DBIA #3630
  1.  Q
  1.  ;
  1. CHKSC ; Check search NLT/LOINC codes
  1.  ;
  1.  N J
  1.  ;
  1.  S J=0
  1.  F  S J=$O(LA7SCDE(J)) Q:'J  D
  1.  . N X
  1.  . S X=LA7SCDE(J)
  1.  . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D  Q
  1.  . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
  1.  . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D  Q
  1.  . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
  1.  . S LA7QERR(6)="Unknown search code "_$P(X,"^")_" passed"
  1.  . K LA7SCDE(J)
  1.  Q
  1.  ;
  1.  ;
  1. SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes
  1.  ; Find all topographies that use this HL7 specimen code
  1.  N J,K,L
  1.  ;
  1.  S J=0
  1.  F  S J=$O(LA7SPEC(J)) Q:'J  D
  1.  . S K=LA7SPEC(J),L=0
  1.  . F  S L=$O(^LAB(61,"HL7",K,L)) Q:'L  S ^TMP("LA7-61",$J,L)=""
  1.  Q
  1.  ;
  1.  ;
  1. BUILDMSG ; Build HL7 message with result of query
  1.  ;
  1.  I $G(LA7NOMSG)=1 N HL,HLECH,HLFS,HLQ,LA7ECH,LA7FS,LA7MSH
  1.  N LA,LA763,LA7ID,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7QUIT,LA7ROOT,LA7X,LRIDT,LRPOC,LRSS,X
  1.  N LA7SITE,LA7FAC,LA7VER,LA7CCNT
  1.  ;
  1.  ; Create dummy MSH to pass HL7 delimiters
  1.  S LA7SITE=$O(^BLRRLMU("B",DUZ(2),0))
  1.  S LA7FAC=$P($G(^DIC(4,DUZ(2),0)),U)
  1.  S LA7VER=$P($G(^BLRRLMU(LA7SITE,0)),U,2)
  1.  I $G(LA7NOMSG)=1 D
  1.  . I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
  1.  . S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
  1.  . S (HLQ,HL("Q"))=""
  1.  . S LA7MSH(0)=$$MSH^LA7CHDR(LA7FS,LA7ECH,LA7SITE)
  1.  . D FILESEG^LA7VHLU(GBL,.LA7MSH)
  1.  I '$G(LA7INPT) D
  1.  .S LA7SFT(0)=$$SFT(LA7FS,LA7ECH,LA7SITE)  ;MU2 sft segment
  1.  .D FILE6249^LA7VHLU(LA76249,.LA7SFT)
  1.  .D FILESEG^LA7VHLU(GBL,.LA7SFT)  ;add to the message
  1.  ;
  1.  F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
  1.  ;
  1.  ; Find POC user to identify those specimens that are POC.
  1.  S LRPOC=$$FIND1^DIC(200,"","OX","LRLAB,POC","B","")
  1.  ;
  1.  S LA7CCNT=0
  1.  ; Take search results and put in HL7 message structure
  1.  S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0,LA7ID="LA7QRY-O-"
  1.  F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7QUIT
  1.  . S LA7CCNT=LA7CCNT+1
  1.  . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
  1.  . ;MU2 added code below because of panel
  1.  . ; I LA7CCNT=1 D
  1.  . ;. D PAT
  1.  . ;. S PIDNTE(0)=$$PIDNTE(LA7FS,LA7ECH,DFN)  ;MU2 pid nte segment
  1.  . ;. I $G(PIDNTE(0))]"" D
  1.  . ;.. D FILE6249^LA7VHLU(LA76249,.PIDNTE)
  1.  . ;.. D FILESEG^LA7VHLU(GBL,.PIDNTE)
  1.  . ;. S NK1(0)=$$NK1(LA7FS,LA7ECH,DFN)  ;MU2 nk1 segment
  1.  . ;. I $G(NK1(0))]"" D
  1.  . ;.. D FILE6249^LA7VHLU(LA76249,.NK1)
  1.  . ;.. D FILESEG^LA7VHLU(GBL,.NK1)
  1.  . ;. D ORC
  1.  . ; D OBX
  1.  . ; I $G(LRSS)="CH" D
  1.  . ; . S SPM(0)=$$SPM^LA7CORU(LA7FS,LA7ECH,LA7UID)
  1.  . ; . D FILE6249^LA7VHLU(LA76249,.SPM)
  1.  . ; . D FILESEG^LA7VHLU(GBL,.SPM)
  1.  . ; D OBXAAO(LA7FS,LA7ECH,LA7UID,LRDFN,LRIDT)  ;MU2 ask at order questions
  1.  . ; maw put below back in when done with those segments
  1.  . ; S LA7SPM(0)=$$SPM^LA7CORU()
  1.  . ; D FILESEG^LA7VHLU(GBL,.LA7SPM)
  1.  . I LA("LRDFN")'=$QS(LA7ROOT,3) D
  1.  .. D PAT
  1.  .. S PIDNTE(0)=$$PIDNTE(LA7FS,LA7ECH,DFN)  ;MU2 pid nte segment
  1.  .. I $G(PIDNTE(0))]"" D
  1.  ... D FILE6249^LA7VHLU(LA76249,.PIDNTE)
  1.  ... D FILESEG^LA7VHLU(GBL,.PIDNTE)
  1.  .. I '$G(LA7INPT) S NK1(0)=$$NK1(LA7FS,LA7ECH,DFN)  ;MU2 nk1 segment
  1.  .. I $G(NK1(0))]"" D
  1.  ... D FILE6249^LA7VHLU(LA76249,.NK1)
  1.  ... D FILESEG^LA7VHLU(GBL,.NK1)
  1.  . I LA("LRIDT")'=$QS(LA7ROOT,4) D
  1.  .. I $G(LA7INTYP)=30,$G(LA7OBRSN) D
  1.  ... D PAT
  1.  ... S PIDNTE(0)=$$PIDNTE(LA7FS,LA7ECH,DFN)  ;MU2 pid nte segment
  1.  ... I $G(PIDNTE(0))]"" D
  1.  .... D FILE6249^LA7VHLU(LA76249,.PIDNTE)
  1.  .... D FILESEG^LA7VHLU(GBL,.PIDNTE)
  1.  ... I '$G(LA7INPT) S NK1(0)=$$NK1(LA7FS,LA7ECH,DFN)  ;MU2 nk1 segment
  1.  ... I $G(NK1(0))]"" D
  1.  .... D FILE6249^LA7VHLU(LA76249,.NK1)
  1.  .... D FILESEG^LA7VHLU(GBL,.NK1)
  1.  .. I '$G(LA7INPT) D ORC
  1.  . I LA("SUB")'=$QS(LA7ROOT,5) D
  1.  .. I $G(LA7INTYP)=30,$G(LA7OBRSN) D
  1.  ... D PAT
  1.  ... I '$G(LA7INPT) S PIDNTE(0)=$$PIDNTE(LA7FS,LA7ECH,DFN)  ;MU2 pid nte segment
  1.  ... I $G(PIDNTE(0))]"" D
  1.  .... D FILE6249^LA7VHLU(LA76249,.PIDNTE)
  1.  .... D FILESEG^LA7VHLU(GBL,.PIDNTE)
  1.  ... I '$G(LA7INPT) S NK1(0)=$$NK1(LA7FS,LA7ECH,DFN)  ;MU2 nk1 segment
  1.  ... I $G(NK1(0))]"" D
  1.  .... D FILE6249^LA7VHLU(LA76249,.NK1)
  1.  .... D FILESEG^LA7VHLU(GBL,.NK1)
  1.  .. D ORC
  1.  . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC
  1.  . D OBX
  1.  I $G(LRSS)="CH" D
  1.  . I $G(LA7INPT),$G(LA7ADDON) Q  ;mu2 inpatient
  1.  . S SPM(0)=$$SPM^LA7CORU(LA7FS,LA7ECH,LA7UID)
  1.  . D FILE6249^LA7VHLU(LA76249,.SPM)
  1.  . D FILESEG^LA7VHLU(GBL,.SPM)
  1.  D OBXAAO(LA7FS,LA7ECH,LA7UID,LRDFN,LRIDT)  ;MU2 ask at order questions
  1.  Q
  1.  ;
  1.  ;
  1. SFT(FS,ECH,SITE) ;-- return the SFT segment
  1.  N SFT,CS,RS,SC,SFTA
  1.  S CS=$E(ECH,1,1)
  1.  S RS=$E(ECH,2,2)
  1.  S SC=$E(ECH,4,4)
  1.  F I=1:1:6 S SFT(I)=""
  1.  S SFTA=$G(^BLRRLMU(SITE,"SFT"))
  1.  S SFT="SFT"
  1.  S SFT(1)=$$SFT1^LA7MUSFT(CS,SC,SFTA)
  1.  S SFT(2)=$$SFT2^LA7MUSFT(SFTA)
  1.  S SFT(3)=$$SFT3^LA7MUSFT(SFTA)
  1.  S SFT(4)=$$SFT4^LA7MUSFT(SFTA)
  1.  S SFT(6)=$$SFT6^LA7MUSFT(SFTA)
  1.  F J=1:1:6 S $P(SFT,FS,J+1)=SFT(J)
  1.  Q SFT
  1.  ;
  1. PID(FS,ECH,LDFN,DF) ;return the pid segment
  1.  N I,J,CS,RS,FAC,AL,MMN,MLNM,MFNM,MMI,MSFX,MPRX,MPSFX,M2,ADD1,ADD2,PH1,PH2,ETH,EDA
  1.  S FAC=$P($G(^DIC(4,DUZ(2),0)),U)
  1.  S CS=$E(ECH,1,1)
  1.  S RS=$E(ECH,2,2)
  1.  S SC=$E(ECH,4,4)
  1.  F I=1:1:39 S PID(I)=""
  1.  S PID="PID"
  1.  S LRDFN=LDFN,DFN=DF
  1.  D DEM^LRX
  1.  S AL=$P($G(^DPT(DF,.01,1,0)),U)  ;MU2 get one alias
  1.  S PID(1)=1
  1.  S PID(3)=$$PID3^LA7MUPID(CS,RS,SC,DFN,SSN)
  1.  S PID(5)=$$PID5^LA7MUPID(CS,RS,AL)
  1.  S PID(6)=$$PID6^LA7MUPID(CS,DFN)
  1.  S PID(7)=$$PID7^LA7MUPID()
  1.  S PID(8)=$$PID8^LA7MUPID()
  1.  S PID(10)=$$PID10^LA7MUPID(CS)
  1.  S PID(11)=$$PID11^LA7MUPID(CS,DFN)
  1.  S PID(13)=$$PID13^LA7MUPID(CS,DFN)
  1.  S PID(14)=$$PID14^LA7MUPID(CS,DFN)
  1.  S EDA=$O(^DPT(DF,.06,"B",0))
  1.  I EDA S ETH=$P($G(^DPT(DF,.06,EDA,0)),U)
  1.  I $G(ETH) S PID(22)=$$PID22^LA7MUPID(CS,DFN,ETH,LA7SITE)
  1.  S PID(29)=$$PID29^LA7MUPID(DFN)
  1.  S PID(30)=$$PID30^LA7MUPID(DFN)
  1.  S PID(33)=$$PID33^LA7MUPID(DFN)
  1.  S PID(34)=$$PID34^LA7MUPID(CS,LA7FAC)
  1.  I '$G(LA7INPT) S PID(35)=$$PID35^LA7MUPID(CS,LA7SITE)
  1.  F J=1:1:39 S $P(PID,FS,J+1)=PID(J)
  1.  Q PID
  1.  ;
  1. PAT ; Build PID/PV1 segments
  1.  N LA7PID,LA7PV1
  1.  S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
  1.  S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
  1.  S LA7PID(0)=$$PID(LA7FS,LA7ECH,LRDFN,DFN)
  1.  D FILESEG^LA7VHLU(GBL,.LA7PID)
  1.  I '$G(LA7NOMSG),$G(LA76249) D FILE6249^LA7VHLU(LA76249,.LA7PID)
  1.  S (LA7OBRSN,LA7OBXSN,LA7NTESN)=0,(LA("LRIDT"),LA("SUB"))=""
  1.  Q
  1.  ;
  1.  ;
  1. PIDNTE(FS,ECH,DF) ;build the PID NTE segment
  1.  Q:'$D(^AUPNPAT(DF,14,0)) ""
  1.  N PDA,REM,CS,RS,SC,NTE,CNT
  1.  S CS=$E(ECH,1,1)
  1.  S RS=$E(ECH,2,2)
  1.  S SC=$E(ECH,3,3)
  1.  F I=1:1:8 S NTE(I)=""
  1.  S NTE="NTE"
  1.  S REM=""
  1.  S CNT=0
  1.  S PDA=0 F  S PDA=$O(^AUPNPAT(DF,14,PDA)) Q:'PDA  D
  1.  . S REM=REM_$G(^AUPNPAT(DF,14,PDA,0))
  1.  . S CNT=CNT+1
  1.  . I CNT>1 S REM=REM_" "
  1.  S NTE(1)=1
  1.  S NTE(2)="P"
  1.  S NTE(3)=$G(REM)
  1.  S NTE(4)="RE"_CS_"Remark"_CS_"HL70364"_CS_"C"_CS_"Comment"_CS_"L"_CS_LA7VER_CS_"1.0"
  1.  F J=1:1:8 S $P(NTE,FS,J+1)=NTE(J)
  1.  Q NTE
  1.  ;
  1. NK1(FS,ECH,DF) ; build the NK1 segment
  1.  N FLAG
  1.  S FLAG=""
  1.  I $D(^DPT(DF,.21)) S FLAG=1
  1.  I $D(^DPT(DF,.291)) S FLAG=1
  1.  I '$G(FLAG) Q ""
  1.  N DATA,REM,CS,RS,SC,NK1,MMN,MLNM,M2,MFNM,MMI,MSFX,MPRX,MPSFX,RES,RELI,RLHL
  1.  S CS=$E(ECH,1,1)
  1.  S RS=$E(ECH,2,2)
  1.  S SC=$E(ECH,4,4)
  1.  F I=1:1:39 S NK1(I)=""
  1.  S DATA=$G(^DPT(DF,.21))
  1.  S NK1="NK1"
  1.  S NK1(1)=1
  1.  I $G(DATA)]"" D
  1.  . S NK1(2)=$$NK12^LA7MUNK1(CS,DATA)
  1.  . S NK1(3)=$$NK13^LA7MUNK1(CS,DF,DATA)
  1.  . S NK1(4)=$$NK14^LA7MUNK1(CS,DF,DATA)
  1.  . S NK1(5)=$$NK15^LA7MUNK1(CS,DF,DATA)
  1.  S NK1(13)=$$NK113^LA7MUNK1(CS,DF,SC)
  1.  S NK1(30)=$$NK130^LA7MUNK1(CS,DF)
  1.  S NK1(31)=$$NK131^LA7MUNK1(CS,DF)
  1.  S NK1(32)=$$NK132^LA7MUNK1(CS,DF)
  1.  F J=1:1:39 S $P(NK1,FS,J+1)=NK1(J)
  1.  Q NK1
  1.  ;
  1. PV1MU2(FS,ECH,DF) ;-- build the MU2 PV1 segment
  1.  N PV1
  1.  F I=1:1:52 S PV1(I)=""
  1.  S PV1="PV1"
  1.  S PV1(1)=1
  1.  S PV1(2)=$S($G(^DPT(DF,.1))]"":"I",1:"O")
  1.  S PV1(4)="C"
  1.  S PV1(44)=$$FMTHL7^XLFDT($P($G(LA763(0)),U))  ;admit date
  1.  S PV1(45)=$$FMTHL7^XLFDT($P($G(LA763(0)),U,3))  ;discharge date
  1.  F J=1:1:52 S $P(PV1,FS,J+1)=PV1(J)
  1.  Q PV1
  1.  ;
  1. ORC ; Build ORC segment
  1.  ;
  1.  N LA764,LA7NLT,LRNMSP,X
  1.  ;
  1.  S (LA("LRIDT"),LRIDT)=$QS(LA7ROOT,4),(LA("SUB"),LRSS)=$QS(LA7ROOT,5)
  1.  S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
  1.  S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
  1.  S LA("HUID")=$P(X,"^"),LRNMSP="LR"
  1.  I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
  1.  S LA("HUID","NMSP")=LRNMSP
  1.  I "CHMI"[LA("SUB") S LA("HUID","SITE")=$P(LA763(0),"^",14)
  1.  E  S LA("HUID","SITE")=""
  1.  ;
  1.  I '$G(LA7UID) S LA7UID=$G(LA("HUID"))
  1.  S LA("RUID")=$P(X,"^",5),LRNMSP="LR"
  1.  I LRPOC,LRPOC=$P(X,"^",4) S LRNMSP="LRPOC"
  1.  S LA("RUID","NMSP")=LRNMSP
  1.  S LA("RUID","SITE")=$P(X,"^",3)
  1.  I LA("RUID")="" D
  1.  . S LA("RUID")=LA("HUID")
  1.  . S LA("RUID","NMSP")=LA("HUID","NMSP")
  1.  . S LA("RUID","SITE")=LA("HUID","SITE")
  1.  ;
  1.  S LA("SITE")=$P(X,"^",2)
  1.  S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
  1.  ;
  1.  S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
  1.  I LA7NLT'="" D
  1.  . S LA764=+$O(^LAM("E",LA7NLT,0))
  1.  . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
  1.  ;
  1.  I '$G(LA7INPT) D
  1.  .S PV1(0)=$$PV1MU2(LA7FS,LA7ECH,DFN)
  1.  .D FILE6249^LA7VHLU(LA76249,.PV1)
  1.  .D FILESEG^LA7VHLU(GBL,.PV1)
  1.  D ORC^LA7CORU,OBR
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. OBR ; Build OBR segment
  1.  ;
  1.  N LA7RS
  1.  ;
  1.  I LA("SUB")="CH" D
  1.  . D OBR^LA7CORU
  1.  . I $G(LA7INPT),$G(LA7ADDON) S LA7OBXSN=0 Q  ;mu2 inpatient
  1.  . D NTE^LA7CORU
  1.  . I $G(LA7INPT),$G(LA7REJ) Q  ;mu2 inpatient
  1.  . S TQ1(0)=$$TQ1^LA7CORU(LA7FS,LA7ECH,LA7UID,LRDFN,LRIDT)
  1.  . D FILE6249^LA7VHLU(LA76249,.TQ1)
  1.  . D FILESEG^LA7VHLU(GBL,.TQ1)
  1.  . S LA7OBXSN=0
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. OBX ; Build OBX segment
  1.  ;
  1.  N LA7DATA,LA7VT
  1.  ;
  1.  S LA7NTESN=0
  1.  I LA("SUB")="MI" D MI^LA7CORU1 Q
  1.  ; I "CYEMSP"[LA("SUB") D AP^LA7CORU2 Q
  1.  ;
  1.  S LA7VT=$QS(LA7ROOT,7)
  1.  I $G(LA7INPT),$$ADDON(LA7VT) D
  1.  . S SPM(0)=$$SPM^LA7CORU(LA7FS,LA7ECH,LA7UID)
  1.  . D FILE6249^LA7VHLU(LA76249,.SPM)
  1.  . D FILESEG^LA7VHLU(GBL,.SPM)
  1.  . S LA7ORCSN=1
  1.  . S LA7ORCSN=LA7ORCSN+1
  1.  . D ORC
  1.  D OBX^LA7COBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
  1.  I '$D(LA7DATA) Q
  1.  D FILESEG^LA7VHLU(GBL,.LA7DATA)
  1.  I '$G(LA7NOMSG),$G(LA76249) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
  1.  ; Send any test interpretation from file #60
  1.  D INTRP^LA7CORUA
  1.  ;
  1.  ; Mark result as sent - set to 1, if corrected results set to 2
  1.  I LA("SUB")="CH" D
  1.  . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
  1.  . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. ADDON(TST) ;-- check to see if this was an addon
  1.  N TSTIEN,ORD,ROOT,DAT,NODE,ADDON
  1.  S ADDON=0
  1.  S TSTIEN=$O(^LAB(60,"C","CH;"_TST_";1",0))
  1.  I 'TSTIEN Q ADDON
  1.  S ORD=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
  1.  I 'ORD Q 0
  1.  S ROOT=$Q(^LRO(69,"C",ORD))
  1.  S DAT=$QS(ROOT,4)
  1.  S NODE=$QS(ROOT,5)
  1.  N NDA
  1.  S NDA=0 F  S NDA=$O(^LRO(69,DAT,1,NODE,2,NDA)) Q:'NDA  D
  1.  . Q:$P($G(^LRO(69,DAT,1,NODE,2,NDA,0)),U)'=TSTIEN
  1.  . I $G(^LRO(69,DAT,1,NODE,2,NDA,1,1,0))["Added" S LA7ADDON=$P($G(^LRO(69,DAT,1,NODE,2,2,0)),U),ADDON=1
  1.  Q ADDON
  1.  ;
  1. PV1 ; Build PV1 segment for HDR
  1.  N LA7DT,LA7PCE,LA7SDENC,LRDX,LRIDT,LRSS,LRUID,VADMVT,VAINDT
  1.  S LRIDT=$QS(LA7ROOT,4),LRSS=$QS(LA7ROOT,5),LA7DT=0
  1.  I LRIDT,LRSS'="" S LA7DT=$P($G(^LR(LRDFN,LRSS,LRIDT,0)),"^")
  1.  I 'LA7DT Q
  1.  ;
  1.  S LRDX=""
  1.  ; Determine if an inpatient at time of specimen and build inpatient PV1.
  1.  S VAINDT=LA7DT D ADM^VADPT2
  1.  I VADMVT S LA7PV1(0)=$$IN^VAFHLPV1(DFN,LA7DT,",3,6,7,10,18,21,36,39,44,45,",VADMVT,"",1,LRDX)
  1.  ;
  1.  ; If not an inpatient then build outpatient PV1.
  1.  I 'VADMVT D
  1.  . N LA7VPTR
  1.  . S LA7PCE=$$PCENC^LA7VHLU3(LRDFN,LRSS,LRIDT),LA7VPTR=""
  1.  . I LA7PCE'="" D
  1.  . . S LA7SDENC=$$SDENC^LA7VHLU3(LA7PCE)
  1.  . . I LA7SDENC'="" S LA7VPTR=LA7SDENC_";SCE("
  1.  . I LA7VPTR="" S LA7VPTR=DFN_";DPT("
  1.  . ; S LA7PV1(0)=$$OUT^VAFHLPV1(DFN,"",LA7DT,LA7VPTR,"A",1)
  1.  . S:$D(^VAT(391.71)) LA7PV1(0)=$$OUT^VAFHLPV1(DFN,"",LA7DT,LA7VPTR,"A",1)     ; IHS/MSC/MKK - LR*5.2*1032 - Only Call if ADT/HL7 PIVOT file exists
  1.  ;
  1.  D FILESEG^LA7VHLU(GBL,.LA7PV1)
  1.  I '$G(LA7NOMSG),$G(LA76249) D FILE6249^LA7VHLU(LA76249,.LA7PV1)
  1.  Q
  1.  ;
  1. OBXAAO(FS,ECH,ACC,LDFN,LIDT)  ;-build the OBX ask at order questions
  1.  N ROI
  1.  S ROI=$O(^BLRRLO("ACC",ACC,0))
  1.  Q:'ROI
  1.  N CS,RS,SC,RDA,OBX,OBY
  1.  S CS=$E(ECH,1,1)
  1.  S RS=$E(ECH,2,2)
  1.  S SC=$E(ECH,3,3)
  1.  F I=1:1:25 S OBY(I)=""
  1.  S RDA=0 F  S RDA=$O(^BLRRLO(ROI,4,RDA)) Q:'RDA  D
  1.  . Q:$P($G(^BLRRLO(ROI,4,RDA,0)),U,3)="SPM5"
  1.  . Q:$P($G(^BLRRLO(ROI,4,RDA,0)),U,3)="SPM9"
  1.  . S OBX(0)="OBX"
  1.  . S OBY(1)=1
  1.  . S OBY(2)="SN"
  1.  . S OBY(3)=$$OBX3^LA7MUOBX(CS,ACC,ROI,RDA)
  1.  . S OBY(5)=$$OBX5^LA7MUOBX(CS,ACC,ROI,RDA)
  1.  . S OBY(6)=$$OBX6^LA7MUOBX(CS)
  1.  . S OBY(11)="F"
  1.  . S OBY(14)=$$FMTHL7^XLFDT($P($G(^LR(LDFN,LRSS,LIDT,0)),U))
  1.  . S OBY(18)=$$FMTHL7^XLFDT($P($G(^LR(LDFN,LRSS,LIDT,0)),U))
  1.  . S OBY(19)=$$FMTHL7^XLFDT($S($P($G(LA763(0)),U):$P($G(LA763(0)),U),1:DT))
  1.  . S OBY(23)=$$OBX23^LA7COBX(4,DUZ(2),LA7FS,LA7ECH)
  1.  . S $P(OBY(23),$E(LA7ECH,1),6)="CLIA"_$E(LA7ECH,4)_"2.16.840.1.113883.4.7"_$E(LA7ECH,4)_"ISO"
  1.  . S $P(OBY(23),$E(LA7ECH,1),7)="XX"
  1.  . S $P(OBY(23),$E(LA7ECH,1),10)=$P($G(^DIC(4,DUZ(2),99)),U)
  1.  . S OBY(24)=$$OBX24^LA7COBX(4,DUZ(2),DT,LA7FS,LA7ECH)
  1.  . S $P(OBY(24),$E(LA7ECH),6)="USA"
  1.  . S $P(OBY(24),$E(LA7ECH),7)="L"
  1.  . S $P(OBY(24),$E(LA7ECH),9)=$$LZERO^LA7MUPID($P(OBY(24),$E(LA7ECH),5),5)  ;MU2 county code same as zip for now
  1.  . S OBY(25)=$$OBX25^LA7COBX($$GET1^DIQ(9009029,DUZ(2),3027,"I"),DUZ(2),LA7FS,LA7ECH)
  1.  . S $P(OBY(25),$E(LA7ECH),9)="NPI"_$E(LA7ECH,4)_"2.16.840.1.113883.4.6"_$E(LA7ECH,4)_"ISO"
  1.  . S $P(OBY(25),$E(LA7ECH),10)="L"
  1.  . S $P(OBY(25),$E(LA7ECH),13)="NPI"
  1.  . S $P(OBY(25),$E(LA7ECH),14)="NPI_Facility"_$E(LA7ECH,4)_"2.16.840.1.113883.3.72.5.26"_$E(LA7ECH,4)_"ISO"
  1.  . S $P(OBY(25),$E(LA7ECH),21)=$P(OBY(25),$E(LA7ECH),6)
  1.  . F J=1:1:25 S $P(OBX(0),FS,J+1)=OBY(J)
  1.  . D FILE6249^LA7VHLU(LA76249,.OBX)
  1.  . D FILESEG^LA7VHLU(GBL,.OBX)
  1.  Q
  1.  ;
  1. LOOKTAB(TYPE,TAB,VAL,ECH) ;-- find the value and description in the HL7 tables
  1.  N DESC,IENI,GBL
  1.  S GBL="^BHLTBL"
  1.  I TYPE="" S GBL="^BHLOTBL"
  1.  S IENI=$O(@GBL@("AVAL",TAB,VAL,0))
  1.  Q:'IENI
  1.  S DESC=$P($G(@GBL@(IENI,0)),U,3)
  1.  Q VAL_ECH_DESC_ECH_TYPE_TAB
  1.  ;
  1. LOOKDSC(TYPE,TAB,DSC,ECH) ;-- find a reverse value based on description
  1.  N VAL,IENI,GBL
  1.  S GBL="^BHLOTBL"
  1.  I TYPE="" S GBL="^BHLOTBL"
  1.  S IENI=$O(@GBL@("ADSC",TAB,DSC,0))
  1.  Q:'IENI
  1.  S VAL=$P($G(@GBL@(IENI,0)),U,2)
  1.  Q VAL_ECH_ECH_TYPE_TAB