R DATE F I=0:0 R ROU Q:ROU=""  ZL  ZS @ROU
24 MAR 84, 9:54
ZKR
ZKR ;DGR NYSCVM  ; 24 MAR 84  9:51
 ;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
 ;K  S FF="#",BS=$C(8),RO=$C(8,32,8),RM=79,SL=24 ;** STD
 ;** enable user interrupts, set up error trapper ;** STD
 S B="",C=",",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
 ;reset error handler ;** STD
 K (FF,BS,RO,RM,SL,B,C,S,TTY,FDX,RPSIZ,SPSIZ,RTO,STO,MAXTRY,DELAY,PAUSE,SSOH,RSOH,SEOL,SPADN,SPAD,SQA,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 $ZE="" U 0 W !,"** All done with Kermit-M" Q
ERR ;
 B 0 ;** M/11
 ;** 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
 ;** if user interrupt, renable them and return to start ;** STD
 W !,"** Fatal MUMPS error : ",$ZE B 1 ;** M/11
 ;** report a real error, enable user interrupts ;** STD
 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
 ;** turn off echo, set line parameters ;** STD
 Q
TTYOFF ;
 U TTY:("":"") U 0 ;** M/11 V5
 ;** 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 ; 24 MAR 84  9:52
 ;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
 ;** 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
 E  U 0:("":"I") U TTY:("":"IS":$C(10)) ;** M/11 V5
 ;** keyboard reads: image mode (no special chars.) ;** STD
 ;** port reads : image mode, also terminate on LF ;** STD
OUT F I=0:0 U 0 R *A:1 Q:'$T  G:A=CESC CESC U TTY W *A
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
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
 ;U 0:(0:0) U TTY:(0:0) ;** M/11 V4
 ;** turn on both echoes ;** STD
 U 0 W *-1 U TTY W *-1 ;** M/11 V5
 ;** 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:RM6 W "******"
 Q

ZKRM
ZKRM ;DGR NYSCVM  ; 03 MAR 84  3:46 PM
 ;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" 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) U 0 C:$I'=IO IO
 K ^ZKRZ($J)
 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 ",$ZD($H,2)," 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:X3600-12,1:X3600),":" S XX=X#360060_"" 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
 ;** disable user interrupts ;** STD
 K ^ZKRZ($J)
 B 1 ;** M/11
 ;** enable user interrupts ;** STD
 G START:$ZE["<INRPT>" W !,"** Fatal MUMPS error : ",$ZE Q  ;** M/11
 ;** restart on user interrupt, otherwise report error and quit ;** STD

ZKRMF
ZKRMF ;DGR NYSCVM ; 03 MAR 84  3:47 PM
 ;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 Q
 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:"rename",1:"copi"),"ed::",! D GFSPEC Q:E  I FSPEC="*.*" W *7,!!,"?? can't specify all files" G RC
 D GETFIL I E W FSPEC Q
 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 ; 03 MAR 84  3:47 PM
 ;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
 B 0 S OZE=$ZE,$ZE="FERRW^ZKRMFIO" ;** M/11
 ;** disable interrupts, set up error trapper ;** STD
 D WLOCK
 S ^ZKR(F1,F2)="0"_FQA_B_$H
 B 1 ;** M/11
 ;** 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
 ;** disable user iterrupts ;** STD
 I CL]"" S ^ZKR(F1,F2,F3)=CL,CL="",BCNT=BCNT+CC,CC=1,F3=F3+1
 S $P(^ZKR(F1,F2),B,4,5)=$H_B_BCNT
 D ULOCK
 S $ZE=OZE K OZE B 1 ;** M/11
 ;** restore previous error trapper, enable interrupts ;** STD
 K F1,F2,F3,BCNT,CL,CC,FQA Q
FERRW ;
 B 0 I $ZE'["<INRPT>" G @OZE ;** M/11
 ;** disable interrupts, report real errors ;** STD
 W *7,!!,"Interrupted while writing to ",FILE," -- this file is not complete" D FCLOSEW H 2 G START^ZKRM
 Q
FOPENR ;
 S E=0 I '$D(FILE) S E=1 Q
 S F1=$P(FILE,"."),F2=$P(FILE,".",2,9) I F1=""!(F2="") S E=1 K F1,F2 Q
 S F3=$O(^ZKR(F1,F2,0)) I F3="" S E=1 K F1,F2,F3 Q
 D RLOCK
 S FQA=$P(^ZKR(F1,F2),B,2),CL=^ZKR(F1,F2,F3),CC=1
 Q
FCLOSER ;
 D ULOCK
 K F1,F2,F3,CL,CC,FQA Q
FKILL ;
 S E=0 I '$D(FILE) S E=1 Q
 S X1=$P(FILE,"."),X2=$P(FILE,".",2,9) I $S(X1="":1,X2="":1,1:0) S E=1 K X1,X2 Q
 K ^ZKR(X1,X2),X1,X2
 Q
