- 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
