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

Last change on this file since 1000 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1RMPFQS ;DDC/KAW-PURGE ORDERS; [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
3RMPFSET I '$D(RMPFMENU) D MENU^RMPFUTL I '$D(RMPFMENU) W !!,$C(7),"*** A MENU SELECTION MUST BE MADE ***" Q ;;RMPFMENU must be defined
4 I '$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS) D ^RMPFUTL Q:'$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS)
5 W @IOF,!,"PURGE ORDERS",!!?23,"*** WARNING ***"
6 W !!,"This routine will permanently purge orders from the disk."
7 W !,"The number of days to retain orders with a status that can be purged"
8 W !,"is controlled by the parameter file. If a status has no entry in the"
9 W !,"parameter file, it will be purged 30 days after the last action on the order."
10 W !!,"Only orders with one of the following statuses will be purged: ",! K RM
11 F IX=1:1 S X=$T(STATUS+IX) Q:X="" D
12 .S A=$P(X,";",3),B=$P(X,";",4),C=$P(X,";",5),D=$P(X,";",6)
13 .I RMPFMENU=10 Q:A="R"
14 .S E=$P(RMPFSYS(1),U,D) S:E="" E=30
15 .W !?3,"<",A,"> ",B,?35,"More than ",E," days since last action."
16 .S RMPF(A)=C_U_E
17STATS W !!,"Enter an <*> to purge all statuses or status(es) selected by letter(s): " D READ G END:$D(RMPFOUT)
18STATS1 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
19 G END:Y="" K RMPFP
20 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)
21 G VIEW:Y="*"
22 F I=1:1 S X=$P(Y,",",I) Q:X="" D I $D(RMPFOUT) S RMPFQUT="" G STATS1
23 .I '$D(RMPF(X)) S RMPFOUT="" Q
24 .S W=$P(RMPF(X),U,1),RMPFP(W)=$P(RMPF(X),U,2) K W
25VIEW W !!,"<P>rint orders to be purged or <RETURN> to continue: " K RMPFL
26 D READ G END:$D(RMPFOUT)
27VIEW1 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
28 G ASK:Y="" S Y=$E(Y,1) I "Pp"'[Y S RMPFQUT="" G VIEW1
29 S RMPFL="" D QUE K RMPFL G ASK:'$D(RMPFCX)
30ASK I $D(RMPFCX) G END:'RMPFCX
31 W !!!!,"Do you wish to purge these orders now? NO// " D READ
32 G END:$D(RMPFOUT)
33ASK1 I $D(RMPFQUT) D G ASK
34 .W !!,"Enter <Y> to permanently purge old orders with one of the following",!,"statues:",!
35 .S X=0 F S X=$O(RMPFP(X)) Q:'X I $D(^RMPF(791810.2,X,0)) W !,$P(^(0),U,1)
36 S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G ASK1
37 G END:"nN"[Y
38SURE W !!,"Are you sure? NO// " D READ
39 G END:$D(RMPFOUT)
40SURE1 I $D(RMPFQUT) W !!,"Enter <Y> to begin the purge, <N> or <RETURN> to exit." G SURE
41 K RMPFL S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G SURE1
42 G END:"nN"[Y S RMPFCX=0,ZTIO="",ZTRTN="RUN^RMPFQS",ZTSAVE("RM*")=""
43 S ZTDESC="PURGE ROES FILES" D ^%ZTLOAD W !!,"*** Request Queued ***"
44END K %XX,%YY,A,B,C,D,E,IX,POP,RMPF,RMPFP,Y,ZTSK,RMPFCX,I,%X,%Y Q
45RUN ;; input: RMPFP
46 ;;output: None
47 S X="NOW",%DT="T" D ^%DT S TD=Y
48 S DIE="^RMPF(791813,",DA=RMPFSTAN,DR="2.03////"_DUZ_";2.04////"_TD
49 D ^DIE,PURGE^RMPFQS1,BATCH^RMPFQS1
50 K RMPFP,RMPFS,ZTSK,%H,%T,Y,TD,%DT,DIE,DR,DA,D,D0,DI,DQ Q
51READ K RMPFOUT,RMPFQUT
52 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
53 I Y?1"^".E S (RMPFOUT,Y)="" Q
54 S:Y?1"?".E (RMPFQUT,Y)=""
55 Q
56QUE W ! S %ZIS="NPQ" D ^%ZIS G END:POP
57 I IO=IO(0),'$D(IO("S")) D PURGE^RMPFQS1 Q
58 I $D(IO("S")) S %ZIS="",IOP=ION D ^%ZIS D PURGE^RMPFQS1 Q
59 S ZTRTN="PURGE^RMPFQS1",ZTDESC="ROES FILE PURGE",ZTIO=ION,ZTSAVE("RM*")=""
60 D ^%ZTLOAD,HOME^%ZIS
61 W:$D(ZTSK) !!,"*** Request Queued ***" H 2
62 Q
63STATUS ;;Statuses to purge
64 ;;C;COMPLETE;8;4
65 ;;D;DISAPPROVED;7;2
66 ;;E;ERROR;6;3
67 ;;I;INCOMPLETE;1;1
68 ;;N;CANCELED;11;6
69 ;;R;ADJUSTMENT REJECTED;10;5
Note: See TracBrowser for help on using the repository browser.