PRCGARP ;WIRMFO@ALTOONA/CTB IFCAP PURGE SCHEDULER ;12/10/97 9:52 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
W @IOF,!,"IFCAP PURGE SCHEDULER",!
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"
D ^PRCFYN Q:%<0
I %=2 D Q:%'=1
. 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
. S %A="ARE YOU POSITIVE",%=2 D ^PRCFYN
. QUIT
S PRCF("X")="AS" D ^PRCFSITE Q:'%
S TREC=$P(^PRC(443.9,0),"^",4),OGET=TREC\1000+1
S MESSAGE="CREATING PURGEMASTER ENTRIES" K ITEMS
D BEGIN^PRCGU
S NEXT=0
X F D S XCOUNT=XCOUNT+COUNT D PERCENT^PRCGU Q:'NEXT
. S COUNT=0 F D QUIT:'NEXT!(COUNT>LREC)
. . S GET=($S((LREC-COUNT)>OGET:OGET,1:(LREC-COUNT)+2))-1
. . I GET<1 S GET=1
. . S NEXT=$O(^PRC(443.9,NEXT)) Q:'NEXT D GET S COUNT=COUNT+ICOUNT
. . S Z="",ROUTINE="START^PRCGARP1",VARIABLE=BEGDA_"-"_ENDA_";"_PRC("SITE") D ADD^PRCGPM1(ROUTINE,VARIABLE,.Z)
. . QUIT
. QUIT
D END^PRCGU
QUIT
GET S (BEGDA,ENDA)=NEXT,ICOUNT=1
Q:ICOUNT=GET
F S NEXT=$O(^PRC(443.9,NEXT)) Q:'NEXT S ENDA=NEXT,ICOUNT=ICOUNT+1 Q:ICOUNT=GET
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGARP 1392 printed Nov 22, 2024@17:14:54 Page 2
PRCGARP ;WIRMFO@ALTOONA/CTB IFCAP PURGE SCHEDULER ;12/10/97 9:52 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 WRITE @IOF,!,"IFCAP PURGE SCHEDULER",!
+3 SET %A="This option will allow you to purge IFCAP records which have previously been"
SET %A(1)="identified and archived for your station."
SET %A(2)="Have you received and verified your archive micro fiche"
+4 DO ^PRCFYN
if %<0
QUIT
+5 IF %=2
Begin DoDot:1
+6 SET %A="I will allow you to purge records which have not been archived, but it is"
SET %A(1)="probably not a good idea to do so."
SET %A(2)="Are you sure you want to continue"
SET %=2
DO ^PRCFYN
if %'=1
QUIT
+7 SET %A="ARE YOU POSITIVE"
SET %=2
DO ^PRCFYN
+8 QUIT
End DoDot:1
if %'=1
QUIT
+9 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
QUIT
+10 SET TREC=$PIECE(^PRC(443.9,0),"^",4)
SET OGET=TREC\1000+1
+11 SET MESSAGE="CREATING PURGEMASTER ENTRIES"
KILL ITEMS
+12 DO BEGIN^PRCGU
+13 SET NEXT=0
X FOR
Begin DoDot:1
+1 SET COUNT=0
FOR
Begin DoDot:2
+2 SET GET=($SELECT((LREC-COUNT)>OGET:OGET,1:(LREC-COUNT)+2))-1
+3 IF GET<1
SET GET=1
+4 SET NEXT=$ORDER(^PRC(443.9,NEXT))
if 'NEXT
QUIT
DO GET
SET COUNT=COUNT+ICOUNT
+5 SET Z=""
SET ROUTINE="START^PRCGARP1"
SET VARIABLE=BEGDA_"-"_ENDA_";"_PRC("SITE")
DO ADD^PRCGPM1(ROUTINE,VARIABLE,.Z)
+6 QUIT
End DoDot:2
if 'NEXT!(COUNT>LREC)
QUIT
+7 QUIT
End DoDot:1
SET XCOUNT=XCOUNT+COUNT
DO PERCENT^PRCGU
if 'NEXT
QUIT
+8 DO END^PRCGU
+9 QUIT
GET SET (BEGDA,ENDA)=NEXT
SET ICOUNT=1
+1 if ICOUNT=GET
QUIT
+2 FOR
SET NEXT=$ORDER(^PRC(443.9,NEXT))
if 'NEXT
QUIT
SET ENDA=NEXT
SET ICOUNT=ICOUNT+1
if ICOUNT=GET
QUIT
+3 QUIT
