LRBLDELT ;AVAMC/REG - DELETE FILE 65 ENTRIES ;8/18/89 10:55 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDELT 1824 printed Dec 13, 2024@02:10:31 Page 2
LRBLDELT ;AVAMC/REG - DELETE FILE 65 ENTRIES ;8/18/89 10:55 ;
+1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 DO END
SET X="BLOOD BANK"
DO ^LRUTL
if Y=-1
GOTO END
+4 WRITE !!?25,"DELETE INVENTORY FILE ENTRIES",!?28,"WITH FINAL DISPOSITIONS"
+5 WRITE !!,$CHAR(7),!!,"Has the tape of the blood inventory file (65) been made ?"
SET %=2
DO YN^LRU
if %'=1
GOTO END
+6 WRITE !!?20,"Delete units (which have final dispositions)",!?20,"received prior to:"
+7 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
+8 WRITE !!?20,"Ok to delete units with final disposition",!?20,"received prior to ",LR
SET %=2
DO YN^LRU
if %'=1
GOTO END
+9 SET LR=0
DO WAIT^LRU
WRITE !,"."
+10 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
+11 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
