GECSPUR1 ;WISC/RFJ/KLD-purge code sheets (purge routine) ;01 Nov 93
;;2.0;GCS;**23**;MAR 14, 1995
Q
;
;
DQ ; queue comes here
N GECSBADA,GECSBATC,GECSCOUN,GECSDA,GECSDATA,GECSNOW,GECSTRAN,PAGE,SCREEN
S SCREEN=0 I '$D(ZTQUEUED),IO=IO(0),$E(IOST)="C" S SCREEN=1
D NOW^%DTC S Y=% D DD^%DT S GECSNOW=Y,PAGE=1 U IO D H
W !!," STATION: ",GECS("SITE")_GECS("SITE1"),!,"BATCH TYPE: ",$S($G(GECSSYS)="*":"** ALL **",1:GECS("BATCH")),!," USER: ",$P($G(^VA(200,DUZ,0)),"^")
W !!,"Deleting all code sheets created or transmitted before: ",GECSDATE
;
; delete transmitted batches
W !!,"deleting batches and code sheets contained in batches:"
S (GECSCOUN,GECSBADA)=0 F S GECSBADA=$O(^GECS(2101.3,GECSBADA)) Q:'GECSBADA S GECSDATA=$G(^(GECSBADA,0)),GECSBATC=$P(GECSDATA,"^") D
. N GECSSUF
. S GECSSUF=GECS("SITE")_GECS("SITE1")
. I $P(GECSBATC,"-")'=GECSSUF Q
. I $G(GECSSYS)'="*",$P(GECSDATA,"^",2)'=GECS("SYSID") Q
. I $G(GECSSYS)'="*" I $P(GECSDATA,"^",6)=""!($P(GECSDATA,"^",6)'=GECS("BATDA")) Q
. I $P(GECSDATA,"^",10)'<GECSDT Q
. W !?5,GECSBATC
. D KILLBATC(GECSBADA)
. W " --deleted, cleaning up associated code sheets:"
. ; remove code sheets associated with batch
. W !?14
. S GECSDA=0 F S GECSDA=$O(^GECS(2100,"AB",GECSBATC,GECSDA)) Q:'GECSDA W $J($P($G(^GECS(2100,GECSDA,0)),"^"),10) D KILLCS(GECSDA) W:$X>68 !?14 S GECSCOUN=GECSCOUN+1
;
; delete code sheets created before date and not batched
W !,"cleaning up code sheets:",!?14
S GECSDA=0 F S GECSDA=$O(^GECS(2100,GECSDA)) Q:'GECSDA S GECSDATA=$G(^(GECSDA,0)) D
. I $G(GECSSYS)'="*" I $P(GECSDATA,"^",2)'=GECS("SYSID")!($P(GECSDATA,"^",3)'=GECS("BATDA")) Q
. ; delete code sheet if batch number is not found
. S GECSTRAN=$G(^GECS(2100,GECSDA,"TRANS"))
. I GECSTRAN'="",$P(GECSTRAN,"^",9)'="",'$O(^GECS(2101.3,"B",$P(GECSTRAN,"^",9),0)) W $J($P(GECSDATA,"^"),10) D KILLCS(GECSDA) W:$X>68 !?14 S GECSCOUN=GECSCOUN+1 Q
. ;
. ; do not delete if code sheet has batch number, batched code
. ; sheets deleted above
. I $P(GECSTRAN,"^",9)'="" Q
. I ($P(GECSDATA,"^",6)'=GECS("SITE"))&($P(GECSDATA,"^",7)'=GECS("SITE1")) Q
. I $P(GECSDATA,"^",10)>GECSDT Q
. W $J($P(GECSDATA,"^"),10) D KILLCS(GECSDA) W:$X>68 !?14 S GECSCOUN=GECSCOUN+1
;
W !!,"Finished - deleted ",GECSCOUN," code sheets."
;
; clean stack file
I $G(GECSDTST) D
. W !,"cleaning up stack file:",!?14
. S GECSDA=0 F S GECSDA=$O(^GECS(2100.1,GECSDA)) Q:'GECSDA S GECSDATA=$G(^(GECSDA,0)) D
. . I $P($P(GECSDATA,"^",3),".")>GECSDTST Q
. . W $P(GECSDATA,"^"),!?14
. . D KILLSTAC(GECSDA)
Q
;
;
H ; header
S %=GECSNOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W !,"CODE SHEET/TRANSMISSION RECORD DELETION TRANSCRIPT ",%
S %="",$P(%,"-",81)="" W !,%
Q
;
;
KILLBATC(DA) ; kill batch da from file 2101.3
I '$D(^GECS(2101.3,DA)) Q
N %,DIC,DIK,X,Y
S DIK="^GECS(2101.3," D ^DIK
Q
;
;
KILLCS(DA) ; delete code sheet da
I '$D(^GECS(2100,DA)) Q
N %,DIC,DIK,X,Y
S DIK="^GECS(2100," D ^DIK
Q
;
;
KILLSTAC(DA) ; delete stack file entry da
I '$D(^GECS(2100.1,DA)) Q
N %,DIC,DIK,X,Y
S DIK="^GECS(2100.1," D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGECSPUR1 3277 printed Nov 22, 2024@17:06:27 Page 2
GECSPUR1 ;WISC/RFJ/KLD-purge code sheets (purge routine) ;01 Nov 93
+1 ;;2.0;GCS;**23**;MAR 14, 1995
+2 QUIT
+3 ;
+4 ;
DQ ; queue comes here
+1 NEW GECSBADA,GECSBATC,GECSCOUN,GECSDA,GECSDATA,GECSNOW,GECSTRAN,PAGE,SCREEN
+2 SET SCREEN=0
IF '$DATA(ZTQUEUED)
IF IO=IO(0)
IF $EXTRACT(IOST)="C"
SET SCREEN=1
+3 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET GECSNOW=Y
SET PAGE=1
USE IO
DO H
+4 WRITE !!," STATION: ",GECS("SITE")_GECS("SITE1"),!,"BATCH TYPE: ",$SELECT($GET(GECSSYS)="*":"** ALL **",1:GECS("BATCH")),!," USER: ",$PIECE($GET(^VA(200,DUZ,0)),"^")
+5 WRITE !!,"Deleting all code sheets created or transmitted before: ",GECSDATE
+6 ;
+7 ; delete transmitted batches
+8 WRITE !!,"deleting batches and code sheets contained in batches:"
+9 SET (GECSCOUN,GECSBADA)=0
FOR
SET GECSBADA=$ORDER(^GECS(2101.3,GECSBADA))
if 'GECSBADA
QUIT
SET GECSDATA=$GET(^(GECSBADA,0))
SET GECSBATC=$PIECE(GECSDATA,"^")
Begin DoDot:1
+10 NEW GECSSUF
+11 SET GECSSUF=GECS("SITE")_GECS("SITE1")
+12 IF $PIECE(GECSBATC,"-")'=GECSSUF
QUIT
+13 IF $GET(GECSSYS)'="*"
IF $PIECE(GECSDATA,"^",2)'=GECS("SYSID")
QUIT
+14 IF $GET(GECSSYS)'="*"
IF $PIECE(GECSDATA,"^",6)=""!($PIECE(GECSDATA,"^",6)'=GECS("BATDA"))
QUIT
+15 IF $PIECE(GECSDATA,"^",10)'<GECSDT
QUIT
+16 WRITE !?5,GECSBATC
+17 DO KILLBATC(GECSBADA)
+18 WRITE " --deleted, cleaning up associated code sheets:"
+19 ; remove code sheets associated with batch
+20 WRITE !?14
+21 SET GECSDA=0
FOR
SET GECSDA=$ORDER(^GECS(2100,"AB",GECSBATC,GECSDA))
if 'GECSDA
QUIT
WRITE $JUSTIFY($PIECE($GET(^GECS(2100,GECSDA,0)),"^"),10)
DO KILLCS(GECSDA)
if $X>68
WRITE !?14
SET GECSCOUN=GECSCOUN+1
End DoDot:1
+22 ;
+23 ; delete code sheets created before date and not batched
+24 WRITE !,"cleaning up code sheets:",!?14
+25 SET GECSDA=0
FOR
SET GECSDA=$ORDER(^GECS(2100,GECSDA))
if 'GECSDA
QUIT
SET GECSDATA=$GET(^(GECSDA,0))
Begin DoDot:1
+26 IF $GET(GECSSYS)'="*"
IF $PIECE(GECSDATA,"^",2)'=GECS("SYSID")!($PIECE(GECSDATA,"^",3)'=GECS("BATDA"))
QUIT
+27 ; delete code sheet if batch number is not found
+28 SET GECSTRAN=$GET(^GECS(2100,GECSDA,"TRANS"))
+29 IF GECSTRAN'=""
IF $PIECE(GECSTRAN,"^",9)'=""
IF '$ORDER(^GECS(2101.3,"B",$PIECE(GECSTRAN,"^",9),0))
WRITE $JUSTIFY($PIECE(GECSDATA,"^"),10)
DO KILLCS(GECSDA)
if $X>68
WRITE !?14
SET GECSCOUN=GECSCOUN+1
QUIT
+30 ;
+31 ; do not delete if code sheet has batch number, batched code
+32 ; sheets deleted above
+33 IF $PIECE(GECSTRAN,"^",9)'=""
QUIT
+34 IF ($PIECE(GECSDATA,"^",6)'=GECS("SITE"))&($PIECE(GECSDATA,"^",7)'=GECS("SITE1"))
QUIT
+35 IF $PIECE(GECSDATA,"^",10)>GECSDT
QUIT
+36 WRITE $JUSTIFY($PIECE(GECSDATA,"^"),10)
DO KILLCS(GECSDA)
if $X>68
WRITE !?14
SET GECSCOUN=GECSCOUN+1
End DoDot:1
+37 ;
+38 WRITE !!,"Finished - deleted ",GECSCOUN," code sheets."
+39 ;
+40 ; clean stack file
+41 IF $GET(GECSDTST)
Begin DoDot:1
+42 WRITE !,"cleaning up stack file:",!?14
+43 SET GECSDA=0
FOR
SET GECSDA=$ORDER(^GECS(2100.1,GECSDA))
if 'GECSDA
QUIT
SET GECSDATA=$GET(^(GECSDA,0))
Begin DoDot:2
+44 IF $PIECE($PIECE(GECSDATA,"^",3),".")>GECSDTST
QUIT
+45 WRITE $PIECE(GECSDATA,"^"),!?14
+46 DO KILLSTAC(GECSDA)
End DoDot:2
End DoDot:1
+47 QUIT
+48 ;
+49 ;
H ; header
+1 SET %=GECSNOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+2 WRITE !,"CODE SHEET/TRANSMISSION RECORD DELETION TRANSCRIPT ",%
+3 SET %=""
SET $PIECE(%,"-",81)=""
WRITE !,%
+4 QUIT
+5 ;
+6 ;
KILLBATC(DA) ; kill batch da from file 2101.3
+1 IF '$DATA(^GECS(2101.3,DA))
QUIT
+2 NEW %,DIC,DIK,X,Y
+3 SET DIK="^GECS(2101.3,"
DO ^DIK
+4 QUIT
+5 ;
+6 ;
KILLCS(DA) ; delete code sheet da
+1 IF '$DATA(^GECS(2100,DA))
QUIT
+2 NEW %,DIC,DIK,X,Y
+3 SET DIK="^GECS(2100,"
DO ^DIK
+4 QUIT
+5 ;
+6 ;
KILLSTAC(DA) ; delete stack file entry da
+1 IF '$DATA(^GECS(2100.1,DA))
QUIT
+2 NEW %,DIC,DIK,X,Y
+3 SET DIK="^GECS(2100.1,"
DO ^DIK
+4 QUIT
