- 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