Sub DocAlyseMedical()
' Paul Beverley - Version 03.08.24
' Analyses the use of various abbreviations in a medical document

' prompts to count number of tests
cc = 53

myScreenOff = True

Set FUT = ActiveDocument
doingSeveralMacros = (InStr(FUT.Name, "zzTestFile") > 0)
If doingSeveralMacros = False Then
  myResponse = MsgBox("    DocAlyse Medical" & vbCr & vbCr & _
       "Analyse this document?", vbQuestion _
       + vbYesNoCancel, "DocAlyse Medical")
  If myResponse <> vbYes Then Exit Sub
End If

If myScreenOff = True Then
  Application.ScreenUpdating = False
  On Error GoTo ReportIt
End If

ss = "________________________________" & _
     "__________________________________"
myTrack = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False

Set rngOld = ActiveDocument.Content
Documents.Add
Set tempDoc = ActiveDocument
Set rng = ActiveDocument.Content
rng.FormattedText = rngOld.FormattedText
Selection.EndKey Unit:=wdStory

If ActiveDocument.Footnotes.Count > 0 Then
  ActiveDocument.StoryRanges(wdFootnotesStory).Copy
  Selection.Paste
  Selection.Collapse wdCollapseEnd
End If

If ActiveDocument.Endnotes.Count > 0 Then
  ActiveDocument.StoryRanges(wdEndnotesStory).Copy
  Selection.Paste
  Selection.Collapse wdCollapseEnd
End If

Set endTempfile = ActiveDocument.Content
endTempfile.Collapse wdCollapseEnd

' collect text in all the textboxes (if any)
sh = ActiveDocument.Shapes.Count
If sh > 0 Then
  For Each shp In ActiveDocument.Shapes
    If shp.Type <> 24 And shp.Type <> 3 Then
      If shp.TextFrame.HasText Then
        shp.TextFrame.TextRange.Copy
        endTempfile.Select
        Selection.Paste
      End If
    End If
  Next
End If

Selection.HomeKey Unit:=wdStory
Set rng = ActiveDocument.Content
rng.Revisions.AcceptAll
DoEvents
myTot = ActiveDocument.Range.End

Selection.HomeKey Unit:=wdStory
Set rngOld = ActiveDocument.Content
ActiveDocument.TrackRevisions = myTrack

Documents.Add
Set rng = ActiveDocument.Content
rng.Text = rngOld.Text

myRslt = ""
myTot = ActiveDocument.Range.End
CR = vbCr: CR2 = CR & CR
tr = Chr(9) & "0zczc" & CR: SP = "     "
Selection.HomeKey Unit:=wdStory

Set newDoc = ActiveDocument

cc = cc - 1
DoEvents
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Wrap = wdFindContinue
  .Replacement.Text = "^&!"
  .MatchWildcards = True
  DoEvents
End With

' bd, bds, bid b.i.d
With rng.Find
  .Text = "[Bb][Dd]>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "[Bb][Dd][Ss]>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "[Bb][Ii][Dd]>"
  .Execute Replace:=wdReplaceAll
End With
k = ActiveDocument.Range.End - myTot
If k > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "[Bb].[Ii].[Dd]>"
  .Execute Replace:=wdReplaceAll
End With
l = ActiveDocument.Range.End - myTot
If l > 0 Then WordBasic.EditUnDo

If i + j + k + l > 0 Then myRslt = myRslt & "bd" & _
     vbTab & Trim(Str(i)) & CR & "bds" & vbTab & _
     Trim(Str(j)) & CR & "bid (?word or abbr.)" & _
     vbTab & Trim(Str(k)) & CR & "b.i.d" & vbTab _
     & Trim(Str(l)) & CR2


'tds, tid, t.i.d
With rng.Find
  .Text = "[Tt][Dd][Ss]>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "[Tt][Ii][Dd]>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "[Tt].[Ii].[Dd]>"
  .Execute Replace:=wdReplaceAll
End With
k = ActiveDocument.Range.End - myTot
If k > 0 Then WordBasic.EditUnDo

