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