- 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 Jan 18, 2025@03:43:17 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