XTPMKPP.m

XTPMKPP ;OAK/BP - PATCH MONITOR PURGING; 4/13/21

 ;;7.3;TOOLKIT;**98,104,150**; Apr 25, 1995;Build 1

 ;;Per VA Directive 6402, this routine should not be modified

 ;

EN D DT^DICRW

 ; number of days to keep data in param file

 S XTBPDAYS=$P($G(^XPD(9.95,1,0)),U,2)

 I +XTBPDAYS=0 S XTBPDAYS=30 ; minimum of 30 days

 S X1=DT,X2=-XTBPDAYS D C^%DTC S XTBEND=X+.2359,XTBX=""

 F  S XTBX=$O(^XPD(9.9,"B",XTBX)) Q:XTBX=""  F XTBDA=0:0 S XTBDA=$O(^XPD(9.9,"B",XTBX,XTBDA)) Q:XTBDA=""  DO

 .S XTBDTA=$G(^XPD(9.9,XTBDA,0)) Q:XTBDTA=""

 .I $P(XTBDTA,U,10) D NONKID(XTBDA,XTBDTA,XTBEND) Q

 .S XTBINST=$P(XTBDTA,U,8) I $G(XTBINST)="" N DA S DIK="^XPD(9.9,",DA=XTBDA D ^DIK Q  ; check install name if it is NULL p752

 .S XTBCMPDT=$P(XTBDTA,U,9) ; compliance date

 .S XTBXX=$O(^XPD(9.7,"B",XTBINST,"A"),-1) I +XTBXX'>0 Q 

 .Q:$P($G(^XPD(9.7,+XTBXX,0)),U,9)'=3  ; not installed

 .I XTBCMPDT<XTBEND S DIK="^XPD(9.9,",DA=XTBDA D ^DIK

 K XTBPDAYS,X1,X2,XTBEND,XTBX,XTBXX,XTBDA,XTBCMPDT,DIK,DA,XTBINST,XTBDTA,X

 Q

NONKID(XTBDA,XTBDTA,XTBEND) ;Delete Non_Kid patches

 N DA,DIK,XTNKB,XTNKBID,XTBCMPDT

 S XTBCMPDT=$P(XTBDTA,U,9) ; compliance date

 S XTNKB=$P(XTBDTA,U,10) ; Non-Kids build

 S XTNKBID=$P(XTBDTA,U,11) ; Non-Kids build Install date

 I XTBCMPDT,XTNKBID,XTBCMPDT<XTBEND S DIK="^XPD(9.9,",DA=XTBDA D ^DIK

 Q

 ;

UNITEST ;

 N XTBX,IEN S XTBX=0 F  S XTBX=$O(^XPD(9.9,"B",XTBX)) Q:XTBX=""  S IEN=$O(^XPD(9.9,"B",XTBX,0)) W !,IEN,?15,$P($G(^XPD(9.9,IEN,0)),"^",8)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XTPMKPP   1479     printed  Apr 09, 2024@21:42:47                                                                                                                                                                                                     Page 2

XTPMKPP   ;OAK/BP - PATCH MONITOR PURGING; 4/13/21

 +1       ;;7.3;TOOLKIT;**98,104,150**; Apr 25, 1995;Build 1

 +2       ;;Per VA Directive 6402, this routine should not be modified

 +3       ;

EN         DO DT^DICRW

 +1       ; number of days to keep data in param file

 +2        SET XTBPDAYS=$PIECE($GET(^XPD(9.95,1,0)),U,2)

 +3       ; minimum of 30 days

           IF +XTBPDAYS=0

               SET XTBPDAYS=30

 +4        SET X1=DT

           SET X2=-XTBPDAYS

           DO C^%DTC

           SET XTBEND=X+.2359

           SET XTBX=""

 +5        FOR 

               SET XTBX=$ORDER(^XPD(9.9,"B",XTBX))

               if XTBX=""

                   QUIT 

               FOR XTBDA=0:0

                   SET XTBDA=$ORDER(^XPD(9.9,"B",XTBX,XTBDA))

                   if XTBDA=""

                       QUIT 

                   Begin DoDot:1

 +6                    SET XTBDTA=$GET(^XPD(9.9,XTBDA,0))

                       if XTBDTA=""

                           QUIT 

 +7                    IF $PIECE(XTBDTA,U,10)

                           DO NONKID(XTBDA,XTBDTA,XTBEND)

                           QUIT 

 +8       ; check install name if it is NULL p752

                       SET XTBINST=$PIECE(XTBDTA,U,8)

                       IF $GET(XTBINST)=""

                           NEW DA

                           SET DIK="^XPD(9.9,"

                           SET DA=XTBDA

                           DO ^DIK

                           QUIT 

 +9       ; compliance date

                       SET XTBCMPDT=$PIECE(XTBDTA,U,9)

 +10                   SET XTBXX=$ORDER(^XPD(9.7,"B",XTBINST,"A"),-1)

                       IF +XTBXX'>0

                           QUIT 

 +11      ; not installed

                       if $PIECE($GET(^XPD(9.7,+XTBXX,0)),U,9)'=3

                           QUIT 

 +12                   IF XTBCMPDT<XTBEND

                           SET DIK="^XPD(9.9,"

                           SET DA=XTBDA

                           DO ^DIK

                   End DoDot:1

 +13       KILL XTBPDAYS,X1,X2,XTBEND,XTBX,XTBXX,XTBDA,XTBCMPDT,DIK,DA,XTBINST,XTBDTA,X

 +14       QUIT 

NONKID(XTBDA,XTBDTA,XTBEND) ;Delete Non_Kid patches

 +1        NEW DA,DIK,XTNKB,XTNKBID,XTBCMPDT

 +2       ; compliance date

           SET XTBCMPDT=$PIECE(XTBDTA,U,9)

 +3       ; Non-Kids build

           SET XTNKB=$PIECE(XTBDTA,U,10)

 +4       ; Non-Kids build Install date

           SET XTNKBID=$PIECE(XTBDTA,U,11)

 +5        IF XTBCMPDT

               IF XTNKBID

                   IF XTBCMPDT<XTBEND

                       SET DIK="^XPD(9.9,"

                       SET DA=XTBDA

                       DO ^DIK

 +6        QUIT 

 +7       ;

UNITEST   ;

 +1        NEW XTBX,IEN

           SET XTBX=0

           FOR 

               SET XTBX=$ORDER(^XPD(9.9,"B",XTBX))

               if XTBX=""

                   QUIT 

               SET IEN=$ORDER(^XPD(9.9,"B",XTBX,0))

               WRITE !,IEN,?15,$PIECE($GET(^XPD(9.9,IEN,0)),"^",8)

 +2        QUIT