LRUCLR.m

LRUCLR ; IHS/DIR/FJE - CLEAN UP WORKLIST FILE 11/12/88 07:55 ;

 ;;5.2;LR;**1013**;JUL 15, 2002

 ;

 ;;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

LRUCLR    ; IHS/DIR/FJE - CLEAN UP WORKLIST FILE 11/12/88 07:55 ;

 +1       ;;5.2;LR;**1013**;JUL 15, 2002

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4        SET U="^"

           SET %DT=""

           SET X="T-90"

           DO ^%DT

           SET LRSAVE=Y

           SET LRAA=0

 +5        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