LRUDEL ;DALOI/REG,CYM,PMK - DELETE AN AP ACCESSION NUMBER ;10/05/16 12:52
;;5.2;LAB SERVICE;**1,72,121,201,350,427,433,450,462**;Sep 27, 1994;Build 44
;
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 $G(LRDFN),$G(LRSS)'="" L -^LR(LRDFN,LRSS)
G N1
;
;
REST ;
;
N LRDIV
;
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):DILOCKTM
I '$T W !!?10,$C(7),"Someone else is editing this entry ",! Q
;
L +^LRO(69.2,LRAA):DILOCKTM
I '$T W !!?10,$C(7),"Someone else is editing this entry ",! Q
;
S LRND=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRDFN=+LRND
S LRDIV=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.4)),U,1)
I '$D(^LR(LRDFN,0)) D BAD Q
;
S Y=^LR(LRDFN,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
;
I LRSS="AU" D Q
. S LRRC=$P($G(^LR(LRDFN,"AU")),U)
. S Y=$$GET1^DIQ(63,LRDFN_",",12) ;Date of Death
. D DEL^LRAUAW
;
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) D
. S LRI=$O(^LR(LRXREF,H(2),LRABV,LRAN,LRDFN,0))
. I LRI S LRSD=$P($G(^LR(LRDFN,LRSS,LRI,0)),U,1)
;
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) D
. S X=^LRO(68,LRAA,1,LRAD,1,LRAN,3)
. S LRSD=+X
. S LRI=$P(X,"^",5)
. I 'LRI S LRI=$O(^LR(LRXREF,H(2),LRABV,LRAN,LRDFN,0))
;
I '$G(LRI) D Q ;No data in #63 for this accession; only delete from #68
. W " OK to DELETE "
. S %=2 D YN^LRU
. I %'=1 W $C(7),!?4,"NOT DELETED",!! Q
. K ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",LRDIV,LRAD,LRAN)
. D T
. W !,LRAN," Deleted"
;
S X=$G(^LR(LRDFN,LRSS,LRI,0))
S LRRC=$P(X,U,10)
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):DILOCKTM
I '$T W !!?10,"Someone else is editing this entry ",!,$C(7) Q
;
S Y=LRRC
D DATE
W " DATE RECEIVED: ",Y," OK to DELETE "
S %=2 D YN^LRU
I %'=1 W $C(7),!?4,"NOT DELETED",!! Q
;
D DEL69AN
;
D ACC^LR7OB1(LRAA,LRAD,LRAN,"OC") ; Cancel order
;
I $D(^LR(LRDFN,LRSS,LRI)) D
. ;
. I $T(CANCEL^MAGT7MA)'="" D CANCEL^MAGT7MA ; invoke Imaging HL7 routine - P433
. ;
. K ^LR(LRDFN,LRSS,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",LRDIV,LRAD,LRAN)
K:LRRC ^LRO(68,LRAA,1,LRAD,1,"E",LRRC,LRAN)
;
L +^LRO(68,LRAA,1,LRAD,1,0):DILOCKTM
I $T D
. 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 ;
N A
F A=1,2,3,4 I $D(^LRO(69.2,LRAA,A,LRAN)) D
. K ^LRO(69.2,LRAA,A,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
N A
S A=0
F S A=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,A)) Q:'A K ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_A)
Q
;
;
DEL69AN ; Delete accession number out of file #69's reference
N LRODT,LRSN,LRI,DR,DIE,DA
S LRODT=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4)
S LRSN=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",5)
;
L +^LRO(69,LRODT,1,LRSN,2):DILOCKTM
I '$T W !!?10,$C(7),"Someone else is editing this entry ",! Q
;;*
CPRSUP ;CPRS status update to Discontinued
D
. N LRORIFN,LRNATURE,LRT,LRTX,LRX
. S LRX=0
. F S LRX=$O(^LRO(69,LRODT,1,LRSN,2,LRX)) Q:LRX<1 S LRT=+$G(^(LRX,0)) D
. . S LRTX(LRT)=""
. S LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
. S LRORIFN=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,11)
. D NEW^LR7OB1(LRODT,LRSN,"OC",LRNATURE,.LRTX,1)
;;;*
S DR="3///@;2///@;4///@;13///@;8///CA;9///L;10////^S X=DUZ"
S DIE="^LRO(69,"_LRODT_",1,"_LRSN_",2,",LRI=0
F S LRI=$O(^LRO(69,LRODT,1,LRSN,2,LRI)) Q:'LRI D
.Q:'$D(^LRO(69,LRODT,1,LRSN,2,LRI,0))
.Q:$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",5)'=LRAN
.Q:$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",4)'=LRAA
.Q:$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",3)'=LRAD
.S DA=LRI,DA(1)=LRSN,DA(2)=LRODT
.D ^DIE
L -^LRO(69,LRODT,1,LRSN,2)
Q
;
;
END D V^LRU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUDEL 4956 printed Apr 09, 2024@21:12:50 Page 2
LRUDEL ;DALOI/REG,CYM,PMK - DELETE AN AP ACCESSION NUMBER ;10/05/16 12:52
+1 ;;5.2;LAB SERVICE;**1,72,121,201,350,427,433,450,462**;Sep 27, 1994;Build 44
+2 ;
+3 DO END
DO ^LRAP
if '$DATA(Y)
GOTO END
DO XR^LRU
+4 WRITE !?22,"Delete an Accession Number",!!
+5 ;
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 ;
+2 IF '$DATA(^LRO(68,LRAA,1,LRAD,0))
WRITE $CHAR(7),!!,"No accession numbers for ",LRH(0),!
GOTO D
+3 SET H(2)=$EXTRACT(LRAD,1,3)
N1 KILL LRNO
+1 READ !!,"Select Accession # : ",LRAN:DTIME
if LRAN=""!(LRAN["^")
QUIT
+2 DO REST
+3 LOCK -^LRO(69.2,LRAA)
+4 IF $GET(LRDFN)
IF $GET(LRSS)'=""
LOCK -^LR(LRDFN,LRSS)
+5 GOTO N1
+6 ;
+7 ;
REST ;
+1 ;
+2 NEW LRDIV
+3 ;
+4 IF LRAN'?1N.N
WRITE $CHAR(7),!!,"Enter NUMBERS only"
QUIT
+5 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE $CHAR(7),!!,"Accession number ",LRAN," for ",LRH(0)," not in ACCESSION file",!!
QUIT
+6 ;
+7 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):DILOCKTM
+8 IF '$TEST
WRITE !!?10,$CHAR(7),"Someone else is editing this entry ",!
QUIT
+9 ;
+10 LOCK +^LRO(69.2,LRAA):DILOCKTM
+11 IF '$TEST
WRITE !!?10,$CHAR(7),"Someone else is editing this entry ",!
QUIT
+12 ;
+13 SET LRND=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRDFN=+LRND
+14 SET LRDIV=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.4)),U,1)
+15 IF '$DATA(^LR(LRDFN,0))
DO BAD
QUIT
+16 ;
+17 SET Y=^LR(LRDFN,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)")
+18 WRITE !,$PIECE(LRP,U)," ID: ",$PIECE(LRP,U,9)
SET Y=$PIECE(LRP,U,3)
DO DATE
if Y'[1700
WRITE " DOB: ",Y
+19 WRITE !!,"ACC # ",LRAN
+20 ;
+21 IF LRSS="AU"
Begin DoDot:1
+22 SET LRRC=$PIECE($GET(^LR(LRDFN,"AU")),U)
+23 ;Date of Death
SET Y=$$GET1^DIQ(63,LRDFN_",",12)
+24 DO DEL^LRAUAW
End DoDot:1
QUIT
+25 ;
+26 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
Begin DoDot:1
+27 SET LRI=$ORDER(^LR(LRXREF,H(2),LRABV,LRAN,LRDFN,0))
+28 IF LRI
SET LRSD=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,1)
End DoDot:1
+29 ;
+30 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
Begin DoDot:1
+31 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,3)
+32 SET LRSD=+X
+33 SET LRI=$PIECE(X,"^",5)
+34 IF 'LRI
SET LRI=$ORDER(^LR(LRXREF,H(2),LRABV,LRAN,LRDFN,0))
End DoDot:1
+35 ;
+36 ;No data in #63 for this accession; only delete from #68
IF '$GET(LRI)
Begin DoDot:1
+37 WRITE " OK to DELETE "
+38 SET %=2
DO YN^LRU
+39 IF %'=1
WRITE $CHAR(7),!?4,"NOT DELETED",!!
QUIT
+40 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",LRDIV,LRAD,LRAN)
+41 DO T
+42 WRITE !,LRAN," Deleted"
End DoDot:1
QUIT
+43 ;
+44 SET X=$GET(^LR(LRDFN,LRSS,LRI,0))
+45 SET LRRC=$PIECE(X,U,10)
+46 IF $PIECE(X,"^",3)!($PIECE(X,"^",11))!($PIECE(X,"^",15))
WRITE $CHAR(7),!,"Report completed &/or released, deletion not allowed."
QUIT
+47 ;
+48 LOCK +^LR(LRDFN,LRSS,LRI):DILOCKTM
+49 IF '$TEST
WRITE !!?10,"Someone else is editing this entry ",!,$CHAR(7)
QUIT
+50 ;
+51 SET Y=LRRC
+52 DO DATE
+53 WRITE " DATE RECEIVED: ",Y," OK to DELETE "
+54 SET %=2
DO YN^LRU
+55 IF %'=1
WRITE $CHAR(7),!?4,"NOT DELETED",!!
QUIT
+56 ;
+57 DO DEL69AN
+58 ;
+59 ; Cancel order
DO ACC^LR7OB1(LRAA,LRAD,LRAN,"OC")
+60 ;
+61 IF $DATA(^LR(LRDFN,LRSS,LRI))
Begin DoDot:1
+62 ;
+63 ; invoke Imaging HL7 routine - P433
IF $TEXT(CANCEL^MAGT7MA)'=""
DO CANCEL^MAGT7MA
+64 ;
+65 KILL ^LR(LRDFN,LRSS,LRI)
+66 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)
End DoDot:1
+67 ;
+68 if LRRC
KILL ^LR(LRXR,LRRC,LRDFN,LRI)
+69 KILL ^LR(LRXREF,H(2),LRABV,LRAN,LRDFN,LRI)
+70 DO K
+71 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",LRDIV,LRAD,LRAN)
+72 if LRRC
KILL ^LRO(68,LRAA,1,LRAD,1,"E",LRRC,LRAN)
+73 ;
+74 LOCK +^LRO(68,LRAA,1,LRAD,1,0):DILOCKTM
+75 IF $TEST
Begin DoDot:1
+76 SET X=^LRO(68,LRAA,1,LRAD,1,0)
SET X(1)=$ORDER(^(0))
SET X(2)=$PIECE(X,"^",4)-1
+77 if X(2)<1
SET X(2)=0
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_X(2)
+78 LOCK -^LRO(68,LRAA,1,LRAD,1,0)
End DoDot:1
+79 ;
+80 DO T
+81 QUIT
+82 ;
+83 ;
BAD WRITE $CHAR(7),!!,"Entry not in file",!!
+1 QUIT
+2 ;
+3 ;
T ;
+1 NEW A
+2 FOR A=1,2,3,4
IF $DATA(^LRO(69.2,LRAA,A,LRAN))
Begin DoDot:1
+3 KILL ^LRO(69.2,LRAA,A,LRAN)
+4 SET X(1)=$ORDER(^LRO(69.2,LRAA,A,0))
+5 if 'X(1)
SET X(1)=0
+6 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))
End DoDot:1
+7 QUIT
+8 ;
+9 ;
DATE ; Returns the date in eye-readable month format
+1 SET Y=$TRANSLATE($$FMTE^XLFDT(Y,"M"),"@"," ")
+2 QUIT
+3 ;
+4 ;
K ; also from LRAPED
+1 NEW A
+2 SET A=0
+3 FOR
SET A=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,A))
if 'A
QUIT
KILL ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_A)
+4 QUIT
+5 ;
+6 ;
DEL69AN ; Delete accession number out of file #69's reference
+1 NEW LRODT,LRSN,LRI,DR,DIE,DA
+2 SET LRODT=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4)
+3 SET LRSN=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",5)
+4 ;
+5 LOCK +^LRO(69,LRODT,1,LRSN,2):DILOCKTM
+6 IF '$TEST
WRITE !!?10,$CHAR(7),"Someone else is editing this entry ",!
QUIT
+7 ;;*
CPRSUP ;CPRS status update to Discontinued
+1 Begin DoDot:1
+2 NEW LRORIFN,LRNATURE,LRT,LRTX,LRX
+3 SET LRX=0
+4 FOR
SET LRX=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRX))
if LRX<1
QUIT
SET LRT=+$GET(^(LRX,0))
Begin DoDot:2
+5 SET LRTX(LRT)=""
End DoDot:2
+6 SET LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
+7 SET LRORIFN=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),U,11)
+8 DO NEW^LR7OB1(LRODT,LRSN,"OC",LRNATURE,.LRTX,1)
End DoDot:1
+9 ;;;*
+10 SET DR="3///@;2///@;4///@;13///@;8///CA;9///L;10////^S X=DUZ"
+11 SET DIE="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
SET LRI=0
+12 FOR
SET LRI=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRI))
if 'LRI
QUIT
Begin DoDot:1
+13 if '$DATA(^LRO(69,LRODT,1,LRSN,2,LRI,0))
QUIT
+14 if $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",5)'=LRAN
QUIT
+15 if $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",4)'=LRAA
QUIT
+16 if $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",3)'=LRAD
QUIT
+17 SET DA=LRI
SET DA(1)=LRSN
SET DA(2)=LRODT
+18 DO ^DIE
End DoDot:1
+19 LOCK -^LRO(69,LRODT,1,LRSN,2)
+20 QUIT
+21 ;
+22 ;
END DO V^LRU
+1 QUIT
