KMPDUTL3.m

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 ---KMPDUTL3   1469     printed  Mar 13, 2025@20:45:59                                                                                                                                                                                                    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