- 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 Mar 13, 2025@21:10:21 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
