LRBLDELT.m

LRBLDELT ; IHS/DIR/FJE - DELETE FILE 65 ENTRIES 8/18/89 10:55 ;

 ;;5.2;LR;;NOV 01, 1997

 ;

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

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

 W !!?25,"DELETE INVENTORY FILE ENTRIES",!?28,"WITH FINAL DISPOSITIONS"

 W !!,$C(7),!!,"Has the tape of the blood inventory file (65) been made ?" S %=2 D YN^LRU G:%'=1 END

 W !!?20,"Delete units (which have final dispositions)",!?20,"received prior to:"

 S %DT="AEQM",%DT("A")="Enter Date:" D ^%DT K %DT G:Y<1 END S LR=Y D D^LRU S X1=LR,LR=Y,X2=-1 D C^%DTC S LRLDT=X

 W !!?20,"Ok to delete units with final disposition",!?20,"received prior to ",LR S %=2 D YN^LRU G:%'=1 END

 S LR=0 D WAIT^LRU W !,"."

 F LRA=0:0 S LRA=$O(^LRD(65,"A",LRA)) Q:'LRA!(LRA>LRLDT)  F LRI=0:0 S LRI=$O(^LRD(65,"A",LRA,LRI)) Q:'LRI  D K

 L +^LRD(65) S X(1)=$O(^LRD(65,0)) S:'X(1) X(1)=0 S X=^LRD(65,0),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-LR) L -^LRD(65) W $C(7),!!,"Deletion completed.",! Q

K Q:'$D(^LRD(65,LRI,4))  I $P(^(4),"^")=""&('$D(^(6))) Q

 S Y=^LRD(65,LRI,0),C=$P(Y,"^",4),R=$P(Y,"^",5),E=$P(Y,"^",6),Z=$P(Y,"^")

 W:LR#25=0 "." F W=0:0 S W=$O(^LRD(65,LRI,3,W)) Q:'W  S V=+^(W,0) K ^LRD(65,"AL",V,LRI)

 I $D(^LRD(65,LRI,8)) S LRP=+^(8) K:LRP ^LRD(65,"AU",LRP,LRI)

 F W=0:0 S W=$O(^LRD(65,LRI,2,W)) Q:'W  K ^LRD(65,"AP",W,LRI) F V=0:0 S V=$O(^LRD(65,LRI,2,W,1,V)) Q:'V  S Y=$P(^(V,0),"^",9) I Y K ^LRD(65,"AN",Y,LRI,W,V)

 I $L(Z)>2 F X(1)=3:1:4 I '$E(Z,X(1)) K ^LRD(65,"B",$E(Z,X(1),$L(Z)),LRI) Q

 S X(1)=$S($D(^LRD(65,LRI,4)):$P(^(4),"^",2),1:"") K:X(1) ^LRD(65,"AB",X(1),LRI)

 K ^LRD(65,LRI),^LRD(65,"A",R,LRI),^LRD(65,"B",Z),^LRD(65,"AT",Z),^LRD(65,"AI",C,Z),^LRD(65,"AE",C,E,LRI),^LRO(69.2,LRAA,8,65,1,LRI),^LRO(69.2,LRAA,8,65,1,"B",Z)

 S LR=LR+1 Q

 ;

END D V^LRU Q

LRBLDELT  ; IHS/DIR/FJE - DELETE FILE 65 ENTRIES 8/18/89 10:55 ;

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

 +2       ;

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

 +4        DO END

           SET X="BLOOD BANK"

           DO ^LRUTL

           IF Y=-1

               GOTO END

 +5        WRITE !!?25,"DELETE INVENTORY FILE ENTRIES",!?28,"WITH FINAL DISPOSITIONS"

 +6        WRITE !!,$CHAR(7),!!,"Has the tape of the blood inventory file (65) been made ?"

           SET %=2

           DO YN^LRU

           IF %'=1

               GOTO END

 +7        WRITE !!?20,"Delete units (which have final dispositions)",!?20,"received prior to:"

 +8        SET %DT="AEQM"

           SET %DT("A")="Enter Date:"

           DO ^%DT

           KILL %DT

           IF Y<1

               GOTO END

           SET LR=Y

           DO D^LRU

           SET X1=LR

           SET LR=Y

           SET X2=-1

           DO C^%DTC

           SET LRLDT=X

 +9        WRITE !!?20,"Ok to delete units with final disposition",!?20,"received prior to ",LR

           SET %=2

           DO YN^LRU

           IF %'=1

               GOTO END

 +10       SET LR=0

           DO WAIT^LRU

           WRITE !,"."

 +11       FOR LRA=0:0

               SET LRA=$ORDER(^LRD(65,"A",LRA))

               IF 'LRA!(LRA>LRLDT)

                   QUIT 

               FOR LRI=0:0

                   SET LRI=$ORDER(^LRD(65,"A",LRA,LRI))

                   IF 'LRI

                       QUIT 

                   DO K

 +12       LOCK +^LRD(65)

           SET X(1)=$ORDER(^LRD(65,0))

           IF 'X(1)

               SET X(1)=0

           SET X=^LRD(65,0)

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

           LOCK -^LRD(65)

           WRITE $CHAR(7),!!,"Deletion completed.",!

           QUIT 

K          IF '$DATA(^LRD(65,LRI,4))

               QUIT 

           IF $PIECE(^(4),"^")=""&('$DATA(^(6)))

               QUIT 

 +1        SET Y=^LRD(65,LRI,0)

           SET C=$PIECE(Y,"^",4)

           SET R=$PIECE(Y,"^",5)

           SET E=$PIECE(Y,"^",6)

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

 +2        IF LR#25=0

               WRITE "."

           FOR W=0:0

               SET W=$ORDER(^LRD(65,LRI,3,W))

               IF 'W

                   QUIT 

               SET V=+^(W,0)

               KILL ^LRD(65,"AL",V,LRI)

 +3        IF $DATA(^LRD(65,LRI,8))

               SET LRP=+^(8)

               IF LRP

                   KILL ^LRD(65,"AU",LRP,LRI)

 +4        FOR W=0:0

               SET W=$ORDER(^LRD(65,LRI,2,W))

               IF 'W

                   QUIT 

               KILL ^LRD(65,"AP",W,LRI)

               FOR V=0:0

                   SET V=$ORDER(^LRD(65,LRI,2,W,1,V))

                   IF 'V

                       QUIT 

                   SET Y=$PIECE(^(V,0),"^",9)

                   IF Y

                       KILL ^LRD(65,"AN",Y,LRI,W,V)

 +5        IF $LENGTH(Z)>2

               FOR X(1)=3:1:4

                   IF '$EXTRACT(Z,X(1))

                       KILL ^LRD(65,"B",$EXTRACT(Z,X(1),$LENGTH(Z)),LRI)

                       QUIT 

 +6        SET X(1)=$SELECT($DATA(^LRD(65,LRI,4)):$PIECE(^(4),"^",2),1:"")

           IF X(1)

               KILL ^LRD(65,"AB",X(1),LRI)

 +7        KILL ^LRD(65,LRI),^LRD(65,"A",R,LRI),^LRD(65,"B",Z),^LRD(65,"AT",Z),^LRD(65,"AI",C,Z),^LRD(65,"AE",C,E,LRI),^LRO(69.2,LRAA,8,65,1,LRI),^LRO(69.2,LRAA,8,65,1,"B",Z)

 +8        SET LR=LR+1

           QUIT 

 +9       ;

END        DO V^LRU

           QUIT