LRAR05.m

LRAR05 ;DAL/HOAK NEW ARCHIVE PURGER ; 12/12/96  10:16 ;

 ;;5.2;LAB SERVICE;**111**;Sep 27, 1994

INIT ;              Building block from...\/

 ;     LRCHIVK SLC/RWF - REMOVE OLD LAB DATA ; 12/14/87  15:46 ;

 Q

EN ;from LRCHIV

 U IO W @IOF,"START OF PURGE PASS" D STAMP^LRX

 S LRDFN=0

DFN ;

 S LRDFN=$O(^LAR("Z",LRDFN)) G END:LRDFN="" W "."

 F LRSS="CH","MI" I $O(^LAR("Z",LRDFN,LRSS,0)) S LRIDT=0,C1=1 D LAB,UPDT

 S ^LAB(69.9,1,"PURGE LRDFN")=LRDFN G DFN

LAB ;

 S LRIDT=$O(^LAR("Z",LRDFN,LRSS,LRIDT)) Q:LRIDT<1

 ;

 IF '$D(^LR(LRDFN,LRSS,LRIDT,0)) W !,"Data not found." G LAB

 ;

 ;              If data in ^LRA matches ^LR purge

 ;

 IF ^LAR("Z",LRDFN,LRSS,LRIDT,0)=^LR(LRDFN,LRSS,LRIDT,0) D  G LAB

 .  K ^LAR("Z",LRDFN,LRSS,LRIDT),^LR(LRDFN,LRSS,LRIDT)

 .  S ^LR(LRDFN,"T",P1,0)=P1

 W !,"^LAR and ^LR don't match, Data not purged.",!

 W " LRDFN = ",LRDFN_" Sub Script = "_LRSS_" LRIDT = "_LRIDT

 W !?4,"^LR("_LRDFN_","_LRSS_","_LRIDT_",0) = ",^LR(LRDFN,LRSS,LRIDT,0)

 W !,"^LAR(""Z"","_LRDFN_","_LRSS_","_LRIDT_",0) = ",^LAR("Z",LRDFN,LRSS,LRIDT,0)

 K ^LAR("Z",LRDFN,LRSS,LRIDT)

 G LAB

 Q

UPDT S X=0,LRCNT=0

 F I=0:0 S X=$O(^LR(LRDFN,LRSS,X)) Q:X<1  S LRCNT=LRCNT+1

 I LRCNT=0 S ^LR(LRDFN,LRSS,0)=$S(LRSS="CH":"^63.04D",1:"^63.05DA") Q

 S $P(^LR(LRDFN,LRSS,0),U,4)=LRCNT

 Q

END W !!,"**PURGE PASS DONE ** " D STAMP^LRX Q  ;W @IOF G H^XUS

 Q

SET ;

 Q:$E(IOST,1,2)'="C-"

 W @IOF D SCRNON S DX=2,DY=2 X IOXY S OK=1 S LRI=0,LRIN=0 K LRTIC

 Q

 ;CAN BE USED INSTEAD OF dots TO SHOW USER HOW JOB IS PROCEEDING

 ;   

 ;    LRJT0=4th piece of 0 node of file being searched

 ;F LRI=1:1:70 S DX=LRI*2+2,DY=6 X IOXY D

JOBTIME ;

 Q:$E(IOST,1,2)'="C-"

 S OK=1

 S DX=LRI*2+2,DY=6 X IOXY D

 . I '$G(LRTIC) S LRTIC=$P((LRJT0/70),".")

 . Q:(LRI+1)'>LRTIC  S LRTIC=LRTIC+$P((LRJT0/70),".") S LRIN=LRIN+1

 . S DX=2+LRIN,DY=8 X IOXY

 . W IORVON

 . W ">"

 . W IORVOFF

 . S DX=16,DY=17 X IOXY

 . W IODHLT,$E((LRIN/LRJT0)*100,1,4),"% of ^LR"

 . S DX=16,DY=18 X IOXY

 . W IODHLB,$E((LRIN/LRJT0)*100,1,4),"% of ^LR"

 . D FLASH

 I 'OK D SCRNOFF

 Q

