XPDANLYZ5 ;OAK/RSF- BUILD ANALYZER ;10/28/22
;;8.0;KERNEL;**782**;Jul 10, 1995;Build 4
;;Per VHA Directive 2004-038, this routine should not be modified.
;
FILEME(ITEM) ;Output some build files
Q:$G(ITEM)<1
N XPFNAME,RME,NB S RME("*")="-",NB=$$REPLACE^XLFSTR(XPDBN,.RME)
I ITEM=1 S XPFNAME1="XPBA_Anal_"_NB_"_"_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_".TXT",XPFNAME=XPFNAME1
I ITEM=3 S XPFNAME3="XPBA_Spell_"_NB_"_"_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_".TXT",XPFNAME=XPFNAME3
I ITEM=4 S XPFNAME4="XPBA_SQA_"_NB_"_"_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_".TXT",XPFNAME=XPFNAME4
N POP
D OPEN^%ZISH("XPBA",XPPATH,XPFNAME,"W")
I POP>0 D Q
. W:XPDR=3 !,"Could not open "_XPFNAME_". Unable to write to file. " Q
U IO
I ITEM=1 D BA I $D(XPBA1) N LL S LL=0 F S LL=$O(XPBA1(LL)) Q:'LL W !,XPBA1(LL)
I ITEM=3 D SPELLST
I ITEM=4 D SQAMM N LL S LL=0 F S LL=$O(XPMM(LL)) Q:'LL W !,XPMM(LL) ;D SQALINES
D CLOSE^%ZISH("XPBA")
Q
;
SPELLST ;
Q:'$D(XPDMM)
W !,"Text for Review/Spell Check, Build "_XPDBN_"; "_$$FMTE^XLFDT($$DT^XLFDT,"2D"),!
N TTT S TTT=0 F S TTT=$O(XPDMM(TTT)) Q:'TTT W !,XPDMM(TTT)
Q
;
BA ;SET BA ARRAY
N TMPT,LNUM Q:'$D(XPDW)
N RR S RR=0,LNUM=0 F S RR=$O(XPDW(RR)) Q:'RR D
. I $L(XPDW(RR))<80 S LNUM=LNUM+1,XPBA1(LNUM)=XPDW(RR)
. E D CUTME(XPDW(RR),1)
I $D(XPBA1) D
. S LNUM=LNUM+1,XPBA1(LNUM)=""
. S LNUM=LNUM+1,XPBA1(LNUM)=""
. S LNUM=LNUM+1,XPBA1(LNUM)=$TR($J("=",79)," ","=")
. S LNUM=LNUM+1,XPBA1(LNUM)=""
. S LNUM=LNUM+1,XPBA1(LNUM)=" This build may include references to components (i.e. Routines,"
. S LNUM=LNUM+1,XPBA1(LNUM)=" Globals, etc.) outside the build namespace. Review and validate "
. S LNUM=LNUM+1,XPBA1(LNUM)=" that all appropriate Integration Control Registrations (ICRs) "
. S LNUM=LNUM+1,XPBA1(LNUM)=" exist for each external reference."
. S LNUM=LNUM+1,XPBA1(LNUM)=""
. S LNUM=LNUM+1,XPBA1(LNUM)=$TR($J("=",79)," ","=")
Q
CUTME(LTXT,IND) ;5 MAY BE OPEN
;get any preliminary spacing
N RSF,RR S RSF="" F RR=1:1:$L(LTXT) Q:'($E(LTXT,RR)?1" ") S RSF=RSF_$E(LTXT,RR)
N T0,T1,T2 S T0=LTXT,T1="",T2=""
;REMOVE/SAVE PRELIMINARY SPACING
I RR>0 S T0=$E(LTXT,RR,99999)
N AL,LL,I S AL=(80-$L(RSF)) ;THIS IS THE LINE LENGTH ACCOUNTING FOR THE PRELIMINARY SPACES
S:IND>2 AL=AL-1
A1 ;
F I=AL:-1:(AL-20) D Q:T1]""
. I $E(T0,I)?1P S T1=RSF_$E(T0,1,I),T2=$E(T0,(I+1),9999) Q
. Q:T1]""
Q:$L(T1)<2&(T1'?1(1U,1P))
S:IND=1 LNUM=LNUM+1,XPBA1(LNUM)=T1
;W:IND=2 !,T1
S:IND=3 MCNT=MCNT+1,XPMM(MCNT)=T1
S:IND=4 TCNT=TCNT+1,XPDKT(NSP,TWOP,TCNT)=T1
S:IND=5 TCNT=TCNT+1,XPDTRR(NSP,TWOP,TCNT)=T1
Q:$G(T2)']""
N T3,E1 S T3=RSF_T2,E1=0
I IND=1 D G:E1 A1
. I $L(T3)<80 S LNUM=LNUM+1,XPBA1(LNUM)=T3 Q
. I $L(T3)>79 S T0=T2 K T1,T2,T3 S T1="",T2="",E1=1 Q
I IND=3 D G:E1 A1
. ;I $L(T3)+13<79 S MCNT=MCNT+1,XPMM(MCNT)=$J(" ",12)_T3 Q
. ;I $L(T3)+13>78 S T0=$J(" ",12)_T2 K T1,T2,T3 S T1="",T2="",E1=1 Q
. I $L(T3)+13<79 S MCNT=MCNT+1,XPMM(MCNT)=$J(" ",ML+1)_T3 Q
. I $L(T3)+13>78 S T0=$J(" ",ML+1)_T2 K T1,T2,T3 S T1="",T2="",E1=1 Q
I IND=4 D G:E1 A1
. N PAD S PAD=24 ;($L(ROU)+14)
. I $L(T3)+PAD<79 S TCNT=TCNT+1,XPDKT(NSP,TWOP,TCNT)=$J(" ",PAD)_T3 Q
. I $L(T3)+PAD>78 S T0=$J(" ",PAD)_T2 K T1,T2,T3 S T1="",T2="",E1=1 Q
I IND=5 D G:E1 A1
. N PAD S PAD=24
. I $L(T3)+PAD<79 S TCNT=TCNT+1,XPDTRR(NSP,TWOP,TCNT)=$J(" ",PAD)_T3 Q
. I $L(T3)+PAD>78 S T0=$J(" ",PAD)_T2 K T1,T2,T3 S T1="",T2="",E1=1 Q
Q
;
FSHOW ; called from menu and deletes Build Analyzer text files
N XPPATH,XPDEL,J,END S XPPATH=$$PWD^%ZISH(),END=0
W @IOF S DIR(0)="F",DIR("A",1)="Set the path to find the .TXT files",DIR("A",2)="or accept the standard default."
S DIR("A",3)="",DIR("A")="PATH",DIR("B")=XPPATH
S DIR("?",1)="Full path specification where XPBA* files reside. Path up to, but not including,"
S DIR("?",2)="the filename. This includes any trailing slashes or brackets."
S DIR("?")=" "
D ^DIR S:$D(DTOUT) END=1 S:$D(DIRUT) END=1 Q:END
S XPPATH=Y
K FILESPEC,XPFILE,XPF S FILESPEC("XPBA*")=""
S Y=$$LIST^%ZISH("","FILESPEC","XPFILE")
W !!,"Build Analyzer text files:",! N K,L S K=" ",L=0 F S K=$O(XPFILE(K)) Q:K']"" S L=L+1,XPF(L)=K,XPDEL(K)="" W !,$J(L,3),". ",K
I $G(L)<1 W @IOF,"There are no Build Analyzer files to delete.",!! Q
W !! K DIR S DIR(0)="Y",DIR("B")="NO"
S DIR("?")="Respond YES to delete the files listed above."
S DIR("A")="Delete all the files above"
D ^DIR Q:$D(DTOUT) Q:$D(DIRUT)
I Y=1 D G:END X1
. S J=$$DEL^%ZISH("",$NA(XPDEL))
. I J=1 W !,"Deletions completed." S END=1 Q
. I J=0 W !,"Unable to complete deletions." S END=1 Q
W !! K DIR S DIR(0)="L^1:"_L
S DIR("A")="Select number of file or files to delete"
D ^DIR G:$D(DTOUT) X1 G:$D(DIRUT) X1
N DME,DARR S DME="" I Y S DME=$$TRIM^XLFSTR(Y,"R",",") D
. N PCE,KK F KK=1:1:$L(DME,",") S PCE=$P(DME,",",KK) Q:'$G(PCE) S DARR(XPF(PCE))=""
I $D(DARR) N J S J=$$DEL^%ZISH(XPPATH,$NA(DARR))
I J=1 W !,"Deletions completed."
I J=0 W !,"Unable to complete deletions."
X1 K FILESPEC,XPFILE,XPF Q
;
PB1 ;FOR BUILD
S XPDCNT=XPDCNT+1,XPDW(XPDCNT)=""
S XPDCNT=XPDCNT+1,XPDW(XPDCNT)=XPDARR("BUILD",XPDBB,"NAME")_" BUILD OVERVIEW"
S XPDW(XPDCNT)=XPDW(XPDCNT)_$$RJ^XLFSTR($$FMTE^XLFDT($$NOW^XLFDT),79-$L(XPDW(XPDCNT))," ")
S XPDHR(XPDCNT)="BUILD OVERVIEW"
S XPDCNT=XPDCNT+1,XPDW(XPDCNT)=$TR($J(" ",79)," ","-")
N TMPTXT,XPDTX1
S XPDCS("FILES")="1"
N XPDTX2 S XPDTX2=" " F S XPDTX2=$O(XPDCS(XPDTX2)) Q:XPDTX2']"" D
. S XPDTX1=XPDTX2_$J(" ",(40-$L(XPDTX2)))
. S TMPTXT="Not Included"
. I '$D(XPDCAR(XPDCS(XPDTX2),0)) S TMPTXT="Not Included"
. E I XPDCAR(XPDCS(XPDTX2),0)]"" S TMPTXT="Included"
. I XPDTX2="FILES",$D(^XPD(9.6,XPDBB,4,"B"))>1 S TMPTXT="Included"
. S XPDCNT=XPDCNT+1,XPDW(XPDCNT)=XPDTX1_TMPTXT
S XPDCNT=XPDCNT+1 ;,XPDW(XPDCNT)=$TR($J(" ",70)," ","-")
K XPDCS("FILES")
Q
;
SQAMM ;
N MCNT,ML,MR1 S MCNT=0
I '$D(XPDSQA) S MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)=" *** No SQA issues were found in the included routines. ***" Q
;^TMP
I $D(XPTK) D
. N TWW,JL S MR1=0,TWW=" " F S TWW=$O(XPTK(TWW)) Q:TWW']"" D
.. S JL=$L(XPTK(TWW),"^") N II,SK F II=1:1:JL S:$L($P(XPTK(TWW),"^",II))>MR1 MR1=$L($P(XPTK(TWW),"^",II))
. S MR1=MR1+2,MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="These ^TMP calls have kill statements within the included routines:" D
.. N WWW,JK,JL S (WWW,JK)=" ",JL=0 F S WWW=$O(XPTK(WWW)) Q:WWW']"" D
... S MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)=WWW,JL=$L(XPTK(WWW),"^") N II,SK F II=1:1:JL S SK=$P(XPTK(WWW),"^",II),MCNT=MCNT+1,XPMM(MCNT)=$J(" ",10)_$P(SK," ")_$J(" ",(MR1-($L($P(SK," "))+10)))_$P(SK," ",2,99)
I $D(XPDKT) D
. N NSP,NSP1 S (NSP,NSP1)=" " F S NSP=$O(XPDTRR(NSP)) Q:NSP']"" F S NSP1=$O(XPDTRR(NSP,NSP1)) Q:NSP1']"" K:$D(XPDKT(NSP,NSP1)) XPDTRR(NSP,NSP1)
. I $D(XPDTRR) D
.. S MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="These ^TMP calls have no associated kill in this build's included routines:"
.. N JK,JL S (NSP,JK)=" ",JL=0 F S NSP=$O(XPDTRR(NSP)) Q:NSP']"" F S JK=$O(XPDTRR(NSP,JK)) Q:JK']"" F S JL=$O(XPDTRR(NSP,JK,JL)) Q:'JL S MCNT=MCNT+1,XPMM(MCNT)=XPDTRR(NSP,JK,JL)
. I '$D(XPDTRR) S MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="All ^TMP calls have at least one kill statement in this build's routines."
;^XTMP
N RRR,XRRR S RRR=" ",XRRR="" F S RRR=$O(XPDXRR(RRR)) Q:RRR']"" I '$D(XTMPARR(RRR)) S XRRR=XRRR_"^"_RRR
I $D(XTMPARR) D
. S MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="General ^XTMP Notes"
. S MCNT=MCNT+1,XPMM(MCNT)="These ^XTMP calls have zero nodes defined in this build's included routines:"
. N WWW,BBB S (WWW,BBB)=" " F S WWW=$O(XTMPARR(WWW)) Q:WWW']"" F S BBB=$O(XTMPARR(WWW,BBB)) Q:BBB']"" D
.. N XLNE S XLNE=$J(" ",5)_"Routine: "_BBB_$J(" ",5)_XTMPARR(WWW,BBB)
.. I $L(XLNE)<79 S MCNT=MCNT+1,XPMM(MCNT)=XLNE
.. I $L(XLNE)>78 S ML=$L("Routine: "_BBB_$J(" ",5)) D CUTME(XLNE,3)
I XRRR]"" S MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="These ^XTMP calls have no zero nodes defined in this build's included routines" D
. N LLL F LLL=2:1:$L(XRRR,"^") S MCNT=MCNT+1,XPMM(MCNT)=$J(" ",5)_"Routine: "_XPDXRR($P(XRRR,"^",LLL))_$J(" ",5)_"^XTMP("_$P(XRRR,"^",LLL)
I XRRR']"" S MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)="ALL ^XTMP calls have zero nodes defined in this build's routines"
N RT1,RT2,SQAM,SQAM1,JJ,TXTC,TTAG S JJ=0,(RT1,RT2,SQAM1)="",ML=XPTL+3
F S RT1=$O(XPDSQA(RT1)) Q:RT1']"" S SQAM=" " F S SQAM=$O(XPDSQA(RT1,SQAM)) Q:SQAM']"" F S JJ=$O(XPDSQA(RT1,SQAM,JJ)) Q:'JJ D
. S XPDROUT(0)="",TTAG=" ",TTAG=$O(XPDSQA(RT1,SQAM,JJ,TTAG)) Q:TTAG']"" ;S:TTAG["+0" TTAG=TTAG_" "
. I RT1'=RT2 D
.. S:RT2]"" MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)=$$CJ^XLFSTR("<><><>",70)
.. S SQAM1="",MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)=RT1,RT2=RT1
. S XPDROUT(MCNT)=RT1
. I SQAM'=SQAM1 S MCNT=MCNT+1,XPMM(MCNT)="",MCNT=MCNT+1,XPMM(MCNT)=" "_SQAM_" "_$TR($J(" ",77-$L(SQAM))," ","."),SQAM1=SQAM
. ;S TXTC=$J(" ",5)_"LINE #"_$J(JJ,3)_" "_XPDSQA(RT1,SQAM,JJ)
. N TABME S TABME=ML-$L(TTAG) S:TTAG["+0" TABME=TABME+1
. S TXTC=$J(" ",3)_TTAG_$J(" ",TABME)_XPDSQA(RT1,SQAM,JJ,TTAG)
. I $L(TXTC)<79 S MCNT=MCNT+1,XPMM(MCNT)=TXTC
. I $L(TXTC)>78 D CUTME(TXTC,3)
Q
TMPX(XLINE) ;
N NSP,PX,EXT S EXT=0,PX=$L(XLINE,"^XTMP(") F I=2:1:PX D
. S NSP=$P($P($P(XLINE,"^XTMP(",I),")"),",") I NSP]"" S XPDXRR(NSP)=ROU I $$NSPACE^XPDANLYZ6($$TRIM^XLFSTR(NSP,"LR",$C(34))) S TCHK=1
N ZN,JJ,POS,QNUM S JJ=1,ZN="" I XLINE?.E1"S ".E1"^XTMP(".E1",0)=".E1(1"^",1"_U_").E D
. N XXL S XXL=0 F I=2:1:PX S QNUM=0 D Q:EXT
.. S:ZN'[",0)=" JJ=XXL+1,ZN="" S POS=$F(XLINE,"XTMP(",JJ)-6 F XXL=POS:1:$L(XLINE) S:$E(XLINE,XXL)=$C(34) QNUM=QNUM+1 S ZN=ZN_$E(XLINE,XXL) Q:('QNUM#2)&($E(XLINE,XXL)=$C(32))
. Q:ZN']""
. I ZN]"" S XTMPARR($P($P(ZN,"(",2),","),ROU)=$P(ZN,"=")_"="_$P(XLINE,",0)=",2)
Q
TMP(XLINE) ;XPDTRR (all TMP) XPDKT (kill array)
N TTAB S TTAB=25 ;S:TAGME["+0" TTAB=26;
N FMTY,NSP,NSPT,PX,TLINE,T9,FTWP,EXT S PX=$L(XLINE,"^TMP(") F I=2:1:PX D Q:EXT
. S EXT=0,NSP="",FMTY=""
. S T9=$J(" ",2)_ROU_" "_TAGME,T9=T9_$J(" ",(TTAB-$L(T9))),TLINE=T9_XLINE
. S FMTY=$P($P(XLINE,"^TMP(",I),")"),NSP=$$TRIM^XLFSTR($P(FMTY,","),"LR",$C(34)),NSPT=T9_"^TMP("_FMTY_")"
. I (NSP']"")!(FMTY']"") Q
. N TWOP S TWOP=$$TRIM^XLFSTR($P(FMTY,",",2),"LR",$C(34)) S:$G(TWOP)']"" TWOP="0"
. Q:NSPT'["" Q:$L(NSPT)<2
. I XLINE["K ^TMP("_FMTY_")" D
.. S FTWP="^TMP("_NSP_","_TWOP S:$D(XPTK(FTWP)) XPTK(FTWP)=XPTK(FTWP)_"^"_ROU_" "_TAGME S:'$D(XPTK(FTWP)) XPTK(FTWP)=ROU_" "_TAGME
.. I $L(TLINE)<75 S TCNT=TCNT+1,XPDKT(NSP,TWOP,TCNT)=NSPT ;TLINE
.. I $L(TLINE)>74 D CUTME(NSPT,4) Q
. I $P(FMTY,",")="$J" S TCHK=1
. I $$NSPACE^XPDANLYZ6(NSP)&($P(FMTY,",",2)["$J") S TCHK=1
. I NSP]"" D
.. I $L(NSPT)<76 S XPDTRR(NSP,TWOP,TCNT)=NSPT
.. I $L(NSPT)>74 D CUTME(NSPT,5)
Q
;
KCOLON(XLINE) ;
N TC1,TCL,J,PP S TCL=$L(XLINE,"K:") F J=2:1:TCL S TC1=$P(XLINE,"K:",J) I TC1]"" D
. F PP=1:1:$L(TC1) I $E(TC1,PP)=$C(32) Q:$E(TC1,PP+1)'="^"&($E(TC1,PP+1)'="@") D
.. I 'XPDIS2,$E(TC1,PP+1)'="@" N TC2 S TC2="K:"_$E(TC1,PP+1,99) Q:$$KCHK(TC2,"K:")'=3
.. S XPDSQA(ROU,XPD1,K,TAGME)=XLINE S:XPDARRR(XPD1,JJ,0)]"" XPDARRR(XPD1,JJ,0)=XPDARRR(XPD1,JJ,0)_" "_K_"," S:XPDARRR(XPD1,JJ,0)']"" XPDARRR(XPD1,JJ,0)="Lines: "_K_"," Q
Q
;
MSQA(XLINE,SQAT) ;IO, %, $I
N SL S SL=($L(SQAT)+1)
S XLINE=" "_XLINE
N NSP,PX,EXT,END,J,XT,I,AA,BB S (END,XT,J)=0,PX=$L(XLINE,SQAT) F I=1:1:(PX-1) D Q:END
. N POS S POS=$F(XLINE,SQAT,J),J=POS,XT=0
. I SQAT="%" D Q:XT Q:END
.. I $E(XLINE,POS)?1P,$E(XLINE,(POS-SL))?1P S XT=1 Q ;IF ITEM SURRONDED BY PUNCTUATION (like "%"), SKIP IT
.. I $E(XLINE,POS)'?1U I $E(XLINE,(POS-SL))="=" S XT=1 Q ;Q IF SOMETHING = %
.. I $E(XLINE,POS)="=",$E(XLINE,-SL)?1P S XT=1 Q ;%= ALLOWED
.. I 'XT,'END,XLINE[$C(34) N I F I=1:2:($L(XLINE,$C(34))-1) I POS>$F(XLINE,$P(XLINE,$C(34),I)),POS<=$F(XLINE,$P(XLINE,$C(34),I+1)) S XT=1 Q
.. N PCT S PCT="" F AA=POS:1:$L(XLINE) Q:$E(XLINE,AA)'?1U S PCT=PCT_$E(XLINE,AA) ;GETS THE LETERS AFTER THE % LIKE %ZIS
.. I PCT]"" D
... I PCT="%ZIS" S XT=1 Q
... I "DRZ"[$E(XLINE,POS) S:PCT="DT" XT=1 S:PCT="DTC" XT=1 S:PCT="RCR" XT=1 S:PCT="ZIS" XT=1 S:PCT="ZTLOAD" XT=1 S:PCT="ZOSF" XT=1
.. S BB="" F AA=(POS-SL):-1:0 S:($E(XLINE,AA)="$")&($E(XLINE,AA-1)="$") XT=1 Q:XT I $E(XLINE,AA)=$C(32),$E(XLINE,AA-2)=$C(32) S BB=$E(XLINE,(AA-1)) S:"XDI"[BB XT=1 S:"SKNMR"[BB END=1 Q
. I SQAT="IO" D
.. I POS-SL=1 S XT=1 Q ;I $E(XLINE,POS)?1P I "UI"[$E(XLINE,(POS-(SL+1))) S XT=1 Q
.. I ($E(XLINE,POS)?1U)!($E(XLINE,(POS-SL))?1U) S XT=1 Q
.. S BB="" F AA=(POS-SL):-1:0 I $E(XLINE,AA)=$C(32),$E(XLINE,AA-2)=$C(32) S BB=$E(XLINE,(AA-1)) S:"UI"[BB XT=1 S:"SKN"[BB END=1 Q
. I SQAT="$I" N SP1 S SP1=(POS-SL) I ($E(XLINE,SP1,(SL+1))="$$")!($E(XLINE,POS)?1A) S XT=1 Q
. I SQAT="DIC(0)" D
.. I $F(XLINE,"FILE^DICN") D Q:XT
... N P1,P2,C1 S P1=$P(XLINE,"FILE^DICN"),P2=$P(XLINE,"FILE^DICN",2),C1=0 N XPDI F XPDI=P1,P2 D
.... N DO1,D2 S DO1=$F(XPDI,"DO") Q:'$G(DO1) S D2=(DO1-3),BB="" F AA=D2:-1:0 I $E(XPDI,AA)=$C(32),$E(XPDI,AA-2)=$C(32) S BB=$E(XPDI,(AA-1)) S:"K"[BB C1=C1+1 Q
... I C1>1 S XT=1 Q
... S END=1
.. Q:END
.. I '$F(XLINE,"FILE^DICN") D Q:XT
... N DO1,D1 S D1="",DO1=$F(XLINE,"DIC(0)=") F AA=DO1:1:$L(XLINE) Q:($E(XLINE,AA)=$C(32))!($E(XLINE,AA)=",") S D1=D1_$E(XLINE,AA)
... Q:D1']"" S:D1'["L" XT=1 Q:XT
... I D1["L" S:'$F(XLINE,"DLAYGO") END=1 Q:END N D2 S BB=0,D2=$F(XLINE,"DLAYGO") F AA=D2:1:$L(XLINE) Q:$E(XLINE,AA)=$C(32) I $E(XLINE,AA)="=" S BB=1
... I BB=1 S XT=1 Q
. Q:XT Q:END
. S END=1
Q END
;
KCHK(XLINE,REF) ;
;CHECK REF IS K ^ OR K: EXCLUDE K: @
N XPS,J,T,XPNUM,XPCON,PCON,END,FOP,FCP,TTT S END=0,PCON=""
S XPS=$L(XLINE,REF) F J=2:1:XPS S XPNUM=$P(XLINE,REF,J) D Q:END=3
K1 . S XPCON="",(END,FOP)=0,FCP=99 F T=1:1:$L(XPNUM) D Q:END=1!(END=3)
.. I $E(XPNUM,T)?1P S TTT=$E(XPNUM,T) D Q:END=1
... I TTT=",",T>FCP S XPCON="^"_$E(XPNUM,1,(T-1)),PCON=$E(XPNUM,(T+2),999),END=1 Q
... I $E(XPNUM,T)=")" S FCP=T,XPCON="^"_$E(XPNUM,1,T) I
... I (T>FCP)&(TTT=$C(32)) S END=1 Q
.. I XPCON']"" S XPCON=XPNUM
. I XPCON]"" D
.. I XPCON["^(" S END=1 Q
.. I (XPCON["^TMP")!(XPCON["^UTILITY") S END=1 Q
.. N INNER,OUTER,FP S OUTER=$P(XPCON,"("),INNER=$P($P(XPCON,"(",2),")"),FP=$P(INNER,",")
.. I $L(INNER,",")=1,FP="0" S END=3 Q
.. I $F(XPCON,"(")=0 S END=3 Q
.. Q:+FP<1 ;Q:FP'?.N
.. Q:$L(INNER,",")>2
.. I $D(^DIC(FP,0,"GL")),^DIC(FP,0,"GL")=(OUTER_"("_FP_",") I ($L(INNER,",")=1!($P(INNER,",",2)=0)) S END=3 Q
. Q:END=3
. I PCON]"" Q:$P(PCON," ")'["^" S XPNUM=$P(PCON,"^",2),PCON="" D K1
Q END
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDANLYZ5 14820 printed Dec 13, 2024@02:03:11 Page 2
XPDANLYZ5 ;OAK/RSF- BUILD ANALYZER ;10/28/22
+1 ;;8.0;KERNEL;**782**;Jul 10, 1995;Build 4
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
FILEME(ITEM) ;Output some build files
+1 if $GET(ITEM)<1
QUIT
+2 NEW XPFNAME,RME,NB
SET RME("*")="-"
SET NB=$$REPLACE^XLFSTR(XPDBN,.RME)
+3 IF ITEM=1
SET XPFNAME1="XPBA_Anal_"_NB_"_"_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)_".TXT"
SET XPFNAME=XPFNAME1
+4 IF ITEM=3
SET XPFNAME3="XPBA_Spell_"_NB_"_"_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)_".TXT"
SET XPFNAME=XPFNAME3
+5 IF ITEM=4
SET XPFNAME4="XPBA_SQA_"_NB_"_"_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)_".TXT"
SET XPFNAME=XPFNAME4
+6 NEW POP
+7 DO OPEN^%ZISH("XPBA",XPPATH,XPFNAME,"W")
+8 IF POP>0
Begin DoDot:1
+9 if XPDR=3
WRITE !,"Could not open "_XPFNAME_". Unable to write to file. "
QUIT
End DoDot:1
QUIT
+10 USE IO
+11 IF ITEM=1
DO BA
IF $DATA(XPBA1)
NEW LL
SET LL=0
FOR
SET LL=$ORDER(XPBA1(LL))
if 'LL
QUIT
WRITE !,XPBA1(LL)
+12 IF ITEM=3
DO SPELLST
+13 ;D SQALINES
IF ITEM=4
DO SQAMM
NEW LL
SET LL=0
FOR
SET LL=$ORDER(XPMM(LL))
if 'LL
QUIT
WRITE !,XPMM(LL)
+14 DO CLOSE^%ZISH("XPBA")
+15 QUIT
+16 ;
SPELLST ;
+1 if '$DATA(XPDMM)
QUIT
+2 WRITE !,"Text for Review/Spell Check, Build "_XPDBN_"; "_$$FMTE^XLFDT($$DT^XLFDT,"2D"),!
+3 NEW TTT
SET TTT=0
FOR
SET TTT=$ORDER(XPDMM(TTT))
if 'TTT
QUIT
WRITE !,XPDMM(TTT)
+4 QUIT
+5 ;
BA ;SET BA ARRAY
+1 NEW TMPT,LNUM
if '$DATA(XPDW)
QUIT
+2 NEW RR
SET RR=0
SET LNUM=0
FOR
SET RR=$ORDER(XPDW(RR))
if 'RR
QUIT
Begin DoDot:1
+3 IF $LENGTH(XPDW(RR))<80
SET LNUM=LNUM+1
SET XPBA1(LNUM)=XPDW(RR)
+4 IF '$TEST
DO CUTME(XPDW(RR),1)
End DoDot:1
+5 IF $DATA(XPBA1)
Begin DoDot:1
+6 SET LNUM=LNUM+1
SET XPBA1(LNUM)=""
+7 SET LNUM=LNUM+1
SET XPBA1(LNUM)=""
+8 SET LNUM=LNUM+1
SET XPBA1(LNUM)=$TRANSLATE($JUSTIFY("=",79)," ","=")
+9 SET LNUM=LNUM+1
SET XPBA1(LNUM)=""
+10 SET LNUM=LNUM+1
SET XPBA1(LNUM)=" This build may include references to components (i.e. Routines,"
+11 SET LNUM=LNUM+1
SET XPBA1(LNUM)=" Globals, etc.) outside the build namespace. Review and validate "
+12 SET LNUM=LNUM+1
SET XPBA1(LNUM)=" that all appropriate Integration Control Registrations (ICRs) "
+13 SET LNUM=LNUM+1
SET XPBA1(LNUM)=" exist for each external reference."
+14 SET LNUM=LNUM+1
SET XPBA1(LNUM)=""
+15 SET LNUM=LNUM+1
SET XPBA1(LNUM)=$TRANSLATE($JUSTIFY("=",79)," ","=")
End DoDot:1
+16 QUIT
CUTME(LTXT,IND) ;5 MAY BE OPEN
+1 ;get any preliminary spacing
+2 NEW RSF,RR
SET RSF=""
FOR RR=1:1:$LENGTH(LTXT)
if '($EXTRACT(LTXT,RR)?1" ")
QUIT
SET RSF=RSF_$EXTRACT(LTXT,RR)
+3 NEW T0,T1,T2
SET T0=LTXT
SET T1=""
SET T2=""
+4 ;REMOVE/SAVE PRELIMINARY SPACING
+5 IF RR>0
SET T0=$EXTRACT(LTXT,RR,99999)
+6 ;THIS IS THE LINE LENGTH ACCOUNTING FOR THE PRELIMINARY SPACES
NEW AL,LL,I
SET AL=(80-$LENGTH(RSF))
+7 if IND>2
SET AL=AL-1
A1 ;
+1 FOR I=AL:-1:(AL-20)
Begin DoDot:1
+2 IF $EXTRACT(T0,I)?1P
SET T1=RSF_$EXTRACT(T0,1,I)
SET T2=$EXTRACT(T0,(I+1),9999)
QUIT
+3 if T1]""
QUIT
End DoDot:1
if T1]""
QUIT
+4 if $LENGTH(T1)<2&(T1'?1(1U,1P))
QUIT
+5 if IND=1
SET LNUM=LNUM+1
SET XPBA1(LNUM)=T1
+6 ;W:IND=2 !,T1
+7 if IND=3
SET MCNT=MCNT+1
SET XPMM(MCNT)=T1
+8 if IND=4
SET TCNT=TCNT+1
SET XPDKT(NSP,TWOP,TCNT)=T1
+9 if IND=5
SET TCNT=TCNT+1
SET XPDTRR(NSP,TWOP,TCNT)=T1
+10 if $GET(T2)']""
QUIT
+11 NEW T3,E1
SET T3=RSF_T2
SET E1=0
+12 IF IND=1
Begin DoDot:1
+13 IF $LENGTH(T3)<80
SET LNUM=LNUM+1
SET XPBA1(LNUM)=T3
QUIT
+14 IF $LENGTH(T3)>79
SET T0=T2
KILL T1,T2,T3
SET T1=""
SET T2=""
SET E1=1
QUIT
End DoDot:1
if E1
GOTO A1
+15 IF IND=3
Begin DoDot:1
+16 ;I $L(T3)+13<79 S MCNT=MCNT+1,XPMM(MCNT)=$J(" ",12)_T3 Q
+17 ;I $L(T3)+13>78 S T0=$J(" ",12)_T2 K T1,T2,T3 S T1="",T2="",E1=1 Q
+18 IF $LENGTH(T3)+13<79
SET MCNT=MCNT+1
SET XPMM(MCNT)=$JUSTIFY(" ",ML+1)_T3
QUIT
+19 IF $LENGTH(T3)+13>78
SET T0=$JUSTIFY(" ",ML+1)_T2
KILL T1,T2,T3
SET T1=""
SET T2=""
SET E1=1
QUIT
End DoDot:1
if E1
GOTO A1
+20 IF IND=4
Begin DoDot:1
+21 ;($L(ROU)+14)
NEW PAD
SET PAD=24
+22 IF $LENGTH(T3)+PAD<79
SET TCNT=TCNT+1
SET XPDKT(NSP,TWOP,TCNT)=$JUSTIFY(" ",PAD)_T3
QUIT
+23 IF $LENGTH(T3)+PAD>78
SET T0=$JUSTIFY(" ",PAD)_T2
KILL T1,T2,T3
SET T1=""
SET T2=""
SET E1=1
QUIT
End DoDot:1
if E1
GOTO A1
+24 IF IND=5
Begin DoDot:1
+25 NEW PAD
SET PAD=24
+26 IF $LENGTH(T3)+PAD<79
SET TCNT=TCNT+1
SET XPDTRR(NSP,TWOP,TCNT)=$JUSTIFY(" ",PAD)_T3
QUIT
+27 IF $LENGTH(T3)+PAD>78
SET T0=$JUSTIFY(" ",PAD)_T2
KILL T1,T2,T3
SET T1=""
SET T2=""
SET E1=1
QUIT
End DoDot:1
if E1
GOTO A1
+28 QUIT
+29 ;
FSHOW ; called from menu and deletes Build Analyzer text files
+1 NEW XPPATH,XPDEL,J,END
SET XPPATH=$$PWD^%ZISH()
SET END=0
+2 WRITE @IOF
SET DIR(0)="F"
SET DIR("A",1)="Set the path to find the .TXT files"
SET DIR("A",2)="or accept the standard default."
+3 SET DIR("A",3)=""
SET DIR("A")="PATH"
SET DIR("B")=XPPATH
+4 SET DIR("?",1)="Full path specification where XPBA* files reside. Path up to, but not including,"
+5 SET DIR("?",2)="the filename. This includes any trailing slashes or brackets."
+6 SET DIR("?")=" "
+7 DO ^DIR
if $DATA(DTOUT)
SET END=1
if $DATA(DIRUT)
SET END=1
if END
QUIT
+8 SET XPPATH=Y
+9 KILL FILESPEC,XPFILE,XPF
SET FILESPEC("XPBA*")=""
+10 SET Y=$$LIST^%ZISH("","FILESPEC","XPFILE")
+11 WRITE !!,"Build Analyzer text files:",!
NEW K,L
SET K=" "
SET L=0
FOR
SET K=$ORDER(XPFILE(K))
if K']""
QUIT
SET L=L+1
SET XPF(L)=K
SET XPDEL(K)=""
WRITE !,$JUSTIFY(L,3),". ",K
+12 IF $GET(L)<1
WRITE @IOF,"There are no Build Analyzer files to delete.",!!
QUIT
+13 WRITE !!
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
+14 SET DIR("?")="Respond YES to delete the files listed above."
+15 SET DIR("A")="Delete all the files above"
+16 DO ^DIR
if $DATA(DTOUT)
QUIT
if $DATA(DIRUT)
QUIT
+17 IF Y=1
Begin DoDot:1
+18 SET J=$$DEL^%ZISH("",$NAME(XPDEL))
+19 IF J=1
WRITE !,"Deletions completed."
SET END=1
QUIT
+20 IF J=0
WRITE !,"Unable to complete deletions."
SET END=1
QUIT
End DoDot:1
if END
GOTO X1
+21 WRITE !!
KILL DIR
SET DIR(0)="L^1:"_L
+22 SET DIR("A")="Select number of file or files to delete"
+23 DO ^DIR
if $DATA(DTOUT)
GOTO X1
if $DATA(DIRUT)
GOTO X1
+24 NEW DME,DARR
SET DME=""
IF Y
SET DME=$$TRIM^XLFSTR(Y,"R",",")
Begin DoDot:1
+25 NEW PCE,KK
FOR KK=1:1:$LENGTH(DME,",")
SET PCE=$PIECE(DME,",",KK)
if '$GET(PCE)
QUIT
SET DARR(XPF(PCE))=""
End DoDot:1
+26 IF $DATA(DARR)
NEW J
SET J=$$DEL^%ZISH(XPPATH,$NAME(DARR))
+27 IF J=1
WRITE !,"Deletions completed."
+28 IF J=0
WRITE !,"Unable to complete deletions."
X1 KILL FILESPEC,XPFILE,XPF
QUIT
+1 ;
PB1 ;FOR BUILD
+1 SET XPDCNT=XPDCNT+1
SET XPDW(XPDCNT)=""
+2 SET XPDCNT=XPDCNT+1
SET XPDW(XPDCNT)=XPDARR("BUILD",XPDBB,"NAME")_" BUILD OVERVIEW"
+3 SET XPDW(XPDCNT)=XPDW(XPDCNT)_$$RJ^XLFSTR($$FMTE^XLFDT($$NOW^XLFDT),79-$LENGTH(XPDW(XPDCNT))," ")
+4 SET XPDHR(XPDCNT)="BUILD OVERVIEW"
+5 SET XPDCNT=XPDCNT+1
SET XPDW(XPDCNT)=$TRANSLATE($JUSTIFY(" ",79)," ","-")
+6 NEW TMPTXT,XPDTX1
+7 SET XPDCS("FILES")="1"
+8 NEW XPDTX2
SET XPDTX2=" "
FOR
SET XPDTX2=$ORDER(XPDCS(XPDTX2))
if XPDTX2']""
QUIT
Begin DoDot:1
+9 SET XPDTX1=XPDTX2_$JUSTIFY(" ",(40-$LENGTH(XPDTX2)))
+10 SET TMPTXT="Not Included"
+11 IF '$DATA(XPDCAR(XPDCS(XPDTX2),0))
SET TMPTXT="Not Included"
+12 IF '$TEST
IF XPDCAR(XPDCS(XPDTX2),0)]""
SET TMPTXT="Included"
+13 IF XPDTX2="FILES"
IF $DATA(^XPD(9.6,XPDBB,4,"B"))>1
SET TMPTXT="Included"
+14 SET XPDCNT=XPDCNT+1
SET XPDW(XPDCNT)=XPDTX1_TMPTXT
End DoDot:1
+15 ;,XPDW(XPDCNT)=$TR($J(" ",70)," ","-")
SET XPDCNT=XPDCNT+1
+16 KILL XPDCS("FILES")
+17 QUIT
+18 ;
SQAMM ;
+1 NEW MCNT,ML,MR1
SET MCNT=0
+2 IF '$DATA(XPDSQA)
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=" *** No SQA issues were found in the included routines. ***"
QUIT
+3 ;^TMP
+4 IF $DATA(XPTK)
Begin DoDot:1
+5 NEW TWW,JL
SET MR1=0
SET TWW=" "
FOR
SET TWW=$ORDER(XPTK(TWW))
if TWW']""
QUIT
Begin DoDot:2
+6 SET JL=$LENGTH(XPTK(TWW),"^")
NEW II,SK
FOR II=1:1:JL
if $LENGTH($PIECE(XPTK(TWW),"^",II))>MR1
SET MR1=$LENGTH($PIECE(XPTK(TWW),"^",II))
End DoDot:2
+7 SET MR1=MR1+2
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)="These ^TMP calls have kill statements within the included routines:"
Begin DoDot:2
+8 NEW WWW,JK,JL
SET (WWW,JK)=" "
SET JL=0
FOR
SET WWW=$ORDER(XPTK(WWW))
if WWW']""
QUIT
Begin DoDot:3
+9 SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=WWW
SET JL=$LENGTH(XPTK(WWW),"^")
NEW II,SK
FOR II=1:1:JL
SET SK=$PIECE(XPTK(WWW),"^",II)
SET MCNT=MCNT+1
SET XPMM(MCNT)=$JUSTIFY(" ",10)_$PIECE(SK," ")_$JUSTIFY(" ",(MR1-($LENGTH($PIECE(SK," "))+10)))_$PIECE(SK," ",2,99)
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF $DATA(XPDKT)
Begin DoDot:1
+11 NEW NSP,NSP1
SET (NSP,NSP1)=" "
FOR
SET NSP=$ORDER(XPDTRR(NSP))
if NSP']""
QUIT
FOR
SET NSP1=$ORDER(XPDTRR(NSP,NSP1))
if NSP1']""
QUIT
if $DATA(XPDKT(NSP,NSP1))
KILL XPDTRR(NSP,NSP1)
+12 IF $DATA(XPDTRR)
Begin DoDot:2
+13 SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)="These ^TMP calls have no associated kill in this build's included routines:"
+14 NEW JK,JL
SET (NSP,JK)=" "
SET JL=0
FOR
SET NSP=$ORDER(XPDTRR(NSP))
if NSP']""
QUIT
FOR
SET JK=$ORDER(XPDTRR(NSP,JK))
if JK']""
QUIT
FOR
SET JL=$ORDER(XPDTRR(NSP,JK,JL))
if 'JL
QUIT
SET MCNT=MCNT+1
SET XPMM(MCNT)=XPDTRR(NSP,JK,JL)
End DoDot:2
+15 IF '$DATA(XPDTRR)
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)="All ^TMP calls have at least one kill statement in this build's routines."
End DoDot:1
+16 ;^XTMP
+17 NEW RRR,XRRR
SET RRR=" "
SET XRRR=""
FOR
SET RRR=$ORDER(XPDXRR(RRR))
if RRR']""
QUIT
IF '$DATA(XTMPARR(RRR))
SET XRRR=XRRR_"^"_RRR
+18 IF $DATA(XTMPARR)
Begin DoDot:1
+19 SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)="General ^XTMP Notes"
+20 SET MCNT=MCNT+1
SET XPMM(MCNT)="These ^XTMP calls have zero nodes defined in this build's included routines:"
+21 NEW WWW,BBB
SET (WWW,BBB)=" "
FOR
SET WWW=$ORDER(XTMPARR(WWW))
if WWW']""
QUIT
FOR
SET BBB=$ORDER(XTMPARR(WWW,BBB))
if BBB']""
QUIT
Begin DoDot:2
+22 NEW XLNE
SET XLNE=$JUSTIFY(" ",5)_"Routine: "_BBB_$JUSTIFY(" ",5)_XTMPARR(WWW,BBB)
+23 IF $LENGTH(XLNE)<79
SET MCNT=MCNT+1
SET XPMM(MCNT)=XLNE
+24 IF $LENGTH(XLNE)>78
SET ML=$LENGTH("Routine: "_BBB_$JUSTIFY(" ",5))
DO CUTME(XLNE,3)
End DoDot:2
End DoDot:1
+25 IF XRRR]""
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)="These ^XTMP calls have no zero nodes defined in this build's included routines"
Begin DoDot:1
+26 NEW LLL
FOR LLL=2:1:$LENGTH(XRRR,"^")
SET MCNT=MCNT+1
SET XPMM(MCNT)=$JUSTIFY(" ",5)_"Routine: "_XPDXRR($PIECE(XRRR,"^",LLL))_$JUSTIFY(" ",5)_"^XTMP("_$PIECE(XRRR,"^",LLL)
End DoDot:1
+27 IF XRRR']""
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)="ALL ^XTMP calls have zero nodes defined in this build's routines"
+28 NEW RT1,RT2,SQAM,SQAM1,JJ,TXTC,TTAG
SET JJ=0
SET (RT1,RT2,SQAM1)=""
SET ML=XPTL+3
+29 FOR
SET RT1=$ORDER(XPDSQA(RT1))
if RT1']""
QUIT
SET SQAM=" "
FOR
SET SQAM=$ORDER(XPDSQA(RT1,SQAM))
if SQAM']""
QUIT
FOR
SET JJ=$ORDER(XPDSQA(RT1,SQAM,JJ))
if 'JJ
QUIT
Begin DoDot:1
+30 ;S:TTAG["+0" TTAG=TTAG_" "
SET XPDROUT(0)=""
SET TTAG=" "
SET TTAG=$ORDER(XPDSQA(RT1,SQAM,JJ,TTAG))
if TTAG']""
QUIT
+31 IF RT1'=RT2
Begin DoDot:2
+32 if RT2]""
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=$$CJ^XLFSTR("<><><>",70)
+33 SET SQAM1=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=RT1
SET RT2=RT1
End DoDot:2
+34 SET XPDROUT(MCNT)=RT1
+35 IF SQAM'=SQAM1
SET MCNT=MCNT+1
SET XPMM(MCNT)=""
SET MCNT=MCNT+1
SET XPMM(MCNT)=" "_SQAM_" "_$TRANSLATE($JUSTIFY(" ",77-$LENGTH(SQAM))," ",".")
SET SQAM1=SQAM
+36 ;S TXTC=$J(" ",5)_"LINE #"_$J(JJ,3)_" "_XPDSQA(RT1,SQAM,JJ)
+37 NEW TABME
SET TABME=ML-$LENGTH(TTAG)
if TTAG["+0"
SET TABME=TABME+1
+38 SET TXTC=$JUSTIFY(" ",3)_TTAG_$JUSTIFY(" ",TABME)_XPDSQA(RT1,SQAM,JJ,TTAG)
+39 IF $LENGTH(TXTC)<79
SET MCNT=MCNT+1
SET XPMM(MCNT)=TXTC
+40 IF $LENGTH(TXTC)>78
DO CUTME(TXTC,3)
End DoDot:1
+41 QUIT
TMPX(XLINE) ;
+1 NEW NSP,PX,EXT
SET EXT=0
SET PX=$LENGTH(XLINE,"^XTMP(")
FOR I=2:1:PX
Begin DoDot:1
+2 SET NSP=$PIECE($PIECE($PIECE(XLINE,"^XTMP(",I),")"),",")
IF NSP]""
SET XPDXRR(NSP)=ROU
IF $$NSPACE^XPDANLYZ6($$TRIM^XLFSTR(NSP,"LR",$CHAR(34)))
SET TCHK=1
End DoDot:1
+3 NEW ZN,JJ,POS,QNUM
SET JJ=1
SET ZN=""
IF XLINE?.E1"S ".E1"^XTMP(".E1",0)=".E1(1"^",1"_U_").E
Begin DoDot:1
+4 NEW XXL
SET XXL=0
FOR I=2:1:PX
SET QNUM=0
Begin DoDot:2
+5 if ZN'[",0)="
SET JJ=XXL+1
SET ZN=""
SET POS=$FIND(XLINE,"XTMP(",JJ)-6
FOR XXL=POS:1:$LENGTH(XLINE)
if $EXTRACT(XLINE,XXL)=$CHAR(34)
SET QNUM=QNUM+1
SET ZN=ZN_$EXTRACT(XLINE,XXL)
if ('QNUM#2)&($EXTRACT(XLINE,XXL)=$CHAR(32))
QUIT
End DoDot:2
if EXT
QUIT
+6 if ZN']""
QUIT
+7 IF ZN]""
SET XTMPARR($PIECE($PIECE(ZN,"(",2),","),ROU)=$PIECE(ZN,"=")_"="_$PIECE(XLINE,",0)=",2)
End DoDot:1
+8 QUIT
TMP(XLINE) ;XPDTRR (all TMP) XPDKT (kill array)
+1 ;S:TAGME["+0" TTAB=26;
NEW TTAB
SET TTAB=25
+2 NEW FMTY,NSP,NSPT,PX,TLINE,T9,FTWP,EXT
SET PX=$LENGTH(XLINE,"^TMP(")
FOR I=2:1:PX
Begin DoDot:1
+3 SET EXT=0
SET NSP=""
SET FMTY=""
+4 SET T9=$JUSTIFY(" ",2)_ROU_" "_TAGME
SET T9=T9_$JUSTIFY(" ",(TTAB-$LENGTH(T9)))
SET TLINE=T9_XLINE
+5 SET FMTY=$PIECE($PIECE(XLINE,"^TMP(",I),")")
SET NSP=$$TRIM^XLFSTR($PIECE(FMTY,","),"LR",$CHAR(34))
SET NSPT=T9_"^TMP("_FMTY_")"
+6 IF (NSP']"")!(FMTY']"")
QUIT
+7 NEW TWOP
SET TWOP=$$TRIM^XLFSTR($PIECE(FMTY,",",2),"LR",$CHAR(34))
if $GET(TWOP)']""
SET TWOP="0"
+8 if NSPT'[""
QUIT
if $LENGTH(NSPT)<2
QUIT
+9 IF XLINE["K ^TMP("_FMTY_")"
Begin DoDot:2
+10 SET FTWP="^TMP("_NSP_","_TWOP
if $DATA(XPTK(FTWP))
SET XPTK(FTWP)=XPTK(FTWP)_"^"_ROU_" "_TAGME
if '$DATA(XPTK(FTWP))
SET XPTK(FTWP)=ROU_" "_TAGME
+11 ;TLINE
IF $LENGTH(TLINE)<75
SET TCNT=TCNT+1
SET XPDKT(NSP,TWOP,TCNT)=NSPT
+12 IF $LENGTH(TLINE)>74
DO CUTME(NSPT,4)
QUIT
End DoDot:2
+13 IF $PIECE(FMTY,",")="$J"
SET TCHK=1
+14 IF $$NSPACE^XPDANLYZ6(NSP)&($PIECE(FMTY,",",2)["$J")
SET TCHK=1
+15 IF NSP]""
Begin DoDot:2
+16 IF $LENGTH(NSPT)<76
SET XPDTRR(NSP,TWOP,TCNT)=NSPT
+17 IF $LENGTH(NSPT)>74
DO CUTME(NSPT,5)
End DoDot:2
End DoDot:1
if EXT
QUIT
+18 QUIT
+19 ;
KCOLON(XLINE) ;
+1 NEW TC1,TCL,J,PP
SET TCL=$LENGTH(XLINE,"K:")
FOR J=2:1:TCL
SET TC1=$PIECE(XLINE,"K:",J)
IF TC1]""
Begin DoDot:1
+2 FOR PP=1:1:$LENGTH(TC1)
IF $EXTRACT(TC1,PP)=$CHAR(32)
if $EXTRACT(TC1,PP+1)'="^"&($EXTRACT(TC1,PP+1)'="@")
QUIT
Begin DoDot:2
+3 IF 'XPDIS2
IF $EXTRACT(TC1,PP+1)'="@"
NEW TC2
SET TC2="K:"_$EXTRACT(TC1,PP+1,99)
if $$KCHK(TC2,"K
QUIT
+4 SET XPDSQA(ROU,XPD1,K,TAGME)=XLINE
if XPDARRR(XPD1,JJ,0)]""
SET XPDARRR(XPD1,JJ,0)=XPDARRR(XPD1,JJ,0)_" "_K_","
if XPDARRR(XPD1,JJ,0)']""
SET XPDARRR(XPD1,JJ,0)="Lines: "_K_","
QUIT
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
MSQA(XLINE,SQAT) ;IO, %, $I
+1 NEW SL
SET SL=($LENGTH(SQAT)+1)
+2 SET XLINE=" "_XLINE
+3 NEW NSP,PX,EXT,END,J,XT,I,AA,BB
SET (END,XT,J)=0
SET PX=$LENGTH(XLINE,SQAT)
FOR I=1:1:(PX-1)
Begin DoDot:1
+4 NEW POS
SET POS=$FIND(XLINE,SQAT,J)
SET J=POS
SET XT=0
+5 IF SQAT="%"
Begin DoDot:2
+6 ;IF ITEM SURRONDED BY PUNCTUATION (like "%"), SKIP IT
IF $EXTRACT(XLINE,POS)?1P
IF $EXTRACT(XLINE,(POS-SL))?1P
SET XT=1
QUIT
+7 ;Q IF SOMETHING = %
IF $EXTRACT(XLINE,POS)'?1U
IF $EXTRACT(XLINE,(POS-SL))="="
SET XT=1
QUIT
+8 ;%= ALLOWED
IF $EXTRACT(XLINE,POS)="="
IF $EXTRACT(XLINE,-SL)?1P
SET XT=1
QUIT
+9 IF 'XT
IF 'END
IF XLINE[$CHAR(34)
NEW I
FOR I=1:2:($LENGTH(XLINE,$CHAR(34))-1)
IF POS>$FIND(XLINE,$PIECE(XLINE,$CHAR(34),I))
IF POS<=$FIND(XLINE,$PIECE(XLINE,$CHAR(34),I+1))
SET XT=1
QUIT
+10 ;GETS THE LETERS AFTER THE % LIKE %ZIS
NEW PCT
SET PCT=""
FOR AA=POS:1:$LENGTH(XLINE)
if $EXTRACT(XLINE,AA)'?1U
QUIT
SET PCT=PCT_$EXTRACT(XLINE,AA)
+11 IF PCT]""
Begin DoDot:3
+12 IF PCT="%ZIS"
SET XT=1
QUIT
+13 IF "DRZ"[$EXTRACT(XLINE,POS)
if PCT="DT"
SET XT=1
if PCT="DTC"
SET XT=1
if PCT="RCR"
SET XT=1
if PCT="ZIS"
SET XT=1
if PCT="ZTLOAD"
SET XT=1
if PCT="ZOSF"
SET XT=1
End DoDot:3
+14 SET BB=""
FOR AA=(POS-SL):-1:0
if ($EXTRACT(XLINE,AA)="$")&($EXTRACT(XLINE,AA-1)="$")
SET XT=1
if XT
QUIT
IF $EXTRACT(XLINE,AA)=$CHAR(32)
IF $EXTRACT(XLINE,AA-2)=$CHAR(32)
SET BB=$EXTRACT(XLINE,(AA-1))
if "XDI"[BB
SET XT=1
if "SKNMR"[BB
SET END=1
QUIT
End DoDot:2
if XT
QUIT
if END
QUIT
+15 IF SQAT="IO"
Begin DoDot:2
+16 ;I $E(XLINE,POS)?1P I "UI"[$E(XLINE,(POS-(SL+1))) S XT=1 Q
IF POS-SL=1
SET XT=1
QUIT
+17 IF ($EXTRACT(XLINE,POS)?1U)!($EXTRACT(XLINE,(POS-SL))?1U)
SET XT=1
QUIT
+18 SET BB=""
FOR AA=(POS-SL):-1:0
IF $EXTRACT(XLINE,AA)=$CHAR(32)
IF $EXTRACT(XLINE,AA-2)=$CHAR(32)
SET BB=$EXTRACT(XLINE,(AA-1))
if "UI"[BB
SET XT=1
if "SKN"[BB
SET END=1
QUIT
End DoDot:2
+19 IF SQAT="$I"
NEW SP1
SET SP1=(POS-SL)
IF ($EXTRACT(XLINE,SP1,(SL+1))="$$")!($EXTRACT(XLINE,POS)?1A)
SET XT=1
QUIT
+20 IF SQAT="DIC(0)"
Begin DoDot:2
+21 IF $FIND(XLINE,"FILE^DICN")
Begin DoDot:3
+22 NEW P1,P2,C1
SET P1=$PIECE(XLINE,"FILE^DICN")
SET P2=$PIECE(XLINE,"FILE^DICN",2)
SET C1=0
NEW XPDI
FOR XPDI=P1,P2
Begin DoDot:4
+23 NEW DO1,D2
SET DO1=$FIND(XPDI,"DO")
if '$GET(DO1)
QUIT
SET D2=(DO1-3)
SET BB=""
FOR AA=D2:-1:0
IF $EXTRACT(XPDI,AA)=$CHAR(32)
IF $EXTRACT(XPDI,AA-2)=$CHAR(32)
SET BB=$EXTRACT(XPDI,(AA-1))
if "K"[BB
SET C1=C1+1
QUIT
End DoDot:4
+24 IF C1>1
SET XT=1
QUIT
+25 SET END=1
End DoDot:3
if XT
QUIT
+26 if END
QUIT
+27 IF '$FIND(XLINE,"FILE^DICN")
Begin DoDot:3
+28 NEW DO1,D1
SET D1=""
SET DO1=$FIND(XLINE,"DIC(0)=")
FOR AA=DO1:1:$LENGTH(XLINE)
if ($EXTRACT(XLINE,AA)=$CHAR(32))!($EXTRACT(XLINE,AA)=",")
QUIT
SET D1=D1_$EXTRACT(XLINE,AA)
+29 if D1']""
QUIT
if D1'["L"
SET XT=1
if XT
QUIT
+30 IF D1["L"
if '$FIND(XLINE,"DLAYGO")
SET END=1
if END
QUIT
NEW D2
SET BB=0
SET D2=$FIND(XLINE,"DLAYGO")
FOR AA=D2:1:$LENGTH(XLINE)
if $EXTRACT(XLINE,AA)=$CHAR(32)
QUIT
IF $EXTRACT(XLINE,AA)="="
SET BB=1
+31 IF BB=1
SET XT=1
QUIT
End DoDot:3
if XT
QUIT
End DoDot:2
+32 if XT
QUIT
if END
QUIT
+33 SET END=1
End DoDot:1
if END
QUIT
+34 QUIT END
+35 ;
KCHK(XLINE,REF) ;
+1 ;CHECK REF IS K ^ OR K: EXCLUDE K: @
+2 NEW XPS,J,T,XPNUM,XPCON,PCON,END,FOP,FCP,TTT
SET END=0
SET PCON=""
+3 SET XPS=$LENGTH(XLINE,REF)
FOR J=2:1:XPS
SET XPNUM=$PIECE(XLINE,REF,J)
Begin DoDot:1
K1 SET XPCON=""
SET (END,FOP)=0
SET FCP=99
FOR T=1:1:$LENGTH(XPNUM)
Begin DoDot:2
+1 IF $EXTRACT(XPNUM,T)?1P
SET TTT=$EXTRACT(XPNUM,T)
Begin DoDot:3
+2 IF TTT=","
IF T>FCP
SET XPCON="^"_$EXTRACT(XPNUM,1,(T-1))
SET PCON=$EXTRACT(XPNUM,(T+2),999)
SET END=1
QUIT
+3 IF $EXTRACT(XPNUM,T)=")"
SET FCP=T
SET XPCON="^"_$EXTRACT(XPNUM,1,T)
IF $TEST
+4 IF (T>FCP)&(TTT=$CHAR(32))
SET END=1
QUIT
End DoDot:3
if END=1
QUIT
+5 IF XPCON']""
SET XPCON=XPNUM
End DoDot:2
if END=1!(END=3)
QUIT
+6 IF XPCON]""
Begin DoDot:2
+7 IF XPCON["^("
SET END=1
QUIT
+8 IF (XPCON["^TMP")!(XPCON["^UTILITY")
SET END=1
QUIT
+9 NEW INNER,OUTER,FP
SET OUTER=$PIECE(XPCON,"(")
SET INNER=$PIECE($PIECE(XPCON,"(",2),")")
SET FP=$PIECE(INNER,",")
+10 IF $LENGTH(INNER,",")=1
IF FP="0"
SET END=3
QUIT
+11 IF $FIND(XPCON,"(")=0
SET END=3
QUIT
+12 ;Q:FP'?.N
if +FP<1
QUIT
+13 if $LENGTH(INNER,",")>2
QUIT
+14 IF $DATA(^DIC(FP,0,"GL"))
IF ^DIC(FP,0,"GL")=(OUTER_"("_FP_",")
IF ($LENGTH(INNER,",")=1!($PIECE(INNER,",",2)=0))
SET END=3
QUIT
End DoDot:2
+15 if END=3
QUIT
+16 IF PCON]""
if $PIECE(PCON," ")'["^"
QUIT
SET XPNUM=$PIECE(PCON,"^",2)
SET PCON=""
DO K1
End DoDot:1
if END=3
QUIT
+17 QUIT END
+18 ;