RLOCK L ^ZKR(FILE,$J) Q
WLOCK L ^ZKR(FILE) Q
ULOCK L  Q

ZKRMI
ZKRMI ;DGR NYSCVM ; 03 MAR 84  3:47 PM
 ;Copyright (c) 1984 New York State College of Veterinary Medicine
 ;Kermit <--> MUMPS interface - Input Kermit -> MUMPS
IOPT ;
 W !!,"Input options (Kermit-M file system --> MUMPS data structures)",! F I=1:1:5 W !?5,I,") ",$P("Sequential file in;Routine in (.MMP files);Routine in (.ROU file);Global in;Sequential global 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<6) S HREF="""IOPT"","""_$P("SFI;RIM;RIR;GI;SGI",S,+A)_"""" D HELP^ZKRM G IOPT
 I $S(A'?1N:1,A<1:1,A>5:1,1:0) W *7," ? no such option" G IO1
 W @FF D @$P("SFI;RIM;RIR;GI;SGI",S,A) G IOPT
SFI ;
 W !!,"Input Kermit-M files to a sequential device",! D GFSPEC Q:E  D GETFIL I E W FSPEC Q
SFI1 W !,"Write to" D ^%IS I POP Q  ;** M/11
 I "TRMSDPMT"'[(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
 S TRM=IOT="TRM",PTR=$S('TRM:0,1:IOST?1"P".E)
 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 $I'=IO W !,"** Done for this set of files" C IO ;** M/11
 ;** 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
 ;** if not listing on local screen, show progress ;** STD
 F I=0:0 D KOUT W:PTR&($Y+3>IOSL) @IOF W LIN,! I F3="" Q
 U 0 I $I'=IO W "done" U IO ;** M/11
 ;** if not listing on local screen, show progress ;** STD
 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
 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:Y3600-12,1:Y3600)_":" S YY=Y#360060_"" 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
 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  ; 03 MAR 84  3:47 PM
 ;Copyright (c) 1984 New York State College of Veterinary Medicine
 ;Kermit <--> MUMPS interface - Input Kermit -> MUMPS - routines
RIM ;
 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 Q
 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=""  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
 ;** load into routine buffer and save on disk ;** STD
 S ^UTILITY("ROU",ROU)="" ;** M/11
 ;** 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("NNoNOno"[(B_A_B):1,"YYESyesYes"[(B_A_B):0,1:2) I E=2 W *7," ??" G RCHECK ;** M/11
 ;** 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  ; 03 MAR 84  3:47 PM
 ;Copyright (c) 1984 New York State College of Veterinary Medicine
 ;Kermit <--> MUMPS interface - Output MUMPS-->Kermit
OOPT ;
 W !!,"Output options (MUMPS data structures --> Kermit-M file system)",! F I=1:1:5 W !?5,I,") ",$P("Sequential file out;Routine out (.MMP files);Routine out (.ROU file);Global out;Sequential global 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<6) 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>5:1,1:0) W *7," ? no such option" G OO1
 W @FF D @$P("SFO;ROM;ROR;GO;SGO",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
 I "TRMSDPMT"'[(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
 S TRM=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
 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'=$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="MT" S E=$S(LIN=$C(26):1,$ZA16384#2:1,1:0) Q
 S E=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 DEF10 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 ; 03 MAR 84  3:47 PM
 ;Copyright (c) 1984 New York State College of Veterinary Medicine
 ;Kermit <--> MUMPS interface - Output MUMPS-->Kermit - routines
ROM ;
 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
 ;** 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
 ;** 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 ; 03 MAR 84  3:47 PM
 ;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=Y3600_":" S YY=Y#360060 S:$L(YY)=1 YY="0"_YY S TIM=TIM_YY K Y,YY
 S DATIM=$ZD(+DATIM,2) ;** M/11 V5
 ;** 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 R A:120 S E=$S(A="":0,"<#@"[$E(A):1,1:0)
 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  ; 03 MAR 84  3:47 PM
 ;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
 ;** 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 S A=$ZU(A),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

ZKRR
ZKRR ;DGR NYSCVM ; 03 MAR 84  3:47 PM
 ;Copyright (c) 1984 New York State College of Veterinary Medicine
 ;Kermit - receive files
 S (TRY,OLDTRY,SPN)=0
R ;
 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 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_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 ; 03 MAR 84  3:47 PM
 ;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 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) S F3=$O(^ZKR(F1,F2,0)) G NXTFIL:F3="" S CL=^(F3),LL=$L(CL),CC=1,FQA=$P(^ZKR(F1,F2),B,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
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
 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
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  ; 03 MAR 84  3:47 PM
 ;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)'<4&(CMD(3)'>19):1,CMD(3)'<64&(CMD(3)'>143):1,1:0) S A=CMD(3) G SLIN1 ;** M/11 or DSM-11
 I '$D(^ZKRX("LINE",CMD(3))) W !,"? No such line" Q
 S A=+^(CMD(3))
SLIN1 O A:(0:""):0 E  W !,"? Can't get that line now" Q  ;** M/11 V5
 ;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 M/11 V5" Q  ;** M/11 V5
 I $E(CMD(3))="S" W !,"? Use NONE in M/11 V5" Q  ;** M/11 V5
 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),SQB=$A(CMD(4)),SQB=$E("000",0,3-$L(SQB))_SQB Q
SS1STA S SSOH=$A(CMD(4),2)-64 Q
SS1TIM S STO=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 ; 03 MAR 84  3:47 PM
 ;Copyright (c) 1984 New York State College of Veterinary Medicine
 ;Kermit - command parser
 U 0:(RM:"":$C(27)) ;** M/11 V5
 ;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
 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
 ;reset terminal protocol if necessary ;** STD
 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=L10+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 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 ; 03 MAR 84  3:47 PM
 ;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 +A1'=A!(A<0) W !,"? retries, 0 or more" S E=3
 Q
VTTY I $S(A'?1.N:0,A'<4&(A'>19):1,A'<64&(A'>143):1,1:0) Q  ;** M/11,DSM-11
 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 ;DGR NYSCVM ; 03 MAR 84  3:47 PM
 ;Copyright (c) 1984 New York State College of Veterinary Medicine
 ;Kermit - Set Terminal Characteristics (DH11 or DZ11).
 ;** M/11 V5 -- 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
 I $D(STC) S %A=STC D CH G:POP XIT
 I $D(BIN) S %A=BIN D CB G:POP XIT
 D SET C %DV O %DV U %DV,0
XIT K %A,%DDBASE,%NOECHO,%I,%DV,%O,%PAR,%PAREN,%S,%LPAR,%CONDIO,%SPD,%DZ,%X,%STSIZ,%STALL,%STOP,%CHRLEN,%BIN
 Q
GET I %DZ S %S="50,75,110,134.5,150,300,600,1200,1800,2000,2400,3600,4800,7200,9600,19200" ;** DZ
 E  S %S="0,50,75,110,134.5,150,200,300,600,1200,1800,2400,4800,9600,Ext A,Ext B" ;** DH
 F %I=1:1:16 S %S($P(%S,",",%I))=%I-1
 S %DDBASE=%DV-64*70+$V($V(44)+20)
 S %LPAR=$V(%DDBASE+6)
 I %DZ S %SPD=%LPAR256#16,%PAR=%LPAR128#2,%CHRLEN=%LPAR8#4,%PAREN=%LPAR64#2 ;** DZ
 E  S %SPD=%LPAR64#16,%PAR=%LPAR32#2,%CHRLEN=%LPAR#4,%PAREN=%LPAR16#2 ;** DH
 S %CONDIO=$V(%DDBASE+20),%BIN=%CONDIO4#2,%NOECHO=%CONDIO2#2
 S %STSIZ=$V(%DDBASE+18),%STALL=%STSIZ256
 Q
SET S %STOP=0 ;1 stop bit
 I %DZ S %LPAR=%LPAR4096*4096+(%SPD*256)+(%PAR*128)+(%PAREN*64)+(%STOP*32)+(%CHRLEN*8)+(%LPAR#8)
 E  S %LPAR=%SPD*1024+(%SPD*64)+(%PAR*32)+(%PAREN*16)+(%STOP*4)+%CHRLEN ;** DH
 S %CONDIO=%CONDIO8*8+(%NOECHO*2)+(%BIN*4)+(%CONDIO#2)
 S %STSIZ=%STALL*256+(%STSIZ#256)
 V %DDBASE+6::%LPAR,%DDBASE+20::%CONDIO,%DDBASE+18::%STSIZ Q
 Q
CN S POP=%DV<64!(%DV>111) S:'POP %DZ=%DV>95 Q
CS S POP='$D(%S(%A)) S:'POP %SPD=%S(%A) Q
CP S POP='(%A?1U&("NEO"[%A)) S:'POP %PAREN="EO"[%A,%CHRLEN=$S(%A="N":3,1:2),%PAR="NE"'[%A Q
CH S POP='(%A?.N&(%A<64)) S:'POP %STALL=%A Q
CB S POP='(%A?1N&("01"[%A)) S:'POP %BIN=%A Q

ZKRUM
ZKRUM ;DGR NYSCVM  ; 03 MAR 84  3:47 PM
 ;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="#"
 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=64,SPSIZ=94,RTO=16,STO=0
 S MAXTRY=8,DELAY=5,PAUSE=0
 S (SSOH,RSOH)=1,SEOL=13,(SPADN,SPAD)=0
 S SQA="#"
 S CESC=25,PAR="N",BAUD=1200
 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 ! Q

ZKRUP
ZKRUP ;DGR NYSCVM  ; 03 MAR 84  3:47 PM
 ;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=CHKSUM64#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 : ",A U TTY
 W A Q
RPACK ;
 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=CHKSUM64#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
 Q
RTO S E=1 Q:'DEBUG!'TTY  U 0 W !,"(receiver timed out)" U TTY Q