XTVSLN ;ALBANY FO/GTS - VistA Package Sizing Manager; 30-JUN-2016
;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point for XTVS PKG MGR EXTRACT MNGR
D EN^VALM("XTVS PKG MGR EXTRACT MNGR")
Q
;
HDR ; -- header code
SET VALMHDR(1)=" VistA Package Size Analysis Manager - Extract Manager"
SET VALMHDR(2)=" Version: "_$$VERNUM^XTVSLM()_" Build: "_$$BLDNUM^XTVSLM()
Q
;
INIT ; -- init variables and list array
NEW DEFDIR
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
DO KILL ;Kill all processing & data arrays and video attributes & control arrays
SET VALMCNT=0
DO ADD^XTVSLAPI(.VALMCNT," ")
DO ADD^XTVSLAPI(.VALMCNT," Extracted package ^XTMP global list")
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))
DO ADD^XTVSLAPI(.VALMCNT," ")
DO ADD^XTVSLAPI(.VALMCNT," Process ID System Date/Time")
DO ADD^XTVSLAPI(.VALMCNT," ----------------------------------------------------")
DO ADD^XTVSLAPI(.VALMCNT," ")
DO FNDXTMP
DO MSG
Q
;
HELP ; -- help code
IF $D(X),X'["??" DO
. SET X="?"
. DO DISP^XQORM1 W !
IF $D(X),X["??" DO
. DO CLEAR^VALM1
. DO FULL^VALM1
. WRITE !,"Extract Manager List action help..."
. WRITE !,"List specific actions:",!
. DO DISP^XQORM1 W !!
. SET XTQVAR=Y
. IF XTQVAR DO
.. SET XTQVAR=0
.. FOR TXTCT=1:1 SET XTX=$P($T(LNTXT+TXTCT^XTVSHLP1),";",3,99) QUIT:XTX="$END" QUIT:XTQVAR DO
... IF XTX="$PAUSE" DO PAUSE^VALM1 D:Y CLEAR^VALM1 IF 'Y SET XTQVAR=1 QUIT
... W !,$S(XTX["$PAUSE":"",1:XTX)
. W !
S VALMBCK="R"
DO MSG
K XTX,Y,TXTCT,XTQVAR
QUIT
;
EXIT ; -- exit code
D KILL
Q
;
MSG(TEXT) ; -- set default message
IF $G(TEXT)]"" SET VALMSG=TEXT
IF $G(TEXT)']"" SET VALMSG="Enter ?? for more actions and Help"
QUIT
;
REFRESH ; -- On Return from another Template or action, refresh XTVS PKG MGR EXTRACT MNGR List Template array
NEW LNENUM,XTDOLRJ,DEFDIR,DEFDRTXT
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
DO KILL^XTVSLN ;Kill all processing & data arrays and video attributes & control arrays for XTVS PKG MGR EXTRACT MNGR template
SET EMGRTARY="^TMP(""XTVS PKG MGR EXTRACT"","_$J_")"
SET LNENUM=0
SET DEFDRTXT=" XTMPSIZE.DAT default directory: "_$S($G(DEFDIR)]"":DEFDIR,1:"<no default defined>")
DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ")
DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," Extracted package ^XTMP global list")
DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM,DEFDRTXT)
DO CNTRL^VALM10(LNENUM,36,$S($L(DEFDIR)>0:$L(DEFDIR),1:20),IOUON,IOUOFF)
DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ")
DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," Process ID System Date/Time")
DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ----------------------------------------------------")
DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ")
;
SET XTDOLRJ=0
FOR SET XTDOLRJ=$O(^XTMP("XTSIZE",XTDOLRJ)) Q:+XTDOLRJ=0 DO
. NEW DATE,EXSYS
. SET DATE=$P($P(^XTMP("XTSIZE",XTDOLRJ,0),"^",3),"-")
. SET EXSYS=$P(^XTMP("XTSIZE",XTDOLRJ,0),"^",4)
. SET DATE=$$FMTE^XLFDT(DATE,"1P")
. DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM,$J(XTDOLRJ,13)_$J(EXSYS,15)_$J(DATE,27))
IF LNENUM'>7 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," No Extracts defined.")
QUIT
;
KILL ; -- Cleanup local and global display arrays
DO CLEAN^VALM10 ;Kill data and video control arrays
DO KILL^VALM10() ;Kill Video attributes
KILL ^TMP("XTVS PKG MGR EXTRACT",$JOB)
KILL DIR,X,Y,DTOUT,DIRUT,DUOUT
QUIT
;
FNDXTMP ; List Package Extracts
NEW XTDOLRJ
SET XTDOLRJ=0
FOR SET XTDOLRJ=$O(^XTMP("XTSIZE",XTDOLRJ)) Q:+XTDOLRJ=0 DO
. NEW DATE,EXSYS
. SET DATE=$P($P(^XTMP("XTSIZE",XTDOLRJ,0),"^",3),"-")
. SET EXSYS=$P(^XTMP("XTSIZE",XTDOLRJ,0),"^",4)
. SET DATE=$$FMTE^XLFDT(DATE,"1P")
. DO ADD^XTVSLAPI(.VALMCNT,$J(XTDOLRJ,13)_$J(EXSYS,15)_$J(DATE,27))
IF VALMCNT'>7 DO ADD^XTVSLAPI(.VALMCNT," No Extracts defined.")
QUIT
;
SELDOLRJ() ; Select a Process ID
;OUTPUT:
; RESULT : Selected PID
; : 0 (failure)
NEW RESULT,DIR,X,Y
D FULL^VALM1
SET DIR("A",1)=""
SET DIR("A")="Enter the Extract Process ID ($JOB) number"
SET DIR("?")="Enter a number from the list."
SET DIR(0)="N::"
DO ^DIR
SET:'$D(DIRUT) RESULT=Y
SET:$D(DIRUT) RESULT=0
Q RESULT
;
CRTPMCLN ;Kill temporary globals created by 'XTVS PKG EXT CRT PARAM ACTION' Protocol
KILL ^TMP("XTVS-FILERPT",$J),^TMP("XTSIZE",$J) ;,^TMP("XTSIZE","IDX",$J)
QUIT
;
;PROTOCOL entry points
DE ; -- Delete Extracts
; -- Protocol: XTVS PKG EXTRACT DEL ACTION
NEW PROCID
SET PROCID=$$SELDOLRJ() ;Prompt user to enter a Process ID
;
IF 'PROCID DO JUSTPAWS^XTVSLAPI("No Process ID selected.")
IF (PROCID),('$D(^XTMP("XTSIZE",PROCID))) DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_PROCID_") is NOT defined!")
IF (PROCID),($D(^XTMP("XTSIZE",PROCID))) DO
. NEW X,Y,DIR
. SET DIR("A",1)=""
. SET DIR("A")="Do you want to delete ^XTMP(""XTSIZE"","_PROCID_")"
. SET DIR("B")="NO"
. SET DIR(0)="Y::"
. DO ^DIR
. IF ('$D(DTOUT)),('$D(DUOUT)),(($G(Y)=1)) KILL ^XTMP("XTSIZE",PROCID) DO KILL,INIT
. IF ($D(DTOUT))!($D(DUOUT))!(($G(Y)=0)) DO
.. DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_PROCID_") NOT DELETED!")
;
DO MSG
KILL X,Y,DTOUT,DIRUT,DUOUT
SET VALMBCK="R"
QUIT
;
ED ; - Display Extract
; -- Protocol: XTVS PKG MGR EXT DISP ACTION
;
NEW XPID,QCHK
SET QCHK=0
SET XPID=$$SELDOLRJ() ;Prompt user to enter a Process ID
;
IF 'XPID DO JUSTPAWS^XTVSLAPI("No Process ID selected.") SET QCHK=1
IF (XPID),('$D(^XTMP("XTSIZE",XPID))) DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") is NOT defined!") SET QCHK=1
IF 'QCHK DO EN^XTVSLDE
DO MSG
SET VALMBCK="R"
QUIT
;
PEXT ; -- Extract Package Data
; -- Protocol: XTVS PKG EXTRACT CREATE ACTION
;
NEW EXTRSLT
SET EXTRSLT=$$PKGEXT^XTVSLNA1()
DO REFRESH
DO MSG
SET VALMBCK="R"
QUIT
;
CRTPARM ; Convert Extract to Parameter list
; -- Protocol: XTVS PKG EXT CRT PARAM ACTION
; Display Package Parameter file from selected ^XTMP("XTSIZE") extract global
;
NEW XPID,QCHK
SET QCHK=0
SET XPID=$$SELDOLRJ() ;Prompt user to enter a Process ID
;
IF 'XPID DO JUSTPAWS^XTVSLAPI("No Process ID selected.") SET QCHK=1
IF (XPID),('$D(^XTMP("XTSIZE",XPID))) DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") is NOT defined!") SET QCHK=1
IF 'QCHK DO
. DO XTMPORD^XTVSLNA1(XPID) ; Create ^TMP("XTSIZE"), Parameter file
. ; Note Family Tree Index: ^TMP("XTSIZE","IDX",$J)
. DO EN^XTVSCP(XPID) ;Display Corrections report
. DO CRTPMCLN ; KILL ^TMP globals
. DO REFRESH
;
DO MSG
SET VALMBCK="R"
QUIT
;
EEXT ; - Email extract global [^XTMP("XTSIZE")]
; -- Protocol: XTVS PKG EXT EMAIL ACTION
;
NEW XPID,QCHK
SET QCHK=0
WRITE !!," The message can take some time to be sent."
SET XPID=$$SELDOLRJ() ;Prompt user to enter a Process ID
;
IF 'XPID DO JUSTPAWS^XTVSLAPI("No Process ID selected.") SET QCHK=1
IF (XPID),('$D(^XTMP("XTSIZE",XPID))) DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") is NOT defined!") SET QCHK=1
IF 'QCHK DO
. NEW XTINSTMM,XTTOMM,XMERR,XMZ,XTTYPE
. KILL XMERR
. SET XTINSTMM("ADDR FLAGS")="R" ;Do not Restrict addressing
. SET XTTYPE="S"
. DO TOWHOM^XMXAPIU(DUZ,,XTTYPE,.XTINSTMM)
. IF +$G(XMERR)'>0 DO
.. NEW XMY,XMTEXT,XMDUZ,XMSUB,XDATE,XTLPCNT,XMMG,XMZ
.. SET XTLPCNT=""
.. FOR SET XTLPCNT=$O(^TMP("XMY",$J,XTLPCNT)) QUIT:XTLPCNT="" SET XMY(XTLPCNT)=""
.. SET XMDUZ=DUZ
.. SET XDATE=$P($P(^XTMP("XTSIZE",XPID,0),"^",3),"-")
.. SET XDATE=$$FMTE^XLFDT(XDATE,"1P")
.. SET XMSUB="PACKAGE FILE EXTRACT ("_$P(^XTMP("XTSIZE",XPID,0),"^",4)_" ; "_XDATE_" ; $JOB#: "_XPID_")"
.. SET XMTEXT="^XTMP(""XTSIZE"","_XPID_","
.. DO ENT^XMPG
.. IF +XMZ>0 DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") Emailed via PackMan. [MSG #:"_XMZ_"]")
.. IF +XMZ'>0 DO JUSTPAWS^XTVSLAPI("Error: ^XTMP(""XTSIZE"","_XPID_") not sent in Packman. ["_XMZ_"]")
;
DO MSG
SET VALMBCK="R"
QUIT
;
QRYEXT ; Remote VistA Extract Query ; Request Package File Extract from another VistA [E.G. Forum]
; -- Protocol: XTVS PKG EXT QUERY REMOTE ACTION
;
NEW XTVSFQ,DIR,XMY,XTVSSZRP,XTVSRPT
SET XTVSSZRP=0
;
D FULL^VALM1
;
SET DIR("A",1)=""
SET DIR("A",2)=" The response from a remote VistA can take some time."
SET DIR("A",3)=""
SET DIR("A")="Do you want to query the Forum Package File? "
SET DIR("B")="YES"
SET DIR("?",1)="Yes to query Forum."
SET DIR("?",2)="No to query another VistA."
SET DIR("?")="Enter '^' to exit."
SET DIR(0)="YA"
DO ^DIR
SET XTVSFQ=$GET(Y)
IF ($DATA(DUOUT))!($DATA(DTOUT))!($DATA(DIROUT)) DO JUSTPAWS^XTVSLAPI("Forum query not indicated!")
KILL DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
;
; Forum, prompt for a Size report from Forum; SET XTVSSIZE=1; and send to SERVER OPTION
IF XTVSFQ=1 DO
. SET XTVSSZRP=$$SIZRPTQY()
. IF XTVSSZRP>-1 SET XMY("S.XTVS PKG EXTRACT SERVER@DOMAIN.EXT")="" ;Query FORUM for size rpt
. IF XTVSSZRP=-1 DO JUSTPAWS^XTVSLAPI("Size Report prompt not answered!")
;
; Not Forum, Query VistA site (Domain)
IF XTVSFQ=0 DO
. KILL DIC,X,Y,DTOUT,DUOUT,XTVSYDOM
. SET DIC="^DIC(4.2,"
. SET DIC(0)="AEQ"
. SET DIC("A")="Domain server to query: "
. SET DIC("S")="I $P(^(0),U,2)'=""C""" ;Screen "CLOSED" domains
. DO ^DIC
. SET XTVSYDOM=Y
. IF ($DATA(DUOUT))!($DATA(DTOUT))!(+XTVSYDOM=-1) DO JUSTPAWS^XTVSLAPI("VistA Domain not selected!")
. IF '$DATA(DUOUT),'$DATA(DTOUT),+XTVSYDOM>0 DO
.. IF $PIECE(XTVSYDOM,"^",2)["FORUM" DO
... SET XTVSSZRP=$$SIZRPTQY() ;Query Size rpt
... IF XTVSSZRP=-1 DO JUSTPAWS^XTVSLAPI("Size Report prompt not answered!")
.. SET XMY("S.XTVS PKG EXTRACT SERVER@"_$PIECE(XTVSYDOM,"^",2))="" ;Query address for size rpt
. KILL DIC,X,Y,DTOUT,DUOUT
;
IF ($DATA(XMY)) DO
. NEW XMTEXT,XMDUZ,XMSUB,XDATE,XMMG,XMZ,TMP
. SET TMP("XTVS REQ MSG",1)="REQUESTED BY: "_$$NETNAME^XMXUTIL(DUZ)
. SET TMP("XTVS REQ MSG",2)="Extract Indicator: 1" ; Extract package file
. IF XTVSSZRP=1 SET TMP("XTVS REQ MSG",3)="Report Indicator: 1" ; Request All Packages Size rpt
. SET XMDUZ=DUZ
. SET XMSUB="XTVS: PACKAGE FILE EXTRACT & REPORT REQUEST"
. SET XMTEXT="TMP(""XTVS REQ MSG"","
. DO ^XMD
. IF +$GET(XMZ)<1 DO
.. DO JUSTPAWS^XTVSLAPI("Error sending query message: "_XMMG_"!")
. IF +$GET(XMZ)>0 DO
.. DO JUSTPAWS^XTVSLAPI("Query message sent! Message # "_XMZ)
;
DO MSG
SET VALMBCK="R"
QUIT
;
SIZRPTQY() ; Prompt for Forum Size Rpt
NEW DIR,X,Y,RESULT
SET RESULT=-1
SET DIR("A",1)=""
SET DIR("A")="Do you want a VistA Package Size Report for all packages on Forum? "
SET DIR("B")="NO"
SET DIR("?",1)="Yes to receive a Package Size report on Forum."
SET DIR("?",2)="No to just receive a Forum Package file extract."
SET DIR("?")="Enter '^' to exit."
SET DIR(0)="YA"
DO ^DIR
IF '$DATA(DTOUT),'$DATA(DUOUT) SET RESULT=Y
QUIT RESULT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLN 11111 printed Dec 13, 2024@02:42:10 Page 2
XTVSLN ;ALBANY FO/GTS - VistA Package Sizing Manager; 30-JUN-2016
+1 ;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point for XTVS PKG MGR EXTRACT MNGR
+1 DO EN^VALM("XTVS PKG MGR EXTRACT MNGR")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)=" VistA Package Size Analysis Manager - Extract Manager"
+2 SET VALMHDR(2)=" Version: "_$$VERNUM^XTVSLM()_" Build: "_$$BLDNUM^XTVSLM()
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 NEW DEFDIR
+2 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+3 ;Kill all processing & data arrays and video attributes & control arrays
DO KILL
+4 SET VALMCNT=0
+5 DO ADD^XTVSLAPI(.VALMCNT," ")
+6 DO ADD^XTVSLAPI(.VALMCNT," Extracted package ^XTMP global list")
+7 DO ADD^XTVSLAPI(.VALMCNT," XTMPSIZE.DAT default directory: "_$SELECT($GET(DEFDIR)]"":DEFDIR,1:"<no default defined>"),1,36,$SELECT($LENGTH(DEFDIR)>0:$LENGTH(DEFDIR),1:20))
+8 DO ADD^XTVSLAPI(.VALMCNT," ")
+9 DO ADD^XTVSLAPI(.VALMCNT," Process ID System Date/Time")
+10 DO ADD^XTVSLAPI(.VALMCNT," ----------------------------------------------------")
+11 DO ADD^XTVSLAPI(.VALMCNT," ")
+12 DO FNDXTMP
+13 DO MSG
+14 QUIT
+15 ;
HELP ; -- help code
+1 IF $DATA(X)
IF X'["??"
Begin DoDot:1
+2 SET X="?"
+3 DO DISP^XQORM1
WRITE !
End DoDot:1
+4 IF $DATA(X)
IF X["??"
Begin DoDot:1
+5 DO CLEAR^VALM1
+6 DO FULL^VALM1
+7 WRITE !,"Extract Manager List action help..."
+8 WRITE !,"List specific actions:",!
+9 DO DISP^XQORM1
WRITE !!
+10 SET XTQVAR=Y
+11 IF XTQVAR
Begin DoDot:2
+12 SET XTQVAR=0
+13 FOR TXTCT=1:1
SET XTX=$PIECE($TEXT(LNTXT+TXTCT^XTVSHLP1),";",3,99)
if XTX="$END"
QUIT
if XTQVAR
QUIT
Begin DoDot:3
+14 IF XTX="$PAUSE"
DO PAUSE^VALM1
if Y
DO CLEAR^VALM1
IF 'Y
SET XTQVAR=1
QUIT
+15 WRITE !,$SELECT(XTX["$PAUSE":"",1:XTX)
End DoDot:3
End DoDot:2
+16 WRITE !
End DoDot:1
+17 SET VALMBCK="R"
+18 DO MSG
+19 KILL XTX,Y,TXTCT,XTQVAR
+20 QUIT
+21 ;
EXIT ; -- exit code
+1 DO KILL
+2 QUIT
+3 ;
MSG(TEXT) ; -- set default message
+1 IF $GET(TEXT)]""
SET VALMSG=TEXT
+2 IF $GET(TEXT)']""
SET VALMSG="Enter ?? for more actions and Help"
+3 QUIT
+4 ;
REFRESH ; -- On Return from another Template or action, refresh XTVS PKG MGR EXTRACT MNGR List Template array
+1 NEW LNENUM,XTDOLRJ,DEFDIR,DEFDRTXT
+2 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+3 ;Kill all processing & data arrays and video attributes & control arrays for XTVS PKG MGR EXTRACT MNGR template
DO KILL^XTVSLN
+4 SET EMGRTARY="^TMP(""XTVS PKG MGR EXTRACT"","_$JOB_")"
+5 SET LNENUM=0
+6 SET DEFDRTXT=" XTMPSIZE.DAT default directory: "_$SELECT($GET(DEFDIR)]"":DEFDIR,1:"<no default defined>")
+7 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ")
+8 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," Extracted package ^XTMP global list")
+9 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM,DEFDRTXT)
+10 DO CNTRL^VALM10(LNENUM,36,$SELECT($LENGTH(DEFDIR)>0:$LENGTH(DEFDIR),1:20),IOUON,IOUOFF)
+11 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ")
+12 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," Process ID System Date/Time")
+13 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ----------------------------------------------------")
+14 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," ")
+15 ;
+16 SET XTDOLRJ=0
+17 FOR
SET XTDOLRJ=$ORDER(^XTMP("XTSIZE",XTDOLRJ))
if +XTDOLRJ=0
QUIT
Begin DoDot:1
+18 NEW DATE,EXSYS
+19 SET DATE=$PIECE($PIECE(^XTMP("XTSIZE",XTDOLRJ,0),"^",3),"-")
+20 SET EXSYS=$PIECE(^XTMP("XTSIZE",XTDOLRJ,0),"^",4)
+21 SET DATE=$$FMTE^XLFDT(DATE,"1P")
+22 DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM,$JUSTIFY(XTDOLRJ,13)_$JUSTIFY(EXSYS,15)_$JUSTIFY(DATE,27))
End DoDot:1
+23 IF LNENUM'>7
DO RTRNADD^XTVSLAPI(EMGRTARY,.LNENUM," No Extracts defined.")
+24 QUIT
+25 ;
KILL ; -- Cleanup local and global display arrays
+1 ;Kill data and video control arrays
DO CLEAN^VALM10
+2 ;Kill Video attributes
DO KILL^VALM10()
+3 KILL ^TMP("XTVS PKG MGR EXTRACT",$JOB)
+4 KILL DIR,X,Y,DTOUT,DIRUT,DUOUT
+5 QUIT
+6 ;
FNDXTMP ; List Package Extracts
+1 NEW XTDOLRJ
+2 SET XTDOLRJ=0
+3 FOR
SET XTDOLRJ=$ORDER(^XTMP("XTSIZE",XTDOLRJ))
if +XTDOLRJ=0
QUIT
Begin DoDot:1
+4 NEW DATE,EXSYS
+5 SET DATE=$PIECE($PIECE(^XTMP("XTSIZE",XTDOLRJ,0),"^",3),"-")
+6 SET EXSYS=$PIECE(^XTMP("XTSIZE",XTDOLRJ,0),"^",4)
+7 SET DATE=$$FMTE^XLFDT(DATE,"1P")
+8 DO ADD^XTVSLAPI(.VALMCNT,$JUSTIFY(XTDOLRJ,13)_$JUSTIFY(EXSYS,15)_$JUSTIFY(DATE,27))
End DoDot:1
+9 IF VALMCNT'>7
DO ADD^XTVSLAPI(.VALMCNT," No Extracts defined.")
+10 QUIT
+11 ;
SELDOLRJ() ; Select a Process ID
+1 ;OUTPUT:
+2 ; RESULT : Selected PID
+3 ; : 0 (failure)
+4 NEW RESULT,DIR,X,Y
+5 DO FULL^VALM1
+6 SET DIR("A",1)=""
+7 SET DIR("A")="Enter the Extract Process ID ($JOB) number"
+8 SET DIR("?")="Enter a number from the list."
+9 SET DIR(0)="N::"
+10 DO ^DIR
+11 if '$DATA(DIRUT)
SET RESULT=Y
+12 if $DATA(DIRUT)
SET RESULT=0
+13 QUIT RESULT
+14 ;
CRTPMCLN ;Kill temporary globals created by 'XTVS PKG EXT CRT PARAM ACTION' Protocol
+1 ;,^TMP("XTSIZE","IDX",$J)
KILL ^TMP("XTVS-FILERPT",$JOB),^TMP("XTSIZE",$JOB)
+2 QUIT
+3 ;
+4 ;PROTOCOL entry points
DE ; -- Delete Extracts
+1 ; -- Protocol: XTVS PKG EXTRACT DEL ACTION
+2 NEW PROCID
+3 ;Prompt user to enter a Process ID
SET PROCID=$$SELDOLRJ()
+4 ;
+5 IF 'PROCID
DO JUSTPAWS^XTVSLAPI("No Process ID selected.")
+6 IF (PROCID)
IF ('$DATA(^XTMP("XTSIZE",PROCID)))
DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_PROCID_") is NOT defined!")
+7 IF (PROCID)
IF ($DATA(^XTMP("XTSIZE",PROCID)))
Begin DoDot:1
+8 NEW X,Y,DIR
+9 SET DIR("A",1)=""
+10 SET DIR("A")="Do you want to delete ^XTMP(""XTSIZE"","_PROCID_")"
+11 SET DIR("B")="NO"
+12 SET DIR(0)="Y::"
+13 DO ^DIR
+14 IF ('$DATA(DTOUT))
IF ('$DATA(DUOUT))
IF (($GET(Y)=1))
KILL ^XTMP("XTSIZE",PROCID)
DO KILL
DO INIT
+15 IF ($DATA(DTOUT))!($DATA(DUOUT))!(($GET(Y)=0))
Begin DoDot:2
+16 DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_PROCID_") NOT DELETED!")
End DoDot:2
End DoDot:1
+17 ;
+18 DO MSG
+19 KILL X,Y,DTOUT,DIRUT,DUOUT
+20 SET VALMBCK="R"
+21 QUIT
+22 ;
ED ; - Display Extract
+1 ; -- Protocol: XTVS PKG MGR EXT DISP ACTION
+2 ;
+3 NEW XPID,QCHK
+4 SET QCHK=0
+5 ;Prompt user to enter a Process ID
SET XPID=$$SELDOLRJ()
+6 ;
+7 IF 'XPID
DO JUSTPAWS^XTVSLAPI("No Process ID selected.")
SET QCHK=1
+8 IF (XPID)
IF ('$DATA(^XTMP("XTSIZE",XPID)))
DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") is NOT defined!")
SET QCHK=1
+9 IF 'QCHK
DO EN^XTVSLDE
+10 DO MSG
+11 SET VALMBCK="R"
+12 QUIT
+13 ;
PEXT ; -- Extract Package Data
+1 ; -- Protocol: XTVS PKG EXTRACT CREATE ACTION
+2 ;
+3 NEW EXTRSLT
+4 SET EXTRSLT=$$PKGEXT^XTVSLNA1()
+5 DO REFRESH
+6 DO MSG
+7 SET VALMBCK="R"
+8 QUIT
+9 ;
CRTPARM ; Convert Extract to Parameter list
+1 ; -- Protocol: XTVS PKG EXT CRT PARAM ACTION
+2 ; Display Package Parameter file from selected ^XTMP("XTSIZE") extract global
+3 ;
+4 NEW XPID,QCHK
+5 SET QCHK=0
+6 ;Prompt user to enter a Process ID
SET XPID=$$SELDOLRJ()
+7 ;
+8 IF 'XPID
DO JUSTPAWS^XTVSLAPI("No Process ID selected.")
SET QCHK=1
+9 IF (XPID)
IF ('$DATA(^XTMP("XTSIZE",XPID)))
DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") is NOT defined!")
SET QCHK=1
+10 IF 'QCHK
Begin DoDot:1
+11 ; Create ^TMP("XTSIZE"), Parameter file
DO XTMPORD^XTVSLNA1(XPID)
+12 ; Note Family Tree Index: ^TMP("XTSIZE","IDX",$J)
+13 ;Display Corrections report
DO EN^XTVSCP(XPID)
+14 ; KILL ^TMP globals
DO CRTPMCLN
+15 DO REFRESH
End DoDot:1
+16 ;
+17 DO MSG
+18 SET VALMBCK="R"
+19 QUIT
+20 ;
EEXT ; - Email extract global [^XTMP("XTSIZE")]
+1 ; -- Protocol: XTVS PKG EXT EMAIL ACTION
+2 ;
+3 NEW XPID,QCHK
+4 SET QCHK=0
+5 WRITE !!," The message can take some time to be sent."
+6 ;Prompt user to enter a Process ID
SET XPID=$$SELDOLRJ()
+7 ;
+8 IF 'XPID
DO JUSTPAWS^XTVSLAPI("No Process ID selected.")
SET QCHK=1
+9 IF (XPID)
IF ('$DATA(^XTMP("XTSIZE",XPID)))
DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") is NOT defined!")
SET QCHK=1
+10 IF 'QCHK
Begin DoDot:1
+11 NEW XTINSTMM,XTTOMM,XMERR,XMZ,XTTYPE
+12 KILL XMERR
+13 ;Do not Restrict addressing
SET XTINSTMM("ADDR FLAGS")="R"
+14 SET XTTYPE="S"
+15 DO TOWHOM^XMXAPIU(DUZ,,XTTYPE,.XTINSTMM)
+16 IF +$GET(XMERR)'>0
Begin DoDot:2
+17 NEW XMY,XMTEXT,XMDUZ,XMSUB,XDATE,XTLPCNT,XMMG,XMZ
+18 SET XTLPCNT=""
+19 FOR
SET XTLPCNT=$ORDER(^TMP("XMY",$JOB,XTLPCNT))
if XTLPCNT=""
QUIT
SET XMY(XTLPCNT)=""
+20 SET XMDUZ=DUZ
+21 SET XDATE=$PIECE($PIECE(^XTMP("XTSIZE",XPID,0),"^",3),"-")
+22 SET XDATE=$$FMTE^XLFDT(XDATE,"1P")
+23 SET XMSUB="PACKAGE FILE EXTRACT ("_$PIECE(^XTMP("XTSIZE",XPID,0),"^",4)_" ; "_XDATE_" ; $JOB#: "_XPID_")"
+24 SET XMTEXT="^XTMP(""XTSIZE"","_XPID_","
+25 DO ENT^XMPG
+26 IF +XMZ>0
DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_XPID_") Emailed via PackMan. [MSG #:"_XMZ_"]")
+27 IF +XMZ'>0
DO JUSTPAWS^XTVSLAPI("Error: ^XTMP(""XTSIZE"","_XPID_") not sent in Packman. ["_XMZ_"]")
End DoDot:2
End DoDot:1
+28 ;
+29 DO MSG
+30 SET VALMBCK="R"
+31 QUIT
+32 ;
QRYEXT ; Remote VistA Extract Query ; Request Package File Extract from another VistA [E.G. Forum]
+1 ; -- Protocol: XTVS PKG EXT QUERY REMOTE ACTION
+2 ;
+3 NEW XTVSFQ,DIR,XMY,XTVSSZRP,XTVSRPT
+4 SET XTVSSZRP=0
+5 ;
+6 DO FULL^VALM1
+7 ;
+8 SET DIR("A",1)=""
+9 SET DIR("A",2)=" The response from a remote VistA can take some time."
+10 SET DIR("A",3)=""
+11 SET DIR("A")="Do you want to query the Forum Package File? "
+12 SET DIR("B")="YES"
+13 SET DIR("?",1)="Yes to query Forum."
+14 SET DIR("?",2)="No to query another VistA."
+15 SET DIR("?")="Enter '^' to exit."
+16 SET DIR(0)="YA"
+17 DO ^DIR
+18 SET XTVSFQ=$GET(Y)
+19 IF ($DATA(DUOUT))!($DATA(DTOUT))!($DATA(DIROUT))
DO JUSTPAWS^XTVSLAPI("Forum query not indicated!")
+20 KILL DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+21 ;
+22 ; Forum, prompt for a Size report from Forum; SET XTVSSIZE=1; and send to SERVER OPTION
+23 IF XTVSFQ=1
Begin DoDot:1
+24 SET XTVSSZRP=$$SIZRPTQY()
+25 ;Query FORUM for size rpt
IF XTVSSZRP>-1
SET XMY("S.XTVS PKG EXTRACT SERVER@DOMAIN.EXT")=""
+26 IF XTVSSZRP=-1
DO JUSTPAWS^XTVSLAPI("Size Report prompt not answered!")
End DoDot:1
+27 ;
+28 ; Not Forum, Query VistA site (Domain)
+29 IF XTVSFQ=0
Begin DoDot:1
+30 KILL DIC,X,Y,DTOUT,DUOUT,XTVSYDOM
+31 SET DIC="^DIC(4.2,"
+32 SET DIC(0)="AEQ"
+33 SET DIC("A")="Domain server to query: "
+34 ;Screen "CLOSED" domains
SET DIC("S")="I $P(^(0),U,2)'=""C"""
+35 DO ^DIC
+36 SET XTVSYDOM=Y
+37 IF ($DATA(DUOUT))!($DATA(DTOUT))!(+XTVSYDOM=-1)
DO JUSTPAWS^XTVSLAPI("VistA Domain not selected!")
+38 IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
IF +XTVSYDOM>0
Begin DoDot:2
+39 IF $PIECE(XTVSYDOM,"^",2)["FORUM"
Begin DoDot:3
+40 ;Query Size rpt
SET XTVSSZRP=$$SIZRPTQY()
+41 IF XTVSSZRP=-1
DO JUSTPAWS^XTVSLAPI("Size Report prompt not answered!")
End DoDot:3
+42 ;Query address for size rpt
SET XMY("S.XTVS PKG EXTRACT SERVER@"_$PIECE(XTVSYDOM,"^",2))=""
End DoDot:2
+43 KILL DIC,X,Y,DTOUT,DUOUT
End DoDot:1
+44 ;
+45 IF ($DATA(XMY))
Begin DoDot:1
+46 NEW XMTEXT,XMDUZ,XMSUB,XDATE,XMMG,XMZ,TMP
+47 SET TMP("XTVS REQ MSG",1)="REQUESTED BY: "_$$NETNAME^XMXUTIL(DUZ)
+48 ; Extract package file
SET TMP("XTVS REQ MSG",2)="Extract Indicator: 1"
+49 ; Request All Packages Size rpt
IF XTVSSZRP=1
SET TMP("XTVS REQ MSG",3)="Report Indicator: 1"
+50 SET XMDUZ=DUZ
+51 SET XMSUB="XTVS: PACKAGE FILE EXTRACT & REPORT REQUEST"
+52 SET XMTEXT="TMP(""XTVS REQ MSG"","
+53 DO ^XMD
+54 IF +$GET(XMZ)<1
Begin DoDot:2
+55 DO JUSTPAWS^XTVSLAPI("Error sending query message: "_XMMG_"!")
End DoDot:2
+56 IF +$GET(XMZ)>0
Begin DoDot:2
+57 DO JUSTPAWS^XTVSLAPI("Query message sent! Message # "_XMZ)
End DoDot:2
End DoDot:1
+58 ;
+59 DO MSG
+60 SET VALMBCK="R"
+61 QUIT
+62 ;
SIZRPTQY() ; Prompt for Forum Size Rpt
+1 NEW DIR,X,Y,RESULT
+2 SET RESULT=-1
+3 SET DIR("A",1)=""
+4 SET DIR("A")="Do you want a VistA Package Size Report for all packages on Forum? "
+5 SET DIR("B")="NO"
+6 SET DIR("?",1)="Yes to receive a Package Size report on Forum."
+7 SET DIR("?",2)="No to just receive a Forum Package file extract."
+8 SET DIR("?")="Enter '^' to exit."
+9 SET DIR(0)="YA"
+10 DO ^DIR
+11 IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
SET RESULT=Y
+12 QUIT RESULT
