LAKERM3.m

LAKERM3 ; IHS/DIR/FJE - UNPACK KERMIT RECORDS VIA LSI 7/20/90 09:26 ;

 ;;5.2;LA;;NOV 01, 1997

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

 ;Call with TSK = instrument

 ;Used to unpack kermit records from ^LA(tsk,"O",n) to ^LA(tsk,"C",n).

 ;See LAEKT7B for example of use.

A S:'$D(LAKDEM) LAKDEM=$C(13) S:'$D(LAKMAX) LAKMAX=124 S:'$D(^LA(TSK,"C")) ^LA(TSK,"C")=0,^("C",0)=0 S R1=^LA(TSK,"C"),R2="",LAKQCTL="#"

 F LOOP=0:0 D GET Q:LOOP!TOUT  D:'LAKERR @LATYPE,STORE

 Q

GET ;S LAKERR=0,OUT=""

 S LAKERR=0,OUT="" I '$D(^LA(TSK,"I",0)) S TOUT=1 Q  ;IHS/ANMC/CLS 11/1/93 patch for bidir

 S CNT=^LA(TSK,"I",0)+1 IF '$D(^(CNT)) S TOUT=TOUT+1 Q:TOUT>9  H 10 G GET

 S ^LA(TSK,"I",0)=CNT,IN=^(CNT),TOUT=0

 S:$E(IN,$L(IN)-1)="~" CTRL=$P(IN,"~",2),IN=$P(IN,"~",1)

 S LATYPE=$E(IN,3) I "SYFDEBZ"'[$E(LATYPE_" ") S LAKERR=1 Q

 Q

S S OUT="" Q:$L(IN)'>8  S LAKQCTL=$E(IN,9),R1=^LA(TSK,"C") Q  ;Start of secion.

Y S LOOP=0,LAKERR=1 Q  ;Y records from download.

F S OUT="",R2="FILE:"_$E(IN,4,$L(IN)-1),R1=^LA(TSK,"C") D OUT Q  ;File header

D S OUT=$E(IN,4,$L(IN)-1) D:OUT[LAKQCTL QCTL Q

E S ^LA(TSK,"C")=R1,OUT="" Q  ;Error, discard data back to last good file

B ;End of transmision

Z S LOOP=1 D OUT:R2]"" Q

QCTL ;Unquote control's

 F I1=0:0 S I1=$F(OUT,LAKQCTL,I1) Q:I1<1  S X=$E(OUT,I1),C=$C($A(X)-32),OUT=$E(OUT,1,I1-2)_$S(X=LAKQCTL:X,1:C)_$E(OUT,I1+1,299)

 Q

STORE D OUT:$L(R2)+$L(OUT)>LAKMAX S R2=R2_OUT I R2[LAKDEM S OUT=$P(R2,LAKDEM,2,99),R2=$P(R2,LAKDEM,1)_LAKDEM D OUT S R2=OUT

 Q

OUT S CNT=^LA(TSK,"C")+1,^("C")=CNT,^("C",CNT)=R2,R2=""

 Q

LAKERM3   ; IHS/DIR/FJE - UNPACK KERMIT RECORDS VIA LSI 7/20/90 09:26 ;

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

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

 +3       ;Call with TSK = instrument

 +4       ;Used to unpack kermit records from ^LA(tsk,"O",n) to ^LA(tsk,"C",n).

 +5       ;See LAEKT7B for example of use.

A          IF '$DATA(LAKDEM)

               SET LAKDEM=$CHAR(13)

           IF '$DATA(LAKMAX)

               SET LAKMAX=124

           IF '$DATA(^LA(TSK,"C"))

               SET ^LA(TSK,"C")=0

               SET ^("C",0)=0

           SET R1=^LA(TSK,"C")

           SET R2=""

           SET LAKQCTL="#"

 +1        FOR LOOP=0:0

               DO GET

               IF LOOP!TOUT

                   QUIT 

               IF 'LAKERR

                   DO @LATYPE

                   DO STORE

 +2        QUIT 

GET       ;S LAKERR=0,OUT=""

 +1       ;IHS/ANMC/CLS 11/1/93 patch for bidir

           SET LAKERR=0

           SET OUT=""

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

               SET TOUT=1

               QUIT 

 +2        SET CNT=^LA(TSK,"I",0)+1

           IF '$DATA(^(CNT))

               SET TOUT=TOUT+1

               IF TOUT>9

                   QUIT 

               HANG 10

               GOTO GET

 +3        SET ^LA(TSK,"I",0)=CNT

           SET IN=^(CNT)

           SET TOUT=0

 +4        IF $EXTRACT(IN,$LENGTH(IN)-1)="~"

               SET CTRL=$PIECE(IN,"~",2)

               SET IN=$PIECE(IN,"~",1)

 +5        SET LATYPE=$EXTRACT(IN,3)

           IF "SYFDEBZ"'[$EXTRACT(LATYPE_" ")

               SET LAKERR=1

               QUIT 

 +6        QUIT 

S         ;Start of secion.

           SET OUT=""

           IF $LENGTH(IN)'>8

               QUIT 

           SET LAKQCTL=$EXTRACT(IN,9)

           SET R1=^LA(TSK,"C")

           QUIT 

Y         ;Y records from download.

           SET LOOP=0

           SET LAKERR=1

           QUIT 

F         ;File header

           SET OUT=""

           SET R2="FILE:"_$EXTRACT(IN,4,$LENGTH(IN)-1)

           SET R1=^LA(TSK,"C")

           DO OUT

           QUIT 

D          SET OUT=$EXTRACT(IN,4,$LENGTH(IN)-1)

           IF OUT[LAKQCTL

               DO QCTL

           QUIT 

E         ;Error, discard data back to last good file

           SET ^LA(TSK,"C")=R1

           SET OUT=""

           QUIT 

B         ;End of transmision

Z          SET LOOP=1

           IF R2]""

               DO OUT

           QUIT 

QCTL      ;Unquote control's

 +1        FOR I1=0:0

               SET I1=$FIND(OUT,LAKQCTL,I1)

               IF I1<1

                   QUIT 

               SET X=$EXTRACT(OUT,I1)

               SET C=$CHAR($ASCII(X)-32)

               SET OUT=$EXTRACT(OUT,1,I1-2)_$SELECT(X=LAKQCTL:X,1:C)_$EXTRACT(OUT,I1+1,299)

 +2        QUIT 

STORE      IF $LENGTH(R2)+$LENGTH(OUT)>LAKMAX

               DO OUT

           SET R2=R2_OUT

           IF R2[LAKDEM

               SET OUT=$PIECE(R2,LAKDEM,2,99)

               SET R2=$PIECE(R2,LAKDEM,1)_LAKDEM

               DO OUT

               SET R2=OUT

 +1        QUIT 

OUT        SET CNT=^LA(TSK,"C")+1

           SET ^("C")=CNT

           SET ^("C",CNT)=R2

           SET R2=""

 +1        QUIT