home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / mumps / mpker.rou < prev    next >
Text File  |  2020-01-01  |  43KB  |  1,013 lines
  1. R DATE F I=0:0 R ROU Q:ROU=""  ZL  ZS @ROU
  2. 24 MAR 84, 9:54
  3. ZKR
  4. ZKR ;DGR NYSCVM  ; 24 MAR 84  9:51
  5.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  6.  ;Kermit - executive
  7. SETUP ;
  8.  B 1 K  S $ZE="ERR^ZKR" D CURRENT^%IS U 0:(RM:"") ;** M/11 V5
  9.  ;K  S FF="#",BS=$C(8),RO=$C(8,32,8),RM=79,SL=24 ;** STD
  10.  ;** enable user interrupts, set up error trapper ;** STD
  11.  S B="",C=",",S=";"
  12.  D INITPAR
  13.  W @FF,!!,"Welcome to Kermit-M version ",^ZKRX("VERSION"),"; enter HELP for instructions",!!
  14. START ;
  15.  D ^ZKRT20 G XIT:E!'VI,@(CSS(1))
  16. RESTART ;
  17.  S $ZE="ERR^ZKR" ;** M/11 V5
  18.  ;reset error handler ;** STD
  19.  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)
  20.  W @FF G START
  21. BYE ;
  22.  I 'TTY W !,"? No remote Kermit to log out" G START
  23.  S SPT="G",SDAT="L",SPN=0 D SPACK,RACK E  U 0 W !,"Error - BYE command not effected" G START
  24.  U 0 W " Remote Kermit has been logged out" G XIT
  25. CONNECT ;
  26.  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
  27.  D ^ZKRC G START
  28. FINISH ;
  29.  I 'TTY W !,"? No remote Kermit server to shut down" G START
  30.  S SPT="G",SDAT="F",SPN=0 D SPACK,RACK E  U 0 W !,"Error - FINISH command not effected" G START
  31.  U 0 W " Remote Kermit server has been shut down" G START
  32. EXIT G XIT
  33. GET ;
  34.  I 'TTY W !,"? No remote Kermit from which to GET files" G START
  35.  S SDAT=CMD(2),SPT="R",SPN=0 D SPACK G RECEIVE
  36. HELP ;
  37.  S GREF="^ZKRX(""HELP""" F I=2:1:VI S GREF=GREF_","""_CSS(I)_""""
  38.  S GREF=GREF_",0)" I '$D(@GREF) W !,"? Kermit: no help on that topic" G HX
  39.  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
  40. HX K GREF,I W ! G START
  41. MUMPS G START^ZKRM
  42. QUIT G XIT
  43. RECEIVE ;
  44.  U 0 W !,"Starting RECEIVE command...",! U TTY
  45.  D TTYON I 'E D ^ZKRR,TTYOFF
  46.  I TTY U 0 W !,"** Done with RECEIVE command"
  47.  G START
  48. RESET ;
  49.  G SETUP
  50. SEND ;
  51.  S FSPEC=CMD(2) D GETFIL I E W !,"? ",FSPEC K FSPEC G START
  52.  U 0 W !,"Starting SEND command...",! U TTY
  53.  ;** turn off echo ;** STD
  54.  D TTYON I 'E H DELAY D ^ZKRS,TTYOFF
  55.  I TTY U 0 W !,"** Done with SEND command"
  56.  G START
  57. SERVER ;
  58.  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",!
  59.  D TTYON G START:E,^ZKRSRV
  60. SET ;
  61.  D ^ZKRSET G START
  62. SHOW ;
  63.  D SHOW^ZKRUM G START
  64. STATISTI ;
  65.  W !!,"Most recent transmission: " W $S('EFB:"** none yet",EFB<0:"** aborted",1:BCNT_" bytes, "_(EFB/10)_" cps thruput"),!
  66.  G START
  67. XIT C:TTY TTY K  S $ZE="" U 0 W !,"** All done with Kermit-M" Q
  68. ERR ;
  69.  B 0 ;** M/11
  70.  ;** disable user interrupts ;** STD
  71.  D TTYOFF
  72.  I 'KAF,$D(F1),$D(F2),F1]"",F2]"",$D(^ZKR(F1,F2)),$P(^(F2),"",3)="" K ^(F2)
  73.  L
  74.  I $ZE["<INRPT>" U 0 W !,"(Interrupt received - restarting)" S $ZE="ERR^ZKR" B 1 G START ;** M/11
  75.  ;** if user interrupt, renable them and return to start ;** STD
  76.  W !,"** Fatal MUMPS error : ",$ZE B 1 ;** M/11
  77.  ;** report a real error, enable user interrupts ;** STD
  78.  Q
  79. GETFIL G GETFIL^ZKRUM
  80. INITPAR G INITPAR^ZKRUM
  81. TTYON ;
  82.  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
  83.  ;** turn off echo, set line parameters ;** STD
  84.  Q
  85. TTYOFF ;
  86.  U TTY:("":"") U 0 ;** M/11 V5
  87.  ;** turn echo on, direct I/O to local terminal ;** STD
  88.  Q
  89. SPACK G SPACK^ZKRUP
  90. RACK D RPACK^ZKRUP I $S(E:0,RPT'="Y":0,SPN'=RPN:0,1:1)
  91.  Q
  92.  
  93. ZKRC
  94. ZKRC ;DGR NYSCVM ; 24 MAR 84  9:52
  95.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  96.  ;Kermit - talk-thru to another machine
  97.  I 'TTY W !,"? No line specified" Q
  98.  O TTY::0 E  W !,"? Can't get that line now" Q  ;** M/11
  99.  ;** OWN the line, timeout if it's unavailable ;** STD
  100.  D ^ZKRTC I POP W !,"? Illegal line parameters specified" Q  ;** M/11 V5
  101.  ;** Set speed, parity, 7 or 8-bit data ;** STD
  102.  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",!!
  103.  I FDX U 0:("":"IS") U TTY:("":"IS":$C(10)) ;** M/11 V5
  104.  E  U 0:("":"I") U TTY:("":"IS":$C(10)) ;** M/11 V5
  105.  ;** keyboard reads: image mode (no special chars.) ;** STD
  106.  ;** port reads : image mode, also terminate on LF ;** STD
  107. OUT F I=0:0 U 0 R *A:1 Q:'$T  G:A=CESC CESC U TTY W *A
  108. 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
  109. CESC ;
  110.  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")
  111. DONE U 0 W !!,"End of connection; you still own the line" D AST W !
  112.  U 0:("":"") U TTY:("":"") ;** M/11 V5
  113.  ;U 0:(0:0) U TTY:(0:0) ;** M/11 V4
  114.  ;** turn on both echoes ;** STD
  115.  U 0 W *-1 U TTY W *-1 ;** M/11 V5
  116.  ;** discard any type-ahead ;** STD
  117.  U 0 Q
  118. SHOW D AST W !,"You're connected to TTY number ",TTY," ; ",$S(FDX:"full",1:"half")," duplex ; baud rate ",BAUD,!,! D AST W !
  119.  G OUT
  120. CHELP U 0 D AST W !,"The following characters can follow the link 'escape':",!
  121.  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",!
  122.  D AST W ! G OUT
  123. SESC U TTY W *A G OUT
  124. EESC U 0 W !,"Illegal character following link 'escape' - ignored",! G OUT
  125. AST W ! F I=1:1:RM6 W "******"
  126.  Q
  127.  
  128. ZKRM
  129. ZKRM ;DGR NYSCVM  ; 03 MAR 84  3:46 PM
  130.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  131.  ;Kermit <--> MUMPS interface - main options
  132.  W !,"Must enter via the MUMPS command in Kermit-M" Q
  133. START ;
  134.  S $ZE="ERR^ZKRM" K ^ZKRZ($J) W @FF
  135.  S OPTS=";Help;Directory;Erase;Rename;Copy;Input;Output;Xit"
  136. MOPT ;
  137.  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 "; "
  138.  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)
  139.  S F=$F(OPTS,S_A) I F<2 W *7," No such option" G MOPT
  140.  W @FF G @("MOPT"_$E(A))
  141. MOPTH S HREF="""MOPT""" D HELP G MOPT
  142. MOPTD D DIR G MOPT
  143. MOPTE D ERA^ZKRMF G MOPT
  144. MOPTR D REN^ZKRMF G MOPT
  145. MOPTC D COP^ZKRMF G MOPT
  146. MOPTO D ^ZKRMO G MOPT
  147. MOPTI D ^ZKRMI G MOPT
  148. MOPTX ;
  149. XIT ;
  150.  I $D(IO) U 0 C:$I'=IO IO
  151.  K ^ZKRZ($J)
  152.  G RESTART^ZKR
  153. DIR ;
  154.  W !,"DIRECTORY of files",! D GFSPEC I E Q
  155.  D GETFIL S FILE=$O(^ZKRZ($J,"FILE","")) I FILE="" W *7," ** no files match this specification" K FILE Q
  156.  W !!,"** Directory of files ",FSPEC," on ",$ZD($H,2)," at " D TIM W !!,"name",?15,"quote",?25,"created",?50,"# of bytes",!
  157.  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)
  158.  K FILE,DATIM,F1,F2,X Q
  159. TIM ;
  160.  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
  161.  Q
  162. DATIM G DATIM^ZKRMU
  163. GETFIL D GETFIL^ZKRMU Q
  164. GFSPEC D GFSPEC^ZKRMU Q
  165. GFILE D GFILE^ZKRMU Q
  166. HELP S HREF="^ZKRX(""MHELP"","_HREF_")" I '$D(@HREF) W *7," Sorry, no help on that topic" Q
  167.  W @FF S SUB=0 F I=0:0 S SUB=$O(@HREF@(SUB)) Q:SUB'?1.N  W !,^(SUB)
  168.  W !!,"Press <RETURN> when done reading..." D READ W @FF
  169.  Q
  170. READ R A:120 S E=$S(A="":0,"<#@^>"[$E(A):1,1:0)
  171.  W:E " Can't do that here." Q
  172. ERR ;
  173.  B 0 ;** M/11
  174.  ;** disable user interrupts ;** STD
  175.  K ^ZKRZ($J)
  176.  B 1 ;** M/11
  177.  ;** enable user interrupts ;** STD
  178.  G START:$ZE["<INRPT>" W !,"** Fatal MUMPS error : ",$ZE Q  ;** M/11
  179.  ;** restart on user interrupt, otherwise report error and quit ;** STD
  180.  
  181. ZKRMF
  182. ZKRMF ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  183.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  184.  ;Kermit <--> MUMPS interface -- process file-oriented options
  185. ERA ;
  186.  W !,"ERASE files",! D GFSPEC Q:E  D GETFIL I E W FSPEC Q
  187.  W *7,!,"** Erase ",FSPEC,", are you sure (Y or N)? N ==> " D READ I A'="Y" W " [no change]" Q
  188.  W !!,"Deleting files that match ",FSPEC,"..." D KILL
  189.  W !!,"** done"
  190.  Q
  191. REN ;
  192.  S KILL=1 G RC
  193. COP ;
  194.  S KILL=0 G RC
  195. RC ;
  196.  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
  197.  D GETFIL I E W FSPEC Q
  198.  S OFN=$P(FSPEC,"."),OFT=$P(FSPEC,".",2),OFNW=$F(OFN,"*")-2,OFTW=$F(OFT,"*")-2
  199.  W !!,$S(KILL:"RENAME",1:"COPY")," ",FSPEC," to what files?",! D GFSPEC I E Q
  200.  S NFN=$P(FSPEC,"."),NFT=$P(FSPEC,".",2),NFNW=$F(NFN,"*")-2,NFTW=$F(NFT,"*")-2
  201.  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
  202.  I $S(OFN'=NFN:0,OFT'=NFT:0,1:1) W *7,!!,"** ?? -- old & new filespecs must be different" G RC
  203.  W !!,"Moving files..." S FILE="" F I=0:1 S FILE=$O(^ZKRZ($J,"FILE",FILE)) Q:FILE=""  D MOVE
  204.  I KILL W !!,"Deleting old files..." D KILL
  205.  W !!,"** Done"
  206.  Q
  207. 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_"..."
  208.  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
  209.  I $D(^ZKR(NF1,NF2)) W *7,!,NF1,".",NF2," is already on file.  Overwrite? N => " D READ I A'="Y" W " [no change]" Q
  210.  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
  211.  W " ** Done"
  212.  Q
  213. 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
  214.  Q
  215. GETFIL D GETFIL^ZKRMU Q
  216. GFSPEC D GFSPEC^ZKRMU Q
  217. READ R A:120 S E=$S(A="":0,"<#@"[$E(A):1,1:0)
  218.  W:E " Can't do that here." Q
  219.  
  220. ZKRMFIO
  221. ZKRMFIO ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  222.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  223.  ;Kermit <--> MUMPS interface -  file i/o utilities
  224. KIN ;
  225.  G KIC:LIN'?.ANP,KIQ:LIN[FQA S C=LIN D KINL S CL=CL_FQA_"M"_FQA_"J",CC=CC+4 Q
  226. 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
  227.  S C=$E(LIN,1,F-2),LIN=$E(LIN,F,255) D KINL S CL=CL_FQA_FQA,CC=CC+2 G KIQ
  228. KINL S X=251-CC I $L(C)<X S CL=CL_C,CC=CC+$L(C) Q
  229.  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
  230. 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
  231.  S C=FQA_"M" D KINC1 S C=FQA_"J" D KINC1
  232.  Q
  233. KINC1 I CC>250 S ^ZKR(F1,F2,F3)=CL,CL="",BCNT=BCNT+CC,CC=1,F3=F3+1
  234.  S CL=CL_C,CC=CC+$L(C)
  235.  Q
  236. KOUT ;
  237.  S LIN=""
  238. KOS Q:F3=""  I CL="" D KOG I F3="" Q
  239.  S F=$F(CL,FQA) I 'F S LIN=LIN_CL,CL="" G KOS
  240.  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
  241.  S LIN=LIN_$S(X=FQA:FQA,X?1U:$C($A(X)-64),X="?":$C(127),1:"") G KOS
  242. KOG S F3=$O(^ZKR(F1,F2,F3)) Q:F3=""  S CL=^(F3) Q
  243. FOPENW ;
  244.  S E=0 I '$D(FILE) S E=1 Q
  245.  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
  246.  S FQA=$S($D(FQA):FQA,1:"#"),CL="",(F3,CC)=1,BCNT=0
  247.  B 0 S OZE=$ZE,$ZE="FERRW^ZKRMFIO" ;** M/11
  248.  ;** disable interrupts, set up error trapper ;** STD
  249.  D WLOCK
  250.  S ^ZKR(F1,F2)="0"_FQA_B_$H
  251.  B 1 ;** M/11
  252.  ;** enable interrupts ;** STD
  253.  Q
  254. FCLOSEW ;
  255.  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
  256.  B 0 ;** M/11
  257.  ;** disable user iterrupts ;** STD
  258.  I CL]"" S ^ZKR(F1,F2,F3)=CL,CL="",BCNT=BCNT+CC,CC=1,F3=F3+1
  259.  S $P(^ZKR(F1,F2),B,4,5)=$H_B_BCNT
  260.  D ULOCK
  261.  S $ZE=OZE K OZE B 1 ;** M/11
  262.  ;** restore previous error trapper, enable interrupts ;** STD
  263.  K F1,F2,F3,BCNT,CL,CC,FQA Q
  264. FERRW ;
  265.  B 0 I $ZE'["<INRPT>" G @OZE ;** M/11
  266.  ;** disable interrupts, report real errors ;** STD
  267.  W *7,!!,"Interrupted while writing to ",FILE," -- this file is not complete" D FCLOSEW H 2 G START^ZKRM
  268.  Q
  269. FOPENR ;
  270.  S E=0 I '$D(FILE) S E=1 Q
  271.  S F1=$P(FILE,"."),F2=$P(FILE,".",2,9) I F1=""!(F2="") S E=1 K F1,F2 Q
  272.  S F3=$O(^ZKR(F1,F2,0)) I F3="" S E=1 K F1,F2,F3 Q
  273.  D RLOCK
  274.  S FQA=$P(^ZKR(F1,F2),B,2),CL=^ZKR(F1,F2,F3),CC=1
  275.  Q
  276. FCLOSER ;
  277.  D ULOCK
  278.  K F1,F2,F3,CL,CC,FQA Q
  279. FKILL ;
  280.  S E=0 I '$D(FILE) S E=1 Q
  281.  S X1=$P(FILE,"."),X2=$P(FILE,".",2,9) I $S(X1="":1,X2="":1,1:0) S E=1 K X1,X2 Q
  282.  K ^ZKR(X1,X2),X1,X2
  283.  Q
  284. RLOCK L ^ZKR(FILE,$J) Q
  285. WLOCK L ^ZKR(FILE) Q
  286. ULOCK L  Q
  287.  
  288. ZKRMI
  289. ZKRMI ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  290.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  291.  ;Kermit <--> MUMPS interface - Input Kermit -> MUMPS
  292. IOPT ;
  293.  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)
  294. 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
  295.  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
  296.  I $S(A'?1N:1,A<1:1,A>5:1,1:0) W *7," ? no such option" G IO1
  297.  W @FF D @$P("SFI;RIM;RIR;GI;SGI",S,A) G IOPT
  298. SFI ;
  299.  W !!,"Input Kermit-M files to a sequential device",! D GFSPEC Q:E  D GETFIL I E W FSPEC Q
  300. SFI1 W !,"Write to" D ^%IS I POP Q  ;** M/11
  301.  I "TRMSDPMT"'[(B_IOT_B) W *7," I can't deal with that type of device" G SFI1
  302.  ;set IO as $I on which to list, IOT as device type, then OPEN it with correct parameters ;** STD
  303.  ;if IOT="TRM" also set up IOST (subtype), IOF (form feed), IOSL (page length) ;** STD
  304.  S TRM=IOT="TRM",PTR=$S('TRM:0,1:IOST?1"P".E)
  305.  U IO S FILE="" F J=0:1 S FILE=$O(^ZKRZ($J,"FILE",FILE)) Q:FILE=""  D FOPENR D:'E SFIL D FCLOSER
  306.  I PTR W @IOF
  307.  I 'TRM U IO W $C(26),! I IOT="MT" W *3
  308.  U 0 I $I'=IO W !,"** Done for this set of files" C IO ;** M/11
  309.  ;** if not listing on local screen, message & close device ;** STD
  310.  K TRM,PTR,IO,IOT,IOST,IOF,IOSL,IOPAR
  311.  Q
  312. 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",!!
  313.  U 0 I $I'=IO W !,"starting ",FILE,"..." U IO ;** M/11
  314.  ;** if not listing on local screen, show progress ;** STD
  315.  F I=0:0 D KOUT W:PTR&($Y+3>IOSL) @IOF W LIN,! I F3="" Q
  316.  U 0 I $I'=IO W "done" U IO ;** M/11
  317.  ;** if not listing on local screen, show progress ;** STD
  318.  Q
  319. RIM G RIM^ZKRMIR
  320. RIR G RIR^ZKRMIR
  321. GI ;
  322.  W !!,"Global input from a Kermit-M file",!
  323. GI1 D GFILE Q:E  D FOPENR I E W *7," [file undefined or empty]" G GI1
  324.  S GNAM="" W !,"Starting global input..."
  325. 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
  326.  S REF=LIN I $P(REF,"(")'=GNAM S GNAM=$P(REF,"(") W !,GNAM,"..."
  327.  I F3="" W *7,!,"ERROR - last reference had no data!" G GIFX
  328.  D KOUT S @REF=LIN G:F3]"" GIF W !,"** done" D FCLOSER
  329. GIFX W !,"** All done" K FILE,REF,GNAM
  330.  Q
  331. SGI ;
  332.  W !!,"Sequential global input from a Kermit-M file",!
  333. SGI1 D GFILE Q:E  D FOPENR I E W *7," [file undefined or empty]" G SGI1
  334. 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
  335.  W !,"Starting input..."
  336.  F GI=1:1 D KOUT S @GRF(1)@(GI)=LIN W:GI#100=0 "." I F3="" D FCLOSER W "** done" Q
  337.  K GI Q
  338. DATIM ;
  339.  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
  340.  S DATIM=$ZD(+DATIM,2)_", "_TIM K TIM
  341.  Q
  342. KOUT G KOUT^ZKRMFIO
  343. FOPENR G FOPENR^ZKRMFIO
  344. FCLOSER G FCLOSER^ZKRMFIO
  345. GFILE G GFILE^ZKRMU
  346. GETFIL G GETFIL^ZKRMU
  347. GFSPEC G GFSPEC^ZKRMU
  348. GRT G GRT^ZKRMU
  349. READ R A:120 S E=$S(A="":0,"<#@^>"[$E(A):1,1:0)
  350.  W:E " Can't do that here." Q
  351.  
  352. ZKRMIR
  353. ZKRMIR ;DGR NYSCVM  ; 03 MAR 84  3:47 PM
  354.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  355.  ;Kermit <--> MUMPS interface - Input Kermit -> MUMPS - routines
  356. RIM ;
  357.  W !!,"Routine input from .MMP files",! D GFSPEC Q:E  I $P(FSPEC,".",2)'="MMP" W *7," MUST have filetype .MMP" G RIM
  358.  D GETFIL I E W FSPEC Q
  359.  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
  360.  K ^ZKRZ($J,"ROU"),RI,FILE W !,"** done" Q
  361. RIR ;
  362.  W !!,"Routine input from a .ROU file",! D GFILE Q:E  I $P(FILE,".",2)'="ROU" W *7," MUST have filetype .ROU" G RIR
  363.  D FOPENR I E W *7," [file undefined or empty]" G RIR
  364.  D KOUT W !,"File description: ",LIN D KOUT W !,"Written on: ",LIN
  365.  F I=0:0 D KOUT Q:LIN=""  S ROU=LIN D RCHECK D:E RIRSK D:'E RFILE
  366.  D FCLOSER K ^ZKRZ($J,"ROU"),RI W !,"** done"
  367.  Q
  368. RIRSK W " skipping ",ROU,"..." F I=0:0 D KOUT I LIN="" Q
  369.  Q
  370. RFILE ;
  371.  W !,"now filing routine ",ROU,"..." K ^ZKRZ($J,"ROU") F RI=1:1 D KOUT Q:LIN=""  S ^ZKRZ($J,"ROU",RI)=LIN
  372.  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
  373.  ;** load into routine buffer and save on disk ;** STD
  374.  S ^UTILITY("ROU",ROU)="" ;** M/11
  375.  ;** update global directory ;** STD
  376.  W "done" Q
  377. RCHECK ;
  378.  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
  379.  ;** check if routine already exists ;** STD
  380.  Q
  381. KOUT G KOUT^ZKRMFIO
  382. FOPENR G FOPENR^ZKRMFIO
  383. FCLOSER G FCLOSER^ZKRMFIO
  384. GFILE G GFILE^ZKRMU
  385. GETFIL G GETFIL^ZKRMU
  386. GFSPEC G GFSPEC^ZKRMU
  387. READ R A:120 S E=$S(A="":0,"<#@^>"[$E(A):1,1:0)
  388.  W:E " Can't do that here." Q
  389.  
  390. ZKRMO
  391. ZKRMO ;DGR NYSCVM  ; 03 MAR 84  3:47 PM
  392.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  393.  ;Kermit <--> MUMPS interface - Output MUMPS-->Kermit
  394. OOPT ;
  395.  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)
  396. 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
  397.  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
  398.  I $S(A'?1N:1,A<1:1,A>5:1,1:0) W *7," ? no such option" G OO1
  399.  W @FF D @$P("SFO;ROM;ROR;GO;SGO",S,A) G OOPT
  400.  Q
  401. SFO ;
  402.  W !!,"Write a sequential MUMPS file to a Kermit-M file",!
  403. SFO1 W !,"Read from" D ^%IS I POP Q  ;** M/11
  404.  I "TRMSDPMT"'[(B_IOT_B) W *7," I can't deal with that type of device" G SFO1
  405.  ;set IO as $I from which to read, IOT as device type, IOST as subtype, then OPEN it with correct parameters ;** STD
  406.  S TRM=IOT="TRM"
  407. 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
  408.  U 0 I TRM,IO'=$I W !,"Enter your text lines at terminal #",IO,!
  409.  I TRM U IO W !!!,"Enter lines of text; enter <CR> only when done",!
  410.  E  U 0 W !,"Writing to file ",FILE,"..." U IO
  411.  U IO F I=0:0 W:TRM !,">" R LIN D SFEOF Q:E  D KIN
  412.  D FCLOSEW
  413.  I TRM W !!,"The above text is now in file ",FILE
  414.  E  U 0 W "** done"
  415. SFOX U 0 I $D(IO),IO'=$I C IO
  416.  K TRM,FILE Q
  417. SFEOF S E=0 I IOT="TRM" S E=$S(LIN="":1,1:0) Q
  418.  I IOT="SDP" S E=$S(LIN=$C(26):1,1:0) Q
  419.  I IOT="MT" S E=$S(LIN=$C(26):1,$ZA16384#2:1,1:0) Q
  420.  S E=1
  421.  Q
  422. ROM G ROM^ZKRMOR
  423. ROR G ROR^ZKRMOR
  424. GO ;
  425.  W !!,"Global output to a Kermit file",!
  426. GOR D GROOT I 'GRF Q
  427. 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
  428.  D HEAD F GI=1:1:GRF S GR=GRF(GI) D GOW
  429.  D FCLOSEW K GI,GR,GRF,DEF,L,M,REF,SUB W *7,!,"** All done" Q
  430. GOW W !,"Starting ",GR,"..." I '$D(@GR) W *7," ** [undefined]" Q
  431.  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
  432.  Q
  433. 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
  434.  Q
  435. GOVIS S LIN=REF(M) D KIN S LIN=@(REF(M)) D KIN Q
  436.  Q
  437. SGO ;
  438.  W !!,"Write one level of one or more globals to a Kermit file",!
  439. SGOR D GROOT I 'GRF Q
  440. 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
  441.  W " writing..." F GI=1:1:GRF S GR=GRF(GI) D SGOW
  442.  D FCLOSEW K GI,GR,GRF,SUB W *7,!,"** All done" Q
  443. SGOW W !,"Starting ",GR,"..." I $D(@GR)10=0 W *7," ** [undefined]" Q
  444.  S SUB="" F I=0:0 S SUB=$O(@GR@(SUB)) Q:SUB=""  I $D(@GR@(SUB))#10 S LIN=@GR@(SUB) D KIN
  445.  Q
  446. GROOT G GROOT^ZKRMU
  447. GFILE G GFILE^ZKRMU
  448. FOPENW G FOPENW^ZKRMFIO
  449. FCLOSEW G FCLOSEW^ZKRMFIO
  450. KIN G KIN^ZKRMFIO
  451. DATIM G DATIM^ZKRMU
  452. READ R A:120 S E=$S(A="":0,"<#@"[$E(A):1,1:0)
  453.  W:E " Can't do that here." Q
  454. HEAD ;
  455.  W !!,"Please enter a free-text description of this file: " D READ
  456.  W " writing..." S LIN=A D KIN S DATIM=$H D DATIM S LIN=DATIM D KIN K DATIM
  457.  Q
  458.  
  459. ZKRMOR
  460. ZKRMOR ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  461.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  462.  ;Kermit <--> MUMPS interface - Output MUMPS-->Kermit - routines
  463. ROM ;
  464.  W !!,"Routine output to Kermit-M files (.MMP)",!,"Please specify the set of routines to write:"
  465.  D RSET G ROMX:'RCT W !,"Writing routines to Kermit files now..."
  466.  S ZL="ZL @A F J=1:1 S X=$T(+J) Q:X=""""  S ^ZKRZ($J,""ROM"",J)=X",A=0 ;** M/11
  467.  ;** SET ZL=an Xecutable string to load a routine named in var. A into scratch global;** STD
  468. ROM1 S A=$O(^ZKRZ($J,"RSET",A)) I A="" W !,"All done for this set of routines" G ROMX
  469.  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
  470.  F J=1:1 S LIN=$S('$D(^ZKRZ($J,"ROM",J)):"",1:^(J)) D:LIN]"" KIN I LIN="" D FCLOSEW W "done" Q
  471.  G ROM1
  472. ROMX K RCT,ZL,^ZKRZ($J,"ROM"),^("RSET")
  473.  Q
  474. ROR ;
  475.  W !!,"Routine output to a Kermit-M file (.ROU)",!,"Please specify the set of routines to write:"
  476.  D RSET G RORX:'RCT
  477. 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
  478.  D FOPENW I E W *7," ?? that file is already defined" G RORF
  479.  S ZL="ZL @A F J=1:1 S X=$T(+J) Q:X=""""  S ^ZKRZ($J,""ROR"",J)=X",A=0 ;** M/11
  480.  ;** SET ZL=an Xecutable string to load a routine named in var. A into scratch global;** STD
  481.  D HEAD S A=0
  482. 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
  483.  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
  484.  G ROR1
  485. RORX K RCT,ZL,^ZKRZ($J,"ROR"),^("RSET")
  486.  Q
  487. RSET G RSET^ZKRMUR
  488. GFILE G GFILE^ZKRMU
  489. FOPENW G FOPENW^ZKRMFIO
  490. FCLOSEW G FCLOSEW^ZKRMFIO
  491. KIN G KIN^ZKRMFIO
  492. DATIM G DATIM^ZKRMU
  493. READ R A:120 S E=$S(A="":0,"<#@"[$E(A):1,1:0)
  494.  W:E " Can't do that here." Q
  495. HEAD ;
  496.  W !!,"Please enter a free-text description of this file: " D READ
  497.  W " writing..." S LIN=A D KIN S DATIM=$H D DATIM S LIN=DATIM D KIN K DATIM
  498.  Q
  499.  
  500. ZKRMU
  501. ZKRMU ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  502.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  503.  ;Kermit <--> MUMPS interface - utility parts
  504. DATIM ;
  505.  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
  506.  S DATIM=$ZD(+DATIM,2) ;** M/11 V5
  507.  ;** set DATIM to readable date, like '2 APR 83' ;** STD
  508.  S DATIM=$J(DATIM,9)_", "_TIM K TIM
  509.  Q
  510. GFSPEC ;
  511.  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
  512.  E  S FSPEC=A
  513.  K FN,FT Q
  514. GETFIL ;
  515.  K ^ZKRZ($J,"FILE") S (E,CT)=0,FN=$P(FSPEC,"."),FT=$P(FSPEC,".",2)
  516.  S FNL=$L(FN),FTL=$L(FT),FNW=$E(FN,FNL)="*",FTW=$E(FT,FTL)="*"
  517.  I 'FNW S F1=FN D GF2 G GFX
  518.  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
  519.  G GFX
  520. GF2 I 'FTW S F2=FT D:$D(^ZKR(F1,F2)) GFSET Q
  521.  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
  522.  Q
  523. GFSET S ^ZKRZ($J,"FILE",F1_"."_F2)="",CT=CT+1 Q
  524. GFX I '$D(^ZKRZ($J,"FILE")) S E=1,FSPEC="File(s) not found for "_FSPEC
  525.  E  S ^ZKRZ($J,"FILE")=CT W " --> ",CT," file",$S(CT=1:"",1:"s")," meet",$S(CT=1:"s",1:"")," the specification"
  526.  K FN,FT,FNW,FTW,FNL,FTL,F1,F2,I,CT Q
  527. GFILE ;
  528.  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
  529.  S FILE=A
  530.  Q
  531. GROOT ;
  532.  K GRF S GRF=0 W !,"Enter global references, one at a time:",!
  533. GR1 W !,"Global ^" D READ Q:E  I "^>"[A S E=1 Q
  534.  I $E(A)="?" D GRH G GR1
  535.  D VERGRF I E W *7," [ syntax ]" G GR1
  536.  S GRF=GRF+1,GRF(GRF)=A K X1,X2 G GR1
  537.  Q
  538. GRH W ! F I=2:1 S X=$T(GRH+I) Q:$P(X," ")]""  W !?5,$P(X,";",2,99)
  539.  W ! Q
  540.  ;Enter a full global reference, including ending parentheses (if any).
  541.  ;For example:
  542.  ;
  543.  ; ^A   -- or --   ^A("ONE",2,"three")
  544.  ;
  545.  ;Each reference will be processed in the order in which you enter it.
  546.  ;It is possible to list the same subtree more than once in the list.
  547.  ;
  548.  ;Press <RETURN> to end the list.  To abort an incorrect list so that
  549.  ;it is not processed, press CTRL/C.
  550. GRT ;
  551.  W !,"Enter a global reference:",!
  552. GRT1 W !,"Global ^" D READ Q:E  I "^>"[A S E=1 Q
  553.  I $E(A)="?" D GRTH G GRT1
  554.  D VERGRF I E W *7," [ syntax ]" G GRT1
  555.  S GRF=1,GRF(1)=A Q
  556. GRTH W ! F I=2:1 S X=$T(GRTH+I) Q:$P(X," ")]""  W !?5,$P(X,";",2,99)
  557.  W ! Q
  558.  ;Enter a full global reference, including ending parentheses (if any).
  559.  ;For example:
  560.  ;
  561.  ; ^A   -- or --   ^A("ONE",2,"three")
  562.  ;
  563. READ R A:120 S E=$S(A="":0,"<#@"[$E(A):1,1:0)
  564.  Q
  565. VERGRF ;
  566.  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
  567.  I $S(X2=""&(A'["("):0,X2=""&(A'[")"):1,$E(X2,$L(X2))'=")":1,1:0) S E=1 Q
  568.  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
  569.  Q
  570.  
  571. ZKRMUR
  572. ZKRMUR ;DGR NYSCVM  ; 03 MAR 84  3:47 PM
  573.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  574.  ;Kermit <--> MUMPS interface - utilities - pick a routine set
  575. RSET ;
  576. 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
  577.  ;** rebuild routine directory if appropriate ;** STD
  578.  K ^ZKRZ($J,"RSET") S RCT=0,SEL=1,E=0
  579. ROU R !,"Routine: " D READ G ROU:E I A="" W ! G XIT
  580.  I A["?" D @$S(A="?L":"DISP",1:"HELP") G ROU
  581.  S SEL=1 I A?1"'".E S SEL=0,A=$E(A,2,99)
  582.  I A?.E1"*" S A=$E(A,1,$L(A)-1),X=A S:X="" X=0 D SING,MULT G ROU
  583.  I A["-" D RANGE G ROU
  584.  D SING I E W *7," I don't have that routine on file"
  585.  G ROU
  586. SING S E=0 I A]"",$D(^UTILITY("ROU",A)) S X=A
  587.  E  S E=1 Q
  588. S I SEL,'$D(^ZKRZ($J,"RSET",X)) S ^(X)="",RCT=RCT+1 Q
  589.  I 'SEL,$D(^ZKRZ($J,"RSET",X)) K ^(X) S RCT=RCT-1
  590.  Q
  591. MULT S X=$O(^UTILITY("ROU",X)) Q:X=""!($E(X,1,$L(A))'=A)
  592.  D S G MULT
  593.  Q
  594. RANGE S X=$P(A,"-",1),Y=$P(A,"-",2) I X]Y W " ???" Q
  595.  I $D(^UTILITY("ROU",X)) D S
  596. R2 S X=$O(^UTILITY("ROU",X)) Q:X=""  Q:X]Y  D S G R2
  597.  Q
  598. XIT K A,X,Y,SEL S ^ZKRZ($J,"RSET",0)=RCT W RCT," routine",$S(RCT=1:" was",1:"s were")," selected",!
  599.  Q
  600. READ R A S A=$ZU(A),E=$S(A="":0,"^<>#@"[$E(A,1):1,1:0)
  601.  W:E " Can't do that here." Q
  602. HELP W !!,"Choose routines as in these examples:"
  603.  W !,"  RNAM",?18,"one routine"
  604.  W !,"  RNAM1-RNAM2",?18,"range of routines"
  605.  W !,"  CD*",?18,"all routines beginning with CD"
  606.  W !,"  *",?18,"all routines"
  607.  W !,"  'RNAM",?18,"exclude this routine from those already selected"
  608.  W !,"  'RNAM1-RNAM2",?18,"exclude this range of routines from those already selected"
  609.  W !,"  'CD*",?18,"exclude all routines beginning with CD from the routines",!?18,"already selected"
  610.  W !!,"Enter '?L' to get a list of routines selected so far"
  611.  W ! Q
  612. 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
  613. DISP1 Q
  614. HELP2 W !,"It may take time (if there are a lot of routines), but it ensures that the",!,"routine directory is accurate." G REF
  615.  
  616. ZKRR
  617. ZKRR ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  618.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  619.  ;Kermit - receive files
  620.  S (TRY,OLDTRY,SPN)=0
  621. R ;
  622.  S TRY=TRY+1 I TRY>MAXTRY G A
  623.  D RPACK I E D NAK G R
  624.  G A:RPT'="S"
  625. RI ;
  626.  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
  627. RF ;
  628.  S TRY=TRY+1 I TRY>MAXTRY G A
  629.  D RPACK I E D NAK G RF
  630.  G A:"SZFB"'[RPT,@("RF"_RPT)
  631. RFS S OLDTRY=OLDTRY+1 G A:OLDTRY>MAXTRY D PREV G A:SPN'=RPN,RI
  632. RFZ D PREV G A:SPN'=RPN D ACK G RF
  633. RFF I SPN'=RPN D NAK G RF
  634.  S FILE=RDAT D FOPEN K FILE I E S SPT="E",SDAT=$E(E,2,99) D SPACK Q
  635.  I TTY U 0 W !,"Receiving file : ",F1,".",F2,"..." U TTY
  636.  S OLDTRY=TRY D ACK,BUMP G RD
  637. RFB I SPN'=RPN D NAK G RF
  638.  D ACK S E=0 Q
  639.  Q
  640. RD ;
  641.  S TRY=TRY+1 I TRY>MAXTRY G A
  642.  D RPACK I E D NAK G RD
  643.  G A:"DFZ"'[RPT,@("RD"_RPT)
  644. RDD I SPN'=RPN S OLDTRY=OLDTRY+1 G A:OLDTRY>MAXTRY D PREV G A:SPN'=RPN D ACK,BUMP G RD
  645.  D PDATA,ACK S OLDTRY=TRY D BUMP G RD
  646. RDF S OLDTRY=OLDTRY+1 G A:OLDTRY>MAXTRY D PREV G A:SPN'=RPN D ACK,BUMP G RD
  647. 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
  648.  D ULOCK
  649.  I TTY U 0 W "done" U TTY
  650.  G RF
  651.  Q
  652. A ;
  653.  I 'KAF,$D(F1),$D(F2),F1]"",F2]"",$D(^ZKR(F1,F2)),$P(^(F2),B,3)="" K ^(F2)
  654.  K F1,F2,F3,BCNT
  655.  I TTY U 0 W !,"Aborting RECEIVE operation" U TTY
  656.  S E=1 Q
  657. UTIL ;
  658. BUMP S TRY=0,SPN=SPN+1#64 Q
  659. PREV S SPN=SPN-1#64 Q
  660. NAK S SPT="N",SDAT="" D SPACK Q
  661. ACK S SPT="Y",SDAT="" D SPACK S TRY=0 Q
  662. SPACK G SPACK^ZKRUP
  663. RPACK I TTY,RPN#8=1 U 0 W "." U TTY
  664.  G RPACK^ZKRUP
  665. PDATA ;
  666.  S ^ZKR(F1,F2,F3)=RDAT,BCNT=BCNT+$L(RDAT),F3=F3+1
  667.  Q
  668. RPAR G RPAR^ZKRUM
  669. FOPEN ;
  670.  S E=0 I FILE'?.1"%"1.8UN1"."1.3UN S E="1 bad filespec" Q
  671.  S F1=$P(FILE,"."),F2=$P(FILE,".",2) I $D(^ZKR(F1,F2)),FW S E="1 file already defind" K F1,F2 Q
  672.  D WLOCK
  673.  K ^ZKR(F1,F2) S ^ZKR(F1,F2)=B_RQA_B_$H,H1=$H,EFB=-1,BCNT=0,F3=1
  674.  Q
  675. EFBAUD S EFB=BCNT*10(H2-H1*86400+$P(H2,",",2)-$P(H1,",",2)) Q
  676. WLOCK L ^ZKR(FILE) Q
  677. ULOCK L  Q
  678.  
  679. ZKRS
  680. ZKRS ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  681.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  682.  ;Kermit - send a group of files
  683.  S (SPN,TRY)=0,RPT=""
  684. S ;
  685.  S TRY=TRY+1 I TRY>MAXTRY G A
  686.  S SPT="S",SDAT=$C(RPSIZ+32)_$C(STO+32)_"   "_SQA D SPACK,RACK E  G S:RPT'="E",RACKER
  687.  D RPAR,BUMP G NXTFIL
  688. SF ;
  689.  S TRY=TRY+1 I TRY>MAXTRY G A
  690.  S SPT="F",SDAT=FILE D SPACK,RACK E  G SF:RPT'="E",RACKER
  691.  D BUMP,BDATA G SD:SDAT]"",SZ
  692. SD ;
  693.  S TRY=TRY+1 I TRY>MAXTRY G A
  694.  S SPT="D" D SPACK,RACK E  G SD:RPT'="E",RACKER
  695.  D BUMP,BDATA G SD:SDAT]"",SZ
  696. SZ ;
  697.  S TRY=TRY+1 I TRY>MAXTRY G A
  698.  S SPT="Z",SDAT="" D SPACK,RACK E  G SZ:RPT'="E",RACKER
  699.  D ULOCK
  700.  S H2=$H D EFBAUD
  701.  I TTY U 0 W "done" U TTY
  702.  D BUMP G NXTFIL
  703. SB ;
  704.  S TRY=TRY+1 I TRY>MAXTRY G A
  705.  S SPT="B",SDAT="" D SPACK,RACK E  G SB:RPT'="E",RACKER
  706.  D BUMP S E=0 Q
  707. A ;
  708.  S E=1 Q
  709. NXTFIL ;
  710.  S:'$D(FILE) FILE="" S FILE=$O(^ZKRZ($J,"FILE",FILE)) I FILE="" G SB
  711.  D RLOCK
  712.  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
  713.  I TTY U 0 W !,"Sending file : ",FILE,"..." U TTY
  714.  G SF
  715. RACKER ;
  716.  I TTY U 0 W !,"Error - ",RDAT," - transfer aborted" U TTY
  717.  S E=1 Q
  718. UTIL ;
  719. RACK D RPACK I $S(E:0,RPT'="Y":0,SPN'=RPN:0,1:1)
  720.  Q
  721. BUMP S TRY=0,SPN=SPN+1#64 Q
  722. SPACK I TTY,SPN#8=1 U 0 W "." U TTY
  723.  G SPACK^ZKRUP
  724. RPACK G RPACK^ZKRUP
  725. BDATA ;
  726.  S SDAT="" I F3="" Q
  727.  I CC>LL D BGLIN I F3="" Q
  728.  S NC=SPSIZ-7 I SQA'=FQA G BD2
  729. 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
  730.  S X=CC+NC,SDAT=SDAT_$E(CL,CC,X-1),CC=X
  731.  Q
  732. 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
  733.  S X=CC+NC-1,SDAT=SDAT_$E(CL,CC,X-1),CC=X
  734.  Q
  735. BD2 S C=$E(CL,CC),CC=CC+1 I C="" D BGLIN G:F3]"" BD2 Q
  736.  I C=SQA S SDAT=SDAT_SQA_SQA,NC=NC-2 G:NC>0 BD2 Q
  737.  I C'=FQA S SDAT=SDAT_C,NC=NC-1 G:NC>0 BD2 Q
  738.  S C=$E(CL,CC),CC=CC+1 I C="" ABORT
  739.  I C=FQA S SDAT=SDAT_FQA,NC=NC-1 G:NC>0 BD2 Q
  740.  S SDAT=SDAT_SQA_C,NC=NC-2 G:NC>0 BD2 Q
  741.  Q
  742. BGLIN S F3=$O(^ZKR(F1,F2,F3)) I F3]"" S CL=^(F3),LL=$L(CL),CC=1
  743.  Q
  744. RPAR G RPAR^ZKRUM
  745. EFBAUD S EFB=BCNT*10(H2-H1*86400+$P(H2,",",2)-$P(H1,",",2)) Q
  746. RLOCK L ^ZKR(FILE,$J) Q
  747. ULOCK L  Q
  748.  
  749. ZKRSET
  750. ZKRSET ;DGR NYSCVM  ; 03 MAR 84  3:47 PM
  751.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  752.  ;Kermit - set Kermit parameters (SET command)
  753. SET ;
  754.  D @("S"_$E(CSS(2),1,3)) Q
  755. SABO S KAF=CMD(3)="KEEP" Q
  756. SBAU S BAUD=CMD(3) Q
  757. SDEB S DEBUG=CMD(3)="ON" Q
  758. SDEL S DELAY=CMD(3) Q
  759. SDUP S FDX=CMD(3)="FULL" Q
  760. SESC S CESC=$A(CMD(3),2)-64 Q
  761. SFIL S FW=CMD(3)="ON" Q
  762. SLIN I '$D(CMD(3)) C:TTY TTY S TTY=0 U 0 W " Ok - no line is assigned" Q
  763.  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
  764.  I '$D(^ZKRX("LINE",CMD(3))) W !,"? No such line" Q
  765.  S A=+^(CMD(3))
  766. SLIN1 O A:(0:""):0 E  W !,"? Can't get that line now" Q  ;** M/11 V5
  767.  ;Open the port if possible, else error message and QUIT ;** STD
  768.  S TTY=A W " Line ",TTY," is now assigned"
  769.  Q
  770. SPAR ;
  771.  I $E(CMD(3))="M" W !,"? Can't set MARK parity in M/11 V5" Q  ;** M/11 V5
  772.  I $E(CMD(3))="S" W !,"? Use NONE in M/11 V5" Q  ;** M/11 V5
  773.  S PAR=$E(CMD(3)) Q
  774. SPAU S PAUSE=CMD(3) Q
  775. SREC G @("SR1"_$E(CMD(3),1,3))
  776. SR1PAC S RPSIZ=CMD(4) Q
  777. SR1STA S RSOH=$A(CMD(4),2)-64 Q
  778. SR1TIM S RTO=CMD(4) Q
  779. SRET S MAXTRY=CMD(3)+1 Q
  780. SSEN G @("SS1"_$E(CMD(3),1,3))
  781. SS1END S SEOL=$A(CMD(4),2)-64 Q
  782. SS1PAC S SPSIZ=CMD(4) Q
  783. SS1QUO S SQA=CMD(4),SQB=$A(CMD(4)),SQB=$E("000",0,3-$L(SQB))_SQB Q
  784. SS1STA S SSOH=$A(CMD(4),2)-64 Q
  785. SS1TIM S STO=CMD(4) Q
  786.  
  787. ZKRSRV
  788. ZKRSRV ;DGR NYSCVM  ; 03 MAR 84  3:47 PM
  789.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  790.  ;Kermit - Server executive
  791.  S SPN=0
  792. SRV ;
  793.  D RPACK I E D NAK G SRV
  794.  I "SRG"'[RPT D NAK G SRV
  795.  G @("SRV"_RPT)
  796. SRVS ;
  797.  D RI^ZKRR G SRV
  798. SRVR ;
  799.  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
  800.  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
  801.  D ^ZKRS G SRV
  802. SRVG ;
  803.  S C=$E(RDAT) I "LF"'[C S SDAT="Unrecognized 'Generic' command "_RDAT,SPT="E" D SPACK G SRV
  804.  G @("SRVG"_C)
  805. SRVGL D ACK U 0 W !,"Session terminated by local Kermit's BYE command" C:TTY'=$I TTY K  Q
  806. SRVGF D ACK U 0 W !,"Server shut down by local Kermit's FINISH command" G START^ZKR
  807. NAK S SPT="N",SDAT="" D SPACK Q
  808. ACK S SPT="Y",SDAT="" D SPACK S TRY=0 Q
  809. SPACK G SPACK^ZKRUP
  810. RPACK G RPACK^ZKRUP
  811. GETFIL D GETFIL^ZKRUM Q
  812.  
  813. ZKRT20
  814. ZKRT20 ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  815.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  816.  ;Kermit - command parser
  817.  U 0:(RM:"":$C(27)) ;** M/11 V5
  818.  ;Make sure 'Escape' is read with READ * ;** STD
  819.  D INIT
  820. RCOM W !
  821. RC1 W "Kermit-M>" F I=1:1:CI-1 W CMD(I)," "
  822.  I CI W CMD(CI) I CI=VI W " " S A=32
  823. 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
  824.  I A>96,A<123 S A=A-32
  825.  I A>32 S:LA=32!'LA&(A-40) CI=CI+1,CMD(CI)="" S C=$C(A),CMD(CI)=CMD(CI)_C
  826.  G RCS
  827. TO W !,"? No response for 10 minutes" D INIT G XIT
  828. CR ;
  829.  S:LA'=32 A=32 S E=0 F EI=VI+1:1:CI D VER I E D VERMSG,INIT G RCOM
  830.  S GI=VI D BCREF I $D(@CREF)#10=0 W !,"? Incomplete" D INIT G RCOM
  831. XIT ;
  832.  K CI,EI,GI,A,C,LA,QREF,CREF,GREF,KW,LSS,SS
  833.  U 0:(RM:"") ;** M/11 V5
  834.  ;reset terminal protocol if necessary ;** STD
  835.  Q
  836. ESC ;
  837.  I LA=32!'LA W *7 S A=LA G RCS
  838.  S E=0 F EI=VI+1:1:CI-1 D VER I E D VERMSG,INIT G RCOM
  839.  S EI=CI D VER I 'E G ESC1
  840.  I E=1 D VERMSG,INIT G RCOM
  841.  W *7 S A=LA G RCS
  842. ESC1 I CSS(VI)[CMD(VI) S X=$F(CSS(VI),CMD(VI)) W $E(CSS(VI),X,99)," " S CMD(VI)=CSS(VI)
  843.  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
  844. QM ;
  845.  S E=0 F EI=VI+1:1:CI-1 D VER I E D VERMSG,INIT G QMX
  846.  I LA=32,CI S EI=CI D VER I E D VERMSG,INIT G QMX
  847.  D BQREF I $D(@(QREF_",1)")) F I=1:1 G QMX:'$D(@(QREF_","_I_")")) W !?3,@(QREF_","_I_")")
  848.  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
  849.  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
  850.  I VI,LSS="",$D(@CREF)#10 W "  confirm with carriage return" G QMX:'KW W !,"   or, enter"
  851.  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
  852.  E  W " confirm with carriage return"
  853. QMX K QREF,CREF,KW,LSS,SS,EI,GI,X,L S A=LA G RCOM
  854. 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
  855.  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
  856.  S A=$A($E(CMD(CI)),$L(CMD(CI))) W @RO G RCS
  857. CTRLU W *13,$J("",$X),$C(13) D INIT G RC1
  858. CTRLC D INIT Q
  859. INIT K CMD,CSS S (CI,VI,E,A)=0 Q
  860. VER G VER^ZKRT20A
  861. BCREF S CREF="^ZKRX(""COMMAND""" F I=1:1:GI S CREF=CREF_","""_CSS(I)_""""
  862.  S CREF=CREF_")" Q
  863. BQREF S QREF="^ZKRX(""?""" F I=1:1:VI S QREF=QREF_","""_CSS(I)_""""
  864.  Q
  865. BGREF S GREF="^ZKRX(""GUIDE""" F I=1:1:VI S GREF=GREF_","""_CSS(I)_""""
  866.  S GREF=GREF_")" Q
  867. VERMSG G VERMSG^ZKRT20A
  868.  
  869. ZKRT20A
  870. ZKRT20A ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  871.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  872.  ;Kermit - command parser - overflow
  873. 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
  874.  I $D(@CREF@(A)) S VI=EI,CSS(EI)=A Q
  875.  S SS=A F I=1:1 S LSS=SS,SS=$O(@CREF@(SS)) Q:SS=""!($E(SS,1,$L(A))'=A)
  876.  I I=2 S VI=EI,CSS(EI)=LSS Q
  877.  S E=$S(I=1:1,1:2) Q
  878. VERMSG W " ",$S(E=1:"? Does not match switch or keyword",E=2:"? Ambiguous",1:"") Q
  879. VCTRL I A'?1"^".1UP!($A(A,2)>95!($A(A,2)<65)) W !,"? Enter a control character like '^A' or '^]'" S E=3
  880.  Q
  881. VFSPEC I A'?1.8UN1"."1.3UN,A'?1"%".7UN1"."1.3UN W !,"? Illegal file spec" S E=3
  882.  Q
  883. 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
  884.  K FN,FT,X Q
  885. VPLEN I +A'=A!(A<10)!(A>94) W !,"? packet length from 10 thru 94" S E=3
  886.  Q
  887. 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
  888.  E  S A=$C(A)
  889.  Q
  890. VRFSPEC Q
  891. VSEC I +A'=A!(A<0) W !,"? Illegal number of seconds" S E=3
  892.  Q
  893. VTRY I +A1'=A!(A<0) W !,"? retries, 0 or more" S E=3
  894.  Q
  895. VTTY I $S(A'?1.N:0,A'<4&(A'>19):1,A'<64&(A'>143):1,1:0) Q  ;** M/11,DSM-11
  896.  I '$D(^ZKRX("LINE",A)) W !,"? No such line" S E=3
  897.  Q
  898. BCREF S CREF="^ZKRX(""COMMAND""" F I=1:1:GI S CREF=CREF_","""_CSS(I)_""""
  899.  S CREF=CREF_")" Q
  900.  
  901. ZKRTC
  902. ZKRTC ;DGR NYSCVM ; 03 MAR 84  3:47 PM
  903.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  904.  ;Kermit - Set Terminal Characteristics (DH11 or DZ11).
  905.  ;** M/11 V5 -- entire routine
  906.  U 0 S %DV=$S(TTY:TTY,1:$I) D CN G:POP XIT D GET
  907.  I $D(PAR) S %A=PAR D CP G:POP XIT
  908.  I $D(BAUD) S %A=BAUD D CS G:POP XIT
  909.  I $D(STC) S %A=STC D CH G:POP XIT
  910.  I $D(BIN) S %A=BIN D CB G:POP XIT
  911.  D SET C %DV O %DV U %DV,0
  912. XIT K %A,%DDBASE,%NOECHO,%I,%DV,%O,%PAR,%PAREN,%S,%LPAR,%CONDIO,%SPD,%DZ,%X,%STSIZ,%STALL,%STOP,%CHRLEN,%BIN
  913.  Q
  914. GET I %DZ S %S="50,75,110,134.5,150,300,600,1200,1800,2000,2400,3600,4800,7200,9600,19200" ;** DZ
  915.  E  S %S="0,50,75,110,134.5,150,200,300,600,1200,1800,2400,4800,9600,Ext A,Ext B" ;** DH
  916.  F %I=1:1:16 S %S($P(%S,",",%I))=%I-1
  917.  S %DDBASE=%DV-64*70+$V($V(44)+20)
  918.  S %LPAR=$V(%DDBASE+6)
  919.  I %DZ S %SPD=%LPAR256#16,%PAR=%LPAR128#2,%CHRLEN=%LPAR8#4,%PAREN=%LPAR64#2 ;** DZ
  920.  E  S %SPD=%LPAR64#16,%PAR=%LPAR32#2,%CHRLEN=%LPAR#4,%PAREN=%LPAR16#2 ;** DH
  921.  S %CONDIO=$V(%DDBASE+20),%BIN=%CONDIO4#2,%NOECHO=%CONDIO2#2
  922.  S %STSIZ=$V(%DDBASE+18),%STALL=%STSIZ256
  923.  Q
  924. SET S %STOP=0 ;1 stop bit
  925.  I %DZ S %LPAR=%LPAR4096*4096+(%SPD*256)+(%PAR*128)+(%PAREN*64)+(%STOP*32)+(%CHRLEN*8)+(%LPAR#8)
  926.  E  S %LPAR=%SPD*1024+(%SPD*64)+(%PAR*32)+(%PAREN*16)+(%STOP*4)+%CHRLEN ;** DH
  927.  S %CONDIO=%CONDIO8*8+(%NOECHO*2)+(%BIN*4)+(%CONDIO#2)
  928.  S %STSIZ=%STALL*256+(%STSIZ#256)
  929.  V %DDBASE+6::%LPAR,%DDBASE+20::%CONDIO,%DDBASE+18::%STSIZ Q
  930.  Q
  931. CN S POP=%DV<64!(%DV>111) S:'POP %DZ=%DV>95 Q
  932. CS S POP='$D(%S(%A)) S:'POP %SPD=%S(%A) Q
  933. CP S POP='(%A?1U&("NEO"[%A)) S:'POP %PAREN="EO"[%A,%CHRLEN=$S(%A="N":3,1:2),%PAR="NE"'[%A Q
  934. CH S POP='(%A?.N&(%A<64)) S:'POP %STALL=%A Q
  935. CB S POP='(%A?1N&("01"[%A)) S:'POP %BIN=%A Q
  936.  
  937. ZKRUM
  938. ZKRUM ;DGR NYSCVM  ; 03 MAR 84  3:47 PM
  939.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  940.  ;Kermit - utility parts - miscellanous
  941. RPAR ;
  942.  S X=$A(RDAT)-32 I X<SPSIZ S SPSIZ=X
  943.  S RTO=$A(RDAT,2)-32,SPADN=$A(RDAT,3)-32,SPAD=$A(RDAT,4) S SPAD=$S(SPAD=63:127,1:SPAD-64)
  944.  S SEOL=$A(RDAT,5)-32 I SEOL<1 S SEOL=13
  945.  S RQA=$E(RDAT,6) S:RQA=" "!(RQA="") RQA="#"
  946.  Q
  947. GETFIL ;
  948.  K ^ZKRZ($J,"FILE") S E=0,FN=$P(FSPEC,"."),FT=$P(FSPEC,".",2)
  949.  S FNL=$L(FN),FTL=$L(FT),FNW=$E(FN,FNL)="*",FTW=$E(FT,FTL)="*"
  950.  I 'FNW S F1=FN D GF2 G GFX
  951.  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
  952.  G GFX
  953. GF2 I 'FTW S F2=FT D:$D(^ZKR(F1,F2)) GFSET Q
  954.  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
  955.  Q
  956. GFSET S ^ZKRZ($J,"FILE",F1_"."_F2)="" Q
  957. GFX I '$D(^ZKRZ($J,"FILE")) S E=1,FSPEC="File(s) not found for "_FSPEC
  958.  K FN,FT,FNW,FTW,FNL,FTL,F1,F2,I Q
  959. INITPAR ;
  960.  S TTY=0,FDX=1,RPSIZ=64,SPSIZ=94,RTO=16,STO=0
  961.  S MAXTRY=8,DELAY=5,PAUSE=0
  962.  S (SSOH,RSOH)=1,SEOL=13,(SPADN,SPAD)=0
  963.  S SQA="#"
  964.  S CESC=25,PAR="N",BAUD=1200
  965.  S KAF=0,FW=0
  966.  S DEBUG=0
  967.  S (SPN,RPN)=0
  968.  S (BCNT,EFB)=0
  969.  Q
  970. SHOW ;
  971.  W !!,"This is Kermit-M Version ",^ZKRX("VERSION")
  972.  W !,"Line assigned : ",$S(TTY:TTY,1:"local terminal")," ; we are ",$S(TTY:"local",1:"remote")
  973.  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"
  974.  W !,"We will receive packets of at most ",RPSIZ," characters"
  975.  W !,"We will send packets of at most ",SPSIZ," characters"
  976.  W !,"Maximum number of tries is ",MAXTRY," ; receiver timeout after ",RTO," seconds"
  977.  W !,"Delay ",DELAY," seconds before sending the first 'send intialize' packet"
  978.  W !,"Pause ",PAUSE," seconds before sending each packet"
  979.  W !,"We send CTRL/",$C(SSOH+64)," as a packet header, and expect CTRL/",$C(RSOH+64)
  980.  W !,"We send CTRL/",$C(SEOL+64)," at the end of each packet; we do not require a packet terminator"
  981.  W !,"Our 'escape' character for remote connection is CTRL/",$C(CESC+64)
  982.  W !,"Partially-received files are ",$S(KAF:"kept",1:"discarded")," if transmission is aborted"
  983.  W !,"The file-warning flag is ",$S(FW:"on",1:"off")
  984.  W !,"We quote control characters with ",SQA," when sending files"
  985.  W ! Q
  986.  
  987. ZKRUP
  988. ZKRUP ;DGR NYSCVM  ; 03 MAR 84  3:47 PM
  989.  ;Copyright (c) 1984 New York State College of Veterinary Medicine
  990.  ;Kermit - utility parts - packets
  991. SPACK ;
  992.  U TTY I PAUSE H PAUSE
  993.  F I=1:1:SPADN W *SPAD
  994.  S CHKSUM=$L(SDAT)+67+SPN+$A(SPT) F I=1:1:$L(SDAT) S CHKSUM=CHKSUM+$A(SDAT,I)
  995.  S CHKSUM=CHKSUM64#4+CHKSUM#64
  996.  S A=$C(SSOH)_$C($L(SDAT)+35)_$C(SPN+32)_SPT_SDAT_$C(CHKSUM+32)_$C(SEOL)
  997.  I TTY,DEBUG U 0 W !,"Sending packet : ",A U TTY
  998.  W A Q
  999. RPACK ;
  1000.  U TTY
  1001.  S E=0 F I=0:0 R *A:RTO G RTO:'$T Q:A=RSOH
  1002.  R *A:RTO G RTO:'$T,RPACK:A=RSOH S RPLEN=A-32,CHKSUM=A
  1003.  R A#RPLEN:RTO G RTO:'$T
  1004.  S RPN=$A(A)-32,RPT=$E(A,2),CHKSUM=CHKSUM+$A(A)+$A(A,2)
  1005.  S RDAT=$E(A,3,RPLEN-1) F I=3:1:RPLEN-1 S CHKSUM=CHKSUM+$A(A,I)
  1006.  S CHKSUM=CHKSUM64#4+CHKSUM#64 I CHKSUM'=($A(A,RPLEN)-32) S E=1
  1007.  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
  1008.  Q
  1009. RTO S E=1 Q:'DEBUG!'TTY  U 0 W !,"(receiver timed out)" U TTY Q
  1010.  
  1011.  
  1012.  
  1013.