source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LROC.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.6 KB
Line 
1LROC ;DALOI/CJS - ORDER LIST CLEAN-UP ; 20 Apr 2005
2 ;;5.2;LAB SERVICE;**121,295,329**;Sep 27, 1994;Build 2
3 ; Modified slc/jer to include set/kill for "D" cross-reference
4 ;
5 N DA,DIR,DIROUT,DTOUT,DUOUT,LRAA,LRSAVE,LRX,MSG,X,Y
6 D ^LROCM
7 ;
8 S DIR(0)="Y"
9 S DIR("A")="Do you wish to Purge old Orders and Accessions",DIR("B")="NO"
10 D ^DIR
11 I Y'=1 Q
12 ;
13 S LRX=+$P($G(^LAB(69.9,1,0)),U,9) S:'LRX LRX=7
14 S LRSAVE=$$FMADD^XLFDT(DT,"-"_LRX)
15 ;
16L1 ; Purge the daily accession areas that meet cutoff
17 S LRAA=0
18 F S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1 D
19 . I $P(^LRO(68,LRAA,0),U,3)'="D" W !,"Use File Manager to clear ",$P(^(0),U)
20 ;
21 N ZTSK,ZTRTN,ZTDESC,ZTIO,ZTSAVE
22 S ZTRTN="DQ^LROC",ZTDESC="Purge old orders and accessions"
23 S ZTIO="",ZTSAVE("LR*")=""
24 D ^%ZTLOAD
25 S MSG=$S($G(ZTSK):"Task #"_ZTSK_" tasked to run",1:"Tasking failed")
26 D EN^DDIOL(MSG,"","!?2")
27 Q
28 ;
29 ;
30DQ ; Tasked entry point to clean up file #69
31 N DA,I,J,K,LRDA
32 ;
33 ; Purge the daily accession areas that meet cutoff
34 S LRAA=0
35 F S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1 D Q:$G(ZTSTOP)
36 . I $P(^LRO(68,LRAA,0),U,3)'="D" Q
37 . I $$S^%ZTLOAD("Processing accession area: "_LRAA) S ZTSTOP=1 Q
38 . S DA=0
39 . F S DA=$O(^LRO(68,LRAA,1,DA)) Q:DA<1!(LRSAVE<DA) K ^LRO(68,LRAA,1,DA)
40 ;
41 I $G(ZTSTOP) Q
42 ;
43 S I=0
44 F S I=$O(^LRO(69,"C",I)) Q:I<1 D Q:$G(ZTSTOP)
45 . I $$S^%ZTLOAD("Processing 'C' X-REF in file #69") S ZTSTOP=1 Q
46 . S J=0
47 . F S J=$O(^LRO(69,"C",I,J)) Q:J>LRSAVE!(J<1) K ^(J)
48 I $G(ZTSTOP) Q
49 ;
50 S I=0
51 F S I=$O(^LRO(69,"D",I)) Q:I<1 D Q:$G(ZTSTOP)
52 . I $$S^%ZTLOAD("Processing 'D' X-REF in file #69") S ZTSTOP=1 Q
53 . S J=0
54 . F S J=$O(^LRO(69,"D",I,J)) Q:J>LRSAVE!(J<1) K ^(J)
55 I $G(ZTSTOP) Q
56 ;
57 S LRDA=1
58 F S LRDA=$O(^LRO(69,LRDA)) D Q:(LRSAVE<LRDA)!(LRDA<1) Q:$G(ZTSTOP)
59 . I LRDA["0000" Q
60 . I $$S^%ZTLOAD("Processing orders in file #69 for "_$$FMTE^XLFDT(LRDA)) S ZTSTOP=1 Q
61 . S ^LRO(69,0)=$P(^LRO(69,0),U,1,2)_U_LRDA_U_($P(^(0),U,4)-1)
62 . N LRSN
63 . S LRSN=0
64 . F S LRSN=$O(^LRO(69,LRDA,1,LRSN)) Q:LRSN<1 D NEW^LR7OB1(LRDA,LRSN,"Z@") ; Call OE/RR
65 . K ^LRO(69,LRDA),^LRO(69,"B",LRDA,LRDA)
66 ;
67 I LRDA<1 S ^LRO(69,0)=$P(^(0),U,1,2)
68 I $G(ZTSTOP) Q
69 ;
70 D CHKUID
71 I $G(ZTSTOP) Q
72 D ^LROC1
73 K LRSAVE
74 ;
75 Q
76 ;
77 ;
78CENDEL ;
79 W !,"STARTING CENTRAL ENTRY #: " R LRSTA:DTIME S LRSTA=LRSTA-1
80 S U="^" W !,"ENDING CENTRAL ENTRY #: " R LRFIN:DTIME
81 W !,"ARE YOU SURE? N//" D % Q:%'["Y"
82 S ZTRTN="REENTRY^LROC",ZTIO="",ZTSAVE("L*")=""
83 D ^%ZTLOAD
84 K IO("Q"),ZTSK,ZTRTN,ZTIO,ZTSAVE
85 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
86 Q
87 ;
88 ;
89REENTRY ;
90 S LRORD=LRSTA
91 F S LRORD=$O(^LRO(69,"C",LRORD)) Q:LRORD<1!(LRORD>LRFIN) D FDAT
92 Q
93 ;
94 ;
95FDAT ;
96 S LRDTN=0
97 F S LRDTN=$O(^LRO(69,"C",LRORD,LRDTN)) Q:LRDTN<1 D ZAP
98 Q
99 ;
100 ;
101ZAP ;
102 S LRSN=0
103 F S LRSN=$O(^LRO(69,"C",+LRORD,LRDTN,LRSN)) Q:LRSN<1 D
104 . D NEW^LR7OB1(LRDTN,LRSN,"Z@") ;Call OE/RR
105 . K ^LRO(69,"C",+LRORD,LRDTN,LRSN) Q:'$D(^LRO(69,LRDTN,1,LRSN,0)) S LRDFN=+^(0)
106 . K ^LRO(69,LRDTN,1,LRSN),^LRO(69,LRDTN,1,"AA",LRDFN,LRSN),^LRO(69,"D",LRDFN,LRDTN,LRSN)
107 S LRAA=0
108 F S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1 D:$P(^(LRAA,0),U,10)="Y" LRORD
109 Q
110 ;
111 ;
112LRORD ;
113 S LRAN=$O(^LRO(68,LRAA,1,LRDTN,1,"D",LRORD,0)) Q:LRAN<1
114 Q:'$D(^LRO(68,LRAA,1,LRDTN,1,LRAN,0))
115 S LRSS=$P(^LRO(68,LRAA,0),"^",2)
116 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
117 I $D(^LR(LRDFN,LRSS,LRIDT,0)),$P(^(0),U,3) Q
118 K ^LR(LRDFN,LRSS,LRIDT)
119 I LRSS="CH" D CHKILL^LRPX(LRDFN,LRIDT)
120 ;
121SKPLR 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:"")
122 K:$L(LROID) ^LRO(68,LRAA,1,LRDTN,1,"C",LROID,LRAN)
123 K:$L(LROCN) ^LRO(68,LRAA,1,LRDTN,1,"D",LROCN,LRAN)
124 K ^LRO(68,LRAA,1,LRDTN,1,LRAN)
125 W "."
126 Q
127 ;
128 ;
129% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
130 Q
131 ;
132 ;
133CHKUID ; Check UID's for purged accessions
134 ;
135 N LRAA,LRAD,LRAN,LRCNT,LRROOT
136 ;
137 ; Check "C" cross-reference
138 S LRROOT="^LRO(68,""C"")",(LRAA,LRAD,LRAN,LRCNT)=0
139 F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,2)'="C" D CHKACN Q:$G(ZTSTOP)
140 ;
141 ; Check "D" cross-reference
142 S LRROOT="^LRO(68,""D"")",(LRAA,LRAD,LRAN,LRCNT)=0
143 F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,2)'="D" D CHKACN Q:$G(ZTSTOP)
144 Q
145 ;
146CHKACN ; Check for deleted corresponding accession.
147 S LRAA=$QS(LRROOT,4),LRAD=$QS(LRROOT,5),LRAN=$QS(LRROOT,6)
148 S LRCNT=LRCNT+1
149 ; take a "rest" - allow OS to swap out process
150 ; Check if task has been requested to stop
151 I '(LRCNT#10000) D Q:$G(ZTSTOP)
152 . I $$S^%ZTLOAD("Processing UID: "_$QS(LRROOT,3)) S ZTSTOP=1 Q
153 . H 2
154 I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q
155 K @LRROOT
156 Q
Note: See TracBrowser for help on using the repository browser.