source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFQS1.m@ 701

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

initial load of WorldVistAEHR

File size: 1.6 KB
Line 
1RMPFQS1 ;DDC/KAW-CONTINUATION OF RMPFQS [ 08/25/97 12:02 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8**;MAY 30, 1995
3PURGE ;; 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
12PURGEE K I,DIK,DIC,RMPFTP,RMPFORD,I,RMPFOUT,RMPFQUT,RMPFX,X,RMPF Q
13KILL ;; 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
24KILLE K S0,RMPFST,RMPFTD,X,RMPFST,X1,X2,DA,Y,%,RMPFS,T,J,RMPFSD,RMPFSSN
25 K RMPFNAM,RMPFDOB,RMPFDOD,RMPFMGG,DFN Q
26BATCH ;; input: None
27 ;;output: None
28 S BT=0
29B1 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
30B2 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
34BATCHE K BT,PT,PX,SX,ST Q
35KILBAT S DA=BT,DIK="^RMPF(791812," D ^DIK
36 Q
37HEAD W @IOF,!?30,"ORDERS TO BE PURGED"
38 D HEADS1^RMPFDS1
39 Q
Note: See TracBrowser for help on using the repository browser.