LR7OF3 ;slc/dcm - Process OBR messages from OE/RR ;8/11/97
;;5.2;LAB SERVICE;**121,187,223,256**;Sep 27, 1994
;
OBR ;Process OBR part of MSG array
;TEST= Ptr to test in file 60
;TESTN= Test Name
;TYPE= Collection Sample Type
;SAMP= Ptr to Collection sample in file 62
;SPEC= Ptr to Specimen in file 61
;URG= Urgency
I '$O(LRXMSG(0)) D
. S TEST=+$P($P(LRXMSG,"|",5),"^",4),TESTN=$P($P(LRXMSG,"|",5),"^",6),TYPE=$$LRACTCOD^LR7OU0($P(LRXMSG,"|",12))
. S SPEC=$S($P($P($P(LRXMSG,"|",5),"^",4),"~",2):$P($P($P(LRXMSG,"|",5),"^",4),"~",2),1:$$LRSPEC^LR7OU0($P(LRXMSG,"|",16)))
. S URG=$$LRURG^LR7OU0($P($P(LRXMSG,"|",28),"^",6)),SAMP=$$LRSAMP^LR7OU0($P(LRXMSG,"|",16))
I $O(LRXMSG(0)) D
. N I,J,X1,CTR
. F CTR=1:1:$L(LRXMSG,"|") S X1(CTR)=$P(LRXMSG,"|",CTR)
. S J=0 F S J=$O(LRXMSG(J)) Q:J<1 D
.. S I=1 I $E(LRXMSG(J))'="|" S X1(CTR)=X1(CTR)_$P(LRXMSG,"|"),I=I+1
.. F I=I:1:$L(LRXMSG(J),"|") S CTR=CTR+1,X1(CTR)=$P(LRXMSG(J),"|",I)
. S TEST=$P(X1(5),"^",4),TESTN=$P(X1(5),"^",6),TYPE=$$LRACTCOD^LR7OU0(X1(12))
. S SPEC=$S($P($P(X1(5),"^",4),"~",2):$P($P(X1(5),"^",4),"~",2),1:$$LRSPEC^LR7OU0(X1(16)))
. S URG=$$LRURG^LR7OU0($P(X1(28),"^",6)),SAMP=$$LRSAMP^LR7OU0(X1(16))
I '$L(TEST) D ACK^LR7OF0("DE",LRXORC,"TEST pointer not sent in message") S LREND=1 Q
I '$L($G(^LAB(60,+TEST,0))) D ACK^LR7OF0("DE",LRXORC,"Invalid Lab test pointer sent from CPRS: "_TEST) S LREND=1 Q
I '$L(TESTN) D ACK^LR7OF0("DE",LRXORC,"Test Name not sent in message") S LREND=1 Q
I '$L(TYPE) D ACK^LR7OF0("DE",LRXORC,"Collection type not sent in message") S LREND=1 Q
I '$L(SAMP) D ACK^LR7OF0("DE",LRXORC,"Sample pointer not sent in message") S LREND=1 Q
I '$L(SPEC) D ACK^LR7OF0("DE",LRXORC,"Specimen not set in file 62: "_SAMP) S LREND=1 Q
I '$L(URG) D ACK^LR7OF0("DE",LRXORC,"Urgency not sent in message") S LREND=1 Q
I LRXTYPE="XO" D Q ;Change order request
. D GET^LR7OF2(.LRXORC,LRXORC)
. Q:'$G(LRORD)
. N TST,FLAG
. S FLAG=0
. I 'LRVERZ F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 S LRSN=0 F S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 I $P(^LRO(69,LRODT,1,LRSN,0),"^",3)=SAMP S FLAG=1 D JAB
. I LRVERZ,$D(^LRO(69,LRODT,1,LRSN,0)),$P(^(0),"^",3)=SAMP S FLAG=1 D JAB
. I FLAG=0 D ACK^LR7OF0("XO",LRXORC,"Specimen not found") S LREND=1 Q
I LRXTYPE="NW" D ST Q ;New order request
Q
JAB ;Cancel or Add test
I TYPE=3,$D(^LRO(69,LRODT,1,LRSN,2,"B",+TEST)) D DOIT^LR7OF2(LRODT,LRSN,TEST,LRXORC,$G(LRDUZ),$G(REASON)) Q
I TYPE="A",'$D(^LRO(69,LRODT,1,LRSN,2,"B",+TEST)) D Q
. I $O(^LRO(69,LRODT,1,LRSN,2,0)),$P(^($O(^(0)),0),"^",3) S LREND=1 D ACK^LR7OF0("UX",LRXORC,"Orders have been accessioned, call lab to add tests to the same order.") Q
. S I=$O(^LRO(69,LRODT,1,LRSN,2,99999),-1)+1,^LRO(69,LRODT,1,LRSN,2,I,0)=TEST_"^"_URG,^LRO(69,LRODT,1,LRSN,2,"B",+TEST,I)=""
Q
ST S LRSX=LRSX+1
I $D(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX)) G ST
S ^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,0)=ORIFN ;_"^"_$S($P($G(^LAB(60,TEST,0)),"^",4)'="CH":1,1:0) ;Setting 2nd piece forces unique order number
S ^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX)=TEST_"^"_QUANT
S ^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,1)=URG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OF3 3212 printed Dec 13, 2024@02:04:58 Page 2
LR7OF3 ;slc/dcm - Process OBR messages from OE/RR ;8/11/97
+1 ;;5.2;LAB SERVICE;**121,187,223,256**;Sep 27, 1994
+2 ;
OBR ;Process OBR part of MSG array
+1 ;TEST= Ptr to test in file 60
+2 ;TESTN= Test Name
+3 ;TYPE= Collection Sample Type
+4 ;SAMP= Ptr to Collection sample in file 62
+5 ;SPEC= Ptr to Specimen in file 61
+6 ;URG= Urgency
+7 IF '$ORDER(LRXMSG(0))
Begin DoDot:1
+8 SET TEST=+$PIECE($PIECE(LRXMSG,"|",5),"^",4)
SET TESTN=$PIECE($PIECE(LRXMSG,"|",5),"^",6)
SET TYPE=$$LRACTCOD^LR7OU0($PIECE(LRXMSG,"|",12))
+9 SET SPEC=$SELECT($PIECE($PIECE($PIECE(LRXMSG,"|",5),"^",4),"~",2):$PIECE($PIECE($PIECE(LRXMSG,"|",5),"^",4),"~",2),1:$$LRSPEC^LR7OU0($PIECE(LRXMSG,"|",16)))
+10 SET URG=$$LRURG^LR7OU0($PIECE($PIECE(LRXMSG,"|",28),"^",6))
SET SAMP=$$LRSAMP^LR7OU0($PIECE(LRXMSG,"|",16))
End DoDot:1
+11 IF $ORDER(LRXMSG(0))
Begin DoDot:1
+12 NEW I,J,X1,CTR
+13 FOR CTR=1:1:$LENGTH(LRXMSG,"|")
SET X1(CTR)=$PIECE(LRXMSG,"|",CTR)
+14 SET J=0
FOR
SET J=$ORDER(LRXMSG(J))
if J<1
QUIT
Begin DoDot:2
+15 SET I=1
IF $EXTRACT(LRXMSG(J))'="|"
SET X1(CTR)=X1(CTR)_$PIECE(LRXMSG,"|")
SET I=I+1
+16 FOR I=I:1:$LENGTH(LRXMSG(J),"|")
SET CTR=CTR+1
SET X1(CTR)=$PIECE(LRXMSG(J),"|",I)
End DoDot:2
+17 SET TEST=$PIECE(X1(5),"^",4)
SET TESTN=$PIECE(X1(5),"^",6)
SET TYPE=$$LRACTCOD^LR7OU0(X1(12))
+18 SET SPEC=$SELECT($PIECE($PIECE(X1(5),"^",4),"~",2):$PIECE($PIECE(X1(5),"^",4),"~",2),1:$$LRSPEC^LR7OU0(X1(16)))
+19 SET URG=$$LRURG^LR7OU0($PIECE(X1(28),"^",6))
SET SAMP=$$LRSAMP^LR7OU0(X1(16))
End DoDot:1
+20 IF '$LENGTH(TEST)
DO ACK^LR7OF0("DE",LRXORC,"TEST pointer not sent in message")
SET LREND=1
QUIT
+21 IF '$LENGTH($GET(^LAB(60,+TEST,0)))
DO ACK^LR7OF0("DE",LRXORC,"Invalid Lab test pointer sent from CPRS: "_TEST)
SET LREND=1
QUIT
+22 IF '$LENGTH(TESTN)
DO ACK^LR7OF0("DE",LRXORC,"Test Name not sent in message")
SET LREND=1
QUIT
+23 IF '$LENGTH(TYPE)
DO ACK^LR7OF0("DE",LRXORC,"Collection type not sent in message")
SET LREND=1
QUIT
+24 IF '$LENGTH(SAMP)
DO ACK^LR7OF0("DE",LRXORC,"Sample pointer not sent in message")
SET LREND=1
QUIT
+25 IF '$LENGTH(SPEC)
DO ACK^LR7OF0("DE",LRXORC,"Specimen not set in file 62: "_SAMP)
SET LREND=1
QUIT
+26 IF '$LENGTH(URG)
DO ACK^LR7OF0("DE",LRXORC,"Urgency not sent in message")
SET LREND=1
QUIT
+27 ;Change order request
IF LRXTYPE="XO"
Begin DoDot:1
+28 DO GET^LR7OF2(.LRXORC,LRXORC)
+29 if '$GET(LRORD)
QUIT
+30 NEW TST,FLAG
+31 SET FLAG=0
+32 IF 'LRVERZ
FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
if LRODT<1
QUIT
SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSN))
if LRSN<1
QUIT
IF $PIECE(^LRO(69,LRODT,1,LRSN,0),"^",3)=SAMP
SET FLAG=1
DO JAB
+33 IF LRVERZ
IF $DATA(^LRO(69,LRODT,1,LRSN,0))
IF $PIECE(^(0),"^",3)=SAMP
SET FLAG=1
DO JAB
+34 IF FLAG=0
DO ACK^LR7OF0("XO",LRXORC,"Specimen not found")
SET LREND=1
QUIT
End DoDot:1
QUIT
+35 ;New order request
IF LRXTYPE="NW"
DO ST
QUIT
+36 QUIT
JAB ;Cancel or Add test
+1 IF TYPE=3
IF $DATA(^LRO(69,LRODT,1,LRSN,2,"B",+TEST))
DO DOIT^LR7OF2(LRODT,LRSN,TEST,LRXORC,$GET(LRDUZ),$GET(REASON))
QUIT
+2 IF TYPE="A"
IF '$DATA(^LRO(69,LRODT,1,LRSN,2,"B",+TEST))
Begin DoDot:1
+3 IF $ORDER(^LRO(69,LRODT,1,LRSN,2,0))
IF $PIECE(^($ORDER(^(0)),0),"^",3)
SET LREND=1
DO ACK^LR7OF0("UX",LRXORC,"Orders have been accessioned, call lab to add tests to the same order.")
QUIT
+4 SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,99999),-1)+1
SET ^LRO(69,LRODT,1,LRSN,2,I,0)=TEST_"^"_URG
SET ^LRO(69,LRODT,1,LRSN,2,"B",+TEST,I)=""
End DoDot:1
QUIT
+5 QUIT
ST SET LRSX=LRSX+1
+1 IF $DATA(^TMP("OR",$JOB,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX))
GOTO ST
+2 ;_"^"_$S($P($G(^LAB(60,TEST,0)),"^",4)'="CH":1,1:0) ;Setting 2nd piece forces unique order number
SET ^TMP("OR",$JOB,"LROT",STARTDT,TYPE,SAMP,SPEC,0)=ORIFN
+3 SET ^TMP("OR",$JOB,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX)=TEST_"^"_QUANT
+4 SET ^TMP("OR",$JOB,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,1)=URG
+5 QUIT
