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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUCLR 630 printed Dec 13, 2024@02:21:20 Page 2
LRUCLR ;SLC/CJS/AVAMC/REG - CLEAN UP WORKLIST FILE ; 11/12/88 07:55 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 SET U="^"
SET %DT=""
SET X="T-90"
DO ^%DT
SET LRSAVE=Y
SET LRAA=0
+3 WRITE !!?20,"CLEAR WORKLISTS OVER 90 DAYS",!
WKL SET LRAA=$ORDER(^LRO(68,LRAA))
if 'LRAA
QUIT
DO ASK
if X["^"
QUIT
GOTO WKL
+1 QUIT
ASK if $PIECE(^LRO(68,LRAA,0),U,3)'="D"
QUIT
WRITE !,"CLEAR ",$PIECE(^LRO(68,LRAA,0),U)," WORKLIST "
SET %=2
if %'=1
QUIT
SET LRAA(1)=$PIECE(^LRO(68,LRAA,0),U,1)
+1 SET DA=0
FOR B=0:1
SET DA=$ORDER(^LRO(68,LRAA,1,DA))
if 'DA!(DA>LRSAVE)
QUIT
SET Y=DA
DO D^LRU
WRITE !?5,Y," DELETED"
KILL ^LRO(68,LRAA,1,DA)
+2 if $DATA(^LRO(68,LRAA,1,0))#2
SET ^LRO(68,LRAA,1,0)=$PIECE(^LRO(68,LRAA,1,0),U,1,2)_"^^"_($PIECE(^LRO(68,LRAA,1,0),U,4)-B)
+3 QUIT
