XTKERM2 ;SF/RWF - Kermit Receive a file. ;11/8/93 11:50 ;
;;7.3;TOOLKIT;**122**;Apr 25, 1995;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
R I '$D(ZTQUEUED) U IO(0) D
. I IO=IO(0) W !,"Now start a KERMIT send from your system.",!,"Starting [REMOTE] KERMIT receive.",!
. E W !,"Starting a [LOCAL] KERMIT receive.",!
. Q
U IO S XTKET=$H
F XTKERR=0:0 D GET,@("R"_XTKR("PT")):'XTKERR Q:XTKERR!(XTKR("PT")="B")
D:XTKERR RB
S %=$H,XTKET=$H-XTKET*86400+$P(%,",",2)-$P(XTKET,",",2)
I '$D(ZTQUEUED) U IO(0) D
. W !,"Done with ",$S(IO=IO(0):"[REMOTE]",1:"[LOCAL]")," receive, File transfer ",$S('XTKERR:"was successful. ("_XTKR("CCNT")_" bytes)",1:"failed. ("_XTKERR_")")
W:'XTKERR !,?10,"Bytes: ",XTKR("CCNT")," Sec: ",XTKET," cps: ",$J($S(XTKET>0:XTKR("CCNT")/XTKET,1:""),3,1)
Q
RS S XTKS("PN")=XTKR("PN") D RPAR^XTKERM4,BSPAR^XTKERM4 S XTKS("PT")="Y" D SPACK,BUMP Q
RF D SEQ Q:X S X=XTKRDAT D FILE,ACK,BUMP Q
RD D SEQ Q:X D STORE,ACK,BUMP Q
RZ D SEQ G:X ABORT S XTKRDAT="" D STORE:XTKR("SA")]"",ACK,BUMP,CLOSE Q
RB D SEQ Q:X D ACK Q
RY ;
RN ;
RE G ABORT
SEQ S X=(XTKR("PN")'=XTKS("PN")) Q:'X D NAK S X=1 Q
Q
GET S XTKR("TRY")=XTKR("TRY")+1 I XTKR("TRY")>XTKR("MAXTRY") G ABORT
D RPACK^XTKERM3
I XTKERR D DEBUG("E:"_XTKERR):$D(XTKDEBUG),NAK G GET
I "SFEDNZYB"'[XTKR("PT") S XTKERR="6 Unknown packet type" Q
Q
ABORT S:'XTKERR XTKERR="5 Aborting receive operation" Q
BUMP S XTKR("TRY")=0,XTKS("PN")=XTKS("PN")+1#64 Q
PREV S XTKS("PN")=$S(XTKS("PN"):XTKS("PN")-1,1:63) Q
NAK S XTKS("PT")="N",XTKSDAT="" D SPACK Q
ACK S XTKS("PT")="Y",XTKSDAT="" D SPACK S XTKR("TRY")=0 Q
SPACK G SPACK^XTKERM3
RPACK G RPACK^XTKERM3
DEBUG(MSG) ;
S XTKDEBUG=XTKDEBUG+1,^TMP("XTKERM",$J,XTKDEBUG)=MSG
Q
FILE ;See if need to change file name.
I XTKDIC["DIZ(8980,",XTKR("RFN")="y" S XTKFILE(0)=XTKFILE,XTKFILE=X
;Other wise toss file name we don't need it.
Q
STORE ;Store the data (XTKRDAT) in file.
I 'XTKMODE S X=XTKRDAT D PDATA Q
F I=0:0 S I=$F(XTKRDAT,XTKR("QA"),I) Q:I<1 S X=$E(XTKRDAT,1,I-2),Y=$E(XTKRDAT,I) D TEXT:XTKMODE=2,REPLACE:XTKMODE=1
S X="" S:$L(XTKRDAT)+$L(XTKR("SA"))'>245 XTKR("SA")=XTKR("SA")_XTKRDAT,XTKRDAT="" S:$L(XTKRDAT)+$L(XTKR("SA"))>245 X=XTKR("SA"),XTKR("SA")=XTKRDAT,XTKRDAT="" S:XTKR("PT")="Z" X=XTKR("SA")
D:X]"" PDATA Q
;Y=M end of line, L form feed, J line feed, other make into control
TEXT I "L"[Y D TX2 S X="|TOP|" D PDATA Q
I "M"'[Y S XTKRDAT=X_$S(Y=XTKR("QA"):Y,"J"[Y:"",1:$C($A(Y)-64))_$E(XTKRDAT,I+1,999),I=I-(Y'=XTKR("QA")) Q
TX2 I $L(XTKR("SA")) S X1=XTKR("SA"),X2=X,Z=245-$L(X1),X=X1_$E(X2,1,Z),XTKR("SA")=$E(X2,Z+1,999)
D PDATA S X="" G TX2:$L(XTKR("SA")) S XTKRDAT=$E(XTKRDAT,I+1,999),I=0 Q
PDATA ;Put data in global
S DWLC=DWLC+1,@(XTKDIC_"DWLC,0)")=X,XTKR("CCNT")=XTKR("CCNT")+$L(X) Q
Q
REPLACE S XTKRDAT=X_$S(Y=XTKR("QA"):Y,1:$C($A(Y)-64))_$E(XTKRDAT,I+1,999),I=$L(X)+(Y=XTKR("QA")) Q
Q
CLOSE ;Close and update the filename if file 8980
I XTKDIC["DIZ(8980,",XTKR("RFN")="y" S $P(^DIZ(8980,XTKDA,0),"^",1)=XTKFILE,^DIZ(8980,"B",$E(XTKFILE,1,30),XTKDA)="" K ^DIZ(8980,"B",XTKFILE(0),XTKDA)
S @("X=$S($D("_XTKDIC_"0)):^(0),1:"""")"),^(0)=$P(X_"^^",U,1,2)_U_DWLC_U_DWLC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTKERM2 3218 printed Dec 13, 2024@02:41:14 Page 2
XTKERM2 ;SF/RWF - Kermit Receive a file. ;11/8/93 11:50 ;
+1 ;;7.3;TOOLKIT;**122**;Apr 25, 1995;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
R IF '$DATA(ZTQUEUED)
USE IO(0)
Begin DoDot:1
+1 IF IO=IO(0)
WRITE !,"Now start a KERMIT send from your system.",!,"Starting [REMOTE] KERMIT receive.",!
+2 IF '$TEST
WRITE !,"Starting a [LOCAL] KERMIT receive.",!
+3 QUIT
End DoDot:1
+4 USE IO
SET XTKET=$HOROLOG
+5 FOR XTKERR=0:0
DO GET
if 'XTKERR
DO @("R"_XTKR("PT"))
if XTKERR!(XTKR("PT")="B")
QUIT
+6 if XTKERR
DO RB
+7 SET %=$HOROLOG
SET XTKET=$HOROLOG-XTKET*86400+$PIECE(%,",",2)-$PIECE(XTKET,",",2)
+8 IF '$DATA(ZTQUEUED)
USE IO(0)
Begin DoDot:1
+9 WRITE !,"Done with ",$SELECT(IO=IO(0):"[REMOTE]",1:"[LOCAL]")," receive, File transfer ",$SELECT('XTKERR:"was successful. ("_XTKR("CCNT")_" bytes)",1:"failed. ("_XTKERR_")")
End DoDot:1
+10 if 'XTKERR
WRITE !,?10,"Bytes: ",XTKR("CCNT")," Sec: ",XTKET," cps: ",$JUSTIFY($SELECT(XTKET>0:XTKR("CCNT")/XTKET,1:""),3,1)
+11 QUIT
RS SET XTKS("PN")=XTKR("PN")
DO RPAR^XTKERM4
DO BSPAR^XTKERM4
SET XTKS("PT")="Y"
DO SPACK
DO BUMP
QUIT
RF DO SEQ
if X
QUIT
SET X=XTKRDAT
DO FILE
DO ACK
DO BUMP
QUIT
RD DO SEQ
if X
QUIT
DO STORE
DO ACK
DO BUMP
QUIT
RZ DO SEQ
if X
GOTO ABORT
SET XTKRDAT=""
if XTKR("SA")]""
DO STORE
DO ACK
DO BUMP
DO CLOSE
QUIT
RB DO SEQ
if X
QUIT
DO ACK
QUIT
RY ;
RN ;
RE GOTO ABORT
SEQ SET X=(XTKR("PN")'=XTKS("PN"))
if 'X
QUIT
DO NAK
SET X=1
QUIT
+1 QUIT
GET SET XTKR("TRY")=XTKR("TRY")+1
IF XTKR("TRY")>XTKR("MAXTRY")
GOTO ABORT
+1 DO RPACK^XTKERM3
+2 IF XTKERR
if $DATA(XTKDEBUG)
DO DEBUG("E:"_XTKERR)
DO NAK
GOTO GET
+3 IF "SFEDNZYB"'[XTKR("PT")
SET XTKERR="6 Unknown packet type"
QUIT
+4 QUIT
ABORT if 'XTKERR
SET XTKERR="5 Aborting receive operation"
QUIT
BUMP SET XTKR("TRY")=0
SET XTKS("PN")=XTKS("PN")+1#64
QUIT
PREV SET XTKS("PN")=$SELECT(XTKS("PN"):XTKS("PN")-1,1:63)
QUIT
NAK SET XTKS("PT")="N"
SET XTKSDAT=""
DO SPACK
QUIT
ACK SET XTKS("PT")="Y"
SET XTKSDAT=""
DO SPACK
SET XTKR("TRY")=0
QUIT
SPACK GOTO SPACK^XTKERM3
RPACK GOTO RPACK^XTKERM3
DEBUG(MSG) ;
+1 SET XTKDEBUG=XTKDEBUG+1
SET ^TMP("XTKERM",$JOB,XTKDEBUG)=MSG
+2 QUIT
FILE ;See if need to change file name.
+1 IF XTKDIC["DIZ(8980,"
IF XTKR("RFN")="y"
SET XTKFILE(0)=XTKFILE
SET XTKFILE=X
+2 ;Other wise toss file name we don't need it.
+3 QUIT
STORE ;Store the data (XTKRDAT) in file.
+1 IF 'XTKMODE
SET X=XTKRDAT
DO PDATA
QUIT
+2 FOR I=0:0
SET I=$FIND(XTKRDAT,XTKR("QA"),I)
if I<1
QUIT
SET X=$EXTRACT(XTKRDAT,1,I-2)
SET Y=$EXTRACT(XTKRDAT,I)
if XTKMODE=2
DO TEXT
if XTKMODE=1
DO REPLACE
+3 SET X=""
if $LENGTH(XTKRDAT)+$LENGTH(XTKR("SA"))'>245
SET XTKR("SA")=XTKR("SA")_XTKRDAT
SET XTKRDAT=""
if $LENGTH(XTKRDAT)+$LENGTH(XTKR("SA"))>245
SET X=XTKR("SA")
SET XTKR("SA")=XTKRDAT
SET XTKRDAT=""
if XTKR("PT")="Z"
SET X=XTKR("SA")
+4 if X]""
DO PDATA
QUIT
+5 ;Y=M end of line, L form feed, J line feed, other make into control
TEXT IF "L"[Y
DO TX2
SET X="|TOP|"
DO PDATA
QUIT
+1 IF "M"'[Y
SET XTKRDAT=X_$SELECT(Y=XTKR("QA"):Y,"J"[Y:"",1:$CHAR($ASCII(Y)-64))_$EXTRACT(XTKRDAT,I+1,999)
SET I=I-(Y'=XTKR("QA"))
QUIT
TX2 IF $LENGTH(XTKR("SA"))
SET X1=XTKR("SA")
SET X2=X
SET Z=245-$LENGTH(X1)
SET X=X1_$EXTRACT(X2,1,Z)
SET XTKR("SA")=$EXTRACT(X2,Z+1,999)
+1 DO PDATA
SET X=""
if $LENGTH(XTKR("SA"))
GOTO TX2
SET XTKRDAT=$EXTRACT(XTKRDAT,I+1,999)
SET I=0
QUIT
PDATA ;Put data in global
+1 SET DWLC=DWLC+1
SET @(XTKDIC_"DWLC,0)")=X
SET XTKR("CCNT")=XTKR("CCNT")+$LENGTH(X)
QUIT
+2 QUIT
REPLACE SET XTKRDAT=X_$SELECT(Y=XTKR("QA"):Y,1:$CHAR($ASCII(Y)-64))_$EXTRACT(XTKRDAT,I+1,999)
SET I=$LENGTH(X)+(Y=XTKR("QA"))
QUIT
+1 QUIT
CLOSE ;Close and update the filename if file 8980
+1 IF XTKDIC["DIZ(8980,"
IF XTKR("RFN")="y"
SET $PIECE(^DIZ(8980,XTKDA,0),"^",1)=XTKFILE
SET ^DIZ(8980,"B",$EXTRACT(XTKFILE,1,30),XTKDA)=""
KILL ^DIZ(8980,"B",XTKFILE(0),XTKDA)
+2 SET @("X=$S($D("_XTKDIC_"0)):^(0),1:"""")")
SET ^(0)=$PIECE(X_"^^",U,1,2)_U_DWLC_U_DWLC
+3 QUIT
