| 1 | PRCGARP ;WIRMFO@ALTOONA/CTB IFCAP PURGE SCHEDULER ;12/10/97 9:52 AM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | W @IOF,!,"IFCAP PURGE SCHEDULER",!
|
|---|
| 5 | S %A="This option will allow you to purge IFCAP records which have previously been",%A(1)="identified and archived for your station.",%A(2)="Have you received and verified your archive micro fiche"
|
|---|
| 6 | D ^PRCFYN Q:%<0
|
|---|
| 7 | I %=2 D Q:%'=1
|
|---|
| 8 | . S %A="I will allow you to purge records which have not been archived, but it is",%A(1)="probably not a good idea to do so.",%A(2)="Are you sure you want to continue",%=2 D ^PRCFYN Q:%'=1
|
|---|
| 9 | . S %A="ARE YOU POSITIVE",%=2 D ^PRCFYN
|
|---|
| 10 | . QUIT
|
|---|
| 11 | S PRCF("X")="AS" D ^PRCFSITE Q:'%
|
|---|
| 12 | S TREC=$P(^PRC(443.9,0),"^",4),OGET=TREC\1000+1
|
|---|
| 13 | S MESSAGE="CREATING PURGEMASTER ENTRIES" K ITEMS
|
|---|
| 14 | D BEGIN^PRCGU
|
|---|
| 15 | S NEXT=0
|
|---|
| 16 | X F D S XCOUNT=XCOUNT+COUNT D PERCENT^PRCGU Q:'NEXT
|
|---|
| 17 | . S COUNT=0 F D QUIT:'NEXT!(COUNT>LREC)
|
|---|
| 18 | . . S GET=($S((LREC-COUNT)>OGET:OGET,1:(LREC-COUNT)+2))-1
|
|---|
| 19 | . . I GET<1 S GET=1
|
|---|
| 20 | . . S NEXT=$O(^PRC(443.9,NEXT)) Q:'NEXT D GET S COUNT=COUNT+ICOUNT
|
|---|
| 21 | . . S Z="",ROUTINE="START^PRCGARP1",VARIABLE=BEGDA_"-"_ENDA_";"_PRC("SITE") D ADD^PRCGPM1(ROUTINE,VARIABLE,.Z)
|
|---|
| 22 | . . QUIT
|
|---|
| 23 | . QUIT
|
|---|
| 24 | D END^PRCGU
|
|---|
| 25 | QUIT
|
|---|
| 26 | GET S (BEGDA,ENDA)=NEXT,ICOUNT=1
|
|---|
| 27 | Q:ICOUNT=GET
|
|---|
| 28 | F S NEXT=$O(^PRC(443.9,NEXT)) Q:'NEXT S ENDA=NEXT,ICOUNT=ICOUNT+1 Q:ICOUNT=GET
|
|---|
| 29 | QUIT
|
|---|
