LR7OF4.m

LR7OF4 ;slc/dcm - Process messages from OE/RR ;8/11/97

 ;;5.2T9;LR;**1018**;Nov 17, 2004

 ;;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

LR7OF4    ;slc/dcm - Process messages from OE/RR ;8/11/97

 +1       ;;5.2T9;LR;**1018**;Nov 17, 2004

 +2       ;;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