LRUDEL ; IHS/DIR/AAB - DELETE AN AP ACCESSION NUMBER 2/18/98 10:04 ; [ 07/22/2002 1:54 PM ]
;;5.2;LR;**1006,1013**;JUL 15, 2002
;
;;5.2;LAB SERVICE;**1,72,121,201**;Jul 03, 1997
D END,^LRAP G:'$D(Y) END D XR^LRU
W !?22,"Delete an Accession Number",!!
D 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
I '$D(^LRO(68,LRAA,1,LRAD,0)) W $C(7),!!,"No accession numbers for ",LRH(0),! G D
S H(2)=$E(LRAD,1,3)
N1 K LRNO
R !!,"Select Accession # : ",LRAN:DTIME Q:LRAN=""!(LRAN["^")
D REST L -^LRO(69.2,LRAA) I $D(LRDFN),$L($G(LRSS)) L -^LR(LRDFN,LRSS)
G N1
REST I LRAN'?1N.N W $C(7),!!,"Enter NUMBERS only" Q
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W $C(7),!!,"Accession number ",LRAN," for ",LRH(0)," not in ACCESSION file",!! Q
L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T W !!?10,$C(7),"Someone else is editing this entry ",! Q
L +^LRO(69.2,LRAA):1 I '$T W !!?10,$C(7),"Someone else is editing this entry ",! Q
S LRND=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRRC=$P(LRND,U,3)
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
W !!,"ACC # ",LRAN S Y=LRRC D DATE G:LRSS="AU" DEL^LRAUAW
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
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,3),LRSD=+X,LRI=$P(X,"^",5) Q:'LRI
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
L +^LR(LRDFN,LRSS,LRI):1 I '$T W !!?10,"Someone else is editing this entry ",!,$C(7) Q
W " DATE RECEIVED: ",Y," OK to DELETE " S %=2 D YN^LRU I %'=1 W $C(7),!?4,"NOT DELETED",!! Q
D ACC^LR7OB1(LRAA,LRAD,LRAN,"OC") ; Cancel order
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)
K:LRRC ^LR(LRXR,LRRC,LRDFN,LRI) K ^LR(LRXREF,H(2),LRABV,LRAN,LRDFN,LRI) D K
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)
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)
D T Q
BAD W $C(7),!!,"Entry not in file",!!
Q
T ;
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))
Q
;
DATE ; Returns the date in eye-readable month format
S Y=$TR($$FMTE^XLFDT(Y,"M"),"@"," ")
Q
K ; also from LRAPED
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)
Q
;
END D V^LRU Q
LRUDEL ; IHS/DIR/AAB - DELETE AN AP ACCESSION NUMBER 2/18/98 10:04 ; [ 07/22/2002 1:54 PM ]
+1 ;;5.2;LR;**1006,1013**;JUL 15, 2002
+2 ;
+3 ;;5.2;LAB SERVICE;**1,72,121,201**;Jul 03, 1997
+4 DO END
DO ^LRAP
IF '$DATA(Y)
GOTO END
DO XR^LRU
+5 WRITE !?22,"Delete an Accession Number",!!
D SET %DT("A")="Accession number date: "
SET %DT="AQE"
DO ^%DT
KILL %DT
IF Y<1
QUIT
SET (Y,LRAD)=$EXTRACT(Y,1,3)_"0000"
DO DATE
SET LRH(0)=Y
+1 IF '$DATA(^LRO(68,LRAA,1,LRAD,0))
WRITE $CHAR(7),!!,"No accession numbers for ",LRH(0),!
GOTO D
+2 SET H(2)=$EXTRACT(LRAD,1,3)
N1 KILL LRNO
+1 READ !!,"Select Accession # : ",LRAN:DTIME
IF LRAN=""!(LRAN["^")
QUIT
+2 DO REST
LOCK -^LRO(69.2,LRAA)
IF $DATA(LRDFN)
IF $LENGTH($GET(LRSS))
LOCK -^LR(LRDFN,LRSS)
+3 GOTO N1
REST IF LRAN'?1N.N
WRITE $CHAR(7),!!,"Enter NUMBERS only"
QUIT
+1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE $CHAR(7),!!,"Accession number ",LRAN," for ",LRH(0)," not in ACCESSION file",!!
QUIT
+2 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):1
IF '$TEST
WRITE !!?10,$CHAR(7),"Someone else is editing this entry ",!
QUIT
+3 LOCK +^LRO(69.2,LRAA):1
IF '$TEST
WRITE !!?10,$CHAR(7),"Someone else is editing this entry ",!
QUIT
+4 SET LRND=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRRC=$PIECE(LRND,U,3)
+5 SET LRDFN=+LRND
IF '$DATA(^LR(LRDFN,0))
GOTO BAD
SET Y=^(0)
SET LRPFN=$PIECE(Y,U,2)
SET LRFNAM=$PIECE(^DIC(LRPFN,0),U)
SET LRPF=^(0,"GL")
SET Y=$PIECE(Y,U,3)
SET LRP=@(LRPF_Y_",0)")
WRITE !,$PIECE(LRP,U)," ID: ",$PIECE(LRP,U,9)
SET Y=$PIECE(LRP,U,3)
DO DATE
IF Y'[1700
WRITE " DOB: ",Y
+6 WRITE !!,"ACC # ",LRAN
SET Y=LRRC
DO DATE
IF LRSS="AU"
GOTO DEL^LRAUAW
+7 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
KILL ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN)
DO T
WRITE !,LRAN," Deleted"
QUIT
+8 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,3)
SET LRSD=+X
SET LRI=$PIECE(X,"^",5)
IF 'LRI
QUIT
+9 SET X=$GET(^LR(LRDFN,LRSS,LRI,0))
IF $PIECE(X,"^",3)!($PIECE(X,"^",11))!($PIECE(X,"^",15))
WRITE $CHAR(7),!,"Report completed &/or released, deletion not allowed."
QUIT
+10 LOCK +^LR(LRDFN,LRSS,LRI):1
IF '$TEST
WRITE !!?10,"Someone else is editing this entry ",!,$CHAR(7)
QUIT
+11 WRITE " DATE RECEIVED: ",Y," OK to DELETE "
SET %=2
DO YN^LRU
IF %'=1
WRITE $CHAR(7),!?4,"NOT DELETED",!!
QUIT
+12 ; Cancel order
DO ACC^LR7OB1(LRAA,LRAD,LRAN,"OC")
+13 IF $DATA(^LR(LRDFN,LRSS,LRI))
KILL ^(LRI)
IF $DATA(^LR(LRDFN,LRSS,0))
SET X=^LR(LRDFN,LRSS,0)
SET X(1)=$ORDER(^(0))
SET X(2)=$PIECE(X,"^",4)-1
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_X(2)
+14 IF LRRC
KILL ^LR(LRXR,LRRC,LRDFN,LRI)
KILL ^LR(LRXREF,H(2),LRABV,LRAN,LRDFN,LRI)
DO K
+15 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN)
IF LRRC
KILL ^LRO(68,LRAA,1,LRAD,1,"E",LRRC,LRAN)
+16 LOCK +^LRO(68,LRAA,1,LRAD,1,0)
SET X=^LRO(68,LRAA,1,LRAD,1,0)
SET X(1)=$ORDER(^(0))
SET X(2)=$PIECE(X,"^",4)-1
IF X(2)<1
SET X(2)=0
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_X(2)
LOCK -^LRO(68,LRAA,1,LRAD,1,0)
+17 DO T
QUIT
BAD WRITE $CHAR(7),!!,"Entry not in file",!!
+1 QUIT
T ;
+1 FOR A=1,2,3,4
IF $DATA(^LRO(69.2,LRAA,A,LRAN))
KILL ^(LRAN)
SET X(1)=$ORDER(^LRO(69.2,LRAA,A,0))
IF 'X(1)
SET X(1)=0
IF $DATA(^LRO(69.2,LRAA,A,0))
SET X=^(0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_$SELECT(X(1)=0:X(1),1:($PIECE(X,"^",4)-1))
+2 QUIT
+3 ;
DATE ; Returns the date in eye-readable month format
+1 SET Y=$TRANSLATE($$FMTE^XLFDT(Y,"M"),"@"," ")
+2 QUIT
K ; also from LRAPED
+1 FOR A=0:0
SET A=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,A))
IF 'A
QUIT
KILL ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_A)
+2 QUIT
+3 ;
END DO V^LRU
QUIT