SCRNON ;

 ;D GSET^%ZISS W IOG1

 D ENS^%ZISS S %ZIS="I"

 D FLASH

 Q

FLASH ;

 ;S LRDT7=LRIDT

 I '$G(LRDT7) S LRDT7=LR(1)

 S DX=13,DY=20 X IOXY

 ;W IORVON

 W IODHLT,$$CJ^XLFSTR($$FMTE^XLFDT(LRDT7,"D"),IOM)

 S DY=DY+1 X IOXY

 W IODHLB,$$CJ^XLFSTR($$FMTE^XLFDT(LRDT7,"D"),IOM)

 ;W IOIND

 ;W IORVOFF

 ;S DY=DY-1 X IOXY

 ;W "                                                                    "

 ;S DY=DY+3 X IOXY

 ;W $G(LRI)

 Q

SCRNOFF ;

 W IOBOFF

 D KILL^%ZISS

 ;W IOG0 D GKILL^%ZISS

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRAR05   2590     printed  Feb 18, 2025@23:34:45                                                                                                                                                                                                      Page 2

LRAR05    ;DAL/HOAK NEW ARCHIVE PURGER ; 12/12/96  10:16 ;

 +1       ;;5.2;LAB SERVICE;**111**;Sep 27, 1994

INIT      ;              Building block from...\/

 +1       ;     LRCHIVK SLC/RWF - REMOVE OLD LAB DATA ; 12/14/87  15:46 ;

 +2        QUIT 

EN        ;from LRCHIV

 +1        USE IO

           WRITE @IOF,"START OF PURGE PASS"

           DO STAMP^LRX

 +2        SET LRDFN=0

DFN       ;

 +1        SET LRDFN=$ORDER(^LAR("Z",LRDFN))

           if LRDFN=""

               GOTO END

           WRITE "."

 +2        FOR LRSS="CH","MI"

               IF $ORDER(^LAR("Z",LRDFN,LRSS,0))

                   SET LRIDT=0

                   SET C1=1

                   DO LAB

                   DO UPDT

 +3        SET ^LAB(69.9,1,"PURGE LRDFN")=LRDFN

           GOTO DFN

LAB       ;

 +1        SET LRIDT=$ORDER(^LAR("Z",LRDFN,LRSS,LRIDT))

           if LRIDT<1

               QUIT 

 +2       ;

 +3        IF '$DATA(^LR(LRDFN,LRSS,LRIDT,0))

               WRITE !,"Data not found."

               GOTO LAB

 +4       ;

 +5       ;              If data in ^LRA matches ^LR purge

 +6       ;

 +7        IF ^LAR("Z",LRDFN,LRSS,LRIDT,0)=^LR(LRDFN,LRSS,LRIDT,0)

               Begin DoDot:1

 +8                KILL ^LAR("Z",LRDFN,LRSS,LRIDT),^LR(LRDFN,LRSS,LRIDT)

 +9                SET ^LR(LRDFN,"T",P1,0)=P1

               End DoDot:1

               GOTO LAB

 +10       WRITE !,"^LAR and ^LR don't match, Data not purged.",!

 +11       WRITE " LRDFN = ",LRDFN_" Sub Script = "_LRSS_" LRIDT = "_LRIDT

 +12       WRITE !?4,"^LR("_LRDFN_","_LRSS_","_LRIDT_",0) = ",^LR(LRDFN,LRSS,LRIDT,0)

 +13       WRITE !,"^LAR(""Z"","_LRDFN_","_LRSS_","_LRIDT_",0) = ",^LAR("Z",LRDFN,LRSS,LRIDT,0)

 +14       KILL ^LAR("Z",LRDFN,LRSS,LRIDT)

 +15       GOTO LAB

 +16       QUIT 

