Routine: LRACP

LRACP ;SLC/DCM - CUMULATIVE PURGE ;2/19/91  10:17 ;

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

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACP   992     printed  Mar 13, 2025@21:10:51                                                                                                                                                                                                        Page 2

LRACP     ;SLC/DCM - CUMULATIVE PURGE ;2/19/91  10:17 ;

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

LRACP.m