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)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACP 992 printed Oct 16, 2024@18:07:15 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
