IBDFPRG1 ;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)
G MANUAL^IBDFPRG
;
;
PURGFD(IBLDT) ; -- Procedure
; -- purge entires in Form Definition file marked for deletion
; that were marked before ibldt and no incomplete entries in
; form tracking exist
;
; Input : ibldt := only purge records with a date marked for
; deletion older than this date
; Output: ibcnt5 := number of entries in 357.95 deleted
; ibcnt2 := number of entries in 359.2 deleted
;
N IBI,IBJ,IBSTAT,X,Y
S (IBCNT5,IBCNT2)=0
I IBLDT=""!(IBLDT'?7N) G PURGFDQ
S IBI=0
F S IBI=$O(^IBD(357.95,"ADEL",IBI)) Q:'IBI!(IBI'<IBLDT) D
.S IBJ=0
.F S IBJ=$O(^IBD(357.95,"ADEL",IBI,IBJ)) Q:'IBJ D
..
..; -- "a" x-ref is special x-ref of all forms not received
..; for 357.95 check KILLTYPE^IBDF19
..;
..I $D(^IBD(357.96,"A",IBJ)) Q
..I $D(^IBD(357.95,IBJ,0)) S X=$$DEL("^IBD(357.95,",IBJ),IBCNT5=IBCNT5+1
..I $D(^IBD(359.2,IBJ,0)) S X=$$DEL("^IBD(359.2,",IBJ),IBCNT2=IBCNT2+1
..Q
.Q
;
PURGFDQ Q
;
PURGFT(IBLDT,IBHOW) ; -- Procedure
; -- purge entries from form tracking file (357.96)
; Input : ibldt := only purge records with an appointment
; date older than this date
; ibhow := 0=no records, 1=complete, 2=all
; Output: ibcnt6 := number of entries in 357.96 deleted
;
N X,Y,IBI,IBJ,IBSTAT
S IBCNT6=0
I IBLDT=""!(IBLDT'?7N) G PURGFTQ
S IBHOW=+$G(IBHOW)
I IBHOW<0!(IBHOW>2) G PURGFTQ
;
S IBI=0
F S IBI=$O(^IBD(357.96,"D",IBI)) Q:'IBI!(IBI'<IBLDT) D
.S IBJ=0
.F S IBJ=$O(^IBD(357.96,"D",IBI,IBJ)) Q:'IBJ D
..I $$STATCHK(IBJ,IBHOW) S X=$$DEL("^IBD(357.96,",IBJ),IBCNT6=IBCNT6+1
..Q
.Q
PURGFTQ Q
;
PURGEL(IBLDT) ; --
; -- Purge AICS Error Log older created prior to ibdldt
; Input : ibldt := only purge error created prior to this date
;
; Output: ibcnt7 := number of entries in 359.3 deleted
;
N IBI,IBJ
S (IBCNT7,IBI)=0
F S IBI=$O(^IBD(359.3,"B",IBI)) Q:'IBI!(IBI'<IBLDT) D
.S IBJ=0
.F S IBJ=$O(^IBD(359.3,"B",IBI,IBJ)) Q:'IBJ D
..I $D(^IBD(359.3,IBJ,0)) S X=$$DEL("^IBD(359.3,",IBJ),IBCNT7=IBCNT7+1
PURGELQ Q
;
STATCHK(ENTRY,IBHOW) ; -- Function
; -- determine if entry in 357.96 can be deleted
; Input : Entry := internal number of entry in 357.96
; ibhow := 0,1,2, to delete none, complete, or all
; Output: Okay := 1=okay to delete, 0=not okay
;
N OKAY,STATUS
S OKAY=0
S IBHOW=+$G(IBHOW)
I IBHOW<1!(IBHOW>2) G STATQ ;How is none or not valid, don't delete
I '$D(^IBD(357.96,ENTRY,0)) G STATQ ;Entry doesn't exist
;
; -- if delete all, okay=1
I IBHOW=2,$P($G(^IBD(357.96,ENTRY,0)),"^",3) S OKAY=1 G STATQ
;
; -- if status = complete, piece 11 must equal 3, 4, or 12 to delete
S STATUS=$P($G(^IBD(357.96,ENTRY,0)),"^",11)
S OKAY=$S(STATUS=3:1,STATUS=4:1,STATUS=6:1,STATUS=7:1,STATUS=12:1,1:0)
;
STATQ Q OKAY
;
DEL(FILE,DA) ; -- Function
; -- delete one entry
; Input : File := internal file number of file or global root
; da := internal number of entry, If more than DA
; needs to be defined then pass da array by
; reference
; Output: 1 := succeded, 0 := failed
;
N SUCCESS
S SUCCESS=0
I $G(FILE)=""!(+$G(DA)<1) G DELQ
S DIK=FILE D ^DIK
S SUCCESS=1
W:'$D(ZTQUEUED) !,"Entry number "_DA_" in file "_DIK_" Deleted!"
DELQ Q SUCCESS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFPRG1 3701 printed Apr 09, 2024@20:58:39 Page 2
IBDFPRG1 ;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 GOTO MANUAL^IBDFPRG
+5 ;
+6 ;
PURGFD(IBLDT) ; -- Procedure
+1 ; -- purge entires in Form Definition file marked for deletion
+2 ; that were marked before ibldt and no incomplete entries in
+3 ; form tracking exist
+4 ;
+5 ; Input : ibldt := only purge records with a date marked for
+6 ; deletion older than this date
+7 ; Output: ibcnt5 := number of entries in 357.95 deleted
+8 ; ibcnt2 := number of entries in 359.2 deleted
+9 ;
+10 NEW IBI,IBJ,IBSTAT,X,Y
+11 SET (IBCNT5,IBCNT2)=0
+12 IF IBLDT=""!(IBLDT'?7N)
GOTO PURGFDQ
+13 SET IBI=0
+14 FOR
SET IBI=$ORDER(^IBD(357.95,"ADEL",IBI))
if 'IBI!(IBI'<IBLDT)
QUIT
Begin DoDot:1
+15 SET IBJ=0
+16 FOR
SET IBJ=$ORDER(^IBD(357.95,"ADEL",IBI,IBJ))
if 'IBJ
QUIT
Begin DoDot:2
+17 +18 ; -- "a" x-ref is special x-ref of all forms not received
+19 ; for 357.95 check KILLTYPE^IBDF19
+20 ;
+21 IF $DATA(^IBD(357.96,"A",IBJ))
QUIT
+22 IF $DATA(^IBD(357.95,IBJ,0))
SET X=$$DEL("^IBD(357.95,",IBJ)
SET IBCNT5=IBCNT5+1
+23 IF $DATA(^IBD(359.2,IBJ,0))
SET X=$$DEL("^IBD(359.2,",IBJ)
SET IBCNT2=IBCNT2+1
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 ;
PURGFDQ QUIT
+1 ;
PURGFT(IBLDT,IBHOW) ; -- Procedure
+1 ; -- purge entries from form tracking file (357.96)
+2 ; Input : ibldt := only purge records with an appointment
+3 ; date older than this date
+4 ; ibhow := 0=no records, 1=complete, 2=all
+5 ; Output: ibcnt6 := number of entries in 357.96 deleted
+6 ;
+7 NEW X,Y,IBI,IBJ,IBSTAT
+8 SET IBCNT6=0
+9 IF IBLDT=""!(IBLDT'?7N)
GOTO PURGFTQ
+10 SET IBHOW=+$GET(IBHOW)
+11 IF IBHOW<0!(IBHOW>2)
GOTO PURGFTQ
+12 ;
+13 SET IBI=0
+14 FOR
SET IBI=$ORDER(^IBD(357.96,"D",IBI))
if 'IBI!(IBI'<IBLDT)
QUIT
Begin DoDot:1
+15 SET IBJ=0
+16 FOR
SET IBJ=$ORDER(^IBD(357.96,"D",IBI,IBJ))
if 'IBJ
QUIT
Begin DoDot:2
+17 IF $$STATCHK(IBJ,IBHOW)
SET X=$$DEL("^IBD(357.96,",IBJ)
SET IBCNT6=IBCNT6+1
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
PURGFTQ QUIT
+1 ;
PURGEL(IBLDT) ; --
+1 ; -- Purge AICS Error Log older created prior to ibdldt
+2 ; Input : ibldt := only purge error created prior to this date
+3 ;
+4 ; Output: ibcnt7 := number of entries in 359.3 deleted
+5 ;
+6 NEW IBI,IBJ
+7 SET (IBCNT7,IBI)=0
+8 FOR
SET IBI=$ORDER(^IBD(359.3,"B",IBI))
if 'IBI!(IBI'<IBLDT)
QUIT
Begin DoDot:1
+9 SET IBJ=0
+10 FOR
SET IBJ=$ORDER(^IBD(359.3,"B",IBI,IBJ))
if 'IBJ
QUIT
Begin DoDot:2
+11 IF $DATA(^IBD(359.3,IBJ,0))
SET X=$$DEL("^IBD(359.3,",IBJ)
SET IBCNT7=IBCNT7+1
End DoDot:2
End DoDot:1
PURGELQ QUIT
+1 ;
STATCHK(ENTRY,IBHOW) ; -- Function
+1 ; -- determine if entry in 357.96 can be deleted
+2 ; Input : Entry := internal number of entry in 357.96
+3 ; ibhow := 0,1,2, to delete none, complete, or all
+4 ; Output: Okay := 1=okay to delete, 0=not okay
+5 ;
+6 NEW OKAY,STATUS
+7 SET OKAY=0
+8 SET IBHOW=+$GET(IBHOW)
+9 ;How is none or not valid, don't delete
IF IBHOW<1!(IBHOW>2)
GOTO STATQ
+10 ;Entry doesn't exist
IF '$DATA(^IBD(357.96,ENTRY,0))
GOTO STATQ
+11 ;
+12 ; -- if delete all, okay=1
+13 IF IBHOW=2
IF $PIECE($GET(^IBD(357.96,ENTRY,0)),"^",3)
SET OKAY=1
GOTO STATQ
+14 ;
+15 ; -- if status = complete, piece 11 must equal 3, 4, or 12 to delete
+16 SET STATUS=$PIECE($GET(^IBD(357.96,ENTRY,0)),"^",11)
+17 SET OKAY=$SELECT(STATUS=3:1,STATUS=4:1,STATUS=6:1,STATUS=7:1,STATUS=12:1,1:0)
+18 ;
STATQ QUIT OKAY
+1 ;
DEL(FILE,DA) ; -- Function
+1 ; -- delete one entry
+2 ; Input : File := internal file number of file or global root
+3 ; da := internal number of entry, If more than DA
+4 ; needs to be defined then pass da array by
+5 ; reference
+6 ; Output: 1 := succeded, 0 := failed
+7 ;
+8 NEW SUCCESS
+9 SET SUCCESS=0
+10 IF $GET(FILE)=""!(+$GET(DA)<1)
GOTO DELQ
+11 SET DIK=FILE
DO ^DIK
+12 SET SUCCESS=1
+13 if '$DATA(ZTQUEUED)
WRITE !,"Entry number "_DA_" in file "_DIK_" Deleted!"
DELQ QUIT SUCCESS
