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 ---[H[J[2J[HPRCGARCF 1645 printed Dec 13, 2024@02:04:45 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
