IBDFPRG ;ALB/AAS - AICS PURGE UTILITY ; 4-OCT-95
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
% ; -- purge utility for purging entries from the
; Form Definition file (357.95)
; Form Tracking file (357.96)
; Form Specification file (359.2)
; AICS Error Log file (359.3)
;
MANUAL ; -- Option to purge records, ask input
N IBCNT2,IBCNT5,IBCNT6,IBCNT7,IBD,IBHOW,IBLDT,IBDAYS,IBPURGE,IBQUIT,DIR,DIRUT,DUOUT,X,Y,IBLOG,D0,DA,D,ZTSK
I '$D(DT) D DT^DICRW
;
S IBQUIT=0
D ASK
Q:IBQUIT
S IBLDT=$$FMADD^XLFDT(DT,-IBDAYS)
S ZTSAVE("IB*")="",ZTRTN="DQ^IBDFPRG",ZTDESC="IBD - Manual Purge of form tracking",ZTIO="" D ^%ZTLOAD
W !,$S($D(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled") D HOME^%ZIS S IBQUIT=1 Q
Q
;
DQ ; -- entry point from manual task
S IBLOG=$$ADD
I IBPURGE("FT") D PURGFT^IBDFPRG1(IBLDT,IBHOW),PURGEL^IBDFPRG1(IBLDT)
I IBPURGE("FD") D PURGFD^IBDFPRG1(IBLDT)
D OUTPUT
G EXIT
Q
;
EXIT ; -- exit for all modes
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
AUTO ; -- Background option to automatically purge records
N X,Y,IBCNT2,IBCNT5,IBCNT6,IBCNT7,IBLDT,IBHOW,IBD,IBLOG,D0,DA,D
I '$D(DT) D DT^DICRW
;
; -- if parameters not defined don't run
I $P($G(^IBD(357.09,1,0)),"^",3)=""!($P($G(^IBD(357.09,1,0)),"^",2)="") G AUTOQ
S IBHOW=$P($G(^IBD(357.09,1,0)),"^",2)
;
; -- Compute last date to purge records
S IBLDT=$$FMADD^XLFDT(DT,-$P($G(^IBD(357.09,1,0)),"^",3))
S IBLOG=$$ADD
;
; -- purge all entries in form tracking according to parameters
D PURGFT^IBDFPRG1(IBLDT,+$P($G(^IBD(357.09,1,0)),"^",2))
;
; -- purge form definition entries only if marked for deletion
; and all entries are complete
D PURGFD^IBDFPRG1(IBLDT)
;
; -- purge entries from AICS ERROR LOG (359.3)
D PURGEL^IBDFPRG1(IBLDT)
;
D OUTPUT
G EXIT
;
AUTOQ Q
;
ADD() ; -- add new entry to purge log
N DIC,DLAYGO
S Y=-1
I $G(^IBD(357.08,0))'="" S X=$$NOW^XLFDT,DIC="^IBD(357.08,",DIC(0)="L",DLAYGO=357.08 D FILE^DICN
ADDQ Q +Y
;
EDIT ; -- update entry after running
N DIC,DIE,DA,DR,X,Y
I IBLOG<1!($G(^IBD(357.08,+IBLOG,0))="") Q
S DIE="^IBD(357.08,",DA=IBLOG
S DR=".02////"_$G(IBHOW)_";.03////"_$G(IBLDT)_";.04////"_$G(IBCNT6)_";.05////"_$G(IBCNT5)_";.06////"_$G(IBCNT2)_";.07////"_$G(IBCNT7)
D ^DIE
Q
;
OUTPUT ; -- output results of purge
;
S IBD(1)="Purge of Form Tracking Statistics"
S IBD(2)="Status of Form Tracking Entries Purged .......... "_$S(+$G(IBHOW)=0:"None",$G(IBHOW)=1:"Completed",$G(IBHOW)=2:"All",1:"None")
S IBD(3)="Form Tracking entries purged upto ............... "_$$FMTE^XLFDT($G(IBLDT))
S IBD(4)="Number of Form tracking Entries Deleted ......... "_$G(IBCNT6)
S IBD(5)="Number of Form Definition Entries Deleted ....... "_$G(IBCNT5)
S IBD(6)="Number of Form Specification Entries Deleted .... "_$G(IBCNT2)
S IBD(7)="Number of AICS Error Log Entries Deleted ........ "_$G(IBCNT7)
D EDIT,SEND
;
I '$D(ZTQUEUED) S X="" F S X=$O(IBD(X)) Q:'X W !,IBD(X)
Q
;
ASK ; -- ask what to purge
; Output : ibpurge("ft") := 1=yes purge form tracking, 0=no
; ibpurge("fd") := 1=yes purge form definition, 0=no
;
N DIR
S IBPURGE("FD")=0,IBPURGE("FT")=0
;
S DIR(0)="Y"
S DIR("?")="Answer YES if you want to purge Form Tracking of unneeded records"
W !!!,"Do you want to purge Form Tracking?"
D ^DIR
I $D(DIRUT) S IBQUIT=1 Q
S IBPURGE("FT")=+Y
;
K DIR
S DIR(0)="Y"
S DIR("?")="Answer YES if you want to purge Form Defintions of unneeded records"
W !!,"Do you want to purge Form Definitions and Form Specifications?"
D ^DIR
I $D(DIRUT) S IBQUIT=1 Q
S IBPURGE("FD")=+Y
;
; -- if the user wants to purge form tracking get needed parms
I IBPURGE("FT")!(IBPURGE("FD")) D ASKN,ASKH
I 'IBPURGE("FT"),'IBPURGE("FD") S IBQUIT=1
Q
;
ASKN ; -- ask number of days to retain
; Output : IBDAYS := number of days to retain
;
N DIR
S IBDAYS=-1
S DIR(0)="N^60:999:0"
S DIR("A")="Number of Days to Retain"
S DIR("B")=+$P($G(^IBD(357.09,1,0)),"^",3)
S DIR("?")="Enter the number of days of form tracking data to retain"
D ^DIR
I $D(DIRUT) S IBQUIT=1 Q
S IBDAYS=+Y
Q
;
ASKH ; -- ask how to purge
; Output : IBHOW := 0=none, 1=complete, 2=all
;
N DIR
S IBHOW=-1
S DIR(0)="S^0:None;1:Purge Completed Entries;2:Purge All Entries"
S DIR("A")="Purge what Entries"
S DIR("B")=+$P($G(^IBD(357.09,1,0)),"^",2)
S DIR("?")="Choose whether you want to purge only completed entries or whether to purge all entries"
D ^DIR
I $D(DIRUT) S IBQUIT=1 Q
S IBHOW=+Y
Q
;
SEND ; -- send mail message to group if defined
N IBDGRP,XMDUZ,XMTEXT,XMY,XMSUB,XMZ
S XMDUZ="AICS PACKAGE",XMTEXT="IBD(",XMSUB="AICS PURGE RESULTS"
K XMY S XMN=0
S IBDGRP=$$GET1^DIQ(3.8,+$P($G(^IBD(357.09,1,1)),"^"),.01)
;S IBDGRP=$P($G(^XMB(3.8,+$P($G(^IBD(357.09,1,1)),"^"),0)),"^")
Q:IBDGRP=""
S XMY("G."_IBDGRP_"@"_^XMB("NETNAME"))=""
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFPRG 4975 printed Nov 22, 2024@18:03:18 Page 2
IBDFPRG ;ALB/AAS - AICS PURGE UTILITY ; 4-OCT-95
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
% ; -- purge utility for purging entries from the
+1 ; Form Definition file (357.95)
+2 ; Form Tracking file (357.96)
+3 ; Form Specification file (359.2)
+4 ; AICS Error Log file (359.3)
+5 ;
MANUAL ; -- Option to purge records, ask input
+1 NEW IBCNT2,IBCNT5,IBCNT6,IBCNT7,IBD,IBHOW,IBLDT,IBDAYS,IBPURGE,IBQUIT,DIR,DIRUT,DUOUT,X,Y,IBLOG,D0,DA,D,ZTSK
+2 IF '$DATA(DT)
DO DT^DICRW
+3 ;
+4 SET IBQUIT=0
+5 DO ASK
+6 if IBQUIT
QUIT
+7 SET IBLDT=$$FMADD^XLFDT(DT,-IBDAYS)
+8 SET ZTSAVE("IB*")=""
SET ZTRTN="DQ^IBDFPRG"
SET ZTDESC="IBD - Manual Purge of form tracking"
SET ZTIO=""
DO ^%ZTLOAD
+9 WRITE !,$SELECT($DATA(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled")
DO HOME^%ZIS
SET IBQUIT=1
QUIT
+10 QUIT
+11 ;
DQ ; -- entry point from manual task
+1 SET IBLOG=$$ADD
+2 IF IBPURGE("FT")
DO PURGFT^IBDFPRG1(IBLDT,IBHOW)
DO PURGEL^IBDFPRG1(IBLDT)
+3 IF IBPURGE("FD")
DO PURGFD^IBDFPRG1(IBLDT)
+4 DO OUTPUT
+5 GOTO EXIT
+6 QUIT
+7 ;
EXIT ; -- exit for all modes
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
+3 ;
AUTO ; -- Background option to automatically purge records
+1 NEW X,Y,IBCNT2,IBCNT5,IBCNT6,IBCNT7,IBLDT,IBHOW,IBD,IBLOG,D0,DA,D
+2 IF '$DATA(DT)
DO DT^DICRW
+3 ;
+4 ; -- if parameters not defined don't run
+5 IF $PIECE($GET(^IBD(357.09,1,0)),"^",3)=""!($PIECE($GET(^IBD(357.09,1,0)),"^",2)="")
GOTO AUTOQ
+6 SET IBHOW=$PIECE($GET(^IBD(357.09,1,0)),"^",2)
+7 ;
+8 ; -- Compute last date to purge records
+9 SET IBLDT=$$FMADD^XLFDT(DT,-$PIECE($GET(^IBD(357.09,1,0)),"^",3))
+10 SET IBLOG=$$ADD
+11 ;
+12 ; -- purge all entries in form tracking according to parameters
+13 DO PURGFT^IBDFPRG1(IBLDT,+$PIECE($GET(^IBD(357.09,1,0)),"^",2))
+14 ;
+15 ; -- purge form definition entries only if marked for deletion
+16 ; and all entries are complete
+17 DO PURGFD^IBDFPRG1(IBLDT)
+18 ;
+19 ; -- purge entries from AICS ERROR LOG (359.3)
+20 DO PURGEL^IBDFPRG1(IBLDT)
+21 ;
+22 DO OUTPUT
+23 GOTO EXIT
+24 ;
AUTOQ QUIT
+1 ;
ADD() ; -- add new entry to purge log
+1 NEW DIC,DLAYGO
+2 SET Y=-1
+3 IF $GET(^IBD(357.08,0))'=""
SET X=$$NOW^XLFDT
SET DIC="^IBD(357.08,"
SET DIC(0)="L"
SET DLAYGO=357.08
DO FILE^DICN
ADDQ QUIT +Y
+1 ;
EDIT ; -- update entry after running
+1 NEW DIC,DIE,DA,DR,X,Y
+2 IF IBLOG<1!($GET(^IBD(357.08,+IBLOG,0))="")
QUIT
+3 SET DIE="^IBD(357.08,"
SET DA=IBLOG
+4 SET DR=".02////"_$GET(IBHOW)_";.03////"_$GET(IBLDT)_";.04////"_$GET(IBCNT6)_";.05////"_$GET(IBCNT5)_";.06////"_$GET(IBCNT2)_";.07////"_$GET(IBCNT7)
+5 DO ^DIE
+6 QUIT
+7 ;
OUTPUT ; -- output results of purge
+1 ;
+2 SET IBD(1)="Purge of Form Tracking Statistics"
+3 SET IBD(2)="Status of Form Tracking Entries Purged .......... "_$SELECT(+$GET(IBHOW)=0:"None",$GET(IBHOW)=1:"Completed",$GET(IBHOW)=2:"All",1:"None")
+4 SET IBD(3)="Form Tracking entries purged upto ............... "_$$FMTE^XLFDT($GET(IBLDT))
+5 SET IBD(4)="Number of Form tracking Entries Deleted ......... "_$GET(IBCNT6)
+6 SET IBD(5)="Number of Form Definition Entries Deleted ....... "_$GET(IBCNT5)
+7 SET IBD(6)="Number of Form Specification Entries Deleted .... "_$GET(IBCNT2)
+8 SET IBD(7)="Number of AICS Error Log Entries Deleted ........ "_$GET(IBCNT7)
+9 DO EDIT
DO SEND
+10 ;
+11 IF '$DATA(ZTQUEUED)
SET X=""
FOR
SET X=$ORDER(IBD(X))
if 'X
QUIT
WRITE !,IBD(X)
+12 QUIT
+13 ;
ASK ; -- ask what to purge
+1 ; Output : ibpurge("ft") := 1=yes purge form tracking, 0=no
+2 ; ibpurge("fd") := 1=yes purge form definition, 0=no
+3 ;
+4 NEW DIR
+5 SET IBPURGE("FD")=0
SET IBPURGE("FT")=0
+6 ;
+7 SET DIR(0)="Y"
+8 SET DIR("?")="Answer YES if you want to purge Form Tracking of unneeded records"
+9 WRITE !!!,"Do you want to purge Form Tracking?"
+10 DO ^DIR
+11 IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+12 SET IBPURGE("FT")=+Y
+13 ;
+14 KILL DIR
+15 SET DIR(0)="Y"
+16 SET DIR("?")="Answer YES if you want to purge Form Defintions of unneeded records"
+17 WRITE !!,"Do you want to purge Form Definitions and Form Specifications?"
+18 DO ^DIR
+19 IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+20 SET IBPURGE("FD")=+Y
+21 ;
+22 ; -- if the user wants to purge form tracking get needed parms
+23 IF IBPURGE("FT")!(IBPURGE("FD"))
DO ASKN
DO ASKH
+24 IF 'IBPURGE("FT")
IF 'IBPURGE("FD")
SET IBQUIT=1
+25 QUIT
+26 ;
ASKN ; -- ask number of days to retain
+1 ; Output : IBDAYS := number of days to retain
+2 ;
+3 NEW DIR
+4 SET IBDAYS=-1
+5 SET DIR(0)="N^60:999:0"
+6 SET DIR("A")="Number of Days to Retain"
+7 SET DIR("B")=+$PIECE($GET(^IBD(357.09,1,0)),"^",3)
+8 SET DIR("?")="Enter the number of days of form tracking data to retain"
+9 DO ^DIR
+10 IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+11 SET IBDAYS=+Y
+12 QUIT
+13 ;
ASKH ; -- ask how to purge
+1 ; Output : IBHOW := 0=none, 1=complete, 2=all
+2 ;
+3 NEW DIR
+4 SET IBHOW=-1
+5 SET DIR(0)="S^0:None;1:Purge Completed Entries;2:Purge All Entries"
+6 SET DIR("A")="Purge what Entries"
+7 SET DIR("B")=+$PIECE($GET(^IBD(357.09,1,0)),"^",2)
+8 SET DIR("?")="Choose whether you want to purge only completed entries or whether to purge all entries"
+9 DO ^DIR
+10 IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+11 SET IBHOW=+Y
+12 QUIT
+13 ;
SEND ; -- send mail message to group if defined
+1 NEW IBDGRP,XMDUZ,XMTEXT,XMY,XMSUB,XMZ
+2 SET XMDUZ="AICS PACKAGE"
SET XMTEXT="IBD("
SET XMSUB="AICS PURGE RESULTS"
+3 KILL XMY
SET XMN=0
+4 SET IBDGRP=$$GET1^DIQ(3.8,+$PIECE($GET(^IBD(357.09,1,1)),"^"),.01)
+5 ;S IBDGRP=$P($G(^XMB(3.8,+$P($G(^IBD(357.09,1,1)),"^"),0)),"^")
+6 if IBDGRP=""
QUIT
+7 SET XMY("G."_IBDGRP_"@"_^XMB("NETNAME"))=""
+8 DO ^XMD
+9 QUIT
