yottagr ;ven/gpl-yottadb extension: graphstore ;2018-03-11T22:31Z
;;1.8;Mash;
;
; %yottagr implements the Yottadb Extension Library's graphstore
; ppis & apis. These may eventually migrate to another Mash
; namespace, tbd. In the meantime, they will get a %yotta ppi &
; api library built.
; It is currently untested & in progress.
;
quit ; no entry from top
;
;
;
;@section 0 primary development
;
;
;
;@routine-credits
;@primary-dev: George P. Lilly (gpl)
; gpl@vistaexpertise.net
;@primary-dev-org: Vista Expertise Network (ven)
; http://vistaexpertise.net
;@copyright: 2017/2018, gpl, all rights reserved
;@license: Apache 2.0
; https://www.apache.org/licenses/LICENSE-2.0.html
;
;@last-updated: 2018-03-11T22:31Z
;@application: Mumps Advanced Shell (Mash)
;@module: Yottadb Extension - %yotta
;@version: 1.8T04
;@release-date: not yet released
;@patch-list: none yet
;
;@additional-dev: Frederick D. S. Marshall (toad)
; toad@vistaexpertise.net
;
;@module-credits
;@primary-dev: George P. Lilly (gpl)
; gpl@vistaexpertise.net
;@project: VA Partnership to Increase Access to Lung Screening
; (VA-PALS)
; http://va-pals.org/
;@funding: 2017, gpl
;@funding: 2017, ven
;@funding: 2017/2018, Bristol-Myers Squibb Foundation (bmsf)
; https://www.bms.com/about-us/responsibility/bristol-myers-squibb-foundation.html
;@partner-org: Veterans Affairs Office of Rural health
; https://www.ruralhealth.va.gov/
;@partner-org: International Early Lung Cancer Action Program (I-ELCAP)
; http://ielcap.com/
;@partner-org: Paraxial Technologies
; http://paraxialtech.com/
;@partner-org: Open Source Electronic Health Record Alliance (OSEHRA)
; https://www.osehra.org/groups/va-pals-open-source-project-group
;
;@module-log
; 2017-02-17 ven/gpl %*1.8t01 %yottagr: create routine to hold
; all yottadb graph methods.
;
; 2017-09-16 ven/gpl %*1.8t01 %yottagr: update
;
; 2017-09-18 ven/gpl %*1.8t01 %yottagr: update
;
; 2017-10-07 ven/gpl %*1.8t01 %yottagr: update
;
; 2018-02-07/11 ven/toad %*1.8t04 %yottagr: passim add white space &
; hdr comments & do-dot quits, tag w/Apache license & attribution
; & to-do to shift namespace later, break up a few long line. debug.
;
; 2018-03-10/11 ven/toad %*1.8t04 %yottagr: fix $namew typo.
;
; 2019-05-28 ven/lgc replaced ^%WHOME with ^%webhome and
; ^%W0 to ^%webapi
;
;@to-do
; %yotta: create entry points in ppi/api style
; r/all local calls w/calls through ^%yotta
; break up into smaller routines & change branches from %yotta
; renamespace elsewhere, research best choice
;
;@contents
; [too big, break up]
;
;
;
;@section 1 code to implement ppis & apis
;
;
;
setroot(graph) ; root of working storage
;
if '$data(graph) set graph="seeGraph"
new %y set %y=$order(^%wd(17.040801,"B",graph,""))
if %y="" set %y=$$addgraph(graph) ; if graph is not present, add it
;
quit $na(^%wd(17.040801,%y)) ; root for graph ; end of $$setroot
;
;
;
addgraph(graph) ; makes a place in the graph file for a new graph
;
new fda set fda(17.040801,"?+1,",.01)=graph
new %yerr
do UPDATE^DIE("","fda","","%yerr")
new %y set %y=$order(^%wd(17.040801,"B",graph,""))
;
quit %y ; end of $$addgraph
;
;
;
homedir() ; extrinsic which return the document home
;
new kbaihd set kbaihd=$get(^%webhome)
if kbaihd="" do break ;
. write !,"error, home directory not set"
. quit
if $extract(kbaihd,$length(kbaihd))="/" do
. set kbaihd=$extract(kbaihd,1,$length(kbaihd)-1)
. quit
;
quit kbaihd ; end of $$homedir
;
;
;
build ; retrieve directory structure and build into xtmp
;
new kbairoot
set kbairoot=$$setroot()
;
; kill @kbairoot
; if '$data(@kbairoot@(0)) do quit ; work area doesn't exist
; . write !,"error, work area not found ",kbairoot
; . quit
; . new X,Y
; . set X="T+999" ; a long time from now
; . do ^%DT ; covert to fm date format
; . set @kbairoot@(0)=Y_"^"_$$NOW^XLFDT_"^kbaiwsai graph"
; . quit
;
zsystem "ls -DRL --file-type ~/www > ~/www/dirconfig.txt"
new zdir set zdir=^%webhome
new kbails,kbails1,ok
set kbails=$na(@kbairoot@("ls"))
set kbails1=$name(@kbails@(1))
set ok=$$FTG^%ZISH(zdir,"dirconfig.txt",kbails1,4)
do bldgraph
;
quit ; end of build
;
;
;
bldgraph ; build the graph in xtmp
;
new kbairoot set kbairoot=$$setroot()
new hmdir set hmdir=$$homedir()
new groot set groot=$name(@kbairoot@("graph"))
; kill @groot
new gsrc set gsrc=$name(@kbairoot@("ls"))
new zi,zj,zln,zien,zien2,uriary,distdir,localdir
set distdir="root" ;
set zien=0
set zien2=0 ; subfile ien
set zi=0
new %cnt set %cnt=0
for set zi=$order(@gsrc@(zi)) quit:+zi=0 do ;
. new zln,zdir,zpar,ztag
. set zln=@gsrc@(zi)
. quit:zln=""
. if zln[":" do quit ;
. . set %cnt=%cnt+1
. . ; if %cnt>100000 do counts(groot) set %cnt=1 ; this is for watching progress on big builds
. . set zien=zien+1
. . if $extract(zln,$length(zln))=":" set zln=$extract(zln,1,$length(zln)-1) ; strip off the :
. . if $get(distdir)="" set distdir="root" ;
. . set @groot@(zien,"parent",distdir)=""
. . set @groot@("pos","parent",distdir,zien)=""
. . set @groot@("ops",distdir,"parent",zien)=""
. . set localdir=zln
. . set @groot@(zien,"localdir",localdir)=""
. . set @groot@("pos","localdir",localdir,zien)=""
. . set @groot@("ops",localdir,"localdir",zien)=""
. . ; set graph type
. . set @groot@(zien,"type","directory")=""
. . set @groot@("pos","type","directory",zien)=""
. . set @groot@("ops","directory","type",zien)=""
. . set distdir=$piece(localdir,$$homedir,2)
. . if distdir'="" do ;
. . . set @groot@(zien,"distdir",distdir)=""
. . . set @groot@("pos","distdir",distdir,zien)=""
. . . set @groot@("ops",distdir,"distdir",zien)=""
. . . set @groot@(zien,"id",distdir)=""
. . . set @groot@("pos","id",distdir,zien)=""
. . . set @groot@("ops",distdir,"id",zien)=""
. . . kill uriary do deuri(distdir,"uriary")
. . . quit
. . set zien2=0
. . quit
. ; process file names as a subfile to the directory
. set zien2=zien2+1
. ; set parent pointer
. if $get(distdir)="" set distdir="root" ;
. set @groot@(zien,zien2,"parent",distdir)=""
. set @groot@("pos","parent",distdir,zien,zien2)=""
. set @groot@("ops",distdir,"parent",zien,zien2)=""
. ; set file name attribute
. set @groot@(zien,zien2,"file",zln)=""
. set @groot@("pos","file",zln,zien,zien2)=""
. set @groot@("ops",zln,"file",zien,zien2)=""
. ; tag the file name
. set @groot@(zien,zien2,"tag",zln)=""
. set @groot@("pos","tag",zln,zien,zien2)=""
. set @groot@("ops",zln,"tag",zien,zien2)=""
. ; added to tag qrda cqm names
. if $extract(zln,1,3)="CMS" do ;
. . new cqm
. . set cqm=$piece(zln,"_",1)
. . do addtag(cqm,zien,zien2)
. . quit
. ;
. ; set the file id
. new zid set zid=distdir_"/"_zln
. if distdir="root" set zid=zln
. set @groot@(zien,zien2,"id",zid)=""
. set @groot@("pos","id",zid,zien,zien2)=""
. set @groot@("ops",zid,"id",zien,zien2)=""
. new ztyp ; graph type
. if $extract(zln,$length(zln))="/" set ztyp="directory"
. else set ztyp="file"
. set @groot@(zien,zien2,"type",ztyp)=""
. set @groot@("pos","type",ztyp,zien,zien2)=""
. set @groot@("ops",ztyp,"type",zien,zien2)=""
. new zftyp
. set zftyp=$reverse($piece($reverse(zln),".",1))
. if zftyp'="" do ;
. . set @groot@(zien,zien2,"filetype",zftyp)=""
. . set @groot@("pos","filetype",zftyp,zien,zien2)=""
. . set @groot@("ops",zftyp,"filetype",zien,zien2)=""
. . set @groot@(zien,zien2,"tag",zftyp)=""
. . set @groot@("pos","tag",zftyp,zien,zien2)=""
. . set @groot@("ops",zftyp,"tag",zien,zien2)=""
. . ; tag the name without the filetype
. . new zfn2
. . set zfn2=$reverse($piece($reverse(zln),$reverse(zftyp)_".",2))
. . if zfn2'="" do ;
. . . set @groot@(zien,zien2,"tag",zfn2)=""
. . . set @groot@("pos","tag",zfn2,zien,zien2)=""
. . . set @groot@("ops",zfn2,"tag",zien,zien2)=""
. . . new contents
. . . if zftyp["xml" do ;
. . . . do scan(.contents,zid,zien,zien2) ; not scanning right now
. . . . quit
. . . quit
. . quit
. set @groot@(zien,zien2,"localdir",localdir)=""
. set @groot@("pos","localdir",localdir,zien,zien2)=""
. set @groot@("ops",localdir,"localdir",zien,zien2)=""
. if $get(distdir)'="" do ;
. . set @groot@(zien,zien2,"distdir",distdir)=""
. . set @groot@("pos","distdir",distdir,zien,zien2)=""
. . set @groot@("ops",distdir,"distdir",zien,zien2)=""
. . quit
. ; add the tags from the directory
. new zj set zj=""
. for set zj=$order(uriary(zj)) quit:zj="" do ;
. . set @groot@(zien,zien2,"tag",uriary(zj))=""
. . set @groot@("pos","tag",uriary(zj),zien,zien2)=""
. . set @groot@("ops",uriary(zj),"tag",zien,zien2)=""
. . quit
. ; if zien=3344 break
. quit
; compute the counts
do counts(groot) ;
;
quit ; end of bldgraph
;
;
;
counts(groot) ;
;
new ztag,zary,zcnt
kill @groot@("countbytag")
kill @groot@("tagbycount")
set ztag=""
for set ztag=$order(@groot@("pos","tag",ztag)) quit:ztag="" do ;
. if ztag="" quit ;
. kill zary
. do match("#tag:"_ztag,"zary")
. ; write !,ztag," ",$data(zary)
. set zcnt=$$count("zary")
. if zcnt<1 quit ;
. set @groot@("countbytag",ztag,zcnt)=""
. set @groot@("tagbycount",zcnt,ztag)=""
. quit
;
quit ; end of counts
;
;
;
testscan ;
;
set zien=4
set zien2=1
; set zid=$order(^xtmp("kbaiweb","graph",4,1,"id",""))
set zid=$order(@$$setroot@("graph",4,1,"id",""))
do scan(.g,zid,zien,zien2)
;
quit ; end of testscan
;
;
;
scan(rtn,zid,zien,zien2) ; scan the file contents for new tags
;
; and add them to the graph
;
new zcmd,tmpfile,tmpdir,cmdfile
set tmpfile="scan.txt"
set cmdfile="scan.sh"
set tmpdir=^%webhome
set zcmd=$name(^tmp("kbaicmd",$job))
set zcmd1=$name(@zcmd@(1))
set @zcmd@(1)="rm "_tmpdir_"/"_tmpfile
new g2 set g2=""
for i=1:1:$length(zid) set g2=g2_$select($extract(zid,i)=" ":"\ ",1:$extract(zid,i))
; set @zcmd@(2)="grep code "_tmpdir_"/"_zid_" > "_tmpdir_"/"_tmpfile
set @zcmd@(2)="grep code "_tmpdir_g2_" > "_tmpdir_tmpfile
; set @zcmd@(3)="grep originaltext "_tmpdir_"/"_zid_" >> "_tmpdir_"/"_tmpfile
set @zcmd@(3)="grep originaltext "_tmpdir_g2_" >> "_tmpdir_tmpfile
new ok
set ok=$$GTF^%ZISH(zcmd1,3,tmpdir,cmdfile)
zsystem "bash ../www/scan.sh"
new where set where=$name(^tmp("kbaiscan",$job))
kill @where
new where1 set where1=$name(@where@(1))
set ok=$$FTG^%ZISH(tmpdir,tmpfile,where1,3)
if ok do ;
. new zi set zi=0
. for set zi=$order(@where@(zi)) quit:+zi=0 do ;
. . new zl set zl=@where@(zi)
. . if zl["code" do ;
. . . new code
. . . set code=$piece($piece(zl,"code=""",2),""" ")
. . . if code[">" quit ;
. . . if code["""" quit ;
. . . ; break
. . . new name
. . . set name=$piece($piece(zl,"displayName=""",2),"""")
. . . if name["["" set name=$piece($piece(name,"["",2),""]")
. . . if name="" do ;
. . . . if zl["
"_title_"
") . do addto^%yottautl(rtn,""_@zr_"
") . ; do multout(.rtn,"zrary",title) . quit kill @rtn@(0) set HTTPRSP("mime")="text/html" set @rtn@($order(@rtn@(""),-1)+1)=gbot ; quit ; end of rewrite ; ; ; eor ; end of routine %yottagr