A1VSLN ;Albany FO/GTS - VistA Package Sizing Manager; 30-JUN-2016
;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
;
EN ; -- main entry point for A1VS PKG MGR EXTRACT MNGR
D EN^VALM("A1VS PKG MGR EXTRACT MNGR")
Q
;
HDR ; -- header code
SET VALMHDR(1)=" VistA Package Size Analysis Manager - Extract Manager"
SET VALMHDR(2)=" Version: "_$$VERNUM^A1VSLM()_" Build: "_$$BLDNUM^A1VSLM()
Q
;
INIT ; -- init variables and list array
DO KILL ;Kill all processing & data arrays and video attributes & control arrays
SET VALMCNT=0
DO ADD^A1VSLAPI(.VALMCNT," ")
DO ADD^A1VSLAPI(.VALMCNT," Extracted package ^XTMP global list")
DO ADD^A1VSLAPI(.VALMCNT," ")
DO ADD^A1VSLAPI(.VALMCNT," Process ID System Date/Time")
DO ADD^A1VSLAPI(.VALMCNT," ----------------------------------------------------")
DO ADD^A1VSLAPI(.VALMCNT," ")
;;DO FNDXTMP("^TMP(""A1VS PKG MGR EXTRACT"","_$JOB_")") ;; TO DO: GTS - Left for Array passing in parameter example; REMOVE CODE!
DO FNDXTMP
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D KILL
Q
;
EXPND ; -- expand code
Q
;
REFRESH ; -- On Return from another Template or action, refresh A1VS PKG MGR EXTRACT MNGR List Template array
NEW LNENUM,A1DOLRJ
DO KILL^A1VSLN ;Kill all processing & data arrays and video attributes & control arrays for A1VS PKG MGR EXTRACT MNGR template
SET EMGRTARY="^TMP(""A1VS PKG MGR EXTRACT"","_$J_")"
SET LNENUM=0
DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," ")
DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," Extracted package ^XTMP global list")
DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," ")
DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," Process ID System Date/Time")
DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," ----------------------------------------------------")
DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," ")
;
SET A1DOLRJ=0
FOR SET A1DOLRJ=$O(^XTMP("A1SIZE",A1DOLRJ)) Q:+A1DOLRJ=0 DO
. NEW DATE,EXSYS
. SET DATE=$P(^XTMP("A1SIZE",A1DOLRJ,0),"^")
. SET EXSYS=$P(^XTMP("A1SIZE",A1DOLRJ,0),"^",2)
. SET DATE=$$FMTE^XLFDT(DATE,"1P")
. DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM,$J(A1DOLRJ,13)_$J(EXSYS,15)_$J(DATE,27))
IF LNENUM'>6 DO RTRNADD^A1VSLAPI(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("A1VS PKG MGR EXTRACT",$JOB)
KILL DIR,X,Y,DTOUT,DIRUT,DUOUT
QUIT
;
FNDXTMP ; List Package Extracts
NEW A1DOLRJ
SET A1DOLRJ=0
FOR SET A1DOLRJ=$O(^XTMP("A1SIZE",A1DOLRJ)) Q:+A1DOLRJ=0 DO
. NEW DATE,EXSYS
. SET DATE=$P(^XTMP("A1SIZE",A1DOLRJ,0),"^")
. SET EXSYS=$P(^XTMP("A1SIZE",A1DOLRJ,0),"^",2)
. SET DATE=$$FMTE^XLFDT(DATE,"1P")
. DO ADD^A1VSLAPI(.VALMCNT,$J(A1DOLRJ,13)_$J(EXSYS,15)_$J(DATE,27))
IF VALMCNT'>6 DO ADD^A1VSLAPI(.VALMCNT," No Extracts defined.")
QUIT
;
SELDOLRJ() ; Select a Process ID
;OUTPUT:
; RESULT : Selected PID
; : -1 (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 'A1VS PKG EXT CRT PARAM ACTION' Protocol
KILL ^TMP("A1VS-FILERPT",$J),^TMP("A1SIZE",$J),^TMP("A1SIZE","IDX",$J)
QUIT
;
;PROTOCOL entry points
DE ; -- Delete Extracts
; -- Protocol: A1VS PKG EXTRACT DEL ACTION
NEW PROCID
SET PROCID=$$SELDOLRJ() ;Prompt user to enter a Process ID
;
IF 'PROCID DO JUSTPAWS^A1VSLAPI("No Process ID selected.")
IF (PROCID),('$D(^XTMP("A1SIZE",PROCID))) DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_PROCID_") is NOT defined!")
IF (PROCID),($D(^XTMP("A1SIZE",PROCID))) DO
. NEW X,Y,DIR
. SET DIR("A",1)=""
. SET DIR("A")="Do you want to delete ^XTMP(""A1SIZE"","_PROCID_")"
. SET DIR("B")="NO"
. SET DIR(0)="Y::"
. DO ^DIR
. IF ('$D(DTOUT)),('$D(DUOUT)),(($G(Y)=1)) KILL ^XTMP("A1SIZE",PROCID) DO KILL,INIT
. IF ($D(DTOUT))!($D(DUOUT))!(($G(Y)=0)) DO
.. DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_PROCID_") NOT DELETED!")
;
KILL X,Y,DTOUT,DIRUT,DUOUT
SET VALMBCK="R"
QUIT
;
ED ; - Extract Display
; -- Protocol: A1VS 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^A1VSLAPI("No Process ID selected.") SET QCHK=1
IF (XPID),('$D(^XTMP("A1SIZE",XPID))) DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_XPID_") is NOT defined!") SET QCHK=1
IF 'QCHK DO EN^A1VSLDE
SET VALMBCK="R"
QUIT
;
PEXT ; -- Create Extract
; -- Protocol: A1VS PKG EXTRACT CREATE ACTION
;
NEW EXTRSLT
SET EXTRSLT=$$PKGEXT^A1VSLNA1()
DO REFRESH
SET VALMBCK="R"
QUIT
;
CRTPARM ; Display Package Parameter file from selected ^XTMP("A1SIZE") extract global
; -- Protocol: A1VS PKG EXT CRT PARAM ACTION
;
NEW XPID,QCHK
SET QCHK=0
SET XPID=$$SELDOLRJ() ;Prompt user to enter a Process ID
;
IF 'XPID DO JUSTPAWS^A1VSLAPI("No Process ID selected.") SET QCHK=1
IF (XPID),('$D(^XTMP("A1SIZE",XPID))) DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_XPID_") is NOT defined!") SET QCHK=1
IF 'QCHK DO
. DO XTMPORD^A1VSLNA1(XPID) ; Create ^TMP("A1SIZE"), Parameter file ; & ^TMP("A1SIZE","IDX"), Family Tree Index
. KILL ^TMP("A1SIZE","IDX",$J) ; Cleanup Family Tree Index
. DO EN^A1VSCP(XPID) ;Display Corrections report
. DO CRTPMCLN ; KILL ^TMP globals
. DO REFRESH
;
SET VALMBCK="R"
QUIT
;
EEXT ; Email ^XTMP("A1SIZE") extract global
; -- Protocol: A1VS PKG EXT EMAIL ACTION
;
NEW XPID,QCHK
SET QCHK=0
SET XPID=$$SELDOLRJ() ;Prompt user to enter a Process ID
;
IF 'XPID DO JUSTPAWS^A1VSLAPI("No Process ID selected.") SET QCHK=1
IF (XPID),('$D(^XTMP("A1SIZE",XPID))) DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_XPID_") is NOT defined!") SET QCHK=1
IF 'QCHK DO
. NEW A1INSTMM,A1TOMM,XMERR,XMZ,A1TYPE
. KILL XMERR
. SET A1INSTMM("ADDR FLAGS")="R" ;Do not Restrict addressing
. SET A1TYPE="S"
. DO TOWHOM^XMXAPIU(DUZ,,A1TYPE,.A1INSTMM)
. IF +$G(XMERR)'>0 DO
.. NEW XMY,XMTEXT,XMDUZ,XMSUB,XDATE,A1LPCNT
.. SET A1LPCNT=""
.. FOR SET A1LPCNT=$O(^TMP("XMY",$J,A1LPCNT)) QUIT:A1LPCNT="" SET XMY(A1LPCNT)=""
.. SET XMDUZ=DUZ
.. SET XDATE=$P(^XTMP("A1SIZE",XPID,0),"^")
.. SET XDATE=$$FMTE^XLFDT(XDATE,"1P")
.. SET XMSUB="PACKAGE FILE EXTRACT ("_$P(^XTMP("A1SIZE",XPID,0),"^",2)_" ; "_XDATE_" ; $JOB#: "_XPID_")"
.. SET XMTEXT="^XTMP(""A1SIZE"","_XPID_","
.. DO ENT^XMPG
.. IF +XMZ>0 DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_XPID_") E-Mailed via PackMan. [MSG #:"_XMZ_"]")
.. IF +XMZ'>0 DO JUSTPAWS^A1VSLAPI("Error: ^XTMP(""A1SIZE"","_XPID_") not sent in Packman. ["_XMZ_"]")
;
SET VALMBCK="R"
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1VSLN 6938 printed Sep 23, 2025@19:14:41 Page 2
A1VSLN ;Albany FO/GTS - VistA Package Sizing Manager; 30-JUN-2016
+1 ;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
+2 ;
EN ; -- main entry point for A1VS PKG MGR EXTRACT MNGR
+1 DO EN^VALM("A1VS 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^A1VSLM()_" Build: "_$$BLDNUM^A1VSLM()
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 ;Kill all processing & data arrays and video attributes & control arrays
DO KILL
+2 SET VALMCNT=0
+3 DO ADD^A1VSLAPI(.VALMCNT," ")
+4 DO ADD^A1VSLAPI(.VALMCNT," Extracted package ^XTMP global list")
+5 DO ADD^A1VSLAPI(.VALMCNT," ")
+6 DO ADD^A1VSLAPI(.VALMCNT," Process ID System Date/Time")
+7 DO ADD^A1VSLAPI(.VALMCNT," ----------------------------------------------------")
+8 DO ADD^A1VSLAPI(.VALMCNT," ")
+9 ;;DO FNDXTMP("^TMP(""A1VS PKG MGR EXTRACT"","_$JOB_")") ;; TO DO: GTS - Left for Array passing in parameter example; REMOVE CODE!
+10 DO FNDXTMP
+11 QUIT
+12 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO KILL
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
REFRESH ; -- On Return from another Template or action, refresh A1VS PKG MGR EXTRACT MNGR List Template array
+1 NEW LNENUM,A1DOLRJ
+2 ;Kill all processing & data arrays and video attributes & control arrays for A1VS PKG MGR EXTRACT MNGR template
DO KILL^A1VSLN
+3 SET EMGRTARY="^TMP(""A1VS PKG MGR EXTRACT"","_$JOB_")"
+4 SET LNENUM=0
+5 DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," ")
+6 DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," Extracted package ^XTMP global list")
+7 DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," ")
+8 DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," Process ID System Date/Time")
+9 DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," ----------------------------------------------------")
+10 DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," ")
+11 ;
+12 SET A1DOLRJ=0
+13 FOR
SET A1DOLRJ=$ORDER(^XTMP("A1SIZE",A1DOLRJ))
if +A1DOLRJ=0
QUIT
Begin DoDot:1
+14 NEW DATE,EXSYS
+15 SET DATE=$PIECE(^XTMP("A1SIZE",A1DOLRJ,0),"^")
+16 SET EXSYS=$PIECE(^XTMP("A1SIZE",A1DOLRJ,0),"^",2)
+17 SET DATE=$$FMTE^XLFDT(DATE,"1P")
+18 DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM,$JUSTIFY(A1DOLRJ,13)_$JUSTIFY(EXSYS,15)_$JUSTIFY(DATE,27))
End DoDot:1
+19 IF LNENUM'>6
DO RTRNADD^A1VSLAPI(EMGRTARY,.LNENUM," No Extracts defined.")
+20 QUIT
+21 ;
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("A1VS PKG MGR EXTRACT",$JOB)
+4 KILL DIR,X,Y,DTOUT,DIRUT,DUOUT
+5 QUIT
+6 ;
FNDXTMP ; List Package Extracts
+1 NEW A1DOLRJ
+2 SET A1DOLRJ=0
+3 FOR
SET A1DOLRJ=$ORDER(^XTMP("A1SIZE",A1DOLRJ))
if +A1DOLRJ=0
QUIT
Begin DoDot:1
+4 NEW DATE,EXSYS
+5 SET DATE=$PIECE(^XTMP("A1SIZE",A1DOLRJ,0),"^")
+6 SET EXSYS=$PIECE(^XTMP("A1SIZE",A1DOLRJ,0),"^",2)
+7 SET DATE=$$FMTE^XLFDT(DATE,"1P")
+8 DO ADD^A1VSLAPI(.VALMCNT,$JUSTIFY(A1DOLRJ,13)_$JUSTIFY(EXSYS,15)_$JUSTIFY(DATE,27))
End DoDot:1
+9 IF VALMCNT'>6
DO ADD^A1VSLAPI(.VALMCNT," No Extracts defined.")
+10 QUIT
+11 ;
SELDOLRJ() ; Select a Process ID
+1 ;OUTPUT:
+2 ; RESULT : Selected PID
+3 ; : -1 (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 'A1VS PKG EXT CRT PARAM ACTION' Protocol
+1 KILL ^TMP("A1VS-FILERPT",$JOB),^TMP("A1SIZE",$JOB),^TMP("A1SIZE","IDX",$JOB)
+2 QUIT
+3 ;
+4 ;PROTOCOL entry points
DE ; -- Delete Extracts
+1 ; -- Protocol: A1VS PKG EXTRACT DEL ACTION
+2 NEW PROCID
+3 ;Prompt user to enter a Process ID
SET PROCID=$$SELDOLRJ()
+4 ;
+5 IF 'PROCID
DO JUSTPAWS^A1VSLAPI("No Process ID selected.")
+6 IF (PROCID)
IF ('$DATA(^XTMP("A1SIZE",PROCID)))
DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_PROCID_") is NOT defined!")
+7 IF (PROCID)
IF ($DATA(^XTMP("A1SIZE",PROCID)))
Begin DoDot:1
+8 NEW X,Y,DIR
+9 SET DIR("A",1)=""
+10 SET DIR("A")="Do you want to delete ^XTMP(""A1SIZE"","_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("A1SIZE",PROCID)
DO KILL
DO INIT
+15 IF ($DATA(DTOUT))!($DATA(DUOUT))!(($GET(Y)=0))
Begin DoDot:2
+16 DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_PROCID_") NOT DELETED!")
End DoDot:2
End DoDot:1
+17 ;
+18 KILL X,Y,DTOUT,DIRUT,DUOUT
+19 SET VALMBCK="R"
+20 QUIT
+21 ;
ED ; - Extract Display
+1 ; -- Protocol: A1VS 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^A1VSLAPI("No Process ID selected.")
SET QCHK=1
+8 IF (XPID)
IF ('$DATA(^XTMP("A1SIZE",XPID)))
DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_XPID_") is NOT defined!")
SET QCHK=1
+9 IF 'QCHK
DO EN^A1VSLDE
+10 SET VALMBCK="R"
+11 QUIT
+12 ;
PEXT ; -- Create Extract
+1 ; -- Protocol: A1VS PKG EXTRACT CREATE ACTION
+2 ;
+3 NEW EXTRSLT
+4 SET EXTRSLT=$$PKGEXT^A1VSLNA1()
+5 DO REFRESH
+6 SET VALMBCK="R"
+7 QUIT
+8 ;
CRTPARM ; Display Package Parameter file from selected ^XTMP("A1SIZE") extract global
+1 ; -- Protocol: A1VS PKG EXT CRT PARAM 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^A1VSLAPI("No Process ID selected.")
SET QCHK=1
+8 IF (XPID)
IF ('$DATA(^XTMP("A1SIZE",XPID)))
DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_XPID_") is NOT defined!")
SET QCHK=1
+9 IF 'QCHK
Begin DoDot:1
+10 ; Create ^TMP("A1SIZE"), Parameter file ; & ^TMP("A1SIZE","IDX"), Family Tree Index
DO XTMPORD^A1VSLNA1(XPID)
+11 ; Cleanup Family Tree Index
KILL ^TMP("A1SIZE","IDX",$JOB)
+12 ;Display Corrections report
DO EN^A1VSCP(XPID)
+13 ; KILL ^TMP globals
DO CRTPMCLN
+14 DO REFRESH
End DoDot:1
+15 ;
+16 SET VALMBCK="R"
+17 QUIT
+18 ;
EEXT ; Email ^XTMP("A1SIZE") extract global
+1 ; -- Protocol: A1VS PKG EXT EMAIL 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^A1VSLAPI("No Process ID selected.")
SET QCHK=1
+8 IF (XPID)
IF ('$DATA(^XTMP("A1SIZE",XPID)))
DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_XPID_") is NOT defined!")
SET QCHK=1
+9 IF 'QCHK
Begin DoDot:1
+10 NEW A1INSTMM,A1TOMM,XMERR,XMZ,A1TYPE
+11 KILL XMERR
+12 ;Do not Restrict addressing
SET A1INSTMM("ADDR FLAGS")="R"
+13 SET A1TYPE="S"
+14 DO TOWHOM^XMXAPIU(DUZ,,A1TYPE,.A1INSTMM)
+15 IF +$GET(XMERR)'>0
Begin DoDot:2
+16 NEW XMY,XMTEXT,XMDUZ,XMSUB,XDATE,A1LPCNT
+17 SET A1LPCNT=""
+18 FOR
SET A1LPCNT=$ORDER(^TMP("XMY",$JOB,A1LPCNT))
if A1LPCNT=""
QUIT
SET XMY(A1LPCNT)=""
+19 SET XMDUZ=DUZ
+20 SET XDATE=$PIECE(^XTMP("A1SIZE",XPID,0),"^")
+21 SET XDATE=$$FMTE^XLFDT(XDATE,"1P")
+22 SET XMSUB="PACKAGE FILE EXTRACT ("_$PIECE(^XTMP("A1SIZE",XPID,0),"^",2)_" ; "_XDATE_" ; $JOB#: "_XPID_")"
+23 SET XMTEXT="^XTMP(""A1SIZE"","_XPID_","
+24 DO ENT^XMPG
+25 IF +XMZ>0
DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_XPID_") E-Mailed via PackMan. [MSG #:"_XMZ_"]")
+26 IF +XMZ'>0
DO JUSTPAWS^A1VSLAPI("Error: ^XTMP(""A1SIZE"","_XPID_") not sent in Packman. ["_XMZ_"]")
End DoDot:2
End DoDot:1
+27 ;
+28 SET VALMBCK="R"
+29 QUIT
