Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LROC

LROC.m

Go to the documentation of this file. 
  1. LROC ;VA/DALOI/CJS - ORDER LIST CLEAN-UP ; 13-Oct-2017 14:04 ;  MKK
  1.  ;;5.2;LAB SERVICE;**1003,1013,121,1018,295,1030,329,1031,1041**;NOV 1, 1997;Build 23
  1.  ;
  1.  ;;VA LR Patch(s): 121,295,329
  1.  ;
  1.  ; Modified slc/jer to include set/kill for "D" cross-reference
  1.  ;
  1. EP ; EP
  1.  N DA,DIR,DIROUT,DTOUT,DUOUT,LRAA,LRSAVE,LRX,MSG,X,Y
  1.  D ^LROCM
  1.  ;
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Do you wish to Purge old Orders and Accessions",DIR("B")="NO"
  1.  D ^DIR
  1.  I Y'=1 Q
  1.  ;
  1.  D STORPURG^BLRPURGU    ; IHS/MSC/MKK - LR*5.2*1041
  1.  ;
  1.  S LRX=+$P($G(^LAB(69.9,1,0)),U,9) S:'LRX LRX=7
  1.  S LRSAVE=$$FMADD^XLFDT(DT,"-"_LRX)
  1.  ;
  1. L1 ; Purge the daily accession areas that meet cutoff
  1.  S LRAA=0
  1.  F  S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1  D
  1.  . I $P(^LRO(68,LRAA,0),U,3)'="D" W !,"Use File Manager to clear ",$P(^(0),U)
  1.  ;
  1.  N ZTSK,ZTRTN,ZTDESC,ZTIO,ZTSAVE
  1.  S ZTRTN="DQ^LROC",ZTDESC="Purge old orders and accessions"
  1.  S ZTIO="",ZTSAVE("LR*")=""
  1.  D ^%ZTLOAD
  1.  S MSG=$S($G(ZTSK):"Task #"_ZTSK_" tasked to run",1:"Tasking failed")
  1.  D EN^DDIOL(MSG,"","!?2")
  1.  Q
  1.  ;
  1.  ;
  1. DQ ; Tasked entry point to clean up file #69
  1.  N DA,I,J,K,LRDA
  1.  ;
  1.  ; Purge the daily accession areas that meet cutoff
  1.  S LRAA=0
  1.  F  S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1  D  Q:$G(ZTSTOP)
  1.  . I $P(^LRO(68,LRAA,0),U,3)'="D" Q
  1.  . I $$S^%ZTLOAD("Processing accession area: "_LRAA) S ZTSTOP=1 Q
  1.  . S DA=0
  1.  . F  S DA=$O(^LRO(68,LRAA,1,DA)) Q:DA<1!(LRSAVE<DA)  K ^LRO(68,LRAA,1,DA)
  1.  ;
  1.  I $G(ZTSTOP) Q
  1.  ;
  1.  S I=0
  1.  F  S I=$O(^LRO(69,"C",I)) Q:I<1  D  Q:$G(ZTSTOP)
  1.  . I $$S^%ZTLOAD("Processing 'C' X-REF in file #69") S ZTSTOP=1 Q
  1.  . S J=0
  1.  . F  S J=$O(^LRO(69,"C",I,J)) Q:J>LRSAVE!(J<1)  K ^(J)
  1.  I $G(ZTSTOP) Q
  1.  ;
  1.  S I=0
  1.  F  S I=$O(^LRO(69,"D",I)) Q:I<1  D  Q:$G(ZTSTOP)
  1.  . I $$S^%ZTLOAD("Processing 'D' X-REF in file #69") S ZTSTOP=1 Q
  1.  . S J=0
  1.  . F  S J=$O(^LRO(69,"D",I,J)) Q:J>LRSAVE!(J<1)  K ^(J)
  1.  I $G(ZTSTOP) Q
  1.  ;
  1.  S LRDA=1
  1.  F  S LRDA=$O(^LRO(69,LRDA)) D  Q:(LRSAVE<LRDA)!(LRDA<1)  Q:$G(ZTSTOP)
  1.  . I LRDA["0000" Q
  1.  . I $$S^%ZTLOAD("Processing orders in file #69 for "_$$FMTE^XLFDT(LRDA)) S ZTSTOP=1 Q
  1.  . S ^LRO(69,0)=$P(^LRO(69,0),U,1,2)_U_LRDA_U_($P(^(0),U,4)-1)
  1.  . N LRSN
  1.  . S LRSN=0
  1.  . F  S LRSN=$O(^LRO(69,LRDA,1,LRSN)) Q:LRSN<1  D NEW^LR7OB1(LRDA,LRSN,"Z@") ; Call OE/RR
  1.  . K ^LRO(69,LRDA),^LRO(69,"B",LRDA,LRDA)
  1.  ;
  1.  I LRDA<1 S ^LRO(69,0)=$P(^(0),U,1,2)
  1.  I $G(ZTSTOP) Q
  1.  ;
  1.  D CHKUID
  1.  I $G(ZTSTOP) Q
  1.  D ^LROC1
  1.  K LRSAVE
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. CENDEL ;
  1.  W !,"STARTING CENTRAL ENTRY #: " R LRSTA:DTIME S LRSTA=LRSTA-1
  1.  S U="^" W !,"ENDING CENTRAL ENTRY #: " R LRFIN:DTIME
  1.  W !,"ARE YOU SURE? N//" D % Q:%'["Y"
  1.  S ZTRTN="REENTRY^LROC",ZTIO="",ZTSAVE("L*")=""
  1.  D ^%ZTLOAD
  1.  K IO("Q"),ZTSK,ZTRTN,ZTIO,ZTSAVE
  1.  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
  1.  Q
  1.  ;
  1.  ;
  1. REENTRY ;
  1.  S LRORD=LRSTA
  1.  F  S LRORD=$O(^LRO(69,"C",LRORD)) Q:LRORD<1!(LRORD>LRFIN)  D FDAT
  1.  Q
  1.  ;
  1.  ;
  1. FDAT ;
  1.  S LRDTN=0
  1.  F  S LRDTN=$O(^LRO(69,"C",LRORD,LRDTN)) Q:LRDTN<1  D ZAP
  1.  Q
  1.  ;
  1.  ;
  1. ZAP ;
  1.  S LRSN=0
  1.  F  S LRSN=$O(^LRO(69,"C",+LRORD,LRDTN,LRSN)) Q:LRSN<1  D
  1.  . D NEW^LR7OB1(LRDTN,LRSN,"Z@") ;Call OE/RR
  1.  . K ^LRO(69,"C",+LRORD,LRDTN,LRSN) Q:'$D(^LRO(69,LRDTN,1,LRSN,0))  S LRDFN=+^(0)
  1.  . K ^LRO(69,LRDTN,1,LRSN),^LRO(69,LRDTN,1,"AA",LRDFN,LRSN),^LRO(69,"D",LRDFN,LRDTN,LRSN)
  1.  S LRAA=0
  1.  F  S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1  D:$P(^(LRAA,0),U,10)="Y" LRORD
  1.  Q
  1.  ;
  1.  ;
  1. LRORD ;
  1.  S LRAN=$O(^LRO(68,LRAA,1,LRDTN,1,"D",LRORD,0)) Q:LRAN<1
  1.  Q:'$D(^LRO(68,LRAA,1,LRDTN,1,LRAN,0))
  1.  S LRSS=$P(^LRO(68,LRAA,0),"^",2)
  1.  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
  1.  I $D(^LR(LRDFN,LRSS,LRIDT,0)),$P(^(0),U,3) Q
  1.  K ^LR(LRDFN,LRSS,LRIDT)
  1.  I LRSS="CH" D CHKILL^LRPX(LRDFN,LRIDT)
  1.  ;
  1. 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:"")
  1.  K:$L(LROID) ^LRO(68,LRAA,1,LRDTN,1,"C",LROID,LRAN)
  1.  K:$L(LROCN) ^LRO(68,LRAA,1,LRDTN,1,"D",LROCN,LRAN)
  1.  K ^LRO(68,LRAA,1,LRDTN,1,LRAN)
  1.  W "."
  1.  Q
  1.  ;
  1.  ;
  1. % R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %
  1.  Q
  1.  ;
  1.  ;
  1. CHKUID ; Check UID's for purged accessions
  1.  ;
  1.  N LRAA,LRAD,LRAN,LRCNT,LRROOT
  1.  ;
  1.  ; Check "C" cross-reference
  1.  S LRROOT="^LRO(68,""C"")",(LRAA,LRAD,LRAN,LRCNT)=0
  1.  F  S LRROOT=$Q(@LRROOT) Q:LRROOT=""  Q:$QS(LRROOT,2)'="C"  D CHKACN Q:$G(ZTSTOP)
  1.  ;
  1.  ; Check "D" cross-reference
  1.  S LRROOT="^LRO(68,""D"")",(LRAA,LRAD,LRAN,LRCNT)=0
  1.  F  S LRROOT=$Q(@LRROOT) Q:LRROOT=""  Q:$QS(LRROOT,2)'="D"  D CHKACN Q:$G(ZTSTOP)
  1.  Q
  1.  ;
  1. CHKACN ; Check for deleted corresponding accession.
  1.  S LRAA=$QS(LRROOT,4),LRAD=$QS(LRROOT,5),LRAN=$QS(LRROOT,6)
  1.  S LRCNT=LRCNT+1
  1.  ; take a "rest" - allow OS to swap out process
  1.  ; Check if task has been requested to stop
  1.  I '(LRCNT#10000) D  Q:$G(ZTSTOP)
  1.  . I $$S^%ZTLOAD("Processing UID: "_$QS(LRROOT,3)) S ZTSTOP=1 Q
  1.  . H 2
  1.  I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q
  1.  K @LRROOT
  1.  Q