- PRCG237Q ;WISC/BGJ - IFCAP 442 FILE CLEANUP (QUEUE); 11/8/99 2:07pm ;9/20/00 13:00
- V ;;5.1;IFCAP;**95,193**;Oct 20, 2000;Build 9
- ;Per VA Directive 6402, this routine should not be modified.
- ;This routine is installed by patch PRC*5*237.
- ;This routine creates entries in file 443.1 for background processing
- ;by PurgeMaster. Entries are created for file 442. Routine PRCG237P
- ;will be utilized by PurgeMaster to actually purge the entries in file
- ;442.
- ;
- ;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 ;SELECT FISCAL YEAR 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_"^PRCG237P",VARIABLE=BEGDA_"-"_ENDA_";"_PRC("SITE")
- . . . I ADDVAR]"" S VARIABLE=VARIABLE_";"_ADDVAR
- . . . D ADD^PRCGPM1(ROUTINE,VARIABLE,.Z)
- D CLN4406
- 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 ;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 442 for review in the "
- S X=X_"background by PurgeMaster (file 443.1 will be populated). "
- S X=X_"Accounts Receivable documents in file 442 will be purged by "
- S X=X_"PurgeMaster based on the date that you will enter. Any "
- S X=X_"document in file 442 without a P.O. DATE will also be purged "
- S X=X_"based on the date you enter and the date in the DATE P.O. "
- S X=X_"ASSIGNED field in file 442."
- 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
- CLN4406 ;add line to delete
- S MYHLD=0,MYCOUNT=0,THISCNT=0
- F S MYHLD=$O(^PRC(443.1,MYHLD)) Q:'MYHLD S MYCOUNT=MYHLD
- S LAST=MYCOUNT+1
- S X="START^PRCCL406"
- S THISCNT=$P(^PRC(443.1,0),U,4)
- S Y=""
- S:X'["^" X="^"_X
- I '$D(^PRC(443.1,LAST)) S ^PRC(443.1,LAST,0)=LAST_"^"_X_"^"_Y,$P(^PRC(443.1,0),"^",3,4)=(LAST_"^"_(THISCNT+1))
- K MYHLD,MYCOUNT,THISCNT
- Q
- LOAD ;
- ;;442;^PRC(442,;442;PRC("DATE")
- ;;;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCG237Q 3625 printed Feb 18, 2025@23:31:01 Page 2
- PRCG237Q ;WISC/BGJ - IFCAP 442 FILE CLEANUP (QUEUE); 11/8/99 2:07pm ;9/20/00 13:00
- V ;;5.1;IFCAP;**95,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*237.
- +3 ;This routine creates entries in file 443.1 for background processing
- +4 ;by PurgeMaster. Entries are created for file 442. Routine PRCG237P
- +5 ;will be utilized by PurgeMaster to actually purge the entries in file
- +6 ;442.
- +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 ;SELECT FISCAL YEAR 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
- +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_"^PRCG237P"
- 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 CLN4406
- +27 DO END^PRCGU
- +28 ;
- 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 ;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 442 for review in the "
- +2 SET X=X_"background by PurgeMaster (file 443.1 will be populated). "
- +3 SET X=X_"Accounts Receivable documents in file 442 will be purged by "
- +4 SET X=X_"PurgeMaster based on the date that you will enter. Any "
- +5 SET X=X_"document in file 442 without a P.O. DATE will also be purged "
- +6 SET X=X_"based on the date you enter and the date in the DATE P.O. "
- +7 SET X=X_"ASSIGNED field in file 442."
- +8 DO MSG^PRCFQ
- WRITE !
- +9 SET X="The date 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
- CLN4406 ;add line to delete
- +1 SET MYHLD=0
- SET MYCOUNT=0
- SET THISCNT=0
- +2 FOR
- SET MYHLD=$ORDER(^PRC(443.1,MYHLD))
- if 'MYHLD
- QUIT
- SET MYCOUNT=MYHLD
- +3 SET LAST=MYCOUNT+1
- +4 SET X="START^PRCCL406"
- +5 SET THISCNT=$PIECE(^PRC(443.1,0),U,4)
- +6 SET Y=""
- +7 if X'["^"
- SET X="^"_X
- +8 IF '$DATA(^PRC(443.1,LAST))
- SET ^PRC(443.1,LAST,0)=LAST_"^"_X_"^"_Y
- SET $PIECE(^PRC(443.1,0),"^",3,4)=(LAST_"^"_(THISCNT+1))
- +9 KILL MYHLD,MYCOUNT,THISCNT
- +10 QUIT
- LOAD ;
- +1 ;;442;^PRC(442,;442;PRC("DATE")
- +2 ;;;