LR7OVB ;HOIFO/BNT - Lab Receive HL7 Order Update from VBECS ;2/22/08 21:19
;;5.2;LAB SERVICE;**367**;Sep 27, 1994;Build 12
;Reference to $$FIND1^DIC supported by IA #2051
;Reference to EN^ORMVBEC supported by IA #4982
;Reference to $$HL7TFM^XLFDT supported by IA #10103
;Reference to $$NOW^XLFDT supported by IA #10103
;Reference to $$STRIP^XLFSTR supported by IA #10104
;
EN1(LRMSG) ; Entry point for LR7O VBECS RECEIVE Protocol
N LRSEG,LRSEGID,LRERR,LRACK,ORDCNTRL,LROIEN,LRTST,LRDFN,DFN,LRI,LRJ,ORIFN,ORDSTS,ORDCNTRL
S LRQUIT=0
S LRI=0 F S LRI=$O(LRMSG(LRI)) Q:'LRI D Q:$D(LRERR)!(LRQUIT)
. S LRSEG=LRMSG(LRI),LRSEGID=$P(LRMSG(LRI),HL("FS"))
. I $T(@LRSEGID)]"" D @LRSEGID
Q:$D(LRERR)!(LRQUIT)
;
I 'LRACK D GENACK
Q
;
ORC ; - Process ORC segment
S ORDCNTRL=$TR($P(LRSEG,HL("FS"),2),"@","P")
I '$L(ORDCNTRL) S LRERR="Invalid control code" D ERROR Q
S ORDSTS=$P(LRSEG,HL("FS"),6)
I ORDSTS'="CM" D ERROR Q
Q
;
OBR ; -- Process OBR segment
S LROIEN=$P($P(LRSEG,HL("FS"),14),";")
S LRTST=$$STRIP^XLFSTR($P($P(LRSEG,HL("FS"),14),";",4)," ")
I LRTST']"" S LRERR="Missing Lab Test ID" D ERROR Q
I LROIEN']"" S LRERR="Missing Lab Test IEN" D ERROR Q
; Complete the Lab Order
D COMPLETE(LROIEN,LRTST,LRDFN1)
Q
;
PID ; -- Process PID segment
N I,X,PIDLST
; Adding logic to support v2.4 Patient Id List
S PIDLST=$P(LRSEG,HL("FS"),4)
I PIDLST[$E(HL("ECH")) D
. F I=1:1:$L(PIDLST,$E(HL("ECH"),2)) S X=$P(PIDLST,$E(HL("ECH"),2),I) Q:X="" I $P(X,$E(HL("ECH")),5)["PI" S LRDFN1=+X Q
I PIDLST'[$E(HL("ECH")) S LRDFN1=+$P(LRSEG,HL("FS"),4)
I '$D(^DPT(LRDFN1,0)) S LRERR="Invalid Patient Id "_LRDFN1 D ERROR Q
Q
;
FMDATE(Y) ; -- Convert HL7 date/time to FM format
Q $$HL7TFM^XLFDT(Y) ;**97
;
ERROR ;
S LRQUIT=1
I 'LRACK D GENACK
Q
;
COMPLETE(LROIEN,LRTST,LRDFN1) ; - Complete the accession for this test and the OERR order
; LROIEN = File 69 IEN
; LRTST = File 60 IEN
; LRDFN1 = File 2 IEN
N LRA,LRB,LRC,LR0,LRV,LRAA,LRY,LRAD,LRAN,LRODT,LRSN
S (LRQUIT,LRW)=0
I '$D(LRACK) S LRACK=1
I '$D(^LRO(69,"C",LROIEN)) S LRERR="Invalid Lab Order Number" D ERROR Q
S LRA=0 F S LRA=$O(^LRO(69,"C",LROIEN,LRA)) Q:'LRA D Q:LRQUIT
. S LRB=0 F S LRB=$O(^LRO(69,"C",LROIEN,LRA,LRB)) Q:'LRB D
. . ; Order has been merged.
. . I $P($G(^LRO(69,LRA,1,LRB,1)),"^",7)]"" D ERROR Q
. . S LRC=0 F S LRC=$O(^LRO(69,LRA,1,LRB,2,LRC)) Q:'LRC D
. . . S LR0=^LRO(69,LRA,1,LRB,2,LRC,0) Q:+LR0'=LRTST
. . . S LRDFN=$P(^LRO(69,LRA,1,LRB,0),"^",1)
. . . I $P($G(^LR(LRDFN,0)),"^",3)'=LRDFN1 S LRERR="Lab Patient on order does not match patient DFN" D ERROR Q
. . . S LRAA=$P($G(LR0),"^",4)
. . . S LRAD=$P($G(LR0),"^",3)
. . . S LRAN=$P($G(LR0),"^",5)
. . . S ORIFN=$P($G(LR0),"^",7)
. . . S LRK=$$NOW^XLFDT()
. . . I '$$FIND1^DIC(68.04,","_LRAN_","_LRAD_","_LRAA_",","QUX",LRTST,,,"LRERR") Q ;Test not ordered or not accession. Same action either way.
. . . S LRV=$$GET1^DIQ(68.04,LRTST_","_LRAN_","_LRAD_","_LRAA_",",4,"I",,"LRERR") Q:LRV ;Already complete
. . . S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
. . . S LRSVC=$P(X,"^",9)
. . . S LRLLOC=$P(X,"^",7)
. . . S LRDFN=+X Q:'$D(^LR(LRDFN,0))
. . . S LRODT=$P(X,"^",4)
. . . S LRSN=$P(X,"^",5)
. . . ;S LRLABPOC=$$FIND1^DIC(200,,"BOX","LRLAB,POC",,,"ERR") S:'LRLABPOC LRLABPOC=".5"
. . . K DIERR,LRFDA D FDA^DILF(68.04,LRTST_","_LRAN_","_LRAD_","_LRAA_",",4,,LRK,"LRFDA")
. . . D FDA^DILF(68.04,LRTST_","_LRAN_","_LRAD_","_LRAA_",",3,,"LRLAB,POC","LRFDA")
. . . D FILE^DIE("E","LRFDA","LRERR")
. . . S Y=^LRO(68,LRAA,1,LRAD,1,LRAN,0),Y(4)=$P(Y,"^",4),Y(5)=$P(Y,"^",5)
. . . ;Y(4)=Date Ordered, Y(5)=Specimen Number
. . . I Y(4),Y(5),$D(^LRO(69,Y(4),1,Y(5),3)) K DIERR,LRFDA D FDA^DILF(69.01,Y(5)_","_Y(4)_",",21,,LRK,"LRFDA") Q:$D(DIERR) D FILE^DIE("E","LRFDA","LRERR")
. . . S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,1,0)) ^(0)="^68.14P^^"
. . . S ORDCNTRL="SC",ORDSTS="CM"
. . . D EN^ORMVBEC
. . . Q
;
Q
;
GENACK ; -- Send an acknowldegement to original message
;Q:$G(VBTEST)
S MSA1="AA"
I $D(LRERR) S MSA1="AR"
S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(LRERR):HL("FS")_LRERR,1:"")
S HLEID=HL("EID"),HLEIDS=HL("EIDS")
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.RESULT)
K MSA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OVB 4318 printed Sep 23, 2025@19:41:40 Page 2
LR7OVB ;HOIFO/BNT - Lab Receive HL7 Order Update from VBECS ;2/22/08 21:19
+1 ;;5.2;LAB SERVICE;**367**;Sep 27, 1994;Build 12
+2 ;Reference to $$FIND1^DIC supported by IA #2051
+3 ;Reference to EN^ORMVBEC supported by IA #4982
+4 ;Reference to $$HL7TFM^XLFDT supported by IA #10103
+5 ;Reference to $$NOW^XLFDT supported by IA #10103
+6 ;Reference to $$STRIP^XLFSTR supported by IA #10104
+7 ;
EN1(LRMSG) ; Entry point for LR7O VBECS RECEIVE Protocol
+1 NEW LRSEG,LRSEGID,LRERR,LRACK,ORDCNTRL,LROIEN,LRTST,LRDFN,DFN,LRI,LRJ,ORIFN,ORDSTS,ORDCNTRL
+2 SET LRQUIT=0
+3 SET LRI=0
FOR
SET LRI=$ORDER(LRMSG(LRI))
if 'LRI
QUIT
Begin DoDot:1
+4 SET LRSEG=LRMSG(LRI)
SET LRSEGID=$PIECE(LRMSG(LRI),HL("FS"))
+5 IF $TEXT(@LRSEGID)]""
DO @LRSEGID
End DoDot:1
if $DATA(LRERR)!(LRQUIT)
QUIT
+6 if $DATA(LRERR)!(LRQUIT)
QUIT
+7 ;
+8 IF 'LRACK
DO GENACK
+9 QUIT
+10 ;
ORC ; - Process ORC segment
+1 SET ORDCNTRL=$TRANSLATE($PIECE(LRSEG,HL("FS"),2),"@","P")
+2 IF '$LENGTH(ORDCNTRL)
SET LRERR="Invalid control code"
DO ERROR
QUIT
+3 SET ORDSTS=$PIECE(LRSEG,HL("FS"),6)
+4 IF ORDSTS'="CM"
DO ERROR
QUIT
+5 QUIT
+6 ;
OBR ; -- Process OBR segment
+1 SET LROIEN=$PIECE($PIECE(LRSEG,HL("FS"),14),";")
+2 SET LRTST=$$STRIP^XLFSTR($PIECE($PIECE(LRSEG,HL("FS"),14),";",4)," ")
+3 IF LRTST']""
SET LRERR="Missing Lab Test ID"
DO ERROR
QUIT
+4 IF LROIEN']""
SET LRERR="Missing Lab Test IEN"
DO ERROR
QUIT
+5 ; Complete the Lab Order
+6 DO COMPLETE(LROIEN,LRTST,LRDFN1)
+7 QUIT
+8 ;
PID ; -- Process PID segment
+1 NEW I,X,PIDLST
+2 ; Adding logic to support v2.4 Patient Id List
+3 SET PIDLST=$PIECE(LRSEG,HL("FS"),4)
+4 IF PIDLST[$EXTRACT(HL("ECH"))
Begin DoDot:1
+5 FOR I=1:1:$LENGTH(PIDLST,$EXTRACT(HL("ECH"),2))
SET X=$PIECE(PIDLST,$EXTRACT(HL("ECH"),2),I)
if X=""
QUIT
IF $PIECE(X,$EXTRACT(HL("ECH")),5)["PI"
SET LRDFN1=+X
QUIT
End DoDot:1
+6 IF PIDLST'[$EXTRACT(HL("ECH"))
SET LRDFN1=+$PIECE(LRSEG,HL("FS"),4)
+7 IF '$DATA(^DPT(LRDFN1,0))
SET LRERR="Invalid Patient Id "_LRDFN1
DO ERROR
QUIT
+8 QUIT
+9 ;
FMDATE(Y) ; -- Convert HL7 date/time to FM format
+1 ;**97
QUIT $$HL7TFM^XLFDT(Y)
+2 ;
ERROR ;
+1 SET LRQUIT=1
+2 IF 'LRACK
DO GENACK
+3 QUIT
+4 ;
COMPLETE(LROIEN,LRTST,LRDFN1) ; - Complete the accession for this test and the OERR order
+1 ; LROIEN = File 69 IEN
+2 ; LRTST = File 60 IEN
+3 ; LRDFN1 = File 2 IEN
+4 NEW LRA,LRB,LRC,LR0,LRV,LRAA,LRY,LRAD,LRAN,LRODT,LRSN
+5 SET (LRQUIT,LRW)=0
+6 IF '$DATA(LRACK)
SET LRACK=1
+7 IF '$DATA(^LRO(69,"C",LROIEN))
SET LRERR="Invalid Lab Order Number"
DO ERROR
QUIT
+8 SET LRA=0
FOR
SET LRA=$ORDER(^LRO(69,"C",LROIEN,LRA))
if 'LRA
QUIT
Begin DoDot:1
+9 SET LRB=0
FOR
SET LRB=$ORDER(^LRO(69,"C",LROIEN,LRA,LRB))
if 'LRB
QUIT
Begin DoDot:2
+10 ; Order has been merged.
+11 IF $PIECE($GET(^LRO(69,LRA,1,LRB,1)),"^",7)]""
DO ERROR
QUIT
+12 SET LRC=0
FOR
SET LRC=$ORDER(^LRO(69,LRA,1,LRB,2,LRC))
if 'LRC
QUIT
Begin DoDot:3
+13 SET LR0=^LRO(69,LRA,1,LRB,2,LRC,0)
if +LR0'=LRTST
QUIT
+14 SET LRDFN=$PIECE(^LRO(69,LRA,1,LRB,0),"^",1)
+15 IF $PIECE($GET(^LR(LRDFN,0)),"^",3)'=LRDFN1
SET LRERR="Lab Patient on order does not match patient DFN"
DO ERROR
QUIT
+16 SET LRAA=$PIECE($GET(LR0),"^",4)
+17 SET LRAD=$PIECE($GET(LR0),"^",3)
+18 SET LRAN=$PIECE($GET(LR0),"^",5)
+19 SET ORIFN=$PIECE($GET(LR0),"^",7)
+20 SET LRK=$$NOW^XLFDT()
+21 ;Test not ordered or not accession. Same action either way.
IF '$$FIND1^DIC(68.04,","_LRAN_","_LRAD_","_LRAA_",","QUX",LRTST,,,"LRERR")
QUIT
+22 ;Already complete
SET LRV=$$GET1^DIQ(68.04,LRTST_","_LRAN_","_LRAD_","_LRAA_",",4,"I",,"LRERR")
if LRV
QUIT
+23 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
+24 SET LRSVC=$PIECE(X,"^",9)
+25 SET LRLLOC=$PIECE(X,"^",7)
+26 SET LRDFN=+X
if '$DATA(^LR(LRDFN,0))
QUIT
+27 SET LRODT=$PIECE(X,"^",4)
+28 SET LRSN=$PIECE(X,"^",5)
+29 ;S LRLABPOC=$$FIND1^DIC(200,,"BOX","LRLAB,POC",,,"ERR") S:'LRLABPOC LRLABPOC=".5"
+30 KILL DIERR,LRFDA
DO FDA^DILF(68.04,LRTST_","_LRAN_","_LRAD_","_LRAA_",",4,,LRK,"LRFDA")
+31 DO FDA^DILF(68.04,LRTST_","_LRAN_","_LRAD_","_LRAA_",",3,,"LRLAB,POC","LRFDA")
+32 DO FILE^DIE("E","LRFDA","LRERR")
+33 SET Y=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET Y(4)=$PIECE(Y,"^",4)
SET Y(5)=$PIECE(Y,"^",5)
+34 ;Y(4)=Date Ordered, Y(5)=Specimen Number
+35 IF Y(4)
IF Y(5)
IF $DATA(^LRO(69,Y(4),1,Y(5),3))
KILL DIERR,LRFDA
DO FDA^DILF(69.01,Y(5)_","_Y(4)_",",21,,LRK,"LRFDA")
if $DATA(DIERR)
QUIT
DO FILE^DIE("E","LRFDA","LRERR")
+36 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,1,0))
SET ^(0)="^68.14P^^"
+37 SET ORDCNTRL="SC"
SET ORDSTS="CM"
+38 DO EN^ORMVBEC
+39 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
if LRQUIT
QUIT
+40 ;
+41 QUIT
+42 ;
GENACK ; -- Send an acknowldegement to original message
+1 ;Q:$G(VBTEST)
+2 SET MSA1="AA"
+3 IF $DATA(LRERR)
SET MSA1="AR"
+4 SET HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$SELECT($DATA(LRERR):HL("FS")_LRERR,1:"")
+5 SET HLEID=HL("EID")
SET HLEIDS=HL("EIDS")
+6 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.RESULT)
+7 KILL MSA
+8 QUIT
