LRNITEG.m

LRNITEG ; IHS/DIR/FJE - INTEGRITY CHECKER FOR LAB SERVICE PACKAGE 8/3/89 17:52 ;

 ;;5.2;LR;;NOV 01, 1997

 ;

 ;;5.2;LAB SERVICE;**1**;Sep 27, 1994

EN ;set %ZOSF variables

 ; This routine stores routines (variable X) in ^TMP("LRNITEG" returns

 ; XBIT which is = $A(X) and SIZE which is the $L(X)

NEW ;

 N I,A,DIF,DIC,Y,II,XCNP,XCS,XCM,XCN,%,X

 K ^TMP("LRNITEG",$J) S XLOAD=^%ZOSF("LOAD"),XTEST=^("TEST"),DIF="^TMP(""LRNITEG"""_","_$J_","

 S XSIZE="S SIZE=0,I=1 F A=0:0 S I=$O(^TMP(""LRNITEG"",$J,I)) Q:I=""""  S SIZE=SIZE+$L(^(I,0))+2"

 Q

VER ; Select or add version #

 K DIC S U="^",DIC("A")=" Select Version # "

 S DIC(0)="AQEZ",DIC="^LAB(69.91,"

 I $D(LOAD) S DIC(0)=DIC(0)_"L",DLAYGO=69

 D ^DIC G:Y<0 STOP S VNODE=+Y,VER=$P(Y,U,2),VERDDT=$P(Y(0),U,2)

 Q

LOOP ; Loop thru intire file checking for mis-match between file directory

 K %DT S %DT="RX",X="NOW" D ^%DT W !,Y

 D EN,VER Q:Y<1  S II=0,LRST=""

ASK R !," Enter Routine to start checking from ",X:DTIME Q:'$T!(X[U)  W:X["?" !!,"Enter a program name to start with " G:X["?" ASK I $L(X),$E(X)="L" S II=X

 S:'$L(X) X="L" I $E(X)'="L" W $C(7),!!?7,"ENTER RETURN OR ROUTINE BEGINNING WITH 'L' " G ASK

 S II=X

ASK1 R !!," Enter EXACT routine to stop checking : ALL// ",X:DTIME Q:'$T!(X[U)  W:X["?" !!,"Enter the name of a program to stop this routine " G:X["?" ASK1 I $L(X),$E(X)="L" S LRST=X

 S:'$L(X) X="" I $L(X),$E(X)'="L" W $C(7),!!?7,"ROUTINE MUST START WITH 'L' " G ASK1

 K ZTSK,IO("Q"),%ZIS S LRST=X,%ZIS="0NQ" D ^%ZIS G:POP STOP I $D(IO("Q"))!(IO'=IO(0)) G QUE

 W !!?7,"Enter '^' to stop ",!!

DQ ;

 S PN=$S($G(^TMP("LRNITEGL")):^("LRNITEGL"),1:0)

 F A=0:0 R X:.1 Q:X="^"  S II=$O(^LAB(69.91,VNODE,"ROU","B",II)) Q:II=""!(II=LRST)  W "." S IX=$O(^(II,0)),X=$P(^LAB(69.91,VNODE,"ROU",IX,0),U),SIZE=$P(^(0),U,2),YBIT=$P(^(0),U,3),ER=0 I $E(X,1,5)'="LRINI" D SIZE I 'ER,XBIT'=YBIT D LOG

 Q

LOG W !,"EDIT/CHANGE IN ",X,!,$C(7) S PN=PN+1,^TMP("LRNITEGL")=PN,^("LRNITEGL",X,DT)=PN

 Q

SIZE ; Test for existence of X, load routine into ^TMP("LRNITEG" AND COUNT $L(X)

 ;Entry point for trigger of ^lab(69.911,.01  Caution if changed.

 N DIF,XCNP S DIF="^TMP(""LRNITEG"""_","_$J_"," X XTEST G:'$T ER S XCNP=0 K ^TMP("LRNITEG",$J) X XLOAD,XSIZE

BIT ;

 S XBIT=0 F I=2:1 Q:'$D(^TMP("LRNITEG",$J,I,0))  S L=^(0),LN=$L(L) F NT=1:1:LN S XBIT=$A(L,NT)+XBIT

CKSUM ; Compute Check Sum

 I '$D(^%ZOSF("RSUM")) S XSUM=1 Q

 X ^%ZOSF("RSUM") S XSUM=Y

 Q

ER ; Error msg for when attempt to use a routine that doen't exist

 S ER=1 W !,"There is not a routine called '",X,"' in this directory ",$C(7),! K X Q

ER2 ; Error msg when the version being loaded does not match the version selected for auto loading

 W !?10,ROU," is version ",$S($L($P(^TMP("LRNITEG",$J,2,0),";",3)):$P(^(0),";",3),1:"Unknown ")," NOT LOADED",$C(7),! Q

STOP ; clean-up

 K A,BIT,CNT,DIF,ER,I,II,IX,L,LN,LOAD,NT,ROU,SIZE,VER,VERDDT,VNODE,XBIT,XCM,XCN,XCMP,XCNP,XCS,XLOAD,XSIZE,XSUM,XTEST,YBIT,^TMP("LRNITEG",$J),DLAYGO Q

 Q

LOOK ; Entry point to look thru the whole selected version routine, checking for mis-matches  Prints the DA every tenth time

 G LOOP

SING ; Entry point for a single routine data look-up

 K DIC D EN,VER G STOP:Y<0 K DIC S DIC(0)="EQAL",DIC="^LAB(69.91,"_VNODE_",""ROU"",",DLAYGO=69,DA(1)=VNODE

SING1 ; Loop point

 D ^DIC G STOP:Y<0 S X=$P(Y,U,2),YBIT=$P(^LAB(69.91,VNODE,"ROU",+Y,0),U,3),ER=0 D SIZE I ER G SING1

 W !,$S(XBIT'=YBIT:" The "_X_" routine has been EDITED ",1:" The "_X_" routine is unedited"),!,"$(A) SIZE = ",XBIT,"      $(L) SIZE = ",SIZE

 W !?10,"Check Sum = ",XSUM,! G SING1

 Q

QUE ;

 S ZTDESC="PRINT CHANGES IN THE LAB INTEGRITY FILE ",ZTRTN="^DQ^LRNITEG",ZTIO=ION F I="VER","VERDDT","II","VNODE","LRST","XLOAD","XSIZE" S ZTSAVE(I)=""

 D ^%ZTLOAD W !!?10,"Queued to device "_ION,!!,$C(7) G STOP

SCREEN ;Screen routine for version number

 N XCNP,DIF,% S VER=$P(^LAB(69.91,DA(1),0),U) S XCNP=0,DIF="^TMP(""LRNITEG"","_$J_"," X ^%ZOSF("LOAD") I $P(@(DIF_"2,0)"),";",3)'=VER K X

 Q

 ;

SUM(REF) ; Sum -> Position-relative Ascii total

 N LRASC,LRDATA,LRPOS,LRTOT,LRREF,X

 ;

 ;  Various quits...

 QUIT:$G(REF)']""!(REF="^") "Invalid reference passed" ;->

 QUIT:$TR(REF,"^","")']"" 0 ;->

 ;

 ;  Does node exist?

 K X S (LRREF,X)="I $D("_REF_")#2" D ^DIM

 I '$D(X) QUIT "Node does not exist..." ;->

 I $D(X) X LRREF QUIT:'$T "Node does not exist..." ;->

 ;

 ;  Now, build sum...

 S LRTOT=0,LRDATA=@REF

 I $L(LRDATA) F LRPOS=1:1:$L(LRDATA) D

 .  S LRASC=$A($E(LRDATA,+LRPOS))

 .  S LRTOT=LRTOT+(LRASC*LRPOS)

 ;

 QUIT LRTOT

 ;

LRNITEG   ; IHS/DIR/FJE - INTEGRITY CHECKER FOR LAB SERVICE PACKAGE 8/3/89 17:52 ;

 +1       ;;5.2;LR;;NOV 01, 1997

 +2       ;

 +3       ;;5.2;LAB SERVICE;**1**;Sep 27, 1994

EN        ;set %ZOSF variables

 +1       ; This routine stores routines (variable X) in ^TMP("LRNITEG" returns

 +2       ; XBIT which is = $A(X) and SIZE which is the $L(X)

NEW       ;

 +1        NEW I,A,DIF,DIC,Y,II,XCNP,XCS,XCM,XCN,%,X

 +2        KILL ^TMP("LRNITEG",$JOB)

           SET XLOAD=^%ZOSF("LOAD")

           SET XTEST=^("TEST")

           SET DIF="^TMP(""LRNITEG"""_","_$JOB_","

 +3        SET XSIZE="S SIZE=0,I=1 F A=0:0 S I=$O(^TMP(""LRNITEG"",$J,I)) Q:I=""""  S SIZE=SIZE+$L(^(I,0))+2"

 +4        QUIT 

VER       ; Select or add version #

 +1        KILL DIC

           SET U="^"

           SET DIC("A")=" Select Version # "

 +2        SET DIC(0)="AQEZ"

           SET DIC="^LAB(69.91,"

 +3        IF $DATA(LOAD)

               SET DIC(0)=DIC(0)_"L"

               SET DLAYGO=69

 +4        DO ^DIC

           IF Y<0

               GOTO STOP

           SET VNODE=+Y

           SET VER=$PIECE(Y,U,2)

           SET VERDDT=$PIECE(Y(0),U,2)

 +5        QUIT 

LOOP      ; Loop thru intire file checking for mis-match between file directory

 +1        KILL %DT

           SET %DT="RX"

           SET X="NOW"

           DO ^%DT

           WRITE !,Y

 +2        DO EN

           DO VER

           IF Y<1

               QUIT 

           SET II=0

           SET LRST=""

ASK        READ !," Enter Routine to start checking from ",X:DTIME

           IF '$TEST!(X[U)

               QUIT 

           IF X["?"

               WRITE !!,"Enter a program name to start with "

           IF X["?"

               GOTO ASK

           IF $LENGTH(X)

               IF $EXTRACT(X)="L"

                   SET II=X

 +1        IF '$LENGTH(X)

               SET X="L"

           IF $EXTRACT(X)'="L"

               WRITE $CHAR(7),!!?7,"ENTER RETURN OR ROUTINE BEGINNING WITH 'L' "

               GOTO ASK

 +2        SET II=X

ASK1       READ !!," Enter EXACT routine to stop checking : ALL// ",X:DTIME

           IF '$TEST!(X[U)

               QUIT 

           IF X["?"

               WRITE !!,"Enter the name of a program to stop this routine "

           IF X["?"

               GOTO ASK1

           IF $LENGTH(X)

               IF $EXTRACT(X)="L"

                   SET LRST=X

 +1        IF '$LENGTH(X)

               SET X=""

           IF $LENGTH(X)

               IF $EXTRACT(X)'="L"

                   WRITE $CHAR(7),!!?7,"ROUTINE MUST START WITH 'L' "

                   GOTO ASK1

 +2        KILL ZTSK,IO("Q"),%ZIS

           SET LRST=X

           SET %ZIS="0NQ"

           DO ^%ZIS

           IF POP

               GOTO STOP

           IF $DATA(IO("Q"))!(IO'=IO(0))

               GOTO QUE

 +3        WRITE !!?7,"Enter '^' to stop ",!!

DQ        ;

 +1        SET PN=$SELECT($GET(^TMP("LRNITEGL")):^("LRNITEGL"),1:0)

 +2        FOR A=0:0

               READ X:.1

               IF X="^"

                   QUIT 

               SET II=$ORDER(^LAB(69.91,VNODE,"ROU","B",II))

               IF II=""!(II=LRST)

                   QUIT 

               WRITE "."

               SET IX=$ORDER(^(II,0))

               SET X=$PIECE(^LAB(69.91,VNODE,"ROU",IX,0),U)

               SET SIZE=$PIECE(^(0),U,2)

               SET YBIT=$PIECE(^(0),U,3)

               SET ER=0

               IF $EXTRACT(X,1,5)'="LRINI"

                   DO SIZE

                   IF 'ER

                       IF XBIT'=YBIT

                           DO LOG

 +3        QUIT 

LOG        WRITE !,"EDIT/CHANGE IN ",X,!,$CHAR(7)

           SET PN=PN+1

           SET ^TMP("LRNITEGL")=PN

           SET ^("LRNITEGL",X,DT)=PN

 +1        QUIT 

SIZE      ; Test for existence of X, load routine into ^TMP("LRNITEG" AND COUNT $L(X)

 +1       ;Entry point for trigger of ^lab(69.911,.01  Caution if changed.

 +2        NEW DIF,XCNP

           SET DIF="^TMP(""LRNITEG"""_","_$JOB_","

           XECUTE XTEST

           IF '$TEST

               GOTO ER

           SET XCNP=0

           KILL ^TMP("LRNITEG",$JOB)

           XECUTE XLOAD

           XECUTE XSIZE

BIT       ;

 +1        SET XBIT=0

           FOR I=2:1

               IF '$DATA(^TMP("LRNITEG",$JOB,I,0))

                   QUIT 

               SET L=^(0)

               SET LN=$LENGTH(L)

               FOR NT=1:1:LN

                   SET XBIT=$ASCII(L,NT)+XBIT

CKSUM     ; Compute Check Sum

 +1        IF '$DATA(^%ZOSF("RSUM"))

               SET XSUM=1

               QUIT 

 +2        XECUTE ^%ZOSF("RSUM")

           SET XSUM=Y

 +3        QUIT 

ER        ; Error msg for when attempt to use a routine that doen't exist

 +1        SET ER=1

           WRITE !,"There is not a routine called '",X,"' in this directory ",$CHAR(7),!

           KILL X

           QUIT 

ER2       ; Error msg when the version being loaded does not match the version selected for auto loading

 +1        WRITE !?10,ROU," is version ",$SELECT($LENGTH($PIECE(^TMP("LRNITEG",$JOB,2,0),";",3)):$PIECE(^(0),";",3),1:"Unknown ")," NOT LOADED",$CHAR(7),!

           QUIT 

STOP      ; clean-up

 +1        KILL A,BIT,CNT,DIF,ER,I,II,IX,L,LN,LOAD,NT,ROU,SIZE,VER,VERDDT,VNODE,XBIT,XCM,XCN,XCMP,XCNP,XCS,XLOAD,XSIZE,XSUM,XTEST,YBIT,^TMP("LRNITEG",$JOB),DLAYGO

           QUIT 

 +2        QUIT 

LOOK      ; Entry point to look thru the whole selected version routine, checking for mis-matches  Prints the DA every tenth time

 +1        GOTO LOOP

SING      ; Entry point for a single routine data look-up

 +1        KILL DIC

           DO EN

           DO VER

           IF Y<0

               GOTO STOP

           KILL DIC

           SET DIC(0)="EQAL"

           SET DIC="^LAB(69.91,"_VNODE_",""ROU"","

           SET DLAYGO=69

           SET DA(1)=VNODE

SING1     ; Loop point

 +1        DO ^DIC

           IF Y<0

               GOTO STOP

           SET X=$PIECE(Y,U,2)

           SET YBIT=$PIECE(^LAB(69.91,VNODE,"ROU",+Y,0),U,3)

           SET ER=0

           DO SIZE

           IF ER

               GOTO SING1

 +2        WRITE !,$SELECT(XBIT'=YBIT:" The "_X_" routine has been EDITED ",1:" The "_X_" routine is unedited"),!,"$(A) SIZE = ",XBIT,"      $(L) SIZE = ",SIZE

 +3        WRITE !?10,"Check Sum = ",XSUM,!

           GOTO SING1

 +4        QUIT 

QUE       ;

 +1        SET ZTDESC="PRINT CHANGES IN THE LAB INTEGRITY FILE "

           SET ZTRTN="^DQ^LRNITEG"

           SET ZTIO=ION

           FOR I="VER","VERDDT","II","VNODE","LRST","XLOAD","XSIZE"

               SET ZTSAVE(I)=""

 +2        DO ^%ZTLOAD

           WRITE !!?10,"Queued to device "_ION,!!,$CHAR(7)

           GOTO STOP

SCREEN    ;Screen routine for version number

 +1        NEW XCNP,DIF,%

           SET VER=$PIECE(^LAB(69.91,DA(1),0),U)

           SET XCNP=0

           SET DIF="^TMP(""LRNITEG"","_$JOB_","

           XECUTE ^%ZOSF("LOAD")

           IF $PIECE(@(DIF_"2,0)"),";",3)'=VER

               KILL X

 +2        QUIT 

 +3       ;

SUM(REF)  ; Sum -> Position-relative Ascii total

 +1        NEW LRASC,LRDATA,LRPOS,LRTOT,LRREF,X

 +2       ;

 +3       ;  Various quits...

 +4       ;->

           IF $GET(REF)']""!(REF="^")

               QUIT "Invalid reference passed"

 +5       ;->

           IF $TRANSLATE(REF,"^","")']""

               QUIT 0

 +6       ;

 +7       ;  Does node exist?

 +8        KILL X

           SET (LRREF,X)="I $D("_REF_")#2"

           DO ^DIM

 +9       ;->

           IF '$DATA(X)

               QUIT "Node does not exist..."

 +10      ;->

           IF $DATA(X)

               XECUTE LRREF

               IF '$TEST

                   QUIT "Node does not exist..."

 +11      ;

 +12      ;  Now, build sum...

 +13       SET LRTOT=0

           SET LRDATA=@REF

 +14       IF $LENGTH(LRDATA)

               FOR LRPOS=1:1:$LENGTH(LRDATA)

                   Begin DoDot:1

 +15                   SET LRASC=$ASCII($EXTRACT(LRDATA,+LRPOS))

 +16                   SET LRTOT=LRTOT+(LRASC*LRPOS)

                   End DoDot:1

 +17      ;

 +18       QUIT LRTOT

 +19      ;