source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRUDEL.m@ 1384

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

initial load of FOIAVistA 6/30/08 version
File size: 2.8 KB
Line 
1LRUDEL ;AVAMC/REG/CYM - DELETE AN AP ACCESSION NUMBER ;2/18/98 10:04 ;
2 ;;5.2;LAB SERVICE;**1,72,121,201**;Jul 03, 1997
3 D END,^LRAP G:'$D(Y) END D XR^LRU
4 W !?22,"Delete an Accession Number",!!
5D S %DT("A")="Accession number date: ",%DT="AQE" D ^%DT K %DT Q:Y<1 S (Y,LRAD)=$E(Y,1,3)_"0000" D DATE S LRH(0)=Y
6 I '$D(^LRO(68,LRAA,1,LRAD,0)) W $C(7),!!,"No accession numbers for ",LRH(0),! G D
7 S H(2)=$E(LRAD,1,3)
8N1 K LRNO
9 R !!,"Select Accession # : ",LRAN:DTIME Q:LRAN=""!(LRAN["^")
10 D REST L -^LRO(69.2,LRAA) I $D(LRDFN),$L($G(LRSS)) L -^LR(LRDFN,LRSS)
11 G N1
12REST I LRAN'?1N.N W $C(7),!!,"Enter NUMBERS only" Q
13 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W $C(7),!!,"Accession number ",LRAN," for ",LRH(0)," not in ACCESSION file",!! Q
14 L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T W !!?10,$C(7),"Someone else is editing this entry ",! Q
15 L +^LRO(69.2,LRAA):1 I '$T W !!?10,$C(7),"Someone else is editing this entry ",! Q
16 S LRND=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRRC=$P(LRND,U,3)
17 S LRDFN=+LRND G:'$D(^LR(LRDFN,0)) BAD S Y=^(0),LRPFN=$P(Y,U,2),LRFNAM=$P(^DIC(LRPFN,0),U),LRPF=^(0,"GL"),Y=$P(Y,U,3),LRP=@(LRPF_Y_",0)") W !,$P(LRP,U)," ID: ",$P(LRP,U,9) S Y=$P(LRP,U,3) D DATE W:Y'[1700 " DOB: ",Y
18 W !!,"ACC # ",LRAN S Y=LRRC D DATE G:LRSS="AU" DEL^LRAUAW
19 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) K ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN) D T W !,LRAN," Deleted" Q
20 S X=^LRO(68,LRAA,1,LRAD,1,LRAN,3),LRSD=+X,LRI=$P(X,"^",5) Q:'LRI
21 S X=$G(^LR(LRDFN,LRSS,LRI,0)) I $P(X,"^",3)!($P(X,"^",11))!($P(X,"^",15)) W $C(7),!,"Report completed &/or released, deletion not allowed." Q
22 L +^LR(LRDFN,LRSS,LRI):1 I '$T W !!?10,"Someone else is editing this entry ",!,$C(7) Q
23 W " DATE RECEIVED: ",Y," OK to DELETE " S %=2 D YN^LRU I %'=1 W $C(7),!?4,"NOT DELETED",!! Q
24 D ACC^LR7OB1(LRAA,LRAD,LRAN,"OC") ; Cancel order
25 I $D(^LR(LRDFN,LRSS,LRI)) K ^(LRI) I $D(^LR(LRDFN,LRSS,0)) S X=^LR(LRDFN,LRSS,0),X(1)=$O(^(0)),X(2)=$P(X,"^",4)-1,^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_X(2)
26 K:LRRC ^LR(LRXR,LRRC,LRDFN,LRI) K ^LR(LRXREF,H(2),LRABV,LRAN,LRDFN,LRI) D K
27 K ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN) K:LRRC ^LRO(68,LRAA,1,LRAD,1,"E",LRRC,LRAN)
28 L +^LRO(68,LRAA,1,LRAD,1,0) S X=^LRO(68,LRAA,1,LRAD,1,0),X(1)=$O(^(0)),X(2)=$P(X,"^",4)-1 S:X(2)<1 X(2)=0 S ^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_X(2) L -^LRO(68,LRAA,1,LRAD,1,0)
29 D T Q
30BAD W $C(7),!!,"Entry not in file",!!
31 Q
32T ;
33 F A=1,2,3,4 I $D(^LRO(69.2,LRAA,A,LRAN)) K ^(LRAN) S X(1)=$O(^LRO(69.2,LRAA,A,0)) S:'X(1) X(1)=0 I $D(^LRO(69.2,LRAA,A,0)) S X=^(0),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_$S(X(1)=0:X(1),1:($P(X,"^",4)-1))
34 Q
35 ;
36DATE ; Returns the date in eye-readable month format
37 S Y=$TR($$FMTE^XLFDT(Y,"M"),"@"," ")
38 Q
39K ; also from LRAPED
40 F A=0:0 S A=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,A)) Q:'A K ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_A)
41 Q
42 ;
43END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.