TMGCODT1 ;TMG/kst/A Code Analysis Tools ;08/17/08
         ;;1.0;TMG-LIB;**1**;08/17/08

ScanAll
        new pArray
        set pArray=$name(^TMG("MODULE CALLS"))

        new Itr,index
        new abort set abort=0
        set index=$$ItrAInit^TMGITR($name(^DIC(9.8,"B")),.Itr)
        do PrepProgress^TMGITR(.Itr,20,1,"index")
        set index="TMGKIDS" ;"temp!
        if index'="" for  do  quit:($$ItrANext^TMGITR(.Itr,.index)="")!abort
        . if $$UserAborted^TMGUSRIF set abort=1 quit
        . ;"write index,!
        . do GetCalls(index,pArray)
        do ProgressDone^TMGITR(.Itr)

        quit

GetCalls(Module,pArray)
        ;"Purpose: To scan one code module and look for *static* calls to other
        ;"         modules.  It will NOT detect indirection (i.e. do @X).
        ;"         Call MUST have a tag.  MyTag^MyMod is detected, but ^MyMod is NOT
        ;"Input: Module -- the name of the module to scan, as would be used
        ;"                 in $text().  I.e. XUP, but not ^XUP, not XUP.m
        ;"       Array -- PASS BY NAME, an OUT PARAMETER.  Format below.
        ;"Output:  Array filled as follows:
        ;"              Array(Module,Addr)=OutSideAddr  (Example of Addr=A+5^MYFUNCT)

        new curModule set curModule=$get(Module)
        new blankLines set blankLines=0
        new offset set offset=1
        new curLabel set curLabel=""

        for  do  quit:(blankLines>30)
        . new Addr set Addr=curLabel_"+"_offset_"^"_curModule
        . new oneLine set oneLine=$text(@Addr)
        . new firstChar set firstChar=$extract(oneLine,1,1)
        . set offset=offset+1
        . if oneLine="" set blankLines=blankLines+1 quit
        . set oneLine=$$CutComment(oneLine)
        . new tempLabel set tempLabel=$$GetLabel(oneLine)
        . if tempLabel'="" set curLabel=tempLabel,offset=1
        . new tempS set tempS=oneLine
        . if tempS'["^" quit
        . new done set done=0
        . for  quit:(tempS'["^")!(done=1)  do
        . . if $$InQt^TMGSTUTL(tempS,$find(tempS,"^")-1)=1 set done=1 quit
        . . new preS,postS
        . . do GetPrePost(.tempS,.preS,.postS)
        . . if (preS="")!(postS="") quit
        . . ;"write curLabel,"+",offset,"--> "
        . . ;"write preS,"^",postS,"   [",$$Trim^TMGSTUTL(oneLine),"]",!
        . . ;"if preS["$" quit
        . . new tempAddr set tempAddr=preS_"^"_postS
        . . ;"write "==> ",$text(@tempAddr),!
        . . ;"set @pArray@("CALLS OUT",curModule,curLabel,offset,tempAddr)=""
        . . set @pArray@("CALLS IN",postS_"::"_preS,curModule,curLabel,offset)=""

        quit


CutComment(oneLine)
        ;"Purpose: to cut off any comments from line, indicated by ;
        ;"Input: oneLine : string to alter
        ;"Result: modified inputline

        new i,L,result
        set result=$get(oneLine)
        if result'[";" goto CCmDone

        new inStr,done,ch
        set inStr=0,done=0
        set L=$length(oneLine)
        for i=1:1:L do  quit:done
        . set ch=$extract(oneLine,i)
        . if ch="""" do
        . . if inStr=0 set inStr=1 quit
        . . if $extract(oneLine,i+1)="""" set i=i+1 quit
        . . set inStr=0
        . if (ch=";")&(inStr=0) do  quit
        . . set result=$extract(oneLine,1,i-1)
        . . set done=1

CCmDone quit result


GetLabel(oneLine)
        ;"Purpose: Get label for a line, if one exists
        ;"Input: oneLine : string to scan
        ;"Result: Label, or "" if none

        new result set result=$get(oneLine)  ;"default to entire line is label
        new ch set ch=$extract(oneLine,1)
        if (ch=" ")!(ch=$char(9)) do  goto GLDone
        . set result=""

        new i,done set done=0
        for i=1:1:$length(oneLine) do  quit:done
        . set ch=$extract(oneLine,i)
        . if (ch=" ")!(ch=$char(9))!(ch="(")!(ch=";") do  quit
        . . set result=$extract(oneLine,1,i-1)
        . . set done=1

GLDone  quit result


GetPrePost(oneLine,preS,postS)
        ;"Purpose: To take a string like 'write $$MyFunct^MyModule(123)' and return
        ;"         '$$MyFunct' in preS, and 'MyModule' in postS.  Also shorten
        ;"         input string, oneLine, so that other calls on the same line
        ;"         can be processed on a separate run.
        ;"Input: oneLine -- the string to process.  PASS BY REFERENCE to get back
        ;"                  shortened line with first instance cut off.
        ;"       preS -- PASS BY REFERENCE, an OUT PARAMETER
        ;"       postS --  PASS BY REFERENCE, an OUT PARAMETER
        ;"Output: See purpose above
        ;"Result: none

        new done,p

        ;"Work first on preS
        set preS=$piece(oneLine,"^",1)
        set p=$length(preS)
        set done=0
        if p>0 for  do  quit:(p=0)!(done=1)
        . new ch set ch=$extract(preS,p)
        . set p=p-1
        . if ch?1(1A,1N) quit
        . set p=p+2,done=1
        set preS=$extract(preS,p,999)

        ;"weed out entries like '_^DIC'  or '_U_^TMP'
        ;"if ($extract(preS,1)="_")!($extract(preS,$length(preS))="_" set preS=""


        ;"Now work on postS
        set postS=$piece(oneLine,"^",2,$length(oneLine,"^"))
        set p=1,done=0
        for  do  quit:(p>$length(postS))!(done=1)
        . new ch set ch=$extract(postS,p)
        . set p=p+1
        . if ch?1(1A,1N,1"_") quit
        . set p=p-2,done=1

        set oneLine=$extract(postS,p+1,999)
        set postS=$extract(postS,1,p)

        quit

 ;"=======================================================
test
        new array
        new DIC,X,Y
        set DIC=9.8
        set DIC(0)="MAEQ"
t1
        do ^DIC write !
        if +Y'>0 goto testDone
        ;"kill array
        do GetCallsOut($piece(Y,"^",2),"array")
        if $data(array) zwr array
        goto t1

testDone
        quit