KMPDUTL3 ;OAK/RAK - CM Tools Utility ;2/17/04 10:53
;;3.0;KMPD;;Jan 22, 2009;Build 42
;
PURGE(KMPDT) ;-- purge data in file #8973.1
;-----------------------------------------------------------------------
; KMPDT.. Date to begin purge in internal fileman format. Purge will
; reverse $order and delete entries 'EARLIER' than KMPDT.
;-----------------------------------------------------------------------
;
Q:'$G(KMPDT)
;
N DA,DATE,DIK,IEN
W:'$D(ZTQUEUED) !!,"Purging old records..."
S DATE=KMPDT
F S DATE=$O(^KMPD(8973.1,"B",DATE),-1) Q:'DATE!(DATE>KMPDT) D
.F IEN=0:0 S IEN=$O(^KMPD(8973.1,"B",DATE,IEN)) Q:'IEN D
..; quit if not 'sent to cm database'.
..Q:'$P($G(^KMPD(8973.1,IEN,0)),U,2)
..I '$D(ZTQUEUED) W:$X>78 !?16 W "."
..; Delete entry.
..S DA=IEN,DIK="^KMPD(8973.1," D ^DIK
;
Q
;
PURGE1 ;-- purge data in file #8973.2
;
N DA,DATE,DAYS,DIK,IEN,PURGE
;
; days to keep data (weeks * 7)
S DAYS=$P($G(^KMPD(8973,1,4)),U,11)
S:'DAYS DAYS=4 S DAYS=DAYS*7
; determine date to start purge
S PURGE=$$FMADD^XLFDT(DT,-DAYS) Q:'PURGE
W:'$D(ZTQUEUED) !!,"Purging old records..."
S DATE=PURGE-.1
F S DATE=$O(^KMPD(8973.2,"C",DATE),-1) Q:'DATE!(DATE>PURGE) D
.F IEN=0:0 S IEN=$O(^KMPD(8973.2,"C",DATE,IEN)) Q:'IEN D
..I '$D(^KMPD(8973.2,IEN,0)) K ^KMPD(8973.2,"C",DATE,IEN) Q
..W:'$D(ZTQUEUED)&('(IEN#10)) "."
..; delete entry.
..S DA=IEN,DIK="^KMPD(8973.2," D ^DIK
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HKMPDUTL3 1469 printed Apr 09, 2024@20:46:56 Page 2
KMPDUTL3 ;OAK/RAK - CM Tools Utility ;2/17/04 10:53
+1 ;;3.0;KMPD;;Jan 22, 2009;Build 42
+2 ;
PURGE(KMPDT) ;-- purge data in file #8973.1
+1 ;-----------------------------------------------------------------------
+2 ; KMPDT.. Date to begin purge in internal fileman format. Purge will
+3 ; reverse $order and delete entries 'EARLIER' than KMPDT.
+4 ;-----------------------------------------------------------------------
+5 ;
+6 if '$GET(KMPDT)
QUIT
+7 ;
+8 NEW DA,DATE,DIK,IEN
+9 if '$DATA(ZTQUEUED)
WRITE !!,"Purging old records..."
+10 SET DATE=KMPDT
+11 FOR
SET DATE=$ORDER(^KMPD(8973.1,"B",DATE),-1)
if 'DATE!(DATE>KMPDT)
QUIT
Begin DoDot:1
+12 FOR IEN=0:0
SET IEN=$ORDER(^KMPD(8973.1,"B",DATE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+13 ; quit if not 'sent to cm database'.
+14 if '$PIECE($GET(^KMPD(8973.1,IEN,0)),U,2)
QUIT
+15 IF '$DATA(ZTQUEUED)
if $X>78
WRITE !?16
WRITE "."
+16 ; Delete entry.
+17 SET DA=IEN
SET DIK="^KMPD(8973.1,"
DO ^DIK
End DoDot:2
End DoDot:1
+18 ;
+19 QUIT
+20 ;
PURGE1 ;-- purge data in file #8973.2
+1 ;
+2 NEW DA,DATE,DAYS,DIK,IEN,PURGE
+3 ;
+4 ; days to keep data (weeks * 7)
+5 SET DAYS=$PIECE($GET(^KMPD(8973,1,4)),U,11)
+6 if 'DAYS
SET DAYS=4
SET DAYS=DAYS*7
+7 ; determine date to start purge
+8 SET PURGE=$$FMADD^XLFDT(DT,-DAYS)
if 'PURGE
QUIT
+9 if '$DATA(ZTQUEUED)
WRITE !!,"Purging old records..."
+10 SET DATE=PURGE-.1
+11 FOR
SET DATE=$ORDER(^KMPD(8973.2,"C",DATE),-1)
if 'DATE!(DATE>PURGE)
QUIT
Begin DoDot:1
+12 FOR IEN=0:0
SET IEN=$ORDER(^KMPD(8973.2,"C",DATE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+13 IF '$DATA(^KMPD(8973.2,IEN,0))
KILL ^KMPD(8973.2,"C",DATE,IEN)
QUIT
+14 if '$DATA(ZTQUEUED)&('(IEN#10))
WRITE "."
+15 ; delete entry.
+16 SET DA=IEN
SET DIK="^KMPD(8973.2,"
DO ^DIK
End DoDot:2
End DoDot:1
+17 ;
+18 QUIT