If i + j + k > 0 Then myRslt = myRslt & "tds" & vbTab _
     & Trim(Str(i)) & CR & "tid" & vbTab & Trim(Str(j)) _
     & CR & "t.i.d" & vbTab & Trim(Str(k)) & CR2

'qds, qid, q.i.d
With rng.Find
  .Text = "[Qq][Dd][Ss]>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "[Qq][Ii][Dd]>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "[Qq].[Ii].[Dd]>"
  .Execute Replace:=wdReplaceAll
End With
k = ActiveDocument.Range.End - myTot
If k > 0 Then WordBasic.EditUnDo

If i + j + k > 0 Then myRslt = myRslt & "qds" & vbTab _
     & Trim(Str(i)) & CR & "qid" & vbTab & Trim(Str(j)) _
     & CR & "q.i.d" & vbTab & Trim(Str(k)) & CR2

'#hrly
With rng.Find
  .Text = "[0-9]hrly>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

'#[ -]hrly
With rng.Find
  .Text = "[0-9][ -]hrly>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

'q#h
With rng.Find
  .Text = "[Qq][0-9][Hh]>"
  .Execute Replace:=wdReplaceAll
End With
k = ActiveDocument.Range.End - myTot
If k > 0 Then WordBasic.EditUnDo

'qqh
With rng.Find
  .Text = "[Qq][Qq][Hh]>"
  .Execute Replace:=wdReplaceAll
End With
l = ActiveDocument.Range.End - myTot
If l > 0 Then WordBasic.EditUnDo

If i + j + k + l > 0 Then myRslt = myRslt & "#hrly" _
     & vbTab & Trim(Str(i)) & CR & "# hrly" & vbTab _
     & Trim(Str(j)) & CR & "q#h" & vbTab & Trim(Str(k)) & CR _
     & "qqh" & vbTab & Trim(Str(l)) & CR2

'prn
With rng.Find
  .Text = "[Pp][Rr][Nn]>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

'p.r.n
With rng.Find
  .Text = "[Pp].[Rr].[Nn]>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

'sos
With rng.Find
  .Text = "[Ss][Oo][Ss]>"
  .Execute Replace:=wdReplaceAll
End With
k = ActiveDocument.Range.End - myTot
If k > 0 Then WordBasic.EditUnDo

's.o.s
With rng.Find
  .Text = "[Ss].[Oo].[Ss]>"
  .Execute Replace:=wdReplaceAll
End With
l = ActiveDocument.Range.End - myTot
If l > 0 Then WordBasic.EditUnDo

If i + j + k + l > 0 Then myRslt = myRslt & "prn" & vbTab _
     & Trim(Str(i)) & CR & "p.r.n" & vbTab & Trim(Str(j)) _
     & CR & "sos" & vbTab & Trim(Str(k)) & CR _
     & "s.o.s" & vbTab & Trim(Str(l)) & CR2

'IV / i.v.
With rng.Find
  .Text = "<iv>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "<i.v>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "<IV>"
  .Execute Replace:=wdReplaceAll
End With
k = ActiveDocument.Range.End - myTot
If k > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "<I.V>"
  .Execute Replace:=wdReplaceAll
End With
l = ActiveDocument.Range.End - myTot
If l > 0 Then WordBasic.EditUnDo

If i + j + k + l > 0 Then myRslt = myRslt & "iv" & vbTab _
     & Trim(Str(i)) & CR & "i.v." & vbTab & Trim(Str(j)) _
     & CR & "IV" & vbTab & Trim(Str(k)) & CR _
     & "I.V." & vbTab & Trim(Str(l)) & CR2

'IM / i.m.
With rng.Find
  .Text = "<im>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "<i.m>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "<IM>"
  .Execute Replace:=wdReplaceAll
End With
k = ActiveDocument.Range.End - myTot
If k > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "<I.M>"
  .Execute Replace:=wdReplaceAll
End With
l = ActiveDocument.Range.End - myTot
If l > 0 Then WordBasic.EditUnDo

