LRAR05 ; IHS/DIR/AAB - NEW ARCHIVE PURGER 12/12/96 10:16 ; [ 07/22/2002 1:05 PM ]
;;5.2;LR;**1002,1013**;JUL 15, 2002
;;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
LRAR05 ; IHS/DIR/AAB - NEW ARCHIVE PURGER 12/12/96 10:16 ; [ 07/22/2002 1:05 PM ]
+1 ;;5.2;LR;**1002,1013**;JUL 15, 2002
+2 ;;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
