- LRARCHK ; IHS/DIR/AAB - REMOVE OLD LAB DATA 12/14/87 15:46 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**59**;Sep 27, 1994
- Q
- EN ;from LRARCHIV
- 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
- LRARCHK ; IHS/DIR/AAB - REMOVE OLD LAB DATA 12/14/87 15:46 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**59**;Sep 27, 1994
- +3 QUIT
- EN ;from LRARCHIV
- +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