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

XTVSLN.m

Go to the documentation of this file.
  1. XTVSLN ;ALBANY FO/GTS - VistA Package Sizing Manager; 30-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 PKG MGR EXTRACT MNGR
  1. D EN^VALM("XTVS PKG MGR EXTRACT MNGR")
  1. Q
  1. ;
  1. HDR ; -- header code
  1. SET VALMHDR(1)=" VistA Package Size Analysis Manager - Extract Manager"
  1. SET VALMHDR(2)=" Version: "_$$VERNUM^XTVSLM()_" Build: "_$$BLDNUM^XTVSLM()
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. NEW DEFDIR
  1. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. DO KILL ;Kill all processing & data arrays and video attributes & control arrays
  1. SET VALMCNT=0
  1. DO ADD^XTVSLAPI(.VALMCNT," ")
  1. DO ADD^XTVSLAPI(.VALMCNT," Extracted package ^XTMP global list")
  1. DO ADD^XTVSLAPI(.VALMCNT," XTMPSIZE.DAT default directory: "_$S($G(DEFDIR)]"":DEFDIR,1:"<no default defined>"),1,36,$S($L(DEFDIR)>0:$L(DEFDIR),1:20))
  1. DO ADD^XTVSLAPI(.VALMCNT," ")
  1. DO ADD^XTVSLAPI(.VALMCNT," Process ID System Date/Time")
  1. DO ADD^XTVSLAPI(.VALMCNT," ----------------------------------------------------")
  1. DO ADD^XTVSLAPI(.VALMCNT," ")
  1. DO FNDXTMP
  1. DO MSG
  1. Q
  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 !,"Extract Manager List 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(LNTXT+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. S VALMBCK="R"
  1. DO MSG
  1. K XTX,Y,TXTCT,XTQVAR
  1. QUIT
  1. ;
  1. EXIT ; -- exit code
  1. D KILL
  1. Q
  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. REFRESH ; -- On Return from another Template or action, refresh XTVS PKG MGR EXTRACT MNGR List Template array
  1. NEW LNENUM,XTDOLRJ,DEFDIR,DEFDRTXT
  1. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. DO KILL^XTVSLN ;Kill all processing & data arrays and video attributes & control arrays for XTVS PKG MGR EXTRACT MNGR template
  1. SET EMGRTARY="^TMP(""XTVS PKG MGR EXTRACT"","_$J_")"
  1. SET LNENUM=0
  1. SET DEFDRTXT=" XTMPSIZE.DAT default directory: "_$S($G(DEFDIR)]"":DEFDIR,1:"<no default defined>")
  1. DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ")
  1. DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," Extracted package ^XTMP global list")
  1. DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM,DEFDRTXT)
  1. DO CNTRL^VALM10(LNENUM,36,$S($L(DEFDIR)>0:$L(DEFDIR),1:20),IOUON,IOUOFF)
  1. DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ")
  1. DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," Process ID System Date/Time")
  1. DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ----------------------------------------------------")
  1. DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ")
  1. ;
  1. SET XTDOLRJ=0
  1. FOR SET XTDOLRJ=$O(^XTMP("XTSIZE",XTDOLRJ)) Q:+XTDOLRJ=0 DO
  1. . NEW DATE,EXSYS
  1. . SET DATE=$P($P(^XTMP("XTSIZE",XTDOLRJ,0),"^",3),"-")
  1. . SET EXSYS=$P(^XTMP("XTSIZE",XTDOLRJ,0),"^",4)
  1. . SET DATE=$$FMTE^XLFDT(DATE,"1P")
  1. . DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM,$J(XTDOLRJ,13)_$J(EXSYS,15)_$J(DATE,27))
  1. IF LNENUM'>7 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," No Extracts defined.")
  1. QUIT
  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 EXTRACT",$JOB)
  1. KILL DIR,X,Y,DTOUT,DIRUT,DUOUT
  1. QUIT
  1. ;
  1. FNDXTMP ; List Package Extracts
  1. NEW XTDOLRJ
  1. SET XTDOLRJ=0
  1. FOR SET XTDOLRJ=$O(^XTMP("XTSIZE",XTDOLRJ)) Q:+XTDOLRJ=0 DO
  1. . NEW DATE,EXSYS
  1. . SET DATE=$P($P(^XTMP("XTSIZE",XTDOLRJ,0),"^",3),"-")
  1. . SET EXSYS=$P(^XTMP("XTSIZE",XTDOLRJ,0),"^",4)
  1. . SET DATE=$$FMTE^XLFDT(DATE,"1P")
  1. . DO ADD^XTVSLAPI(.VALMCNT,$J(XTDOLRJ,13)_$J(EXSYS,15)_$J(DATE,27))
  1. IF VALMCNT'>7 DO ADD^XTVSLAPI(.VALMCNT," No Extracts defined.")
  1. QUIT
  1. ;
  1. SELDOLRJ() ; Select a Process ID
  1. ;OUTPUT:
  1. ; RESULT : Selected PID
  1. ; : 0 (failure)
  1. NEW RESULT,DIR,X,Y
  1. D FULL^VALM1
  1. SET DIR("A",1)=""
  1. SET DIR("A")="Enter the Extract Process ID ($JOB) number"
  1. SET DIR("?")="Enter a number from the list."
  1. SET DIR(0)="N::"
  1. DO ^DIR
  1. SET:'$D(DIRUT) RESULT=Y
  1. SET:$D(DIRUT) RESULT=0
  1. Q RESULT
  1. ;
  1. CRTPMCLN ;Kill temporary globals created by 'XTVS PKG EXT CRT PARAM ACTION' Protocol
  1. KILL ^TMP("XTVS-FILERPT",$J),^TMP("XTSIZE",$J) ;,^TMP("XTSIZE","IDX",$J)
  1. QUIT
  1. ;
  1. ;PROTOCOL entry points
  1. DE ; -- Delete Extracts
  1. ; -- Protocol: XTVS PKG EXTRACT DEL ACTION
  1. NEW PROCID
  1. SET PROCID=$$SELDOLRJ() ;Prompt user to enter a Process ID
  1. ;
  1. IF 'PROCID DO JUSTPAWS^XTVSLAPI("No Process ID selected.")
  1. IF (PROCID),('$D(^XTMP("XTSIZE",PROCID))) DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_PROCID_") is NOT defined!")
  1. IF (PROCID),($D(^XTMP("XTSIZE",PROCID))) DO
  1. . NEW X,Y,DIR
  1. . SET DIR("A",1)=""
  1. . SET DIR("A")="Do you want to delete ^XTMP(""XTSIZE"","_PROCID_")"
  1. . SET DIR("B")="NO"
  1. . SET DIR(0)="Y::"
  1. . DO ^DIR
  1. . IF ('$D(DTOUT)),('$D(DUOUT)),(($G(Y)=1)) KILL ^XTMP("XTSIZE",PROCID) DO KILL,INIT
  1. . IF ($D(DTOUT))!($D(DUOUT))!(($G(Y)=0)) DO
  1. .. DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_PROCID_") NOT DELETED!")
  1. ;
  1. DO MSG
  1. KILL X,Y,DTOUT,DIRUT,DUOUT
  1. SET VALMBCK="R"
  1. QUIT
  1. ;
  1. ED ; - Display Extract
  1. ; -- Protocol: XTVS PKG MGR EXT DISP ACTION
  1. ;
  1. NEW XPID,QCHK
  1. SET QCHK=0
  1. SET XPID=$$SELDOLRJ() ;Prompt user to enter a Process ID
  1. ;
  1. IF 'XPID DO JUSTPAWS^XTVSLAPI("No Process ID selected.") SET QCHK=1
  1. IF (XPID),('$D(^XTMP("XTSIZE",XPID))) DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") is NOT defined!") SET QCHK=1
  1. IF 'QCHK DO EN^XTVSLDE
  1. DO MSG
  1. SET VALMBCK="R"
  1. QUIT
  1. ;
  1. PEXT ; -- Extract Package Data
  1. ; -- Protocol: XTVS PKG EXTRACT CREATE ACTION
  1. ;
  1. NEW EXTRSLT
  1. SET EXTRSLT=$$PKGEXT^XTVSLNA1()
  1. DO REFRESH
  1. DO MSG
  1. SET VALMBCK="R"
  1. QUIT
  1. ;
  1. CRTPARM ; Convert Extract to Parameter list
  1. ; -- Protocol: XTVS PKG EXT CRT PARAM ACTION
  1. ; Display Package Parameter file from selected ^XTMP("XTSIZE") extract global
  1. ;
  1. NEW XPID,QCHK
  1. SET QCHK=0
  1. SET XPID=$$SELDOLRJ() ;Prompt user to enter a Process ID
  1. ;
  1. IF 'XPID DO JUSTPAWS^XTVSLAPI("No Process ID selected.") SET QCHK=1
  1. IF (XPID),('$D(^XTMP("XTSIZE",XPID))) DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") is NOT defined!") SET QCHK=1
  1. IF 'QCHK DO
  1. . DO XTMPORD^XTVSLNA1(XPID) ; Create ^TMP("XTSIZE"), Parameter file
  1. . ; Note Family Tree Index: ^TMP("XTSIZE","IDX",$J)
  1. . DO EN^XTVSCP(XPID) ;Display Corrections report
  1. . DO CRTPMCLN ; KILL ^TMP globals
  1. . DO REFRESH
  1. ;
  1. DO MSG
  1. SET VALMBCK="R"
  1. QUIT
  1. ;
  1. EEXT ; - Email extract global [^XTMP("XTSIZE")]
  1. ; -- Protocol: XTVS PKG EXT EMAIL ACTION
  1. ;
  1. NEW XPID,QCHK
  1. SET QCHK=0
  1. WRITE !!," The message can take some time to be sent."
  1. SET XPID=$$SELDOLRJ() ;Prompt user to enter a Process ID
  1. ;
  1. IF 'XPID DO JUSTPAWS^XTVSLAPI("No Process ID selected.") SET QCHK=1
  1. IF (XPID),('$D(^XTMP("XTSIZE",XPID))) DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") is NOT defined!") SET QCHK=1
  1. IF 'QCHK DO
  1. . NEW XTINSTMM,XTTOMM,XMERR,XMZ,XTTYPE
  1. . KILL XMERR
  1. . SET XTINSTMM("ADDR FLAGS")="R" ;Do not Restrict addressing
  1. . SET XTTYPE="S"
  1. . DO TOWHOM^XMXAPIU(DUZ,,XTTYPE,.XTINSTMM)
  1. . IF +$G(XMERR)'>0 DO
  1. .. NEW XMY,XMTEXT,XMDUZ,XMSUB,XDATE,XTLPCNT,XMMG,XMZ
  1. .. SET XTLPCNT=""
  1. .. FOR SET XTLPCNT=$O(^TMP("XMY",$J,XTLPCNT)) QUIT:XTLPCNT="" SET XMY(XTLPCNT)=""
  1. .. SET XMDUZ=DUZ
  1. .. SET XDATE=$P($P(^XTMP("XTSIZE",XPID,0),"^",3),"-")
  1. .. SET XDATE=$$FMTE^XLFDT(XDATE,"1P")
  1. .. SET XMSUB="PACKAGE FILE EXTRACT ("_$P(^XTMP("XTSIZE",XPID,0),"^",4)_" ; "_XDATE_" ; $JOB#: "_XPID_")"
  1. .. SET XMTEXT="^XTMP(""XTSIZE"","_XPID_","
  1. .. DO ENT^XMPG
  1. .. IF +XMZ>0 DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") Emailed via PackMan. [MSG #:"_XMZ_"]")
  1. .. IF +XMZ'>0 DO JUSTPAWS^XTVSLAPI("Error: ^XTMP(""XTSIZE"","_XPID_") not sent in Packman. ["_XMZ_"]")
  1. ;
  1. DO MSG
  1. SET VALMBCK="R"
  1. QUIT
  1. ;
  1. QRYEXT ; Remote VistA Extract Query ; Request Package File Extract from another VistA [E.G. Forum]
  1. ; -- Protocol: XTVS PKG EXT QUERY REMOTE ACTION
  1. ;
  1. NEW XTVSFQ,DIR,XMY,XTVSSZRP,XTVSRPT
  1. SET XTVSSZRP=0
  1. ;
  1. D FULL^VALM1
  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 query the Forum Package File? "
  1. SET DIR("B")="YES"
  1. SET DIR("?",1)="Yes to query Forum."
  1. SET DIR("?",2)="No to query another VistA."
  1. SET DIR("?")="Enter '^' to exit."
  1. SET DIR(0)="YA"
  1. DO ^DIR
  1. SET XTVSFQ=$GET(Y)
  1. IF ($DATA(DUOUT))!($DATA(DTOUT))!($DATA(DIROUT)) DO JUSTPAWS^XTVSLAPI("Forum query not indicated!")
  1. KILL DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1. ;
  1. ; Forum, prompt for a Size report from Forum; SET XTVSSIZE=1; and send to SERVER OPTION
  1. IF XTVSFQ=1 DO
  1. . SET XTVSSZRP=$$SIZRPTQY()
  1. . IF XTVSSZRP>-1 SET XMY("S.XTVS PKG EXTRACT SERVER@DOMAIN.EXT")="" ;Query FORUM for size rpt
  1. . IF XTVSSZRP=-1 DO JUSTPAWS^XTVSLAPI("Size Report prompt not answered!")
  1. ;
  1. ; Not Forum, Query VistA site (Domain)
  1. IF XTVSFQ=0 DO
  1. . KILL DIC,X,Y,DTOUT,DUOUT,XTVSYDOM
  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. . SET XTVSYDOM=Y
  1. . IF ($DATA(DUOUT))!($DATA(DTOUT))!(+XTVSYDOM=-1) DO JUSTPAWS^XTVSLAPI("VistA Domain not selected!")
  1. . IF '$DATA(DUOUT),'$DATA(DTOUT),+XTVSYDOM>0 DO
  1. .. IF $PIECE(XTVSYDOM,"^",2)["FORUM" DO
  1. ... SET XTVSSZRP=$$SIZRPTQY() ;Query Size rpt
  1. ... IF XTVSSZRP=-1 DO JUSTPAWS^XTVSLAPI("Size Report prompt not answered!")
  1. .. SET XMY("S.XTVS PKG EXTRACT SERVER@"_$PIECE(XTVSYDOM,"^",2))="" ;Query address for size rpt
  1. . KILL DIC,X,Y,DTOUT,DUOUT
  1. ;
  1. IF ($DATA(XMY)) DO
  1. . NEW XMTEXT,XMDUZ,XMSUB,XDATE,XMMG,XMZ,TMP
  1. . SET TMP("XTVS REQ MSG",1)="REQUESTED BY: "_$$NETNAME^XMXUTIL(DUZ)
  1. . SET TMP("XTVS REQ MSG",2)="Extract Indicator: 1" ; Extract package file
  1. . IF XTVSSZRP=1 SET TMP("XTVS REQ MSG",3)="Report Indicator: 1" ; Request All Packages Size rpt
  1. . SET XMDUZ=DUZ
  1. . SET XMSUB="XTVS: PACKAGE FILE EXTRACT & REPORT REQUEST"
  1. . SET XMTEXT="TMP(""XTVS REQ MSG"","
  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. DO MSG
  1. SET VALMBCK="R"
  1. QUIT
  1. ;
  1. SIZRPTQY() ; Prompt for Forum Size Rpt
  1. NEW DIR,X,Y,RESULT
  1. SET RESULT=-1
  1. SET DIR("A",1)=""
  1. SET DIR("A")="Do you want a VistA Package Size Report for all packages on Forum? "
  1. SET DIR("B")="NO"
  1. SET DIR("?",1)="Yes to receive a Package Size report on Forum."
  1. SET DIR("?",2)="No to just receive a Forum Package file extract."
  1. SET DIR("?")="Enter '^' to exit."
  1. SET DIR(0)="YA"
  1. DO ^DIR
  1. IF '$DATA(DTOUT),'$DATA(DUOUT) SET RESULT=Y
  1. QUIT RESULT