LRACP.m

LRACP ; IHS/DIR/FJE - CUMULATIVE PURGE 2/19/91 10:17 ;

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

 ;

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

QUEUE S U="^"

 W !,"This option uses the number of days entered in the GRACE PERIOD FOR CUMULATIVE",!,"field in the LABORATORY SITE file to identify and purge patient lab data from",!,"the cumulative file.",!

 W !?10,"The file is set for ( ",+$P(^LAB(69.9,1,0),U,12)," ) days ",!

 W !,"Are you sure you want to continue" S %=2 D YN^DICN I %=2!(%=-1) Q

 S ZTRTN="ENT^LRACP",ZTDESC="Cumulative Purge",ZTIO="" D ^%ZTLOAD Q

MORE I '$D(^LR(LRDFN,0)) K ^LAC("LRAC",LRDFN) Q

 S X=^LR(LRDFN,0),LRDPF=$P(X,U,2),DFN=$P(X,U,3) Q:$O(^LR(LRDFN,"CH",0))<LRDAYS

 I LRDPF=2 D PT^LRX Q:$L(LRWRD)

 K ^LAC("LRAC",LRDFN),^LAC("LRAC","B",LRDFN)

 Q

IDT S LRDFN=0 F  S LRDFN=$O(^LAC("LRAC",LRDFN)) Q:LRDFN<1  D MORE

 Q

ENT ;

 S U="^" S:$D(ZTQUEUED) ZTREQ="@"

 G:'$P(^LAB(69.9,1,0),U,12) CLEAN S X1=DT,X2=-$P(^(0),"^",12) D C^%DTC S LRDAYS=9999999-X_.5,LRXLR="LRAC"

 D IDT

CLEAN ;

 K LRDAYS,LRDFN,LRDPF,DFN

 Q

LRACP     ; IHS/DIR/FJE - CUMULATIVE PURGE 2/19/91 10:17 ;

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

 +2       ;

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

QUEUE      SET U="^"

 +1        WRITE !,"This option uses the number of days entered in the GRACE PERIOD FOR CUMULATIVE",!,"field in the LABORATORY SITE file to identify and purge patient lab data from",!,"the cumulative file.",!

 +2        WRITE !?10,"The file is set for ( ",+$PIECE(^LAB(69.9,1,0),U,12)," ) days ",!

 +3        WRITE !,"Are you sure you want to continue"

           SET %=2

           DO YN^DICN

           IF %=2!(%=-1)

               QUIT 

 +4        SET ZTRTN="ENT^LRACP"

           SET ZTDESC="Cumulative Purge"

           SET ZTIO=""

           DO ^%ZTLOAD

           QUIT 

MORE       IF '$DATA(^LR(LRDFN,0))

               KILL ^LAC("LRAC",LRDFN)

               QUIT 

 +1        SET X=^LR(LRDFN,0)

           SET LRDPF=$PIECE(X,U,2)

           SET DFN=$PIECE(X,U,3)

           IF $ORDER(^LR(LRDFN,"CH",0))<LRDAYS

               QUIT 

 +2        IF LRDPF=2

               DO PT^LRX

               IF $LENGTH(LRWRD)

                   QUIT 

 +3        KILL ^LAC("LRAC",LRDFN),^LAC("LRAC","B",LRDFN)

 +4        QUIT 

IDT        SET LRDFN=0

           FOR 

               SET LRDFN=$ORDER(^LAC("LRAC",LRDFN))

               IF LRDFN<1

                   QUIT 

               DO MORE

 +1        QUIT 

ENT       ;

 +1        SET U="^"

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        IF '$PIECE(^LAB(69.9,1,0),U,12)

               GOTO CLEAN

           SET X1=DT

           SET X2=-$PIECE(^(0),"^",12)

           DO C^%DTC

           SET LRDAYS=9999999-X_.5

           SET LRXLR="LRAC"

 +3        DO IDT

CLEAN     ;

 +1        KILL LRDAYS,LRDFN,LRDPF,DFN

 +2        QUIT