source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFQS.m@ 1000

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