source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLDK.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.2 KB
Line 
1LRBLDK ;AVAMC/REG - DELETE EX-DONORS (65.5 ENTRIES) ; 11/12/88 13:19 ;
2 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 D V^LRU S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
5 W !!?15,"DONORS WHO HAVE NOT DONATED SINCE A SPECIFIED DATE",!
6 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
7 S X=^LRO(69.2,LRAA,8,65.5,0),LR=$P(^(1,0),U,4)
8 W !!?20,"DONORS NOT DONATING SINCE ",$P(X,U,2),!?20,"will be deleted. OK " S %=2 D YN^LRU G:%'=1 END
9 D WAIT^LRU W !,"."
10 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
11 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
12K 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)
13 I S]"" K ^LRE("G",S,X) S S=$E(Z)_$E(S,6,10) K ^LRE("G4",S,X)
14 K ^LRE("D",Z(1),X),^LRE("B",Z,X),^LRE(X) Q
15 ;
16END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.