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 Sep 23, 2025@19:40:42 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 ;;;
