RMPFQS1 ;DDC/KAW-CONTINUATION OF RMPFQS [ 08/25/97 12:02 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8**;MAY 30, 1995
PURGE ;; input: RMPFP
;;output; RMPFCX
S RMPFORD="S",RMPFTP="B",RMPFCX=0
S RMPF=$O(^RMPF(791810.5,"C",RMPFMENU,0)) D HEAD:$D(RMPFL)
S RMPFX=0,DIK="^RMPF(791810,"
F S RMPFX=$O(^RMPF(791810,RMPFX)) Q:'RMPFX D KILL Q:$D(RMPFOUT)
I RMPFCX=0 W:'$D(ZTSK) !!,"*** NO ORDERS TO PURGE ***" G PURGEE
W:'$D(ZTSK) !!,"Number of Orders to be Purged: ",RMPFCX G PURGEE
D:$D(IO("S")) ^%ZISC
PURGEE K I,DIK,DIC,RMPFTP,RMPFORD,I,RMPFOUT,RMPFQUT,RMPFX,X,RMPF Q
KILL ;; input: RMPFX,RMPFP,RMPFL,DIK,RMPF
;;output: None
Q:'$D(^RMPF(791810,RMPFX,0)) S S0=^(0),X=$P(S0,U,15) Q:X'=RMPF
S RMPFST=$P(S0,U,3) I 'RMPFST K S0,RMPFST Q
I '$D(RMPFP(RMPFST)) K S0,RMPFST Q
S RMPFTD=$P(S0,U,6),X1=DT,X2="-"_RMPFP(RMPFST) S:'X2 X2=-30 D C^%DTC
G KILLE:RMPFTD>X
I '$D(RMPFL) S DA=RMPFX D ^DIK S RMPFCX=RMPFCX+1
I $D(RMPFL) D SUB^RMPFDS1 D
.I IOST?1"C-".E,$Y>20 W !!,"Enter <RETURN> to continue or <^> to exit." D READ^RMPFQS D HEAD:'$D(RMPFOUT)
.I IOST?1"P-".E,$Y>(IOSL-5) D HEAD
KILLE K S0,RMPFST,RMPFTD,X,RMPFST,X1,X2,DA,Y,%,RMPFS,T,J,RMPFSD,RMPFSSN
K RMPFNAM,RMPFDOB,RMPFDOD,RMPFMGG,DFN Q
BATCH ;; input: None
;;output: None
S BT=0
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
B2 S PT=$O(^RMPF(791812,BT,101,PT)) I 'PT D KILBAT G B1
G B2:'$D(^RMPF(791812,BT,101,PT,0)) S PX=$P(^(0),U,1)
G B2:'$D(^RMPF(791810,PX,0)) S SX=$P(^(0),U,3)
G B2:SX>4,B1
BATCHE K BT,PT,PX,SX,ST Q
KILBAT S DA=BT,DIK="^RMPF(791812," D ^DIK
Q
HEAD W @IOF,!?30,"ORDERS TO BE PURGED"
D HEADS1^RMPFDS1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFQS1 1678 printed Apr 09, 2024@21:39:03 Page 2
RMPFQS1 ;DDC/KAW-CONTINUATION OF RMPFQS [ 08/25/97 12:02 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8**;MAY 30, 1995
PURGE ;; input: RMPFP
+1 ;;output; RMPFCX
+2 SET RMPFORD="S"
SET RMPFTP="B"
SET RMPFCX=0
+3 SET RMPF=$ORDER(^RMPF(791810.5,"C",RMPFMENU,0))
if $DATA(RMPFL)
DO HEAD
+4 SET RMPFX=0
SET DIK="^RMPF(791810,"
+5 FOR
SET RMPFX=$ORDER(^RMPF(791810,RMPFX))
if 'RMPFX
QUIT
DO KILL
if $DATA(RMPFOUT)
QUIT
+6 IF RMPFCX=0
if '$DATA(ZTSK)
WRITE !!,"*** NO ORDERS TO PURGE ***"
GOTO PURGEE
+7 if '$DATA(ZTSK)
WRITE !!,"Number of Orders to be Purged: ",RMPFCX
GOTO PURGEE
+8 if $DATA(IO("S"))
DO ^%ZISC
PURGEE KILL I,DIK,DIC,RMPFTP,RMPFORD,I,RMPFOUT,RMPFQUT,RMPFX,X,RMPF
QUIT
KILL ;; input: RMPFX,RMPFP,RMPFL,DIK,RMPF
+1 ;;output: None
+2 if '$DATA(^RMPF(791810,RMPFX,0))
QUIT
SET S0=^(0)
SET X=$PIECE(S0,U,15)
if X'=RMPF
QUIT
+3 SET RMPFST=$PIECE(S0,U,3)
IF 'RMPFST
KILL S0,RMPFST
QUIT
+4 IF '$DATA(RMPFP(RMPFST))
KILL S0,RMPFST
QUIT
+5 SET RMPFTD=$PIECE(S0,U,6)
SET X1=DT
SET X2="-"_RMPFP(RMPFST)
if 'X2
SET X2=-30
DO C^%DTC
+6 if RMPFTD>X
GOTO KILLE
+7 IF '$DATA(RMPFL)
SET DA=RMPFX
DO ^DIK
SET RMPFCX=RMPFCX+1
+8 IF $DATA(RMPFL)
DO SUB^RMPFDS1
Begin DoDot:1
+9 IF IOST?1"C-".E
IF $Y>20
WRITE !!,"Enter <RETURN> to continue or <^> to exit."
DO READ^RMPFQS
if '$DATA(RMPFOUT)
DO HEAD
+10 IF IOST?1"P-".E
IF $Y>(IOSL-5)
DO HEAD
End DoDot:1
KILLE KILL S0,RMPFST,RMPFTD,X,RMPFST,X1,X2,DA,Y,%,RMPFS,T,J,RMPFSD,RMPFSSN
+1 KILL RMPFNAM,RMPFDOB,RMPFDOD,RMPFMGG,DFN
QUIT
BATCH ;; input: None
+1 ;;output: None
+2 SET BT=0
B1 SET BT=$ORDER(^RMPF(791812,BT))
if 'BT
GOTO BATCHE
if '$DATA(^(BT,0))
GOTO B1
SET ST=$PIECE(^(0),U,2)
if ST'=3
GOTO B1
SET PT=0
B2 SET PT=$ORDER(^RMPF(791812,BT,101,PT))
IF 'PT
DO KILBAT
GOTO B1
+1 if '$DATA(^RMPF(791812,BT,101,PT,0))
GOTO B2
SET PX=$PIECE(^(0),U,1)
+2 if '$DATA(^RMPF(791810,PX,0))
GOTO B2
SET SX=$PIECE(^(0),U,3)
+3 if SX>4
GOTO B2
GOTO B1
BATCHE KILL BT,PT,PX,SX,ST
QUIT
KILBAT SET DA=BT
SET DIK="^RMPF(791812,"
DO ^DIK
+1 QUIT
HEAD WRITE @IOF,!?30,"ORDERS TO BE PURGED"
+1 DO HEADS1^RMPFDS1
+2 QUIT
