RMPFQS ;DDC/KAW-PURGE ORDERS; [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
RMPFSET I '$D(RMPFMENU) D MENU^RMPFUTL I '$D(RMPFMENU) W !!,$C(7),"*** A MENU SELECTION MUST BE MADE ***" Q ;;RMPFMENU must be defined
I '$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS) D ^RMPFUTL Q:'$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS)
W @IOF,!,"PURGE ORDERS",!!?23,"*** WARNING ***"
W !!,"This routine will permanently purge orders from the disk."
W !,"The number of days to retain orders with a status that can be purged"
W !,"is controlled by the parameter file. If a status has no entry in the"
W !,"parameter file, it will be purged 30 days after the last action on the order."
W !!,"Only orders with one of the following statuses will be purged: ",! K RM
F IX=1:1 S X=$T(STATUS+IX) Q:X="" D
.S A=$P(X,";",3),B=$P(X,";",4),C=$P(X,";",5),D=$P(X,";",6)
.I RMPFMENU=10 Q:A="R"
.S E=$P(RMPFSYS(1),U,D) S:E="" E=30
.W !?3,"<",A,"> ",B,?35,"More than ",E," days since last action."
.S RMPF(A)=C_U_E
STATS W !!,"Enter an <*> to purge all statuses or status(es) selected by letter(s): " D READ G END:$D(RMPFOUT)
STATS1 I $D(RMPFQUT) W !!,"Enter an <*> to purge all orders with a status listed above or",!?6,"the letter or letters to the left of each status separated by commas",!?6,"to select specific statuses." G STATS
G END:Y="" K RMPFP
I Y="*" S X=0 F S X=$O(RMPF(X)) Q:X="" S Y1=$P(RMPF(X),U,1),RMPFP(Y1)=$P(RMPF(X),U,2)
G VIEW:Y="*"
F I=1:1 S X=$P(Y,",",I) Q:X="" D I $D(RMPFOUT) S RMPFQUT="" G STATS1
.I '$D(RMPF(X)) S RMPFOUT="" Q
.S W=$P(RMPF(X),U,1),RMPFP(W)=$P(RMPF(X),U,2) K W
VIEW W !!,"<P>rint orders to be purged or <RETURN> to continue: " K RMPFL
D READ G END:$D(RMPFOUT)
VIEW1 I $D(RMPFQUT) W !!,"Enter a <P> to print a list of the orders to be purged or",!?8,"<RETURN> to continue with the process." G VIEW
G ASK:Y="" S Y=$E(Y,1) I "Pp"'[Y S RMPFQUT="" G VIEW1
S RMPFL="" D QUE K RMPFL G ASK:'$D(RMPFCX)
ASK I $D(RMPFCX) G END:'RMPFCX
W !!!!,"Do you wish to purge these orders now? NO// " D READ
G END:$D(RMPFOUT)
ASK1 I $D(RMPFQUT) D G ASK
.W !!,"Enter <Y> to permanently purge old orders with one of the following",!,"statues:",!
.S X=0 F S X=$O(RMPFP(X)) Q:'X I $D(^RMPF(791810.2,X,0)) W !,$P(^(0),U,1)
S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G ASK1
G END:"nN"[Y
SURE W !!,"Are you sure? NO// " D READ
G END:$D(RMPFOUT)
SURE1 I $D(RMPFQUT) W !!,"Enter <Y> to begin the purge, <N> or <RETURN> to exit." G SURE
K RMPFL S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G SURE1
G END:"nN"[Y S RMPFCX=0,ZTIO="",ZTRTN="RUN^RMPFQS",ZTSAVE("RM*")=""
S ZTDESC="PURGE ROES FILES" D ^%ZTLOAD W !!,"*** Request Queued ***"
END K %XX,%YY,A,B,C,D,E,IX,POP,RMPF,RMPFP,Y,ZTSK,RMPFCX,I,%X,%Y Q
RUN ;; input: RMPFP
;;output: None
S X="NOW",%DT="T" D ^%DT S TD=Y
S DIE="^RMPF(791813,",DA=RMPFSTAN,DR="2.03////"_DUZ_";2.04////"_TD
D ^DIE,PURGE^RMPFQS1,BATCH^RMPFQS1
K RMPFP,RMPFS,ZTSK,%H,%T,Y,TD,%DT,DIE,DR,DA,D,D0,DI,DQ Q
READ K RMPFOUT,RMPFQUT
R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
I Y?1"^".E S (RMPFOUT,Y)="" Q
S:Y?1"?".E (RMPFQUT,Y)=""
Q
QUE W ! S %ZIS="NPQ" D ^%ZIS G END:POP
I IO=IO(0),'$D(IO("S")) D PURGE^RMPFQS1 Q
I $D(IO("S")) S %ZIS="",IOP=ION D ^%ZIS D PURGE^RMPFQS1 Q
S ZTRTN="PURGE^RMPFQS1",ZTDESC="ROES FILE PURGE",ZTIO=ION,ZTSAVE("RM*")=""
D ^%ZTLOAD,HOME^%ZIS
W:$D(ZTSK) !!,"*** Request Queued ***" H 2
Q
STATUS ;;Statuses to purge
;;C;COMPLETE;8;4
;;D;DISAPPROVED;7;2
;;E;ERROR;6;3
;;I;INCOMPLETE;1;1
;;N;CANCELED;11;6
;;R;ADJUSTMENT REJECTED;10;5
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFQS 3618 printed Nov 22, 2024@17:46:53 Page 2
RMPFQS ;DDC/KAW-PURGE ORDERS; [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
RMPFSET ;;RMPFMENU must be defined
IF '$DATA(RMPFMENU)
DO MENU^RMPFUTL
IF '$DATA(RMPFMENU)
WRITE !!,$CHAR(7),"*** A MENU SELECTION MUST BE MADE ***"
QUIT
+1 IF '$DATA(RMPFSTAN)!'$DATA(RMPFDAT)!'$DATA(RMPFSYS)
DO ^RMPFUTL
if '$DATA(RMPFSTAN)!'$DATA(RMPFDAT)!'$DATA(RMPFSYS)
QUIT
+2 WRITE @IOF,!,"PURGE ORDERS",!!?23,"*** WARNING ***"
+3 WRITE !!,"This routine will permanently purge orders from the disk."
+4 WRITE !,"The number of days to retain orders with a status that can be purged"
+5 WRITE !,"is controlled by the parameter file. If a status has no entry in the"
+6 WRITE !,"parameter file, it will be purged 30 days after the last action on the order."
+7 WRITE !!,"Only orders with one of the following statuses will be purged: ",!
KILL RM
+8 FOR IX=1:1
SET X=$TEXT(STATUS+IX)
if X=""
QUIT
Begin DoDot:1
+9 SET A=$PIECE(X,";",3)
SET B=$PIECE(X,";",4)
SET C=$PIECE(X,";",5)
SET D=$PIECE(X,";",6)
+10 IF RMPFMENU=10
if A="R"
QUIT
+11 SET E=$PIECE(RMPFSYS(1),U,D)
if E=""
SET E=30
+12 WRITE !?3,"<",A,"> ",B,?35,"More than ",E," days since last action."
+13 SET RMPF(A)=C_U_E
End DoDot:1
STATS WRITE !!,"Enter an <*> to purge all statuses or status(es) selected by letter(s): "
DO READ
if $DATA(RMPFOUT)
GOTO END
STATS1 IF $DATA(RMPFQUT)
WRITE !!,"Enter an <*> to purge all orders with a status listed above or",!?6,"the letter or letters to the left of each status separated by commas",!?6,"to select specific statuses."
GOTO STATS
+1 if Y=""
GOTO END
KILL RMPFP
+2 IF Y="*"
SET X=0
FOR
SET X=$ORDER(RMPF(X))
if X=""
QUIT
SET Y1=$PIECE(RMPF(X),U,1)
SET RMPFP(Y1)=$PIECE(RMPF(X),U,2)
+3 if Y="*"
GOTO VIEW
+4 FOR I=1:1
SET X=$PIECE(Y,",",I)
if X=""
QUIT
Begin DoDot:1
+5 IF '$DATA(RMPF(X))
SET RMPFOUT=""
QUIT
+6 SET W=$PIECE(RMPF(X),U,1)
SET RMPFP(W)=$PIECE(RMPF(X),U,2)
KILL W
End DoDot:1
IF $DATA(RMPFOUT)
SET RMPFQUT=""
GOTO STATS1
VIEW WRITE !!,"<P>rint orders to be purged or <RETURN> to continue: "
KILL RMPFL
+1 DO READ
if $DATA(RMPFOUT)
GOTO END
VIEW1 IF $DATA(RMPFQUT)
WRITE !!,"Enter a <P> to print a list of the orders to be purged or",!?8,"<RETURN> to continue with the process."
GOTO VIEW
+1 if Y=""
GOTO ASK
SET Y=$EXTRACT(Y,1)
IF "Pp"'[Y
SET RMPFQUT=""
GOTO VIEW1
+2 SET RMPFL=""
DO QUE
KILL RMPFL
if '$DATA(RMPFCX)
GOTO ASK
ASK IF $DATA(RMPFCX)
if 'RMPFCX
GOTO END
+1 WRITE !!!!,"Do you wish to purge these orders now? NO// "
DO READ
+2 if $DATA(RMPFOUT)
GOTO END
ASK1 IF $DATA(RMPFQUT)
Begin DoDot:1
+1 WRITE !!,"Enter <Y> to permanently purge old orders with one of the following",!,"statues:",!
+2 SET X=0
FOR
SET X=$ORDER(RMPFP(X))
if 'X
QUIT
IF $DATA(^RMPF(791810.2,X,0))
WRITE !,$PIECE(^(0),U,1)
End DoDot:1
GOTO ASK
+3 if Y=""
SET Y="N"
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO ASK1
+4 if "nN"[Y
GOTO END
SURE WRITE !!,"Are you sure? NO// "
DO READ
+1 if $DATA(RMPFOUT)
GOTO END
SURE1 IF $DATA(RMPFQUT)
WRITE !!,"Enter <Y> to begin the purge, <N> or <RETURN> to exit."
GOTO SURE
+1 KILL RMPFL
if Y=""
SET Y="N"
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO SURE1
+2 if "nN"[Y
GOTO END
SET RMPFCX=0
SET ZTIO=""
SET ZTRTN="RUN^RMPFQS"
SET ZTSAVE("RM*")=""
+3 SET ZTDESC="PURGE ROES FILES"
DO ^%ZTLOAD
WRITE !!,"*** Request Queued ***"
END KILL %XX,%YY,A,B,C,D,E,IX,POP,RMPF,RMPFP,Y,ZTSK,RMPFCX,I,%X,%Y
QUIT
RUN ;; input: RMPFP
+1 ;;output: None
+2 SET X="NOW"
SET %DT="T"
DO ^%DT
SET TD=Y
+3 SET DIE="^RMPF(791813,"
SET DA=RMPFSTAN
SET DR="2.03////"_DUZ_";2.04////"_TD
+4 DO ^DIE
DO PURGE^RMPFQS1
DO BATCH^RMPFQS1
+5 KILL RMPFP,RMPFS,ZTSK,%H,%T,Y,TD,%DT,DIE,DR,DA,D,D0,DI,DQ
QUIT
READ KILL RMPFOUT,RMPFQUT
+1 READ Y:DTIME
IF '$TEST
WRITE $CHAR(7)
READ Y:5
if Y="."
GOTO READ
if '$TEST
SET Y=U
+2 IF Y?1"^".E
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
QUE WRITE !
SET %ZIS="NPQ"
DO ^%ZIS
if POP
GOTO END
+1 IF IO=IO(0)
IF '$DATA(IO("S"))
DO PURGE^RMPFQS1
QUIT
+2 IF $DATA(IO("S"))
SET %ZIS=""
SET IOP=ION
DO ^%ZIS
DO PURGE^RMPFQS1
QUIT
+3 SET ZTRTN="PURGE^RMPFQS1"
SET ZTDESC="ROES FILE PURGE"
SET ZTIO=ION
SET ZTSAVE("RM*")=""
+4 DO ^%ZTLOAD
DO HOME^%ZIS
+5 if $DATA(ZTSK)
WRITE !!,"*** Request Queued ***"
HANG 2
+6 QUIT
STATUS ;;Statuses to purge
+1 ;;C;COMPLETE;8;4
+2 ;;D;DISAPPROVED;7;2
+3 ;;E;ERROR;6;3
+4 ;;I;INCOMPLETE;1;1
+5 ;;N;CANCELED;11;6
+6 ;;R;ADJUSTMENT REJECTED;10;5
