source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCGARP.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.3 KB
Line 
1PRCGARP ;WIRMFO@ALTOONA/CTB IFCAP PURGE SCHEDULER ;12/10/97 9:52 AM
2V ;;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
16X 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
26GET 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
Note: See TracBrowser for help on using the repository browser.