LRUCLR.m

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 ---LRUCLR   630     printed  Apr 09, 2024@21:07:11                                                                                                                                                                                                       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