- LRAR03 ;DAL/HOAK NEW ARCHIVE PURGERSET ; 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
- ;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 ;
- QUIT
- FLASH ;
- QUIT
- SCRNOFF ;
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAR03 2048 printed Feb 18, 2025@23:34:43 Page 2
- LRAR03 ;DAL/HOAK NEW ARCHIVE PURGERSET ; 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 QUIT
- +2 ;CAN BE USED INSTEAD OF dots TO SHOW USER HOW JOB IS PROCEEDING
- +3 ;
- +4 ; LRJT0=4th piece of 0 node of file being searched
- +5 ;F LRI=1:1:70 S DX=LRI*2+2,DY=6 X IOXY D
- JOBTIME ;
- +1 ;
- +2 if $EXTRACT(IOST,1,2)'="C-"
- QUIT
- +3 SET OK=1
- +4 SET DX=LRI*2+2
- SET DY=6
- XECUTE IOXY
- Begin DoDot:1
- +5 IF '$GET(LRTIC)
- SET LRTIC=$PIECE((LRJT0/70),".")
- +6 if (LRI+1)'>LRTIC
- QUIT
- SET LRTIC=LRTIC+$PIECE((LRJT0/70),".")
- SET LRIN=LRIN+1
- +7 SET DX=2+LRIN
- SET DY=8
- XECUTE IOXY
- +8 WRITE IORVON
- +9 WRITE ">"
- +10 WRITE IORVOFF
- +11 SET DX=16
- SET DY=17
- XECUTE IOXY
- +12 WRITE IODHLT,$EXTRACT((LRIN/LRJT0)*100,1,4),"% of ^LR"
- +13 SET DX=16
- SET DY=18
- XECUTE IOXY
- +14 WRITE IODHLB,$EXTRACT((LRIN/LRJT0)*100,1,4),"% of ^LR"
- +15 DO FLASH
- End DoDot:1
- +16 IF 'OK
- DO SCRNOFF
- +17 QUIT
- SCRNON ;
- +1 QUIT
- FLASH ;
- +1 QUIT
- SCRNOFF ;
- +1 QUIT