If i + j + k + l > 0 Then myRslt = myRslt & "im" & vbTab _
     & Trim(Str(i)) & CR & "i.m." & vbTab & Trim(Str(j)) _
     & CR & "IM" & vbTab & Trim(Str(k)) & CR _
     & "I.M." & vbTab & Trim(Str(l)) & CR2

'SC / s.c.
With rng.Find
  .Text = "<sc>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "<s.c>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "<SC>"
  .Execute Replace:=wdReplaceAll
End With
k = ActiveDocument.Range.End - myTot
If k > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "<S.C>"
  .Execute Replace:=wdReplaceAll
End With
l = ActiveDocument.Range.End - myTot
If l > 0 Then WordBasic.EditUnDo

If i + j + k + l > 0 Then myRslt = myRslt & "sc" & vbTab _
     & Trim(Str(i)) & CR & "s.c." & vbTab & Trim(Str(j)) _
     & CR & "SC" & vbTab & Trim(Str(k)) & CR _
     & "S.C." & vbTab & Trim(Str(l)) & CR2

'# ?
With rng.Find
  .Text = "[0-9]" & Chr(181)
  .Execute Replace:=wdReplaceAll
End With
h = ActiveDocument.Range.End - myTot
If h > 0 Then WordBasic.EditUnDo

'# ?
With rng.Find
  .Text = "[0-9] " & Chr(181)
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

'#micro
With rng.Find
  .Text = "[0-9]micro"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

'# micro
With rng.Find
  .Text = "[0-9] micro"
  .Execute Replace:=wdReplaceAll
End With
k = ActiveDocument.Range.End - myTot
If k > 0 Then WordBasic.EditUnDo

If h + i + j + k > 0 Then myRslt = myRslt & "# " _
     & Chr(181) & vbTab & Trim(Str(h + i)) & CR _
     & "# " & "micro" & vbTab & Trim(Str(j + k)) & CR2


'count/minute
With rng.Find
  .Text = "cpm>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "c.p.m>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

If i + j > 0 Then myRslt = myRslt & "cpm" & vbTab & Trim(Str(i)) _
     & CR & "c.p.m." & vbTab & Trim(Str(j)) & CR2

'beats/minute
With rng.Find
  .Text = "bpm>"
  .Execute Replace:=wdReplaceAll
End With
i = ActiveDocument.Range.End - myTot
If i > 0 Then WordBasic.EditUnDo

With rng.Find
  .Text = "b.p.m>"
  .Execute Replace:=wdReplaceAll
End With
j = ActiveDocument.Range.End - myTot
If j > 0 Then WordBasic.EditUnDo

If i + j > 0 Then myRslt = myRslt & "bpm" & vbTab & Trim(Str(i)) & CR _
     & "b.p.m." & vbTab & Trim(Str(j)) & CR2


myRslt = myRslt & CR

Selection.HomeKey Unit:=wdStory
Selection.TypeText Text:="DocAlyse Medical" & vbCr & vbCr
newDoc.Paragraphs(1).Style = ActiveDocument.Styles(wdStyleHeading1)

newDoc.Paragraphs(3).Range.Select
Selection.End = newDoc.Content.End
Selection.TypeText CR & myRslt & CR2
Selection.Font.Bold = True
Set rng = ActiveDocument.Content
rng.ParagraphFormat.TabStops.ClearAll
rng.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(4.5), _
    Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces

' Grey out the zero lines
cc = cc - 1
DoEvents
Set rng = ActiveDocument.Content
StatusBar = ss & "  " & Trim(Str(cc)) & vbCr
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^13([!^13]@)^t0"
  .Wrap = wdFindContinue
  .Replacement.Text = "^p\1^t^="
  .Replacement.Font.Bold = False
  .Replacement.Font.Color = wdColorGray25
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  
  .Text = "^t^=zczc"
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With

With Selection.Find
  .Text = ""
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute
End With

Selection.HomeKey Unit:=wdStory
tempDoc.Close SaveChanges:=False

If doingSeveralMacros = False Then
  Beep
  newDoc.Activate
Else
  FUT.Activate
End If
Application.ScreenUpdating = True
Exit Sub

ReportIt:
Application.ScreenUpdating = True
On Error GoTo 0
Resume
End Sub