- 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 Jan 18, 2025@03:05:39 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