- LRBLDEL ;AVAMC/REG - DELETE FILE 65 ENTRIES ;8/14/90 14:36 ;
- ;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- Q D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
- W !!?25,"DELETE INVENTORY FILE ENTRIES",!?28,"WITH FINAL DISPOSITIONS"
- I '$D(^LRO(69.2,LRAA,8,65,1)) W !!?26,$C(7),"NO DELETION LIST",!,"USE Print units with final disposition OPTION under supervisor OPTIONS" G END:'$D(^XUSEC("LRLIASON",DUZ)),A
- S X=^LRO(69.2,LRAA,8,65,0),LR=0
- W !!?15,"Units received from: ",$P(X,U,2)," to ",$P(X,U,3),!?15,"with final dispositions will be deleted. OK " S %=2 D YN^LRU G:%'=1 END
- D WAIT^LRU W !,"."
- S X=0 F LRA=1:1 S X=$O(^LRO(69.2,LRAA,8,65,1,X)) Q:'X I $D(^LRD(65,X,0)) S Y=^(0),C=$P(Y,"^",4),R=$P(Y,"^",5),E=$P(Y,"^",6),Z=$P(Y,"^") D K
- OUT 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) K ^LRO(69.2,LRAA,8,65,1) W $C(7),!!,"Deletion completed.",! G END
- K W:LRA#25=0 "." F W=0:0 S W=$O(^LRD(65,X,3,W)) Q:'W S V=+^(W,0) K ^LRD(65,"AL",V,X)
- F W=0:0 S W=$O(^LRD(65,X,15,W)) Q:'W S V=$P(^(W,0),"^",8) K:V ^LRD(65,"A",V,X)
- I $D(^LRD(65,X,8)) S LRP=+^(8) K:LRP ^LRD(65,"AU",LRP,X)
- F W=0:0 S W=$O(^LRD(65,X,2,W)) Q:'W K ^LRD(65,"AP",W,X) F V=0:0 S V=$O(^LRD(65,X,2,W,1,V)) Q:'V S Y=$P(^(V,0),"^",9) I Y K ^LRD(65,"AN",Y,X,W,V)
- S DA=X D K^LRBLU
- S X(1)=$S($D(^LRD(65,X,4)):$P(^(4),"^",2),1:"") K:X(1) ^LRD(65,"AB",X(1),X)
- K ^LRD(65,X),^LRD(65,"A",R,X),^LRD(65,"B",Z),^LRD(65,"AT",Z),^LRD(65,"AI",C,Z),^LRD(65,"AE",C,E,X),^LRO(69.2,LRAA,8,65,1,X),^LRO(69.2,LRAA,8,65,1,"B",Z)
- S LR=LR+1 Q
- A G:$P($T(LRBLDEL+1),"~",2)<5.3 END
- W !!,"To delete units without a deletion list:",!,"Did you make a backup tape of the BLOOD INVENTORY file " S %=2 D YN^LRU G:%'=1 END
- W !,"Did you check the backup tape " S %=2 D YN^LRU G:%'=1 END W !!?19,"Ok to delete units with final disposition",!?19,"from one date received to another " S %=2 D YN^LRU G:%'=1 END W !
- D B G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.0001,LR=0 D WAIT^LRU
- F A=1:1 S LRSDT=$O(^LRD(65,"A",LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) F X=0:0 S X=$O(^LRD(65,"A",LRSDT,X)) Q:'X I $D(^LRD(65,X,4)),$P(^(4),"^")]"",$D(^(0)) S Y=^(0),C=$P(Y,"^",4),R=$P(Y,"^",5),E=$P(Y,"^",6),Z=$P(Y,"^") D:R=LRSDT K
- G OUT
- ;
- B S %DT="AEX",%DT(0)="-N",%DT("A")="Start with Date: " D ^%DT K %DT
- Q:Y<1 S LRSDT=Y
- S %DT="AEX",%DT("A")="Go to Date " D ^%DT K %DT
- Q:Y<1 S LRLDT=Y I LRSDT>LRLDT S X=LRSDT,LRSDT=LRLDT,LRLDT=X
- S Y=LRSDT D D^LRU S LRSTR=Y,Y=LRLDT D D^LRU S LRLST=Y Q
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDEL 2629 printed Apr 23, 2025@18:24:28 Page 2
- LRBLDEL ;AVAMC/REG - DELETE FILE 65 ENTRIES ;8/14/90 14:36 ;
- +1 ;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 QUIT
- 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 IF '$DATA(^LRO(69.2,LRAA,8,65,1))
- WRITE !!?26,$CHAR(7),"NO DELETION LIST",!,"USE Print units with final disposition OPTION under supervisor OPTIONS"
- if '$DATA(^XUSEC("LRLIASON",DUZ))
- GOTO END
- GOTO A
- +6 SET X=^LRO(69.2,LRAA,8,65,0)
- SET LR=0
- +7 WRITE !!?15,"Units received from: ",$PIECE(X,U,2)," to ",$PIECE(X,U,3),!?15,"with final dispositions will be deleted. OK "
- SET %=2
- DO YN^LRU
- if %'=1
- GOTO END
- +8 DO WAIT^LRU
- WRITE !,"."
- +9 SET X=0
- FOR LRA=1:1
- SET X=$ORDER(^LRO(69.2,LRAA,8,65,1,X))
- if 'X
- QUIT
- IF $DATA(^LRD(65,X,0))
- SET Y=^(0)
- SET C=$PIECE(Y,"^",4)
- SET R=$PIECE(Y,"^",5)
- SET E=$PIECE(Y,"^",6)
- SET Z=$PIECE(Y,"^")
- DO K
- OUT 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)
- KILL ^LRO(69.2,LRAA,8,65,1)
- WRITE $CHAR(7),!!,"Deletion completed.",!
- GOTO END
- K if LRA#25=0
- WRITE "."
- FOR W=0:0
- SET W=$ORDER(^LRD(65,X,3,W))
- if 'W
- QUIT
- SET V=+^(W,0)
- KILL ^LRD(65,"AL",V,X)
- +1 FOR W=0:0
- SET W=$ORDER(^LRD(65,X,15,W))
- if 'W
- QUIT
- SET V=$PIECE(^(W,0),"^",8)
- if V
- KILL ^LRD(65,"A",V,X)
- +2 IF $DATA(^LRD(65,X,8))
- SET LRP=+^(8)
- if LRP
- KILL ^LRD(65,"AU",LRP,X)
- +3 FOR W=0:0
- SET W=$ORDER(^LRD(65,X,2,W))
- if 'W
- QUIT
- KILL ^LRD(65,"AP",W,X)
- FOR V=0:0
- SET V=$ORDER(^LRD(65,X,2,W,1,V))
- if 'V
- QUIT
- SET Y=$PIECE(^(V,0),"^",9)
- IF Y
- KILL ^LRD(65,"AN",Y,X,W,V)
- +4 SET DA=X
- DO K^LRBLU
- +5 SET X(1)=$SELECT($DATA(^LRD(65,X,4)):$PIECE(^(4),"^",2),1:"")
- if X(1)
- KILL ^LRD(65,"AB",X(1),X)
- +6 KILL ^LRD(65,X),^LRD(65,"A",R,X),^LRD(65,"B",Z),^LRD(65,"AT",Z),^LRD(65,"AI",C,Z),^LRD(65,"AE",C,E,X),^LRO(69.2,LRAA,8,65,1,X),^LRO(69.2,LRAA,8,65,1,"B",Z)
- +7 SET LR=LR+1
- QUIT
- A if $PIECE($TEXT(LRBLDEL+1),"~",2)<5.3
- GOTO END
- +1 WRITE !!,"To delete units without a deletion list:",!,"Did you make a backup tape of the BLOOD INVENTORY file "
- SET %=2
- DO YN^LRU
- if %'=1
- GOTO END
- +2 WRITE !,"Did you check the backup tape "
- SET %=2
- DO YN^LRU
- if %'=1
- GOTO END
- WRITE !!?19,"Ok to delete units with final disposition",!?19,"from one date received to another "
- SET %=2
- DO YN^LRU
- if %'=1
- GOTO END
- WRITE !
- +3 DO B
- if Y<0
- GOTO END
- SET LRLDT=LRLDT+.99
- SET LRSDT=LRSDT-.0001
- SET LR=0
- DO WAIT^LRU
- +4 FOR A=1:1
- SET LRSDT=$ORDER(^LRD(65,"A",LRSDT))
- if 'LRSDT!(LRSDT>LRLDT)
- QUIT
- FOR X=0:0
- SET X=$ORDER(^LRD(65,"A",LRSDT,X))
- if 'X
- QUIT
- IF $DATA(^LRD(65,X,4))
- IF $PIECE(^(4),"^")]""
- IF $DATA(^(0))
- SET Y=^(0)
- SET C=$PIECE(Y,"^",4)
- SET R=$PIECE(Y,"^",5)
- SET E=$PIECE(Y,"^",6)
- SET Z=$PIECE(Y,"^")
- if R=LRSDT
- DO K
- +5 GOTO OUT
- +6 ;
- B SET %DT="AEX"
- SET %DT(0)="-N"
- SET %DT("A")="Start with Date: "
- DO ^%DT
- KILL %DT
- +1 if Y<1
- QUIT
- SET LRSDT=Y
- +2 SET %DT="AEX"
- SET %DT("A")="Go to Date "
- DO ^%DT
- KILL %DT
- +3 if Y<1
- QUIT
- SET LRLDT=Y
- IF LRSDT>LRLDT
- SET X=LRSDT
- SET LRSDT=LRLDT
- SET LRLDT=X
- +4 SET Y=LRSDT
- DO D^LRU
- SET LRSTR=Y
- SET Y=LRLDT
- DO D^LRU
- SET LRLST=Y
- QUIT
- END DO V^LRU
- QUIT
