LRCHIVK.m

LRCHIVK ; IHS/DIR/FJE - REMOVE OLD LAB DATA 12/14/87 15:46 ;

 ;;5.2;LR;**1013**;JUL 15, 2002

 ;

 ;;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

LRCHIVK   ; IHS/DIR/FJE - REMOVE OLD LAB DATA 12/14/87 15:46 ;

 +1       ;;5.2;LR;**1013**;JUL 15, 2002

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4        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