LR1103.m

LR1103 ;SLC/RWF- TO CHECK THE STATUS OF THE LSI-11 Interface ; 8/5/87  21:0 ;

 ;;V~5.0~;LAB;;02/27/90 17:09

ASK ;from LRJOB

 I '$D(^LA("Q")) W !,"There are no LAB routines running to check" Q

 S X=$O(^LAB(62.4,0)) I (X<1)!(X>91) W !,"There are no Interface's in the Auto-instrument file." Q

 F LR=1:10:91 IF $D(^LAB(62.4,LR,0)) W !,"Checking Interface # ",LR D AS1

 K I,LR,Q,X,LROLD,LRCNT,LRPCNT,T,LROUT,LRANS Q

AS1 I '$D(^LA(LR,"I")) W "  Routine for this Interface not started." Q

 S T=LR,X=0,LROUT=1,LROLD=^LA(LR,"I") D OUT K LRPCNT

AS2 W !,"Interface check ... This may take a minute. "

 F I=1:1:15 Q:^LA(LR,"I")>LROLD  H 2

 S LRCNT=^LA(LR,"I"),LRANS=^LA(LR,"I",LRCNT)

 W !,"Interface data line is ",$S(LROLD=LRCNT:"NOT WORKING",1:"OK "_LRANS),!

 IF LROLD=LRCNT,'$D(LRPCNT) W !,"LET ME TRY ONCE MORE" S LRPCNT=1 G AS2

 Q

OUT S LRCNT=^LA(T,"O")+1,^("O")=LRCNT,^("O",LRCNT)=LROUT

 LOCK ^LA("Q") S Q=^LA("Q")+1,^("Q")=Q,^("Q",Q)=T LOCK

 Q

ACK ;Build and send the ACK triger/responce string

 F LR=1:10:91 I $D(^LAB(62.4,LR,0)) W:'$D(ACK) !,"Sending string for Interface # ",LR D AC2

 K I,LR,LROUT,Q,LRCNT,X Q

AC2 S LROUT="" F I=LR:1:LR+9 S X=$S($D(^LAB(62.4,I,0)):^(0),1:""),LROUT=LROUT_$E(100+$P(X,"^",13),2,3)_$E(100+$P(X,"^",14),2,3)

 S T=LR D OUT W:'$D(ACK) !?10,"$L(",LROUT,")=",$L(LROUT) Q

LR1103    ;SLC/RWF- TO CHECK THE STATUS OF THE LSI-11 Interface ; 8/5/87  21:0 ;

 +1       ;;V~5.0~;LAB;;02/27/90 17:09

ASK       ;from LRJOB

 +1        IF '$DATA(^LA("Q"))

               WRITE !,"There are no LAB routines running to check"

               QUIT 

 +2        SET X=$ORDER(^LAB(62.4,0))

           IF (X<1)!(X>91)

               WRITE !,"There are no Interface's in the Auto-instrument file."

               QUIT 

 +3        FOR LR=1:10:91

               IF $DATA(^LAB(62.4,LR,0))

                   WRITE !,"Checking Interface # ",LR

                   DO AS1

 +4        KILL I,LR,Q,X,LROLD,LRCNT,LRPCNT,T,LROUT,LRANS

           QUIT 

AS1        IF '$DATA(^LA(LR,"I"))

               WRITE "  Routine for this Interface not started."

               QUIT 

 +1        SET T=LR

           SET X=0

           SET LROUT=1

           SET LROLD=^LA(LR,"I")

           DO OUT

           KILL LRPCNT

AS2        WRITE !,"Interface check ... This may take a minute. "

 +1        FOR I=1:1:15

               IF ^LA(LR,"I")>LROLD

                   QUIT 

               HANG 2

 +2        SET LRCNT=^LA(LR,"I")

           SET LRANS=^LA(LR,"I",LRCNT)

 +3        WRITE !,"Interface data line is ",$SELECT(LROLD=LRCNT:"NOT WORKING",1:"OK "_LRANS),!

 +4        IF LROLD=LRCNT

               IF '$DATA(LRPCNT)

                   WRITE !,"LET ME TRY ONCE MORE"

                   SET LRPCNT=1

                   GOTO AS2

 +5        QUIT 

OUT        SET LRCNT=^LA(T,"O")+1

           SET ^("O")=LRCNT

           SET ^("O",LRCNT)=LROUT

 +1        LOCK ^LA("Q")

           SET Q=^LA("Q")+1

           SET ^("Q")=Q

           SET ^("Q",Q)=T

           LOCK 

 +2        QUIT 

ACK       ;Build and send the ACK triger/responce string

 +1        FOR LR=1:10:91

               IF $DATA(^LAB(62.4,LR,0))

                   IF '$DATA(ACK)

                       WRITE !,"Sending string for Interface # ",LR

                   DO AC2

 +2        KILL I,LR,LROUT,Q,LRCNT,X

           QUIT 

AC2        SET LROUT=""

           FOR I=LR:1:LR+9

               SET X=$SELECT($DATA(^LAB(62.4,I,0)):^(0),1:"")

               SET LROUT=LROUT_$EXTRACT(100+$PIECE(X,"^",13),2,3)_$EXTRACT(100+$PIECE(X,"^",14),2,3)

 +1        SET T=LR

           DO OUT

           IF '$DATA(ACK)

               WRITE !?10,"$L(",LROUT,")=",$LENGTH(LROUT)

           QUIT