- 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 Feb 19, 2025@00:19:35 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