- 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 Feb 18, 2025@23:59:53 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
