RMPFQS.m

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 ---RMPFQS   3618     printed  Mar 13, 2025@21:42                                                                                                                                                                                                         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