| [613] | 1 | PRCG239Q ;WISC/BGJ-IFCAP 410 FILE CLEANUP (QUEUE) ;11/8/99
|
|---|
| 2 | V ;;5.1;IFCAP;**95**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;This routine is installed by patch PRC*5.1*95.
|
|---|
| 5 | ;This routine creates entries in file 443.1 for background processing
|
|---|
| 6 | ;by PurgeMaster. Entries are created for file 417.
|
|---|
| 7 | ;Routine PRCG239P will be utilized by PurgeMaster to actually purge the
|
|---|
| 8 | ;entries in this file.
|
|---|
| 9 | ;
|
|---|
| 10 | W @IOF,!
|
|---|
| 11 | D MSG
|
|---|
| 12 | S %A="Are you ready to continue",%A(0)="!",%=1
|
|---|
| 13 | D ^PRCFYN Q:%'=1
|
|---|
| 14 | S PRCF("X")="AS" D ^PRCFSITE G OUT:'%
|
|---|
| 15 | D NOW^%DTC K %H,%,%I
|
|---|
| 16 | S CFY=$E(X,1,3)+1700,CFY=$S(+$E(X,4,5)>9:CFY+1,1:CFY)
|
|---|
| 17 | S PFY=CFY-1700-1_"0930"
|
|---|
| 18 | S X="Date/Fiscal Year thru which FMS reconilliation data in file 417 will be purged."
|
|---|
| 19 | D DATE
|
|---|
| 20 | I +OUT G OUT
|
|---|
| 21 | I $E(Y,4,7)="0000" S Y=$E(Y,1,3)_"0930"
|
|---|
| 22 | S PRC("DATE")=Y
|
|---|
| 23 | K OUT
|
|---|
| 24 | DQ ;
|
|---|
| 25 | I $D(ZTQUEUED) S ZTREQ="@"
|
|---|
| 26 | F I=1:1 S X=$T(LOAD+I) Q:$P(X,";",3)="" D
|
|---|
| 27 | . S FILE(I)=$P(X,";",3),GLO(I)=$P(X,";",4),REF(I)=$P(X,";",5),ADDVAR(I)=$P(X,";",6)
|
|---|
| 28 | S N=0,TREC=0
|
|---|
| 29 | F S N=$O(GLO(N)) Q:'N D
|
|---|
| 30 | . S X="S REC(N)=$P("_GLO(N)_"0),U,4)" X X S TREC=TREC+REC(N)
|
|---|
| 31 | S OGET=TREC\1000+1
|
|---|
| 32 | S MESSAGE="CREATING PURGEMASTER ENTRIES FOR FILE CLEANUP"
|
|---|
| 33 | D BEGIN^PRCGU
|
|---|
| 34 | S LEVEL=0
|
|---|
| 35 | F S LEVEL=$O(GLO(LEVEL)) Q:LEVEL="" D
|
|---|
| 36 | . S GLO=GLO(LEVEL),REF=REF(LEVEL),ADDVAR=""
|
|---|
| 37 | . S:ADDVAR(LEVEL)]"" @("ADDVAR="_ADDVAR(LEVEL))
|
|---|
| 38 | . S NEXT=0
|
|---|
| 39 | . F D S XCOUNT=XCOUNT+COUNT D PERCENT^PRCGU Q:'NEXT
|
|---|
| 40 | . . S COUNT=0
|
|---|
| 41 | . . F D Q:'NEXT!(COUNT>LREC)
|
|---|
| 42 | . . . S GET=($S((LREC-COUNT)>OGET:OGET,1:(LREC-COUNT)+2))-1
|
|---|
| 43 | . . . I GET<1 S GET=1
|
|---|
| 44 | . . . D GET
|
|---|
| 45 | . . . Q:'NEXT
|
|---|
| 46 | . . . S COUNT=COUNT+ICOUNT
|
|---|
| 47 | . . . S Z="",ROUTINE=REF_"^PRCG239P",VARIABLE=BEGDA_"-"_ENDA_";"_PRC("SITE")
|
|---|
| 48 | . . . I ADDVAR]"" S VARIABLE=VARIABLE_";"_ADDVAR
|
|---|
| 49 | . . . D ADD^PRCGPM1(ROUTINE,VARIABLE,.Z)
|
|---|
| 50 | D END^PRCGU
|
|---|
| 51 | ;
|
|---|
| 52 | OUT ;
|
|---|
| 53 | K A,ADDVAR,ATERM,BEGDA,BTIME,CFY,COUNT,CURSOR,DX,DY,ENDA,FILE,GET,GLO,HOURS,ICOUNT,LEVEL,LINE,LREC,MIN,NEXT,OGET,OUT,PERCENT,PFY,REC,REF,ROUTINE,RTIME,SEC,TIME,TREC,TTIME,VARIABLE,X,XCOUNT,XPOS,Y,Z,PRC
|
|---|
| 54 | D KILL^%ZISS
|
|---|
| 55 | Q
|
|---|
| 56 | GET ;
|
|---|
| 57 | S (BEGDA,ENDA)=NEXT+1,ICOUNT=1
|
|---|
| 58 | S @("NEXT=$O("_GLO_"NEXT))")
|
|---|
| 59 | I 'NEXT S NEXT="" Q
|
|---|
| 60 | S BEGDA=NEXT,(NEXT,ENDA)=NEXT+GET,ICOUNT=ENDA-BEGDA+1
|
|---|
| 61 | Q
|
|---|
| 62 | MSG ;
|
|---|
| 63 | S X="This will schedule records in file 417 for review in the "
|
|---|
| 64 | S X=X_"background by PurgeMaster (file 443.1 will be populated). "
|
|---|
| 65 | S X=X_"FMS reconcilliation data in file 417 will be purged by "
|
|---|
| 66 | S X=X_"PurgeMaster based on the date that you will enter."
|
|---|
| 67 | D MSG^PRCFQ W !
|
|---|
| 68 | S X="The date you are about to enter MUST be confirmed with A&MM "
|
|---|
| 69 | S X=X_"or Fiscal staff. FAILURE TO DO SO MAY RESULT IN DATA "
|
|---|
| 70 | S X=X_"CORRUPTION." D MSG^PRCFQ W $C(7),$C(7),$C(7)
|
|---|
| 71 | Q
|
|---|
| 72 | DATE ;Select fiscal year
|
|---|
| 73 | S DIR(0)="DA^:"_PFY_":EA"
|
|---|
| 74 | S DIR("A")="Select DATE/FISCAL YEAR: "
|
|---|
| 75 | S DIR("A",1)=X
|
|---|
| 76 | S DIR("?")="You may only select for purging those documents which are not in the current Fiscal Year."
|
|---|
| 77 | D ^DIR
|
|---|
| 78 | S OUT=$G(DTOUT)_$G(DUOUT)_$G(DIRUT)_$G(DIROUT)
|
|---|
| 79 | K DTOUT,DUOUT,DIRUT,DIROUT,DIR
|
|---|
| 80 | Q
|
|---|
| 81 | LOAD ;
|
|---|
| 82 | ;;417;^PRCS(417,;417;PRC("DATE")
|
|---|
| 83 | ;;;
|
|---|
