| 1 | QACDELT ;HISC/CEW - Purge Contact Records ;2/10/95 11:06
|
|---|
| 2 | ;;2.0;Patient Representative;;07/25/1995
|
|---|
| 3 | 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."
|
|---|
| 4 | W !?5,"Once these records are purged, they cannot be recovered!",*7
|
|---|
| 5 | ASK ;
|
|---|
| 6 | W !!,"Are you sure you want to continue" S %=2 D YN^DICN
|
|---|
| 7 | G:(%=-1)!(%=2) EXIT I '% W !!?5,"Please answer Y(es) or (N)o" G ASK
|
|---|
| 8 | DATE ;
|
|---|
| 9 | W !!,"Select the date range to purge."
|
|---|
| 10 | D ^QAQDATE G:QAQQUIT EXIT I QAQNBEG>DT W !?5,"*** Beginning date must be today or earlier !! ***",*7 G DATE
|
|---|
| 11 | K DIR S DIR(0)="Y",DIR("B")="NO"
|
|---|
| 12 | S DIR("A")="Should I continue with the purge"
|
|---|
| 13 | D ^DIR K DIR G:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) EXIT
|
|---|
| 14 | I Y'>0 W !!?10,"No records purged!" G EXIT
|
|---|
| 15 | S ZTRTN="ENTSK^QACDELT",ZTDTH=$H
|
|---|
| 16 | S (ZTIO,ZTSAVE("QAQNBEG"),ZTSAVE("QAQNEND"))=""
|
|---|
| 17 | S ZTDESC="Purge selected Patient Representative contact records"
|
|---|
| 18 | D ^%ZTLOAD W !!,"Deletion request queued."
|
|---|
| 19 | G EXIT
|
|---|
| 20 | ENTSK ;
|
|---|
| 21 | S QACDT=QAQNBEG-.0000001 F S QACDT=$O(^QA(745.1,"D",QACDT)) Q:(QACDT'>0)!(QACDT>QAQNEND)!(QACDT\1'?7N) D
|
|---|
| 22 | . S QACD0=0 F S QACD0=$O(^QA(745.1,"D",QACDT,QACD0)) Q:QACD0'>0 D
|
|---|
| 23 | .. K DA,DIK S DIK="^QA(745.1,",DA=QACD0 D ^DIK
|
|---|
| 24 | .. Q
|
|---|
| 25 | . Q
|
|---|
| 26 | EXIT ;
|
|---|
| 27 | D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
|
|---|
| 28 | K %,DA,DIK,QACDT,ZTSAVE,ZTIO,ZTDESC,ZTDTH,ZTRTN,QACD0,DIR,DIROUT
|
|---|
| 29 | K DTOUT,DUOUT,Y
|
|---|
| 30 | D K^QAQDATE
|
|---|
| 31 | Q
|
|---|
