PRCGARCF.m

PRCGARCF ;WIRMFO@ALTOONA/CTB FIND ARCHIVABLE RECORDS ;12/10/97  9:49 AM

V ;;5.1;IFCAP;**193**;Oct 20, 2000;Build 9

 ;Per VA Directive 6402, this routine should not be modified.

 ;ifcap archive

 ;

 ;PRC*5.1*193 Added universal date control query to process

 ;

 ;SELECT STATION

 S PRCF("X")="AS" D ^PRCFSITE Q:'%

 D NOW^%DTC

 S CFY=$E(X,1,3)+1700,CFY=$S(+$E(X,4,5)>9:CFY+1,1:CFY)

DT ;SELECT FISCAL YEAR        ;PRC*5.1*193

 S PRCGOUT=$$PURGEDT^PRCGPUTL("",7)

 I PRCGPGDT'>0!PRCGOUT G END

 W !! S %A="The archiving processing will go through date "_PRCGDOUT_" is this OK?" S %=1 D ^PRCFYN G END:%'=1

 W !! S %A="ARE YOU SURE" D ^PRCFYN I %'=1 W ?35,"I am confused, let's start over..." G DT

 S FY=PRCGPGDT,AFY=$E(FY,1,3)+1700

CKOLD S %=2

 I $O(^PRC(443.9,0)) D

 . F  D  Q:%<3

 . . W !! S %A="There are already records in the IFCAP Pending Archive File",%A(1)="If these are old records, they could cause duplication of the archive.",%A(2)="Do you want me to REMOVE these records before I begin"

 . . S %=1 D ^PRCFYN Q:%'=1

 . . S %A="ARE YOU SURE" D ^PRCFYN

 . . Q:%'=2  W !! S X="OK,  Now I'm really confused.  Let's do that again.*" D MSG^PRCFQ S %=3

 . . QUIT

 . QUIT

 QUIT:%<0

 S CLEANFIL=%

 S ZTDESC="IFCAP ARCHIVE RECORD FIND",ZTSAVE("AFY")="",ZTSAVE("EFY")="",ZTSAVE("FY")="",ZTSAVE("CFY")="",ZTSAVE("PRC*")="",ZTSAVE("CLEANFIL")="",ZTRTN="^PRCGARCG"

 D ^PRCFQ

END K FY,BFY,EFY,CFY,AFY,NX,MX,ZERONODE,FLAG,X,Y,TREC,CREC,LREC,XPOS,DX,CY

 K MOP,ARCBIT,DIC,DLAYGO,A,N,M,PERCENT,%DT,ARCHECK,CURSOR,CLEANFIL,D0

 K DG,DICR,DIG,DIH,DIU,DIV,DIW,ITEMS,MESSAGE,OUT,RTIME,TTIME,YPOS

 K PRCGOUT,PRCGDOUT,PRCGPGDT

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCGARCF   1645     printed  Apr 09, 2024@21:04:43                                                                                                                                                                                                    Page 2

PRCGARCF  ;WIRMFO@ALTOONA/CTB FIND ARCHIVABLE RECORDS ;12/10/97  9:49 AM

V         ;;5.1;IFCAP;**193**;Oct 20, 2000;Build 9

 +1       ;Per VA Directive 6402, this routine should not be modified.

 +2       ;ifcap archive

 +3       ;

 +4       ;PRC*5.1*193 Added universal date control query to process

 +5       ;

 +6       ;SELECT STATION

 +7        SET PRCF("X")="AS"

           DO ^PRCFSITE

           if '%

               QUIT 

 +8        DO NOW^%DTC

 +9        SET CFY=$EXTRACT(X,1,3)+1700

           SET CFY=$SELECT(+$EXTRACT(X,4,5)>9:CFY+1,1:CFY)

DT        ;SELECT FISCAL YEAR        ;PRC*5.1*193

 +1        SET PRCGOUT=$$PURGEDT^PRCGPUTL("",7)

 +2        IF PRCGPGDT'>0!PRCGOUT

               GOTO END

 +3        WRITE !!

           SET %A="The archiving processing will go through date "_PRCGDOUT_" is this OK?"

           SET %=1

           DO ^PRCFYN

           if %'=1

               GOTO END

 +4        WRITE !!

           SET %A="ARE YOU SURE"

           DO ^PRCFYN

           IF %'=1

               WRITE ?35,"I am confused, let's start over..."

               GOTO DT

 +5        SET FY=PRCGPGDT

           SET AFY=$EXTRACT(FY,1,3)+1700

CKOLD      SET %=2

 +1        IF $ORDER(^PRC(443.9,0))

               Begin DoDot:1

 +2                FOR 

                       Begin DoDot:2

 +3                        WRITE !!

                           SET %A="There are already records in the IFCAP Pending Archive File"

                           SET %A(1)="If these are old records, they could cause duplication of the archive."

                           SET %A(2)="Do you want me to REMOVE these records before I begin"

 +4                        SET %=1

                           DO ^PRCFYN

                           if %'=1

                               QUIT 

 +5                        SET %A="ARE YOU SURE"

                           DO ^PRCFYN

 +6                        if %'=2

                               QUIT 

                           WRITE !!

                           SET X="OK,  Now I'm really confused.  Let's do that again.*"

                           DO MSG^PRCFQ

                           SET %=3

 +7                        QUIT 

                       End DoDot:2

                       if %<3

                           QUIT 

 +8                QUIT 

               End DoDot:1

 +9        if %<0

               QUIT 

 +10       SET CLEANFIL=%

 +11       SET ZTDESC="IFCAP ARCHIVE RECORD FIND"

           SET ZTSAVE("AFY")=""

           SET ZTSAVE("EFY")=""

           SET ZTSAVE("FY")=""

           SET ZTSAVE("CFY")=""

           SET ZTSAVE("PRC*")=""

           SET ZTSAVE("CLEANFIL")=""

           SET ZTRTN="^PRCGARCG"

 +12       DO ^PRCFQ

END        KILL FY,BFY,EFY,CFY,AFY,NX,MX,ZERONODE,FLAG,X,Y,TREC,CREC,LREC,XPOS,DX,CY

 +1        KILL MOP,ARCBIT,DIC,DLAYGO,A,N,M,PERCENT,%DT,ARCHECK,CURSOR,CLEANFIL,D0

 +2        KILL DG,DICR,DIG,DIH,DIU,DIV,DIW,ITEMS,MESSAGE,OUT,RTIME,TTIME,YPOS

 +3        KILL PRCGOUT,PRCGDOUT,PRCGPGDT

 +4        QUIT