130 lines
4.9 KiB
Plaintext
130 lines
4.9 KiB
Plaintext
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; ;
|
|
; Copyright 1987, 2011 Fidelity Information Services, Inc ;
|
|
; ;
|
|
; This source code contains the intellectual property ;
|
|
; of its copyright holder(s), and is made available ;
|
|
; under a license. If you do not know the terms of ;
|
|
; the license, please stop and do not read further. ;
|
|
; ;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
%RO ;routine output
|
|
;last modified by R. Partridge
|
|
;invoke ^%RO to get interaction
|
|
;invoke CALL^%RO with %ZR - routine array,
|
|
;%ZC - strip comments, %ZD - device, %ZH - header label
|
|
;
|
|
w !,"Routine Output - Save selected routines into RO file.",!
|
|
n ctrap,exc,d,k
|
|
d dev
|
|
i '$d(%zdebug) n $et s $et="zg "_$zl_":ERR^%RO" u $p:(ctrap=$c(3):exc="zg "_$zl_":EXIT^%RO")
|
|
n ename,fl,l,lc,out,r,rn,rf,src,x,y,t1,%ZC,%ZD,%ZH,%ZR,%ZRSET
|
|
s (fl,lc,r)=0,out=1
|
|
d main
|
|
q
|
|
;
|
|
CALL n ctrap,exc,d,k
|
|
d dev
|
|
n ename,fl,l,lc,out,r,rn,rf,src,x,y,t1,%ZRSET
|
|
n:'$d(%ZC) %ZC n:'$d(%ZD) %ZD n:'$d(%ZH) %ZH
|
|
s %ZC=$g(%ZC,1),%ZD=$g(%ZD,$p),%ZH=$g(%ZH),(fl,lc,r,out)=0
|
|
o %ZD:(newversion:block=2048:record=2044):0 e q
|
|
i $d(%ZR)<10 d CALL^%RSEL q:$d(%ZR)<10
|
|
d work
|
|
q
|
|
;
|
|
FL w !,"First Line Lister",!
|
|
n ctrap,exc,d,k
|
|
d dev
|
|
i '$d(%zdebug) n $et s $et="zg "_$zl_":ERR^%RO" u $p:(ctrap=$c(3):exc="zg "_$zl_":EXIT^%RO")
|
|
n ename,fl,l,lc,out,r,rf,rn,src,x,y,t1,%ZC,%ZD,%ZH,%ZR,%ZRSET
|
|
s (lc,r)=0,(%ZC,fl,out)=1,%ZH="Routine First Line Lister Utility"
|
|
d main
|
|
u $p:(ctrap=ctrap:exc=exc)
|
|
q
|
|
;
|
|
main
|
|
s %ZR="" d CALL^%RSEL
|
|
i %ZR=0 w !,"No routines selected" q
|
|
f d q:$l(%ZD)
|
|
. r !,"Output device: <terminal>: ",%ZD,!
|
|
. i '$l(%ZD) s %ZD=$p q
|
|
. i %ZD="^" q
|
|
. i %ZD="?" d q
|
|
. . w !!,"Select the device you want for output"
|
|
. . w !,"If you wish to exit enter a carat (^)",!
|
|
. . s %ZD=""
|
|
. i $zparse(%ZD)="" w " no such device" s %ZD="" q
|
|
. o %ZD:(newversion:block=2048:record=2044:exception="g noopen"):0
|
|
. i '$t w !,%ZD," is not available" s %ZD="" q
|
|
. q
|
|
noopen . w !,$p($ZS,",",2,999),! c %ZD s %ZD=""
|
|
q:%ZD="^"
|
|
i 'fl d
|
|
. r !,"Header Label: ",%ZH
|
|
. r !,"Strip comments <No>?: ",%ZC
|
|
. i $l(%ZC),"\YES"[("\"_$tr(%ZC,"yes","YES")) s %ZC=0
|
|
. e s %ZC=1
|
|
w !
|
|
d work
|
|
q
|
|
;
|
|
work i '$l(%ZH) s %ZH="%RO Routine Output Utility"
|
|
u %ZD w %ZH,!,"GT.M ",$zd($h,"DD-MON-YEAR 24:60:SS"),! u $p
|
|
s %ZR=""
|
|
f s %ZR=$o(%ZR(%ZR)) q:'$l(%ZR) d out
|
|
i 'fl u %ZD w !!
|
|
u $p
|
|
i out d
|
|
. w !!,"Total of ",lc," line",$s(lc=1:"",1:"s")
|
|
. w " in ",r," routine",$s(r=1:".",1:"s."),!!
|
|
c:%ZD'=$p %ZD u $p:(ctrap=ctrap:exc=exc)
|
|
q
|
|
;
|
|
out s rf=%ZR(%ZR)_$tr($e(%ZR),"%","_")_$e(%ZR,2,9999)_".m"
|
|
o rf:(readonly:rewind:exception="g rnoopen")
|
|
u rf:exception="g reof" r x s rn=$p($p($p(x,$c(9))," "),"(") d frmt
|
|
i $tr(rn,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")'=%ZR s rn=%ZR
|
|
i %ZD'=$p u $p w:$x>70 ! w %ZR,?$x\10+1*10
|
|
s r=r+1,lc=lc+1 s:x="" x=rn
|
|
u %ZD w rn,!,x,!
|
|
; warning - loop terminated by an execption
|
|
i 'fl f u rf r x d frmt i $l(x) u %ZD w x,! s lc=lc+1
|
|
f u rf r x d frmt q:x'?.E1";"1.E u %ZD w x,! s lc=lc+1
|
|
u %ZD w ! c rf
|
|
q
|
|
;
|
|
reof u %ZD w ! c rf
|
|
rnoopen i $zs'["EOF" w !,$p($zs,",",2,999),!
|
|
q
|
|
frmt new stripped set stripped=0
|
|
if '%ZC set t1=0 do ;strip comments
|
|
. for set t1=$find(x,";",t1) quit:'t1 if $length($extract(x,1,t1-1),"""")#2 do quit
|
|
. . if $extract(x,t1)'=";" set x=$extract(x,1,t1-2) if '$length($translate(x," "_$char(9))) set x="",stripped=1
|
|
if '$length(x),stripped quit
|
|
;kill stripped
|
|
if '$length(x) set x=" " quit
|
|
if $extract(x)=";" set x=" "_x ;if lonely comment, provide ls
|
|
set t1=0
|
|
for set t1=$find(x,$char(9),t1) quit:'t1 do ;convert <TAB>s to spaces
|
|
. set x=$extract(x,1,t1-2)_$justify("",8-(t1-2#8))_$extract(x,t1,9999)
|
|
quit
|
|
;
|
|
ERR u $p w !,$p($zs,",",2,99),!
|
|
s $ec=""
|
|
; Warning - Fall-though
|
|
EXIT i $d(%ZD),%ZD'=$p c %ZD
|
|
i $d(rf) c rf
|
|
u $p:(ctrap=ctrap:exc=exc)
|
|
q
|
|
dev ; save device parameters EXC, and CTRAP
|
|
zsh "d":d
|
|
s d=""
|
|
f s d=$o(d("D",d)) q:d="" i $p=$p(d("D",d)," ") s d=d("D",d),ctrap=$p($p(d,"CTRA=",2)," "),exc=$p(d,"EXCE=",2) q
|
|
e s (ctrap,exc)="" ; should never happen
|
|
s k=$l(exc,"""")
|
|
s k=$l(exc) i $e(exc,1,1)="""",$e(exc,k,k)="""" s exc=$e(exc,2,k-1)
|
|
if ctrap'="" s exc="s ctrap="_ctrap x exc
|
|
k d
|
|
q
|