Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XTVSRFL1

XTVSRFL1.m

Go to the documentation of this file.
  1. XTVSRFL1 ;ALBANY FO/GTS - VistA Package Sizing Manager; 21-OCT-2016
  1. ;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;;Variable glosary (local, for each package)
  1. ;; PKGIEN = Package IEN
  1. ;; PKGNAME = Package NAME (.01 - $P(^(0),"^",1))
  1. ;; PKGPFX = Package PREFIX / NAMESPACE (1 - $P(^(0),"^",2))
  1. ;;
  1. ;; RTOT = total ROUTINEs
  1. ;; TLCNT = total SIZE of all ROUTINES
  1. ;; FTOT = total FILEs
  1. ;; FLDTOT = total FIELDs of all FILES (Future: TBD)
  1. ;; OTOT = total OPTIONs (^DIC(19,)
  1. ;; PRCTOT = total PROTOCOLs (^ORD(101,)
  1. ;; RPTOT = total REMOTE PROCEDUREs (^XWB(8994,)
  1. ;; TPLTTOT = total Fileman Templates
  1. ;
  1. ONERPT(PKGNAME,VALMCNT) ; Report a single package
  1. ;;INPUT:
  1. ; PKGNAME - Package name to report
  1. ; VALMCNT - Current Node # on ListMan ^TMP("XTVS PKG MGR RPT",$JOB) global
  1. ;
  1. N Q,PCENUM,ADP,RDP,FTOT,FLDTOT,FFCTRSLT,RTOT,OTOT,PRCTOT,RPTOT,TPLTTOT,PKGIEN,PKGPFX,RNDT,TLCNT
  1. N PARMDAT,PARMDAT3,PARMDAT4,PARMDAT7,PARMDAT8
  1. D FULL^VALM1
  1. ;
  1. SET PKGIEN=0
  1. IF PKGNAME["''" DO
  1. . IF $D(^DIC(9.4,"B",$REPLACE(PKGNAME,"''",""""))) SET PKGIEN=$O(^DIC(9.4,"B",$REPLACE(PKGNAME,"''",""""),""))
  1. . IF '$D(^DIC(9.4,"B",$REPLACE(PKGNAME,"''",""""))),$D(^DIC(9.4,"B",PKGNAME)) SET PKGIEN=$O(^DIC(9.4,"B",PKGNAME,""))
  1. IF PKGNAME'["''" SET PKGIEN=+$O(^DIC(9.4,"B",PKGNAME,""))
  1. ;
  1. IF PKGIEN=0 W !!,"Selected package is not defined in the Package file (#9.4) on this VistA.",!,"Protocol count may be incorrect.",!!
  1. ;
  1. S PKGPFX=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNAME,2,"Primary Prefix"))
  1. I PKGPFX="" W !!,"PREFIX not found for package selected. Unable to continue." Q
  1. ;
  1. SET PARMDAT=^TMP("XTVS-PARAM-CAP",$J,PKGNAME,5,"Additional Prefixes")
  1. S (ADP,Q,PCENUM)=0
  1. FOR SET PCENUM=PCENUM+1 SET Q=$P(PARMDAT,"|",PCENUM) Q:Q="" IF $$MULTX(Q,PKGNAME) SET ADP=ADP+1 SET ADP(ADP)=Q
  1. ;
  1. SET PARMDAT=^TMP("XTVS-PARAM-CAP",$J,PKGNAME,6,"Excepted Prefixes")
  1. S (RDP,Q,PCENUM)=0
  1. FOR SET PCENUM=PCENUM+1 SET Q=$P(PARMDAT,"|",PCENUM) Q:Q="" SET RDP=RDP+1 SET RDP(RDP)=Q
  1. ;
  1. W !,"...counting...",!," ...files and fields..."
  1. SET PARMDAT3=^TMP("XTVS-PARAM-CAP",$J,PKGNAME,3,"*Lowest File#")
  1. SET PARMDAT4=^TMP("XTVS-PARAM-CAP",$J,PKGNAME,4,"*Highest File#")
  1. SET PARMDAT7=^TMP("XTVS-PARAM-CAP",$J,PKGNAME,7,"File Numbers")
  1. SET PARMDAT8=^TMP("XTVS-PARAM-CAP",$J,PKGNAME,8,"File Ranges")
  1. SET FFCTRSLT=$$COUNTFLS(PKGPFX,PARMDAT3,PARMDAT4,PARMDAT7,PARMDAT8) ; Count Files^Fields
  1. SET FTOT=$P(FFCTRSLT,"^") ;Extract File ctr
  1. SET FLDTOT=$P(FFCTRSLT,"^",2) ;Extract Field ctr
  1. ;
  1. W !," ...routines..."
  1. S TLCNT=0
  1. S RTOT=$$ROUTINE(PKGPFX,.TLCNT,.RDP,.ADP)
  1. I ADP F Q=1:1:ADP I ADP(Q)'="" S RTOT=RTOT+$$ROUTINE(ADP(Q),.TLCNT,.RDP,.ADP) ;ADP(Q) added prefixes called individually
  1. ;
  1. W !," ...options..."
  1. S OTOT=0
  1. D CNTR("^DIC(19,",.OTOT,PKGPFX,.RDP,.ADP)
  1. I ADP F Q=1:1:ADP I ADP(Q)'="" D CNTR("^DIC(19,",.OTOT,ADP(Q),.RDP,.ADP)
  1. ;
  1. W !," ...protocols..."
  1. S PRCTOT=$$PROTOCOL(PKGPFX,PKGIEN,.RDP)
  1. I ADP F Q=1:1:ADP I ADP(Q)'="" S PRCTOT=PRCTOT+$$PROTOCOL(ADP(Q),PKGIEN,.RDP)
  1. ;
  1. W !," ...remote procedures..."
  1. S RPTOT=0
  1. D CNTR("^XWB(8994,",.RPTOT,PKGPFX,.RDP,.ADP)
  1. I ADP F Q=1:1:ADP I ADP(Q)'="" D CNTR("^XWB(8994,",.RPTOT,ADP(Q),.RDP,.ADP)
  1. ;
  1. W !," ...edit, print, & sort templates..."
  1. S TPLTTOT=0
  1. D CNTR("^DIPT(",.TPLTTOT,PKGPFX,.RDP,.ADP) ;Print Templates
  1. I ADP F Q=1:1:ADP I ADP(Q)'="" D CNTR("^DIPT(",.TPLTTOT,ADP(Q),.RDP,.ADP)
  1. ;
  1. D CNTR("^DIBT(",.TPLTTOT,PKGPFX,.RDP) ;Sort Templates
  1. I ADP F Q=1:1:ADP I ADP(Q)'="" D CNTR("^DIBT(",.TPLTTOT,ADP(Q),.RDP,.ADP)
  1. ;
  1. D CNTR("^DIE(",.TPLTTOT,PKGPFX,.RDP) ;Input Templates
  1. I ADP F Q=1:1:ADP I ADP(Q)'="" D CNTR("^DIE(",.TPLTTOT,ADP(Q),.RDP,.ADP)
  1. ;
  1. DO ADD^XTVSLAPI(.VALMCNT," ")
  1. DO ADD^XTVSLAPI(.VALMCNT," VistA Application Sizing Information",1,3,36)
  1. DO NOW^%DTC S Y=X D DD^%DT
  1. SET RNDT=Y
  1. DO ADD^XTVSLAPI(.VALMCNT,"Run Date: "_RNDT)
  1. DO ADD^XTVSLAPI(.VALMCNT,"VistA Application: "_PKGNAME)
  1. DO ADD^XTVSLAPI(.VALMCNT,"==================")
  1. DO ADD^XTVSLAPI(.VALMCNT,"Number of Routines: "_RTOT)
  1. DO ADD^XTVSLAPI(.VALMCNT,"Size of Routines: "_TLCNT)
  1. DO ADD^XTVSLAPI(.VALMCNT,"Number of Files: "_FTOT)
  1. DO ADD^XTVSLAPI(.VALMCNT,"Number of Fields: "_FLDTOT)
  1. DO ADD^XTVSLAPI(.VALMCNT,"Number of Options: "_OTOT)
  1. DO ADD^XTVSLAPI(.VALMCNT,"Number of Protocols: "_PRCTOT)
  1. DO ADD^XTVSLAPI(.VALMCNT,"Number of RPCs: "_RPTOT)
  1. DO ADD^XTVSLAPI(.VALMCNT,"Number of Templates: "_TPLTTOT)
  1. QUIT
  1. ;
  1. COUNTFLS(PKGPFX,LINE3,LINE4,LINE7,LINE8) ;Count total # of files for a package
  1. ; LINE3=*Lowest File # from ^TMP("XTVS-PARAM-CAP",$J,PKGNAME,3,"*Lowest File#") or SELPKGPM
  1. ; LINE4=*Highest File # from ^TMP("XTVS-PARAM-CAP",$J,PKGNAME,4,"*Highest File#") or SELPKGPM
  1. ; LINE7=File Numbers from ^TMP("XTVS-PARAM-CAP",$J,PKGNAME,7,"File Numbers") or SELPKGPM
  1. ; LINE8=File Ranges from ^TMP("XTVS-PARAM-CAP",$J,PKGNAME,8,"File Ranges") or SELPKGPM
  1. ;
  1. NEW FNDFLDAT,FILELIST,PCENUM,FLERNG,STRTFNUM,ENDFNUM,FTOT,FNUM,FLDCNT
  1. SET (FTOT,FNDFLDAT,FLDCNT)=0
  1. ;
  1. ; 1st look for delimited list of file ranges, if exists count it only
  1. SET FILELIST=LINE8
  1. IF FILELIST'="" DO
  1. . SET FNDFLDAT=1
  1. . SET PCENUM=0
  1. . FOR SET PCENUM=PCENUM+1 SET FLERNG=$P(FILELIST,"|",PCENUM) QUIT:FLERNG']"" DO
  1. .. SET STRTFNUM=+$P(FLERNG,"-")
  1. .. SET ENDFNUM=+$P(FLERNG,"-",2)
  1. .. IF +STRTFNUM>0,+ENDFNUM>0 SET FTOT=FTOT+$$FLECNT(STRTFNUM,ENDFNUM,.FLDCNT)
  1. ;
  1. ; 2nd if no list of file ranges, look files between Lowest and Highest file number range
  1. IF 'FNDFLDAT,PKGPFX'="XU" DO
  1. . NEW STRTFNUM,ENDFNUM,FNUM,FILENAME
  1. . SET STRTFNUM=LINE3
  1. . SET ENDFNUM=LINE4
  1. . IF +STRTFNUM>0,+ENDFNUM>0 SET FNDFLDAT=1 SET FTOT=FTOT+$$FLECNT(STRTFNUM,ENDFNUM,.FLDCNT)
  1. ;
  1. ; 3rd if no list of file ranges & no High/Low file range, count files in File list data element
  1. SET FILELIST=LINE7
  1. IF 'FNDFLDAT,FILELIST'="" DO
  1. . SET FNDFLDAT=1
  1. . SET PCENUM=0
  1. . FOR SET PCENUM=PCENUM+1 SET FNUM=$P(FILELIST,"|",PCENUM) QUIT:FNUM']"" SET FTOT=FTOT+1 SET FLDCNT=FLDCNT+$$FLDCNTR(FNUM)
  1. SET FTOT=FTOT_"^"_FLDCNT
  1. KILL ^TMP("XTVS-FILE-CNTD",$J,PKGPFX)
  1. QUIT FTOT
  1. ;
  1. ROUTINE(PKGPFX,TLCNT,RDP,ADP) ; Returns # of routines & total characters in all routines
  1. ; CNT - # characters in each routine including line feeds on each line of each routine
  1. NEW CNT,LPPFX,PFXLN,X,ADPFXLN,ADPFX,ADPNDE,LPCT,ADPRSET
  1. SET PFXLN=$L(PKGPFX)
  1. SET (ADPRSET,CNT)=0
  1. FOR LPCT=1:1 Q:$G(ADP(LPCT))="" IF ADP(LPCT)=PKGPFX SET ADPRSET=LPCT KILL ADP(LPCT)
  1. SET LPPFX=""
  1. DO RTNLST(PKGPFX,"^TMP(""XTVS"",""RTNLST"""_","_$J_")") ;Create global of Routines with Primary Prefix
  1. FOR SET LPPFX=$ORDER(^TMP("XTVS","RTNLST",$J,LPPFX)) QUIT:LPPFX="" DO
  1. .IF $$ADPRDPCK(LPPFX,.RDP),$$ADPRDPCK(LPPFX,.ADP) DO
  1. .. SET X=LPPFX
  1. .. X ^%ZOSF("TEST") IF $T SET TLCNT=TLCNT+$$RSIZE(LPPFX) SET CNT=CNT+1
  1. KILL ^TMP("XTVS","RTNLST",$J)
  1. IF ADPRSET SET ADP(ADPRSET)=PKGPFX
  1. QUIT CNT
  1. ;
  1. RTNLST(PREFIX,RTNLIST) ; Create RTNLIST of routines in PREFIX namespace
  1. ; NOTE: NEW RTNS will destroy the ResultSet Query object when QUIT takes RTNS out of scope
  1. NEW RTNS,RTNNAME
  1. SET RTNS=##class(%ResultSet).%New("%Routine:RoutineList") ;Create Routine Query Class instance
  1. DO RTNS.Execute(PREFIX_"*.INT") ;Query Routines
  1. FOR Q:'RTNS.Next() SET RTNNAME=$P(RTNS.GetData(1),".") SET @RTNLIST@(RTNNAME)=""
  1. QUIT
  1. ;
  1. ADPRDPCK(LPPFX,CKDP) ;Check for Excepted PREFIX [Result=0 when excepted] ; Additional PREFIX [Result=0 when included in Additional]
  1. N RESULT,CKFX,CKFXLN,CKPNDE
  1. S RESULT=1
  1. FOR CKPNDE=1:1:CKDP SET CKFX=$G(CKDP(CKPNDE)) Q:CKFX="" Q:'RESULT DO
  1. . SET CKFXLN=$L(CKFX)
  1. . IF $E(LPPFX,1,CKFXLN)=CKFX SET RESULT=0 ;Do not count OR will be/already counted
  1. Q RESULT
  1. ;
  1. FLECNT(STRTFNUM,ENDFNUM,FLDCNT) ; Count Files & Fields
  1. NEW FCNT,FNUM
  1. SET FCNT=0
  1. SET FNUM=$O(^DIC(STRTFNUM),-1)
  1. FOR SET FNUM=$O(^DIC(FNUM)) Q:'FNUM Q:FNUM>ENDFNUM DO
  1. . IF '$D(^TMP("XTVS-FILE-CNTD",$J,PKGPFX,FNUM)) DO
  1. .. SET FILENAME=$P($G(^DIC(FNUM,0)),"^")
  1. .. IF FILENAME]"" S FCNT=FCNT+1 SET FLDCNT=FLDCNT+$$FLDCNTR(FNUM)
  1. .. SET ^TMP("XTVS-FILE-CNTD",$J,PKGPFX,FNUM)=""
  1. Q FCNT
  1. ;
  1. FLDCNTR(FILENUM) ; Return # of fields
  1. NEW FLDCT,FIELDNUM
  1. SET (FLDCT,FIELDNUM)=0
  1. IF $D(^DD(FILENUM)) DO
  1. .FOR QUIT:FIELDNUM="" QUIT:'$D(^DD(+FILENUM,+FIELDNUM)) DO
  1. ..SET FIELDNUM=$O(^DD(FILENUM,FIELDNUM))
  1. ..IF +FIELDNUM>0 DO
  1. ...SET FLDCT=FLDCT+1
  1. ...; Check for Multiples and recursively call FLDCNTR
  1. ...IF +$E($P($G(^DD(FILENUM,FIELDNUM,0)),"^",2),1,1)>0 SET FLDCT=FLDCT+$$FLDCNTR(+$P($G(^DD(FILENUM,FIELDNUM,0)),"^",2))
  1. QUIT FLDCT
  1. ;
  1. PROTOCOL(PKGPFX,PKGIEN,RDP,ADP) ; Count Protocols
  1. NEW LPPFX,PFXLN,CNT,ORDIEN,SPCPOS,DASHPOS,UNDRSPOS,PRTPFX,LPCT,ADPRSET,PFXANLYS,PFXEXT
  1. SET PFXLN=$L(PKGPFX)
  1. SET (ADPRSET,CNT)=0
  1. IF '$D(PKGIEN) SET PKGIEN=0
  1. IF $D(PKGIEN),(PKGIEN="") SET PKGIEN=0
  1. FOR LPCT=1:1 SET LPPFX=$O(ADP(LPCT)) Q:$G(ADP(LPCT))="" IF ADP(LPCT)=PKGPFX SET ADPRSET=LPCT KILL ADP(LPCT)
  1. SET LPPFX=$O(^ORD(101,"B",PKGPFX),-1)
  1. FOR SET LPPFX=$O(^ORD(101,"B",LPPFX)) QUIT:LPPFX="" Q:$E(LPPFX,1,$L(PKGPFX))'=PKGPFX SET ORDIEN=$O(^ORD(101,"B",LPPFX,"")) QUIT:ORDIEN="" DO
  1. . IF $P($G(^ORD(101,ORDIEN,0)),"^",12)=PKGIEN SET CNT=CNT+1 ;In Package; count it
  1. . IF ($P($G(^ORD(101,ORDIEN,0)),"^",12)="") DO
  1. .. SET PRTPFX=LPPFX
  1. .. SET SPCPOS=$FIND(PRTPFX," ")
  1. .. SET DASHPOS=$FIND(PRTPFX,"-")
  1. .. SET UNDRSPOS=$FIND(PRTPFX,"_")
  1. .. SET:PRTPFX[$$PFXDLIM(SPCPOS,DASHPOS,UNDRSPOS) PRTPFX=$P(PRTPFX,$$PFXDLIM(SPCPOS,DASHPOS,UNDRSPOS))
  1. .. IF (PRTPFX=PKGPFX),($D(RDP)),($$ADPRDPCK(PRTPFX,.RDP)) SET CNT=CNT+1 ;Do NOT count if Prefix is in Excepted list
  1. .. IF PRTPFX'=PKGPFX DO
  1. ... SET PFXAVAIL=1
  1. ... SET PFXANLYS=PKGPFX
  1. ... FOR PFXEXT=PFXLN+1:1 Q:($E(PRTPFX,PFXEXT)'?1AN) Q:'PFXAVAIL SET PFXANLYS=PFXANLYS_$E(PRTPFX,PFXEXT) DO
  1. .... IF $D(^TMP("XTVS-FORUM-PFXS",$J,PFXANLYS)) SET PFXAVAIL=0 ;Do NOT count if extended Prefix is a Package Prefix
  1. .... IF $D(ADP),('$$ADPRDPCK(PFXANLYS,.ADP)) SET PFXAVAIL=0 ;Do NOT count if extended Prefix is an additional Prefix
  1. .... IF $D(RDP),('$$ADPRDPCK(PFXANLYS,.RDP)) SET PFXAVAIL=0 ;Do NOT count if extended Prefix is excluded from Package
  1. ... IF PFXAVAIL SET CNT=CNT+1
  1. . SET LPPFX=$$QUOTEFX(LPPFX) ;So LPPFX with quote will work with FOR loop
  1. IF ADPRSET SET ADP(ADPRSET)=PKGPFX
  1. Q CNT
  1. ;
  1. CNTR(TMPGLB,CNT,PKGPFX,RDP,ADP) ; Count Templates & RPCs
  1. NEW LPPFX,PFXLN,TMPLTPFX,PFXEXT,PFXANLYS,PFXAVAIL,SPCPOS,DASHPOS,UNDRSPOS,LPCT,ADPRSET
  1. SET PFXLN=$L(PKGPFX)
  1. SET ADPRSET=0
  1. FOR LPCT=1:1 SET LPPFX=$O(ADP(LPCT)) Q:$G(ADP(LPCT))="" IF ADP(LPCT)=PKGPFX SET ADPRSET=LPCT KILL ADP(LPCT)
  1. SET LPPFX=$O(@(TMPGLB_"""B"","""_PKGPFX_""")"),-1)
  1. IF LPPFX["""" SET LPPFX=QUOTEFX(LPPFX)
  1. FOR SET LPPFX=$O(@(TMPGLB_"""B"","""_LPPFX_""")")) Q:LPPFX="" Q:$E(LPPFX,1,PFXLN)'=PKGPFX DO
  1. .SET TMPLTPFX=LPPFX
  1. .SET SPCPOS=$FIND(TMPLTPFX," ")
  1. .SET DASHPOS=$FIND(TMPLTPFX,"-")
  1. .SET UNDRSPOS=$FIND(TMPLTPFX,"_")
  1. .SET:TMPLTPFX[$$PFXDLIM(SPCPOS,DASHPOS,UNDRSPOS) TMPLTPFX=$P(TMPLTPFX,$$PFXDLIM(SPCPOS,DASHPOS,UNDRSPOS))
  1. .IF $L(TMPLTPFX)=PFXLN,($D(RDP)),($$ADPRDPCK(TMPLTPFX,.RDP)) SET CNT=CNT+1 ;Do NOT count if Prefix is in Excepted list
  1. .IF $L(TMPLTPFX)>PFXLN,('$D(^TMP("XTVS-FORUM-PFXS",$J,TMPLTPFX))) DO
  1. ..; Above IF: Prefix starts with PKGPFX and not a specified prefix for any package
  1. .. SET PFXAVAIL=1
  1. .. SET PFXANLYS=PKGPFX
  1. .. FOR PFXEXT=PFXLN+1:1 Q:($E(TMPLTPFX,PFXEXT)'?1AN) Q:'PFXAVAIL SET PFXANLYS=PFXANLYS_$E(TMPLTPFX,PFXEXT) DO
  1. ... IF $D(^TMP("XTVS-FORUM-PFXS",$J,PFXANLYS)) SET PFXAVAIL=0 ;Do NOT count if extended Prefix is a Package Prefix
  1. ... IF $D(ADP),('$$ADPRDPCK(PFXANLYS,.ADP)) SET PFXAVAIL=0 ;Do NOT count if extended Prefix is an additional Prefix
  1. ... IF $D(RDP),('$$ADPRDPCK(PFXANLYS,.RDP)) SET PFXAVAIL=0 ;Do NOT count if extended Prefix is excluded from Package
  1. .. IF PFXAVAIL SET CNT=CNT+1
  1. .SET LPPFX=$$QUOTEFX(LPPFX) ;So LPPFX with quote will work with FOR loop
  1. IF ADPRSET SET ADP(ADPRSET)=PKGPFX
  1. Q
  1. ;
  1. QUOTEFX(ITEMNAME) ; Return ITEMNAME with single quotes changed to double
  1. NEW QUPDT,LPCNT,XTVSBPC
  1. SET QUPDT=""
  1. FOR LPCNT=1:1 SET XTVSBPC=$E(ITEMNAME,LPCNT) Q:XTVSBPC="" S QUPDT=QUPDT_XTVSBPC IF XTVSBPC="""" S QUPDT=QUPDT_""""
  1. SET ITEMNAME=QUPDT
  1. Q ITEMNAME
  1. ;
  1. ;
  1. MULTX(APFX,PKGNAME) ; Return indication of Multiple packages using same prefix
  1. ;MULTX can prevent Primary prefix from double counting when added prefix on another package
  1. ; NOTE: This creates an error in AMIE because (Retired) COMP & PEN Primary = DVBC when DVBC is a legitimate added prefix for AMIE
  1. ; COMP & PEN should be deleted from the Package Parameter file
  1. ;
  1. ; ^TMP("XTVS-PREFIX-IDX",$J,PKGPFX,PKGNAME)="" ;Primary Prefix,Pkg-Name for packages in Forum Param file
  1. ; ^TMP("XTVS-FORUM-PFXS",$J,PREFIX)="" ;All Prefixes in package file
  1. ; Following ^TMP for PACKAGES in Param file : Prefix,Pkg-Name = 1 when KIDS Prefix, Null when not KIDS Prefix
  1. ; ^TMP("XTVS-IDX-PKG",$J,PREFIX,PKGNAME)=$S($D(^TMP("XTVS-KIDSPFX-IDX",$J,PREFIX)):1,1:"")
  1. ; Output: Result - 1 count prefix ; 0 don't count prefix
  1. NEW RESULT,LPPKG
  1. SET RESULT=1
  1. SET LPPKG=""
  1. ;
  1. ; If not the KIDS Prefix or Primary prefix, check for duplication in other packages
  1. IF ($G(^TMP("XTVS-KIDSPFX-IDX",$J,APFX))'=PKGNAME),('$D(^TMP("XTVS-PREFIX-IDX",$J,APFX,PKGNAME))) SET RESULT=$$CHKOTHPK(APFX,PKGNAME)
  1. ;
  1. QUIT RESULT
  1. ;
  1. CHKOTHPK(APFX,PKGNAME) ; Check other packages using the same prefix
  1. NEW LPPKG,RESULT
  1. SET LPPKG=""
  1. SET RESULT=1
  1. ;
  1. FOR SET LPPKG=$O(^TMP("XTVS-IDX-PKG",$J,APFX,LPPKG)) Q:LPPKG="" Q:'RESULT IF (LPPKG'=PKGNAME) DO
  1. . IF $G(^TMP("XTVS-IDX-PKG",$J,APFX,LPPKG))=1 SET RESULT=0 ;APFX: KIDS prefix for another package in Param file
  1. . IF $D(^TMP("XTVS-PREFIX-IDX",$J,APFX,LPPKG)) SET RESULT=0 ;APFX: Primay prefix for other package in Param file
  1. ;
  1. QUIT RESULT
  1. ;
  1. KIDSIDX ;Create Prefix-Package Indexes from KIDS patches for builds linked to Package file
  1. NEW KIDSIEN,KIDSPKG,KIDSPRFX,KIDSZERO,PKGIEN,PATCHNME
  1. SET KIDSIEN=0
  1. FOR SET KIDSIEN=$O(^XPD(9.6,KIDSIEN)) Q:+KIDSIEN=0 DO
  1. . SET KIDSZERO=$G(^XPD(9.6,KIDSIEN,0))
  1. . IF KIDSZERO]"" DO
  1. .. SET PKGIEN=$P(KIDSZERO,"^",2)
  1. .. IF +PKGIEN>0 DO
  1. ... SET KIDSPKG=$P($G(^DIC(9.4,PKGIEN,0)),"^",1)
  1. ... SET PATCHNME=$P(KIDSZERO,"^",1)
  1. ... SET KIDSPRFX=$P(PATCHNME,"*",1)
  1. ... IF KIDSPRFX]"" SET ^TMP("XTVS-KIDSPFX-IDX",$J,KIDSPRFX)=KIDSPKG
  1. QUIT
  1. ;
  1. PARAMIDX ;Create Prefix Indicies
  1. NEW PKGNAME,LINEITEM,TMPSUB,PKGPFX,ADDPRFX,PREFIX
  1. ;
  1. SET TMPSUB=0
  1. FOR SET TMPSUB=$O(^TMP("XTVS-PARAM-CAP",$J,TMPSUB)) QUIT:TMPSUB="" DO
  1. .SET LINEITEM=^TMP("XTVS-PARAM-CAP",$J,TMPSUB)
  1. .SET PKGNAME=$P(LINEITEM,"^")
  1. .SET PKGPFX=$P(LINEITEM,"^",2)
  1. .SET ^TMP("XTVS-PREFIX-IDX",$J,PKGPFX,PKGNAME)="" ;Primary Prefix,Pkg-Name for packages in remote (E.G. Forum) Param file
  1. .SET ^TMP("XTVS-FORUM-PFXS",$J,PKGPFX)="" ;Prefix
  1. .; Following ^TMP for PACKAGES in Param file: Prefix,Pkg-Name = 1 when KIDS Prefix, Null when not KIDS Prefix
  1. .;SET ^TMP("XTVS-IDX-PKG",$J,PKGPFX,PKGNAME)=$S($D(^TMP("XTVS-KIDSPFX-IDX",$J,PKGPFX)):1,1:"")
  1. . IF '$D(^TMP("XTVS-KIDSPFX-IDX",$J,PKGPFX)) SET ^TMP("XTVS-IDX-PKG",$J,PKGPFX,PKGNAME)=""
  1. . IF $D(^TMP("XTVS-KIDSPFX-IDX",$J,PKGPFX)) SET ^TMP("XTVS-IDX-PKG",$J,PKGPFX,PKGNAME)=$S(^TMP("XTVS-KIDSPFX-IDX",$J,PKGPFX)=PKGNAME:1,1:"")
  1. .;
  1. .SET ADDPRFX=$P(LINEITEM,"^",5)
  1. .SET LPCNT=0
  1. .FOR PCENUM=1:1 SET PREFIX=$P(ADDPRFX,"|",PCENUM) Q:PREFIX="" DO
  1. .. SET ^TMP("XTVS-FORUM-PFXS",$J,PREFIX)="" ;Prefix
  1. .. ; Following ^TMP for PACKAGES in Param file : Prefix,Pkg-Name = 1 when KIDS Prefix, Null when not KIDS Prefix
  1. .. SET ^TMP("XTVS-IDX-PKG",$J,PREFIX,PKGNAME)=$S($D(^TMP("XTVS-KIDSPFX-IDX",$J,PREFIX)):1,1:"")
  1. ;
  1. QUIT
  1. ;
  1. RSIZE(RTN) ; Compute routine size (# characters plus line feeds) [^%ZOSF("SIZE") algorithm]
  1. NEW LINE,CT,RSIZEVAL
  1. SET (CT,RSIZEVAL)=0
  1. SET LINE=""
  1. X "ZL @RTN F S CT=CT+1,LINE=$T(+CT) Q:$L(LINE)=0 SET RSIZEVAL=RSIZEVAL+$L(LINE)+2"
  1. QUIT RSIZEVAL
  1. ;
  1. PFXDLIM(SPCPOS,DASHPOS,UNDRSPOS) ; Return the delimter for lowest pos #
  1. NEW DELIM
  1. SET:SPCPOS=0 SPCPOS=9999
  1. SET:DASHPOS=0 DASHPOS=9999
  1. SET:UNDRSPOS=0 UNDRSPOS=9999
  1. SET DELIM=" "
  1. SET:((SPCPOS<DASHPOS)&(SPCPOS<UNDRSPOS)) DELIM=" "
  1. SET:((DASHPOS<SPCPOS)&(DASHPOS<UNDRSPOS)) DELIM="-"
  1. SET:((UNDRSPOS<DASHPOS)&(UNDRSPOS<SPCPOS)) DELIM="_"
  1. QUIT DELIM