| 1 | RMPFQS1 ;DDC/KAW-CONTINUATION OF RMPFQS [ 08/25/97 12:02 PM ]
|
|---|
| 2 | ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8**;MAY 30, 1995
|
|---|
| 3 | PURGE ;; input: RMPFP
|
|---|
| 4 | ;;output; RMPFCX
|
|---|
| 5 | S RMPFORD="S",RMPFTP="B",RMPFCX=0
|
|---|
| 6 | S RMPF=$O(^RMPF(791810.5,"C",RMPFMENU,0)) D HEAD:$D(RMPFL)
|
|---|
| 7 | S RMPFX=0,DIK="^RMPF(791810,"
|
|---|
| 8 | F S RMPFX=$O(^RMPF(791810,RMPFX)) Q:'RMPFX D KILL Q:$D(RMPFOUT)
|
|---|
| 9 | I RMPFCX=0 W:'$D(ZTSK) !!,"*** NO ORDERS TO PURGE ***" G PURGEE
|
|---|
| 10 | W:'$D(ZTSK) !!,"Number of Orders to be Purged: ",RMPFCX G PURGEE
|
|---|
| 11 | D:$D(IO("S")) ^%ZISC
|
|---|
| 12 | PURGEE K I,DIK,DIC,RMPFTP,RMPFORD,I,RMPFOUT,RMPFQUT,RMPFX,X,RMPF Q
|
|---|
| 13 | KILL ;; input: RMPFX,RMPFP,RMPFL,DIK,RMPF
|
|---|
| 14 | ;;output: None
|
|---|
| 15 | Q:'$D(^RMPF(791810,RMPFX,0)) S S0=^(0),X=$P(S0,U,15) Q:X'=RMPF
|
|---|
| 16 | S RMPFST=$P(S0,U,3) I 'RMPFST K S0,RMPFST Q
|
|---|
| 17 | I '$D(RMPFP(RMPFST)) K S0,RMPFST Q
|
|---|
| 18 | S RMPFTD=$P(S0,U,6),X1=DT,X2="-"_RMPFP(RMPFST) S:'X2 X2=-30 D C^%DTC
|
|---|
| 19 | G KILLE:RMPFTD>X
|
|---|
| 20 | I '$D(RMPFL) S DA=RMPFX D ^DIK S RMPFCX=RMPFCX+1
|
|---|
| 21 | I $D(RMPFL) D SUB^RMPFDS1 D
|
|---|
| 22 | .I IOST?1"C-".E,$Y>20 W !!,"Enter <RETURN> to continue or <^> to exit." D READ^RMPFQS D HEAD:'$D(RMPFOUT)
|
|---|
| 23 | .I IOST?1"P-".E,$Y>(IOSL-5) D HEAD
|
|---|
| 24 | KILLE K S0,RMPFST,RMPFTD,X,RMPFST,X1,X2,DA,Y,%,RMPFS,T,J,RMPFSD,RMPFSSN
|
|---|
| 25 | K RMPFNAM,RMPFDOB,RMPFDOD,RMPFMGG,DFN Q
|
|---|
| 26 | BATCH ;; input: None
|
|---|
| 27 | ;;output: None
|
|---|
| 28 | S BT=0
|
|---|
| 29 | B1 S BT=$O(^RMPF(791812,BT)) G BATCHE:'BT,B1:'$D(^(BT,0)) S ST=$P(^(0),U,2) G B1:ST'=3 S PT=0
|
|---|
| 30 | B2 S PT=$O(^RMPF(791812,BT,101,PT)) I 'PT D KILBAT G B1
|
|---|
| 31 | G B2:'$D(^RMPF(791812,BT,101,PT,0)) S PX=$P(^(0),U,1)
|
|---|
| 32 | G B2:'$D(^RMPF(791810,PX,0)) S SX=$P(^(0),U,3)
|
|---|
| 33 | G B2:SX>4,B1
|
|---|
| 34 | BATCHE K BT,PT,PX,SX,ST Q
|
|---|
| 35 | KILBAT S DA=BT,DIK="^RMPF(791812," D ^DIK
|
|---|
| 36 | Q
|
|---|
| 37 | HEAD W @IOF,!?30,"ORDERS TO BE PURGED"
|
|---|
| 38 | D HEADS1^RMPFDS1
|
|---|
| 39 | Q
|
|---|
