LROC ;DALOI/CJS - ORDER LIST CLEAN-UP ; 20 Apr 2005
;;5.2;LAB SERVICE;**121,295,329**;Sep 27, 1994;Build 2
; Modified slc/jer to include set/kill for "D" cross-reference
;
N DA,DIR,DIROUT,DTOUT,DUOUT,LRAA,LRSAVE,LRX,MSG,X,Y
D ^LROCM
;
S DIR(0)="Y"
S DIR("A")="Do you wish to Purge old Orders and Accessions",DIR("B")="NO"
D ^DIR
I Y'=1 Q
;
S LRX=+$P($G(^LAB(69.9,1,0)),U,9) S:'LRX LRX=7
S LRSAVE=$$FMADD^XLFDT(DT,"-"_LRX)
;
L1 ; Purge the daily accession areas that meet cutoff
S LRAA=0
F S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1 D
. I $P(^LRO(68,LRAA,0),U,3)'="D" W !,"Use File Manager to clear ",$P(^(0),U)
;
N ZTSK,ZTRTN,ZTDESC,ZTIO,ZTSAVE
S ZTRTN="DQ^LROC",ZTDESC="Purge old orders and accessions"
S ZTIO="",ZTSAVE("LR*")=""
D ^%ZTLOAD
S MSG=$S($G(ZTSK):"Task #"_ZTSK_" tasked to run",1:"Tasking failed")
D EN^DDIOL(MSG,"","!?2")
Q
;
;
DQ ; Tasked entry point to clean up file #69
N DA,I,J,K,LRDA
;
; Purge the daily accession areas that meet cutoff
S LRAA=0
F S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1 D Q:$G(ZTSTOP)
. I $P(^LRO(68,LRAA,0),U,3)'="D" Q
. I $$S^%ZTLOAD("Processing accession area: "_LRAA) S ZTSTOP=1 Q
. S DA=0
. F S DA=$O(^LRO(68,LRAA,1,DA)) Q:DA<1!(LRSAVE<DA) K ^LRO(68,LRAA,1,DA)
;
I $G(ZTSTOP) Q
;
S I=0
F S I=$O(^LRO(69,"C",I)) Q:I<1 D Q:$G(ZTSTOP)
. I $$S^%ZTLOAD("Processing 'C' X-REF in file #69") S ZTSTOP=1 Q
. S J=0
. F S J=$O(^LRO(69,"C",I,J)) Q:J>LRSAVE!(J<1) K ^(J)
I $G(ZTSTOP) Q
;
S I=0
F S I=$O(^LRO(69,"D",I)) Q:I<1 D Q:$G(ZTSTOP)
. I $$S^%ZTLOAD("Processing 'D' X-REF in file #69") S ZTSTOP=1 Q
. S J=0
. F S J=$O(^LRO(69,"D",I,J)) Q:J>LRSAVE!(J<1) K ^(J)
I $G(ZTSTOP) Q
;
S LRDA=1
F S LRDA=$O(^LRO(69,LRDA)) D Q:(LRSAVE<LRDA)!(LRDA<1) Q:$G(ZTSTOP)
. I LRDA["0000" Q
. I $$S^%ZTLOAD("Processing orders in file #69 for "_$$FMTE^XLFDT(LRDA)) S ZTSTOP=1 Q
. S ^LRO(69,0)=$P(^LRO(69,0),U,1,2)_U_LRDA_U_($P(^(0),U,4)-1)
. N LRSN
. S LRSN=0
. F S LRSN=$O(^LRO(69,LRDA,1,LRSN)) Q:LRSN<1 D NEW^LR7OB1(LRDA,LRSN,"Z@") ; Call OE/RR
. K ^LRO(69,LRDA),^LRO(69,"B",LRDA,LRDA)
;
I LRDA<1 S ^LRO(69,0)=$P(^(0),U,1,2)
I $G(ZTSTOP) Q
;
D CHKUID
I $G(ZTSTOP) Q
D ^LROC1
K LRSAVE
;
Q
;
;
CENDEL ;
W !,"STARTING CENTRAL ENTRY #: " R LRSTA:DTIME S LRSTA=LRSTA-1
S U="^" W !,"ENDING CENTRAL ENTRY #: " R LRFIN:DTIME
W !,"ARE YOU SURE? N//" D % Q:%'["Y"
S ZTRTN="REENTRY^LROC",ZTIO="",ZTSAVE("L*")=""
D ^%ZTLOAD
K IO("Q"),ZTSK,ZTRTN,ZTIO,ZTSAVE
K %H,%ZA,%ZB,%ZC,DA,I,J,LRAA,LRAN,LRDFN,LRDTM,LRDTN,LRFIN,LRIDT,LRIOZERO,LRLOST,LROCN,LROID,LRORD,LROSN,LRSAVE,LRSN,LRSS,LRSTA,POP,Z
Q
;
;
REENTRY ;
S LRORD=LRSTA
F S LRORD=$O(^LRO(69,"C",LRORD)) Q:LRORD<1!(LRORD>LRFIN) D FDAT
Q
;
;
FDAT ;
S LRDTN=0
F S LRDTN=$O(^LRO(69,"C",LRORD,LRDTN)) Q:LRDTN<1 D ZAP
Q
;
;
ZAP ;
S LRSN=0
F S LRSN=$O(^LRO(69,"C",+LRORD,LRDTN,LRSN)) Q:LRSN<1 D
. D NEW^LR7OB1(LRDTN,LRSN,"Z@") ;Call OE/RR
. K ^LRO(69,"C",+LRORD,LRDTN,LRSN) Q:'$D(^LRO(69,LRDTN,1,LRSN,0)) S LRDFN=+^(0)
. K ^LRO(69,LRDTN,1,LRSN),^LRO(69,LRDTN,1,"AA",LRDFN,LRSN),^LRO(69,"D",LRDFN,LRDTN,LRSN)
S LRAA=0
F S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1 D:$P(^(LRAA,0),U,10)="Y" LRORD
Q
;
;
LRORD ;
S LRAN=$O(^LRO(68,LRAA,1,LRDTN,1,"D",LRORD,0)) Q:LRAN<1
Q:'$D(^LRO(68,LRAA,1,LRDTN,1,LRAN,0))
S LRSS=$P(^LRO(68,LRAA,0),"^",2)
S LRDFN=+^LRO(68,LRAA,1,LRDTN,1,LRAN,0) G:'$D(^(3)) SKPLR S LRDTM=+^LRO(68,LRAA,1,LRDTN,1,LRAN,3) G:'LRDTM SKPLR S LRIDT=9999999-LRDTM
I $D(^LR(LRDFN,LRSS,LRIDT,0)),$P(^(0),U,3) Q
K ^LR(LRDFN,LRSS,LRIDT)
I LRSS="CH" D CHKILL^LRPX(LRDFN,LRIDT)
;
SKPLR S X=^LRO(68,LRAA,1,LRDTN,1,LRAN,0),LROSN=$P(X,U,5),LROID=$P(X,U,6),LROCN=$S($D(^(.1)):$P(^(.1),U),1:"")
K:$L(LROID) ^LRO(68,LRAA,1,LRDTN,1,"C",LROID,LRAN)
K:$L(LROCN) ^LRO(68,LRAA,1,LRDTN,1,"D",LROCN,LRAN)
K ^LRO(68,LRAA,1,LRDTN,1,LRAN)
W "."
Q
;
;
% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
Q
;
;
CHKUID ; Check UID's for purged accessions
;
N LRAA,LRAD,LRAN,LRCNT,LRROOT
;
; Check "C" cross-reference
S LRROOT="^LRO(68,""C"")",(LRAA,LRAD,LRAN,LRCNT)=0
F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,2)'="C" D CHKACN Q:$G(ZTSTOP)
;
; Check "D" cross-reference
S LRROOT="^LRO(68,""D"")",(LRAA,LRAD,LRAN,LRCNT)=0
F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,2)'="D" D CHKACN Q:$G(ZTSTOP)
Q
;
CHKACN ; Check for deleted corresponding accession.
S LRAA=$QS(LRROOT,4),LRAD=$QS(LRROOT,5),LRAN=$QS(LRROOT,6)
S LRCNT=LRCNT+1
; take a "rest" - allow OS to swap out process
; Check if task has been requested to stop
I '(LRCNT#10000) D Q:$G(ZTSTOP)
. I $$S^%ZTLOAD("Processing UID: "_$QS(LRROOT,3)) S ZTSTOP=1 Q
. H 2
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q
K @LRROOT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROC 4832 printed Nov 22, 2024@17:28:31 Page 2
LROC ;DALOI/CJS - ORDER LIST CLEAN-UP ; 20 Apr 2005
+1 ;;5.2;LAB SERVICE;**121,295,329**;Sep 27, 1994;Build 2
+2 ; Modified slc/jer to include set/kill for "D" cross-reference
+3 ;
+4 NEW DA,DIR,DIROUT,DTOUT,DUOUT,LRAA,LRSAVE,LRX,MSG,X,Y
+5 DO ^LROCM
+6 ;
+7 SET DIR(0)="Y"
+8 SET DIR("A")="Do you wish to Purge old Orders and Accessions"
SET DIR("B")="NO"
+9 DO ^DIR
+10 IF Y'=1
QUIT
+11 ;
+12 SET LRX=+$PIECE($GET(^LAB(69.9,1,0)),U,9)
if 'LRX
SET LRX=7
+13 SET LRSAVE=$$FMADD^XLFDT(DT,"-"_LRX)
+14 ;
L1 ; Purge the daily accession areas that meet cutoff
+1 SET LRAA=0
+2 FOR
SET LRAA=$ORDER(^LRO(68,LRAA))
if LRAA<1
QUIT
Begin DoDot:1
+3 IF $PIECE(^LRO(68,LRAA,0),U,3)'="D"
WRITE !,"Use File Manager to clear ",$PIECE(^(0),U)
End DoDot:1
+4 ;
+5 NEW ZTSK,ZTRTN,ZTDESC,ZTIO,ZTSAVE
+6 SET ZTRTN="DQ^LROC"
SET ZTDESC="Purge old orders and accessions"
+7 SET ZTIO=""
SET ZTSAVE("LR*")=""
+8 DO ^%ZTLOAD
+9 SET MSG=$SELECT($GET(ZTSK):"Task #"_ZTSK_" tasked to run",1:"Tasking failed")
+10 DO EN^DDIOL(MSG,"","!?2")
+11 QUIT
+12 ;
+13 ;
DQ ; Tasked entry point to clean up file #69
+1 NEW DA,I,J,K,LRDA
+2 ;
+3 ; Purge the daily accession areas that meet cutoff
+4 SET LRAA=0
+5 FOR
SET LRAA=$ORDER(^LRO(68,LRAA))
if LRAA<1
QUIT
Begin DoDot:1
+6 IF $PIECE(^LRO(68,LRAA,0),U,3)'="D"
QUIT
+7 IF $$S^%ZTLOAD("Processing accession area: "_LRAA)
SET ZTSTOP=1
QUIT
+8 SET DA=0
+9 FOR
SET DA=$ORDER(^LRO(68,LRAA,1,DA))
if DA<1!(LRSAVE<DA)
QUIT
KILL ^LRO(68,LRAA,1,DA)
End DoDot:1
if $GET(ZTSTOP)
QUIT
+10 ;
+11 IF $GET(ZTSTOP)
QUIT
+12 ;
+13 SET I=0
+14 FOR
SET I=$ORDER(^LRO(69,"C",I))
if I<1
QUIT
Begin DoDot:1
+15 IF $$S^%ZTLOAD("Processing 'C' X-REF in file #69")
SET ZTSTOP=1
QUIT
+16 SET J=0
+17 FOR
SET J=$ORDER(^LRO(69,"C",I,J))
if J>LRSAVE!(J<1)
QUIT
KILL ^(J)
End DoDot:1
if $GET(ZTSTOP)
QUIT
+18 IF $GET(ZTSTOP)
QUIT
+19 ;
+20 SET I=0
+21 FOR
SET I=$ORDER(^LRO(69,"D",I))
if I<1
QUIT
Begin DoDot:1
+22 IF $$S^%ZTLOAD("Processing 'D' X-REF in file #69")
SET ZTSTOP=1
QUIT
+23 SET J=0
+24 FOR
SET J=$ORDER(^LRO(69,"D",I,J))
if J>LRSAVE!(J<1)
QUIT
KILL ^(J)
End DoDot:1
if $GET(ZTSTOP)
QUIT
+25 IF $GET(ZTSTOP)
QUIT
+26 ;
+27 SET LRDA=1
+28 FOR
SET LRDA=$ORDER(^LRO(69,LRDA))
Begin DoDot:1
+29 IF LRDA["0000"
QUIT
+30 IF $$S^%ZTLOAD("Processing orders in file #69 for "_$$FMTE^XLFDT(LRDA))
SET ZTSTOP=1
QUIT
+31 SET ^LRO(69,0)=$PIECE(^LRO(69,0),U,1,2)_U_LRDA_U_($PIECE(^(0),U,4)-1)
+32 NEW LRSN
+33 SET LRSN=0
+34 ; Call OE/RR
FOR
SET LRSN=$ORDER(^LRO(69,LRDA,1,LRSN))
if LRSN<1
QUIT
DO NEW^LR7OB1(LRDA,LRSN,"Z@")
+35 KILL ^LRO(69,LRDA),^LRO(69,"B",LRDA,LRDA)
End DoDot:1
if (LRSAVE<LRDA)!(LRDA<1)
QUIT
if $GET(ZTSTOP)
QUIT
+36 ;
+37 IF LRDA<1
SET ^LRO(69,0)=$PIECE(^(0),U,1,2)
+38 IF $GET(ZTSTOP)
QUIT
+39 ;
+40 DO CHKUID
+41 IF $GET(ZTSTOP)
QUIT
+42 DO ^LROC1
+43 KILL LRSAVE
+44 ;
+45 QUIT
+46 ;
+47 ;
CENDEL ;
+1 WRITE !,"STARTING CENTRAL ENTRY #: "
READ LRSTA:DTIME
SET LRSTA=LRSTA-1
+2 SET U="^"
WRITE !,"ENDING CENTRAL ENTRY #: "
READ LRFIN:DTIME
+3 WRITE !,"ARE YOU SURE? N//"
DO %
if %'["Y"
QUIT
+4 SET ZTRTN="REENTRY^LROC"
SET ZTIO=""
SET ZTSAVE("L*")=""
+5 DO ^%ZTLOAD
+6 KILL IO("Q"),ZTSK,ZTRTN,ZTIO,ZTSAVE
+7 KILL %H,%ZA,%ZB,%ZC,DA,I,J,LRAA,LRAN,LRDFN,LRDTM,LRDTN,LRFIN,LRIDT,LRIOZERO,LRLOST,LROCN,LROID,LRORD,LROSN,LRSAVE,LRSN,LRSS,LRSTA,POP,Z
+8 QUIT
+9 ;
+10 ;
REENTRY ;
+1 SET LRORD=LRSTA
+2 FOR
SET LRORD=$ORDER(^LRO(69,"C",LRORD))
if LRORD<1!(LRORD>LRFIN)
QUIT
DO FDAT
+3 QUIT
+4 ;
+5 ;
FDAT ;
+1 SET LRDTN=0
+2 FOR
SET LRDTN=$ORDER(^LRO(69,"C",LRORD,LRDTN))
if LRDTN<1
QUIT
DO ZAP
+3 QUIT
+4 ;
+5 ;
ZAP ;
+1 SET LRSN=0
+2 FOR
SET LRSN=$ORDER(^LRO(69,"C",+LRORD,LRDTN,LRSN))
if LRSN<1
QUIT
Begin DoDot:1
+3 ;Call OE/RR
DO NEW^LR7OB1(LRDTN,LRSN,"Z@")
+4 KILL ^LRO(69,"C",+LRORD,LRDTN,LRSN)
if '$DATA(^LRO(69,LRDTN,1,LRSN,0))
QUIT
SET LRDFN=+^(0)
+5 KILL ^LRO(69,LRDTN,1,LRSN),^LRO(69,LRDTN,1,"AA",LRDFN,LRSN),^LRO(69,"D",LRDFN,LRDTN,LRSN)
End DoDot:1
+6 SET LRAA=0
+7 FOR
SET LRAA=$ORDER(^LRO(68,LRAA))
if LRAA<1
QUIT
if $PIECE(^(LRAA,0),U,10)="Y"
DO LRORD
+8 QUIT
+9 ;
+10 ;
LRORD ;
+1 SET LRAN=$ORDER(^LRO(68,LRAA,1,LRDTN,1,"D",LRORD,0))
if LRAN<1
QUIT
+2 if '$DATA(^LRO(68,LRAA,1,LRDTN,1,LRAN,0))
QUIT
+3 SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)
+4 SET LRDFN=+^LRO(68,LRAA,1,LRDTN,1,LRAN,0)
if '$DATA(^(3))
GOTO SKPLR
SET LRDTM=+^LRO(68,LRAA,1,LRDTN,1,LRAN,3)
if 'LRDTM
GOTO SKPLR
SET LRIDT=9999999-LRDTM
+5 IF $DATA(^LR(LRDFN,LRSS,LRIDT,0))
IF $PIECE(^(0),U,3)
QUIT
+6 KILL ^LR(LRDFN,LRSS,LRIDT)
+7 IF LRSS="CH"
DO CHKILL^LRPX(LRDFN,LRIDT)
+8 ;
SKPLR SET X=^LRO(68,LRAA,1,LRDTN,1,LRAN,0)
SET LROSN=$PIECE(X,U,5)
SET LROID=$PIECE(X,U,6)
SET LROCN=$SELECT($DATA(^(.1)):$PIECE(^(.1),U),1:"")
+1 if $LENGTH(LROID)
KILL ^LRO(68,LRAA,1,LRDTN,1,"C",LROID,LRAN)
+2 if $LENGTH(LROCN)
KILL ^LRO(68,LRAA,1,LRDTN,1,"D",LROCN,LRAN)
+3 KILL ^LRO(68,LRAA,1,LRDTN,1,LRAN)
+4 WRITE "."
+5 QUIT
+6 ;
+7 ;
% READ %:DTIME
if %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 QUIT
+2 ;
+3 ;
CHKUID ; Check UID's for purged accessions
+1 ;
+2 NEW LRAA,LRAD,LRAN,LRCNT,LRROOT
+3 ;
+4 ; Check "C" cross-reference
+5 SET LRROOT="^LRO(68,""C"")"
SET (LRAA,LRAD,LRAN,LRCNT)=0
+6 FOR
SET LRROOT=$QUERY(@LRROOT)
if LRROOT=""
QUIT
if $QSUBSCRIPT(LRROOT,2)'="C"
QUIT
DO CHKACN
if $GET(ZTSTOP)
QUIT
+7 ;
+8 ; Check "D" cross-reference
+9 SET LRROOT="^LRO(68,""D"")"
SET (LRAA,LRAD,LRAN,LRCNT)=0
+10 FOR
SET LRROOT=$QUERY(@LRROOT)
if LRROOT=""
QUIT
if $QSUBSCRIPT(LRROOT,2)'="D"
QUIT
DO CHKACN
if $GET(ZTSTOP)
QUIT
+11 QUIT
+12 ;
CHKACN ; Check for deleted corresponding accession.
+1 SET LRAA=$QSUBSCRIPT(LRROOT,4)
SET LRAD=$QSUBSCRIPT(LRROOT,5)
SET LRAN=$QSUBSCRIPT(LRROOT,6)
+2 SET LRCNT=LRCNT+1
+3 ; take a "rest" - allow OS to swap out process
+4 ; Check if task has been requested to stop
+5 IF '(LRCNT#10000)
Begin DoDot:1
+6 IF $$S^%ZTLOAD("Processing UID: "_$QSUBSCRIPT(LRROOT,3))
SET ZTSTOP=1
QUIT
+7 HANG 2
End DoDot:1
if $GET(ZTSTOP)
QUIT
+8 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
+9 KILL @LRROOT
+10 QUIT
