| 1 | PRCFPR2 ;WISC/LDB-Purge stacked document listing ;7/13/93 3:10 PM
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | PURGE ;Allow deletion from file 421.8 by date
|
|---|
| 5 | ;
|
|---|
| 6 | N DIR,DIC,DIE,DIK,X,Y
|
|---|
| 7 | S PRCF("X")="AS" D ^PRCFSITE Q:'%
|
|---|
| 8 | I '$D(^PRC(421.8,"AD")) W !,"THERE ARE NO PRINTED RECORDS TO PURGE" Q
|
|---|
| 9 | S DIR(0)="YO",DIR("B")="NO",DIR("A")="Purge all PRINTED documents from the listing" D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT S ALL=Y G:Y DEL
|
|---|
| 10 | S DIR("A")="Begin with which date",DIR("?",1)="Time is optional.",DIR("?")=" Enter the date to start range-",DIR("B")=$$DATE($O(^PRC(421.8,"AD",0)))
|
|---|
| 11 | S DIR(0)="DO^"_$O(^PRC(421.8,"AD",0))_":"_(DT+.9999)_":EXT" D ^DIR S:'Y DATE1=$O(^PRC(421.8,"AD",0)) G:$D(DTOUT)!$D(DUOUT) EXIT
|
|---|
| 12 | S:Y DATE1=Y
|
|---|
| 13 | W ! K DIR S DIR("A")="End with which date",DIR("?",1)="Time is optional.",DIR("?")=" Enter the date that will end the range-"
|
|---|
| 14 | D NOW^%DTC S %=$E(%,1,12) S DIR(0)="DO^"_DATE1_":"_(DT+.9999)_":EXT",DIR("B")=$$DATE(%) D ^DIR G:$D(DIRUT) EXIT S DATE2=Y,Y=0
|
|---|
| 15 | I 'ALL,'DATE1 W !!,"NO RECORDS WERE DELETED" G EXIT
|
|---|
| 16 | DEL S DAT=$S('ALL:(DATE1-.0001),1:0),DATE2=$S(ALL:9999999.99,'ALL&$P(DATE2,"."):DATE2,'ALL&'$P(DATE2,"."):DATE2_".9999",1:9999999.99)
|
|---|
| 17 | F S DAT=$O(^PRC(421.8,"AD",DAT)) Q:'DAT!(DAT>(DATE2)) D
|
|---|
| 18 | .S DA=0 F S DA=$O(^PRC(421.8,"AD",DAT,DA)) Q:'DA I $P($G(^PRC(421.8,DA,0)),"^",8)=PRC("SITE") S DIK="^PRC(421.8," D ^DIK
|
|---|
| 19 | D EXIT Q
|
|---|
| 20 | ;
|
|---|
| 21 | ;
|
|---|
| 22 | DATE(Y) D DD^%DT S DATE=Y
|
|---|
| 23 | Q DATE
|
|---|
| 24 | ;
|
|---|
| 25 | EXIT K %,ALL,D,DA,DAT,DATE,DATE1,DATE2,DAYS,DIK,DIR,DIRUT,DTOUT,DUOUT,FTYPE,SITE,X1,X2 Q
|
|---|
| 26 | ;
|
|---|
| 27 | ;
|
|---|
| 28 | ;
|
|---|
| 29 | QD ;Called from option PRCFA STACK DOCUMENTS PURGE (queued as background job)
|
|---|
| 30 | ;DAYS to retain is set in file 411 for PRINTER USE STACK DOCUMENTS
|
|---|
| 31 | ;DEFAULT DAYS IS 7
|
|---|
| 32 | D DT^DICRW
|
|---|
| 33 | S SITE=0 F S SITE=$O(^PRC(411,SITE)) Q:'SITE D
|
|---|
| 34 | .S PRTDA=0 F S PRTDA=$O(^PRC(411,SITE,2,PRTDA)) Q:'PRTDA I $P($G(^(PRTDA,0)),"^")?1"F".E D
|
|---|
| 35 | ..S FTYPE=$P(^PRC(411,SITE,2,PRTDA,0),"^") Q:"FR"'[FTYPE S FTYPE=$S(FTYPE="FR":2,FTYPE="F":"13",1:""),DAYS=$P(^PRC(411,SITE,2,PRTDA,0),"^",4) D
|
|---|
| 36 | ...S X2=$S('DAYS:-7,1:-DAYS),X1=DT D C^%DTC S DATE2=(X-1)+.9999
|
|---|
| 37 | ...S DAT=0 F S DAT=$O(^PRC(421.8,"AD",DAT)) Q:'DAT!(DAT>DATE2) D
|
|---|
| 38 | ....S DA=0 F S DA=$O(^PRC(421.8,"AD",DAT,DA)) Q:'DA I FTYPE[(+$P($G(^PRC(421.8,DA,0)),"^",2)),$P($G(^(0)),"^",8)=SITE D PRG
|
|---|
| 39 | Q
|
|---|
| 40 | PRG S DIK="^PRC(421.8," D ^DIK Q
|
|---|
