source: FOIAVistA/trunk/r/GENERIC_CODE_SHEET-GEC/GECSPUR1.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.1 KB
Line 
1GECSPUR1 ;WISC/RFJ/KLD-purge code sheets (purge routine) ;01 Nov 93
2 ;;2.0;GCS;**23**;MAR 14, 1995
3 Q
4 ;
5 ;
6DQ ; queue comes here
7 N GECSBADA,GECSBATC,GECSCOUN,GECSDA,GECSDATA,GECSNOW,GECSTRAN,PAGE,SCREEN
8 S SCREEN=0 I '$D(ZTQUEUED),IO=IO(0),$E(IOST)="C" S SCREEN=1
9 D NOW^%DTC S Y=% D DD^%DT S GECSNOW=Y,PAGE=1 U IO D H
10 W !!," STATION: ",GECS("SITE")_GECS("SITE1"),!,"BATCH TYPE: ",$S($G(GECSSYS)="*":"** ALL **",1:GECS("BATCH")),!," USER: ",$P($G(^VA(200,DUZ,0)),"^")
11 W !!,"Deleting all code sheets created or transmitted before: ",GECSDATE
12 ;
13 ; delete transmitted batches
14 W !!,"deleting batches and code sheets contained in batches:"
15 S (GECSCOUN,GECSBADA)=0 F S GECSBADA=$O(^GECS(2101.3,GECSBADA)) Q:'GECSBADA S GECSDATA=$G(^(GECSBADA,0)),GECSBATC=$P(GECSDATA,"^") D
16 . N GECSSUF
17 . S GECSSUF=GECS("SITE")_GECS("SITE1")
18 . I $P(GECSBATC,"-")'=GECSSUF Q
19 . I $G(GECSSYS)'="*",$P(GECSDATA,"^",2)'=GECS("SYSID") Q
20 . I $G(GECSSYS)'="*" I $P(GECSDATA,"^",6)=""!($P(GECSDATA,"^",6)'=GECS("BATDA")) Q
21 . I $P(GECSDATA,"^",10)'<GECSDT Q
22 . W !?5,GECSBATC
23 . D KILLBATC(GECSBADA)
24 . W " --deleted, cleaning up associated code sheets:"
25 . ; remove code sheets associated with batch
26 . W !?14
27 . 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
28 ;
29 ; delete code sheets created before date and not batched
30 W !,"cleaning up code sheets:",!?14
31 S GECSDA=0 F S GECSDA=$O(^GECS(2100,GECSDA)) Q:'GECSDA S GECSDATA=$G(^(GECSDA,0)) D
32 . I $G(GECSSYS)'="*" I $P(GECSDATA,"^",2)'=GECS("SYSID")!($P(GECSDATA,"^",3)'=GECS("BATDA")) Q
33 . ; delete code sheet if batch number is not found
34 . S GECSTRAN=$G(^GECS(2100,GECSDA,"TRANS"))
35 . 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
36 . ;
37 . ; do not delete if code sheet has batch number, batched code
38 . ; sheets deleted above
39 . I $P(GECSTRAN,"^",9)'="" Q
40 . I ($P(GECSDATA,"^",6)'=GECS("SITE"))&($P(GECSDATA,"^",7)'=GECS("SITE1")) Q
41 . I $P(GECSDATA,"^",10)>GECSDT Q
42 . W $J($P(GECSDATA,"^"),10) D KILLCS(GECSDA) W:$X>68 !?14 S GECSCOUN=GECSCOUN+1
43 ;
44 W !!,"Finished - deleted ",GECSCOUN," code sheets."
45 ;
46 ; clean stack file
47 I $G(GECSDTST) D
48 . W !,"cleaning up stack file:",!?14
49 . S GECSDA=0 F S GECSDA=$O(^GECS(2100.1,GECSDA)) Q:'GECSDA S GECSDATA=$G(^(GECSDA,0)) D
50 . . I $P($P(GECSDATA,"^",3),".")>GECSDTST Q
51 . . W $P(GECSDATA,"^"),!?14
52 . . D KILLSTAC(GECSDA)
53 Q
54 ;
55 ;
56H ; header
57 S %=GECSNOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
58 W !,"CODE SHEET/TRANSMISSION RECORD DELETION TRANSCRIPT ",%
59 S %="",$P(%,"-",81)="" W !,%
60 Q
61 ;
62 ;
63KILLBATC(DA) ; kill batch da from file 2101.3
64 I '$D(^GECS(2101.3,DA)) Q
65 N %,DIC,DIK,X,Y
66 S DIK="^GECS(2101.3," D ^DIK
67 Q
68 ;
69 ;
70KILLCS(DA) ; delete code sheet da
71 I '$D(^GECS(2100,DA)) Q
72 N %,DIC,DIK,X,Y
73 S DIK="^GECS(2100," D ^DIK
74 Q
75 ;
76 ;
77KILLSTAC(DA) ; delete stack file entry da
78 I '$D(^GECS(2100.1,DA)) Q
79 N %,DIC,DIK,X,Y
80 S DIK="^GECS(2100.1," D ^DIK
81 Q
Note: See TracBrowser for help on using the repository browser.