LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;June 23, 2008
;;5.2;AUTOMATED LAB INSTRUMENTS;**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
;
; Create dummy MSH to pass HL7 delimiters
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"_LA7FS_LA7ECH_LA7FS
. S $P(LA7MSH(0),LA7FS,7)=$$FMTHL7^XLFDT($$NOW^XLFDT)_LA7FS
. D FILESEG^LA7VHLU(GBL,.LA7MSH)
;
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","")
;
; 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
. I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
. I LA("LRDFN")'=$QS(LA7ROOT,3) D PAT
. I LA("LRIDT")'=$QS(LA7ROOT,4) D
. . I $G(LA7INTYP)=30,$G(LA7OBRSN) D PAT
. . D ORC
. I LA("SUB")'=$QS(LA7ROOT,5) D
. . I $G(LA7INTYP)=30,$G(LA7OBRSN) D PAT
. . D ORC
. I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC
. D OBX
;
Q
;
;
PAT ; Build PID/PV1 segments
;
N I,LA7,LA7ERR,LA7PID,LA7PV1,VADMVT,VAINDT
;
S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
D DEM^LRX
;
; Build PID segment
S LA7PIDSN=LA7PIDSN+1
;
; Check if this field has been built previously for this patient
; Save this field to TMP global to use for subsequent calls.
I $D(^TMP($J,"LA7VHLU","PID",DFN,LA7FS_LA7ECH)) D
. M LA7PID=^TMP($J,"LA7VHLU","PID",DFN,LA7FS_LA7ECH)
. S $P(LA7PID(0),LA7FS,2)=LA7PIDSN
E D
. D BLDPID^VAFCQRY(DFN,LA7PIDSN,"ALL",.LA7,.HL,.LA7ERR)
. S I=0
. F S I=$O(LA7(I)) Q:'I S LA7PID(I-1)=LA7(I)
. M ^TMP($J,"LA7VHLU","PID",DFN,LA7FS_LA7ECH)=LA7PID
;
D FILESEG^LA7VHLU(GBL,.LA7PID)
I '$G(LA7NOMSG),$G(LA76249) D FILE6249^LA7VHLU(LA76249,.LA7PID)
;
; Build PV1 segment if building message for HDR and other subscribers
I $G(LA7INTYP)=30 D PV1
;
S (LA7OBRSN,LA7OBXSN,LA7NTESN)=0,(LA("LRIDT"),LA("SUB"))=""
Q
;
;
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")=""
;
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)
;
D ORC^LA7VORU,OBR
;
Q
;
;
OBR ; Build OBR segment
;
N LA7RS
;
I LA("SUB")="CH" D
. D OBR^LA7VORU
. D NTE^LA7VORU
. S LA7OBXSN=0
;
Q
;
;
OBX ; Build OBX segment
;
N LA7DATA,LA7VT
;
S LA7NTESN=0
I LA("SUB")="MI" D MI^LA7VORU1 Q
I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
;
S LA7VT=$QS(LA7ROOT,7)
D OBX^LA7VOBX(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^LA7VORUA
;
; 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
;
;
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)
;
D FILESEG^LA7VHLU(GBL,.LA7PV1)
I '$G(LA7NOMSG),$G(LA76249) D FILE6249^LA7VHLU(LA76249,.LA7PV1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7QRY1 6001 printed Oct 16, 2024@17:40:08 Page 2
LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;June 23, 2008
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,68**;Sep 27, 1994;Build 56
+2 ;
+3 ; Reference to ADM^VADPT2 supported by DBIA #325
+4 ; Reference to BLDPID^VAFCQRY supported by DBIA #3630
+5 QUIT
+6 ;
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 ;
+5 ; Create dummy MSH to pass HL7 delimiters
+6 IF $GET(LA7NOMSG)=1
Begin DoDot:1
+7 IF $LENGTH($GET(LA7HL7))'=5
SET LA7HL7="|^\~&"
+8 SET (HL("FS"),HLFS,LA7FS)=$EXTRACT(LA7HL7)
SET (HL("ECH"),HLECH,LA7ECH)=$EXTRACT(LA7HL7,2,5)
+9 SET (HLQ,HL("Q"))=""
+10 SET LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
+11 SET $PIECE(LA7MSH(0),LA7FS,7)=$$FMTHL7^XLFDT($$NOW^XLFDT)_LA7FS
+12 DO FILESEG^LA7VHLU(GBL,.LA7MSH)
End DoDot:1
+13 ;
+14 FOR X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE"
SET LA(X)=""
+15 ;
+16 ; Find POC user to identify those specimens that are POC.
+17 SET LRPOC=$$FIND1^DIC(200,"","OX","LRLAB,POC","B","")
+18 ;
+19 ; Take search results and put in HL7 message structure
+20 SET LA7ROOT="^TMP(""LA7-QRY"",$J)"
SET (LA7QUIT,LA7PIDSN)=0
SET LA7ID="LA7QRY-O-"
+21 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
Begin DoDot:1
+22 IF $QSUBSCRIPT(LA7ROOT,1)'="LA7-QRY"!($QSUBSCRIPT(LA7ROOT,2)'=$JOB)
SET LA7QUIT=1
QUIT
+23 IF LA("LRDFN")'=$QSUBSCRIPT(LA7ROOT,3)
DO PAT
+24 IF LA("LRIDT")'=$QSUBSCRIPT(LA7ROOT,4)
Begin DoDot:2
+25 IF $GET(LA7INTYP)=30
IF $GET(LA7OBRSN)
DO PAT
+26 DO ORC
End DoDot:2
+27 IF LA("SUB")'=$QSUBSCRIPT(LA7ROOT,5)
Begin DoDot:2
+28 IF $GET(LA7INTYP)=30
IF $GET(LA7OBRSN)
DO PAT
+29 DO ORC
End DoDot:2
+30 IF LA("NLT")'=$PIECE($QSUBSCRIPT(LA7ROOT,6),"!")
DO ORC
+31 DO OBX
End DoDot:1
if LA7QUIT
QUIT
+32 ;
+33 QUIT
+34 ;
+35 ;
PAT ; Build PID/PV1 segments
+1 ;
+2 NEW I,LA7,LA7ERR,LA7PID,LA7PV1,VADMVT,VAINDT
+3 ;
+4 SET (LA("LRDFN"),LRDFN)=$QSUBSCRIPT(LA7ROOT,3)
+5 SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)
SET DFN=$PIECE(^(0),"^",3)
+6 DO DEM^LRX
+7 ;
+8 ; Build PID segment
+9 SET LA7PIDSN=LA7PIDSN+1
+10 ;
+11 ; Check if this field has been built previously for this patient
+12 ; Save this field to TMP global to use for subsequent calls.
+13 IF $DATA(^TMP($JOB,"LA7VHLU","PID",DFN,LA7FS_LA7ECH))
Begin DoDot:1
+14 MERGE LA7PID=^TMP($JOB,"LA7VHLU","PID",DFN,LA7FS_LA7ECH)
+15 SET $PIECE(LA7PID(0),LA7FS,2)=LA7PIDSN
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 DO BLDPID^VAFCQRY(DFN,LA7PIDSN,"ALL",.LA7,.HL,.LA7ERR)
+18 SET I=0
+19 FOR
SET I=$ORDER(LA7(I))
if 'I
QUIT
SET LA7PID(I-1)=LA7(I)
+20 MERGE ^TMP($JOB,"LA7VHLU","PID",DFN,LA7FS_LA7ECH)=LA7PID
End DoDot:1
+21 ;
+22 DO FILESEG^LA7VHLU(GBL,.LA7PID)
+23 IF '$GET(LA7NOMSG)
IF $GET(LA76249)
DO FILE6249^LA7VHLU(LA76249,.LA7PID)
+24 ;
+25 ; Build PV1 segment if building message for HDR and other subscribers
+26 IF $GET(LA7INTYP)=30
DO PV1
+27 ;
+28 SET (LA7OBRSN,LA7OBXSN,LA7NTESN)=0
SET (LA("LRIDT"),LA("SUB"))=""
+29 QUIT
+30 ;
+31 ;
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 SET LA("RUID")=$PIECE(X,"^",5)
SET LRNMSP="LR"
+14 IF LRPOC
IF LRPOC=$PIECE(X,"^",4)
SET LRNMSP="LRPOC"
+15 SET LA("RUID","NMSP")=LRNMSP
+16 SET LA("RUID","SITE")=$PIECE(X,"^",3)
+17 IF LA("RUID")=""
Begin DoDot:1
+18 SET LA("RUID")=LA("HUID")
+19 SET LA("RUID","NMSP")=LA("HUID","NMSP")
+20 SET LA("RUID","SITE")=LA("HUID","SITE")
End DoDot:1
+21 ;
+22 SET LA("SITE")=$PIECE(X,"^",2)
+23 SET LA7NVAF=$$NVAF^LA7VHLU2(0)
SET LA7NTESN=0
+24 ;
+25 SET (LA("NLT"),LA7NLT)=$PIECE($QSUBSCRIPT(LA7ROOT,6),"!")
SET (LA764,LA("ORD"))=""
+26 IF LA7NLT'=""
Begin DoDot:1
+27 SET LA764=+$ORDER(^LAM("E",LA7NLT,0))
+28 IF LA764
SET LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
End DoDot:1
+29 ;
+30 DO ORC^LA7VORU
DO OBR
+31 ;
+32 QUIT
+33 ;
+34 ;
OBR ; Build OBR segment
+1 ;
+2 NEW LA7RS
+3 ;
+4 IF LA("SUB")="CH"
Begin DoDot:1
+5 DO OBR^LA7VORU
+6 DO NTE^LA7VORU
+7 SET LA7OBXSN=0
End DoDot:1
+8 ;
+9 QUIT
+10 ;
+11 ;
OBX ; Build OBX segment
+1 ;
+2 NEW LA7DATA,LA7VT
+3 ;
+4 SET LA7NTESN=0
+5 IF LA("SUB")="MI"
DO MI^LA7VORU1
QUIT
+6 IF "CYEMSP"[LA("SUB")
DO AP^LA7VORU2
QUIT
+7 ;
+8 SET LA7VT=$QSUBSCRIPT(LA7ROOT,7)
+9 DO OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
+10 IF '$DATA(LA7DATA)
QUIT
+11 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+12 IF '$GET(LA7NOMSG)
IF $GET(LA76249)
DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+13 ; Send any test interpretation from file #60
+14 DO INTRP^LA7VORUA
+15 ;
+16 ; Mark result as sent - set to 1, if corrected results set to 2
+17 IF LA("SUB")="CH"
Begin DoDot:1
+18 IF $PIECE(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$PIECE(LA7VT,"^")),"^",10)>1
QUIT
+19 SET $PIECE(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$PIECE(LA7VT,"^")),"^",10)=$SELECT($PIECE(LA7VT,"^",2)="C":2,1:1)
End DoDot:1
+20 ;
+21 QUIT
+22 ;
+23 ;
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 SET LA7PV1(0)=$$OUT^VAFHLPV1(DFN,"",LA7DT,LA7VPTR,"A",1)
End DoDot:1
+20 ;
+21 DO FILESEG^LA7VHLU(GBL,.LA7PV1)
+22 IF '$GET(LA7NOMSG)
IF $GET(LA76249)
DO FILE6249^LA7VHLU(LA76249,.LA7PV1)
+23 QUIT
