1. Create a Custom document property called eg FileShortName. (Use File >
Properties > Custom. Give the property any value you like.)

2. In the footer of the document, insert a DocProperty field: { DocProperty
FileShortName }

3. Write a macro called something like SetName:

Private Sub SetName()

   Dim pName as string
   Dim pIndex as long
   Dim pDialog as Word.Dialog

   set pDialog = Dialogs(wdDialogFileSaveAs)

   'Show the dialog without carrying out any actions
   '(returns TRUE if user clicks OK)
   If pDialog.Display then
       pName = pDialog.Name
       pIndex = instr(pName, "_")

       'User might not enter a name with an underscore
       if pIndex > 0 then
           pName = left$(pName, pIndex - 1)
       end if

       'Set the property
       ActiveDocument.CustomDocumentProperties("FileShortName") = pName

       'Update fields in the footer. Might need to change this if you have
a first page footer, or multiple sections, etc
       ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Fields.Update

       'Save the document under the new name
       pDialog.Execute
   end if

End Sub

4. Write a macro called FileSaveAs to run in place of the built-in SaveAs
command. All this macro does is call SetName.

5. Write a macro called FileSave. This calls SetName only if the document
has never been saved; otherwise it simply saves the document.