11 lines
620 B
Mathematica
11 lines
620 B
Mathematica
LRUCLR ;SLC/CJS/AVAMC/REG - CLEAN UP WORKLIST FILE ; 11/12/88 07:55 ;
|
|
;;5.2;LAB SERVICE;;Sep 27, 1994
|
|
S U="^",%DT="",X="T-90" D ^%DT S LRSAVE=Y,LRAA=0
|
|
W !!?20,"CLEAR WORKLISTS OVER 90 DAYS",!
|
|
WKL S LRAA=$O(^LRO(68,LRAA)) Q:'LRAA D ASK Q:X["^" G WKL
|
|
Q
|
|
ASK Q:$P(^LRO(68,LRAA,0),U,3)'="D" W !,"CLEAR ",$P(^LRO(68,LRAA,0),U)," WORKLIST " S %=2 Q:%'=1 S LRAA(1)=$P(^LRO(68,LRAA,0),U,1)
|
|
S DA=0 F B=0:1 S DA=$O(^LRO(68,LRAA,1,DA)) Q:'DA!(DA>LRSAVE) S Y=DA D D^LRU W !?5,Y," DELETED" K ^LRO(68,LRAA,1,DA)
|
|
S:$D(^LRO(68,LRAA,1,0))#2 ^LRO(68,LRAA,1,0)=$P(^LRO(68,LRAA,1,0),U,1,2)_"^^"_($P(^LRO(68,LRAA,1,0),U,4)-B)
|
|
Q
|