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