Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFPRG1

IBDFPRG1.m

Go to the documentation of this file.
  1. IBDFPRG1 ;ALB/AAS - AICS PURGE UTILITY ; 4-OCT-95
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. ;
  1. % ; -- purge utility for purging entries from the
  1. ; Form Definition file (357.95)
  1. ; Form Tracking file (357.96)
  1. ; Form Specification file (359.2)
  1. G MANUAL^IBDFPRG
  1. ;
  1. ;
  1. PURGFD(IBLDT) ; -- Procedure
  1. ; -- purge entires in Form Definition file marked for deletion
  1. ; that were marked before ibldt and no incomplete entries in
  1. ; form tracking exist
  1. ;
  1. ; Input : ibldt := only purge records with a date marked for
  1. ; deletion older than this date
  1. ; Output: ibcnt5 := number of entries in 357.95 deleted
  1. ; ibcnt2 := number of entries in 359.2 deleted
  1. ;
  1. N IBI,IBJ,IBSTAT,X,Y
  1. S (IBCNT5,IBCNT2)=0
  1. I IBLDT=""!(IBLDT'?7N) G PURGFDQ
  1. S IBI=0
  1. F S IBI=$O(^IBD(357.95,"ADEL",IBI)) Q:'IBI!(IBI'<IBLDT) D
  1. .S IBJ=0
  1. .F S IBJ=$O(^IBD(357.95,"ADEL",IBI,IBJ)) Q:'IBJ D
  1. ..
  1. ..; -- "a" x-ref is special x-ref of all forms not received
  1. ..; for 357.95 check KILLTYPE^IBDF19
  1. ..;
  1. ..I $D(^IBD(357.96,"A",IBJ)) Q
  1. ..I $D(^IBD(357.95,IBJ,0)) S X=$$DEL("^IBD(357.95,",IBJ),IBCNT5=IBCNT5+1
  1. ..I $D(^IBD(359.2,IBJ,0)) S X=$$DEL("^IBD(359.2,",IBJ),IBCNT2=IBCNT2+1
  1. ..Q
  1. .Q
  1. ;
  1. PURGFDQ Q
  1. ;
  1. PURGFT(IBLDT,IBHOW) ; -- Procedure
  1. ; -- purge entries from form tracking file (357.96)
  1. ; Input : ibldt := only purge records with an appointment
  1. ; date older than this date
  1. ; ibhow := 0=no records, 1=complete, 2=all
  1. ; Output: ibcnt6 := number of entries in 357.96 deleted
  1. ;
  1. N X,Y,IBI,IBJ,IBSTAT
  1. S IBCNT6=0
  1. I IBLDT=""!(IBLDT'?7N) G PURGFTQ
  1. S IBHOW=+$G(IBHOW)
  1. I IBHOW<0!(IBHOW>2) G PURGFTQ
  1. ;
  1. S IBI=0
  1. F S IBI=$O(^IBD(357.96,"D",IBI)) Q:'IBI!(IBI'<IBLDT) D
  1. .S IBJ=0
  1. .F S IBJ=$O(^IBD(357.96,"D",IBI,IBJ)) Q:'IBJ D
  1. ..I $$STATCHK(IBJ,IBHOW) S X=$$DEL("^IBD(357.96,",IBJ),IBCNT6=IBCNT6+1
  1. ..Q
  1. .Q
  1. PURGFTQ Q
  1. ;
  1. PURGEL(IBLDT) ; --
  1. ; -- Purge AICS Error Log older created prior to ibdldt
  1. ; Input : ibldt := only purge error created prior to this date
  1. ;
  1. ; Output: ibcnt7 := number of entries in 359.3 deleted
  1. ;
  1. N IBI,IBJ
  1. S (IBCNT7,IBI)=0
  1. F S IBI=$O(^IBD(359.3,"B",IBI)) Q:'IBI!(IBI'<IBLDT) D
  1. .S IBJ=0
  1. .F S IBJ=$O(^IBD(359.3,"B",IBI,IBJ)) Q:'IBJ D
  1. ..I $D(^IBD(359.3,IBJ,0)) S X=$$DEL("^IBD(359.3,",IBJ),IBCNT7=IBCNT7+1
  1. PURGELQ Q
  1. ;
  1. STATCHK(ENTRY,IBHOW) ; -- Function
  1. ; -- determine if entry in 357.96 can be deleted
  1. ; Input : Entry := internal number of entry in 357.96
  1. ; ibhow := 0,1,2, to delete none, complete, or all
  1. ; Output: Okay := 1=okay to delete, 0=not okay
  1. ;
  1. N OKAY,STATUS
  1. S OKAY=0
  1. S IBHOW=+$G(IBHOW)
  1. I IBHOW<1!(IBHOW>2) G STATQ ;How is none or not valid, don't delete
  1. I '$D(^IBD(357.96,ENTRY,0)) G STATQ ;Entry doesn't exist
  1. ;
  1. ; -- if delete all, okay=1
  1. I IBHOW=2,$P($G(^IBD(357.96,ENTRY,0)),"^",3) S OKAY=1 G STATQ
  1. ;
  1. ; -- if status = complete, piece 11 must equal 3, 4, or 12 to delete
  1. S STATUS=$P($G(^IBD(357.96,ENTRY,0)),"^",11)
  1. S OKAY=$S(STATUS=3:1,STATUS=4:1,STATUS=6:1,STATUS=7:1,STATUS=12:1,1:0)
  1. ;
  1. STATQ Q OKAY
  1. ;
  1. DEL(FILE,DA) ; -- Function
  1. ; -- delete one entry
  1. ; Input : File := internal file number of file or global root
  1. ; da := internal number of entry, If more than DA
  1. ; needs to be defined then pass da array by
  1. ; reference
  1. ; Output: 1 := succeded, 0 := failed
  1. ;
  1. N SUCCESS
  1. S SUCCESS=0
  1. I $G(FILE)=""!(+$G(DA)<1) G DELQ
  1. S DIK=FILE D ^DIK
  1. S SUCCESS=1
  1. W:'$D(ZTQUEUED) !,"Entry number "_DA_" in file "_DIK_" Deleted!"
  1. DELQ Q SUCCESS