PRCG239Q ;WISC/BGJ-IFCAP 410 FILE CLEANUP (QUEUE) ;11/8/99
V ;;5.1;IFCAP;**95,138,193**;Oct 20, 2000;Build 9
;Per VA Directive 6402, this routine should not be modified.
;This routine is installed by patch PRC*5.1*95.
;This routine creates entries in file 443.1 for background processing
;by PurgeMaster. Entries are created for file 417.
;Routine PRCG239P will be utilized by PurgeMaster to actually purge the
;entries in this file.
;
;PRC*5.1*193 Added universal date control query to process
;
W @IOF,!
D MSG
S %A="Are you ready to continue",%A(0)="!",%=1
D ^PRCFYN Q:%'=1
S PRCF("X")="AS" D ^PRCFSITE G OUT:'%
D NOW^%DTC K %H,%,%I
S CFY=$E(X,1,3)+1700,CFY=$S(+$E(X,4,5)>9:CFY+1,1:CFY)
S PFY=CFY-1700-1_"0930"
DT ;Ask processing date PRC*5.1*193
S PRCGOUT=$$PURGEDT^PRCGPUTL("",7)
I PRCGPGDT'>0!PRCGOUT G OUT
W !! S %A="The archiving processing will go through date "_PRCGDOUT_" is this OK?" S %=1 D ^PRCFYN G OUT:%'=1
W !! S %A="ARE YOU SURE" D ^PRCFYN I %'=1 W ?35,"I am confused, let's start over..." G DT
S Y=PRCGPGDT,PRC("DATE")=Y
DQ ;
I $D(ZTQUEUED) S ZTREQ="@"
F I=1:1 S X=$T(LOAD+I) Q:$P(X,";",3)="" D
. S FILE(I)=$P(X,";",3),GLO(I)=$P(X,";",4),REF(I)=$P(X,";",5),ADDVAR(I)=$P(X,";",6)
S N=0,TREC=0
F S N=$O(GLO(N)) Q:'N D
. S X="S REC(N)=$P("_GLO(N)_"0),U,4)" X X S TREC=TREC+REC(N)
S OGET=TREC\1000+1
S MESSAGE="CREATING PURGEMASTER ENTRIES FOR FILE CLEANUP"
D BEGIN^PRCGU
S LEVEL=0
F S LEVEL=$O(GLO(LEVEL)) Q:LEVEL="" D
. S GLO=GLO(LEVEL),REF=REF(LEVEL),ADDVAR=""
. S:ADDVAR(LEVEL)]"" @("ADDVAR="_ADDVAR(LEVEL))
. S NEXT=0
. F D S XCOUNT=XCOUNT+COUNT D PERCENT^PRCGU Q:'NEXT
. . S COUNT=0
. . F D Q:'NEXT!(COUNT>LREC)
. . . S GET=($S((LREC-COUNT)>OGET:OGET,1:(LREC-COUNT)+2))-1
. . . I GET<1 S GET=1
. . . D GET
. . . Q:'NEXT
. . . S COUNT=COUNT+ICOUNT
. . . S Z="",ROUTINE=REF_"^PRCG239P",VARIABLE=BEGDA_"-"_ENDA_";"_PRC("SITE")
. . . I ADDVAR]"" S VARIABLE=VARIABLE_";"_ADDVAR
. . . D ADD^PRCGPM1(ROUTINE,VARIABLE,.Z)
D END^PRCGU
;
OUT ;
K A,ADDVAR,ATERM,BEGDA,BTIME,CFY,COUNT,CURSOR,DX,DY,ENDA,FILE,GET,GLO
K HOURS,ICOUNT,LEVEL,LINE,LREC,MIN,VARIABLE,X,XCOUNT,XPOS,Y,Z,PRC
K NEXT,OGET,OUT,PERCENT,PFY,REC,REF,ROUTINE,RTIME,SEC,TIME,TREC,TTIME
K PRCGOUT,PRCGDOUT,PRCGPGDT ;PRC*5.1*193
D KILL^%ZISS
Q
GET ;
S (BEGDA,ENDA)=NEXT+1,ICOUNT=1
S @("NEXT=$O("_GLO_"NEXT))")
I 'NEXT S NEXT="" Q
S BEGDA=NEXT,(NEXT,ENDA)=NEXT+GET,ICOUNT=ENDA-BEGDA+1
Q
MSG ;
S X="This will schedule records in file 417 for review in the "
S X=X_"background by PurgeMaster (file 443.1 will be populated). "
S X=X_"FMS reconciliation data in file 417 will be purged by "
S X=X_"PurgeMaster based on the date that you will enter."
D MSG^PRCFQ W !
S X="The date you are about to enter MUST be confirmed with A&MM "
S X=X_"or Fiscal staff. FAILURE TO DO SO MAY RESULT IN DATA "
S X=X_"CORRUPTION." D MSG^PRCFQ W $C(7),$C(7),$C(7)
Q
LOAD ;
;;417;^PRCS(417,;417;PRC("DATE")
;;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCG239Q 3030 printed Apr 09, 2024@21:00:29 Page 2
PRCG239Q ;WISC/BGJ-IFCAP 410 FILE CLEANUP (QUEUE) ;11/8/99
V ;;5.1;IFCAP;**95,138,193**;Oct 20, 2000;Build 9
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;This routine is installed by patch PRC*5.1*95.
+3 ;This routine creates entries in file 443.1 for background processing
+4 ;by PurgeMaster. Entries are created for file 417.
+5 ;Routine PRCG239P will be utilized by PurgeMaster to actually purge the
+6 ;entries in this file.
+7 ;
+8 ;PRC*5.1*193 Added universal date control query to process
+9 ;
+10 WRITE @IOF,!
+11 DO MSG
+12 SET %A="Are you ready to continue"
SET %A(0)="!"
SET %=1
+13 DO ^PRCFYN
if %'=1
QUIT
+14 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
GOTO OUT
+15 DO NOW^%DTC
KILL %H,%,%I
+16 SET CFY=$EXTRACT(X,1,3)+1700
SET CFY=$SELECT(+$EXTRACT(X,4,5)>9:CFY+1,1:CFY)
+17 SET PFY=CFY-1700-1_"0930"
DT ;Ask processing date PRC*5.1*193
+1 SET PRCGOUT=$$PURGEDT^PRCGPUTL("",7)
+2 IF PRCGPGDT'>0!PRCGOUT
GOTO OUT
+3 WRITE !!
SET %A="The archiving processing will go through date "_PRCGDOUT_" is this OK?"
SET %=1
DO ^PRCFYN
if %'=1
GOTO OUT
+4 WRITE !!
SET %A="ARE YOU SURE"
DO ^PRCFYN
IF %'=1
WRITE ?35,"I am confused, let's start over..."
GOTO DT
+5 SET Y=PRCGPGDT
SET PRC("DATE")=Y
DQ ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 FOR I=1:1
SET X=$TEXT(LOAD+I)
if $PIECE(X,";",3)=""
QUIT
Begin DoDot:1
+3 SET FILE(I)=$PIECE(X,";",3)
SET GLO(I)=$PIECE(X,";",4)
SET REF(I)=$PIECE(X,";",5)
SET ADDVAR(I)=$PIECE(X,";",6)
End DoDot:1
+4 SET N=0
SET TREC=0
+5 FOR
SET N=$ORDER(GLO(N))
if 'N
QUIT
Begin DoDot:1
+6 SET X="S REC(N)=$P("_GLO(N)_"0),U,4)"
XECUTE X
SET TREC=TREC+REC(N)
End DoDot:1
+7 SET OGET=TREC\1000+1
+8 SET MESSAGE="CREATING PURGEMASTER ENTRIES FOR FILE CLEANUP"
+9 DO BEGIN^PRCGU
+10 SET LEVEL=0
+11 FOR
SET LEVEL=$ORDER(GLO(LEVEL))
if LEVEL=""
QUIT
Begin DoDot:1
+12 SET GLO=GLO(LEVEL)
SET REF=REF(LEVEL)
SET ADDVAR=""
+13 if ADDVAR(LEVEL)]""
SET @("ADDVAR="_ADDVAR(LEVEL))
+14 SET NEXT=0
+15 FOR
Begin DoDot:2
+16 SET COUNT=0
+17 FOR
Begin DoDot:3
+18 SET GET=($SELECT((LREC-COUNT)>OGET:OGET,1:(LREC-COUNT)+2))-1
+19 IF GET<1
SET GET=1
+20 DO GET
+21 if 'NEXT
QUIT
+22 SET COUNT=COUNT+ICOUNT
+23 SET Z=""
SET ROUTINE=REF_"^PRCG239P"
SET VARIABLE=BEGDA_"-"_ENDA_";"_PRC("SITE")
+24 IF ADDVAR]""
SET VARIABLE=VARIABLE_";"_ADDVAR
+25 DO ADD^PRCGPM1(ROUTINE,VARIABLE,.Z)
End DoDot:3
if 'NEXT!(COUNT>LREC)
QUIT
End DoDot:2
SET XCOUNT=XCOUNT+COUNT
DO PERCENT^PRCGU
if 'NEXT
QUIT
End DoDot:1
+26 DO END^PRCGU
+27 ;
OUT ;
+1 KILL A,ADDVAR,ATERM,BEGDA,BTIME,CFY,COUNT,CURSOR,DX,DY,ENDA,FILE,GET,GLO
+2 KILL HOURS,ICOUNT,LEVEL,LINE,LREC,MIN,VARIABLE,X,XCOUNT,XPOS,Y,Z,PRC
+3 KILL NEXT,OGET,OUT,PERCENT,PFY,REC,REF,ROUTINE,RTIME,SEC,TIME,TREC,TTIME
+4 ;PRC*5.1*193
KILL PRCGOUT,PRCGDOUT,PRCGPGDT
+5 DO KILL^%ZISS
+6 QUIT
GET ;
+1 SET (BEGDA,ENDA)=NEXT+1
SET ICOUNT=1
+2 SET @("NEXT=$O("_GLO_"NEXT))")
+3 IF 'NEXT
SET NEXT=""
QUIT
+4 SET BEGDA=NEXT
SET (NEXT,ENDA)=NEXT+GET
SET ICOUNT=ENDA-BEGDA+1
+5 QUIT
MSG ;
+1 SET X="This will schedule records in file 417 for review in the "
+2 SET X=X_"background by PurgeMaster (file 443.1 will be populated). "
+3 SET X=X_"FMS reconciliation data in file 417 will be purged by "
+4 SET X=X_"PurgeMaster based on the date that you will enter."
+5 DO MSG^PRCFQ
WRITE !
+6 SET X="The date you are about to enter MUST be confirmed with A&MM "
+7 SET X=X_"or Fiscal staff. FAILURE TO DO SO MAY RESULT IN DATA "
+8 SET X=X_"CORRUPTION."
DO MSG^PRCFQ
WRITE $CHAR(7),$CHAR(7),$CHAR(7)
+9 QUIT
LOAD ;
+1 ;;417;^PRCS(417,;417;PRC("DATE")
+2 ;;;
