- 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