LAKERMIT ; IHS/DIR/FJE - KERMIT PROTOCALL CONTROLLER THRU LSI 7/20/90 09:24 ;
;;5.2;LA;;NOV 01, 1997
;;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)
Q:'$D(^LA(T,"O"))#2 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) ;IHS/ANMC/CLS 11/1/95 patch for bidir
L ^LA("Q") S Q=^LA("Q")+1,^("Q")=Q,^("Q",Q)=T L Q
LAKERMIT ; IHS/DIR/FJE - KERMIT PROTOCALL CONTROLLER THRU LSI 7/20/90 09:24 ;
+1 ;;5.2;LA;;NOV 01, 1997
+2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
+3 ;;
+4 ;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 ;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)
+2 ;IHS/ANMC/CLS 11/1/95 patch for bidir
IF '$DATA(^LA(T,"O"))#2
QUIT
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)
+3 LOCK ^LA("Q")
SET Q=^LA("Q")+1
SET ^("Q")=Q
SET ^("Q",Q)=T
LOCK
QUIT
