32 lines
1.3 KiB
Mathematica
32 lines
1.3 KiB
Mathematica
QACDELT ;HISC/CEW - Purge Contact Records ;2/10/95 11:06
|
|
;;2.0;Patient Representative;;07/25/1995
|
|
W !!!?32,"***WARNING***",!!?5,"This option purges all Patient Rep contact records with Dates of Contact",!?5,"that fall within the date range you select."
|
|
W !?5,"Once these records are purged, they cannot be recovered!",*7
|
|
ASK ;
|
|
W !!,"Are you sure you want to continue" S %=2 D YN^DICN
|
|
G:(%=-1)!(%=2) EXIT I '% W !!?5,"Please answer Y(es) or (N)o" G ASK
|
|
DATE ;
|
|
W !!,"Select the date range to purge."
|
|
D ^QAQDATE G:QAQQUIT EXIT I QAQNBEG>DT W !?5,"*** Beginning date must be today or earlier !! ***",*7 G DATE
|
|
K DIR S DIR(0)="Y",DIR("B")="NO"
|
|
S DIR("A")="Should I continue with the purge"
|
|
D ^DIR K DIR G:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) EXIT
|
|
I Y'>0 W !!?10,"No records purged!" G EXIT
|
|
S ZTRTN="ENTSK^QACDELT",ZTDTH=$H
|
|
S (ZTIO,ZTSAVE("QAQNBEG"),ZTSAVE("QAQNEND"))=""
|
|
S ZTDESC="Purge selected Patient Representative contact records"
|
|
D ^%ZTLOAD W !!,"Deletion request queued."
|
|
G EXIT
|
|
ENTSK ;
|
|
S QACDT=QAQNBEG-.0000001 F S QACDT=$O(^QA(745.1,"D",QACDT)) Q:(QACDT'>0)!(QACDT>QAQNEND)!(QACDT\1'?7N) D
|
|
. S QACD0=0 F S QACD0=$O(^QA(745.1,"D",QACDT,QACD0)) Q:QACD0'>0 D
|
|
.. K DA,DIK S DIK="^QA(745.1,",DA=QACD0 D ^DIK
|
|
.. Q
|
|
. Q
|
|
EXIT ;
|
|
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
|
|
K %,DA,DIK,QACDT,ZTSAVE,ZTIO,ZTDESC,ZTDTH,ZTRTN,QACD0,DIR,DIROUT
|
|
K DTOUT,DUOUT,Y
|
|
D K^QAQDATE
|
|
Q
|