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 ---[H[J[2J[HXTPMKPP 1479 printed Dec 13, 2024@02:41:35 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
