Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCG237Q

PRCG237Q.m

Go to the documentation of this file.
  1. PRCG237Q ;WISC/BGJ - IFCAP 442 FILE CLEANUP (QUEUE); 11/8/99 2:07pm ;9/20/00 13:00
  1. V ;;5.1;IFCAP;**95,193**;Oct 20, 2000;Build 9
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;This routine is installed by patch PRC*5*237.
  1. ;This routine creates entries in file 443.1 for background processing
  1. ;by PurgeMaster. Entries are created for file 442. Routine PRCG237P
  1. ;will be utilized by PurgeMaster to actually purge the entries in file
  1. ;442.
  1. ;
  1. ;PRC*5.1*193 Added universal date control query to process
  1. ;
  1. W @IOF,!
  1. D MSG
  1. S %A="Are you ready to continue",%A(0)="!",%=1
  1. D ^PRCFYN Q:%'=1
  1. S PRCF("X")="AS" D ^PRCFSITE G OUT:'%
  1. D NOW^%DTC K %H,%,%I
  1. S CFY=$E(X,1,3)+1700,CFY=$S(+$E(X,4,5)>9:CFY+1,1:CFY)
  1. S PFY=CFY-1700-1_"0930"
  1. DT ;SELECT FISCAL YEAR PRC*5.1*193
  1. S PRCGOUT=$$PURGEDT^PRCGPUTL("",7)
  1. I PRCGPGDT'>0!PRCGOUT G OUT
  1. W !! S %A="The archiving processing will go through date "_PRCGDOUT_" is this OK?" S %=1 D ^PRCFYN G OUT:%'=1
  1. W !! S %A="ARE YOU SURE" D ^PRCFYN I %'=1 W ?35,"I am confused, let's start over..." G DT
  1. S Y=PRCGPGDT,PRC("DATE")=Y
  1. ;
  1. DQ ;
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. F I=1:1 S X=$T(LOAD+I) Q:$P(X,";",3)="" D
  1. . S FILE(I)=$P(X,";",3),GLO(I)=$P(X,";",4),REF(I)=$P(X,";",5),ADDVAR(I)=$P(X,";",6)
  1. S N=0,TREC=0
  1. F S N=$O(GLO(N)) Q:'N D
  1. . S X="S REC(N)=$P("_GLO(N)_"0),U,4)" X X S TREC=TREC+REC(N)
  1. S OGET=TREC\1000+1
  1. S MESSAGE="CREATING PURGEMASTER ENTRIES FOR FILE CLEANUP"
  1. D BEGIN^PRCGU
  1. S LEVEL=0
  1. F S LEVEL=$O(GLO(LEVEL)) Q:LEVEL="" D
  1. . S GLO=GLO(LEVEL),REF=REF(LEVEL),ADDVAR=""
  1. . S:ADDVAR(LEVEL)]"" @("ADDVAR="_ADDVAR(LEVEL))
  1. . S NEXT=0
  1. . F D S XCOUNT=XCOUNT+COUNT D PERCENT^PRCGU Q:'NEXT
  1. . . S COUNT=0
  1. . . F D Q:'NEXT!(COUNT>LREC)
  1. . . . S GET=($S((LREC-COUNT)>OGET:OGET,1:(LREC-COUNT)+2))-1
  1. . . . I GET<1 S GET=1
  1. . . . D GET
  1. . . . Q:'NEXT
  1. . . . S COUNT=COUNT+ICOUNT
  1. . . . S Z="",ROUTINE=REF_"^PRCG237P",VARIABLE=BEGDA_"-"_ENDA_";"_PRC("SITE")
  1. . . . I ADDVAR]"" S VARIABLE=VARIABLE_";"_ADDVAR
  1. . . . D ADD^PRCGPM1(ROUTINE,VARIABLE,.Z)
  1. D CLN4406
  1. D END^PRCGU
  1. ;
  1. OUT ;
  1. K A,ADDVAR,ATERM,BEGDA,BTIME,CFY,COUNT,CURSOR,DX,DY,ENDA,FILE,GET,GLO
  1. K HOURS,ICOUNT,LEVEL,LINE,LREC,MIN,NEXT,OGET,OUT,PERCENT,PFY,REC,REF
  1. K ROUTINE,RTIME,SEC,TIME,TREC,TTIME,VARIABLE,X,XCOUNT,XPOS,Y,Z,PRC
  1. K PRCGOUT,PRCGDOUT,PRCGPGDT ;PRC*5.1*193
  1. D KILL^%ZISS
  1. Q
  1. GET ;
  1. S (BEGDA,ENDA)=NEXT+1,ICOUNT=1
  1. S @("NEXT=$O("_GLO_"NEXT))")
  1. I 'NEXT S NEXT="" Q
  1. S BEGDA=NEXT,(NEXT,ENDA)=NEXT+GET,ICOUNT=ENDA-BEGDA+1
  1. Q
  1. MSG ;
  1. S X="This will schedule records in file 442 for review in the "
  1. S X=X_"background by PurgeMaster (file 443.1 will be populated). "
  1. S X=X_"Accounts Receivable documents in file 442 will be purged by "
  1. S X=X_"PurgeMaster based on the date that you will enter. Any "
  1. S X=X_"document in file 442 without a P.O. DATE will also be purged "
  1. S X=X_"based on the date you enter and the date in the DATE P.O. "
  1. S X=X_"ASSIGNED field in file 442."
  1. D MSG^PRCFQ W !
  1. S X="The date you are about to enter MUST be confirmed with A&MM "
  1. S X=X_"or Fiscal staff. FAILURE TO DO SO MAY RESULT IN DATA "
  1. S X=X_"CORRUPTION." D MSG^PRCFQ W $C(7),$C(7),$C(7)
  1. Q
  1. CLN4406 ;add line to delete
  1. S MYHLD=0,MYCOUNT=0,THISCNT=0
  1. F S MYHLD=$O(^PRC(443.1,MYHLD)) Q:'MYHLD S MYCOUNT=MYHLD
  1. S LAST=MYCOUNT+1
  1. S X="START^PRCCL406"
  1. S THISCNT=$P(^PRC(443.1,0),U,4)
  1. S Y=""
  1. S:X'["^" X="^"_X
  1. 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))
  1. K MYHLD,MYCOUNT,THISCNT
  1. Q
  1. LOAD ;
  1. ;;442;^PRC(442,;442;PRC("DATE")
  1. ;;;