| 1 | LRARCHK ;SLC/RWF - REMOVE OLD LAB DATA ; 12/14/87 15:46 ;
|
|---|
| 2 | ;;5.2;LAB SERVICE;**59**;Sep 27, 1994
|
|---|
| 3 | Q
|
|---|
| 4 | EN ;from LRARCHIV
|
|---|
| 5 | U IO W @IOF,"START OF PURGE PASS" D STAMP^LRX
|
|---|
| 6 | S LRDFN=0
|
|---|
| 7 | DFN S LRDFN=$O(^LAR("Z",LRDFN)) G END:LRDFN="" W "."
|
|---|
| 8 | F LRSS="CH","MI" I $O(^LAR("Z",LRDFN,LRSS,0)) S LRIDT=0,C1=1 D LAB,UPDT
|
|---|
| 9 | S ^LAB(69.9,1,"PURGE LRDFN")=LRDFN G DFN
|
|---|
| 10 | LAB S LRIDT=$O(^LAR("Z",LRDFN,LRSS,LRIDT)) Q:LRIDT<1
|
|---|
| 11 | IF '$D(^LR(LRDFN,LRSS,LRIDT,0)) W !,"Data not found." G LAB
|
|---|
| 12 | 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
|
|---|
| 13 | W !,"^LAR and ^LR don't match, Data not purged.",!," LRDFN = ",LRDFN_" Sub Script = "_LRSS_" LRIDT = "_LRIDT
|
|---|
| 14 | W !?4,"^LR("_LRDFN_","_LRSS_","_LRIDT_",0) = ",^LR(LRDFN,LRSS,LRIDT,0)
|
|---|
| 15 | W !,"^LAR(""Z"","_LRDFN_","_LRSS_","_LRIDT_",0) = ",^LAR("Z",LRDFN,LRSS,LRIDT,0)
|
|---|
| 16 | K ^LAR("Z",LRDFN,LRSS,LRIDT)
|
|---|
| 17 | G LAB
|
|---|
| 18 | Q
|
|---|
| 19 | UPDT S X=0,LRCNT=0
|
|---|
| 20 | F I=0:0 S X=$O(^LR(LRDFN,LRSS,X)) Q:X<1 S LRCNT=LRCNT+1
|
|---|
| 21 | I LRCNT=0 S ^LR(LRDFN,LRSS,0)=$S(LRSS="CH":"^63.04D",1:"^63.05DA") Q
|
|---|
| 22 | S $P(^LR(LRDFN,LRSS,0),U,4)=LRCNT
|
|---|
| 23 | Q
|
|---|
| 24 | END W !!,"**PURGE PASS DONE ** " D STAMP^LRX Q ;W @IOF G H^XUS
|
|---|
