PRCGARP.m

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 ---PRCGARP   1392     printed  Mar 13, 2025@21:09:36                                                                                                                                                                                                     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