XTRMON.m

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 ---XTRMON   2682     printed  Apr 09, 2024@21:44:07                                                                                                                                                                                                      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