LRCHIVK ;SLC/RWF - REMOVE OLD LAB DATA ; 12/14/87 15:46 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
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 ^LAR("Z",LRDFN,LRSS,LRIDT,0)=^LR(LRDFN,LRSS,LRIDT,0) K ^LAR("Z",LRDFN,LRSS,LRIDT),^LR(LRDFN,LRSS,LRIDT) S ^LR(LRDFN,"T",P1,0)=P1 G LAB
W !,"^LAR and ^LR don't match, Data not purged.",!," 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCHIVK 1167 printed Sep 23, 2025@19:49:18 Page 2
LRCHIVK ;SLC/RWF - REMOVE OLD LAB DATA ; 12/14/87 15:46 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 QUIT
EN ;from LRCHIV
+1 USE IO
WRITE @IOF,"START OF PURGE PASS"
DO STAMP^LRX
+2 SET LRDFN=0
DFN SET LRDFN=$ORDER(^LAR("Z",LRDFN))
if LRDFN=""
GOTO END
WRITE "."
+1 FOR LRSS="CH","MI"
IF $ORDER(^LAR("Z",LRDFN,LRSS,0))
SET LRIDT=0
SET C1=1
DO LAB
DO UPDT
+2 SET ^LAB(69.9,1,"PURGE LRDFN")=LRDFN
GOTO DFN
LAB SET LRIDT=$ORDER(^LAR("Z",LRDFN,LRSS,LRIDT))
if LRIDT<1
QUIT
+1 IF '$DATA(^LR(LRDFN,LRSS,LRIDT,0))
WRITE !,"Data not found."
GOTO LAB
+2 IF ^LAR("Z",LRDFN,LRSS,LRIDT,0)=^LR(LRDFN,LRSS,LRIDT,0)
KILL ^LAR("Z",LRDFN,LRSS,LRIDT),^LR(LRDFN,LRSS,LRIDT)
SET ^LR(LRDFN,"T",P1,0)=P1
GOTO LAB
+3 WRITE !,"^LAR and ^LR don't match, Data not purged.",!," LRDFN = ",LRDFN_" Sub Script = "_LRSS_" LRIDT = "_LRIDT
+4 WRITE !?4,"^LR("_LRDFN_","_LRSS_","_LRIDT_",0) = ",^LR(LRDFN,LRSS,LRIDT,0)
+5 WRITE !,"^LAR(""Z"","_LRDFN_","_LRSS_","_LRIDT_",0) = ",^LAR("Z",LRDFN,LRSS,LRIDT,0)
+6 KILL ^LAR("Z",LRDFN,LRSS,LRIDT)
+7 GOTO LAB
+8 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
