- XTKERM1 ;SF/RWF - Kermit Send a file ;10/21/09 16:44
- ;;7.3;TOOLKIT;**122**;Apr 25, 1995;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
- S D BSPAR^XTKERM4,STO S XTKS("PT")="S",F1=0
- I '$D(ZTQUEUED) U IO(0) D
- . I IO=IO(0) W !,"Now start a KERMIT receive on your system.",!,"Starting [REMOTE] KERMIT send.",! H 5
- . E W !,"Starting a [LOCAL] KERMIT send.",!
- . Q
- U IO S XTKET=$H
- F XTKERR=0:0 D @("S"_XTKS("PT")) Q:XTKERR!(XTKS("PT")="")
- S %=$H,XTKET=%-XTKET*86400+$P(%,",",2)-$P(XTKET,",",2)
- I '$D(ZTQUEUED) U IO(0) D
- . W !,"Done with ",$S(IO=IO(0):"[REMOTE]",1:"[LOCAL]")," send, File transfer ",$S('XTKERR:"was successful.",1:"failed. ("_XTKERR_")")
- . W:'XTKERR !,?10,"Bytes: ",XTKS("CCNT")," Sec: ",XTKET W:XTKET>0 " cps: ",$J($S(XTKET>0:XTKS("CCNT")/XTKET,1:""),3,1)
- Q
- SS S XTKS("PN")=0 D SEND,RTO S XTKSDAT=XTKRDAT D SPAR^XTKERM4 S XTKS("PT")="F" Q
- SF S XTKSDAT=XTKFILE D SEND,RACK:(XTKR("PN")'=XTKS("PN")) S XTKS("PT")="D" Q
- SD D GDATA I 'F1 D SZ Q
- D SDATA Q
- SZ S XTKSDAT="",XTKS("PT")="Z" D SEND S XTKS("PT")="B" Q:XTKERR
- Q ;MARK FILE AS SENT.
- SB S XTKSDAT="",XTKS("PT")="B" D SEND S XTKS("PT")="" Q
- SEND D:XTKS("PT")'="S" BUMP D SPACK ;Fall into RACK
- RACK S XTKS("TRY")=XTKS("TRY")+1 I XTKS("TRY")>XTKS("MAXTRY") G ABORT
- D RPACK^XTKERM3 I "EY"'[XTKR("PT")!XTKERR D SPACK G RACK
- I XTKR("PN")'=XTKS("PN") D SPACK G RACK
- S:"E"=XTKR("PT") XTKERR="8 Error packet" Q
- Q
- SEQ S X=(XTKS("PN")'=XTKS("PN")) Q:'X D NAK S X=1 Q
- Q
- ABORT S:'XTKERR XTKERR="7 Aborting send operation" Q
- BUMP S XTKS("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 XTKS("TRY")=0 Q
- SPACK G SPACK^XTKERM3
- RPACK G RPACK^XTKERM3
- SDATA ;Send the data from the file.
- S XTKSDAT="",XTKS("SA")=X G IDATA:'XTKMODE
- I X'[XTKS("QA")&(X?1.ANP) S XTKSDAT=$E(X,1,XTKS("SIZ")),I=XTKS("SIZ")+1 G SD2
- F I=1:1:$L(XTKS("SA")) S %1=$E(XTKS("SA"),I),%2=(%1[XTKS("QA")!(%1?1C)) Q:$L(XTKSDAT)+1+%2>XTKS("SIZ") D
- . S XTKSDAT=XTKSDAT_$S('%2:%1,%1[XTKS("QA"):%1_%1,1:XTKS("QA")_$C($A(%1)+64)),%2=0
- . Q
- S:'%2&(I=$L(XTKS("SA"))) I=I+1
- SD2 S XTKS("SA")=$E(XTKS("SA"),I,999) D SEND Q:XTKERR S X=XTKS("SA") G SDATA:X]""
- Q
- IDATA F F3=0:0 S X=$E(XTKS("SA"),1,XTKS("SIZ")),XTKS("SA")=$E(XTKS("SA"),XTKS("SIZ")+1,999) D SEND Q:XTKS("SA")=""
- Q
- Q
- GDATA ;Get data from global
- S @("F1=$O("_XTKDIC_"F1))") Q:F1'>0 S X=@(XTKDIC_"F1,0)"),XTKS("CCNT")=XTKS("CCNT")+$L(X) S:XTKMODE=2 X=X_$C(13) S:XTKMODE=3 X=X_$C(13,10) Q
- Q
- STO ;Save timeout data for startup
- S XTKR("TOS")=XTKR("TO"),XTKR("TO")=5,XTKS("MAXTRY")=30
- Q
- RTO ;Restore saved timeout
- S XTKR("TO")=XTKR("TOS"),XTKS("MAXTRY")=10 K XTKR("TOS")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTKERM1 2778 printed Jan 18, 2025@03:42:20 Page 2
- XTKERM1 ;SF/RWF - Kermit Send a file ;10/21/09 16:44
- +1 ;;7.3;TOOLKIT;**122**;Apr 25, 1995;Build 4
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- S DO BSPAR^XTKERM4
- DO STO
- SET XTKS("PT")="S"
- SET F1=0
- +1 IF '$DATA(ZTQUEUED)
- USE IO(0)
- Begin DoDot:1
- +2 IF IO=IO(0)
- WRITE !,"Now start a KERMIT receive on your system.",!,"Starting [REMOTE] KERMIT send.",!
- HANG 5
- +3 IF '$TEST
- WRITE !,"Starting a [LOCAL] KERMIT send.",!
- +4 QUIT
- End DoDot:1
- +5 USE IO
- SET XTKET=$HOROLOG
- +6 FOR XTKERR=0:0
- DO @("S"_XTKS("PT"))
- if XTKERR!(XTKS("PT")="")
- QUIT
- +7 SET %=$HOROLOG
- SET XTKET=%-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]")," send, File transfer ",$SELECT('XTKERR:"was successful.",1:"failed. ("_XTKERR_")")
- +10 if 'XTKERR
- WRITE !,?10,"Bytes: ",XTKS("CCNT")," Sec: ",XTKET
- if XTKET>0
- WRITE " cps: ",$JUSTIFY($SELECT(XTKET>0:XTKS("CCNT")/XTKET,1:""),3,1)
- End DoDot:1
- +11 QUIT
- SS SET XTKS("PN")=0
- DO SEND
- DO RTO
- SET XTKSDAT=XTKRDAT
- DO SPAR^XTKERM4
- SET XTKS("PT")="F"
- QUIT
- SF SET XTKSDAT=XTKFILE
- DO SEND
- if (XTKR("PN")'=XTKS("PN"))
- DO RACK
- SET XTKS("PT")="D"
- QUIT
- SD DO GDATA
- IF 'F1
- DO SZ
- QUIT
- +1 DO SDATA
- QUIT
- SZ SET XTKSDAT=""
- SET XTKS("PT")="Z"
- DO SEND
- SET XTKS("PT")="B"
- if XTKERR
- QUIT
- +1 ;MARK FILE AS SENT.
- QUIT
- SB SET XTKSDAT=""
- SET XTKS("PT")="B"
- DO SEND
- SET XTKS("PT")=""
- QUIT
- SEND ;Fall into RACK
- if XTKS("PT")'="S"
- DO BUMP
- DO SPACK
- RACK SET XTKS("TRY")=XTKS("TRY")+1
- IF XTKS("TRY")>XTKS("MAXTRY")
- GOTO ABORT
- +1 DO RPACK^XTKERM3
- IF "EY"'[XTKR("PT")!XTKERR
- DO SPACK
- GOTO RACK
- +2 IF XTKR("PN")'=XTKS("PN")
- DO SPACK
- GOTO RACK
- +3 if "E"=XTKR("PT")
- SET XTKERR="8 Error packet"
- QUIT
- +4 QUIT
- SEQ SET X=(XTKS("PN")'=XTKS("PN"))
- if 'X
- QUIT
- DO NAK
- SET X=1
- QUIT
- +1 QUIT
- ABORT if 'XTKERR
- SET XTKERR="7 Aborting send operation"
- QUIT
- BUMP SET XTKS("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 XTKS("TRY")=0
- QUIT
- SPACK GOTO SPACK^XTKERM3
- RPACK GOTO RPACK^XTKERM3
- SDATA ;Send the data from the file.
- +1 SET XTKSDAT=""
- SET XTKS("SA")=X
- if 'XTKMODE
- GOTO IDATA
- +2 IF X'[XTKS("QA")&(X?1.ANP)
- SET XTKSDAT=$EXTRACT(X,1,XTKS("SIZ"))
- SET I=XTKS("SIZ")+1
- GOTO SD2
- +3 FOR I=1:1:$LENGTH(XTKS("SA"))
- SET %1=$EXTRACT(XTKS("SA"),I)
- SET %2=(%1[XTKS("QA")!(%1?1C))
- if $LENGTH(XTKSDAT)+1+%2>XTKS("SIZ")
- QUIT
- Begin DoDot:1
- +4 SET XTKSDAT=XTKSDAT_$SELECT('%2:%1,%1[XTKS("QA"):%1_%1,1:XTKS("QA")_$CHAR($ASCII(%1)+64))
- SET %2=0
- +5 QUIT
- End DoDot:1
- +6 if '%2&(I=$LENGTH(XTKS("SA")))
- SET I=I+1
- SD2 SET XTKS("SA")=$EXTRACT(XTKS("SA"),I,999)
- DO SEND
- if XTKERR
- QUIT
- SET X=XTKS("SA")
- if X]""
- GOTO SDATA
- +1 QUIT
- IDATA FOR F3=0:0
- SET X=$EXTRACT(XTKS("SA"),1,XTKS("SIZ"))
- SET XTKS("SA")=$EXTRACT(XTKS("SA"),XTKS("SIZ")+1,999)
- DO SEND
- if XTKS("SA")=""
- QUIT
- +1 QUIT
- +2 QUIT
- GDATA ;Get data from global
- +1 SET @("F1=$O("_XTKDIC_"F1))")
- if F1'>0
- QUIT
- SET X=@(XTKDIC_"F1,0)")
- SET XTKS("CCNT")=XTKS("CCNT")+$LENGTH(X)
- if XTKMODE=2
- SET X=X_$CHAR(13)
- if XTKMODE=3
- SET X=X_$CHAR(13,10)
- QUIT
- +2 QUIT
- STO ;Save timeout data for startup
- +1 SET XTKR("TOS")=XTKR("TO")
- SET XTKR("TO")=5
- SET XTKS("MAXTRY")=30
- +2 QUIT
- RTO ;Restore saved timeout
- +1 SET XTKR("TO")=XTKR("TOS")
- SET XTKS("MAXTRY")=10
- KILL XTKR("TOS")
- +2 QUIT