LR7OF4 ;slc/dcm - Process messages from OE/RR ;8/11/97
;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
PURG ;Process Purge request for OBR Segment
N TST,X,LRODT,LRSN,LRORD,LRORIFN,STARTDT,LRDUZ,PROV,REASON,QUANT,LREND
S LREND=0
D GET^LR7OF2(.LRXORC,LRXORC) Q:LREND
I 'LRVERZ S LRODT=0 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 D Q
. S X=$P($P(LRXMSG,"|",5),"^",4) I X S TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",X,0)) I TST D P1(LRODT,LRSN,TST) Q:LREND
I LRVERZ,$D(^LRO(69,LRODT,1,LRSN,0)) S X=$P($P(LRXMSG,"|",5),"^",4) I X S TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",X,0)) I TST D P1(LRODT,LRSN,TST) Q:LREND
I LREND D ACK^LR7OF0("ZU",LRXORC) Q
D ACK^LR7OF0("ZR",LRXORC)
Q
P1(LRODT,LRSN,TST) ;Check to purge
N X
I '$D(^LRO(69,LRODT,1,LRSN,0)) Q
S X=+^LRO(69,LRODT,1,LRSN,0) I $D(^LR(X,0)),$P(X,"^",2)'=2 G P2
I '$D(^LRO(69,LRODT,1,LRSN,1)) S LREND=1 Q
I $D(^LRO(69,LRODT,1,LRSN,3)),'$L($P(^(3),"^",2)) S LREND=1 Q
P2 S:$D(^LRO(69,LRODT,1,LRSN,2,TST,0)) $P(^(0),"^",7)="P" ;P=flag for purged
Q
PURG1 ;Process Purge request for ORC Segment
N X,I,STOP S X=$P(LRXORC,"|",4),STOP=0
S I=LINE F S I=$O(MSG(I)) Q:I<1 I $P(MSG(I),"|")="OBR" S STOP=1 Q
Q:STOP
I $L(X,"^")>5 D ACK^LR7OF0("ZR",LRXORC) Q ;Old unreleased 2.5 order
I +X#1 D ACK^LR7OF0("ZR",LRXORC) Q ;Old ORGY 2.5
I +X,$P(X,"^",2),$P(X,"^",3) D ACK^LR7OF0("ZR",LRXORC) Q ;Old unconverted 2.5
I +X,$P(X,"^",2)="LRCH" D PURG Q ;3.0 order with no tests (early tuscaloosa days)
I 'X D ACK^LR7OF0("ZR",LRXORC) Q ;Order with no lab pointers
D ACK^LR7OF0("DE",LRXORC,"Unrecognized ID's :"_$P(LRXORC,"|",4))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OF4 1672 printed Dec 13, 2024@02:04:59 Page 2
LR7OF4 ;slc/dcm - Process messages from OE/RR ;8/11/97
+1 ;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
PURG ;Process Purge request for OBR Segment
+1 NEW TST,X,LRODT,LRSN,LRORD,LRORIFN,STARTDT,LRDUZ,PROV,REASON,QUANT,LREND
+2 SET LREND=0
+3 DO GET^LR7OF2(.LRXORC,LRXORC)
if LREND
QUIT
+4 IF 'LRVERZ
SET LRODT=0
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
Begin DoDot:1
+5 SET X=$PIECE($PIECE(LRXMSG,"|",5),"^",4)
IF X
SET TST=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",X,0))
IF TST
DO P1(LRODT,LRSN,TST)
if LREND
QUIT
End DoDot:1
QUIT
+6 IF LRVERZ
IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET X=$PIECE($PIECE(LRXMSG,"|",5),"^",4)
IF X
SET TST=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",X,0))
IF TST
DO P1(LRODT,LRSN,TST)
if LREND
QUIT
+7 IF LREND
DO ACK^LR7OF0("ZU",LRXORC)
QUIT
+8 DO ACK^LR7OF0("ZR",LRXORC)
+9 QUIT
P1(LRODT,LRSN,TST) ;Check to purge
+1 NEW X
+2 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+3 SET X=+^LRO(69,LRODT,1,LRSN,0)
IF $DATA(^LR(X,0))
IF $PIECE(X,"^",2)'=2
GOTO P2
+4 IF '$DATA(^LRO(69,LRODT,1,LRSN,1))
SET LREND=1
QUIT
+5 IF $DATA(^LRO(69,LRODT,1,LRSN,3))
IF '$LENGTH($PIECE(^(3),"^",2))
SET LREND=1
QUIT
P2 ;P=flag for purged
if $DATA(^LRO(69,LRODT,1,LRSN,2,TST,0))
SET $PIECE(^(0),"^",7)="P"
+1 QUIT
PURG1 ;Process Purge request for ORC Segment
+1 NEW X,I,STOP
SET X=$PIECE(LRXORC,"|",4)
SET STOP=0
+2 SET I=LINE
FOR
SET I=$ORDER(MSG(I))
if I<1
QUIT
IF $PIECE(MSG(I),"|")="OBR"
SET STOP=1
QUIT
+3 if STOP
QUIT
+4 ;Old unreleased 2.5 order
IF $LENGTH(X,"^")>5
DO ACK^LR7OF0("ZR",LRXORC)
QUIT
+5 ;Old ORGY 2.5
IF +X#1
DO ACK^LR7OF0("ZR",LRXORC)
QUIT
+6 ;Old unconverted 2.5
IF +X
IF $PIECE(X,"^",2)
IF $PIECE(X,"^",3)
DO ACK^LR7OF0("ZR",LRXORC)
QUIT
+7 ;3.0 order with no tests (early tuscaloosa days)
IF +X
IF $PIECE(X,"^",2)="LRCH"
DO PURG
QUIT
+8 ;Order with no lab pointers
IF 'X
DO ACK^LR7OF0("ZR",LRXORC)
QUIT
+9 DO ACK^LR7OF0("DE",LRXORC,"Unrecognized ID's :"_$PIECE(LRXORC,"|",4))
+10 QUIT
