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

XTVSLR.m

Go to the documentation of this file.
  1. XTVSLR ;ALBANY FO/GTS - VistA Package Sizing Manager; 27-JUN-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. EN ; -- main entry point for XTVS VISTA SIZE RPT
  1. DO EN^VALM("XTVS PKG MGR VISTA SIZE RPT")
  1. QUIT
  1. ;
  1. HDR ; -- Main header code
  1. NEW DEFDIR,SPCPAD,DIRHEAD
  1. SET SPCPAD=""
  1. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. SET VALMHDR(1)=" VistA Package Size Analysis Manager - Package Statistics"
  1. SET VALMHDR(2)=" Version: "_$$VERNUM^XTVSLM()_" Build: "_$$BLDNUM^XTVSLM()
  1. SET DIRHEAD="Default Directory: "_DEFDIR
  1. SET $P(SPCPAD," ",(80-$L(DIRHEAD))/2)=""
  1. SET VALMHDR(3)=SPCPAD_DIRHEAD
  1. SET SPCPAD=""
  1. SET DIRHEAD="Parameter file: "_XTVPSPRM
  1. SET $P(SPCPAD," ",(80-$L(DIRHEAD))/2)=""
  1. SET VALMHDR(4)=SPCPAD_DIRHEAD
  1. QUIT
  1. ;
  1. HDRA ; -- Alternate header code
  1. SET VALMHDR(1)=""
  1. SET VALMHDR(2)=" Total"
  1. SET VALMHDR(3)="Application Rtn"
  1. SET VALMHDR(4)="(Namespace) Routines Size Files Fields Options Protocols RPCs Templates"
  1. QUIT
  1. ;
  1. INIT ; -- init variables and list array
  1. NEW XTVSXFNM
  1. KILL ^TMP("XTVS PKG MGR RPT",$JOB)
  1. DO FULL^VALM1
  1. IF (+$G(FIRSTITM)>0),($G(LASTITM)>0) DO
  1. . NEW CHKLKER,LCKCHK,DEFDIR
  1. . SET XTVSXFNM=$$SELXTMP^XTVSLAPI(FIRSTITM,LASTITM)
  1. . IF XTVSXFNM]"" DO
  1. .. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. .. SET XTVPSPRM=XTVSXFNM
  1. .. SET LASTSPKG=""
  1. .. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM) ;Returns 1 when current process has lock
  1. .. SET CHKLKER=$$REQLOCK^XTVSLAPI(XTVPSPRM) ;Returns 1 when any process has lock
  1. .. IF (+CHKLKER=0)!(+LCKCHK=1) DO
  1. ... WRITE:(+CHKLKER=0) !!,$P(CHKLKER,"^",2)
  1. ... WRITE:(+LCKCHK=1) !!,XTVPSPRM_" LOCK already held."
  1. ... DO BUILD
  1. .. IF (+CHKLKER=1),(+LCKCHK'=1) DO
  1. ... W !!," <* LOCK request denied! Try again later. *>"
  1. ... DO JUSTPAWS^XTVSLAPI($P(CHKLKER,"^",2))
  1. ... S VALMQUIT=""
  1. . IF XTVSXFNM']"" SET VALMQUIT=""
  1. IF ((+$G(FIRSTITM)'>0)&(+$G(LASTITM)'>0))!($G(XTVSXFNM)']"") SET VALMQUIT=""
  1. DO MSG
  1. QUIT
  1. ;
  1. BUILD ; - Build local and global display arrays
  1. NEW UNLKRSLT
  1. SET VALMCNT=0
  1. DO INIT^XTVSRFL(.VALMCNT,XTVPSPRM)
  1. SET UNLKRSLT=$$UNLCKPFL^XTVSLAPI(XTVPSPRM)
  1. IF +UNLKRSLT DO JUSTPAWS^XTVSLAPI($P(UNLKRSLT,"^",2))
  1. IF VALMCNT'>0 SET VALMQUIT=""
  1. QUIT
  1. ;
  1. HELP ; -- help code
  1. IF $D(X),X'["??" DO
  1. . SET X="?"
  1. . DO DISP^XQORM1 W !
  1. IF $D(X),X["??" DO
  1. . DO CLEAR^VALM1
  1. . DO FULL^VALM1
  1. . WRITE !,"Package Statistics action help..."
  1. . WRITE !,"List specific actions:",!
  1. . DO DISP^XQORM1 W !
  1. . SET XTQVAR=Y
  1. . IF XTQVAR DO
  1. .. SET XTQVAR=0
  1. .. FOR TXTCT=1:1 SET XTX=$P($T(LRTXT+TXTCT^XTVSHLP1),";",3,99) QUIT:XTX="$END" QUIT:XTQVAR DO
  1. ... IF XTX="$PAUSE" DO PAUSE^VALM1 D:Y CLEAR^VALM1 IF 'Y SET XTQVAR=1 QUIT
  1. ... W !,$S(XTX["$PAUSE":"",1:XTX)
  1. . W !
  1. D MSG
  1. S VALMBCK="R"
  1. K XTX,Y,TXTCT,XTQVAR
  1. QUIT
  1. ;
  1. EXIT ; -- exit code
  1. D KILL
  1. Q
  1. ;
  1. KILL ; - Cleanup local and global display arrays
  1. DO CLEAN^VALM10 ;Kill data and video control arrays
  1. DO KILL^VALM10() ;Kill Video attributes
  1. KILL ^TMP("XTVS PKG MGR RPT",$JOB),LASTSPKG
  1. KILL DIR,X,Y,DTOUT,DIRUT,DUOUT
  1. QUIT
  1. ;
  1. MSG(TEXT) ; -- set default message
  1. IF $G(TEXT)]"" SET VALMSG=TEXT
  1. IF $G(TEXT)']"" SET VALMSG="Enter ?? for more actions and Help"
  1. QUIT
  1. ;
  1. ; ListMan Report Action APIs
  1. TEXTFILE ; Write report to text file
  1. ; -- Protocol: XTVS PKG MGR RPT WRT ACTION
  1. ;
  1. DO FULL^VALM1
  1. ;
  1. NEW DIR,Y,X,FILENME,STORPATH
  1. SET (FILENME,STORPATH)=""
  1. SET DIR(0)="FAOr^2:60^"
  1. SET DIR("A")="Enter directory to write report file: "_$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. SET DIR("A",1)=" "
  1. SET DIR("B")=""
  1. SET DIR("?")="Enter '^' to abort Host File creation."
  1. SET DIR("?",1)="Enter a host directory where you have write privileges"
  1. SET DIR("?",2)=" and at least 10K of space."
  1. SET DIR("?",3)=" "
  1. DO ^DIR
  1. ;
  1. IF '$D(DTOUT),'$D(DUOUT),'$D(DIROUT) DO
  1. . SET:X]"" STORPATH=X
  1. . SET:X']"" STORPATH=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. . NEW DIR,Y,X
  1. . SET DIR(0)="FAOr^3:30^"
  1. . SET DIR("A")="Enter the name of the Host File "
  1. . SET DIR("A",1)=" "
  1. . SET DIR("B")="VistAPkgSize_"_$P($$NOW^XLFDT,".",1)_$P($$NOW^XLFDT,".",2)_".txt"
  1. . SET DIR("?")="Enter '^' to abort Host File creation."
  1. . SET DIR("?",1)="The file will be written to "_STORPATH
  1. . DO ^DIR
  1. . IF '$D(DTOUT),'$D(DUOUT),'$D(DIROUT) DO
  1. .. SET FILENME=Y
  1. .. DO WRTTXTFL^XTVSLAPI(FILENME,STORPATH)
  1. ;
  1. DO MSG
  1. SET VALMBCK="R"
  1. QUIT
  1. ;
  1. REMREQ ; - Remote VistA Size Query
  1. ; -- Protocol: XTVS PKG MGR RPT QUERY REMOTE ACTION
  1. ;
  1. NEW LCKCHK,CHKLKER
  1. DO FULL^VALM1
  1. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM) ;Returns 1 when current process has lock
  1. SET CHKLKER=$$REQLOCK^XTVSLAPI(XTVPSPRM) ;Returns 1 when any process has lock
  1. IF (+CHKLKER=0)!(+LCKCHK=1) DO
  1. . WRITE:(+CHKLKER=0) !!,$P(CHKLKER,"^",2)
  1. . WRITE:(+LCKCHK=1) !!,XTVPSPRM_" LOCK already held."
  1. . DO REMRPTRQ(XTVPSPRM)
  1. IF (+CHKLKER=1),(+LCKCHK'=1) DO
  1. . WRITE !!," <* LOCK request denied! Try again later. *>"
  1. . DO JUSTPAWS^XTVSLAPI($P(CHKLKER,"^",2))
  1. DO MSG
  1. SET VALMBCK="R"
  1. QUIT
  1. ;
  1. ; ListMan Report Action APIs
  1. REMRPTRQ(XTVPSPRM) ; Request remote report file
  1. ; Called from APIs invoked by Protocols:
  1. ; XTVS PKG QUERY REMOTE VISTA SIZE ACTION [Remote VistA Size Query
  1. ; - from VistA Package Size Analysis Manager LM display]
  1. ; XTVS PKG MGR RPT QUERY REMOTE ACTION [Remote VistA Size Query - from Package Statistics LM display]
  1. ;
  1. NEW LINEITEM,XTVSRQ,DIR,XMY,XTVSRPT,PRMDSPCT,XTVSPVAL,PKGNAME,XTVSRMCT,UNLKRSLT
  1. ;
  1. SET LINEITEM=""
  1. SET PKGNAME=0
  1. KILL XMY
  1. ;
  1. SET DIR("A",1)=""
  1. SET DIR("A",2)=" The response from a remote VistA can take some time."
  1. SET DIR("A",3)=""
  1. SET DIR("A")="Do you want to request a report from a remote VistA? "
  1. SET DIR("B")="YES"
  1. SET DIR("?",1)="Yes to query remote system using the displayed parameters."
  1. SET DIR("?",2)="No to abort request action."
  1. SET DIR("?")="Enter '^' to exit."
  1. SET DIR(0)="YA"
  1. DO ^DIR
  1. SET XTVSRQ=$GET(Y)
  1. IF ($DATA(DUOUT))!($DATA(DTOUT))!($DATA(DIROUT))!(XTVSRQ=0) DO
  1. . W !!,"Size Report prompt not answered!"
  1. . SET UNLKRSLT=$$UNLCKPFL^XTVSLAPI(XTVPSPRM)
  1. . IF ($P(UNLKRSLT,"^")'=1) W !!," <* UNLOCK ERROR. Check LOCK file Integrity. *>"
  1. . DO JUSTPAWS^XTVSLAPI($P(UNLKRSLT,"^",2))
  1. ;
  1. KILL DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1. ;
  1. ; If query remote system, select package to report
  1. IF XTVSRQ=1 DO
  1. . WRITE !!," ...Loading Parameters...",!
  1. . SET XTVSRMCT=4
  1. . DO OPEN^%ZISH("XTMP",DEFDIR,XTVPSPRM,"R")
  1. . U IO
  1. . FOR S LINEITEM="" READ LINEITEM:5 Q:$$STATUS^%ZISH IF LINEITEM]"" DO
  1. .. DO ADD2MSG(LINEITEM,"XTVS REQ MSG",.XTVSRMCT)
  1. .. DO SCAPARY^XTVSLP(LINEITEM) ;^TMP("XTVS-PARAM-CAP",$J) needed for $$SELPKG^XTVSLPDC(0) (XT*7.3*152)
  1. . DO CLOSE^%ZISH("XTMP")
  1. . ;
  1. . SET UNLKRSLT=$$UNLCKPFL^XTVSLAPI(XTVPSPRM)
  1. . IF ($P(UNLKRSLT,"^")'=1) W !!," <* UNLOCK ERROR. Check LOCK file Integrity. *>"
  1. . W !,$P(UNLKRSLT,"^",2),!
  1. . ;
  1. . SET PKGNAME=$$SELPKG^XTVSLPDC(0)
  1. . SET LINEITEM=""
  1. ;
  1. IF PKGNAME=0,XTVSRQ=1 DO JUSTPAWS^XTVSLAPI("VistA Package not selected!")
  1. ; If package selected, select VistA site (Domain)
  1. IF PKGNAME'=0 DO
  1. . SET LASTSPKG=PKGNAME
  1. . SET LINEITEM=^TMP("XTVS-PARAM-CAP",$J,PKGNAME)
  1. . KILL DIC,X,Y,DTOUT,DUOUT
  1. . SET DIC="^DIC(4.2,"
  1. . SET DIC(0)="AEQ"
  1. . SET DIC("A")="Domain server to query: "
  1. . SET DIC("S")="I $P(^(0),U,2)'=""C""" ;Screen "CLOSED" domains
  1. . DO ^DIC
  1. . IF '$DATA(DUOUT),'$DATA(DTOUT),(+Y>-1) SET XMY("S.XTVS PKG EXTRACT SERVER@"_$PIECE(Y,"^",2))="" ;Query address for size rpt
  1. . IF ($DATA(DUOUT))!($DATA(DTOUT))!(+Y=-1) DO JUSTPAWS^XTVSLAPI("VistA Domain not selected!")
  1. . KILL DIC,X,Y,DTOUT,DUOUT
  1. ;
  1. ; If site selected, send query message
  1. IF ($DATA(XMY)) DO
  1. . NEW XMTEXT,XMDUZ,XMSUB,XDATE,XMMG,XMZ,TMP
  1. . SET ^TMP("XTVS REQ MSG",$J,1)="REQUESTED BY: "_$$NETNAME^XMXUTIL(DUZ)
  1. . SET ^TMP("XTVS REQ MSG",$J,2)="Extract Indicator: 0" ; No Extract requested
  1. . SET ^TMP("XTVS REQ MSG",$J,3)="Report Indicator: 2" ; Request Single Package Size rpt
  1. . SET ^TMP("XTVS REQ MSG",$J,4)="Package Parameters: "_LINEITEM ; Package to report at remote site
  1. . SET XMDUZ=DUZ
  1. . SET XMSUB="XTVS: PACKAGE FILE EXTRACT & REPORT REQUEST"
  1. . SET XMTEXT="^TMP(""XTVS REQ MSG"","_$J_","
  1. . DO ^XMD
  1. . IF +$GET(XMZ)<1 DO
  1. .. DO JUSTPAWS^XTVSLAPI("Error sending query message: "_XMMG_"!")
  1. . IF +$GET(XMZ)>0 DO
  1. .. DO JUSTPAWS^XTVSLAPI("Query message sent! Message # "_XMZ)
  1. ;
  1. KILL ^TMP("XTVS REQ MSG",$J),^TMP("XTVS-PARAM-CAP",$J)
  1. ;
  1. QUIT
  1. ;
  1. ADD2MSG(LINEITEM,ARRYNAME,XTVSRMCT) ;Add a parameters to Request Message array (XT*7.3*152)
  1. NEW EXTSTR
  1. SET EXTSTR=$EXTRACT(LINEITEM,1,255)
  1. SET XTVSRMCT=XTVSRMCT+1
  1. IF $L(LINEITEM)'>255 SET ^TMP(ARRYNAME,$J,XTVSRMCT)=LINEITEM
  1. IF $L(LINEITEM)>255 SET ^TMP(ARRYNAME,$J,XTVSRMCT)=EXTSTR DO
  1. . DO ADD2MSG($E(LINEITEM,256,9999999),ARRYNAME,.XTVSRMCT) ; Recurse to process next 255 characters
  1. QUIT
  1. ;
  1. SWAPHEAD ;Report of all packages, toggle action header and report header
  1. ; -- Protocol: XTVS PKG RPT SWAP HEADER
  1. NEW SWAPPD
  1. SET SWAPPD=0
  1. IF VALMHDR(1)="" KILL VALMHDR DO HDR SET SWAPPD=1
  1. IF 'SWAPPD,VALMHDR(1)'="" KILL VALMHDR DO HDRA
  1. SET VALMBCK="R"
  1. QUIT