LAKERM2.m

LAKERM2 ; IHS/DIR/FJE - BUILD A KERMIT FILE TO SEND THRU LSI 7/20/90 09:25 ;

 ;;5.2;LA;;NOV 01, 1997

 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994

 ;Call with X=data, LAKTYPE=record type, TSK=instrument #

 ;Files the records in ^LA(TSK,"O",n)

 Q

L1 S:'$D(LAKRM) LAKRM=94,LAKSEQ=0 S:LAKTYPE="S" LAKSEQ=0

 I LAKTYPE'="S" D POUND:X["#",QCTRL:X?.E1C.E

 F IX2=0:0 D L2 Q:X']""

 Q

L2 S LAKSPK=$C(LAKSEQ+32)_LAKTYPE_$E(X,1,+LAKRM),X=$E(X,LAKRM+1,299)

 D SPACK^LAKERMIT S LAKSEQ=LAKSEQ+1#64

 L ^LA(TSK) S O=^LA(TSK,"O")+1,^("O")=O,^("O",O)=LAKSPK L

 Q

POUND F I=2:1 S I=$F(X,"#",I) Q:I<1  S X=$E(X,1,I-2)_"#"_$E(X,I-1,999)

 Q

QCTRL F I=2:1 Q:I>$L(X)  I $A(X,I)<32 S X=$E(X,1,I-1)_"#"_$C($A(X,I)+32)_$E(X,I+1,999)

 Q

START ;A call is made to here once to do setup.

 S LAKTYPE="S",X="~} @-#N1" D L1

 Q

END ;At the end of data a call is made to here.

 S LAKTYPE="Z",X="" D L1 S LAKTYPE="B",X="" D L1,SEND L  G QUIT

 Q

SEND L ^LA(TSK,"P") Q:$S($D(^LA(TSK,"P")):$P(^("P"),"^",2),1:"QUIT")'="QUIT"  Q:'$D(^LA(TSK,"O",0))  Q:^LA(TSK,"O")'>^LA(TSK,"O",0)

 S ^LA(TSK,"P")="KERMIT^OUT",^("P3")=0,T=TSK L ^LA("Q") S Q=^LA("Q")+1,^("Q")=Q,^("Q",Q)=T L

 Q

DATA ;A call is made to here for each record in the load list.

 S LAKTYPE="D" D L1 Q

 Q

NEXT ;Finish old file start new.

 I LAKTYPE'="S" S LAKTYPE="Z" D L1

 S LAKTYPE="F",X="S "_LRFILE D L1

 Q

QUIT K C,CHKSUM,LAKRM,LAKSEQ,LAKSPK,LAKTYPE,X,O

 Q

LAKERM2   ; IHS/DIR/FJE - BUILD A KERMIT FILE TO SEND THRU LSI 7/20/90 09:25 ;

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

 +2       ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994

 +3       ;Call with X=data, LAKTYPE=record type, TSK=instrument #

 +4       ;Files the records in ^LA(TSK,"O",n)

 +5        QUIT 

L1         IF '$DATA(LAKRM)

               SET LAKRM=94

               SET LAKSEQ=0

           IF LAKTYPE="S"

               SET LAKSEQ=0

 +1        IF LAKTYPE'="S"

               IF X["#"

                   DO POUND

               IF X?.E1C.E

                   DO QCTRL

 +2        FOR IX2=0:0

               DO L2

               IF X']""

                   QUIT 

 +3        QUIT 

L2         SET LAKSPK=$CHAR(LAKSEQ+32)_LAKTYPE_$EXTRACT(X,1,+LAKRM)

           SET X=$EXTRACT(X,LAKRM+1,299)

 +1        DO SPACK^LAKERMIT

           SET LAKSEQ=LAKSEQ+1#64

 +2        LOCK ^LA(TSK)

           SET O=^LA(TSK,"O")+1

           SET ^("O")=O

           SET ^("O",O)=LAKSPK

           LOCK 

 +3        QUIT 

POUND      FOR I=2:1

               SET I=$FIND(X,"#",I)

               IF I<1

                   QUIT 

               SET X=$EXTRACT(X,1,I-2)_"#"_$EXTRACT(X,I-1,999)

 +1        QUIT 

QCTRL      FOR I=2:1

               IF I>$LENGTH(X)

                   QUIT 

               IF $ASCII(X,I)<32

                   SET X=$EXTRACT(X,1,I-1)_"#"_$CHAR($ASCII(X,I)+32)_$EXTRACT(X,I+1,999)

 +1        QUIT 

START     ;A call is made to here once to do setup.

 +1        SET LAKTYPE="S"

           SET X="~} @-#N1"

           DO L1

 +2        QUIT 

END       ;At the end of data a call is made to here.

 +1        SET LAKTYPE="Z"

           SET X=""

           DO L1

           SET LAKTYPE="B"

           SET X=""

           DO L1

           DO SEND

           LOCK 

           GOTO QUIT

 +2        QUIT 

SEND       LOCK ^LA(TSK,"P")

           IF $SELECT($DATA(^LA(TSK,"P"))

               QUIT 

           IF '$DATA(^LA(TSK,"O",0))

               QUIT 

           IF ^LA(TSK,"O")'>^LA(TSK,"O",0)

               QUIT 

 +1        SET ^LA(TSK,"P")="KERMIT^OUT"

           SET ^("P3")=0

           SET T=TSK

           LOCK ^LA("Q")

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

           SET ^("Q")=Q

           SET ^("Q",Q)=T

           LOCK 

 +2        QUIT 

DATA      ;A call is made to here for each record in the load list.

 +1        SET LAKTYPE="D"

           DO L1

           QUIT 

 +2        QUIT 

NEXT      ;Finish old file start new.

 +1        IF LAKTYPE'="S"

               SET LAKTYPE="Z"

               DO L1

 +2        SET LAKTYPE="F"

           SET X="S "_LRFILE

           DO L1

 +3        QUIT 

QUIT       KILL C,CHKSUM,LAKRM,LAKSEQ,LAKSPK,LAKTYPE,X,O

 +1        QUIT