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

GECSPURG.m

Go to the documentation of this file.
  1. GECSPURG ;WISC/RFJ/KLD-purge code sheets (ask prompts) ; 5/21/12 5:05am
  1. ;;2.0;GEC;**23,36,39**;MAR 14, 1995;Build 7
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;GEC*2*39 Added universal date control query to process
  1. ;
  1. W !,"This routine will delete Code Sheets from the Code Sheet file and"
  1. W !,"Batch and Transmission records from the Transmission Record file."
  1. W !,"Deletion is based upon the date a batch and a code sheet is"
  1. W !,"created.",!
  1. N %,%H,%I,DIR,DONTASK,GECS,GECSDATE,GECSDT,GECSDTST,X,Y
  1. D ^GECSSITE Q:'$G(GECS("SITE"))
  1. ;
  1. ; if programmer, ask to purge *all* code sheets
  1. I '$L($G(GECSSYS)),$G(DUZ(0))="@" N GECSSYS D ALL Q:GECSSYS="^" I GECSSYS="*" D ASK Q
  1. ;
  1. I $L($G(GECSSYS)) S DONTASK=1
  1. W ! D BATTYPE^GECSUSEL($G(GECSSYS),$G(DONTASK)) Q:'$G(GECS("BATDA"))
  1. N GECSSYS,GECSOUT,GECSPGDT,GECSDOUT
  1. S GECSSYS=GECS("BATCH")
  1. ;
  1. ASK ; ask days to retain code sheets
  1. DT ;Ask processing date GEC*2*39
  1. S GECSOUT=$$PURGEDT^GECSPURG("",7)
  1. I GECSPGDT'>0!GECSOUT Q
  1. S (Y,GECSDT)=GECSPGDT
  1. ;
  1. I GECSSYS="*"!($G(GECS("SYSID"))="FMS") D
  1. . S X1=DT,X2=-2558 D C^%DTC S (Y,GECSDTST)=X D DD^%DT
  1. . W !!,"This program will remove all stack file entries which were created before",!,Y,"."
  1. ;
  1. ; calculate cutoff date
  1. S Y=GECSDT D DD^%DT S GECSDATE=Y
  1. S XP="I will now delete all code sheets and associated records which were"
  1. S XP(1)="created before "_GECSDATE_" for station "_GECS("SITE")_GECS("SITE1")_".",XP(2)="OK to continue"
  1. W ! I $$YN^GECSUTIL(1)'=1 Q
  1. ;
  1. S %ZIS="Q" W ! D ^%ZIS Q:POP
  1. I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^GECSPUR1",ZTDESC="Purge Generic Code Sheets",ZTSAVE("GECS*")="",ZTSAVE("ZTREQ")="@" D ^%ZTLOAD K ZTSK Q
  1. W !!,">> please wait <<"
  1. D DQ^GECSPUR1
  1. Q
  1. ;
  1. ;
  1. ALL ; ask to delete all code sheets
  1. S XP="DO YOU WANT TO DELETE ALL TYPES OF CODE SHEETS",XH="ENTER 'YES' TO DELETE ALL TYPE OF CODE SHEETS, 'NO' TO SELECT THE BATCH TYPE."
  1. W ! S %=$$YN^GECSUTIL(2)
  1. I %=2 S GECSSYS="" Q
  1. I %=1 S GECSSYS="*" Q
  1. S GECSSYS="^"
  1. Q
  1. PURGEDT(GECSTHRU,GECSYRS) ;ARCHIVE/PURGE date query ;GEC*2*39
  1. N GECSDT,OUT D DTGEC S OUT=0
  1. P1 S GECSDOUT=0,GECSPGDT=0
  1. S DIR(0)="D^::E",DIR("A")="Select Fiscal Year thru which this option is to run",DIR("?",1)="Enter a valid FileMan date (YYYY is valid), or an up-arrow to quit."
  1. S DIR("?")="Date is converted to last day of FISCAL YEAR associated with entry"
  1. S:GECSTHRU>0 DIR("B")=GECSTHRU
  1. D ^DIR K DIR I X["^"!(X="") S OUT=1 G Q
  1. I $E(Y,4,5)>9 S Y=($E(Y,1,3)+1)_"0930"
  1. E S Y=$E(Y,1,3)_"0930"
  1. S GECSPGDT=Y
  1. I GECSPGDT>GECSDT W !,"CANNOT RUN THIS OPTION FOR LESS THAN LAST "_GECSYRS_" FISCAL YEARS + CURRENT FISCAL YEAR" K GECSDOUT,GECSPGDT G P1
  1. D DD^%DT S GECSDOUT=Y K Y
  1. Q Q OUT
  1. ;
  1. DTGEC N U,X,MM,DD,YY
  1. S U="^"
  1. I '$D(DT) D NOW^%DTC S DT=X
  1. S MM=$E(DT,4,5),DD=$E(DT,6,7),YY=$E(DT,1,3)
  1. S YY=YY-GECSYRS ;MIN = LAST 7 YEARS + CURRENT
  1. S YY=YY-1,GECSDT=YY_"0930"
  1. Q