XTRMON ;ISCSF/RWF - Watch for changes in routine checksums. ;02 Jul 2003 2:59 pm
;;7.3;TOOLKIT;**27,59,70**;Apr 25, 1995
A N CNT,NOW,MODE,RTN,RN,RSUM,TEST,XMB,DA,DIC,X0,OS
K ^TMP($J)
S CNT=0,NOW=$$HTFM^XLFDT($H),U="^"
S RSUM=^%ZOSF("RSUM"),TEST=^%ZOSF("TEST")
S OS=^%ZOSF("OS")
S MODE=$G(^XTV(8989.3,1,"RM")) I "n"[$E(MODE) Q
G ALL:"a"=$E(MODE)
SEL S RTN=""
F S RTN=$O(^XTV(8989.3,1,"RM1","B",RTN)) Q:RTN="" D
. I RTN["*" D RANGE($P(RTN,"*")) Q
. D CHK(RTN)
. Q
EXIT ;
D LOST
S XMB="XTRMON",XMTEXT="^TMP($J,",XMB(1)=$$FMTE^XLFDT(NOW,1),XMB(2)=CNT
X ^%ZOSF("UCI") S XMB(3)=Y
D:CNT>0 ^XMB
K XMB,CNT,RN,RTN
Q
;
RANGE(RTN) ;Check a N-space
S RN=RTN D CHK(RTN) ;Check for rtn with namespace name
I OS["GT.M" G GRNG
F S RN=$O(^$ROUTINE(RN)) Q:$E(RN,1,$L(RTN))'=RTN D CHK(RN)
Q
;
GRNG ;Check a N-space in GT.M
N X,RA,RY,RX S RSUM="S Y=$$RSUM^%ZOSV2(X)"
I '$D(ZTQUEUED) W !,"Namespace: "_RTN
S X=$ZSEARCH("*.X"),RA=$$RTNDIR^%ZOSV_RTN,RY=RA_"*.m"
F S RX=$ZSEARCH(RY) Q:(RX="")!(RX'[RA) D
. S RX=$TR(RX,"]","/"),RN=$P($P(RX,"/",$L(RX,"/")),".",1)
. D CHK(RN)
Q
;
ALL ;Check all routines
I OS["GT.M" G GALL
S RN="" F S RN=$O(^$ROUTINE(RN)) Q:RN="" D CHK(RN)
G EXIT
;
GALL ;GT.M all routines
N X,RY,RX S RSUM="S Y=$$RSUM^%ZOSV2(X)"
S X=$ZSEARCH("*.X"),RY=$$RTNDIR^%ZOSV_"A.m"
F S RX=$ZSEARCH(RY) Q:(RX="")!(RX'["*") D
. S RX=$TR(RX,"]","/"),RN=$P($P(RX,"/",$L(RX,"/")),".",1) D CHK(RN)
G EXIT
;
CHK(RN) ;Check one routine
N $ET,$ES S $ET="D CHKERR^XTRMON Q"
S X=RN X TEST Q:'$T
S DA=$O(^DIC(9.8,"B",RN,0)) I DA<1 D Q:DA'>0 ;See if RN is in file
. S X=RN,DIC="^DIC(9.8,",DIC(0)="ML" D FILE^DICN ;No, so add
. S DA=+Y I DA>0 S DIE=DIC,DR="1///R" D ^DIE ;Set routine flag
. Q
S X0=^DIC(9.8,DA,0),X=RN X RSUM I '$D(ZTQUEUED) W "." ;Test
Q:(Y<0)!(Y=+$P(X0,U,5))
D LOG($E(RN_" ",1,10)_$S($P(X0,U,5)>0:"Has changed, Old: "_$P(X0,U,5)_" New: "_Y,1:"Is new"))
I '$D(ZTQUEUED) W !,RN,?10,$S($P(X0,U,5)>0:"Has changed",1:"Is new")
S $P(^DIC(9.8,DA,0),U,5,6)=Y_U_NOW
Q
;
CHKERR ;Handle an error during check
S $ET="D ^%ZTER G UNWIND^%ZTER"
D LOG(RN_" Caused an error: "_$$EC^%ZOSV)
S Y=-1,$EC="" ;Set Y=-1 to stop test
Q
;
LOG(MSG) ;Record message
S CNT=CNT+1,^TMP($J,CNT,0)=MSG
Q
;
LOST ;Look for routines no-longer in the system
I '$D(ZTQUEUED) W !,"Starting LOST routine check."
S RTN=""
F S RTN=$O(^DIC(9.8,"B",RTN)) Q:RTN="" D
. Q:$E(RTN)="%"
. S IX=$O(^DIC(9.8,"B",RTN,0)),X0=$G(^DIC(9.8,+IX,0)) Q:$P(X0,U,2)="PK"
. S X=RTN X TEST Q:$T
. D LOG($E(X_" ",1,10)_"Not in UCI")
. S DA=IX,DIK="^DIC(9.8," D ^DIK
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTRMON 2682 printed Oct 16, 2024@18:42:20 Page 2
XTRMON ;ISCSF/RWF - Watch for changes in routine checksums. ;02 Jul 2003 2:59 pm
+1 ;;7.3;TOOLKIT;**27,59,70**;Apr 25, 1995
A NEW CNT,NOW,MODE,RTN,RN,RSUM,TEST,XMB,DA,DIC,X0,OS
+1 KILL ^TMP($JOB)
+2 SET CNT=0
SET NOW=$$HTFM^XLFDT($HOROLOG)
SET U="^"
+3 SET RSUM=^%ZOSF("RSUM")
SET TEST=^%ZOSF("TEST")
+4 SET OS=^%ZOSF("OS")
+5 SET MODE=$GET(^XTV(8989.3,1,"RM"))
IF "n"[$EXTRACT(MODE)
QUIT
+6 if "a"=$EXTRACT(MODE)
GOTO ALL
SEL SET RTN=""
+1 FOR
SET RTN=$ORDER(^XTV(8989.3,1,"RM1","B",RTN))
if RTN=""
QUIT
Begin DoDot:1
+2 IF RTN["*"
DO RANGE($PIECE(RTN,"*"))
QUIT
+3 DO CHK(RTN)
+4 QUIT
End DoDot:1
EXIT ;
+1 DO LOST
+2 SET XMB="XTRMON"
SET XMTEXT="^TMP($J,"
SET XMB(1)=$$FMTE^XLFDT(NOW,1)
SET XMB(2)=CNT
+3 XECUTE ^%ZOSF("UCI")
SET XMB(3)=Y
+4 if CNT>0
DO ^XMB
+5 KILL XMB,CNT,RN,RTN
+6 QUIT
+7 ;
RANGE(RTN) ;Check a N-space
+1 ;Check for rtn with namespace name
SET RN=RTN
DO CHK(RTN)
+2 IF OS["GT.M"
GOTO GRNG
+3 FOR
