- PRCG238Q ;WISC/BGJ-IFCAP 410 FILE CLEANUP (QUEUE) ;11/8/99
- V ;;5.1;IFCAP;**193**;Oct 20, 2000;Build 9
- ;Per VA Directive 6402, this routine should not be modified.
- ;This routine is installed by patch PRC*5*238.
- ;This routine creates entries in file 443.1 for background processing
- ;by PurgeMaster. Entries are created for files 410, 410.1 and 443.
- ;Routine PRCG238P will be utilized by PurgeMaster to actually purge the
- ;entries in these files.
- ;
- ;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("PERMDATE")=Y,PRC("TEMPDATE")=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_"^PRCG238P",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,NEXT,OGET,OUT,PERCENT,PFY,REC,REF
- K ROUTINE,RTIME,SEC,TIME,TREC,TTIME,VARIABLE,X,XCOUNT,XPOS,Y,Z,PRC
- K PRCGOUT,PRCGDOUT,PRCGPGDT
- 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 files 410, 410.1 and 443 for review "
- S X=X_"in the background by PurgeMaster (file 443.1 will be populated). "
- S X=X_"Entries in file 410 will be purged first by PurgeMaster based "
- S X=X_"on dates that you will enter. As data in file 410 is purged, "
- S X=X_"related entries in file 410.1 are also purged. Entries in file "
- S X=X_"443 will be purged next if there is no corresponding entry in "
- S X=X_"file 410. Finally, additional clean-up will be performed on file 410.1."
- D MSG^PRCFQ
- W ! S X="The dates 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 ;
- ;;410;^PRCS(410,;410;PRC("TEMPDATE")_"-"_PRC("PERMDATE")
- ;;443;^PRC(443,;443
- ;;410.1;^PRCS(410.1,;4101;"-"_PRC("PERMDATE")
- ;;;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCG238Q 3415 printed Feb 18, 2025@23:31:03 Page 2
- PRCG238Q ;WISC/BGJ-IFCAP 410 FILE CLEANUP (QUEUE) ;11/8/99
- V ;;5.1;IFCAP;**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*238.
- +3 ;This routine creates entries in file 443.1 for background processing
- +4 ;by PurgeMaster. Entries are created for files 410, 410.1 and 443.
- +5 ;Routine PRCG238P will be utilized by PurgeMaster to actually purge the
- +6 ;entries in these files.
- +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"
- +18 ;
- 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("PERMDATE")=Y
- SET PRC("TEMPDATE")=Y
- +6 ;
- 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_"^PRCG238P"
- 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,NEXT,OGET,OUT,PERCENT,PFY,REC,REF
- +3 KILL ROUTINE,RTIME,SEC,TIME,TREC,TTIME,VARIABLE,X,XCOUNT,XPOS,Y,Z,PRC
- +4 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 files 410, 410.1 and 443 for review "
- +2 SET X=X_"in the background by PurgeMaster (file 443.1 will be populated). "
- +3 SET X=X_"Entries in file 410 will be purged first by PurgeMaster based "
- +4 SET X=X_"on dates that you will enter. As data in file 410 is purged, "
- +5 SET X=X_"related entries in file 410.1 are also purged. Entries in file "
- +6 SET X=X_"443 will be purged next if there is no corresponding entry in "
- +7 SET X=X_"file 410. Finally, additional clean-up will be performed on file 410.1."
- +8 DO MSG^PRCFQ
- +9 WRITE !
- SET X="The dates you are about to enter MUST be confirmed with A&MM "
- +10 SET X=X_"or Fiscal staff. FAILURE TO DO SO MAY RESULT IN DATA "
- +11 SET X=X_"CORRUPTION."
- DO MSG^PRCFQ
- WRITE $CHAR(7),$CHAR(7),$CHAR(7)
- +12 QUIT
- LOAD ;
- +1 ;;410;^PRCS(410,;410;PRC("TEMPDATE")_"-"_PRC("PERMDATE")
- +2 ;;443;^PRC(443,;443
- +3 ;;410.1;^PRCS(410.1,;4101;"-"_PRC("PERMDATE")
- +4 ;;;
