- LAKERMIT ;SLC/RWF/DLG - KERMIT PROTOCALL CONTROLLER THRU LSI ;7/20/90 09:24 ;
- ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- ;;
- ;Call with T set to Instrument data is to/from
- A I $D(^LA("KR",0)) L ^LA("KR") S (%,^(0))=^LA("KR",0)+1,^(%)=T_"^"_IN_"%^%"_$H L
- Q:IN="~A" L ^LA(T,"P") S:'$D(^LA(T,"P")) ^("P")="KERMIT^"_$S($E(IN,3)="N":"OUT",1:"IN") S MODE=$P(^("P"),"^",2)
- ;P1=Seq #, P2=Last type, P3=Reset point if don't get file
- S:'$D(^LA(T,"P1")) ^LA(T,"P1")=0,^("P2")="" S LAKSPK=""
- D RCHK,@MODE Q
- RCHK ;Check received packet and set parts, check for mode changes.
- S LAKERR=0,LARLEN=$A(IN)-32,LAKERR=$L(IN)-1-LARLEN,LAKRSEQ=$A(IN,2)-32,LAKTYPE=$E(IN,3) Q:LAKERR
- I LAKTYPE="E" S MODE="RESTART",^LA(T,"P2")=LAKTYPE Q
- S LAKERR=(LAKTYPE'="S")&(^LA(T,"P1")'=LAKRSEQ),C=0 Q:LAKERR F I=1:1:LARLEN S C=C+$A(IN,I)
- S CHKSUM=C\64#4+C#64,LAKERR=$A(IN,LARLEN+1)-32-CHKSUM
- I MODE="IN","Y"[LAKTYPE S MODE="OUT",^LA(T,"P2")="S"
- I MODE="OUT","FS"[LAKTYPE S MODE="IN"
- I MODE="QUIT","S"[LAKTYPE S MODE="IN" I '$D(^LA("LOCK",T)),$D(^LAB(62.4,T,1)) X ^(1)
- S $P(^LA(T,"P"),"^",2)=MODE L Q
- IN D NAK:LAKERR,RACK:'LAKERR,KICK:LAKTYPE="B" S OUT=LAKSPK,%=OUT D:$D(^LA("KR",0)) DEBUG Q ;Upload
- NAK I LAKRSEQ+1=^LA(T,"P1") S LAKSPK=$C(LAKRSEQ+32)_"Y" D SPACK Q ;Packet not right
- S LAKSPK=$C(LAKRSEQ+32)_"N" D SPACK Q
- SPACK S LAKSPK=$C($L(LAKSPK)+33)_LAKSPK,C=0 F I=1:1:$L(LAKSPK) S C=C+$A(LAKSPK,I) ;Send a responce packet
- S CHKSUM=C\64#4+C#64,LAKSPK=$C(1)_LAKSPK_$C(CHKSUM+32) Q
- Q
- RACK Q:LAKTYPE="A" Q:(^LA(T,"P2")="S"&(LAKTYPE="S")) S ^LA(T,"P1")=LAKRSEQ+1#64,^("P2")=LAKTYPE
- I LAKTYPE="B" S ^LA(T,"P")="KERMIT^QUIT" ;Good packet
- I LAKTYPE="S" S LAKSPK=" Y~} @-#N1" D SPACK Q ;Send initiate, Return config.
- S LAKSPK=$C(LAKRSEQ+32)_"Y" D SPACK Q
- QUIT K ^LA(T,"P"),^("P1"),^("P2"),^("P3") I '$D(^LA("LOCK",T)),$D(^LAB(62.4,T,1)) X ^(1)
- Q
- RESTART S:$D(^LA(T,"P3")) ^LA(T,"O",0)=^LA(T,"P3") D:$P(^LA(T,"P"),"^",2)="OUT" KICK Q
- OUT L ^LA(T,"O") D SCHK,RSEND:LAKERR,NEXT:'LAKERR L Q ;Download
- SCHK I LAKTYPE="N" S LAKERR=1 Q ;If a NAK, call resend.
- I ^LA(T,"P2")="Z",LAKTYPE="Y" S ^LA(T,"P2")="" K ^LA(T,"P3") Q ;end of file
- I ^LA(T,"P2")="B",LAKTYPE="Y" S ^LA(T,"P")="KERMIT^QUIT" Q ;end of session
- S O=^LA(T,"O",0)+1 I '$D(^(O)) S LAKSPK=$C(LAKRSEQ+33)_"E0000" D SPACK S OUT=LAKSPK Q
- Q
- RSEND S O=^LA(T,"O",0)-1 S:O'<0 ^(0)=O ;Resend last packet, Fall into Next
- NEXT S O=^LA(T,"O",0)+1 I '$D(^(O)) L ^LA(T) K:'$D(^LA("LOCK",T)) ^LA(T) L Q
- S ^LA(T,"O",0)=O,OUT=^(O),^LA(T,"P1")=$A(OUT,3)-32,^("P2")=$E(OUT,4)
- I $E(OUT,4)="S" S ^LA(T,"P3")=O-1 ;Set restart point.
- I $D(^LA("KR",0)) D DEBUG
- Q
- DEBUG L ^LA("KR") S (OUT1,^(0))=^LA("KR",0)+1,^(OUT1)=$E(T_"^Sent:"_OUT_"%^%"_$H,1,200)
- K OUT1 L Q
- KICK ;Start a download after an upload. (done async)
- Q:'$D(^LA(T,"O",0)) Q:^LA(T,"O")'>^LA(T,"O",0) S:$D(^LA(T,"P3")) ^LA(T,"O",0)=^LA(T,"P3") S ^LA(T,"P3")=^LA(T,"O",0)
- L ^LA("Q") S Q=^LA("Q")+1,^("Q")=Q,^("Q",Q)=T L Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAKERMIT 2976 printed Feb 18, 2025@23:09:18 Page 2
- LAKERMIT ;SLC/RWF/DLG - KERMIT PROTOCALL CONTROLLER THRU LSI ;7/20/90 09:24 ;
- +1 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- +2 ;;
- +3 ;Call with T set to Instrument data is to/from
- A IF $DATA(^LA("KR",0))
- LOCK ^LA("KR")
- SET (%,^(0))=^LA("KR",0)+1
- SET ^(%)=T_"^"_IN_"%^%"_$HOROLOG
- LOCK
- +1 if IN="~A"
- QUIT
- LOCK ^LA(T,"P")
- if '$DATA(^LA(T,"P"))
- SET ^("P")="KERMIT^"_$SELECT($EXTRACT(IN,3)="N":"OUT",1:"IN")
- SET MODE=$PIECE(^("P"),"^",2)
- +2 ;P1=Seq #, P2=Last type, P3=Reset point if don't get file
- +3 if '$DATA(^LA(T,"P1"))
- SET ^LA(T,"P1")=0
- SET ^("P2")=""
- SET LAKSPK=""
- +4 DO RCHK
- DO @MODE
- QUIT
- RCHK ;Check received packet and set parts, check for mode changes.
- +1 SET LAKERR=0
- SET LARLEN=$ASCII(IN)-32
- SET LAKERR=$LENGTH(IN)-1-LARLEN
- SET LAKRSEQ=$ASCII(IN,2)-32
- SET LAKTYPE=$EXTRACT(IN,3)
- if LAKERR
- QUIT
- +2 IF LAKTYPE="E"
- SET MODE="RESTART"
- SET ^LA(T,"P2")=LAKTYPE
- QUIT
- +3 SET LAKERR=(LAKTYPE'="S")&(^LA(T,"P1")'=LAKRSEQ)
- SET C=0
- if LAKERR
- QUIT
- FOR I=1:1:LARLEN
- SET C=C+$ASCII(IN,I)
- +4 SET CHKSUM=C\64#4+C#64
- SET LAKERR=$ASCII(IN,LARLEN+1)-32-CHKSUM
- +5 IF MODE="IN"
- IF "Y"[LAKTYPE
- SET MODE="OUT"
- SET ^LA(T,"P2")="S"
- +6 IF MODE="OUT"
- IF "FS"[LAKTYPE
- SET MODE="IN"
- +7 IF MODE="QUIT"
- IF "S"[LAKTYPE
- SET MODE="IN"
- IF '$DATA(^LA("LOCK",T))
- IF $DATA(^LAB(62.4,T,1))
- XECUTE ^(1)
- +8 SET $PIECE(^LA(T,"P"),"^",2)=MODE
- LOCK
- QUIT
- IN ;Upload
- if LAKERR
- DO NAK
- if 'LAKERR
- DO RACK
- if LAKTYPE="B"
- DO KICK
- SET OUT=LAKSPK
- SET %=OUT
- if $DATA(^LA("KR",0))
- DO DEBUG
- QUIT
- NAK ;Packet not right
- IF LAKRSEQ+1=^LA(T,"P1")
- SET LAKSPK=$CHAR(LAKRSEQ+32)_"Y"
- DO SPACK
- QUIT
- +1 SET LAKSPK=$CHAR(LAKRSEQ+32)_"N"
- DO SPACK
- QUIT
- SPACK ;Send a responce packet
- SET LAKSPK=$CHAR($LENGTH(LAKSPK)+33)_LAKSPK
- SET C=0
- FOR I=1:1:$LENGTH(LAKSPK)
- SET C=C+$ASCII(LAKSPK,I)
- +1 SET CHKSUM=C\64#4+C#64
- SET LAKSPK=$CHAR(1)_LAKSPK_$CHAR(CHKSUM+32)
- QUIT
- +2 QUIT
- RACK if LAKTYPE="A"
- QUIT
- if (^LA(T,"P2")="S"&(LAKTYPE="S"))
- QUIT
- SET ^LA(T,"P1")=LAKRSEQ+1#64
- SET ^("P2")=LAKTYPE
- +1 ;Good packet
- IF LAKTYPE="B"
- SET ^LA(T,"P")="KERMIT^QUIT"
- +2 ;Send initiate, Return config.
- IF LAKTYPE="S"
- SET LAKSPK=" Y~} @-#N1"
- DO SPACK
- QUIT
- +3 SET LAKSPK=$CHAR(LAKRSEQ+32)_"Y"
- DO SPACK
- QUIT
- QUIT KILL ^LA(T,"P"),^("P1"),^("P2"),^("P3")
- IF '$DATA(^LA("LOCK",T))
- IF $DATA(^LAB(62.4,T,1))
- XECUTE ^(1)
- +1 QUIT
- RESTART if $DATA(^LA(T,"P3"))
- SET ^LA(T,"O",0)=^LA(T,"P3")
- if $PIECE(^LA(T,"P"),"^",2)="OUT"
- DO KICK
- QUIT
- OUT ;Download
- LOCK ^LA(T,"O")
- DO SCHK
- if LAKERR
- DO RSEND
- if 'LAKERR
- DO NEXT
- LOCK
- QUIT
- SCHK ;If a NAK, call resend.
- IF LAKTYPE="N"
- SET LAKERR=1
- QUIT
- +1 ;end of file
- IF ^LA(T,"P2")="Z"
- IF LAKTYPE="Y"
- SET ^LA(T,"P2")=""
- KILL ^LA(T,"P3")
- QUIT
- +2 ;end of session
- IF ^LA(T,"P2")="B"
- IF LAKTYPE="Y"
- SET ^LA(T,"P")="KERMIT^QUIT"
- QUIT
- +3 SET O=^LA(T,"O",0)+1
- IF '$DATA(^(O))
- SET LAKSPK=$CHAR(LAKRSEQ+33)_"E0000"
- DO SPACK
- SET OUT=LAKSPK
- QUIT
- +4 QUIT
- RSEND ;Resend last packet, Fall into Next
- SET O=^LA(T,"O",0)-1
- if O'<0
- SET ^(0)=O
- NEXT SET O=^LA(T,"O",0)+1
- IF '$DATA(^(O))
- LOCK ^LA(T)
- if '$DATA(^LA("LOCK",T))
- KILL ^LA(T)
- LOCK
- QUIT
- +1 SET ^LA(T,"O",0)=O
- SET OUT=^(O)
- SET ^LA(T,"P1")=$ASCII(OUT,3)-32
- SET ^("P2")=$EXTRACT(OUT,4)
- +2 ;Set restart point.
- IF $EXTRACT(OUT,4)="S"
- SET ^LA(T,"P3")=O-1
- +3 IF $DATA(^LA("KR",0))
- DO DEBUG
- +4 QUIT
- DEBUG LOCK ^LA("KR")
- SET (OUT1,^(0))=^LA("KR",0)+1
- SET ^(OUT1)=$EXTRACT(T_"^Sent:"_OUT_"%^%"_$HOROLOG,1,200)
- +1 KILL OUT1
- LOCK
- QUIT
- KICK ;Start a download after an upload. (done async)
- +1 if '$DATA(^LA(T,"O",0))
- QUIT
- if ^LA(T,"O")'>^LA(T,"O",0)
- QUIT
- if $DATA(^LA(T,"P3"))
- SET ^LA(T,"O",0)=^LA(T,"P3")
- SET ^LA(T,"P3")=^LA(T,"O",0)
- +2 LOCK ^LA("Q")
- SET Q=^LA("Q")+1
- SET ^("Q")=Q
- SET ^("Q",Q)=T
- LOCK
- QUIT