XPDANLYZ2 ;OAK/RSF- BUILD ANALYZER ;10/28/22
;;8.0;KERNEL;**782,792**;Jul 10, 1995;Build 4
;;Per VHA Directive 2004-038, this routine should not be modified.
;
XREF ;XREF
Q:'FXX
S XPDARR("FILE",FXX,"XREF")="No"
I $D(^DD(FXX,0,"IX")) D
. S XPDARR("FILE",FXX,"XREF")="Yes"
. N JJ,LL,MM,RSF S JJ="",(LL,MM)=0 F S JJ=$O(^DD(FXX,0,"IX",JJ)) Q:$G(JJ)']"" F S LL=$O(^DD(FXX,0,"IX",JJ,LL)) Q:'$G(LL) D
.. F S MM=$O(^DD(FXX,0,"IX",JJ,LL,MM)) Q:'$G(MM) D
... Q:(JJ="B") ;&(MM=.01)
... N PP S PP=0,RSF="field" F S PP=$O(^DD(LL,MM,1,PP)) Q:'PP S:LL'=FXX RSF="subfield " D
.... I JJ=$P(^DD(LL,MM,1,PP,0),"^",2),'$D(^DD(LL,MM,1,PP,"%D")) S XPDARR("FILE",FXX,MM,"WARNING","XREF")=$P(^DD(LL,MM,1,PP,0),"^",2)_" cross-reference ("_RSF_" #"_MM_") - DESCRIPTION missing."
Q
;
;OPTION
OPTME ;Option Analysis called from START^XPDANLYZ1
N XPDOARR,KK S KK=0 ;XPDRC=2 IS OPTION
N DIRUT,Y K DIR S DIR(0)="YO",DIR("A")="Do you want to analyze all options for a namespace"
S DIR("?")="Will use a range of options whose name starts with a series of letters - usually the namespace (i.e. TIU)"
D ^DIR I $D(DIRUT) S END=1 Q
N XPDY S XPDY=Y
G1 I XPDY=0 W ! D
. N DIC,Y S DIC=19,DIC(0)="QEAM",DIC("A")="Select individual options by name: "
. D ^DIC I Y=-1 K DIC S XPDY=99,END=1 Q
. ;I $D(DUOUT) K DIC Q ;-1 LIKE ABOVE
. I $D(DTOUT) S XPDY=99,END=1 Q
. I $G(Y)]"" S XPDOARR($P(Y,"^"))=$P(Y,"^",2),KK=KK+1 ;OPTION ien ^ NAME
G:XPDY=0 G1
I XPDY=1 N XPDPKG,XPDPKGL D G:END X1^XPDANLYZ1
. W ! N DIRUT K DIR S DIR(0)="FO^2:10",DIR("?")="Enter the Package for the options to include"
. S DIR("A")="Enter the package abbreviation or leading characters of options to include"
. D ^DIR
. I $D(DIRUT) S END=1 Q
. I $G(Y)]"" S XPDPKG=$$UP^XLFSTR(Y),XPDPKGL=$L(XPDPKG) Q:'$G(XPDPKGL) ;** CONFRIM ALL SHOULD BE UPPERCASE
. N JJ S JJ="",KK=0 F S JJ=$O(^DIC(19,"B",JJ)) Q:$G(JJ)']"" I $E(JJ,1,XPDPKGL)=XPDPKG S XPDOARR($O(^DIC(19,"B",JJ,0)))=JJ,KK=KK+1
I $G(KK)>1 D
. W !!,"Will check these ",KK," options:"
. N JJ S JJ=0 F S JJ=$O(XPDOARR(JJ)) Q:'JJ W !,?5,XPDOARR(JJ) I ($Y+5)>IOSL D HDR^XPDANLYZ1("Options (continued): ") Q:END
. W !!,?5,",, WORKING .."
I $D(XPDOARR) D OCHK(.XPDOARR)
Q
OCHK(XPDORR) ;setting up information to check OPTIONS ENTRY/EXIT for files and routines.
N JJ,XPDIENS S JJ=0 F S JJ=$O(XPDORR(JJ)) Q:'JJ D
. N TARR S XPDIENS=JJ_"," D GETS^DIQ(19,XPDIENS,"**","N","TARR") I $D(TARR) D
.. S XPDARR("OPTION",JJ,"NAME")=XPDORR(JJ)
.. I '$D(TARR(19,XPDIENS,3.5)) S XPDARR("OPTION",JJ,"DESCRIPT")="No",XPDARR("OPTION",JJ,"WARNING","DESCRIPTION")="DESCRIPTION field (#3.5) missing."
.. I $D(TARR(19,XPDIENS,3.5)) S XPDARR("OPTION",JJ,"DESCRIPT")="Yes" N LL S LL=0 F S LL=$O(TARR(19,XPDIENS,3.5,LL)) Q:'LL S XPDARR("OPTION",JJ,"DESCRIPTION",LL)=TARR(19,XPDIENS,3.5,LL)
.. I $D(TARR(19,XPDIENS,1)) S XPDARR("OPTION",JJ,"Menu")=TARR(19,XPDIENS,1)
.. I '$D(TARR(19,XPDIENS,1)) S XPDARR("OPTION",JJ,"WARNING","MENU TXT")="MENU TEXT field (#1) missing."
.. I '$D(TARR(19,XPDIENS,12)) S XPDARR("OPTION",JJ,"WARNING","PKG")="PACKAGE field (#12) missing."
.. I $D(TARR(19,XPDIENS,12)) S XPDARR("OPTION",JJ,"PKG")=TARR(19,XPDIENS,12)
.. ; 25 IS ROUTINE AND IS TAG^ROUTINE
.. I $D(TARR(19,XPDIENS,25)) N TT,RR S TT=$L(TARR(19,XPDIENS,25),"^") Q:$G(TT)']"" S RR=$P(TARR(19,XPDIENS,25),"^",TT) S:RR["(" RR=$P(RR,"(") D
... S XPOPT(JJ,"ROU",RR)="ROUTINE field(#25):"
... ;S XPDARR("OPTION",JJ,"WARNING",RR)="Calls routine "_RR_" not found in build"
... ;I $E(RR,1,$L(XPDSPC))'=XPDSPC S XPDARR("OPTION",JJ,"WARNING",RR_"Z")="Calls routine "_RR_" not in patch namespace."
Q:XPDRC=4
S XPDCS("OPTION")=19
OPX K DIC Q
;
RPCHK ; RPC Analysis called XPDANLYZ1
N XPDCARR,KK S KK=0 ;XPDRC=4 IS RPC
N DIRUT K DIR S DIR(0)="YO",DIR("A")="Do you want to analyze all RPCs for a namespace"
S DIR("?")="Will use a range of RPCs whose name starts with a series of letters - usually the namespace (i.e. TIU)"
D ^DIR I $D(DIRUT) S END=1 Q
N XPDY S XPDY=Y
RPC1 I XPDY=0 W ! D
. N DIC S DIC=8994,DIC(0)="QEAM",DIC("A")="Select individual RPCs by name: "
. D ^DIC I Y=-1 K DIC S XPDY=99 Q
. I $D(DTOUT) S XPDY=99 Q
. I $G(Y)]"" S XPDCARR($P(Y,"^"))=$P(Y,"^",2),KK=KK+1 ;RPC ien ^ NAME
G:XPDY=0 RPC1
I XPDY=1 N XPDPKG,XPDPKGL D G:END X1^XPDANLYZ1
. W ! N DIRUT K DIR S DIR(0)="FO^2:10",DIR("?")="Enter the Package for the RPCs"
. S DIR("A")="Enter the package abbreviation or leading characters of RPCs to include"
. D ^DIR
. I $D(DIRUT) Q
. I $G(Y)]"" S XPDPKG=$$UP^XLFSTR(Y),XPDPKGL=$L(XPDPKG) Q:'$G(XPDPKGL) ;** CONFRIM ALL SHOULD BE UPPERCASE
. N JJ S JJ="",KK=0 F S JJ=$O(^XWB(8994,"B",JJ)) Q:$G(JJ)']"" I $E(JJ,1,XPDPKGL)=XPDPKG S XPDCARR($O(^XWB(8994,"B",JJ,0)))=JJ,KK=KK+1
I $G(KK)>1 D
. W !!,"Will check these ",KK," Remote Procedure Calls"
. N JJ S JJ=0 F S JJ=$O(XPDCARR(JJ)) Q:'JJ W !,?5,XPDCARR(JJ) I ($Y+5)>IOSL D HDR^XPDANLYZ1("RPC (continued): ") Q:END
. W !!,?5,",, WORKING .."
I $D(XPDCARR) D RPC2(.XPDCARR)
Q
RPC2(XPDRPC) ;^XWB(8994,; Remote Procedure check
Q:'$D(XPDRPC)
N JJ,XPDIENS S JJ=0 F S JJ=$O(XPDRPC(JJ)) Q:'JJ D
. N TARR S XPDIENS=JJ_"," D GETS^DIQ(8994,XPDIENS,"**","NR","TARR") I $D(TARR) D
.. S XPDARR("REMOTE PROCEDURE",JJ,"NAME")=XPDRPC(JJ)
.. I '$D(TARR(8994,XPDIENS,"DESCRIPTION")) S XPDARR("REMOTE PROCEDURE",JJ,"DESCRIPT")="No",XPDARR("REMOTE PROCEDURE",JJ,"WARNING","DESCRIPTION")="DESCRIPTION field (#1) missing."
.. I $D(TARR(8994,XPDIENS,"DESCRIPTION")) S XPDARR("REMOTE PROCEDURE",JJ,"DESCRIPT")="Yes" N LL S LL=0 F S LL=$O(TARR(8994,XPDIENS,"DESCRIPTION",LL)) Q:'LL S XPDARR("REMOTE PROCEDURE",JJ,"DESCRIPTION",LL)=TARR(8994,XPDIENS,"DESCRIPTION",LL)
.. ;RETURN PARAMETERS
.. I $D(TARR(8994,XPDIENS,"RETURN VALUE TYPE")),'$D(TARR(8994,XPDIENS,"RETURN PARAMETER DESCRIPTION")) S XPDARR("REMOTE PROCEDURE",JJ,"WARNING","RETURN DESCRIPTION")="RPC RETURN DESCRIPTION field (#3) missing."
.. ;INPUT
.. I $D(^XWB(8994,JJ,2,0)) N XPDIP S XPDIP=$P(^XWB(8994,JJ,2,0),"^",4) Q:$G(XPDIP)<1 D
... N MM F MM=1:1:XPDIP I '$D(TARR(8994.02,MM_","_XPDIENS,"DESCRIPTION")) N LL D ;p792
.... S LL=MM I '$D(TARR(8994.02,MM_","_XPDIENS)) S LL=$P($O(TARR(8994.02,MM_","_XPDIENS)),",") S:LL="" LL=MM I $D(TARR(8994.02,LL_","_XPDIENS,"DESCRIPTION")) Q
.... S XPDARR("REMOTE PROCEDURE",JJ,"WARNING","INPUT DESCRIPTION")="RPC Input Description for "_$G(TARR(8994.02,LL_","_XPDIENS,"INPUT PARAMETER"))_" missing."
.. I $D(TARR(8994,XPDIENS,"ROUTINE")) N RRR S RRR=TARR(8994,XPDIENS,"ROUTINE") D
... S XPDARR("REMOTE PROCEDURE",JJ,"ROUTINE",RRR)="Routine field (#.03): Calls "_RRR_" not found in build."
... ;I $E(RRR,1,$L(XPDSPC))'=XPDSPC S XPDARR("REMOTE PROCEDURE",JJ,"WARNING",RRR_"Z")="Routine field (#.03): Calls "_RRR_" not in patch namespace."
Q:XPDRC=4
S XPDCS("REMOTE PROCEDURE")=8994
RPCX K DIC Q
;
SQA(RR) ;Sets SQA CL array XPDARRR
S XPDARRR("////",RR,0)=""
S XPDARRR("DIC(0)",RR,0)=""
S XPDARRR("^UTILITY",RR,0)=""
S XPDARRR("^TMP",RR,0)=""
S XPDARRR("^XTMP",RR,0)=""
S XPDARRR("%",RR,0)=""
S XPDARRR("$I",RR,0)=""
S XPDARRR("U=",RR,0)=""
S XPDARRR("K ^",RR,0)=""
S XPDARRR("K:",RR,0)=""
S XPDARRR("K @",RR,0)=""
S XPDARRR("^(",RR,0)=""
S XPDARRR("IO",RR,0)=""
Q
;
FMSG(XPDBT) ;
N XPDUZ S XPDUZ=$G(DUZ) Q:'$G(DUZ)
K ^TMP("XPDEM",$J)
N XMCRIT S XMCRIT("SUBJ")=XPDBT
D LISTMSGS^XMXAPIB(XPDUZ,"*","SUBJ;DATE;F","B",,,.XMCRIT,"^TMP(""XPDEM"",$J)")
I $D(^TMP("XPDEM",$J)) D
. N JKL,XPDNIEN S JKL=$O(^TMP("XPDEM",$J,"XMLIST",0)) Q:'$G(JKL) S XPDNIEN=^TMP("XPDEM",$J,"XMLIST",JKL)
. ;W !,XPDNIEN
. N XPDMTXT,XPD,XEND S XPD=$$GET1^DIQ(3.9,288988_",",3,"","XPDMTXT"),XEND=0
. Q:'$D(XPDMTXT) Q:'$D(XPDMTXT(.006))
. ; NOT SURE THIS IS CONSISTENT...Q:XPDMTXT(.006)'["FORUM"
. W !!,"Description from FORUM patch:",!
. S JKL=.9 F S JKL=$O(XPDMTXT(JKL)) Q:('$G(JKL))!(+$G(XEND))!(XPDMTXT(JKL)="Packman Mail Message:") D Q:+$G(XEND)
.. I XPDMTXT(JKL)="$END TXT" S XEND=1 Q
.. W !,XPDMTXT(JKL)
Q
;
COMP1 ;SETS THE COMPONENTS USED BY BUILD PROGRAM From <https://www.domain.ext/vdl/documents/Infrastructure/Kernel/krn8_0dg.docx>
S XPDCS("APPLICATION ACTION")=1.61
S XPDCS("BULLETIN")=3.6
S XPDCS("DIALOG")=.84
S XPDCS("ENTITY")=1.5
S XPDCS("FORM")=.403
S XPDCS("FUNCTION")=.5
S XPDCS("HELP FRAME")=9.2
S XPDCS("HL7 APPLICATION PARAMETER")=771
S XPDCS("HLO APPLICATION REGISTRY")=779.2
S XPDCS("HL LOGICAL LINK")=870
;S XPDCS("HL LOWER LEVEL PROTOCOL")=""
S XPDCS("INPUT TEMPLATE")=.402
S XPDCS("LIST TEMPLATE")=409.61
S XPDCS("MAIL GROUP")=3.8
S XPDCS("OPTION")=19
S XPDCS("PARAMETER DEFINITION")=8989.51
S XPDCS("PARAMETER TEMPLATE")=8989.52
S XPDCS("POLICY")=1.6
S XPDCS("POLICY FUNCTION")=1.62
S XPDCS("PRINT TEMPLATE")=.4
S XPDCS("PROTOCOL")=101
S XPDCS("REMOTE PROCEDURE")=8994
S XPDCS("ROUTINE")=9.8
S XPDCS("SECURITY KEY")=19.1
S XPDCS("SORT TEMPLATE")=.401
S XPDCS("XULM LOCK DICTIONARY")=8993
Q
;
RLINES ;CAPTURES ROUTINE INFO; XPDSQA ARRAY OF SQA ROUTINE LINES
N JJ,X,RTN,ROU,DIF,XCNP,XPDARRR,XPDPNUM,PNUM,XPCNT,X2,BROU S XPDPNUM=$P(XPDARR("BUILD",XPDBIEN,"NAME"),"*",3),PNUM="",XPCNT=5,XPTL=0
N TCNT S (JJ,TCNT)=0 F S JJ=$O(XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ)) Q:'JJ S ROU=XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ) D
. S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=""
. I ROU'=$$UP^XLFSTR(ROU) S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* NAME (#.01) must be in UPPERCASE." ;ROU
. D SQA^XPDANLYZ2(JJ) ;SETS SQA CL ARRAY XPDARRR
. D RSPELL(ROU) ;SETS SPELL CHECK ARRAY XPRSPL
. ;I $E(ROU,1,$L(XPDSPC))'=XPDSPC S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* "_ROU_" is not in the Package namespace."
. I '$$NSPACE^XPDANLYZ6(ROU) S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* "_ROU_" is not in the Package namespace."
. N XRIEN S XRIEN=$O(^DIC(9.8,"B",ROU,0)) Q:'XRIEN D
.. N XPDINX S XPDINX=$$GET1^DIQ(9.8,XRIEN_",",1.4)
.. I XPDINX]"" S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* Date of Last ^XINDEX: "_XPDINX
.. I XPDINX']"" S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* Date ^XINDEX last run was not found."
. N X S X=ROU X ^%ZOSF("TEST") Q:'$T
. K RTN S XCNP=0,DIF="RTN(" X ^%ZOSF("LOAD")
. N K,SQAC,ZTAG,TCHK S (TCHK,K)=0 F S K=$O(RTN(K)) Q:'K D
.. I $E(RTN(K,0),1)'=" " S ZTAG=$P($P(RTN(K,0)," "),"(")_"^"_K I $L($P(ZTAG,"^"))>XPTL S XPTL=$L($P(ZTAG,"^"))
.. I K=1 S XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,1)=RTN(K,0) Q
.. I K=2 D
... S XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,2)=RTN(K,0)
... N QL S PNUM=$P(RTN(K,0),"**",2),X2=","_PNUM_",",QL=$L(PNUM,",") I $P(PNUM,",",QL)'=XPDPNUM S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* Missing current patch number on second line."
... ;D BCHK^XPDANLYZ3(ROU) I $D(BROU(ROU)) D ;RESOURCE INTENSIVE FOR LITTLE USEFUL INFO
... ;. S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* BUILD file also lists this routine in these patches:"
... ;. S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=BROU(ROU)
.. I K=3,$E(RTN(K,0),1,6)[";",$L(RTN(K,0))>3,$E(RTN(K,0),1)'?1U S XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,3)=RTN(K,0) ;,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,4)="" Q
.. I K>3,$TR($E(RTN(K,0),1,10)," ",".")?."."1";".E Q ;QUITS IF BEGINS WITH SPACES OR SPACES AND .. FOLLOWED BY ";"
.. N XPD1,EXT S XPD1=" ",EXT=0 F S XPD1=$O(XPDARRR(XPD1)) Q:$G(XPD1)']"" D
... N TAGME S TAGME=$P(ZTAG,"^")_" +"_(K-$P(ZTAG,"^",2))
... I XPD1="K:",RTN(K,0)[XPD1 D KCOLON^XPDANLYZ5(RTN(K,0)) Q
... Q:EXT
... I XPD1="^XTMP",RTN(K,0)[XPD1 D TMPX^XPDANLYZ5(RTN(K,0)) I 'XPDIS2 Q:TCHK ;TMPX^ZZSRABA
... I XPD1="^TMP",'XPDIS2,RTN(K,0)[XPD1 D TMP^XPDANLYZ5(RTN(K,0)) I 'XPDIS2 Q:TCHK
... I (XPD1="K ^"),'XPDIS2,RTN(K,0)[XPD1 S TCHK=$$KCHK^XPDANLYZ5(RTN(K,0),XPD1) Q:TCHK'=3
... I (XPD1="%"),'XPDIS2,RTN(K,0)[XPD1 S TCHK=$$MSQA^XPDANLYZ5(RTN(K,0),XPD1) Q:'TCHK ;$$GCHK^XPDANLYZ5(RTN(K,0),XPD1) D
... I (XPD1="IO"),'XPDIS2,RTN(K,0)[XPD1 S TCHK=$$MSQA^XPDANLYZ5(RTN(K,0),XPD1) Q:'TCHK
... I (XPD1="$I"),'XPDIS2,RTN(K,0)[XPD1 S TCHK=$$MSQA^XPDANLYZ5(RTN(K,0),XPD1) Q:'TCHK
... I (XPD1="DIC(0)"),'XPDIS2,RTN(K,0)[XPD1 S TCHK=$$MSQA^XPDANLYZ5(RTN(K,0),XPD1) Q:'TCHK
... I XPD1="U=",'XPDIS2,(RTN(K,0)["U=""^""")!(RTN(K,0)'?.E1P1"U=") Q
... I RTN(K,0)[XPD1 S XPDSQA(ROU,XPD1,K,TAGME)=RTN(K,0) I XTOG 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_","
. I XTOG D
.. S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* The SQA Checklist identifies the following specific code "
.. S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=" references to check in this routine:",SQAC=XPCNT
.. N MM S MM=" " F S MM=$O(XPDARRR(MM)) Q:MM']"" D
... I XPDARRR(MM,JJ,0)]"" S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=$J(MM,8)_$J(" ",5)_$$TRIM^XLFSTR(XPDARRR(MM,JJ,0),"R",",")
... I $L(XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT))>73 D CUT^XPDANLYZ3
.. S:SQAC=XPCNT XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=$J(" ",2)_"- No specific code references from the SQA Checklist were found."
. S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=" "
. S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=$$CJ^XLFSTR("<><><>",50)
Q
RSPELL(ROU) ;FIND TEXT IN ROUTINE BETWEEN QUOTES and after ";;"
N X S X=ROU X ^%ZOSF("TEST") Q:'$T
K RTN S XCNP=0,DIF="RTN(" X ^%ZOSF("LOAD")
N K,CNT S (CNT,K)=0 F S K=$O(RTN(K)) Q:'K D
. I RTN(K,0)[$C(34) N I,XTXT,TMP S TMP=RTN(K,0) F I=2:2:$L(TMP) D
.. I $TR($E(TMP,1,10)," ",".")?."."1";".E Q ;DO NOT LOOK AT LINE THAT BEGINS WITH ';'
.. S XTXT=$$TRIM^XLFSTR($P(TMP,$C(34),I)) I $L(XTXT)>2,XTXT?.E3A.E D
... I $L(XTXT)>14,XTXT'[$C(32) Q ;QUIT IF 15 OR MORE CHARACTERS WITHOUT A SPACE...PROBABLY CODE.
... I XTXT[("I "_$P(XTXT," ",2)) Q ;IF STATEMENT, NOT FOR SPELL CHECK
... N J,CLTXT S CLTXT="" I XTXT'[$C(32) Q:$E(XTXT,$L(XTXT))="(" F J=1:1:$L(XTXT) S:$E(XTXT,J)?1A CLTXT=CLTXT_$E(XTXT,J)
... I CLTXT]"" I $L(XTXT)>(2*$L(CLTXT)) Q ;NUMBER,PUNCUATION, FEW LETTERS
... Q:TMP[("("_$C(34)_XTXT) Q:TMP[("$J,"_$C(34)_XTXT) Q:TMP[(XTXT_$C(34)_",$J")
... Q:TMP[("DIC="_$C(34)_XTXT) Q:TMP[("DIC(0)="_$C(34)_XTXT) Q:TMP[("DR="_$C(34)_XTXT) Q:TMP[("DIE="_$C(34)_XTXT) Q:TMP[("DIC(""S"")="_$C(34)_XTXT)
... S XTXT=$J(K,3)_": "_XTXT S:$L(XTXT)<81 CNT=CNT+1,XPRSPL(ROU,CNT)=XTXT
... I $L(XTXT)>80 N L1,L2 S L1="",L2="" D LWRAP(XTXT,($L($P(XTXT,":"))+2)) S:L1]"" CNT=CNT+1,XPRSPL(ROU,CNT)=L1 S:L2]"" CNT=CNT+1,XPRSPL(ROU,CNT)=L2
. I K>2,RTN(K,0)[";;" Q:RTN(K,0)[$C(34)_";;"_$C(34) Q:$L(RTN(K,0))<5 N XPT81 S XPT81=$J(K,3)_": "_$P(RTN(K,0),";;",2,99) D
.. S:$L(XPT81)<81 CNT=CNT+1,XPRSPL(ROU,CNT)=XPT81 I $L(XPT81)>80 D
... N L1,L2 S L1="",L2="" D LWRAP(XPT81,($L($P(XPT81,":"))+2)) S:L1]"" CNT=CNT+1,XPRSPL(ROU,CNT)=L1 S:L2]"" CNT=CNT+1,XPRSPL(ROU,CNT)=L2
Q
LWRAP(LTXT,LW) ;
N T0 S T0=LTXT
F I=80:-1:60 D Q:L1]""
. I $E(T0,I)?1P S L1=$E(T0,1,I),L2=$J(" ",LW)_$E(T0,(I+1),9999)
. Q:L1]""
S:L1']"" L1=LTXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDANLYZ2 15179 printed Oct 16, 2024@18:03:57 Page 2
XPDANLYZ2 ;OAK/RSF- BUILD ANALYZER ;10/28/22
+1 ;;8.0;KERNEL;**782,792**;Jul 10, 1995;Build 4
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
XREF ;XREF
+1 if 'FXX
QUIT
+2 SET XPDARR("FILE",FXX,"XREF")="No"
+3 IF $DATA(^DD(FXX,0,"IX"))
Begin DoDot:1
+4 SET XPDARR("FILE",FXX,"XREF")="Yes"
+5 NEW JJ,LL,MM,RSF
SET JJ=""
SET (LL,MM)=0
FOR
SET JJ=$ORDER(^DD(FXX,0,"IX",JJ))
if $GET(JJ)']""
QUIT
FOR
SET LL=$ORDER(^DD(FXX,0,"IX",JJ,LL))
if '$GET(LL)
QUIT
Begin DoDot:2
+6 FOR
SET MM=$ORDER(^DD(FXX,0,"IX",JJ,LL,MM))
if '$GET(MM)
QUIT
Begin DoDot:3
+7 ;&(MM=.01)
if (JJ="B")
QUIT
+8 NEW PP
SET PP=0
SET RSF="field"
FOR
SET PP=$ORDER(^DD(LL,MM,1,PP))
if 'PP
QUIT
if LL'=FXX
SET RSF="subfield "
Begin DoDot:4
+9 IF JJ=$PIECE(^DD(LL,MM,1,PP,0),"^",2)
IF '$DATA(^DD(LL,MM,1,PP,"%D"))
SET XPDARR("FILE",FXX,MM,"WARNING","XREF")=$PIECE(^DD(LL,MM,1,PP,0),"^",2)_" cross-reference ("_RSF_" #"_MM_") - DESCRIPTION missing."
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
+12 ;OPTION
OPTME ;Option Analysis called from START^XPDANLYZ1
+1 ;XPDRC=2 IS OPTION
NEW XPDOARR,KK
SET KK=0
+2 NEW DIRUT,Y
KILL DIR
SET DIR(0)="YO"
SET DIR("A")="Do you want to analyze all options for a namespace"
+3 SET DIR("?")="Will use a range of options whose name starts with a series of letters - usually the namespace (i.e. TIU)"
+4 DO ^DIR
IF $DATA(DIRUT)
SET END=1
QUIT
+5 NEW XPDY
SET XPDY=Y
G1 IF XPDY=0
WRITE !
Begin DoDot:1
+1 NEW DIC,Y
SET DIC=19
SET DIC(0)="QEAM"
SET DIC("A")="Select individual options by name: "
+2 DO ^DIC
IF Y=-1
KILL DIC
SET XPDY=99
SET END=1
QUIT
+3 ;I $D(DUOUT) K DIC Q ;-1 LIKE ABOVE
+4 IF $DATA(DTOUT)
SET XPDY=99
SET END=1
QUIT
+5 ;OPTION ien ^ NAME
IF $GET(Y)]""
SET XPDOARR($PIECE(Y,"^"))=$PIECE(Y,"^",2)
SET KK=KK+1
End DoDot:1
+6 if XPDY=0
GOTO G1
+7 IF XPDY=1
NEW XPDPKG,XPDPKGL
Begin DoDot:1
+8 WRITE !
NEW DIRUT
KILL DIR
SET DIR(0)="FO^2:10"
SET DIR("?")="Enter the Package for the options to include"
+9 SET DIR("A")="Enter the package abbreviation or leading characters of options to include"
+10 DO ^DIR
+11 IF $DATA(DIRUT)
SET END=1
QUIT
+12 ;** CONFRIM ALL SHOULD BE UPPERCASE
IF $GET(Y)]""
SET XPDPKG=$$UP^XLFSTR(Y)
SET XPDPKGL=$LENGTH(XPDPKG)
if '$GET(XPDPKGL)
QUIT
+13 NEW JJ
SET JJ=""
SET KK=0
FOR
SET JJ=$ORDER(^DIC(19,"B",JJ))
if $GET(JJ)']""
QUIT
IF $EXTRACT(JJ,1,XPDPKGL)=XPDPKG
SET XPDOARR($ORDER(^DIC(19,"B",JJ,0)))=JJ
SET KK=KK+1
End DoDot:1
if END
GOTO X1^XPDANLYZ1
+14 IF $GET(KK)>1
Begin DoDot:1
+15 WRITE !!,"Will check these ",KK," options:"
+16 NEW JJ
SET JJ=0
FOR
SET JJ=$ORDER(XPDOARR(JJ))
if 'JJ
QUIT
WRITE !,?5,XPDOARR(JJ)
IF ($Y+5)>IOSL
DO HDR^XPDANLYZ1("Options (continued): ")
if END
QUIT
+17 WRITE !!,?5,",, WORKING .."
End DoDot:1
+18 IF $DATA(XPDOARR)
DO OCHK(.XPDOARR)
+19 QUIT
OCHK(XPDORR) ;setting up information to check OPTIONS ENTRY/EXIT for files and routines.
+1 NEW JJ,XPDIENS
SET JJ=0
FOR
SET JJ=$ORDER(XPDORR(JJ))
if 'JJ
QUIT
Begin DoDot:1
+2 NEW TARR
SET XPDIENS=JJ_","
DO GETS^DIQ(19,XPDIENS,"**","N","TARR")
IF $DATA(TARR)
Begin DoDot:2
+3 SET XPDARR("OPTION",JJ,"NAME")=XPDORR(JJ)
+4 IF '$DATA(TARR(19,XPDIENS,3.5))
SET XPDARR("OPTION",JJ,"DESCRIPT")="No"
SET XPDARR("OPTION",JJ,"WARNING","DESCRIPTION")="DESCRIPTION field (#3.5) missing."
+5 IF $DATA(TARR(19,XPDIENS,3.5))
SET XPDARR("OPTION",JJ,"DESCRIPT")="Yes"
NEW LL
SET LL=0
FOR
SET LL=$ORDER(TARR(19,XPDIENS,3.5,LL))
if 'LL
QUIT
SET XPDARR("OPTION",JJ,"DESCRIPTION",LL)=TARR(19,XPDIENS,3.5,LL)
+6 IF $DATA(TARR(19,XPDIENS,1))
SET XPDARR("OPTION",JJ,"Menu")=TARR(19,XPDIENS,1)
+7 IF '$DATA(TARR(19,XPDIENS,1))
SET XPDARR("OPTION",JJ,"WARNING","MENU TXT")="MENU TEXT field (#1) missing."
+8 IF '$DATA(TARR(19,XPDIENS,12))
SET XPDARR("OPTION",JJ,"WARNING","PKG")="PACKAGE field (#12) missing."
+9 IF $DATA(TARR(19,XPDIENS,12))
SET XPDARR("OPTION",JJ,"PKG")=TARR(19,XPDIENS,12)
+10 ; 25 IS ROUTINE AND IS TAG^ROUTINE
+11 IF $DATA(TARR(19,XPDIENS,25))
NEW TT,RR
SET TT=$LENGTH(TARR(19,XPDIENS,25),"^")
if $GET(TT)']""
QUIT
SET RR=$PIECE(TARR(19,XPDIENS,25),"^",TT)
if RR["("
SET RR=$PIECE(RR,"(")
Begin DoDot:3
+12 SET XPOPT(JJ,"ROU",RR)="ROUTINE field(#25):"
+13 ;S XPDARR("OPTION",JJ,"WARNING",RR)="Calls routine "_RR_" not found in build"
+14 ;I $E(RR,1,$L(XPDSPC))'=XPDSPC S XPDARR("OPTION",JJ,"WARNING",RR_"Z")="Calls routine "_RR_" not in patch namespace."
End DoDot:3
End DoDot:2
End DoDot:1
+15 if XPDRC=4
QUIT
+16 SET XPDCS("OPTION")=19
OPX KILL DIC
QUIT
+1 ;
RPCHK ; RPC Analysis called XPDANLYZ1
+1 ;XPDRC=4 IS RPC
NEW XPDCARR,KK
SET KK=0
+2 NEW DIRUT
KILL DIR
SET DIR(0)="YO"
SET DIR("A")="Do you want to analyze all RPCs for a namespace"
+3 SET DIR("?")="Will use a range of RPCs whose name starts with a series of letters - usually the namespace (i.e. TIU)"
+4 DO ^DIR
IF $DATA(DIRUT)
SET END=1
QUIT
+5 NEW XPDY
SET XPDY=Y
RPC1 IF XPDY=0
WRITE !
Begin DoDot:1
+1 NEW DIC
SET DIC=8994
SET DIC(0)="QEAM"
SET DIC("A")="Select individual RPCs by name: "
+2 DO ^DIC
IF Y=-1
KILL DIC
SET XPDY=99
QUIT
+3 IF $DATA(DTOUT)
SET XPDY=99
QUIT
+4 ;RPC ien ^ NAME
IF $GET(Y)]""
SET XPDCARR($PIECE(Y,"^"))=$PIECE(Y,"^",2)
SET KK=KK+1
End DoDot:1
+5 if XPDY=0
GOTO RPC1
+6 IF XPDY=1
NEW XPDPKG,XPDPKGL
Begin DoDot:1
+7 WRITE !
NEW DIRUT
KILL DIR
SET DIR(0)="FO^2:10"
SET DIR("?")="Enter the Package for the RPCs"
+8 SET DIR("A")="Enter the package abbreviation or leading characters of RPCs to include"
+9 DO ^DIR
+10 IF $DATA(DIRUT)
QUIT
+11 ;** CONFRIM ALL SHOULD BE UPPERCASE
IF $GET(Y)]""
SET XPDPKG=$$UP^XLFSTR(Y)
SET XPDPKGL=$LENGTH(XPDPKG)
if '$GET(XPDPKGL)
QUIT
+12 NEW JJ
SET JJ=""
SET KK=0
FOR
SET JJ=$ORDER(^XWB(8994,"B",JJ))
if $GET(JJ)']""
QUIT
IF $EXTRACT(JJ,1,XPDPKGL)=XPDPKG
SET XPDCARR($ORDER(^XWB(8994,"B",JJ,0)))=JJ
SET KK=KK+1
End DoDot:1
if END
GOTO X1^XPDANLYZ1
+13 IF $GET(KK)>1
Begin DoDot:1
+14 WRITE !!,"Will check these ",KK," Remote Procedure Calls"
+15 NEW JJ
SET JJ=0
FOR
SET JJ=$ORDER(XPDCARR(JJ))
if 'JJ
QUIT
WRITE !,?5,XPDCARR(JJ)
IF ($Y+5)>IOSL
DO HDR^XPDANLYZ1("RPC (continued): ")
if END
QUIT
+16 WRITE !!,?5,",, WORKING .."
End DoDot:1
+17 IF $DATA(XPDCARR)
DO RPC2(.XPDCARR)
+18 QUIT
RPC2(XPDRPC) ;^XWB(8994,; Remote Procedure check
+1 if '$DATA(XPDRPC)
QUIT
+2 NEW JJ,XPDIENS
SET JJ=0
FOR
SET JJ=$ORDER(XPDRPC(JJ))
if 'JJ
QUIT
Begin DoDot:1
+3 NEW TARR
SET XPDIENS=JJ_","
DO GETS^DIQ(8994,XPDIENS,"**","NR","TARR")
IF $DATA(TARR)
Begin DoDot:2
+4 SET XPDARR("REMOTE PROCEDURE",JJ,"NAME")=XPDRPC(JJ)
+5 IF '$DATA(TARR(8994,XPDIENS,"DESCRIPTION"))
SET XPDARR("REMOTE PROCEDURE",JJ,"DESCRIPT")="No"
SET XPDARR("REMOTE PROCEDURE",JJ,"WARNING","DESCRIPTION")="DESCRIPTION field (#1) missing."
+6 IF $DATA(TARR(8994,XPDIENS,"DESCRIPTION"))
SET XPDARR("REMOTE PROCEDURE",JJ,"DESCRIPT")="Yes"
NEW LL
SET LL=0
FOR
SET LL=$ORDER(TARR(8994,XPDIENS,"DESCRIPTION",LL))
if 'LL
QUIT
SET XPDARR("REMOTE PROCEDURE",JJ,"DESCRIPTION",LL)=TARR(8994,XPDIENS,"DESCRIPTION",LL)
+7 ;RETURN PARAMETERS
+8 IF $DATA(TARR(8994,XPDIENS,"RETURN VALUE TYPE"))
IF '$DATA(TARR(8994,XPDIENS,"RETURN PARAMETER DESCRIPTION"))
SET XPDARR("REMOTE PROCEDURE",JJ,"WARNING","RETURN DESCRIPTION")="RPC RETURN DESCRIPTION field (#3) missing."
+9 ;INPUT
+10 IF $DATA(^XWB(8994,JJ,2,0))
NEW XPDIP
SET XPDIP=$PIECE(^XWB(8994,JJ,2,0),"^",4)
if $GET(XPDIP)<1
QUIT
Begin DoDot:3
+11 ;p792
NEW MM
FOR MM=1:1:XPDIP
IF '$DATA(TARR(8994.02,MM_","_XPDIENS,"DESCRIPTION"))
NEW LL
Begin DoDot:4
+12 SET LL=MM
IF '$DATA(TARR(8994.02,MM_","_XPDIENS))
SET LL=$PIECE($ORDER(TARR(8994.02,MM_","_XPDIENS)),",")
if LL=""
SET LL=MM
IF $DATA(TARR(8994.02,LL_","_XPDIENS,"DESCRIPTION"))
QUIT
+13 SET XPDARR("REMOTE PROCEDURE",JJ,"WARNING","INPUT DESCRIPTION")="RPC Input Description for "_$GET(TARR(8994.02,LL_","_XPDIENS,"INPUT PARAMETER"))_" missing."
End DoDot:4
End DoDot:3
+14 IF $DATA(TARR(8994,XPDIENS,"ROUTINE"))
NEW RRR
SET RRR=TARR(8994,XPDIENS,"ROUTINE")
Begin DoDot:3
+15 SET XPDARR("REMOTE PROCEDURE",JJ,"ROUTINE",RRR)="Routine field (#.03): Calls "_RRR_" not found in build."
+16 ;I $E(RRR,1,$L(XPDSPC))'=XPDSPC S XPDARR("REMOTE PROCEDURE",JJ,"WARNING",RRR_"Z")="Routine field (#.03): Calls "_RRR_" not in patch namespace."
End DoDot:3
End DoDot:2
End DoDot:1
+17 if XPDRC=4
QUIT
+18 SET XPDCS("REMOTE PROCEDURE")=8994
RPCX KILL DIC
QUIT
+1 ;
SQA(RR) ;Sets SQA CL array XPDARRR
+1 SET XPDARRR("////",RR,0)=""
+2 SET XPDARRR("DIC(0)",RR,0)=""
+3 SET XPDARRR("^UTILITY",RR,0)=""
+4 SET XPDARRR("^TMP",RR,0)=""
+5 SET XPDARRR("^XTMP",RR,0)=""
+6 SET XPDARRR("%",RR,0)=""
+7 SET XPDARRR("$I",RR,0)=""
+8 SET XPDARRR("U=",RR,0)=""
+9 SET XPDARRR("K ^",RR,0)=""
+10 SET XPDARRR("K:",RR,0)=""
+11 SET XPDARRR("K @",RR,0)=""
+12 SET XPDARRR("^(",RR,0)=""
+13 SET XPDARRR("IO",RR,0)=""
+14 QUIT
+15 ;
FMSG(XPDBT) ;
+1 NEW XPDUZ
SET XPDUZ=$GET(DUZ)
if '$GET(DUZ)
QUIT
+2 KILL ^TMP("XPDEM",$JOB)
+3 NEW XMCRIT
SET XMCRIT("SUBJ")=XPDBT
+4 DO LISTMSGS^XMXAPIB(XPDUZ,"*","SUBJ;DATE;F","B",,,.XMCRIT,"^TMP(""XPDEM"",$J)")
+5 IF $DATA(^TMP("XPDEM",$JOB))
Begin DoDot:1
+6 NEW JKL,XPDNIEN
SET JKL=$ORDER(^TMP("XPDEM",$JOB,"XMLIST",0))
if '$GET(JKL)
QUIT
SET XPDNIEN=^TMP("XPDEM",$JOB,"XMLIST",JKL)
+7 ;W !,XPDNIEN
+8 NEW XPDMTXT,XPD,XEND
SET XPD=$$GET1^DIQ(3.9,288988_",",3,"","XPDMTXT")
SET XEND=0
+9 if '$DATA(XPDMTXT)
QUIT
if '$DATA(XPDMTXT(.006))
QUIT
+10 ; NOT SURE THIS IS CONSISTENT...Q:XPDMTXT(.006)'["FORUM"
+11 WRITE !!,"Description from FORUM patch:",!
+12 SET JKL=.9
FOR
SET JKL=$ORDER(XPDMTXT(JKL))
if ('$GET(JKL))!(+$GET(XEND))!(XPDMTXT(JKL)="Packman Mail Message
QUIT
Begin DoDot:2
+13 IF XPDMTXT(JKL)="$END TXT"
SET XEND=1
QUIT
+14 WRITE !,XPDMTXT(JKL)
End DoDot:2
if +$GET(XEND)
QUIT
End DoDot:1
+15 QUIT
+16 ;
COMP1 ;SETS THE COMPONENTS USED BY BUILD PROGRAM From <https://www.domain.ext/vdl/documents/Infrastructure/Kernel/krn8_0dg.docx>
+1 SET XPDCS("APPLICATION ACTION")=1.61
+2 SET XPDCS("BULLETIN")=3.6
+3 SET XPDCS("DIALOG")=.84
+4 SET XPDCS("ENTITY")=1.5
+5 SET XPDCS("FORM")=.403
+6 SET XPDCS("FUNCTION")=.5
+7 SET XPDCS("HELP FRAME")=9.2
+8 SET XPDCS("HL7 APPLICATION PARAMETER")=771
+9 SET XPDCS("HLO APPLICATION REGISTRY")=779.2
+10 SET XPDCS("HL LOGICAL LINK")=870
+11 ;S XPDCS("HL LOWER LEVEL PROTOCOL")=""
+12 SET XPDCS("INPUT TEMPLATE")=.402
+13 SET XPDCS("LIST TEMPLATE")=409.61
+14 SET XPDCS("MAIL GROUP")=3.8
+15 SET XPDCS("OPTION")=19
+16 SET XPDCS("PARAMETER DEFINITION")=8989.51
+17 SET XPDCS("PARAMETER TEMPLATE")=8989.52
+18 SET XPDCS("POLICY")=1.6
+19 SET XPDCS("POLICY FUNCTION")=1.62
+20 SET XPDCS("PRINT TEMPLATE")=.4
+21 SET XPDCS("PROTOCOL")=101
+22 SET XPDCS("REMOTE PROCEDURE")=8994
+23 SET XPDCS("ROUTINE")=9.8
+24 SET XPDCS("SECURITY KEY")=19.1
+25 SET XPDCS("SORT TEMPLATE")=.401
+26 SET XPDCS("XULM LOCK DICTIONARY")=8993
+27 QUIT
+28 ;
RLINES ;CAPTURES ROUTINE INFO; XPDSQA ARRAY OF SQA ROUTINE LINES
+1 NEW JJ,X,RTN,ROU,DIF,XCNP,XPDARRR,XPDPNUM,PNUM,XPCNT,X2,BROU
SET XPDPNUM=$PIECE(XPDARR("BUILD",XPDBIEN,"NAME"),"*",3)
SET PNUM=""
SET XPCNT=5
SET XPTL=0
+2 NEW TCNT
SET (JJ,TCNT)=0
FOR
SET JJ=$ORDER(XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ))
if 'JJ
QUIT
SET ROU=XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ)
Begin DoDot:1
+3 SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=""
+4 ;ROU
IF ROU'=$$UP^XLFSTR(ROU)
SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* NAME (#.01) must be in UPPERCASE."
+5 ;SETS SQA CL ARRAY XPDARRR
DO SQA^XPDANLYZ2(JJ)
+6 ;SETS SPELL CHECK ARRAY XPRSPL
DO RSPELL(ROU)
+7 ;I $E(ROU,1,$L(XPDSPC))'=XPDSPC S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* "_ROU_" is not in the Package namespace."
+8 IF '$$NSPACE^XPDANLYZ6(ROU)
SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* "_ROU_" is not in the Package namespace."
+9 NEW XRIEN
SET XRIEN=$ORDER(^DIC(9.8,"B",ROU,0))
if 'XRIEN
QUIT
Begin DoDot:2
+10 NEW XPDINX
SET XPDINX=$$GET1^DIQ(9.8,XRIEN_",",1.4)
+11 IF XPDINX]""
SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* Date of Last ^XINDEX: "_XPDINX
+12 IF XPDINX']""
SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* Date ^XINDEX last run was not found."
End DoDot:2
+13 NEW X
SET X=ROU
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+14 KILL RTN
SET XCNP=0
SET DIF="RTN("
XECUTE ^%ZOSF("LOAD")
+15 NEW K,SQAC,ZTAG,TCHK
SET (TCHK,K)=0
FOR
SET K=$ORDER(RTN(K))
if 'K
QUIT
Begin DoDot:2
+16 IF $EXTRACT(RTN(K,0),1)'=" "
SET ZTAG=$PIECE($PIECE(RTN(K,0)," "),"(")_"^"_K
IF $LENGTH($PIECE(ZTAG,"^"))>XPTL
SET XPTL=$LENGTH($PIECE(ZTAG,"^"))
+17 IF K=1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,1)=RTN(K,0)
QUIT
+18 IF K=2
Begin DoDot:3
+19 SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,2)=RTN(K,0)
+20 NEW QL
SET PNUM=$PIECE(RTN(K,0),"**",2)
SET X2=","_PNUM_","
SET QL=$LENGTH(PNUM,",")
IF $PIECE(PNUM,",",QL)'=XPDPNUM
SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* Missing current patch number on second line."
+21 ;D BCHK^XPDANLYZ3(ROU) I $D(BROU(ROU)) D ;RESOURCE INTENSIVE FOR LITTLE USEFUL INFO
+22 ;. S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* BUILD file also lists this routine in these patches:"
+23 ;. S XPCNT=XPCNT+1,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=BROU(ROU)
End DoDot:3
+24 ;,XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,4)="" Q
IF K=3
IF $EXTRACT(RTN(K,0),1,6)[";"
IF $LENGTH(RTN(K,0))>3
IF $EXTRACT(RTN(K,0),1)'?1U
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,3)=RTN(K,0)
+25 ;QUITS IF BEGINS WITH SPACES OR SPACES AND .. FOLLOWED BY ";"
IF K>3
IF $TRANSLATE($EXTRACT(RTN(K,0),1,10)," ",".")?."."1";".E
QUIT
+26 NEW XPD1,EXT
SET XPD1=" "
SET EXT=0
FOR
SET XPD1=$ORDER(XPDARRR(XPD1))
if $GET(XPD1)']""
QUIT
Begin DoDot:3
+27 NEW TAGME
SET TAGME=$PIECE(ZTAG,"^")_" +"_(K-$PIECE(ZTAG,"^",2))
+28 IF XPD1="K:"
IF RTN(K,0)[XPD1
DO KCOLON^XPDANLYZ5(RTN(K,0))
QUIT
+29 if EXT
QUIT
+30 ;TMPX^ZZSRABA
IF XPD1="^XTMP"
IF RTN(K,0)[XPD1
DO TMPX^XPDANLYZ5(RTN(K,0))
IF 'XPDIS2
if TCHK
QUIT
+31 IF XPD1="^TMP"
IF 'XPDIS2
IF RTN(K,0)[XPD1
DO TMP^XPDANLYZ5(RTN(K,0))
IF 'XPDIS2
if TCHK
QUIT
+32 IF (XPD1="K ^")
IF 'XPDIS2
IF RTN(K,0)[XPD1
SET TCHK=$$KCHK^XPDANLYZ5(RTN(K,0),XPD1)
if TCHK'=3
QUIT
+33 ;$$GCHK^XPDANLYZ5(RTN(K,0),XPD1) D
IF (XPD1="%")
IF 'XPDIS2
IF RTN(K,0)[XPD1
SET TCHK=$$MSQA^XPDANLYZ5(RTN(K,0),XPD1)
if 'TCHK
QUIT
+34 IF (XPD1="IO")
IF 'XPDIS2
IF RTN(K,0)[XPD1
SET TCHK=$$MSQA^XPDANLYZ5(RTN(K,0),XPD1)
if 'TCHK
QUIT
+35 IF (XPD1="$I")
IF 'XPDIS2
IF RTN(K,0)[XPD1
SET TCHK=$$MSQA^XPDANLYZ5(RTN(K,0),XPD1)
if 'TCHK
QUIT
+36 IF (XPD1="DIC(0)")
IF 'XPDIS2
IF RTN(K,0)[XPD1
SET TCHK=$$MSQA^XPDANLYZ5(RTN(K,0),XPD1)
if 'TCHK
QUIT
+37 IF XPD1="U="
IF 'XPDIS2
IF (RTN(K,0)["U=""^""")!(RTN(K,0)'?.E1P1"U=")
QUIT
+38 IF RTN(K,0)[XPD1
SET XPDSQA(ROU,XPD1,K,TAGME)=RTN(K,0)
IF XTOG
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_","
End DoDot:3
End DoDot:2
+39 IF XTOG
Begin DoDot:2
+40 SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)="* The SQA Checklist identifies the following specific code "
+41 SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=" references to check in this routine:"
SET SQAC=XPCNT
+42 NEW MM
SET MM=" "
FOR
SET MM=$ORDER(XPDARRR(MM))
if MM']""
QUIT
Begin DoDot:3
+43 IF XPDARRR(MM,JJ,0)]""
SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=$JUSTIFY(MM,8)_$JUSTIFY(" ",5)_$$TRIM^XLFSTR(XPDARRR(MM,JJ,0),"R",",")
+44 IF $LENGTH(XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT))>73
DO CUT^XPDANLYZ3
End DoDot:3
+45 if SQAC=XPCNT
SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=$JUSTIFY(" ",2)_"- No specific code references from the SQA Checklist were found."
End DoDot:2
+46 SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=" "
+47 SET XPCNT=XPCNT+1
SET XPDARR("BUILD",XPDBIEN,"ROUTINE",JJ,XPCNT)=$$CJ^XLFSTR("<><><>",50)
End DoDot:1
+48 QUIT
RSPELL(ROU) ;FIND TEXT IN ROUTINE BETWEEN QUOTES and after ";;"
+1 NEW X
SET X=ROU
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+2 KILL RTN
SET XCNP=0
SET DIF="RTN("
XECUTE ^%ZOSF("LOAD")
+3 NEW K,CNT
SET (CNT,K)=0
FOR
SET K=$ORDER(RTN(K))
if 'K
QUIT
Begin DoDot:1
+4 IF RTN(K,0)[$CHAR(34)
NEW I,XTXT,TMP
SET TMP=RTN(K,0)
FOR I=2:2:$LENGTH(TMP)
Begin DoDot:2
+5 ;DO NOT LOOK AT LINE THAT BEGINS WITH ';'
IF $TRANSLATE($EXTRACT(TMP,1,10)," ",".")?."."1";".E
QUIT
+6 SET XTXT=$$TRIM^XLFSTR($PIECE(TMP,$CHAR(34),I))
IF $LENGTH(XTXT)>2
IF XTXT?.E3A.E
Begin DoDot:3
+7 ;QUIT IF 15 OR MORE CHARACTERS WITHOUT A SPACE...PROBABLY CODE.
IF $LENGTH(XTXT)>14
IF XTXT'[$CHAR(32)
QUIT
+8 ;IF STATEMENT, NOT FOR SPELL CHECK
IF XTXT[("I "_$PIECE(XTXT," ",2))
QUIT
+9 NEW J,CLTXT
SET CLTXT=""
IF XTXT'[$CHAR(32)
if $EXTRACT(XTXT,$LENGTH(XTXT))="("
QUIT
FOR J=1:1:$LENGTH(XTXT)
if $EXTRACT(XTXT,J)?1A
SET CLTXT=CLTXT_$EXTRACT(XTXT,J)
+10 ;NUMBER,PUNCUATION, FEW LETTERS
IF CLTXT]""
IF $LENGTH(XTXT)>(2*$LENGTH(CLTXT))
QUIT
+11 if TMP[("("_$CHAR(34)_XTXT)
QUIT
if TMP[("$J,"_$CHAR(34)_XTXT)
QUIT
if TMP[(XTXT_$CHAR(34)_",$J")
QUIT
+12 if TMP[("DIC="_$CHAR(34)_XTXT)
QUIT
if TMP[("DIC(0)="_$CHAR(34)_XTXT)
QUIT
if TMP[("DR="_$CHAR(34)_XTXT)
QUIT
if TMP[("DIE="_$CHAR(34)_XTXT)
QUIT
if TMP[("DIC(""S"")="_$CHAR(34)_XTXT)
QUIT
+13 SET XTXT=$JUSTIFY(K,3)_": "_XTXT
if $LENGTH(XTXT)<81
SET CNT=CNT+1
SET XPRSPL(ROU,CNT)=XTXT
+14 IF $LENGTH(XTXT)>80
NEW L1,L2
SET L1=""
SET L2=""
DO LWRAP(XTXT,($LENGTH($PIECE(XTXT,":"))+2))
if L1]""
SET CNT=CNT+1
SET XPRSPL(ROU,CNT)=L1
if L2]""
SET CNT=CNT+1
SET XPRSPL(ROU,CNT)=L2
End DoDot:3
End DoDot:2
+15 IF K>2
IF RTN(K,0)[";;"
if RTN(K,0)[$CHAR(34)_";;"_$CHAR(34)
QUIT
if $LENGTH(RTN(K,0))<5
QUIT
NEW XPT81
SET XPT81=$JUSTIFY(K,3)_": "_$PIECE(RTN(K,0),";;",2,99)
Begin DoDot:2
+16 if $LENGTH(XPT81)<81
SET CNT=CNT+1
SET XPRSPL(ROU,CNT)=XPT81
IF $LENGTH(XPT81)>80
Begin DoDot:3
+17 NEW L1,L2
SET L1=""
SET L2=""
DO LWRAP(XPT81,($LENGTH($PIECE(XPT81,":"))+2))
if L1]""
SET CNT=CNT+1
SET XPRSPL(ROU,CNT)=L1
if L2]""
SET CNT=CNT+1
SET XPRSPL(ROU,CNT)=L2
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
LWRAP(LTXT,LW) ;
+1 NEW T0
SET T0=LTXT
+2 FOR I=80:-1:60
Begin DoDot:1
+3 IF $EXTRACT(T0,I)?1P
SET L1=$EXTRACT(T0,1,I)
SET L2=$JUSTIFY(" ",LW)_$EXTRACT(T0,(I+1),9999)
+4 if L1]""
QUIT
End DoDot:1
if L1]""
QUIT
+5 if L1']""
SET L1=LTXT
+6 QUIT