UPDT       SET X=0

           SET LRCNT=0

 +1        FOR I=0:0

               SET X=$ORDER(^LR(LRDFN,LRSS,X))

               if X<1

                   QUIT 

               SET LRCNT=LRCNT+1

 +2        IF LRCNT=0

               SET ^LR(LRDFN,LRSS,0)=$SELECT(LRSS="CH":"^63.04D",1:"^63.05DA")

               QUIT 

 +3        SET $PIECE(^LR(LRDFN,LRSS,0),U,4)=LRCNT

 +4        QUIT 

END       ;W @IOF G H^XUS

           WRITE !!,"**PURGE PASS DONE ** "

           DO STAMP^LRX

           QUIT 

 +1        QUIT 

SET       ;

 +1        if $EXTRACT(IOST,1,2)'="C-"

               QUIT 

 +2        WRITE @IOF

           DO SCRNON

           SET DX=2

           SET DY=2

           XECUTE IOXY

           SET OK=1

           SET LRI=0

           SET LRIN=0

           KILL LRTIC

 +3        QUIT 

 +4       ;CAN BE USED INSTEAD OF dots TO SHOW USER HOW JOB IS PROCEEDING

 +5       ;   

 +6       ;    LRJT0=4th piece of 0 node of file being searched

 +7       ;F LRI=1:1:70 S DX=LRI*2+2,DY=6 X IOXY D

JOBTIME   ;

 +1        if $EXTRACT(IOST,1,2)'="C-"

               QUIT 

 +2        SET OK=1

 +3        SET DX=LRI*2+2

           SET DY=6

           XECUTE IOXY

           Begin DoDot:1

 +4            IF '$GET(LRTIC)

                   SET LRTIC=$PIECE((LRJT0/70),".")

 +5            if (LRI+1)'>LRTIC

                   QUIT 

               SET LRTIC=LRTIC+$PIECE((LRJT0/70),".")

               SET LRIN=LRIN+1

 +6            SET DX=2+LRIN

               SET DY=8

               XECUTE IOXY

 +7            WRITE IORVON

 +8            WRITE ">"

 +9            WRITE IORVOFF

 +10           SET DX=16

               SET DY=17

               XECUTE IOXY

 +11           WRITE IODHLT,$EXTRACT((LRIN/LRJT0)*100,1,4),"% of ^LR"

 +12           SET DX=16

               SET DY=18

               XECUTE IOXY

 +13           WRITE IODHLB,$EXTRACT((LRIN/LRJT0)*100,1,4),"% of ^LR"

 +14           DO FLASH

           End DoDot:1

 +15       IF 'OK

               DO SCRNOFF

 +16       QUIT 

SCRNON    ;

 +1       ;D GSET^%ZISS W IOG1

 +2        DO ENS^%ZISS

           SET %ZIS="I"

 +3        DO FLASH

 +4        QUIT 

FLASH     ;

 +1       ;S LRDT7=LRIDT

 +2        IF '$GET(LRDT7)

               SET LRDT7=LR(1)

 +3        SET DX=13

           SET DY=20

           XECUTE IOXY

 +4       ;W IORVON

 +5        WRITE IODHLT,$$CJ^XLFSTR($$FMTE^XLFDT(LRDT7,"D"),IOM)

 +6        SET DY=DY+1

           XECUTE IOXY

 +7        WRITE IODHLB,$$CJ^XLFSTR($$FMTE^XLFDT(LRDT7,"D"),IOM)

 +8       ;W IOIND

 +9       ;W IORVOFF

 +10      ;S DY=DY-1 X IOXY

 +11      ;W "                                                                    "

 +12      ;S DY=DY+3 X IOXY

 +13      ;W $G(LRI)

 +14       QUIT 

SCRNOFF   ;

 +1        WRITE IOBOFF

 +2        DO KILL^%ZISS

 +3       ;W IOG0 D GKILL^%ZISS

 +4        QUIT