- LAKERM3 ;SLC/RWF/DLG - UNPACK KERMIT RECORDS VIA LSI ;7/20/90 09:26 ;
- ;;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 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAKERM3 1446 printed Mar 13, 2025@20:47:33 Page 2
- LAKERM3 ;SLC/RWF/DLG - UNPACK KERMIT RECORDS VIA LSI ;7/20/90 09:26 ;
- +1 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- +2 ;Call with TSK = instrument
- +3 ;Used to unpack kermit records from ^LA(tsk,"O",n) to ^LA(tsk,"C",n).
- +4 ;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 SET LAKERR=0
- SET OUT=""
- +1 SET CNT=^LA(TSK,"I",0)+1
- IF '$DATA(^(CNT))
- SET TOUT=TOUT+1
- if TOUT>9
- QUIT
- HANG 10
- GOTO GET
- +2 SET ^LA(TSK,"I",0)=CNT
- SET IN=^(CNT)
- SET TOUT=0
- +3 if $EXTRACT(IN,$LENGTH(IN)-1)="~"
- SET CTRL=$PIECE(IN,"~",2)
- SET IN=$PIECE(IN,"~",1)
- +4 SET LATYPE=$EXTRACT(IN,3)
- IF "SYFDEBZ"'[$EXTRACT(LATYPE_" ")
- SET LAKERR=1
- QUIT
- +5 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
