LR7OF0 ;slc/dcm/JAH - Receive/Route MSG array from OE/RR ;07/14/16 19:59
;;5.2;LAB SERVICE;**121,187,223,230,256,291,462**;Sep 27, 1994;Build 44
;
;This routine invokes IA #2187
;
EN(MSG,MSGTYPE) ;Route all messages from here
;MSG=HL7 message array
;MSGTYPE=LRCH for chem (default), LRAP for AP
N X,VISIT,LOC,LOCP,ROOM,DFN,LRPNM,LRXMSG,TEST,TESTN,TYPE,SAMP,SPEC,URG,ORIFN,STARTDT,LRDUZ,PROV,REASON,LRSX,LRLLOC,LROLLOC,LRPRAC,LROUTINE,LRSDT,LRXZ,LRODT,LRSAMP,LRSPEC,LRORDR,LRLB,LRNT,LRSX,LROT,LRCOM,LRI,LRIO,LRJ,LRORD,QUANT
N LOCA,LINE,LRHDR,LRORDER,LRORIFN,LRSN,LRSUM,LRSXN,LRTIME,LRTSTS,LRURG,LRSDT,LREND,LRXTYPE,LRXORC,LRDFN,LRDPF,LRPLACR,LRQUANT,LRVERZ,NOBR,NORC
S (NOBR,NORC)=1 ;flag to check for OBR, ORC segments
D END
S LRI=2,LRXORC="ORC"
F S LRI=$O(MSG(LRI)) Q:LRI<1 S X=MSG(LRI) I $P(MSG(LRI),"|")="ORC" S LRXORC=MSG(LRI),NORC=0 Q
S LRHDR=$$HDRCHK($G(MSG(1)))
Q:'$L(LRHDR)
I '$$PIDCHK($G(MSG(2))) Q
I LRHDR="BHS" K ^TMP("OR",$J,"LRES") Q ;Initialization to begin batch
I LRHDR="BTS" D Q ;Clean-up to end batch
. D LC
. K ^TMP("OR",$J,"LRES")
S LINE=2,LRSX=0,LREND=0 F S LINE=$O(MSG(LINE)) Q:LINE<1 S LRXMSG=MSG(LINE) D:$O(MSG(LINE,0)) SPLIT D I LREND Q
. I $P(LRXMSG,"|")="PV1" S VISIT=$P(LRXMSG,"|",19),LOC=$P($P(LRXMSG,"|",4),"^"),ROOM=$P($P(LRXMSG,"|",4),"^",2),LOCP=LOC,LOCA=$S(LOCP:$P(^SC(LOCP,0),"^",2),1:"") Q
. I $P(LRXMSG,"|")="ORC" S NORC=0,LRXTYPE=$P(LRXMSG,"|",2),LRXORC=LRXMSG I LRXTYPE="NW" D NEW^LR7OF2 Q ;New order, from OE/RR
. I $P(LRXMSG,"|")="ORC",LRXTYPE="CA" Q ; D CANC^LR7OF2 S LREND=1 Q ;Cancel order, from OE/RR
. I $P(LRXMSG,"|")="OBR" S NOBR=0 I LRXTYPE="CA" D CANC^LR7OF2 Q ;Cancel tests identified in OBR segment
. I $P(LRXMSG,"|")="ORC",LRXTYPE="Z@" D PURG1^LR7OF4 S LREND=1 Q ;Purge request-weird
. I $P(LRXMSG,"|")="OBR",LRXTYPE="Z@" D PURG^LR7OF4 S LREND=1 Q ;Purge request
. I $P(LRXMSG,"|")="ORC",LRXTYPE="XO" D XO^LR7OF2 Q ;Change order
. I $P(LRXMSG,"|")="ORC",LRXTYPE="NA" D NUM^LR7OF2 Q ;Backdoor new order, request order number
. I $P(LRXMSG,"|")="ORC" S X="Unrecognized order control: "_LRXTYPE D ACK("DE",LRXORC,X) Q
. I $P(LRXMSG,"|")="OBR",LRXTYPE="NA" D NA^LR7OF2 Q ;Backdoor assign ORIFN to test
. I $P(LRXMSG,"|")="OBR",LRXTYPE="NW" D OBR^LR7OF3 Q
. I $P(LRXMSG,"|")="OBR",LRXTYPE="XO" D OBR^LR7OF3 Q
. I $P(LRXMSG,"|")="DG1" D DG1^LRBEBA2(LRXMSG) Q ; CIDC
. I $P(LRXMSG,"|")="ZCL" D ZCL^LRBEBA2(LRXMSG) Q ; CIDC
. I $P(LRXMSG,"|")="NTE" D NTE^LR7OF2 Q ;Order comments
. ;;*
. ;
. I $P(LRXMSG,"|")="AP1" S VAL=MSG(LINE) D AP1^LR7OAPKM(.MSG,VAL) Q ;Call to get CPRS AP Order data
. ;;;*
. D ACK("DE",LRXORC,"Unrecognized Message segment: "_$P(LRXMSG,"|")) Q
I LREND S LREND=0 D END Q
I NORC D ACK("OC",LRXORC,"Incomplete transaction...no ORC segment in message!") D END Q
I NOBR D ACK("OC",LRXORC,"Incomplete transaction...no OBR segment in message") D END Q
I LRXTYPE="NW" D ;Process new order request
. N REJECT
. S LROLLOC=LOCP,LRLLOC=$S($L($G(LOCA)):LOCA,1:"UNKNOWN"),LRPRAC=PROV,LROUTINE=$P(^LAB(69.9,1,3),"^",2)
. I $D(^TMP("OR",$J,"LROT")) S LRSDT=0 D
.. F S LRSDT=$O(^TMP("OR",$J,"LROT",LRSDT)) Q:LRSDT<1 S LRXZ="" F LRI=0:0 S LRXZ=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ)) Q:LRXZ="" S LRODT=$P(LRSDT,".") D
... I $G(MSGTYPE)="LRAP" D EN^LR7OFA1 Q
... D EN^LR7OF1
. D END,ACK("OK","ORC|OK|"_LRPLACR_"|"_LRORD_";"_LRODT_";"_LRSN_"^"_$S($G(MSG)="BBMSG":"LRBB",$G(MSG)="APMSG":"LRAP",1:"LRCH"),"")
Q
HDRCHK(HDR) ;Check & return message Header (BHS,MSH,BTS)
I '$L(HDR) D ACK("DE",LRXORC,"No Message Header Defined") Q ""
I $P(HDR,"|")="BTS" Q "BTS"
I $P(HDR,"|")'="BHS",$P(HDR,"|")'="MSH" D ACK("DE",LRXORC,"Invalid Message Header: "_$P(HDR,"|")) Q ""
I $P(HDR,"|",2)'="^~\&" D ACK("DE",LRXORC,"Invalid Encoding Characters: "_$P(HDR,"|",2)) Q ""
I $P(HDR,"|",3)'="ORDER ENTRY" D ACK("DE",LRXORC,"Unrecognized message source: "_$P(HDR,"|",3)) Q ""
I $P(HDR,"|",4)'=DUZ(2) D ACK("DE",LRXORC,"DUZ(2) doesn't match institution in message: "_DUZ(2)_"'="_$P(HDR,"|",4)) Q ""
I $P(HDR,"|")="MSH",$P(HDR,"|",9)'="ORM"&($P(HDR,"|",9)'="ORR") D ACK("DE",LRXORC,"Unrecognized Message type: "_$P(HDR,"|",9)) Q ""
Q $P(HDR,"|")
;
PIDCHK(PID) ;Check PID & setup patient variables (DFN,LRDPF,LRDFN,LRPNM)
I '$L(PID) D ACK("DE",LRXORC,"No Patient ID in message") Q 0
I $P(PID,"|")'="PID" D ACK("DE",LRXORC,"Invalid (PID) message header: "_$P(X,"|")) Q 0
I '$L($P(PID,"|",6)) D ACK("DE",LRXORC,"No Patient Name") Q 0
S DFN=$S($P(PID,"|",4):$P(PID,"|",4),1:+$P(PID,"|",5)),LRDPF=$S($P(PID,"|",4):"2^DPT(",1:$P(@("^"_$P($P(PID,"|",5),";",2)_"0)"),"^",2)_"^"_$P($P(PID,"|",5),";",2)),LRPNM=$P(PID,"|",6),LRDFN=$$LRDFN^LR7OR1(+DFN,$P(LRDPF,"^",2))
I 'LRDFN D END^LRDPA I LRDFN<1 D ACK("DE",LRXORC,"Invalid LRDFN") Q 0
I '$D(@("^"_$P(LRDPF,"^",2)_+DFN_",0)")) D ACK("DE",LRXORC,"Patient identifier: "_LRDFN_" not found in "_LRDPF_" file") Q 0
Q 1
;
LC ;Print to LC Lab device
N LRSDT,LRXZ,CTR,LRODT,LRSN,LRPTR
S LRSDT=0
F S LRSDT=$O(^TMP("OR",$J,"LRES",LRDFN,LRSDT)) Q:'LRSDT S LRXZ="" F S LRXZ=$O(^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ)) Q:LRXZ="" D
. S CTR=0 F S CTR=$O(^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ,CTR)) Q:'CTR S X=^(CTR) D
.. S LRPTR(LRXZ,$P(X,"^",2),$P(X,"^",3))=""
S LRODT=0 F S LRODT=$O(LRPTR("LC",LRODT)) Q:'LRODT S LRSN=0 F S LRSN=$O(LRPTR("LC",LRODT,LRSN)) Q:'LRSN D
. S ION=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2) S:ION="" ION=$P(^LAB(69.9,1,3),U,4) I ION]"" D ^LROW2P
S LRODT=0 F S LRODT=$O(LRPTR("I",LRODT)) Q:'LRODT S LRSN=0 F S LRSN=$O(LRPTR("I",LRODT,LRSN)) Q:'LRSN D
. S ION=$P($G(^LAB(69.9,1,7,DUZ(2),0)),U,3) I ION]"" D ^LROW2P
Q
ACK(TYPE,MSG3,COMMENT) ;Send back ok or nok to OE/RR
;TYPE=Message control
;COMMENT=Comment to be passed back
;MSG3=contents of MSG(3) containing the ORC segment
N LRMSG,ARRAY,X8,VAR
I TYPE="DE" S VAR("XQY0")="" D EN^ORERR("BAD msg xchng OE/RR->LAB:"_$G(COMMENT),.MSG,.VAR) S:$P($G(MSG3),"|",2)="NW" TYPE="OC" ;Trap problem message and send back to OE/RR as an OC type
S LRMSG(1)=$$MSH^LR7OU0("ORR")
S LRMSG(2)=$G(MSG(2))
S LRMSG(3)=$G(MSG3),$P(LRMSG(3),"|",2)=TYPE
I $O(REJECT(0)),$O(^ORD(100.03,"C","LRDUP",0)) S X8=$$DC1^LROR6($O(^(0)),"Already ordered for this specimen, type and time"),$P(LRMSG(3),"|",2)="OC",$P(LRMSG(3),"|",4)="",$P(LRMSG(3),"|",17)=X8
I $D(COMMENT) N MSG S MSG="LRMSG",ARRAY(1)=COMMENT D NTE^LR7OU01(1,"L","ARRAY(",4)
S LRMSG="LRMSG"
D MSG^XQOR("LR7O CH EVSEND OR",.LRMSG) ;Lab accepts, returns Order #
Q
SPLIT ;Build array for long segment
N I
S I=0 F S I=$O(MSG(LINE,I)) Q:I<1 S LRXMSG(I)=MSG(LINE,I)
Q
END ;Clean-up and get out
K ^TMP("OR",$J,"LROT"),^("COM")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OF0 6724 printed Apr 09, 2024@21:14:18 Page 2
LR7OF0 ;slc/dcm/JAH - Receive/Route MSG array from OE/RR ;07/14/16 19:59
+1 ;;5.2;LAB SERVICE;**121,187,223,230,256,291,462**;Sep 27, 1994;Build 44
+2 ;
+3 ;This routine invokes IA #2187
+4 ;
EN(MSG,MSGTYPE) ;Route all messages from here
+1 ;MSG=HL7 message array
+2 ;MSGTYPE=LRCH for chem (default), LRAP for AP
+3 NEW X,VISIT,LOC,LOCP,ROOM,DFN,LRPNM,LRXMSG,TEST,TESTN,TYPE,SAMP,SPEC,URG,ORIFN,STARTDT,LRDUZ,PROV,REASON,LRSX,LRLLOC,LROLLOC,LRPRAC,LROUTINE,LRSDT,LRXZ,LRODT,LRSAMP,LRSPEC,LRORDR,LRLB,LRNT,LRSX,LROT,LRCOM,LRI,LRIO,LRJ,LRORD,QUANT
+4 NEW LOCA,LINE,LRHDR,LRORDER,LRORIFN,LRSN,LRSUM,LRSXN,LRTIME,LRTSTS,LRURG,LRSDT,LREND,LRXTYPE,LRXORC,LRDFN,LRDPF,LRPLACR,LRQUANT,LRVERZ,NOBR,NORC
+5 ;flag to check for OBR, ORC segments
SET (NOBR,NORC)=1
+6 DO END
+7 SET LRI=2
SET LRXORC="ORC"
+8 FOR
SET LRI=$ORDER(MSG(LRI))
if LRI<1
QUIT
SET X=MSG(LRI)
IF $PIECE(MSG(LRI),"|")="ORC"
SET LRXORC=MSG(LRI)
SET NORC=0
QUIT
+9 SET LRHDR=$$HDRCHK($GET(MSG(1)))
+10 if '$LENGTH(LRHDR)
QUIT
+11 IF '$$PIDCHK($GET(MSG(2)))
QUIT
+12 ;Initialization to begin batch
IF LRHDR="BHS"
KILL ^TMP("OR",$JOB,"LRES")
QUIT
+13 ;Clean-up to end batch
IF LRHDR="BTS"
Begin DoDot:1
+14 DO LC
+15 KILL ^TMP("OR",$JOB,"LRES")
End DoDot:1
QUIT
+16 SET LINE=2
SET LRSX=0
SET LREND=0
FOR
SET LINE=$ORDER(MSG(LINE))
if LINE<1
QUIT
SET LRXMSG=MSG(LINE)
if $ORDER(MSG(LINE,0))
DO SPLIT
Begin DoDot:1
+17 IF $PIECE(LRXMSG,"|")="PV1"
SET VISIT=$PIECE(LRXMSG,"|",19)
SET LOC=$PIECE($PIECE(LRXMSG,"|",4),"^")
SET ROOM=$PIECE($PIECE(LRXMSG,"|",4),"^",2)
SET LOCP=LOC
SET LOCA=$SELECT(LOCP:$PIECE(^SC(LOCP,0),"^",2),1:"")
QUIT
+18 ;New order, from OE/RR
IF $PIECE(LRXMSG,"|")="ORC"
SET NORC=0
SET LRXTYPE=$PIECE(LRXMSG,"|",2)
SET LRXORC=LRXMSG
IF LRXTYPE="NW"
DO NEW^LR7OF2
QUIT
+19 ; D CANC^LR7OF2 S LREND=1 Q ;Cancel order, from OE/RR
IF $PIECE(LRXMSG,"|")="ORC"
IF LRXTYPE="CA"
QUIT
+20 ;Cancel tests identified in OBR segment
IF $PIECE(LRXMSG,"|")="OBR"
SET NOBR=0
IF LRXTYPE="CA"
DO CANC^LR7OF2
QUIT
+21 ;Purge request-weird
IF $PIECE(LRXMSG,"|")="ORC"
IF LRXTYPE="Z@"
DO PURG1^LR7OF4
SET LREND=1
QUIT
+22 ;Purge request
IF $PIECE(LRXMSG,"|")="OBR"
IF LRXTYPE="Z@"
DO PURG^LR7OF4
SET LREND=1
QUIT
+23 ;Change order
IF $PIECE(LRXMSG,"|")="ORC"
IF LRXTYPE="XO"
DO XO^LR7OF2
QUIT
+24 ;Backdoor new order, request order number
IF $PIECE(LRXMSG,"|")="ORC"
IF LRXTYPE="NA"
DO NUM^LR7OF2
QUIT
+25 IF $PIECE(LRXMSG,"|")="ORC"
SET X="Unrecognized order control: "_LRXTYPE
DO ACK("DE",LRXORC,X)
QUIT
+26 ;Backdoor assign ORIFN to test
IF $PIECE(LRXMSG,"|")="OBR"
IF LRXTYPE="NA"
DO NA^LR7OF2
QUIT
+27 IF $PIECE(LRXMSG,"|")="OBR"
IF LRXTYPE="NW"
DO OBR^LR7OF3
QUIT
+28 IF $PIECE(LRXMSG,"|")="OBR"
IF LRXTYPE="XO"
DO OBR^LR7OF3
QUIT
+29 ; CIDC
IF $PIECE(LRXMSG,"|")="DG1"
DO DG1^LRBEBA2(LRXMSG)
QUIT
+30 ; CIDC
IF $PIECE(LRXMSG,"|")="ZCL"
DO ZCL^LRBEBA2(LRXMSG)
QUIT
+31 ;Order comments
IF $PIECE(LRXMSG,"|")="NTE"
DO NTE^LR7OF2
QUIT
+32 ;;*
+33 ;
+34 ;Call to get CPRS AP Order data
IF $PIECE(LRXMSG,"|")="AP1"
SET VAL=MSG(LINE)
DO AP1^LR7OAPKM(.MSG,VAL)
QUIT
+35 ;;;*
+36 DO ACK("DE",LRXORC,"Unrecognized Message segment: "_$PIECE(LRXMSG,"|"))
QUIT
End DoDot:1
IF LREND
QUIT
+37 IF LREND
SET LREND=0
DO END
QUIT
+38 IF NORC
DO ACK("OC",LRXORC,"Incomplete transaction...no ORC segment in message!")
DO END
QUIT
+39 IF NOBR
DO ACK("OC",LRXORC,"Incomplete transaction...no OBR segment in message")
DO END
QUIT
+40 ;Process new order request
IF LRXTYPE="NW"
Begin DoDot:1
+41 NEW REJECT
+42 SET LROLLOC=LOCP
SET LRLLOC=$SELECT($LENGTH($GET(LOCA)):LOCA,1:"UNKNOWN")
SET LRPRAC=PROV
SET LROUTINE=$PIECE(^LAB(69.9,1,3),"^",2)
+43 IF $DATA(^TMP("OR",$JOB,"LROT"))
SET LRSDT=0
Begin DoDot:2
+44 FOR
SET LRSDT=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT))
if LRSDT<1
QUIT
SET LRXZ=""
FOR LRI=0:0
SET LRXZ=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ))
if LRXZ=""
QUIT
SET LRODT=$PIECE(LRSDT,".")
Begin DoDot:3
+45 IF $GET(MSGTYPE)="LRAP"
DO EN^LR7OFA1
QUIT
+46 DO EN^LR7OF1
End DoDot:3
End DoDot:2
+47 DO END
DO ACK("OK","ORC|OK|"_LRPLACR_"|"_LRORD_";"_LRODT_";"_LRSN_"^"_$SELECT($GET(MSG)="BBMSG":"LRBB",$GET(MSG)="APMSG":"LRAP",1:"LRCH"),"")
End DoDot:1
+48 QUIT
HDRCHK(HDR) ;Check & return message Header (BHS,MSH,BTS)
+1 IF '$LENGTH(HDR)
DO ACK("DE",LRXORC,"No Message Header Defined")
QUIT ""
+2 IF $PIECE(HDR,"|")="BTS"
QUIT "BTS"
+3 IF $PIECE(HDR,"|")'="BHS"
IF $PIECE(HDR,"|")'="MSH"
DO ACK("DE",LRXORC,"Invalid Message Header: "_$PIECE(HDR,"|"))
QUIT ""
+4 IF $PIECE(HDR,"|",2)'="^~\&"
DO ACK("DE",LRXORC,"Invalid Encoding Characters: "_$PIECE(HDR,"|",2))
QUIT ""
+5 IF $PIECE(HDR,"|",3)'="ORDER ENTRY"
DO ACK("DE",LRXORC,"Unrecognized message source: "_$PIECE(HDR,"|",3))
QUIT ""
+6 IF $PIECE(HDR,"|",4)'=DUZ(2)
DO ACK("DE",LRXORC,"DUZ(2) doesn't match institution in message: "_DUZ(2)_"'="_$PIECE(HDR,"|",4))
QUIT ""
+7 IF $PIECE(HDR,"|")="MSH"
IF $PIECE(HDR,"|",9)'="ORM"&($PIECE(HDR,"|",9)'="ORR")
DO ACK("DE",LRXORC,"Unrecognized Message type: "_$PIECE(HDR,"|",9))
QUIT ""
+8 QUIT $PIECE(HDR,"|")
+9 ;
PIDCHK(PID) ;Check PID & setup patient variables (DFN,LRDPF,LRDFN,LRPNM)
+1 IF '$LENGTH(PID)
DO ACK("DE",LRXORC,"No Patient ID in message")
QUIT 0
+2 IF $PIECE(PID,"|")'="PID"
DO ACK("DE",LRXORC,"Invalid (PID) message header: "_$PIECE(X,"|"))
QUIT 0
+3 IF '$LENGTH($PIECE(PID,"|",6))
DO ACK("DE",LRXORC,"No Patient Name")
QUIT 0
+4 SET DFN=$SELECT($PIECE(PID,"|",4):$PIECE(PID,"|",4),1:+$PIECE(PID,"|",5))
SET LRDPF=$SELECT($PIECE(PID,"|",4):"2^DPT(",1:$PIECE(@("^"_$PIECE($PIECE(PID,"|",5),";",2)_"0)"),"^",2)_"^"_$PIECE($PIECE(PID,"|",5),";",2))
SET LRPNM=$PIECE(PID,"|",6)
SET LRDFN=$$LRDFN^LR7OR1(+DFN,$PIECE(LRDPF,"^",2))
+5 IF 'LRDFN
DO END^LRDPA
IF LRDFN<1
DO ACK("DE",LRXORC,"Invalid LRDFN")
QUIT 0
+6 IF '$DATA(@("^"_$PIECE(LRDPF,"^",2)_+DFN_",0)"))
DO ACK("DE",LRXORC,"Patient identifier: "_LRDFN_" not found in "_LRDPF_" file")
QUIT 0
+7 QUIT 1
+8 ;
LC ;Print to LC Lab device
+1 NEW LRSDT,LRXZ,CTR,LRODT,LRSN,LRPTR
+2 SET LRSDT=0
+3 FOR
SET LRSDT=$ORDER(^TMP("OR",$JOB,"LRES",LRDFN,LRSDT))
if 'LRSDT
QUIT
SET LRXZ=""
FOR
SET LRXZ=$ORDER(^TMP("OR",$JOB,"LRES",LRDFN,LRSDT,LRXZ))
if LRXZ=""
QUIT
Begin DoDot:1
+4 SET CTR=0
FOR
SET CTR=$ORDER(^TMP("OR",$JOB,"LRES",LRDFN,LRSDT,LRXZ,CTR))
if 'CTR
QUIT
SET X=^(CTR)
Begin DoDot:2
+5 SET LRPTR(LRXZ,$PIECE(X,"^",2),$PIECE(X,"^",3))=""
End DoDot:2
End DoDot:1
+6 SET LRODT=0
FOR
SET LRODT=$ORDER(LRPTR("LC",LRODT))
if 'LRODT
QUIT
SET LRSN=0
FOR
SET LRSN=$ORDER(LRPTR("LC",LRODT,LRSN))
if 'LRSN
QUIT
Begin DoDot:1
+7 SET ION=$PIECE($GET(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2)
if ION=""
SET ION=$PIECE(^LAB(69.9,1,3),U,4)
IF ION]""
DO ^LROW2P
End DoDot:1
+8 SET LRODT=0
FOR
SET LRODT=$ORDER(LRPTR("I",LRODT))
if 'LRODT
QUIT
SET LRSN=0
FOR
SET LRSN=$ORDER(LRPTR("I",LRODT,LRSN))
if 'LRSN
QUIT
Begin DoDot:1
+9 SET ION=$PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,3)
IF ION]""
DO ^LROW2P
End DoDot:1
+10 QUIT
ACK(TYPE,MSG3,COMMENT) ;Send back ok or nok to OE/RR
+1 ;TYPE=Message control
+2 ;COMMENT=Comment to be passed back
+3 ;MSG3=contents of MSG(3) containing the ORC segment
+4 NEW LRMSG,ARRAY,X8,VAR
+5 ;Trap problem message and send back to OE/RR as an OC type
IF TYPE="DE"
SET VAR("XQY0")=""
DO EN^ORERR("BAD msg xchng OE/RR->LAB:"_$GET(COMMENT),.MSG,.VAR)
if $PIECE($GET(MSG3),"|",2)="NW"
SET TYPE="OC"
+6 SET LRMSG(1)=$$MSH^LR7OU0("ORR")
+7 SET LRMSG(2)=$GET(MSG(2))
+8 SET LRMSG(3)=$GET(MSG3)
SET $PIECE(LRMSG(3),"|",2)=TYPE
+9 IF $ORDER(REJECT(0))
IF $ORDER(^ORD(100.03,"C","LRDUP",0))
SET X8=$$DC1^LROR6($ORDER(^(0)),"Already ordered for this specimen, type and time")
SET $PIECE(LRMSG(3),"|",2)="OC"
SET $PIECE(LRMSG(3),"|",4)=""
SET $PIECE(LRMSG(3),"|",17)=X8
+10 IF $DATA(COMMENT)
NEW MSG
SET MSG="LRMSG"
SET ARRAY(1)=COMMENT
DO NTE^LR7OU01(1,"L","ARRAY(",4)
+11 SET LRMSG="LRMSG"
+12 ;Lab accepts, returns Order #
DO MSG^XQOR("LR7O CH EVSEND OR",.LRMSG)
+13 QUIT
SPLIT ;Build array for long segment
+1 NEW I
+2 SET I=0
FOR
SET I=$ORDER(MSG(LINE,I))
if I<1
QUIT
SET LRXMSG(I)=MSG(LINE,I)
+3 QUIT
END ;Clean-up and get out
+1 KILL ^TMP("OR",$JOB,"LROT"),^("COM")
+2 QUIT
