RMPR8PG ;PHX,HOIFO/JLT,SPS-PURGE 668 SUSPENSE FILE ; AUGUST 29, 1994
;;3.0;PROSTHETICS;**5,75,140,163,211**;Feb 09, 1996;Build 10
;
;02/03/06 Added code to delete the pointer in 664.1 field .05 when a
;record is purged.
;
EN D DIV4^RMPRSIT Q:$D(X)
I '$$CONFIRM(RMPRSITE,RMPR("STA")) S RDEL=0 G END ;RMPR*3.0*211
EN2 K %ZIS,IOP,ZTIO S %ZIS="MQ",%ZIS("B")="" D ^%ZIS G:POP END
;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN2
I $D(IO("Q")) S ZTRTN="EN1^RMPR8PG",ZTDESC="PURGE 668 SUSPENSE FILE" F RD="I","RMPRIEN","RMPRDT","ION","RMPR(","RMPRSITE" S ZTSAVE(RD)=""
I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"<REQUEST QUEUED!>" G EXIT
EN1 S (I,RMPRIEN,RDEL)=0,RMPRDT=$P(^RMPR(669.9,RMPRSITE,0),U,8) G:RMPRDT'>89 END
S X1=DT,X2=-RMPRDT D C^%DTC S RMPRDT=X I RMPRDT<$O(^RMPR(668,"B",""))!('$O(^RMPR(668,0))) G END
;RMPR*3.0*163 adds check to insure the 0 node is defined in DIP run
S DIS(0)="I $D(^RMPR(668,D0,0)),$P(^RMPR(668,D0,0),U,7)=RMPR(""STA"")",IOP=ION,DIC="^RMPR(668,",FLDS=".01;C1,1;C20;L17,2,3,6;C45;L15,5;C65,4;C1,7;C1",BY="5",FR=$S($D(^RMPR(668,"B")):$O(^RMPR(668,"B","")),1:2890101)
S TO=RMPRDT,DHD="Purge Suspense File Entries from Station/Division "_RMPR("STA") D EN1^DIP
N RMPR6641
F S RMPRIEN=$O(^RMPR(668,RMPRIEN)) Q:RMPRIEN'>0 I $P($G(^RMPR(668,RMPRIEN,0)),U,7)=RMPR("STA") I ($P(^RMPR(668,RMPRIEN,0),U,5))&($P(^(0),U,5)<RMPRDT) S DA=RMPRIEN,DIC="^RMPR(668," S DA=RMPRIEN,DIK=DIC D ^DIK D S RDEL=RDEL+1
. S RMPR6641=0 F S RMPR6641=$O(^RMPR(664.1,"SUS",DA,RMPR6641)) Q:RMPR6641'>0 D
.. I $D(^RMPR(664.1,RMPR6641,0)) S $P(^(0),U,8)=""
END I $G(RDEL)<1 W !!,"No Suspense entries purged."
I $G(RDEL)>1 W !!,RDEL," Suspense entries purged."
I $G(RDEL)=1 W !!,RDEL,"Suspense entry purged. "
EXIT ;common exit point
K I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,RMPR6641,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO D ^%ZISC
G AUDIT^RMPR8PG1 ;RMPR*3.0*163 Call to audit/remove file 668 'L' & 'L1' x-ref with pointer to null master rec
Q
CONFIRM(RMPRSITE,RMPRSTA) ;RMPR*3.0*211;display number of deletes and ask user to confirm to proceed with the Purge;
;Return 1 to proceed with purge, 0 to not proceed;
N I,RMPRIEN,RMPRDT,RMPRSN,EDEL,RMPRYN,RMPROLD,RMPRNEW,RMPRPD
S (I,RMPRIEN,EDEL)=0,RMPRSN=$P(^RMPR(669.9,RMPRSITE,0),U),RMPROLD=DT,RMPRNEW=0
;Check Suspense Purge value
S RMPRDT=$P(^RMPR(669.9,RMPRSITE,0),U,8) I RMPRDT'>89 D Q 0
.W !,"The SUSPENSE PURGE value in the PROSTHETICS SITE PARAMETER FILE for "
.W !,RMPRSN," is less than 90 days."
.W !,"The Suspense Purge cannot proceed unless the value is between 90 and "
.W !,"4,000 days (inclusive)."
.D RTN
S X1=DT,X2=-RMPRDT D C^%DTC S RMPRPD=X
;Check if file has 0 node and whether there are any entries
I RMPRPD<$O(^RMPR(668,"B",""))!('$O(^RMPR(668,0))) D Q 0
.W !,"There are no suspense records to be purged or the file has no 0 node."
.D RTN
;Scan suspense file to estimate how much will be deleted"
W !!,"The PROSTHETIC SUSPENSE file will now be scanned to estimate the number of"
W !,"records that will be purged. Depending on how long it has been since the last"
W !,"purge, it may take some time to determine the estimate.",!
F S RMPRIEN=$O(^RMPR(668,RMPRIEN)) Q:RMPRIEN'>0 I $P($G(^RMPR(668,RMPRIEN,0)),U,7)=RMPRSTA,($P(^RMPR(668,RMPRIEN,0),U,5))&($P(^(0),U,5)<RMPRPD) D
.S EDEL=EDEL+1,X=$P(^RMPR(668,RMPRIEN,0),U) S:X<RMPROLD RMPROLD=X S:X>RMPRNEW RMPRNEW=X
I EDEL'>0 W !,"There are currently no suspense records old enough to be purged." D RTN Q 0
;Display estimate of records to purged
W !,"For the ",RMPRSN,", there are currently ",EDEL
W !,"suspense records that will be purged based on the SUSPENSE PURGE value in the"
W !,"PROSTHETICS SITE PARAMETER FILE. The value is currently set to ",RMPRDT," days.",!
S Y=RMPROLD D DD^%DT S RMPROLD=$P(Y,"@"),Y=RMPRNEW D DD^%DT S RMPRNEW=$P(Y,"@")
W !,"The oldest record that will be purged was suspended on ",RMPROLD,"."
W !,"The most recent record to be purged was suspended on ",RMPRNEW,".",!
W !,"Once the purge runs, the entries purged are unrecoverable.",!
RMPRTP ;Ask user to confirm before initiating the purge
W !,"Are you sure you want to proceed with the purge? NO// " R RMPRYN:DTIME I '$T!(RMPRYN["^") Q 0
S:RMPRYN="" RMPRYN="N" S RMPRYN=$E(RMPRYN)
I "YyNn"'[RMPRYN W !!,"Enter YES to proceed with the purge. Otherwise, enter NO.",! G RMPRTP
I "Yy"'[RMPRYN Q 0
Q 1
RTN ;
R !,"Type < Enter > to continue: ",I:DTIME Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR8PG 4486 printed Dec 13, 2024@02:33:25 Page 2
RMPR8PG ;PHX,HOIFO/JLT,SPS-PURGE 668 SUSPENSE FILE ; AUGUST 29, 1994
+1 ;;3.0;PROSTHETICS;**5,75,140,163,211**;Feb 09, 1996;Build 10
+2 ;
+3 ;02/03/06 Added code to delete the pointer in 664.1 field .05 when a
+4 ;record is purged.
+5 ;
EN DO DIV4^RMPRSIT
if $DATA(X)
QUIT
+1 ;RMPR*3.0*211
IF '$$CONFIRM(RMPRSITE,RMPR("STA"))
SET RDEL=0
GOTO END
EN2 KILL %ZIS,IOP,ZTIO
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
GOTO END
+1 ;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN2
+2 IF $DATA(IO("Q"))
SET ZTRTN="EN1^RMPR8PG"
SET ZTDESC="PURGE 668 SUSPENSE FILE"
FOR RD="I","RMPRIEN","RMPRDT","ION","RMPR(","RMPRSITE"
SET ZTSAVE(RD)=""
+3 IF $DATA(IO("Q"))
KILL IO("Q")
DO ^%ZTLOAD
WRITE !,"<REQUEST QUEUED!>"
GOTO EXIT
EN1 SET (I,RMPRIEN,RDEL)=0
SET RMPRDT=$PIECE(^RMPR(669.9,RMPRSITE,0),U,8)
if RMPRDT'>89
GOTO END
+1 SET X1=DT
SET X2=-RMPRDT
DO C^%DTC
SET RMPRDT=X
IF RMPRDT<$ORDER(^RMPR(668,"B",""))!('$ORDER(^RMPR(668,0)))
GOTO END
+2 ;RMPR*3.0*163 adds check to insure the 0 node is defined in DIP run
+3 SET DIS(0)="I $D(^RMPR(668,D0,0)),$P(^RMPR(668,D0,0),U,7)=RMPR(""STA"")"
SET IOP=ION
SET DIC="^RMPR(668,"
SET FLDS=".01;C1,1;C20;L17,2,3,6;C45;L15,5;C65,4;C1,7;C1"
SET BY="5"
SET FR=$SELECT($DATA(^RMPR(668,"B")):$ORDER(^RMPR(668,"B","")),1:2890101)
+4 SET TO=RMPRDT
SET DHD="Purge Suspense File Entries from Station/Division "_RMPR("STA")
DO EN1^DIP
+5 NEW RMPR6641
+6 FOR
SET RMPRIEN=$ORDER(^RMPR(668,RMPRIEN))
if RMPRIEN'>0
QUIT
IF $PIECE($GET(^RMPR(668,RMPRIEN,0)),U,7)=RMPR("STA")
IF ($PIECE(^RMPR(668,RMPRIEN,0),U,5))&($PIECE(^(0),U,5)<RMPRDT)
SET DA=RMPRIEN
SET DIC="^RMPR(668,"
SET DA=RMPRIEN
SET DIK=DIC
DO ^DIK
Begin DoDot:1
+7 SET RMPR6641=0
FOR
SET RMPR6641=$ORDER(^RMPR(664.1,"SUS",DA,RMPR6641))
if RMPR6641'>0
QUIT
Begin DoDot:2
+8 IF $DATA(^RMPR(664.1,RMPR6641,0))
SET $PIECE(^(0),U,8)=""
End DoDot:2
End DoDot:1
SET RDEL=RDEL+1
END IF $GET(RDEL)<1
WRITE !!,"No Suspense entries purged."
+1 IF $GET(RDEL)>1
WRITE !!,RDEL," Suspense entries purged."
+2 IF $GET(RDEL)=1
WRITE !!,RDEL,"Suspense entry purged. "
EXIT ;common exit point
+1 KILL I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,RMPR6641,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO
DO ^%ZISC
+2 ;RMPR*3.0*163 Call to audit/remove file 668 'L' & 'L1' x-ref with pointer to null master rec
GOTO AUDIT^RMPR8PG1
+3 QUIT
CONFIRM(RMPRSITE,RMPRSTA) ;RMPR*3.0*211;display number of deletes and ask user to confirm to proceed with the Purge;
+1 ;Return 1 to proceed with purge, 0 to not proceed;
+2 NEW I,RMPRIEN,RMPRDT,RMPRSN,EDEL,RMPRYN,RMPROLD,RMPRNEW,RMPRPD
+3 SET (I,RMPRIEN,EDEL)=0
SET RMPRSN=$PIECE(^RMPR(669.9,RMPRSITE,0),U)
SET RMPROLD=DT
SET RMPRNEW=0
+4 ;Check Suspense Purge value
+5 SET RMPRDT=$PIECE(^RMPR(669.9,RMPRSITE,0),U,8)
IF RMPRDT'>89
Begin DoDot:1
+6 WRITE !,"The SUSPENSE PURGE value in the PROSTHETICS SITE PARAMETER FILE for "
+7 WRITE !,RMPRSN," is less than 90 days."
+8 WRITE !,"The Suspense Purge cannot proceed unless the value is between 90 and "
+9 WRITE !,"4,000 days (inclusive)."
+10 DO RTN
End DoDot:1
QUIT 0
+11 SET X1=DT
SET X2=-RMPRDT
DO C^%DTC
SET RMPRPD=X
+12 ;Check if file has 0 node and whether there are any entries
+13 IF RMPRPD<$ORDER(^RMPR(668,"B",""))!('$ORDER(^RMPR(668,0)))
Begin DoDot:1
+14 WRITE !,"There are no suspense records to be purged or the file has no 0 node."
+15 DO RTN
End DoDot:1
QUIT 0
+16 ;Scan suspense file to estimate how much will be deleted"
+17 WRITE !!,"The PROSTHETIC SUSPENSE file will now be scanned to estimate the number of"
+18 WRITE !,"records that will be purged. Depending on how long it has been since the last"
+19 WRITE !,"purge, it may take some time to determine the estimate.",!
+20 FOR
SET RMPRIEN=$ORDER(^RMPR(668,RMPRIEN))
if RMPRIEN'>0
QUIT
IF $PIECE($GET(^RMPR(668,RMPRIEN,0)),U,7)=RMPRSTA
IF ($PIECE(^RMPR(668,RMPRIEN,0),U,5))&($PIECE(^(0),U,5)<RMPRPD)
Begin DoDot:1
+21 SET EDEL=EDEL+1
SET X=$PIECE(^RMPR(668,RMPRIEN,0),U)
if X<RMPROLD
SET RMPROLD=X
if X>RMPRNEW
SET RMPRNEW=X
End DoDot:1
+22 IF EDEL'>0
WRITE !,"There are currently no suspense records old enough to be purged."
DO RTN
QUIT 0
+23 ;Display estimate of records to purged
+24 WRITE !,"For the ",RMPRSN,", there are currently ",EDEL
+25 WRITE !,"suspense records that will be purged based on the SUSPENSE PURGE value in the"
+26 WRITE !,"PROSTHETICS SITE PARAMETER FILE. The value is currently set to ",RMPRDT," days.",!
+27 SET Y=RMPROLD
DO DD^%DT
SET RMPROLD=$PIECE(Y,"@")
SET Y=RMPRNEW
DO DD^%DT
SET RMPRNEW=$PIECE(Y,"@")
+28 WRITE !,"The oldest record that will be purged was suspended on ",RMPROLD,"."
+29 WRITE !,"The most recent record to be purged was suspended on ",RMPRNEW,".",!
+30 WRITE !,"Once the purge runs, the entries purged are unrecoverable.",!
RMPRTP ;Ask user to confirm before initiating the purge
+1 WRITE !,"Are you sure you want to proceed with the purge? NO// "
READ RMPRYN:DTIME
IF '$TEST!(RMPRYN["^")
QUIT 0
+2 if RMPRYN=""
SET RMPRYN="N"
SET RMPRYN=$EXTRACT(RMPRYN)
+3 IF "YyNn"'[RMPRYN
WRITE !!,"Enter YES to proceed with the purge. Otherwise, enter NO.",!
GOTO RMPRTP
+4 IF "Yy"'[RMPRYN
QUIT 0
+5 QUIT 1
RTN ;
+1 READ !,"Type < Enter > to continue: ",I:DTIME
QUIT
