LRBLDK.m

LRBLDK ; IHS/DIR/FJE - DELETE EX-DONORS (65.5 ENTRIES) 11/12/88 13:19 ;

 ;;5.2;LR;;NOV 01, 1997

 ;

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 D V^LRU S X="BLOOD BANK" D ^LRUTL G:Y=-1 END

 W !!?15,"DONORS WHO HAVE NOT DONATED SINCE A SPECIFIED DATE",!

 I '$D(^LRO(69.2,LRAA,8,65.5,1)) W !!?32,$C(7),"NO DELETION LIST",!!?14,"To obtain a list of donors to delete first print them",!,"using the Print ex-donors OPTION under supervisor OPTIONS" G END

 S X=^LRO(69.2,LRAA,8,65.5,0),LR=$P(^(1,0),U,4)

 W !!?20,"DONORS NOT DONATING SINCE ",$P(X,U,2),!?20,"will be deleted. OK " S %=2 D YN^LRU G:%'=1 END

 D WAIT^LRU W !,"."

 S X=0 F A=1:1 S X=$O(^LRO(69.2,LRAA,8,65.5,1,X)) Q:'X  I $D(^LRE(X,0)) S Y=^(0),Z=$P(Y,"^"),Z(1)=$E(Y,1)_$E($P(Y,"^",3),4,7),S=$P(Y,"^",13) D K

 L +^LRE(0) S X=^LRE(0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-LR) L -^LRE(0) G END

K W:A#25=0 "." F W=0:0 S W=$O(^LRE(X,5,W)) Q:'W  S W(1)=^(W,0),V=+W(1) K ^LRE("AD",$P(V,".",1),X) S W(4)=$P(W(1),"^",4) I W(4)]"" K ^LRE("C",W(4),X,W),^LRE("AT",W(4)) K:$L(W(4))>2 ^LRE("C",$E(W(4),3,12),X,W)

 I S]"" K ^LRE("G",S,X) S S=$E(Z)_$E(S,6,10) K ^LRE("G4",S,X)

 K ^LRE("D",Z(1),X),^LRE("B",Z,X),^LRE(X) Q

 ;

END D V^LRU Q

LRBLDK    ; IHS/DIR/FJE - DELETE EX-DONORS (65.5 ENTRIES) 11/12/88 13:19 ;

 +1       ;;5.2;LR;;NOV 01, 1997

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4        DO V^LRU

           SET X="BLOOD BANK"

           DO ^LRUTL

           IF Y=-1

               GOTO END

 +5        WRITE !!?15,"DONORS WHO HAVE NOT DONATED SINCE A SPECIFIED DATE",!

 +6        IF '$DATA(^LRO(69.2,LRAA,8,65.5,1))

               WRITE !!?32,$CHAR(7),"NO DELETION LIST",!!?14,"To obtain a list of donors to delete first print them",!,"using the Print ex-donors OPTION under supervisor OPTIONS"

               GOTO END

 +7        SET X=^LRO(69.2,LRAA,8,65.5,0)

           SET LR=$PIECE(^(1,0),U,4)

 +8        WRITE !!?20,"DONORS NOT DONATING SINCE ",$PIECE(X,U,2),!?20,"will be deleted. OK "

           SET %=2

           DO YN^LRU

           IF %'=1

               GOTO END

 +9        DO WAIT^LRU

           WRITE !,"."

 +10       SET X=0

           FOR A=1:1

               SET X=$ORDER(^LRO(69.2,LRAA,8,65.5,1,X))

               IF 'X

                   QUIT 

               IF $DATA(^LRE(X,0))

                   SET Y=^(0)

                   SET Z=$PIECE(Y,"^")

                   SET Z(1)=$EXTRACT(Y,1)_$EXTRACT($PIECE(Y,"^",3),4,7)

                   SET S=$PIECE(Y,"^",13)

                   DO K

 +11       LOCK +^LRE(0)

           SET X=^LRE(0)

           SET X(1)=$ORDER(^(0))

           SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-LR)

           LOCK -^LRE(0)

           GOTO END

K          IF A#25=0

               WRITE "."

           FOR W=0:0

               SET W=$ORDER(^LRE(X,5,W))

               IF 'W

                   QUIT 

               SET W(1)=^(W,0)

               SET V=+W(1)

               KILL ^LRE("AD",$PIECE(V,".",1),X)

               SET W(4)=$PIECE(W(1),"^",4)

               IF W(4)]""

                   KILL ^LRE("C",W(4),X,W),^LRE("AT",W(4))

                   IF $LENGTH(W(4))>2

                       KILL ^LRE("C",$EXTRACT(W(4),3,12),X,W)

 +1        IF S]""

               KILL ^LRE("G",S,X)

               SET S=$EXTRACT(Z)_$EXTRACT(S,6,10)

               KILL ^LRE("G4",S,X)

 +2        KILL ^LRE("D",Z(1),X),^LRE("B",Z,X),^LRE(X)

           QUIT 

 +3       ;

END        DO V^LRU

           QUIT