;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - executive
SETUP ;
;B 1 K S $ZE="ERR^ZKR" D CURRENT^%IS U 0:(RM:"") ;** M/11 V5
;B 1 K S $ZT="ERR^ZKR" D CURRENT^%IS U 0:(RM:"") ;** M/11+ V1
;K S FF="#",BS=$C(8),RO=$C(8,32,8),RM=79,SL=24 ;** STD
B 1 K S $ZT="ERR^ZKR",FF="#",BS=$C(8),RO=$C(8,32,8),RM=79,SL=24 U 0:("MR":0) ;** CCSM
;B 1 K S $ZT="^%ER",FF="#",BS=$C(8),RO=$C(8,32,8),RM=79,SL=24 U 0:("MR":0) ;** CCSM
;** enable user interrupts, set up error trapper ;** STD
S B="\",S=";"
D INITPAR
W @FF,!!,"Welcome to Kermit-M version ",^ZKRX("VERSION"),"; enter HELP for instructions",!!
START ;
D ^ZKRT20 G XIT:E!'VI,@(CSS(1))
RESTART ;
;S $ZE="ERR^ZKR" ;** M/11 V5
S $ZT="ERR^ZKR" ; ** CCSM
;reset error handler ;** STD
K (FF,BS,RO,RM,SL,B,S,TTY,FDX,RPSIZ,SPSIZ,RTO,STO,MAXTRY,DELAY,PAUSE,SSOH,RSOH,SEOL,SPADN,SPAD,SQA,SQB,CESC,PAR,BAUD,KAF,FW,DEBUG,SPN,RPN,BCNT,EFB)
W @FF G START
BYE ;
I 'TTY W !,"? No remote Kermit to log out" G START
S SPT="G",SDAT="L",SPN=0 D SPACK,RACK E U 0 W !,"Error - BYE command not effected" G START
U 0 W " Remote Kermit has been logged out" G XIT
CONNECT ;
I $S('$D(CMD(2)):0,CMD(2)="":0,1:1) S A=$S($D(^ZKRX("LINE",CMD(2))):^(CMD(2)),1:CMD(2)) C:$S('TTY:0,TTY=+A:0,1:1) TTY S TTY=+A
D ^ZKRC G START
FINISH ;
I 'TTY W !,"? No remote Kermit server to shut down" G START
S SPT="G",SDAT="F",SPN=0 D SPACK,RACK E U 0 W !,"Error - FINISH command not effected" G START
U 0 W " Remote Kermit server has been shut down" G START
EXIT G XIT
GET ;
I 'TTY W !,"? No remote Kermit from which to GET files" G START
S SDAT=CMD(2),SPT="R",SPN=0 D SPACK G RECEIVE
HELP ;
S GREF="^ZKRX(""HELP""" F I=2:1:VI S GREF=GREF_","""_CSS(I)_""""
S GREF=GREF_",0)" I '$D(@GREF) W !,"? Kermit: no help on that topic" G HX
W ! S $Y=0 F I=1:1:^(0) W !,^(I) I $Y+2>SL W !,"Press any key for more..." R *A:600 W $C(13),$J("",25),$C(13) S $X=0,$Y=0
HX K GREF,I W ! G START
MUMPS G START^ZKRM
QUIT G XIT
RECEIVE ;
U 0 W !,"Starting RECEIVE command...",! U TTY
D TTYON I 'E D ^ZKRR,TTYOFF
I TTY U 0 W !,"** Done with RECEIVE command"
G START
RESET ;
G SETUP
SEND ;
S FSPEC=CMD(2) D GETFIL I E W !,"? ",FSPEC K FSPEC G START
U 0 W !,"Starting SEND command...",! U TTY
;** turn off echo ;** STD
D TTYON I 'E H DELAY D ^ZKRS,TTYOFF
I TTY U 0 W !,"** Done with SEND command"
G START
SERVER ;
U 0 W !!,"Entering SERVER mode",!,"Enter the BYE command to stop the server and EXIT",!,"Enter the FINISH command to stop the server and return to the command level",!
D TTYON G START:E,^ZKRSRV
SET ;
D ^ZKRSET G START
SHOW ;
D SHOW^ZKRUM G START
STATISTI ;
W !!,"Most recent transmission: " W $S('EFB:"** none yet",EFB<0:"** aborted",1:BCNT_" bytes, "_(EFB/10)_" cps thruput"),!
G START
XIT C:TTY TTY
;K
S $ZT="" U 0:("EC":0:"EP":0) W !,"** All done with Kermit-M" Q
ERR ;
B 0 ;** M/11 ;**M/11+ V1
;** disable user interrupts ;** STD
D TTYOFF
I 'KAF,$D(F1),$D(F2),F1]"",F2]"",$D(^ZKR(F1,F2)),$P(^(F2),"\",3)="" K ^(F2)
L
;I $ZE["<INRPT>" U 0 W !,"(Interrupt received - restarting)" S $ZE="ERR^ZKR" B 1 G START ;** M/11
;I $ZE["<INTERRUPT>" U 0 W !,"(Interrupt received - restarting)" ZQ B 1 G START ;** M/11+ V1
;** if user interrupt, renable them and return to start ;** STD
I $ZN=24 U 0 W !,"(Interrupt received - restarting)" B 1 G START ;** CCSM
W !,"** Fatal MUMPS error : ",$ZE B 1 ;** M/11 ;**M/11+ V1 ;** CCSM
;** report a real error, enable user interrupts ;** STD
;ZQ ;**M/11+ V1 (unstack all DOs, FORs, etc)
Q
GETFIL G GETFIL^ZKRUM
INITPAR G INITPAR^ZKRUM
TTYON ;
;S E=0 U TTY:(0:"S") I TTY D ^ZKRTC S E=POP K POP I E W *7," Can't set up that port correctly" ;** M/11 V5 ;**M/11+ V1
S E=0 U TTY:("EC":1:"MR":0) I TTY D ^ZKRTC S E=POP K POP I E W *7," Can't set up that port correctly" ;** CCSM
;** turn off echo, set line parameters ;** STD
Q
TTYOFF ;
;U TTY:("":"") U 0 ;** M/11 V5 ;**M/11+ V1
U TTY:("EC":0:"EP":0) U 0 ;** CCSM
;** turn echo on, direct I/O to local terminal ;** STD
Q
SPACK G SPACK^ZKRUP
RACK D RPACK^ZKRUP I $S(E:0,RPT'="Y":0,SPN'=RPN:0,1:1)
Q
ZKRC
ZKRC ;DGR NYSCVM ;15APR90 3:58PM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - talk-thru to another machine
I 'TTY W !,"? No line specified" Q
O TTY::0 E W !,"? Can't get that line now" Q ;** M/11
;** OWN the line, timeout if it's unavailable ;** STD
D ^ZKRTC I POP W !,"? Illegal line parameters specified" Q ;** M/11 V5 ;** M/11+ V1
;** Set speed, parity, 7 or 8-bit data ;** STD
U 0 W ! D AST W !,"You are now in 'talk thru' mode",!,"Everything you type will go to the CONNECTed line",!,"Enter CTRL/",$C(CESC+64)," followed by 'C' to get back to Kermit-M",!!
;I FDX U 0:("":"IS") U TTY:("":"IS":$C(10)) ;** M/11 V5 ;** M/11+ V1
;E U 0:("":"I") U TTY:("":"IS":$C(10)) ;** M/11 V5 ;** M/11+ V1
B 0
I FDX U 0:("BK":1:"EC":1) U TTY:("EC":1:"BK":1:"MR":0) ;** CCSM
E U 0:("BK":1:"EC":0) U TTY:("EC":1:"BK":1:"MR":0) ;** CCSM
;** keyboard reads: image mode (no special chars.) ;** STD
;** port reads : image mode, also terminate on LF ;** STD
;** note : in OUT and IN, I have changed the 1-sec timeouts to 0-sec. timeouts to speed up communications. This increases the system load which may be undesirable on large multiuser systems.
OUT ;F I=0:0 U 0 R *A:1 Q:'$T G:A=CESC CESC U TTY W *A
F I=0:0 U 0 R *A:0 Q:'$T G:A=CESC CESC U TTY W *A ;** CCSM
IN ;F I=0:0 U TTY R A:1 U 0 W:A]"" A G:'$T OUT W *10 R *A:0 I G:A=CESC CESC U TTY W *A G OUT ;** M/11
F I=0:0 U TTY R A:0 U 0 W:A]"" A G:'$T OUT R *A:0 I G:A=CESC CESC U TTY W *A G OUT ;** CCSM
CESC ;
U 0 R *A:RTO G @$S(A=67:"DONE",A=99:"DONE",A=83:"SHOW",A=115:"SHOW",A=63:"CHELP",A=CESC:"SESC",1:"EESC")
DONE U 0 W !!,"End of connection; you still own the line" D AST W !
;U 0:("":"") U TTY:("":"") ;** M/11 V5 ;** M/11+ V1
;U 0:(0:0) U TTY:(0:0) ;** M/11 V4
B 1 U 0:("EC":0) U TTY:("EC":0) ;** CCSM
;** turn on both echoes ;** STD
;U 0 W *-1 U TTY W *-1 ;** M/11 V5 ;** M/11+ V1
;** discard any type-ahead ;** STD
U 0 Q
SHOW D AST W !,"You're connected to TTY number ",TTY," ; ",$S(FDX:"full",1:"half")," duplex ; baud rate ",BAUD,!,! D AST W !
G OUT
CHELP U 0 D AST W !,"The following characters can follow the link 'escape':",!
W !?3,"C or c -- close the connection",!?3,"S or s -- show the status of the connection",!?3,"? -- show these options",!?3,"Another CTRL/",$C(CESC+64)," will be transmitted to the other machine",!?3,"Anything else will be ignored",!
D AST W ! G OUT
SESC U TTY W *A G OUT
EESC U 0 W !,"Illegal character following link 'escape' - ignored",! G OUT
AST W ! F I=1:1:RM\6 W "******"
Q
ZKRM
ZKRM ;DGR NYSCVM ;16APR90 8:34PM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit <--> MUMPS interface - main options
W !,"Must enter via the MUMPS command in Kermit-M" Q
START ;
;S $ZE="ERR^ZKRM" ;** M/11 V5
S $ZT="ERR^ZKRM" ;** M/11+ V1
K ^ZKRZ($J) W @FF
S OPTS=";Help;Directory;Erase;Rename;Copy;Input;Output;Xit"
MOPT ;
U 0 W !!,"Kermit-M file system -- MAIN options",!! F I=2:1:9 S X=$P(OPTS,S,I) W "(",$E(X),")",$E(X,2,99) I I<9 W "; "
W !!,"Option (? for help) : X => " D READ G MOPT:E,XIT:A="" S:$E(A)="?" A="H" S:$E(A)?1L A=$C($A(A)-32)_$E(A,2,99) F I=2:1:$L(A) I $E(A,I)?1U S A=$E(A,1,I-1)_$C($A(A,I)+32)_$E(A,I+1,99)
S F=$F(OPTS,S_A) I F<2 W *7," No such option" G MOPT
W @FF G @("MOPT"_$E(A))
MOPTH S HREF="""MOPT""" D HELP G MOPT
MOPTD D DIR G MOPT
MOPTE D ERA^ZKRMF G MOPT
MOPTR D REN^ZKRMF G MOPT
MOPTC D COP^ZKRMF G MOPT
MOPTO D ^ZKRMO G MOPT
MOPTI D ^ZKRMI G MOPT
MOPTX ;
XIT ;
I $D(IO),$D(ZDS) U IO S $ZDS=ZDS C:$I'=IO IO
U 0
K ^ZKRZ($J),ZDS,ZIO,FN
G RESTART^ZKR
DIR ;
W !,"DIRECTORY of files",! D GFSPEC I E Q
D GETFIL S FILE=$O(^ZKRZ($J,"FILE","")) I FILE="" W *7," ** no files match this specification" K FILE Q
W !!,"** Directory of files ",FSPEC," on " D ^%OUTDAT W " at " D TIM W !!,"name",?15,"quote",?25,"created",?50,"# of bytes",!
S FILE="" F I=0:1 S FILE=$O(^ZKRZ($J,"FILE",FILE)) Q:FILE="" W !,FILE S F1=$P(FILE,"."),F2=$P(FILE,".",2),X=^ZKR(F1,F2) W ?15,$P(X,B,2) S DATIM=$P(X,B,4) D DATIM W ?25,DATIM,?50,$J($P(X,B,5),10)
K FILE,DATIM,F1,F2,X Q
TIM ;
S X=$P($H,",",2) W $S(X>43199:X\3600-12,1:X\3600),":" S XX=X#3600\60_"" S:$L(XX)=1 XX="0"_XX W XX,$S(X>43199:" PM",1:" AM") K X,XX Q
Q
DATIM G DATIM^ZKRMU
GETFIL D GETFIL^ZKRMU Q
GFSPEC D GFSPEC^ZKRMU Q
GFILE D GFILE^ZKRMU Q
HELP S HREF="^ZKRX(""MHELP"","_HREF_")" I '$D(@HREF) W *7," Sorry, no help on that topic" Q
W @FF S SUB=0 F I=0:0 S SUB=$O(@HREF@(SUB)) Q:SUB'?1.N W !,^(SUB)
W !!,"Press <RETURN> when done reading..." D READ W @FF
Q
READ R A:120 S E=$S(A="":0,"<#@^>"[$E(A):1,1:0)
W:E " Can't do that here." Q
ERR ;
B 0 ;** M/11 ;** M/11+ V1
;** disable user interrupts ;** STD
K ^ZKRZ($J)
B 1 ;** M/11 ;** M/11+ V1
;** enable user interrupts ;** STD
;G START:$ZE["<INRPT>" ;** M/11 V5
;I $ZE["<INTERRUPT>" ZQ G START ;** M/11+ V1
I $ZN=24 G START ;** CCSM
U 0 W !,"** Fatal MUMPS error : ",$ZE Q ;** M/11 ;** M/11 V1
;** restart on user interrupt, otherwise report error and quit ;** STD
ZKRMF
ZKRMF ;DGR NYSCVM ; 13 Feb 85 17:12
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit <--> MUMPS interface -- process file-oriented options
ERA ;
W !,"ERASE files",! D GFSPEC Q:E D GETFIL I E W " ",FSPEC,! G ERA
W *7,!,"** Erase ",FSPEC,", are you sure (Y or N)? N ==> " D READ I A'="Y" W " [no change]" Q
W !!,"Deleting files that match ",FSPEC,"..." D KILL
W !!,"** done"
Q
REN ;
S KILL=1 G RC
COP ;
S KILL=0 G RC
RC ;
W !!,$S(KILL:"RENAME",1:"COPY")," files",!!,"Enter the set of files to be ",$S(KILL:"renam",1:"copi"),"ed::",! D GFSPEC Q:E I FSPEC="*.*" W *7,!!,"?? can't specify all files" G RC
D GETFIL I E W " ",FSPEC,! G RC
S OFN=$P(FSPEC,"."),OFT=$P(FSPEC,".",2),OFNW=$F(OFN,"*")-2,OFTW=$F(OFT,"*")-2
W !!,$S(KILL:"RENAME",1:"COPY")," ",FSPEC," to what files?",! D GFSPEC I E Q
S NFN=$P(FSPEC,"."),NFT=$P(FSPEC,".",2),NFNW=$F(NFN,"*")-2,NFTW=$F(NFT,"*")-2
I $S(NFNW>0&(OFNW>0):0,NFNW=OFNW:0,1:1) W *7,!!,"** ?? -- old & new filespecs do not have the same format" G RC
I $S(OFN'=NFN:0,OFT'=NFT:0,1:1) W *7,!!,"** ?? -- old & new filespecs must be different" G RC
W !!,"Moving files..." S FILE="" F I=0:1 S FILE=$O(^ZKRZ($J,"FILE",FILE)) Q:FILE="" D MOVE
I KILL W !!,"Deleting old files..." D KILL
W !!,"** Done"
Q
MOVE S OF1=$P(FILE,"."),OF2=$P(FILE,".",2,9),NF1=$S(NFNW<0:NFN,1:$E(NFN,1,NFNW)_$E(OF1,OFNW+1,99)),NF2=$S(NFTW<0:NFT,1:$E(NFT,1,NFTW)_$E(OF2,OFTW+1,99)) W !,OF1_"."_OF2_" --> "_NF1_"."_NF2_"..."
I $S($L(NF1)>8:1,$L(NF2)>3:1,1:0) W *7," ?? new file name is too long - no change" K ^ZKRZ($J,"FILE",FILE) Q
I $D(^ZKR(NF1,NF2)) W *7,!,NF1,".",NF2," is already on file. Overwrite? N => " D READ I A'="Y" W " [no change]" Q
S ^ZKR(NF1,NF2)=^ZKR(OF1,OF2) S SUB="" F I=0:0 S SUB=$O(^ZKR(OF1,OF2,SUB)) Q:SUB="" S X=^(SUB),^ZKR(NF1,NF2,SUB)=X
W " ** Done"
Q
KILL S FILE="" F I=0:1 S FILE=$O(^ZKRZ($J,"FILE",FILE)) Q:FILE="" K ^ZKR($P(FILE,"."),$P(FILE,".",2,9)) W:I#5=0 ! W ?(I#5*16),FILE
Q
GETFIL D GETFIL^ZKRMU Q
GFSPEC D GFSPEC^ZKRMU Q
READ R A:120 S E=$S(A="":0,"<#@"[$E(A):1,1:0)
W:E " Can't do that here." Q
ZKRMFIO
ZKRMFIO ;DGR NYSCVM ;17APR90 11:08PM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit <--> MUMPS interface - file i/o utilities
KIN ;
G KIC:LIN'?.ANP,KIQ:LIN[FQA S C=LIN D KINL S CL=CL_FQA_"M"_FQA_"J",CC=CC+4 Q
KIQ S F=$F(LIN,FQA) I F<2 S C=LIN D KINL S CL=CL_FQA_"M"_FQA_"J",CC=CC+4 Q
S C=$E(LIN,1,F-2),LIN=$E(LIN,F,255) D KINL S CL=CL_FQA_FQA,CC=CC+2 G KIQ
KINL S X=251-CC I $L(C)<X S CL=CL_C,CC=CC+$L(C) Q
S ^ZKR(F1,F2,F3)=CL_$E(C,0,X),C=$E(C,X+1,255),F3=F3+1,CL="",BCNT=BCNT+CC,CC=1 G KINL
KIC F I=1:1:$L(LIN) S C=$E(LIN,I),C=$S(C=FQA:C_C,C?1C:FQA_$C($A(C)+64),1:C) D KINC1
S C=FQA_"M" D KINC1 S C=FQA_"J" D KINC1
Q
KINC1 I CC>250 S ^ZKR(F1,F2,F3)=CL,CL="",BCNT=BCNT+CC,CC=1,F3=F3+1
S CL=CL_C,CC=CC+$L(C)
Q
KOUT ;
S LIN=""
KOS Q:F3="" I CL="" D KOG I F3="" Q
S F=$F(CL,FQA) I 'F S LIN=LIN_CL,CL="" G KOS
S LIN=LIN_$E(CL,1,F-2),X=$E(CL,F),CL=$E(CL,F+1,255) D:CL="" KOG
I X="M",$E(CL,1,2)=(FQA_"J") S CL=$E(CL,3,255) Q
S LIN=LIN_$S(X=FQA:FQA,X?1U:$C($A(X)-64),X="?":$C(127),1:"") G KOS
KOG S F3=$O(^ZKR(F1,F2,F3)) Q:F3="" S CL=^(F3) Q
FOPENW ;
S E=0 I '$D(FILE) S E=1 Q
S F1=$P(FILE,"."),F2=$P(FILE,".",2,9) I $S(F1="":1,F2="":1,$D(^ZKR(F1,F2)):1,1:0) S E=1 K F1,F2 Q
S FQA=$S($D(FQA):FQA,1:"#"),CL="",(F3,CC)=1,BCNT=0
S FQB=$S($D(FQB):FQB,1:"&")
;B 0 S OZE=$ZE,$ZE="FERRW^ZKRMFIO" ;** M/11
B 0 S $ZT="FERRW^ZKRMFIO" ;** M/11+ V1, CCSM
;** disable interrupts, set up error trapper ;** STD
D WLOCK
S ^ZKR(F1,F2)="0\"_FQA_","_FQB_B_$H
B 1 ;** M/11 ;** M/11+ V1, CCSM
;** enable interrupts ;** STD
Q
FCLOSEW ;
S E=0 I $S('$D(F1):1,'$D(F2):1,F1="":1,F2="":1,'$D(CL):1,'$D(F3):1,'$D(^ZKR(F1,F2))#10:1,1:0) S E=1 Q
B 0 ;** M/11 ;** M/11+ V1, CCSM
;** disable user iterrupts ;** STD
I CL]"" S ^ZKR(F1,F2,F3)=CL,CL="",BCNT=BCNT+CC,CC=1,F3=F3+1
W !!,"Input options (Kermit-M file system --> MUMPS data structures)",! F I=1:1:6 W !?5,I,") ",$P("Sequential file in;Routine in (.MMP files);Routine in (.ROU file);Global in;Sequential global in;Binary file in",S,I)
IO1 W !!,"Your choice (? for help) : X => " D READ G IO1:E Q:"Xx^>"[A I "?Hh"[$E(A) S HREF="""IOPT""" D HELP^ZKRM G IOPT
I A?1N1"?",$E(A)>0,$E(A<7) S HREF="""IOPT"","""_$P("SFI;RIM;RIR;GI;SGI;BFI",S,+A)_"""" D HELP^ZKRM G IOPT
I $S(A'?1N:1,A<1:1,A>6:1,1:0) W *7," ? no such option" G IO1
W @FF D @$P("SFI;RIM;RIR;GI;SGI;BFI",S,A) G IOPT
SFI ;
W !!,"Input Kermit-M files to a sequential device",! D GFSPEC Q:E D GETFIL I E W " ",FSPEC,! G SFI
SFI1 W !,"Write to device 0,2,5 or 6: " R IO I IO="" Q
I IO=5!(IO=6) R !,"File name: ",FN Q:FN=""
I IO=5!(IO=6) S IOSL=0 O IO:("FN":FN:"FA":2):5 E Q
I IO=2 O IO:("MR":80):30 E U 0 W *7," Printer busy - try later!" Q
;I "\TRM\SDP\MT\"'[(B_IOT_B) W *7," I can't deal with that type of device" G SFI1
;set IO as $I on which to list, IOT as device type, then OPEN it with correct parameters ;** STD
;if IOT="TRM" also set up IOST (subtype), IOF (form feed), IOSL (page length) ;** STD
I IO S IOT="SDP",TRM=0
E S TRM=1,IOT="TRM"
S TRM=IOT="TRM",PTR=IO=2
I IOT="TRM" S IOF="#",IOSL=24
I PTR S IOF="#",IOSL=66
U IO S FILE="" F J=0:1 S FILE=$O(^ZKRZ($J,"FILE",FILE)) Q:FILE="" D FOPENR D:'E SFIL D FCLOSER
I PTR W @IOF
I 'TRM U IO W $C(26),! I IOT="MT" W *3
U 0 I IO W !,"** Done for this set of files" C IO ;** CCSM
;** if not listing on local screen, message & close device ;** STD
K TRM,PTR,IO,IOT,IOST,IOF,IOSL,IOPAR
Q
SFIL I TRM S X=^ZKR(F1,F2),DATIM=$P(X,B,4) D DATIM W:PTR @IOF W !!,"Kermit file : ",FILE," received at ",DATIM," ; ",$P(X,B,5)," bytes",!!
U 0 I $I'=IO W !,"starting ",FILE,"..." U IO ;** M/11 ;** M/11+ V1
;** if not listing on local screen, show progress ;** STD
F I=0:0 D KOUT W:PTR&($Y+3>IOSL) @IOF S:LIN[$C(26) LIN=$E(LIN,0,$F(LIN,$C(26)-2)),F3="" W LIN,! I F3="" Q
U 0 I $I'=IO W "done" U IO ;** M/11 ;** M/11+ V1
;** if not listing on local screen, show progress ;** STD
Q
BFI S $ZT="" B 1
W !!,"Input from Kermit-M files to a binary DOS file",! D GFSPEC Q:E D GETFIL I E W " ",FSPEC,! G BFI
BFI1 S IO=5
R !,"DOS file name to write to: ",FN Q:FN=""
C IO
O IO:("FN":FN:"FA":2:"TR":1):5 E Q
U IO S FILE="" F J=0:1 S FILE=$O(^ZKRZ($J,"FILE",FILE)) Q:FILE="" D FOPENR D:'E BFIL D FCLOSER
U 0 I IO W !,"** Done for this set of files" C IO ;** CCSM
;** if not listing on local screen, message & close device ;** STD
K IO
Q
BFIL U 0 S X=^ZKR(F1,F2),DATIM=$P(X,B,4) D DATIM W !!,"Kermit file : ",FILE," received at ",DATIM," ; ",$P(X,B,5)," bytes",!!
U 0 W !,"starting ",FILE," to ",FN U IO S $ZDS=0 ;** CCSM
;** if not listing on local screen, show progress ;** STD
F D BFIL1 S F3=$O(^ZKR(F1,F2,F3)) Q:F3=""
U 0 W "done" U IO ;** CCSM
K BIN,CL,LIN,C1
Q
BFIL1 S CL=^ZKR(F1,F2,F3),LIN=""
F I=1:1 Q:I>$L(CL) S C=$A(CL,I) D BFIL2
U IO W LIN U 0 W "."
Q
BFIL2 S BIN=0
I C=$A(FQB) S I=I+1,C=$A(CL,I),BIN=1 D:C=-1 BFIL3
I C=$A(FQA) S I=I+1,C=$A(CL,I) D:C=-1 BFIL3 I C'=$A(FQB),C'=$A(FQA) S C=$S(C=63:C+64,1:C-64)
I BIN S C=C+128
S LIN=LIN_$C(C)
Q
BFIL3 S F3=$O(^ZKR(F1,F2,F3)),CL=^(F3),I=1,C=$A(CL,I)
Q
RIM G RIM^ZKRMIR
RIR G RIR^ZKRMIR
GI ;
W !!,"Global input from a Kermit-M file",!
GI1 D GFILE Q:E D FOPENR I E W *7," [file undefined or empty]" G GI1
D KOUT W !,LIN,! D KOUT W LIN,! ;pkw 4/15/90 - display comment, date
S GNAM="" W !,"Starting global input..."
GIF D KOUT G:LIN="" GIFX I $E(LIN)'="^" W *7,!,"ERROR - no global reference where one was expected",!,"No more input from file" G GIFX
S REF=LIN I $P(REF,"(")'=GNAM S GNAM=$P(REF,"(") W !,GNAM,"..."
I F3="" W *7,!,"ERROR - last reference had no data!" G GIFX
D KOUT S @REF=LIN G:F3]"" GIF W !,"** done" D FCLOSER
GIFX W !,"** All done" K FILE,REF,GNAM
Q
SGI ;
W !!,"Sequential global input from a Kermit-M file",!
SGI1 D GFILE Q:E D FOPENR I E W *7," [file undefined or empty]" G SGI1
SGI2 W !,"Enter the root of the global subtree under which to file:" D GRT Q:E I $D(@(GRF(1)))\10 W *7,!!,"** that subtree already has descendents, try again",! G SGI2
W !,"Starting input..."
F GI=1:1 D KOUT S @GRF(1)@(GI)=LIN W:GI#100=0 "." I F3="" D FCLOSER W "** done" Q
K GI Q
DATIM ;
Q:DATIM'?1.6N1","1.6N S Y=$P(DATIM,",",2) S TIM=$S(Y>43199:Y\3600-12,1:Y\3600)_":" S YY=Y#3600\60_"" S:$L(YY)=1 YY="0"_YY S TIM=TIM_YY_$S(Y>43199:" PM",1:" AM") K Y,YY
;S DATIM=$ZD(+DATIM,2)_", "_TIM K TIM
S %HDAT=DATIM D %DAT^%OUTDAT S DATIM=%DAT
Q
KOUT G KOUT^ZKRMFIO
FOPENR G FOPENR^ZKRMFIO
FCLOSER G FCLOSER^ZKRMFIO
GFILE G GFILE^ZKRMU
GETFIL G GETFIL^ZKRMU
GFSPEC G GFSPEC^ZKRMU
GRT G GRT^ZKRMU
READ R A:120 S E=$S(A="":0,"<#@^>"[$E(A):1,1:0)
W:E " Can't do that here." Q
ZKRMIR
ZKRMIR ;DGR NYSCVM ;14APR90 11:03AM
;Copyright (c) 1984 New York State College of Veterinary Medicine
W !!,"Routine input from .MMP files",! D GFSPEC Q:E I $P(FSPEC,".",2)'="MMP" W *7," MUST have filetype .MMP" G RIM
D GETFIL I E W " ",FSPEC,! G RIM
S FILE="" F I=0:0 S FILE=$O(^ZKRZ($J,"FILE",FILE)) Q:FILE="" S ROU=$P(FILE,".") D RCHECK I 'E D FOPENR,RFILE,FCLOSER
K ^ZKRZ($J,"ROU"),RI,FILE W !,"** done" Q
RIR ;
W !!,"Routine input from a .ROU file",! D GFILE Q:E I $P(FILE,".",2)'="ROU" W *7," MUST have filetype .ROU" G RIR
D FOPENR I E W *7," [file undefined or empty]" G RIR
D KOUT W !,"File description: ",LIN D KOUT W !,"Written on: ",LIN
F I=0:0 D KOUT Q:LIN=""!($E(LIN)=$C(26)) S ROU=LIN D RCHECK D:E RIRSK D:'E RFILE
D FCLOSER K ^ZKRZ($J,"ROU"),RI W !,"** done"
Q
RIRSK W " skipping ",ROU,"..." F I=0:0 D KOUT I LIN="" Q
Q
RFILE ;
W !,"now filing routine ",ROU,"..." K ^ZKRZ($J,"ROU") F RI=1:1 D KOUT Q:LIN="" S ^ZKRZ($J,"ROU",RI)=LIN
;X "ZR F RI=1:1 S X=$D(^ZKRZ($J,""ROU"",RI)) X ""I X ZI ^(RI)"" I 'X ZS @ROU Q" ;** M/11 ;** M/11+ V1
S %GLB="^ZKRZ("_$J_","_"""ROU"""_")" D ^%RSAVE ;** CCSM
;** load into routine buffer and save on disk ;** STD
S ^UTILITY("ROU",ROU)="" ;** M/11 ;**M/11+ V1
;** update global directory ;** STD
W "done" Q
RCHECK ;
S E=0 I $D(^UTILITY("ROU",ROU)) W *7,!,"Routine ",ROU," is already on file. Overwrite? No => " D READ S E=$S("\N\No\NO\no\\"[(B_A_B):1,"\Y\YES\yes\Yes\"[(B_A_B):0,1:2) I E=2 W *7," ??" G RCHECK ;** M/11 ;** M/11+ V1
;** check if routine already exists ;** STD
Q
KOUT G KOUT^ZKRMFIO
FOPENR G FOPENR^ZKRMFIO
FCLOSER G FCLOSER^ZKRMFIO
GFILE G GFILE^ZKRMU
GETFIL G GETFIL^ZKRMU
GFSPEC G GFSPEC^ZKRMU
READ R A:120 S E=$S(A="":0,"<#@^>"[$E(A):1,1:0)
W:E " Can't do that here." Q
ZKRMO
ZKRMO ;DGR NYSCVM ;24APR90 6:39AM
;Copyright (c) 1984 New York State College of Veterinary Medicine
W !!,"Output options (MUMPS data structures --> Kermit-M file system)",! F I=1:1:6 W !?5,I,") ",$P("Sequential file out;Routine out (.MMP files);Routine out (.ROU file);Global out;Sequential global out;Binary file out",S,I)
OO1 W !!,"Your choice (? for help) : X => " D READ G OO1:E Q:"Xx^>"[A I "?Hh"[$E(A) S HREF="""OOPT""" D HELP^ZKRM G OOPT
I A?1N1"?",$E(A)>0,$E(A<7) S HREF="""OOPT"","""_$P("SFO;ROM;ROR;GO;SGO",S,+A)_"""" D HELP^ZKRM G OOPT
I $S(A'?1N:1,A<1:1,A>6:1,1:0) W *7," ? no such option" G OO1
W @FF D @$P("SFO;ROM;ROR;GO;SGO;BFO",S,A) G OOPT
Q
SFO ;
W !!,"Write a sequential MUMPS file to a Kermit-M file",!
SFO1 ;W !,"Read from" D ^%IS I POP Q ;** M/11 ;** M/11+ V1
;W !,"Read from device 0,5 or 6: " R IO I IO="" Q
S IO=5
I IO R !,"File name: ",FN
I IO O IO:("FN":FN:"FA":0):5 E Q
;I "\TRM\SDP\MT\"'[(B_IOT_B) W *7," I can't deal with that type of device" G SFO1
;set IO as $I from which to read, IOT as device type, IOST as subtype, then OPEN it with correct parameters ;** STD
I IO S IOT="SDP",TRM=0
E S TRM=1,IOT="TRM"
SFOF W !,"Write to which Kermit-M file?" D GFILE G:E SFOX D FOPENW I E W *7," ?? that file is already defined" G SFOF
U 0 I TRM,IO'=$I W !,"Enter your text lines at terminal #",IO,!
I TRM U IO W !!!,"Enter lines of text; enter <CR> only when done",!
E U 0 W !,"Writing to file ",FILE,"..." U IO S $ZDS=0 ;** CCSM
U IO F I=0:0 W:TRM !,">" R LIN D SFEOF Q:E D KIN
D FCLOSEW
I TRM W !!,"The above text is now in file ",FILE
E U 0 W "** done"
SFOX U 0 I $D(IO),IO,IO'=$I C IO
K TRM,FILE Q
SFEOF S E=0 I IOT="TRM" S E=$S(LIN="":1,1:0) Q
;I IOT="SDP" S E=$S(LIN=$C(26):1,1:0) Q
I IOT="SDP" S E=$ZIO\256=36 Q
I IOT="MT" S E=$S(LIN=$C(26):1,$ZA\16384#2:1,1:0) Q
S E=1
Q
BFO ; **CCSM specific
W !!,"Write a binary DOS file to a Kermit-M file",!
S IO=5
R !,"Read from DOS file name: ",FN Q:FN=""
C IO
O IO:("FN":FN:"FA":0:"TR":1):5 E Q
U IO S ZDS=$ZDS ;eof
BFOF U 0 W !,"Write to which Kermit-M file?" D GFILE G:E BFOX D FOPENW I E W *7," ?? that file is already defined" G BFOF
U 0 W !,"Writing ",FN," to file ",FILE
U IO S $ZDS=0 ;** CCSM
F U IO R LIN#80 S ZIO=$ZIO U 0 W "." D BKIN Q:ZIO\256=36
S CL="" D FCLOSEW
U 0 W "** done"
BFOX U IO C IO
K FN,FILE,ZIO,ZDS Q
BKIN I $L(LIN)'=80,ZIO\256'=36 S LIN=LIN_$C(13)
F I=1:1 Q:I>$L(LIN) S C=$A(LIN,I) D
.I C>127 S C=C-128,LIN=$E(LIN,1,I-1)_FQB_$C(C)_$E(LIN,I+1,255),I=I+1
.I C<32 S C=C+64,LIN=$E(LIN,1,I-1)_FQA_$C(C)_$E(LIN,I+1,255),I=I+1
.I C=127 S C=C-64,LIN=$E(LIN,1,I-1)_FQA_$C(C)_$E(LIN,I+1,255),I=I+1
.I C=$A(FQA)!(C=$A(FQB)) S LIN=$E(LIN,1,I-1)_FQA_$C(C)_$E(LIN,I+1,255),I=I+1
S ^ZKR(F1,F2,F3)=LIN,BCNT=BCNT+$L(LIN),LIN="",F3=F3+1
Q
ROM G ROM^ZKRMOR
ROR G ROR^ZKRMOR
GO ;
W !!,"Global output to a Kermit file",!
GOR D GROOT I 'GRF Q
GOF W !!,"Write into what Kermit-M file?",! D GFILE Q:E D FOPENW I E W *7," ?? that file is already defined" G GOF
D HEAD F GI=1:1:GRF S GR=GRF(GI) D GOW
D FCLOSEW K GI,GR,GRF,DEF,L,M,REF,SUB W *7,!,"** All done" Q
GOW W !,"Starting ",GR,"..." I '$D(@GR) W *7," ** [undefined]" Q
S L=$S(GR["(":1,1:0),M=L,REF(L)=GR,L(L)=$L(GR)-1 D GOVIS:$D(@GR)#10 S M=L+1 D GODOWN
Q
GODOWN S SUB(L)="" F I=0:0 S SUB(L)=$O(@REF(L)@(SUB(L))) Q:SUB(L)="" S REF(M)=$S('L:REF(L)_"("""_SUB(L)_""")",1:$E(REF(L),1,L(L))_","""_SUB(L)_""")"),L(M)=$L(REF(M))-1,DEF=$D(@REF(M)) D:DEF#10 GOVIS I DEF\10 S L=M,M=M+1 D GODOWN S M=L,L=L-1
Q
GOVIS S LIN=REF(M) D KIN S LIN=@(REF(M)) D KIN Q
Q
SGO ;
W !!,"Write one level of one or more globals to a Kermit file",!
SGOR D GROOT I 'GRF Q
SGOF W !!,"Write into what Kermit-M file?",! D GFILE Q:E D FOPENW I E W *7," ?? that file is already defined" G SGO
W " writing..." F GI=1:1:GRF S GR=GRF(GI) D SGOW
D FCLOSEW K GI,GR,GRF,SUB W *7,!,"** All done" Q
SGOW W !,"Starting ",GR,"..." I $D(@GR)\10=0 W *7," ** [undefined]" Q
S SUB="" F I=0:0 S SUB=$O(@GR@(SUB)) Q:SUB="" I $D(@GR@(SUB))#10 S LIN=@GR@(SUB) D KIN
Q
GROOT G GROOT^ZKRMU
GFILE G GFILE^ZKRMU
FOPENW G FOPENW^ZKRMFIO
FCLOSEW G FCLOSEW^ZKRMFIO
KIN G KIN^ZKRMFIO
DATIM G DATIM^ZKRMU
READ R A:120 S E=$S(A="":0,"<#@"[$E(A):1,1:0)
W:E " Can't do that here." Q
HEAD ;
W !!,"Please enter a free-text description of this file: " D READ
W " writing..." S LIN=A D KIN S DATIM=$H D DATIM S LIN=DATIM D KIN K DATIM
Q
ZKRMOR
ZKRMOR ;DGR NYSCVM ; 18 Apr 85 15:52
;Copyright (c) 1984 New York State College of Veterinary Medicine
W !!,"Routine output to Kermit-M files (.MMP)",!,"Please specify the set of routines to write:"
D RSET G ROMX:'RCT W !,"Writing routines to Kermit files now..."
S ZL="ZL @A F J=1:1 S X=$T(+J) Q:X="""" S ^ZKRZ($J,""ROM"",J)=X",A=0 ;** M/11 ;** M/11+ V1
;** SET ZL=an Xecutable string to load a routine named in var. A into scratch global;** STD
ROM1 S A=$O(^ZKRZ($J,"RSET",A)) I A="" W !,"All done for this set of routines" G ROMX
W !,A,"..." K ^ZKRZ($J,"ROM") X ZL I J>1 S FILE=A_".MMP" D FOPENW I E W *7,FILE," is already defined - NOT overwritten" G ROM1
F J=1:1 S LIN=$S('$D(^ZKRZ($J,"ROM",J)):"",1:^(J)) D:LIN]"" KIN I LIN="" D FCLOSEW W "done" Q
G ROM1
ROMX K RCT,ZL,^ZKRZ($J,"ROM"),^("RSET")
Q
ROR ;
W !!,"Routine output to a Kermit-M file (.ROU)",!,"Please specify the set of routines to write:"
D RSET G RORX:'RCT
RORF W !!,"Write these routines to what Kermit-M file?",! D GFILE Q:E I $P(FILE,".",2,3)'="ROU" W *7," ?? must have file type of .ROU" G RORF
D FOPENW I E W *7," ?? that file is already defined" G RORF
S ZL="ZL @A F J=1:1 S X=$T(+J) Q:X="""" S ^ZKRZ($J,""ROR"",J)=X",A=0 ;** M/11 ;** M/11+ V1
;** SET ZL=an Xecutable string to load a routine named in var. A into scratch global;** STD
D HEAD S A=0
ROR1 S A=$O(^ZKRZ($J,"RSET",A)) I A="" S LIN="" D KIN D FCLOSEW W !,"All done for this set of routines" G RORX
W !,A,"..." K ^ZKRZ($J,"ROR") S LIN=A D KIN X ZL F J=1:1 S LIN=$S('$D(^ZKRZ($J,"ROR",J)):"",1:^(J)) D KIN I LIN="" W "done" Q
G ROR1
RORX K RCT,ZL,^ZKRZ($J,"ROR"),^("RSET")
Q
RSET G RSET^ZKRMUR
GFILE G GFILE^ZKRMU
FOPENW G FOPENW^ZKRMFIO
FCLOSEW G FCLOSEW^ZKRMFIO
KIN G KIN^ZKRMFIO
DATIM G DATIM^ZKRMU
READ R A:120 S E=$S(A="":0,"<#@"[$E(A):1,1:0)
W:E " Can't do that here." Q
HEAD ;
W !!,"Please enter a free-text description of this file: " D READ
W " writing..." S LIN=A D KIN S DATIM=$H D DATIM S LIN=DATIM D KIN K DATIM
Q
ZKRMU
ZKRMU ;DGR NYSCVM ;16MAR90 10:37PM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit <--> MUMPS interface - utility parts
DATIM ;
Q:DATIM'?1.6N1","1.6N S Y=$P(DATIM,",",2) S TIM=Y\3600_":" S YY=Y#3600\60 S:$L(YY)=1 YY="0"_YY S TIM=TIM_YY K Y,YY
;S DATIM=$ZD(+DATIM,2) ;** M/11 V5 ;** M/11+ V1
S %HDAT=+DATIM D %DAT^%OUTDAT S DATIM=%DAT
;** set DATIM to readable date, like '2 APR 83' ;** STD
S DATIM=$J(DATIM,9)_", "_TIM K TIM
Q
GFSPEC ;
W !,"-- File specification : " D READ S:A="" E=1 Q:E S FN=$P(A,"."),FT=$P(A,".",2) I $S($L(FN)>8:1,$L(FT)>3:1,FN="":1,FT="":1,FN'?.1"%".8UN.1"*":1,FT'?.3UN.1"*":1,1:0) W *7," ** like TEST.DAT, or T*.D*, or, *.MMP" G GFSPEC
E S FSPEC=A
K FN,FT Q
GETFIL ;
K ^ZKRZ($J,"FILE") S (E,CT)=0,FN=$P(FSPEC,"."),FT=$P(FSPEC,".",2)
S FNL=$L(FN),FTL=$L(FT),FNW=$E(FN,FNL)="*",FTW=$E(FT,FTL)="*"
I 'FNW S F1=FN D GF2 G GFX
S FN=$E(FN,0,FNL-1),F1=FN D:$S(F1="":0,'$D(^ZKR(F1)):0,1:1) GF2 F I=0:0 S F1=$O(^ZKR(F1)) Q:F1=""!($E(F1,0,FNL-1)'=FN) D GF2
G GFX
GF2 I 'FTW S F2=FT D:$D(^ZKR(F1,F2)) GFSET Q
S FT=$E(FT,0,FTL-1),F2=FT D:$S(F2="":0,'$D(^ZKR(F1,F2)):0,1:1) GFSET F I=0:0 S F2=$O(^ZKR(F1,F2)) Q:F2=""!($E(F2,0,FTL-1)'=FT) D GFSET
Q
GFSET S ^ZKRZ($J,"FILE",F1_"."_F2)="",CT=CT+1 Q
GFX I '$D(^ZKRZ($J,"FILE")) S E=1,FSPEC="File(s) not found for "_FSPEC
E S ^ZKRZ($J,"FILE")=CT W " --> ",CT," file",$S(CT=1:"",1:"s")," meet",$S(CT=1:"s",1:"")," the specification"
K FN,FT,FNW,FTW,FNL,FTL,F1,F2,I,CT Q
GFILE ;
W !,"- File specification : " D READ S:"^>"[A E=1 Q:E I A'?1.8UN1"."1.3UN,A'?1"%".7UN1"."1.3UN W *7," Enter a single file name, like TEST.DAT" G GFILE
S FILE=A
Q
GROOT ;
K GRF S GRF=0 W !,"Enter global references, one at a time:",!
GR1 W !,"Global ^" D READ Q:E I "^>"[A S E=1 Q
I $E(A)="?" D GRH G GR1
D VERGRF I E W *7," [ syntax ]" G GR1
S GRF=GRF+1,GRF(GRF)=A K X1,X2 G GR1
Q
GRH W ! F I=2:1 S X=$T(GRH+I) Q:$P(X," ")]"" W !?5,$P(X,";",2,99)
W ! Q
;Enter a full global reference, including ending parentheses (if any).
;For example:
;
; ^A -- or -- ^A("ONE",2,"three")
;
;Each reference will be processed in the order in which you enter it.
;It is possible to list the same subtree more than once in the list.
;
;Press <RETURN> to end the list. To abort an incorrect list so that
;it is not processed, press CTRL/C.
GRT ;
W !,"Enter a global reference:",!
GRT1 W !,"Global ^" D READ Q:E I "^>"[A S E=1 Q
I $E(A)="?" D GRTH G GRT1
D VERGRF I E W *7," [ syntax ]" G GRT1
S GRF=1,GRF(1)=A Q
GRTH W ! F I=2:1 S X=$T(GRTH+I) Q:$P(X," ")]"" W !?5,$P(X,";",2,99)
W ! Q
;Enter a full global reference, including ending parentheses (if any).
;For example:
;
; ^A -- or -- ^A("ONE",2,"three")
;
READ U 0:("TR":0:"EP":0:"MR":80) ;** CCSM
R A:120 S E=$S(A="":0,"<#@"[$E(A):1,1:0)
;S A=$ZU(A) ;** M/11 V5 (NYSCVM only)
S A=$TR(A,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") ;** M/11+ V1
;Convert A to upper case ;** STD
Q
VERGRF ;
S E=0 S:$E(A)'="^" A="^"_A S X1=$P(A,"("),X2=$P(A,"(",2,255) I $S(X1?1"^"1.8AN:0,X1?1"^%".7AN:0,1:1) S E=1 Q
I $S(X2=""&(A'["("):0,X2=""&(A'[")"):1,$E(X2,$L(X2))'=")":1,1:0) S E=1 Q
I X2]"" S X2=$E(X2,0,$L(X2)-1) F I=1:1:$L(X2,",") S X1=$P(X2,",",I) I $S(+X1=X1:0,$E(X1)=""""&($E(X1,$L(X1))=""""):0,1:1) S E=1 Q
Q
ZKRMUR
ZKRMUR ;DGR NYSCVM ; 19 Apr 85 8:38
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit <--> MUMPS interface - utilities - pick a routine set
RSET ;
REF R !,"Refresh routine directory in ^UTILITY? No=> " D READ G REF:E,HELP2:$E(A)="?" I A?1"Y".E D ^%ROU ;** M/11 ;** M/11+ V1
;** rebuild routine directory if appropriate ;** STD
K ^ZKRZ($J,"RSET") S RCT=0,SEL=1,E=0
ROU R !,"Routine: " D READ G ROU:E I A="" W ! G XIT
I A["?" D @$S(A="?L":"DISP",1:"HELP") G ROU
S SEL=1 I A?1"'".E S SEL=0,A=$E(A,2,99)
I A?.E1"*" S A=$E(A,1,$L(A)-1),X=A S:X="" X=0 D SING,MULT G ROU
I A["-" D RANGE G ROU
D SING I E W *7," I don't have that routine on file"
G ROU
SING S E=0 I A]"",$D(^UTILITY("ROU",A)) S X=A
E S E=1 Q
S I SEL,'$D(^ZKRZ($J,"RSET",X)) S ^(X)="",RCT=RCT+1 Q
I 'SEL,$D(^ZKRZ($J,"RSET",X)) K ^(X) S RCT=RCT-1
Q
MULT S X=$O(^UTILITY("ROU",X)) Q:X=""!($E(X,1,$L(A))'=A)
D S G MULT
Q
RANGE S X=$P(A,"-",1),Y=$P(A,"-",2) I X]Y W " ???" Q
I $D(^UTILITY("ROU",X)) D S
R2 S X=$O(^UTILITY("ROU",X)) Q:X="" Q:X]Y D S G R2
Q
XIT K A,X,Y,SEL S ^ZKRZ($J,"RSET",0)=RCT W RCT," routine",$S(RCT=1:" was",1:"s were")," selected",!
Q
READ R A D UPPER S E=$S(A="":0,"^<>#@"[$E(A,1):1,1:0)
W:E " Can't do that here." Q
HELP W !!,"Choose routines as in these examples:"
W !," RNAM",?18,"one routine"
W !," RNAM1-RNAM2",?18,"range of routines"
W !," CD*",?18,"all routines beginning with CD"
W !," *",?18,"all routines"
W !," 'RNAM",?18,"exclude this routine from those already selected"
W !," 'RNAM1-RNAM2",?18,"exclude this range of routines from those already selected"
W !," 'CD*",?18,"exclude all routines beginning with CD from the routines",!?18,"already selected"
W !!,"Enter '?L' to get a list of routines selected so far"
W ! Q
DISP W " ",$S('RCT:"** no",1:RCT)," routine",$S(RCT=1:" has",1:"s have")," been selected thus far",$S('RCT:" **",1:":") I RCT S X=0,E=1 F Y=1:1 W ! F A=0:1:7 S X=$O(^ZKRZ($J,"RSET",X)) G:X="" DISP1 W ?(A*10),X
DISP1 Q
HELP2 W !,"It may take time (if there are a lot of routines), but it ensures that the",!,"routine directory is accurate." G REF
UPPER ;Convert A to upper-case
;S A=$ZU(A) ;** M/11 V5 (NYSCVM only)
S A=$TR(A,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") ;** M/11+ V1
;Convert A to upper case characters ;** STD
Q
ZKRR
ZKRR ;DGR NYSCVM ;22APR90 9:01AM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - receive files
S (TRY,OLDTRY,SPN)=0
S TRY=TRY+1 I TRY>MAXTRY G A
D RPACK I E D NAK G R
G A:RPT'="S"
RI ;
S SPN=RPN D RPAR S SPT="Y",SDAT=$C(RPSIZ+32)_$C(STO+32)_" "_SQA_SQB D SPACK,BUMP S OLDTRY=0 K F1,F2 G RF
RF ;
S TRY=TRY+1 I TRY>MAXTRY G A
D RPACK I E D NAK G RF
G A:"SZFB"'[RPT,@("RF"_RPT)
RFS S OLDTRY=OLDTRY+1 G A:OLDTRY>MAXTRY D PREV G A:SPN'=RPN,RI
RFZ D PREV G A:SPN'=RPN D ACK G RF
RFF ;
I SPN'=RPN D NAK G RF
S FILE=RDAT D FOPEN K FILE I E S SPT="E",SDAT=$E(E,2,99) D SPACK Q
I TTY U 0 W !,"Receiving file : ",F1,".",F2,"..." U TTY
S OLDTRY=TRY D ACK,BUMP G RD
RFB I SPN'=RPN D NAK G RF
D ACK S E=0 Q
Q
RD ;
S TRY=TRY+1 I TRY>MAXTRY G A
D RPACK I E D NAK G RD
G A:"DFZ"'[RPT,@("RD"_RPT)
RDD I SPN'=RPN S OLDTRY=OLDTRY+1 G A:OLDTRY>MAXTRY D PREV G A:SPN'=RPN D ACK,BUMP G RD
D PDATA,ACK S OLDTRY=TRY D BUMP G RD
RDF S OLDTRY=OLDTRY+1 G A:OLDTRY>MAXTRY D PREV G A:SPN'=RPN D ACK,BUMP G RD
RDZ G A:SPN'=RPN S ^ZKR(F1,F2)=^ZKR(F1,F2)_B_$H_B_BCNT S H2=$H D EFBAUD K H1,H2,F1,F2,F3 D ACK,BUMP
D ULOCK
I TTY U 0 W "done" U TTY
G RF
Q
A ;
I 'KAF,$D(F1),$D(F2),F1]"",F2]"",$D(^ZKR(F1,F2)),$P(^(F2),B,3)="" K ^(F2)
K F1,F2,F3,BCNT
I TTY U 0 W !,"Aborting RECEIVE operation" U TTY
S E=1 Q
UTIL ;
BUMP S TRY=0,SPN=SPN+1#64 Q
PREV S SPN=SPN-1#64 Q
NAK S SPT="N",SDAT="" D SPACK Q
ACK S SPT="Y",SDAT="" D SPACK S TRY=0 Q
SPACK G SPACK^ZKRUP
RPACK I TTY,RPN#8=1 U 0 W "." U TTY
G RPACK^ZKRUP
PDATA ;
S ^ZKR(F1,F2,F3)=RDAT,BCNT=BCNT+$L(RDAT),F3=F3+1
Q
RPAR G RPAR^ZKRUM
FOPEN ;
S E=0 I FILE'?.1"%"1.8UN1"."1.3UN S E="1 bad filespec" Q
S F1=$P(FILE,"."),F2=$P(FILE,".",2) I $D(^ZKR(F1,F2)),FW S E="1 file already defind" K F1,F2 Q
D WLOCK
K ^ZKR(F1,F2) S ^ZKR(F1,F2)=B_RQA_","_RQB_B_$H,H1=$H,EFB=-1,BCNT=0,F3=1
Q
EFBAUD S EFB=BCNT*10\(H2-H1*86400+$P(H2,",",2)-$P(H1,",",2)) Q
WLOCK L ^ZKR(FILE) Q
ULOCK L Q
ZKRS
ZKRS ;DGR NYSCVM ;24APR90 6:40AM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - send a group of files
S (SPN,TRY)=0,RPT=""
S ;
S TRY=TRY+1 I TRY>MAXTRY G A
S SPT="S",SDAT=$C(RPSIZ+32)_$C(STO+32)_" "_SQA_SQB D SPACK,RACK E G S:RPT'="E",RACKER
D RPAR,BUMP G NXTFIL
SF ;
S TRY=TRY+1 I TRY>MAXTRY G A
S SPT="F",SDAT=FILE D SPACK,RACK E G SF:RPT'="E",RACKER
D BUMP,BDATA G SD:SDAT]"",SZ
SD ;
S TRY=TRY+1 I TRY>MAXTRY G A
S SPT="D" D SPACK,RACK E G SD:RPT'="E",RACKER
D BUMP,BDATA G SD:SDAT]"",SZ
SZ ;
S TRY=TRY+1 I TRY>MAXTRY G A
S SPT="Z",SDAT="" D SPACK,RACK E G SZ:RPT'="E",RACKER
D ULOCK
S H2=$H D EFBAUD
I TTY U 0 W "done" U TTY
D BUMP G NXTFIL
SB ;
S TRY=TRY+1 I TRY>MAXTRY G A
S SPT="B",SDAT="" D SPACK,RACK E G SB:RPT'="E",RACKER
D BUMP S E=0 Q
A ;
S E=1 Q
NXTFIL ;
S:'$D(FILE) FILE="" S FILE=$O(^ZKRZ($J,"FILE",FILE)) I FILE="" G SB
D RLOCK
S F1=$P(FILE,"."),F2=$P(FILE,".",2),F3=$O(^ZKR(F1,F2,0)) G NXTFIL:F3="" S CL=^(F3),LL=$L(CL),CC=1,FQA=$P($P(^ZKR(F1,F2),B,2),","),FQB=$P($P(^(F2),B,2),",",2),BCNT=$P(^(F2),B,5),H1=$H,EFB=-1
I TTY U 0 W !,"Sending file : ",FILE,"..." U TTY
G SF
RACKER ;
I TTY U 0 W !,"Error - ",RDAT," - transfer aborted" U TTY
S E=1 Q
UTIL ;
RACK D RPACK I $S(E:0,RPT'="Y":0,SPN'=RPN:0,1:1)
Q
BUMP S TRY=0,SPN=SPN+1#64 Q
SPACK I TTY,SPN#8=1 U 0 W "." U TTY
G SPACK^ZKRUP
RPACK G RPACK^ZKRUP
BDATA ;
S SDAT="" I F3="" Q
I CC>LL D BGLIN I F3="" Q
S NC=SPSIZ-7 ;I SQA'=FQA G BD2
G BD3
BD1 S F=$F(CL,FQA,CC) G:F BD11 I LL-CC<NC S SDAT=SDAT_$E(CL,CC,LL),NC=NC-LL+CC+1 D BGLIN G:F3]"" BD1 Q
S X=CC+NC,SDAT=SDAT_$E(CL,CC,X-1),CC=X
Q
BD11 S X=F-CC+1 I X'>NC S SDAT=SDAT_$E(CL,CC,F),NC=NC-X,CC=F+1 G BD1:NC Q
S X=CC+NC-1,SDAT=SDAT_$E(CL,CC,X-1),CC=X
Q
BD2 S C=$E(CL,CC),CC=CC+1 I C="" D BGLIN G:F3]"" BD2 Q
I C=SQA S SDAT=SDAT_SQA_SQA,NC=NC-2 G:NC>0 BD2 Q
I C'=FQA S SDAT=SDAT_C,NC=NC-1 G:NC>0 BD2 Q
S C=$E(CL,CC),CC=CC+1 I C="" ABORT ; note by pkw - not a legal MUMPS statement - I don't know what this was meant to do
I C=FQA S SDAT=SDAT_FQA,NC=NC-1 G:NC>0 BD2 Q
S SDAT=SDAT_SQA_C,NC=NC-2 G:NC>0 BD2 Q
Q
BGLIN S F3=$O(^ZKR(F1,F2,F3)) I F3]"" S CL=^(F3),LL=$L(CL),CC=1
Q
BD3 S C=$E(CL,CC) I C="" D BGLIN G:F3]"" BD3 Q
I C=FQB,NC>2 D FQB G BD3
I C=FQB,NC<3 Q
I C=FQA,NC>1 D FQA G BD3
I C=FQA,NC<2 Q
S SDAT=SDAT_C,CC=CC+1,NC=NC-1 G:NC>0 BD3 Q
FQB S CC=CC+1,SDAT=SDAT_SQB,NC=NC-1 Q
FQA S CC=CC+1,SDAT=SDAT_SQA,NC=NC-1 Q
RPAR G RPAR^ZKRUM
EFBAUD S EFB=BCNT*10\(H2-H1*86400+$P(H2,",",2)-$P(H1,",",2)) Q
RLOCK L ^ZKR(FILE,$J) Q
ULOCK L Q
ZKRSET
ZKRSET ;DGR NYSCVM ;17APR90 7:32PM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - set Kermit parameters (SET command)
SET ;
D @("S"_$E(CSS(2),1,3)) Q
SABO S KAF=CMD(3)="KEEP" Q
SBAU S BAUD=CMD(3) Q
SDEB S DEBUG=CMD(3)="ON" Q
SDEL S DELAY=CMD(3) Q
SDUP S FDX=CMD(3)="FULL" Q
SESC S CESC=$A(CMD(3),2)-64 Q
SFIL S FW=CMD(3)="ON" Q
SLIN I '$D(CMD(3)) C:TTY TTY S TTY=0 U 0 W " Ok - no line is assigned" Q
I $S(CMD(3)'?1.N:0,CMD(3)'<8&(CMD(3)'>47):1,1:0) S A=CMD(3) G SLIN1 ;** CCSM
I '$D(^ZKRX("LINE",CMD(3))) W !,"? No such line" Q
S A=+^(CMD(3))
SLIN1 O A::0 E W !,"? Can't get that line now" Q ;** CCSM
;Open the port if possible, else error message and QUIT ;** STD
S TTY=A W " Line ",TTY," is now assigned"
Q
SPAR ;
I $E(CMD(3))="M" W !,"? Can't set MARK parity in CCSM" Q ;** CCSM
I $E(CMD(3))="S" W !,"? Use NONE in CCSM" Q ;** CCSM
S PAR=$E(CMD(3)) Q
SPAU S PAUSE=CMD(3) Q
SREC G @("SR1"_$E(CMD(3),1,3))
SR1PAC S RPSIZ=CMD(4) Q
SR1STA S RSOH=$A(CMD(4),2)-64 Q
SR1TIM S RTO=CMD(4) Q
SRET S MAXTRY=CMD(3)+1 Q
SSEN G @("SS1"_$E(CMD(3),1,3))
SS1END S SEOL=$A(CMD(4),2)-64 Q
SS1PAC S SPSIZ=CMD(4) Q
SS1QUO S SQA=CMD(4) Q
SS1STA S SSOH=$A(CMD(4),2)-64 Q
SS1TIM S STO=CMD(4) Q
SS1QOB S SQB=CMD(4) Q
ZKRSRV
ZKRSRV ;DGR NYSCVM ; 03 MAR 84 3:47 PM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - Server executive
S SPN=0
SRV ;
D RPACK I E D NAK G SRV
I "SRG"'[RPT D NAK G SRV
G @("SRV"_RPT)
SRVS ;
D RI^ZKRR G SRV
SRVR ;
S FN=$P(RDAT,"."),FT=$P(RDAT,".",2) I $S($L(FN)>8:1,$L(FT)>3:1,FN="":1,FT="":1,FN'?.1"%".8UN.1"*":1,FT'?.3UN.1"*":1,1:0) K FN,FT S SPT="E",SDAT="Illegal filespec : "_RDAT D SPACK G SRV
K FN,FT S FSPEC=RDAT D GETFIL K FSPEC I E S SPT="E",SDAT="No file(s) match "_RDAT D SPACK G SRV
D ^ZKRS G SRV
SRVG ;
S C=$E(RDAT) I "LF"'[C S SDAT="Unrecognized 'Generic' command "_RDAT,SPT="E" D SPACK G SRV
G @("SRVG"_C)
SRVGL D ACK U 0 W !,"Session terminated by local Kermit's BYE command" C:TTY'=$I TTY K Q
SRVGF D ACK U 0 W !,"Server shut down by local Kermit's FINISH command" G START^ZKR
NAK S SPT="N",SDAT="" D SPACK Q
ACK S SPT="Y",SDAT="" D SPACK S TRY=0 Q
SPACK G SPACK^ZKRUP
RPACK G RPACK^ZKRUP
GETFIL D GETFIL^ZKRUM Q
ZKRT20
ZKRT20 ;DGR NYSCVM ;15APR90 6:22PM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - command parser
;U 0:(RM:"":$C(27)) ;** M/11 V5 ;** M/11+ V1
U 0:("EP":0) ;** CCSM
;Make sure 'Escape' is read with READ * ;** STD
D INIT
RCOM W !
RC1 W "Kermit-M>" F I=1:1:CI-1 W CMD(I)," "
I CI W CMD(CI) I CI=VI W " " S A=32
RCS ;S LA=A R *A:600 G TO:'$T,CR:A=13,ESC:A=27,QM:A=63,DEL:A=127,CTRLU:A=21,CTRLC:A=3
S LA=A R *A:600 G TO:'$T,CR:A=13,ESC:A=27,QM:A=63,DEL:A=8,CTRLU:A=21,CTRLC:A=3
I A>96,A<123 S A=A-32
I A>32 S:LA=32!'LA&(A-40) CI=CI+1,CMD(CI)="" S C=$C(A),CMD(CI)=CMD(CI)_C
G RCS
TO W !,"? No response for 10 minutes" D INIT G XIT
CR ;
S:LA'=32 A=32 S E=0 F EI=VI+1:1:CI D VER I E D VERMSG,INIT G RCOM
S GI=VI D BCREF I $D(@CREF)#10=0 W !,"? Incomplete" D INIT G RCOM
XIT ;
K CI,EI,GI,A,C,LA,QREF,CREF,GREF,KW,LSS,SS
;U 0:(RM:"") ;** M/11 V5 ;** M/11+ V1
;reset terminal protocol if necessary ;** STD
U 0:("EP":0:"EC":0)
Q
ESC ;
I LA=32!'LA W *7 S A=LA G RCS
S E=0 F EI=VI+1:1:CI-1 D VER I E D VERMSG,INIT G RCOM
S EI=CI D VER I 'E G ESC1
I E=1 D VERMSG,INIT G RCOM
W *7 S A=LA G RCS
ESC1 I CSS(VI)[CMD(VI) S X=$F(CSS(VI),CMD(VI)) W $E(CSS(VI),X,99)," " S CMD(VI)=CSS(VI)
S A=32 D BGREF G:$D(@GREF)#10=0 RCS S X=$P(CMD(VI)," ")_" ("_(@GREF)_")",X=$E(X,$F(X,CMD(VI)),255),CMD(VI)=CMD(VI)_X W $S($E(X)=" ":$E(X,2,255),1:X)," " G RCS
QM ;
S E=0 F EI=VI+1:1:CI-1 D VER I E D VERMSG,INIT G QMX
I LA=32,CI S EI=CI D VER I E D VERMSG,INIT G QMX
D BQREF I $D(@(QREF_",1)")) F I=1:1 G QMX:'$D(@(QREF_","_I_")")) W !?3,@(QREF_","_I_")")
K KW S KW=0,LSS=$S('LA:"",LA=32:"",1:CMD(CI)),SS=LSS S GI=VI D BCREF I VI,SS]"",$D(@CREF@(SS)) S KW=1,KW(1)=SS
F I=1:1 S SS=$O(@CREF@(SS)) Q:SS="" Q:$E(SS,0,$L(LSS))'=LSS S KW=KW+1,KW(KW)=SS
I VI,LSS="",$D(@CREF)#10 W " confirm with carriage return" G QMX:'KW W !," or, enter"
I KW W " one of the following:",! S X=2 F I=1:1:KW S L=$L(KW(I))+1 X $S(L+X>RM:"W ! S X=2",1:"") W ?X,KW(I) S X=L\10+1*10+X
E W " confirm with carriage return"
QMX K QREF,CREF,KW,LSS,SS,EI,GI,X,L S A=LA G RCOM
DEL S A=32 G RCS:'CI I LA=32 S:VI VI=VI-1 S A=$A($E(CMD(CI)),$L(CMD(CI))) W RO G RCS
S CMD(CI)=$E(CMD(CI),0,$L(CMD(CI))-1) I '$L(CMD(CI)) K CMD(CI) S:CI CI=CI-1,A=32 W RO G RCS
S A=$A($E(CMD(CI)),$L(CMD(CI))) W RO G RCS
CTRLU W *13,$J("",$X),$C(13) D INIT G RC1
CTRLC D INIT Q
INIT K CMD,CSS S (CI,VI,E,A)=0,CMD(CI)="" Q
VER G VER^ZKRT20A
BCREF S CREF="^ZKRX(""COMMAND""" F I=1:1:GI S CREF=CREF_","""_CSS(I)_""""
S CREF=CREF_")" Q
BQREF S QREF="^ZKRX(""?""" F I=1:1:VI S QREF=QREF_","""_CSS(I)_""""
Q
BGREF S GREF="^ZKRX(""GUIDE""" F I=1:1:VI S GREF=GREF_","""_CSS(I)_""""
S GREF=GREF_")" Q
VERMSG G VERMSG^ZKRT20A
ZKRT20A
ZKRT20A ;DGR NYSCVM ;15APR90 6:29PM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - command parser - overflow
VER S E=0 Q:CMD(EI)="" S GI=EI-1 D BCREF S A=$P(CMD(EI)," "),SS=$O(@CREF@("~")) I $E(SS)="~" D @("V"_$E(SS,2,9)) S:'E VI=EI,CSS(EI)=SS Q
I $D(@CREF@(A)) S VI=EI,CSS(EI)=A Q
S SS=A F I=1:1 S LSS=SS,SS=$O(@CREF@(SS)) Q:SS=""!($E(SS,1,$L(A))'=A)
I I=2 S VI=EI,CSS(EI)=LSS Q
S E=$S(I=1:1,1:2) Q
VERMSG W " ",$S(E=1:"? Does not match switch or keyword",E=2:"? Ambiguous",1:"") Q
VCTRL I A'?1"^".1UP!($A(A,2)>95!($A(A,2)<65)) W !,"? Enter a control character like '^A' or '^]'" S E=3
Q
VFSPEC I A'?1.8UN1"."1.3UN,A'?1"%".7UN1"."1.3UN W !,"? Illegal file spec" S E=3
Q
VFSPECW S FN=$P(A,"."),FT=$P(A,".",2) I $S($L(FN)>8:1,$L(FT)>3:1,FN="":1,FT="":1,FN'?.1"%".8UN.1"*":1,FT'?.3UN.1"*":1,1:0) W !,"? Illegal file spec" S E=3
K FN,FT,X Q
VPLEN I +A'=A!(A<10)!(A>94) W !,"? packet length from 10 thru 94" S E=3
Q
VQUOTE S A=$A(A) I $S(A<33:1,A>126:1,A>62&(A<96):1,1:0) W !,"? a character from '!' -> '>' or '`' -> '~'" S E=3
E S A=$C(A)
Q
VRFSPEC Q
VSEC I +A'=A!(A<0) W !,"? Illegal number of seconds" S E=3
Q
VTRY I +A\1'=A!(A<0) W !,"? retries, 0 or more" S E=3
Q
VTTY I $S(A'?1.N:0,A>7!(A<48):1,1:0) Q ;** CCSM PORTS 8-47
I '$D(^ZKRX("LINE",A)) W !,"? No such line" S E=3
Q
BCREF S CREF="^ZKRX(""COMMAND""" F I=1:1:GI S CREF=CREF_","""_CSS(I)_""""
S CREF=CREF_")" Q
ZKRTC
ZKRTC ;PKW ;15APR90 3:29PM
;Kermit - Set Terminal Characteristics
;** CCSM -- entire routine
U 0 S %DV=$S(TTY:TTY,1:$I) D CN G:POP XIT D GET
I $D(PAR) S %A=PAR D CP G:POP XIT
I $D(BAUD) S %A=BAUD D CS G:POP XIT
D SET C %DV O %DV U %DV,0
XIT ;
K %A,%I,%DV,%O,%PAR,%S,%P,%SPD,%WL
Q
GET S %S="110,19200,300,600,1200,2400,4800,9600"
F %I=0:1:7 S %S($P(%S,",",%I+1))=%I
S %P="N,O,E" F %I=0:1:2 S %P($P(%P,",",%I+1))=%I
Q
SET ;O %DV:("BK":1:"MR":0,"BR":%SPD,"PA":0,"WL":3,"SB":0,"XO":0,"TR":1:"EC":1)
I $D(BAUD) O %DV:("BR":%SPD:"BK":1:"EC":1:"SB":0:"MR":0:"XO":0:"TR":1)
I $D(PAR) O %DV:("PA":%PAR:"BK":1:"EC":1:"SB":0:"MR":0:"XO":0:"WL":%WL:"TR":1)
S POP=0
Q
CN ; check number of port
S POP=%DV<8!(%DV>47) Q ; allowable serial ports
CS ; check speed
S POP='$D(%S(%A)) S:'POP %SPD=%S(%A) Q
CP ; check parity, adjust word length
S POP='$D(%P(%A)) S:'POP %PAR=%P(%A),%WL=$S(%A="N":3,1:2) Q
ZKRUM
ZKRUM ;DGR NYSCVM ;22APR90 11:11AM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - utility parts - miscellanous
RPAR ;
S X=$A(RDAT)-32 I X<SPSIZ S SPSIZ=X
S RTO=$A(RDAT,2)-32,SPADN=$A(RDAT,3)-32,SPAD=$A(RDAT,4) S SPAD=$S(SPAD=63:127,1:SPAD-64)
S SEOL=$A(RDAT,5)-32 I SEOL<1 S SEOL=13
S RQA=$E(RDAT,6) S:RQA=" "!(RQA="") RQA="#"
S RQB=$E(RDAT,7) S:RQB=" "!(RQB="") RQB="&"
Q
GETFIL ;
K ^ZKRZ($J,"FILE") S E=0,FN=$P(FSPEC,"."),FT=$P(FSPEC,".",2)
S FNL=$L(FN),FTL=$L(FT),FNW=$E(FN,FNL)="*",FTW=$E(FT,FTL)="*"
I 'FNW S F1=FN D GF2 G GFX
S FN=$E(FN,0,FNL-1),F1=FN D:$S(F1="":0,'$D(^ZKR(F1)):0,1:1) GF2 F I=0:0 S F1=$O(^ZKR(F1)) Q:F1=""!($E(F1,0,FNL-1)'=FN) D GF2
G GFX
GF2 I 'FTW S F2=FT D:$D(^ZKR(F1,F2)) GFSET Q
S FT=$E(FT,0,FTL-1),F2=FT D:$S(F2="":0,'$D(^ZKR(F1,F2)):0,1:1) GFSET F I=0:0 S F2=$O(^ZKR(F1,F2)) Q:F2=""!($E(F2,0,FTL-1)'=FT) D GFSET
Q
GFSET S ^ZKRZ($J,"FILE",F1_"."_F2)="" Q
GFX I '$D(^ZKRZ($J,"FILE")) S E=1,FSPEC="File(s) not found for "_FSPEC
K FN,FT,FNW,FTW,FNL,FTL,F1,F2,I Q
INITPAR ;
S TTY=0,FDX=1,RPSIZ=94,SPSIZ=94,RTO=16,STO=5
S MAXTRY=3,DELAY=5,PAUSE=0
S (SSOH,RSOH)=1,SEOL=13,(SPADN,SPAD)=0
S SQA="#",SQB="&"
S CESC=25,PAR="N",BAUD=2400
S KAF=0,FW=0
S DEBUG=0
S (SPN,RPN)=0
S (BCNT,EFB)=0
Q
SHOW ;
W !!,"This is Kermit-M Version ",^ZKRX("VERSION")
W !,"Line assigned : ",$S(TTY:TTY,1:"local terminal")," ; we are ",$S(TTY:"local",1:"remote")
W !,"Connections are ",$S(FDX:"full",1:"half")," duplex, ",$S(PAR="N":"no",PAR="E":"even",PAR="O":"odd",PAR="M":"mark",PAR="S":"space")," parity, ",BAUD," baud"
W !,"We will receive packets of at most ",RPSIZ," characters"
W !,"We will send packets of at most ",SPSIZ," characters"
W !,"Maximum number of tries is ",MAXTRY," ; receiver timeout after ",RTO," seconds"
W !,"Delay ",DELAY," seconds before sending the first 'send intialize' packet"
W !,"Pause ",PAUSE," seconds before sending each packet"
W !,"We send CTRL/",$C(SSOH+64)," as a packet header, and expect CTRL/",$C(RSOH+64)
W !,"We send CTRL/",$C(SEOL+64)," at the end of each packet; we do not require a packet terminator"
W !,"Our 'escape' character for remote connection is CTRL/",$C(CESC+64)
W !,"Partially-received files are ",$S(KAF:"kept",1:"discarded")," if transmission is aborted"
W !,"The file-warning flag is ",$S(FW:"on",1:"off")
W !,"We quote control characters with ",SQA," when sending files"
W !,"We quote binary characters (above 127 decimal) with ",SQB," when sending files"
W ! Q
ZKRUP
ZKRUP ;DGR NYSCVM ;14APR90 10:33AM
;Copyright (c) 1984 New York State College of Veterinary Medicine
;Kermit - utility parts - packets
SPACK ;
U TTY I PAUSE H PAUSE
F I=1:1:SPADN W *SPAD
S CHKSUM=$L(SDAT)+67+SPN+$A(SPT) F I=1:1:$L(SDAT) S CHKSUM=CHKSUM+$A(SDAT,I)
S CHKSUM=CHKSUM\64#4+CHKSUM#64
S A=$C(SSOH)_$C($L(SDAT)+35)_$C(SPN+32)_SPT_SDAT_$C(CHKSUM+32)_$C(SEOL)
I TTY,DEBUG U 0 W !,"Sending packet #",SPN," of type ",SPT," ; Data: ^"_$C($A(A)+64)_$E(A,2,255) U TTY
W A Q
RPACK ;U 5 W "IN RPACK, RTO=",RTO,! U TTY
U TTY
S E=0 F I=0:0 R *A:RTO G RTO:'$T Q:A=RSOH
R *A:RTO G RTO:'$T,RPACK:A=RSOH S RPLEN=A-32,CHKSUM=A
R A#RPLEN:RTO G RTO:'$T
S RPN=$A(A)-32,RPT=$E(A,2),CHKSUM=CHKSUM+$A(A)+$A(A,2)
S RDAT=$E(A,3,RPLEN-1) F I=3:1:RPLEN-1 S CHKSUM=CHKSUM+$A(A,I)
S CHKSUM=CHKSUM\64#4+CHKSUM#64 I CHKSUM'=($A(A,RPLEN)-32) S E=1
I DEBUG,TTY U 0 W !,"Received packet # ",RPN," of type ",RPT," ; Data : ",RDAT," ; Checksum : ",$A(A,RPLEN)-32 W:E !,"** Checksum error - wanted ",CHKSUM U TTY
;U 5 W !,"Received packet # ",RPN," of type ",RPT," ; Data : ",RDAT," ; Checksum : ",$A(A,RPLEN)-32,! W:E "** Checksum error - wanted ",CHKSUM,! U TTY
Q
RTO ;U 5 W "IN RTO",! U TTY
S E=1 Q:'DEBUG!'TTY U 0 W !,"(receiver timed out)" U TTY Q
ZKRZ
ZKRZ ;JDG NYSCVM ; 20 APR 84 11:38
;Kermit Maintenance Utilties
CHRCHG ;Change a character throughout ^ZKRX (incl. subscripts)
S REF="^YGT2",L=0,CHR="~",NCHR="|",NRF="^ZKRX"
S L=0,REF(L)=REF
DOWN S L=L+1,R(L)=""
ACROSS S R(L)=$O(@REF(L-1)@(R(L))) I R(L)="" S L=L-1 Q
S REF(L)=REF_"("""_R(1)_""""
F I=2:1:L S REF(L)=REF(L)_","""_R(I)_""""
S REF(L)=REF(L)_")"
D DOWN:$D(@REF(L))\10
I $D(@REF(L))#10 D NSET W "." ;S @NREF=@REF(L) K @REF(L)
G ACROSS
NSET S NREF=NRF_"("
S I=1 D REPL S NREF=NREF_""""_NR_""""
F I=2:1:L D REPL S NREF=NREF_","""_NR_""""
S NREF=NREF_")"
Q
REPL S NR=R(I)
F II=1:0 Q:NR'[CHR S NR=$P(NR,CHR,1)_NCHR_$P(NR,CHR,2,999)
