XTVSLAPI ;ALBANY FO/GTS - VistA Package Sizing Manager; 27-JUN-2016
;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
; APIs
;
EMAILEXT ; - Send Package File Extract via Packman; Extract & Email ^XTMP(""XTSIZE"","_$JOB_")
; -- Option: XTVS PKG MGR EXT PACKAGE MSG
;
NEW EXTRSLT
SET EXTRSLT=$$PKGEXT^XTVSLNA1()
IF 'EXTRSLT,$D(^XTMP("XTSIZE",$JOB)) DO
. NEW XTINSTMM,XTTOMM,XMERR,XMZ,XTTYPE
. ;
. WRITE !!," The message can take some time to be sent.",!
. 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,XTLPCNT,XDATE
.. SET XTLPCNT=""
.. FOR SET XTLPCNT=$O(^TMP("XMY",$J,XTLPCNT)) QUIT:XTLPCNT="" SET XMY(XTLPCNT)=""
.. SET XMDUZ=DUZ
.. SET XDATE=$P($P(^XTMP("XTSIZE",$JOB,0),"^",3),"-") ; Date from 3rd pce [date of extract]
.. SET XDATE=$$FMTE^XLFDT(XDATE,"1P")
.. SET XMSUB="PACKAGE FILE EXTRACT ("_$P(^XTMP("XTSIZE",$JOB,0),"^",4)_" ; "_XDATE_" ; $JOB#: "_$JOB_")"
.. SET XMTEXT="^XTMP(""XTSIZE"","_$JOB_","
.. DO ENT^XMPG
.. IF +XMZ>0 DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_$JOB_") Emailed via PackMan. [MSG #:"_XMZ_"]")
.. IF +XMZ'>0 DO JUSTPAWS^XTVSLAPI("Error: ^XTMP(""XTSIZE"","_$JOB_") not sent in Packman. ["_XMMG_"]")
. IF $P(EXTRSLT,"^",2)'>0 KILL ^TMP("XMY",$J),^XTMP("XTSIZE",$JOB)
;
IF EXTRSLT DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_$JOB_") global exists. Use Extract Manager to access it.")
QUIT
;
ADD(VALMCNT,MSG,LRBOLD,STRTBLD,ENDBLD) ; -- add line to build display
;Input
; VALMCNT - Current array node number
; MSG - Message to add to ListMan Display
; LRBOLD - Turns Bold text on - off
; STRTBLD - Column position to begin Bold Text
; ENDBLD - Number of columns to apply Bold Text
;
SET VALMCNT=VALMCNT+1
DO SET^VALM10(VALMCNT,MSG)
IF $GET(LRBOLD) DO
. SET:'$G(STRTBLD) STRTBLD=1
. SET:'$G(ENDBLD) ENDBLD=79
. DO CNTRL^VALM10(VALMCNT,STRTBLD,ENDBLD,IOUON,IOUOFF)
QUIT
;
SPLITADD(VALMCNT,MSG,ADDSPACE) ; -- add line to build display
;Input
; VALMCNT - Current array node number
; MSG - Message to add to ListMan Display
; ADDSPACE - Add space indicator (1 - add space, 0 - no space
;
NEW SEGMENTS,TOTNODES,PCE,MSGPCE,START,END
SET:(+$G(ADDSPACE)'=1) ADDSPACE=0
SET SEGMENTS=$L(MSG)/80
SET TOTNODES=+$P(SEGMENTS,".")
IF ADDSPACE,(+$P(SEGMENTS,".",2)>0) SET TOTNODES=TOTNODES+1
FOR PCE=0:1:TOTNODES DO
. SET START=1+(PCE*80)
. SET END=80+(PCE*80)
. SET MSGPCE=$E(MSG,START,END)
. SET VALMCNT=VALMCNT+1
. DO SET^VALM10(VALMCNT,MSGPCE)
QUIT
;
RTRNADD(EMGRTARY,LNENUM,MSG) ; Add a line to EMGRTARY array
;INPUT
; EMGRTARY - Extract Management array [Passed by value for Indirect use]
; LNENUM - Last Node number in the EMGRTARY array
; MSG - Message to store in next line on EMGRTARY array
;
SET LNENUM=LNENUM+1
SET @EMGRTARY@(LNENUM,0)=MSG
QUIT
;
EDITPCHK() ; -- does DUZ have XTVS EDITOR key
NEW XTVSSEC
DO OWNSKEY^XUSRB(.XTVSSEC,"XTVS EDITOR")
QUIT +$G(XTVSSEC(0))
;
YNCHK(APROMPT,DEFANS) ; Yes/No Prompt
;INPUT
; APROMPT - Prompt to display before Y/N question [DIR("A")]
; DEFANS - Default Y/N answer [DIR("B")] (optional - defaults to NO)
;OUTPUT
; XTSVRSLT - value of Y when DIR Y/N prompt answer = Yes/No
; 0^-1 when Timeout, ^ or ^^ out. 3rd ^ piece = 1 when Timeout [0^-1^1].
;
NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,XTSVRSLT
SET DIR("A")=APROMPT
SET DIR(0)="Y^A"
SET DIR("B")=$G(DEFANS)
IF '$D(DEFANS) SET DIR("B")="NO"
DO ^DIR
SET XTSVRSLT=Y_"^"_Y
IF $D(DTOUT)!$D(DUOUT)!$D(DIROUT) SET XTSVRSLT="0"_"^-1"_$S($D(DTOUT):"^1",1:"^")
QUIT XTSVRSLT
;
SELXTMP(BEGIN,END) ;Select XTMPSIZE.DAT file
; RETURN: Selected XTMPSIZE file name
;
NEW SELARY,ITEMNUM,FILENME,YVAL
SET SELARY=""
SET ITEMNUM=$$XTMP2SEL(BEGIN,END,.SELARY)
IF ITEMNUM>0 DO
. NEW PARAMSTR,QSTHLP1
. SET QSTHLP1=" Enter the name or number (1-"_ITEMNUM_") of the parameter file."
. SET PARAMSTR("MINLNG")=10
. SET PARAMSTR("PATRN")="1""XTMPSIZE"".ANP"
. SET PARAMSTR("MAXLNG")=30
. SET PARAMSTR("DEFANS")=$G(XTVPSPRM)
. SET PARAMSTR("ADDITM")=0
. SET YVAL=+$$SELITEM^XTVSLP(QSTHLP1,.ITEMNUM,.SELARY,.PARAMSTR)
. IF (+$G(YVAL)>0)&(+$G(YVAL)<(ITEMNUM+1)) SET FILENME=SELARY(YVAL) W " ",FILENME
;
IF ITEMNUM'>0 DO JUSTPAWS^XTVSLAPI(" There are no XTMPSIZE files to select!")
;
QUIT $G(FILENME)
;
WRTTXTFL(FILENME,STORPATH) ; Output Package Manager Report to Text file
NEW POPERR,LMTMPNDE
SET (D1,POPERR)=""
;
;If write delimited report to a file
IF FILENME]"" DO QUIT:POPERR
. DO OPEN^%ZISH("DELIMFL1",STORPATH,FILENME,"A")
. SET:POP POPERR=POP
. QUIT:POPERR
. U IO
. SET LMTMPNDE=0
. FOR SET LMTMPNDE=$O(^TMP("XTVS PKG MGR RPT",$J,LMTMPNDE)) Q:+LMTMPNDE=0 DO
.. W !,^TMP("XTVS PKG MGR RPT",$J,LMTMPNDE,0)
. D CLOSE^%ZISH("DELIMFL1")
QUIT
;
SNDEXT(XTSVSUBJ,XQSND,XTEXTARY) ;Send VistA Size report
; -- Protocol: XTVS PKG MGR RPT MAIL ACTION
;
;INPUT:
; XTSVSUBJ - Subject of message generated
; XQSND - User's DUZ, Group Name, or S.server name
; XTEXTARY - Array containing msg text
;
N XTINSTMM,XTINSTVA,XTTASKMM,XTTASKVA,XTTOMM,XTTOVA,XMERR,XMZ,XTLPCNT,XTTYPE
;
DO FULL^VALM1
WRITE !!," The message can take some time to be sent.",!
;
S XTINSTMM("ADDR FLAGS")="R" ;Do not Restrict addressing
S XTTYPE="S"
K XMERR
D TOWHOM^XMXAPIU(DUZ,,XTTYPE,.XTINSTMM)
;
;Check Network addresses and mail attachmt
S XTINSTVA("ADDR FLAGS")="R" ;Do not Restrict addressing
S XTINSTVA("FROM")="VISTA_PACKAGE_MANAGER_RPT"
S XTSVSUBJ=$E(XTSVSUBJ,1,65)
S XTLPCNT=""
F S XTLPCNT=$O(^TMP("XMY",$J,XTLPCNT)) Q:XTLPCNT="" S XTTOVA(XTLPCNT)=""
;
I +$G(XMERR)'>0 DO
.N XTFORMAT
.WRITE !!,"NOTE: Attachments sent to VA MailMan addresses will be unreadable."
.WRITE !," Send the the report in a message if sending to a VA Mailman address."
.SET XTFORMAT=$$MSGORATC^XTVSLAPI("the VistA Size Report")
.IF XTFORMAT'="M",XTFORMAT'="A" DO JUSTPAWS(" Message not sent!")
.; Report in message
.IF XTFORMAT="M" DO
.. D SENDMSG^XMXAPI(XQSND,XTSVSUBJ,XTEXTARY,.XTTOVA,.XTINSTVA,.XTTASKVA)
.. D JUSTPAWS("MSG#: "_XTTASKVA_" created!")
.; Report in attachment
.IF XTFORMAT="A" DO
.. W !," [Creating attachments..."
.. D OUTLKARY(XTEXTARY,"^TMP($J,""XTNETMSG"")",XTSVSUBJ,1)
.. D SENDMSG^XMXAPI(XQSND,XTSVSUBJ,"^TMP($J,""XTNETMSG"")",.XTTOVA,.XTINSTVA,.XTTASKVA)
.. D JUSTPAWS("MSG#: "_XTTASKVA_" created!")
;
K ^TMP("XMY",$J),^TMP("XMY0",$J),^TMP($J,"XTNETMSG")
DO MSG^XTVSLR
SET VALMBCK="R"
Q
;
MSGORATC(XTQTXT) ; Query message or text attachment
; INPUT:
; XTQTXT - Report name text to include in user prompt
;
; OUTPUT:
; RESULT -
; M : Message - Send report in a message
; A : Attachment - Send report as a text file attachment to the message
; -1 : Fail/Error condition
;
NEW RESULT
SET DIR("A")="Send "_XTQTXT_" as a message or a text file attachment: "
SET DIR("B")="A"
SET DIR(0)="SAB^M:Message;A:Attachment"
SET DIR("?")="Enter 'M' to send the report in a message or 'A' to send in a file attached to a message."
D ^DIR
SET RESULT=$SELECT($D(DIRUT):-1,1:Y)
QUIT RESULT
;
OUTLKARY(XTPMARY,XTOTLK,XTSVSUBJ,XTRT) ;Create attachmts array
;INPUT:
; XTPMARY - Array containing raw message text
; XTOTLK - Array containing message text for network addresses
; XTSVSUBJ - Message subject
; XTRT - Real Time processing from UI
;
N XTFILNAM,XTDTTM,XTCRLF,XTSTR,XTNODE,XTOUTNOD,XTNODATA,XTCHAR
S:+$G(XTRT)=0 XTRT=0
S:+$G(XTRT) XTCHAR=0
S XTSTR=""
S XTNODATA=0
S XTCRLF=$C(13,10)
S XTDTTM=$$NOW^XLFDT
K @XTOTLK
S @XTOTLK@(1)="Attachment Generated......: "_$$FMTE^XLFDT(XTDTTM)_XTCRLF
S @XTOTLK@(2)=" "
S @XTOTLK@(3)="Extract Requested......: "_XTSVSUBJ_XTCRLF
S @XTOTLK@(4)=" "
;
S XTFILNAM="VistAPkgSize_"_$P(XTDTTM,".",1)_"_"_$P(XTDTTM,".",2)_".txt"
S @XTOTLK@(5)="Attached VistA Size Report file.....: "_XTFILNAM_XTCRLF
S:($O(@XTPMARY@(0))="") XTNODATA=1
S @XTOTLK@(6)=" "
S:(XTNODATA=0) @XTOTLK@(7)=" "
S:(XTNODATA=1) @XTOTLK@(7)="No report!!"
;
;Begin file output
S @XTOTLK@(8)=$$UUBEGFN(XTFILNAM)
S XTNODE=0
S XTOUTNOD=8
F S XTNODE=$O(@XTPMARY@(XTNODE)) Q:(XTNODE="") Q:($P($G(@XTPMARY@(XTNODE)),"^",1)="CURRENT") DO
. I +$G(XTRT) D:XTNODE#100=0 HANGCHAR(.XTCHAR) ; Display progress character
. S XTSTR=XTSTR_@XTPMARY@(XTNODE,0)_XTCRLF
. D ENCODE(.XTSTR,.XTOUTNOD,XTOTLK)
;
F Q:$L(XTSTR<45) D ENCODE(.XTSTR,.XTOUTNOD,XTOTLK)
S:(XTSTR'="") @XTOTLK@(XTOUTNOD+1)=$$UUEN(XTSTR)
S @XTOTLK@(XTOUTNOD+2)=" "
S @XTOTLK@(XTOUTNOD+3)="end"
;
SET VALMBCK="R"
QUIT
;
UUBEGFN(XTFILENM) ; Construct uuencode "begin" coding
; Call with XTFILENM = name of uuencoded file attachmt
;
; Returns XTX = string with "begin..."_file name
;
N XTX
S XTX="begin 644 "_XTFILENM
Q XTX
;
ENCODE(XTSTR,XTDTANOD,XTOTLK) ;Encode a string, keep remainder for next line
;INPUT:
; XTSTR - String to send in msg; call by reference, Remainder returned in XTSTR
; XTDTANOD - Number of next Node to store msg line in array
; XTOTLK - Array containing msg text for network addresses
;
N XTQUIT,XTLEN,XTX
S XTQUIT=0,XTLEN=$L(XTSTR)
F D Q:XTQUIT
. I $L(XTSTR)<45 S XTQUIT=1 Q
. S XTX=$E(XTSTR,1,45)
. S XTDTANOD=XTDTANOD+1,@XTOTLK@(XTDTANOD)=$$UUEN(XTX)
. S XTSTR=$E(XTSTR,46,XTLEN)
Q
;
UUEN(STR) ; Uuencode string passed in.
;Input
; STR - String to Encode
;
;Output
; TMP - Encoded string
;
N J,K,LEN,XTI,XTX,S,TMP,X,Y
S TMP="",LEN=$L(STR)
F XTI=1:3:LEN D
. S XTX=$E(STR,XTI,XTI+2)
. I $L(XTX)<3 S XTX=XTX_$E(" ",1,3-$L(XTX))
. S S=$A(XTX,1)*256+$A(XTX,2)*256+$A(XTX,3),Y=""
. F K=0:1:23 S Y=(S\(2**K)#2)_Y
. F K=1:6:24 D
. . S J=$$DEC^XLFUTL($E(Y,K,K+5),2)
. . S TMP=TMP_$C(J+32)
S TMP=$C(LEN+32)_TMP
Q TMP
;
HANGCHAR(XTCHAR) ; Display Hang Characters
;Input
; XTCHAR - Last "Hang Character" displayed
NEW XTBS,XTD,XTS
SET:'$D(XTCHAR) XTCHAR=0
SET XTD="-"
SET XTS="\"
SET XTBS="/"
NEW XTRESET,XTY
SET XTY=$Y
DO IOXY^XGF(IOSL-1,62) ;IA #3173
SET XTRESET=0
SET:XTCHAR=0 XTCHAR=XTBS
IF 'XTRESET,XTCHAR=XTD SET XTCHAR=XTS SET XTRESET=1
IF 'XTRESET,XTCHAR=XTS SET XTCHAR=XTBS SET XTRESET=1
IF 'XTRESET,XTCHAR=XTBS SET XTCHAR=XTD SET XTRESET=1
WRITE XTCHAR
IF 1 ;Needed for ^DIC screen calls
Q
;
JUSTPAWS(MSG) ; Press Return to Continue
NEW DIR,X,Y,DTOUT,DIRUT,DUOUT
IF $G(MSG)="" SET MSG=""
IF MSG]"" DO
. SET DIR("A",1)=" "
. SET DIR("A",2)=" "_MSG
. SET DIR("A",3)=" "
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
SET DIR("?")="Press the Enter/Return Key to continue"
DO ^DIR
QUIT
;
FEXT(XTMPARY) ;Return Package File Multiple entries
; INPUT: XTMPARY - Package Extract Array [^XTMP("XTSIZE")]
; OUTPUT: FILELIST - Pipe (|) delimited list of File Multiple entries
;
NEW FILELIST,FLNMNODE
SET FILELIST=""
SET FLNMNODE=0
FOR SET FLNMNODE=$O(@XTMPARY@(FLNMNODE)) QUIT:FLNMNODE="" DO
. SET FILELIST=FILELIST_FLNMNODE_"|"
QUIT FILELIST
;
LISTOUT(SELARY) ; List the packages for selection
NEW ITEMNMBR,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
SET Y=0
SET ITEMNMBR=""
FOR SET ITEMNMBR=$O(SELARY(ITEMNMBR)) QUIT:+ITEMNMBR=0 QUIT:$D(DIRUT) WRITE !," ",ITEMNMBR,": ",SELARY(ITEMNMBR) DO:'(ITEMNMBR#20) PAUSE^VALM1
QUIT
;
UNLCKPFL(FILENAME) ; UnLOCK a Parameter file
NEW UNLKFNME,LOCKRSLT,DEFDIR
SET LOCKRSLT=0
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
SET UNLKFNME=$P(FILENAME,".")_".LCK"
;
;Check PID owning LOCK
KILL FLSLIST,LOCKLIST
SET FLSLIST(UNLKFNME)=""
SET LOCKRSLT=$$LIST^%ZISH(DEFDIR,"FLSLIST","LOCKLIST")
KILL FLSLIST,LOCKLIST
;
IF +LOCKRSLT=0 SET LOCKRSLT="-1^UNLOCK Failure: Parameter file "_FILENAME_" was not LOCKED."
IF '$D(OPTUNLCK),(+LOCKRSLT=1) SET LOCKRSLT=$$CHKPID(DEFDIR,FILENAME) ;Do not check from XTVS PKG MGR PARAM UNLOCK ACTION
;
IF $P(LOCKRSLT,"^")=1 DO
. NEW DELLKFL
. SET DELLKFL(UNLKFNME)=""
. SET LOCKRSLT=$$DEL^%ZISH(DEFDIR,$NA(DELLKFL))
. KILL DELLKFL(UNLKFNME) ;Delete Parameter Lock file
. IF LOCKRSLT=1 SET LOCKRSLT="1^Parameter file "_FILENAME_" LOCK released."
. IF LOCKRSLT=0 SET LOCKRSLT="0^UNLOCK failed: Parameter file "_FILENAME_"!"
. ;
QUIT LOCKRSLT
;
CHKPID(DEFDIR,FILENAME) ; Check PID in .LCK against $JOB
NEW DOLRJ,CKDOLRJ,UNLKFNME
SET UNLKFNME=$P(FILENAME,".")_".LCK"
SET DOLRJ=""
DO OPEN^%ZISH("CKHNDL",DEFDIR,UNLKFNME,"R")
SET CKDOLRJ=$S('POP:1,1:0) ;Pop = 0, file opened
IF 'CKDOLRJ SET CKDOLRJ="-1^LOCK Check Failure: Parameter file has been UNLOCKED by another process!"
IF $P(CKDOLRJ,"^")=1 DO
. USE IO
. READ DOLRJ:5
. DO CLOSE^%ZISH("CKHNDL")
. IF $JOB=DOLRJ SET CKDOLRJ=1
. IF $JOB'=DOLRJ SET CKDOLRJ="0^Parameter file "_FILENAME_" LOCKED by another user."
QUIT CKDOLRJ
;
REQLOCK(FILENAME) ; Check LOCK on a Parameter file. If unlocked, set LOCK
;RETURN: Code^msg
; Code 0 - Obtained LOCK
; 1 - LOCK failed
NEW FILENME,LOCKRSLT,DOLRJ,EXTDIR
KILL FLSLIST,LOCKLIST
SET EXTDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
SET FILENME=$P(FILENAME,".")_".LCK"
SET FLSLIST(FILENME)=""
;
;Check for existing Lock
SET LOCKRSLT=$$LIST^%ZISH(EXTDIR,"FLSLIST","LOCKLIST")
KILL FLSLIST,LOCKLIST
IF LOCKRSLT=1 DO
. DO OPEN^%ZISH("CKHNDL",EXTDIR,FILENME,"R")
. USE IO
. FOR S DOLRJ="" READ DOLRJ:5 Q:$$STATUS^%ZISH DO
.. SET LOCKRSLT=LOCKRSLT_"^Parameter file "_FILENAME_" LOCKED by $JOB PID "_$S(DOLRJ]"":DOLRJ,1:"{unknown}")
. DO CLOSE^%ZISH("CKHNDL")
;
;File not locked, LOCK it
IF LOCKRSLT=0 DO
. NEW LOCKERR
. SET LOCKERR=0
. DO OPEN^%ZISH("LKHNDL",EXTDIR,FILENME,"W")
. SET LOCKERR=$S(POP>0:1,1:0)
. IF 'LOCKERR DO
.. USE IO
.. WRITE $JOB
.. SET LOCKRSLT=LOCKRSLT_"^"_FILENAME_" LOCK obtained."
. DO CLOSE^%ZISH("LKHNDL")
. IF LOCKERR SET LOCKRSLT="1^LOCK request for parameter file "_FILENAME_" FAILED."
QUIT LOCKRSLT
;
NOTCE(NTCTEXT,XTVSADDR,PKGNAME) ; Send Package extract notice msg to requester
; Input:
; NTCTEXT - Notice Text to share with reader (text~TAG^ROUTINE)
; XTVSADDR - Recipients E-Mail address
; PKGNAME - Name of package that had data cleanup during extract
;
NEW XMERR,XMY,XMTEXT,XMDUZ,XMSUB,ERRTEXT
KILL ^TMP("XTVS-REMOTE-ERROR",$JOB)
IF PKGNAME]"" DO
. SET ^TMP("XTVS-REMOTE-ERROR",$JOB,1)="Notice for Package Extract on "_^%ZOSF("PROD")_"."
. SET ^TMP("XTVS-REMOTE-ERROR",$JOB,2)="Data was cleaned up on "_PKGNAME_" extract."
. SET ^TMP("XTVS-REMOTE-ERROR",$JOB,3)=$P(NTCTEXT,"~")
SET XMDUZ="VISTA PACKAGE SIZE ANALYSIS MANAGER"
SET XMY(XTVSADDR)=""
SET XMTEXT="^TMP(""XTVS-REMOTE-ERROR"","_$JOB_","
SET XMSUB="PACKAGE EXTRACT ("_^%ZOSF("PROD")_") ; data cleanup!"
DO ^XMD
IF +XMZ'>0 DO
. SET ERRTEXT="'Extract cleanup notice message' FAILED to return to "_XTVSADDR_"."
. DO APPERROR^%ZTER($S($P(NTCTEXT,"~",2)]"":$P(NTCTEXT,"~",2)_" : ",1:"")_"Package extract error")
KILL ^TMP("XTVS-REMOTE-ERROR",$JOB)
QUIT
;
RMTPKGMG(MSGTEXT,XTVSADDR,PKGNAME) ; Send Package extract notice msg to requester.
; Only invoked by SRVREXT^XTVSSVR when a remote package size report is requested for a single package and fails
; Input:
; MSGTEXT - Text to share with reader
; XTVSADDR - Recipients E-Mail address
; PKGNAME - Name of package that had data cleanup during extract
;
NEW XMERR,XMY,XMTEXT,XMDUZ,XMSUB,ERRTEXT
KILL ^TMP("XTVS-REMOTE-ERROR",$JOB)
IF PKGNAME]"" DO
. SET ^TMP("XTVS-REMOTE-ERROR",$JOB,1)="Package Size Report warning for "_^%ZOSF("PROD")_"."
. SET ^TMP("XTVS-REMOTE-ERROR",$JOB,2)=MSGTEXT
SET XMDUZ=DUZ
SET XMY(XTVSADDR)=""
SET XMTEXT="^TMP(""XTVS-REMOTE-ERROR"","_$JOB_","
SET XMSUB="PACKAGE REPORT NOTICE ("_^%ZOSF("PROD")_") ; Report process warning."
DO ^XMD
IF +XMZ'>0 DO
. SET ERRTEXT="'Package Report Notice' FAILED to return to "_XTVSADDR_"."
. DO APPERROR^%ZTER("TALLYRPT^XTVSRFL : Package extract error")
KILL ^TMP("XTVS-REMOTE-ERROR",$JOB)
QUIT
;
INSRTX(X,SELARY,ITEMNUM) ;Insert item into SELARY in cardinal order
NEW SELITNUM,INSRTPOS,CURITNME,CURITMNM
SET INSRTPOS=0
FOR SELITNUM=1:1:ITEMNUM Q:INSRTPOS>0 DO
. SET CURITNME=$P(SELARY(SELITNUM),"^")
. IF X']CURITNME SET INSRTPOS=SELITNUM
IF INSRTPOS>0 FOR CURITMNM=ITEMNUM:-1:INSRTPOS SET SELARY(CURITMNM+1)=SELARY(CURITMNM) ;Move all entries following duplicate item
IF INSRTPOS=0 SET INSRTPOS=ITEMNUM+1
SET SELARY(INSRTPOS)=X
SET X=INSRTPOS
SET ITEMNUM=ITEMNUM+1
QUIT
;
XTMP2SEL(FIRSTITM,LASTITM,SELARY) ; Move XTMPSIZE from LM List to SELARY
; Default values if not defined:
; FIRSTITM - 1
; LASTITM - Larger of 1 or FIRSTITM when LASTITM > FIRSTITM
;
; E.G. Pull XTMPSIZE file from: ^TMP("XTVS PACKAGE MGR",7566,6,0)=" 1) XTMPSIZE_CLINICAL_6-15-21.DAT"
;
NEW ITEMNUM,FILENME,LINENUM
;
SET FIRSTITM=$S($G(FIRSTITM):+FIRSTITM,1:1)
SET LASTITM=$S($G(LASTITM):+LASTITM,1:1)
SET LASTITM=$S(FIRSTITM>LASTITM:FIRSTITM,1:LASTITM)
;
SET ITEMNUM=0
FOR LINENUM=FIRSTITM:1:LASTITM DO
. SET FILENME=$P(^TMP("XTVS PACKAGE MGR",$J,LINENUM,0),") ",2)
. SET ITEMNUM=ITEMNUM+1
. SET SELARY(ITEMNUM)=FILENME
QUIT ITEMNUM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLAPI 17579 printed Dec 13, 2024@02:42:07 Page 2
XTVSLAPI ;ALBANY FO/GTS - VistA Package Sizing Manager; 27-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 ;
+4 ; APIs
+5 ;
EMAILEXT ; - Send Package File Extract via Packman; Extract & Email ^XTMP(""XTSIZE"","_$JOB_")
+1 ; -- Option: XTVS PKG MGR EXT PACKAGE MSG
+2 ;
+3 NEW EXTRSLT
+4 SET EXTRSLT=$$PKGEXT^XTVSLNA1()
+5 IF 'EXTRSLT
IF $DATA(^XTMP("XTSIZE",$JOB))
Begin DoDot:1
+6 NEW XTINSTMM,XTTOMM,XMERR,XMZ,XTTYPE
+7 ;
+8 WRITE !!," The message can take some time to be sent.",!
+9 KILL XMERR
+10 ;Do not Restrict addressing
SET XTINSTMM("ADDR FLAGS")="R"
+11 SET XTTYPE="S"
+12 DO TOWHOM^XMXAPIU(DUZ,,XTTYPE,.XTINSTMM)
+13 IF +$GET(XMERR)'>0
Begin DoDot:2
+14 NEW XMY,XMTEXT,XMDUZ,XMSUB,XTLPCNT,XDATE
+15 SET XTLPCNT=""
+16 FOR
SET XTLPCNT=$ORDER(^TMP("XMY",$JOB,XTLPCNT))
if XTLPCNT=""
QUIT
SET XMY(XTLPCNT)=""
+17 SET XMDUZ=DUZ
+18 ; Date from 3rd pce [date of extract]
SET XDATE=$PIECE($PIECE(^XTMP("XTSIZE",$JOB,0),"^",3),"-")
+19 SET XDATE=$$FMTE^XLFDT(XDATE,"1P")
+20 SET XMSUB="PACKAGE FILE EXTRACT ("_$PIECE(^XTMP("XTSIZE",$JOB,0),"^",4)_" ; "_XDATE_" ; $JOB#: "_$JOB_")"
+21 SET XMTEXT="^XTMP(""XTSIZE"","_$JOB_","
+22 DO ENT^XMPG
+23 IF +XMZ>0
DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_$JOB_") Emailed via PackMan. [MSG #:"_XMZ_"]")
+24 IF +XMZ'>0
DO JUSTPAWS^XTVSLAPI("Error: ^XTMP(""XTSIZE"","_$JOB_") not sent in Packman. ["_XMMG_"]")
End DoDot:2
+25 IF $PIECE(EXTRSLT,"^",2)'>0
KILL ^TMP("XMY",$JOB),^XTMP("XTSIZE",$JOB)
End DoDot:1
+26 ;
+27 IF EXTRSLT
DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_$JOB_") global exists. Use Extract Manager to access it.")
+28 QUIT
+29 ;
ADD(VALMCNT,MSG,LRBOLD,STRTBLD,ENDBLD) ; -- add line to build display
+1 ;Input
+2 ; VALMCNT - Current array node number
+3 ; MSG - Message to add to ListMan Display
+4 ; LRBOLD - Turns Bold text on - off
+5 ; STRTBLD - Column position to begin Bold Text
+6 ; ENDBLD - Number of columns to apply Bold Text
+7 ;
+8 SET VALMCNT=VALMCNT+1
+9 DO SET^VALM10(VALMCNT,MSG)
+10 IF $GET(LRBOLD)
Begin DoDot:1
+11 if '$GET(STRTBLD)
SET STRTBLD=1
+12 if '$GET(ENDBLD)
SET ENDBLD=79
+13 DO CNTRL^VALM10(VALMCNT,STRTBLD,ENDBLD,IOUON,IOUOFF)
End DoDot:1
+14 QUIT
+15 ;
SPLITADD(VALMCNT,MSG,ADDSPACE) ; -- add line to build display
+1 ;Input
+2 ; VALMCNT - Current array node number
+3 ; MSG - Message to add to ListMan Display
+4 ; ADDSPACE - Add space indicator (1 - add space, 0 - no space
+5 ;
+6 NEW SEGMENTS,TOTNODES,PCE,MSGPCE,START,END
+7 if (+$GET(ADDSPACE)'=1)
SET ADDSPACE=0
+8 SET SEGMENTS=$LENGTH(MSG)/80
+9 SET TOTNODES=+$PIECE(SEGMENTS,".")
+10 IF ADDSPACE
IF (+$PIECE(SEGMENTS,".",2)>0)
SET TOTNODES=TOTNODES+1
+11 FOR PCE=0:1:TOTNODES
Begin DoDot:1
+12 SET START=1+(PCE*80)
+13 SET END=80+(PCE*80)
+14 SET MSGPCE=$EXTRACT(MSG,START,END)
+15 SET VALMCNT=VALMCNT+1
+16 DO SET^VALM10(VALMCNT,MSGPCE)
End DoDot:1
+17 QUIT
+18 ;
RTRNADD(EMGRTARY,LNENUM,MSG) ; Add a line to EMGRTARY array
+1 ;INPUT
+2 ; EMGRTARY - Extract Management array [Passed by value for Indirect use]
+3 ; LNENUM - Last Node number in the EMGRTARY array
+4 ; MSG - Message to store in next line on EMGRTARY array
+5 ;
+6 SET LNENUM=LNENUM+1
+7 SET @EMGRTARY@(LNENUM,0)=MSG
+8 QUIT
+9 ;
EDITPCHK() ; -- does DUZ have XTVS EDITOR key
+1 NEW XTVSSEC
+2 DO OWNSKEY^XUSRB(.XTVSSEC,"XTVS EDITOR")
+3 QUIT +$GET(XTVSSEC(0))
+4 ;
YNCHK(APROMPT,DEFANS) ; Yes/No Prompt
+1 ;INPUT
+2 ; APROMPT - Prompt to display before Y/N question [DIR("A")]
+3 ; DEFANS - Default Y/N answer [DIR("B")] (optional - defaults to NO)
+4 ;OUTPUT
+5 ; XTSVRSLT - value of Y when DIR Y/N prompt answer = Yes/No
+6 ; 0^-1 when Timeout, ^ or ^^ out. 3rd ^ piece = 1 when Timeout [0^-1^1].
+7 ;
+8 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,XTSVRSLT
+9 SET DIR("A")=APROMPT
+10 SET DIR(0)="Y^A"
+11 SET DIR("B")=$GET(DEFANS)
+12 IF '$DATA(DEFANS)
SET DIR("B")="NO"
+13 DO ^DIR
+14 SET XTSVRSLT=Y_"^"_Y
+15 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET XTSVRSLT="0"_"^-1"_$SELECT($DATA(DTOUT):"^1",1:"^")
+16 QUIT XTSVRSLT
+17 ;
SELXTMP(BEGIN,END) ;Select XTMPSIZE.DAT file
+1 ; RETURN: Selected XTMPSIZE file name
+2 ;
+3 NEW SELARY,ITEMNUM,FILENME,YVAL
+4 SET SELARY=""
+5 SET ITEMNUM=$$XTMP2SEL(BEGIN,END,.SELARY)
+6 IF ITEMNUM>0
Begin DoDot:1
+7 NEW PARAMSTR,QSTHLP1
+8 SET QSTHLP1=" Enter the name or number (1-"_ITEMNUM_") of the parameter file."
+9 SET PARAMSTR("MINLNG")=10
+10 SET PARAMSTR("PATRN")="1""XTMPSIZE"".ANP"
+11 SET PARAMSTR("MAXLNG")=30
+12 SET PARAMSTR("DEFANS")=$GET(XTVPSPRM)
+13 SET PARAMSTR("ADDITM")=0
+14 SET YVAL=+$$SELITEM^XTVSLP(QSTHLP1,.ITEMNUM,.SELARY,.PARAMSTR)
+15 IF (+$GET(YVAL)>0)&(+$GET(YVAL)<(ITEMNUM+1))
SET FILENME=SELARY(YVAL)
WRITE " ",FILENME
End DoDot:1
+16 ;
+17 IF ITEMNUM'>0
DO JUSTPAWS^XTVSLAPI(" There are no XTMPSIZE files to select!")
+18 ;
+19 QUIT $GET(FILENME)
+20 ;
WRTTXTFL(FILENME,STORPATH) ; Output Package Manager Report to Text file
+1 NEW POPERR,LMTMPNDE
+2 SET (D1,POPERR)=""
+3 ;
+4 ;If write delimited report to a file
+5 IF FILENME]""
Begin DoDot:1
+6 DO OPEN^%ZISH("DELIMFL1",STORPATH,FILENME,"A")
+7 if POP
SET POPERR=POP
+8 if POPERR
QUIT
+9 USE IO
+10 SET LMTMPNDE=0
+11 FOR
SET LMTMPNDE=$ORDER(^TMP("XTVS PKG MGR RPT",$JOB,LMTMPNDE))
if +LMTMPNDE=0
QUIT
Begin DoDot:2
+12 WRITE !,^TMP("XTVS PKG MGR RPT",$JOB,LMTMPNDE,0)
End DoDot:2
+13 DO CLOSE^%ZISH("DELIMFL1")
End DoDot:1
if POPERR
QUIT
+14 QUIT
+15 ;
SNDEXT(XTSVSUBJ,XQSND,XTEXTARY) ;Send VistA Size report
+1 ; -- Protocol: XTVS PKG MGR RPT MAIL ACTION
+2 ;
+3 ;INPUT:
+4 ; XTSVSUBJ - Subject of message generated
+5 ; XQSND - User's DUZ, Group Name, or S.server name
+6 ; XTEXTARY - Array containing msg text
+7 ;
+8 NEW XTINSTMM,XTINSTVA,XTTASKMM,XTTASKVA,XTTOMM,XTTOVA,XMERR,XMZ,XTLPCNT,XTTYPE
+9 ;
+10 DO FULL^VALM1
+11 WRITE !!," The message can take some time to be sent.",!
+12 ;
+13 ;Do not Restrict addressing
SET XTINSTMM("ADDR FLAGS")="R"
+14 SET XTTYPE="S"
+15 KILL XMERR
+16 DO TOWHOM^XMXAPIU(DUZ,,XTTYPE,.XTINSTMM)
+17 ;
+18 ;Check Network addresses and mail attachmt
+19 ;Do not Restrict addressing
SET XTINSTVA("ADDR FLAGS")="R"
+20 SET XTINSTVA("FROM")="VISTA_PACKAGE_MANAGER_RPT"
+21 SET XTSVSUBJ=$EXTRACT(XTSVSUBJ,1,65)
+22 SET XTLPCNT=""
+23 FOR
SET XTLPCNT=$ORDER(^TMP("XMY",$JOB,XTLPCNT))
if XTLPCNT=""
QUIT
SET XTTOVA(XTLPCNT)=""
+24 ;
+25 IF +$GET(XMERR)'>0
Begin DoDot:1
+26 NEW XTFORMAT
+27 WRITE !!,"NOTE: Attachments sent to VA MailMan addresses will be unreadable."
+28 WRITE !," Send the the report in a message if sending to a VA Mailman address."
+29 SET XTFORMAT=$$MSGORATC^XTVSLAPI("the VistA Size Report")
+30 IF XTFORMAT'="M"
IF XTFORMAT'="A"
DO JUSTPAWS(" Message not sent!")
+31 ; Report in message
+32 IF XTFORMAT="M"
Begin DoDot:2
+33 DO SENDMSG^XMXAPI(XQSND,XTSVSUBJ,XTEXTARY,.XTTOVA,.XTINSTVA,.XTTASKVA)
+34 DO JUSTPAWS("MSG#: "_XTTASKVA_" created!")
End DoDot:2
+35 ; Report in attachment
+36 IF XTFORMAT="A"
Begin DoDot:2
+37 WRITE !," [Creating attachments..."
+38 DO OUTLKARY(XTEXTARY,"^TMP($J,""XTNETMSG"")",XTSVSUBJ,1)
+39 DO SENDMSG^XMXAPI(XQSND,XTSVSUBJ,"^TMP($J,""XTNETMSG"")",.XTTOVA,.XTINSTVA,.XTTASKVA)
+40 DO JUSTPAWS("MSG#: "_XTTASKVA_" created!")
End DoDot:2
End DoDot:1
+41 ;
+42 KILL ^TMP("XMY",$JOB),^TMP("XMY0",$JOB),^TMP($JOB,"XTNETMSG")
+43 DO MSG^XTVSLR
+44 SET VALMBCK="R"
+45 QUIT
+46 ;
MSGORATC(XTQTXT) ; Query message or text attachment
+1 ; INPUT:
+2 ; XTQTXT - Report name text to include in user prompt
+3 ;
+4 ; OUTPUT:
+5 ; RESULT -
+6 ; M : Message - Send report in a message
+7 ; A : Attachment - Send report as a text file attachment to the message
+8 ; -1 : Fail/Error condition
+9 ;
+10 NEW RESULT
+11 SET DIR("A")="Send "_XTQTXT_" as a message or a text file attachment: "
+12 SET DIR("B")="A"
+13 SET DIR(0)="SAB^M:Message;A:Attachment"
+14 SET DIR("?")="Enter 'M' to send the report in a message or 'A' to send in a file attached to a message."
+15 DO ^DIR
+16 SET RESULT=$SELECT($DATA(DIRUT):-1,1:Y)
+17 QUIT RESULT
+18 ;
OUTLKARY(XTPMARY,XTOTLK,XTSVSUBJ,XTRT) ;Create attachmts array
+1 ;INPUT:
+2 ; XTPMARY - Array containing raw message text
+3 ; XTOTLK - Array containing message text for network addresses
+4 ; XTSVSUBJ - Message subject
+5 ; XTRT - Real Time processing from UI
+6 ;
+7 NEW XTFILNAM,XTDTTM,XTCRLF,XTSTR,XTNODE,XTOUTNOD,XTNODATA,XTCHAR
+8 if +$GET(XTRT)=0
SET XTRT=0
+9 if +$GET(XTRT)
SET XTCHAR=0
+10 SET XTSTR=""
+11 SET XTNODATA=0
+12 SET XTCRLF=$CHAR(13,10)
+13 SET XTDTTM=$$NOW^XLFDT
+14 KILL @XTOTLK
+15 SET @XTOTLK@(1)="Attachment Generated......: "_$$FMTE^XLFDT(XTDTTM)_XTCRLF
+16 SET @XTOTLK@(2)=" "
+17 SET @XTOTLK@(3)="Extract Requested......: "_XTSVSUBJ_XTCRLF
+18 SET @XTOTLK@(4)=" "
+19 ;
+20 SET XTFILNAM="VistAPkgSize_"_$PIECE(XTDTTM,".",1)_"_"_$PIECE(XTDTTM,".",2)_".txt"
+21 SET @XTOTLK@(5)="Attached VistA Size Report file.....: "_XTFILNAM_XTCRLF
+22 if ($ORDER(@XTPMARY@(0))="")
SET XTNODATA=1
+23 SET @XTOTLK@(6)=" "
+24 if (XTNODATA=0)
SET @XTOTLK@(7)=" "
+25 if (XTNODATA=1)
SET @XTOTLK@(7)="No report!!"
+26 ;
+27 ;Begin file output
+28 SET @XTOTLK@(8)=$$UUBEGFN(XTFILNAM)
+29 SET XTNODE=0
+30 SET XTOUTNOD=8
+31 FOR
SET XTNODE=$ORDER(@XTPMARY@(XTNODE))
if (XTNODE="")
QUIT
if ($PIECE($GET(@XTPMARY@(XTNODE)),"^",1)="CURRENT")
QUIT
Begin DoDot:1
+32 ; Display progress character
IF +$GET(XTRT)
if XTNODE#100=0
DO HANGCHAR(.XTCHAR)
+33 SET XTSTR=XTSTR_@XTPMARY@(XTNODE,0)_XTCRLF
+34 DO ENCODE(.XTSTR,.XTOUTNOD,XTOTLK)
End DoDot:1
+35 ;
+36 FOR
if $LENGTH(XTSTR<45)
QUIT
DO ENCODE(.XTSTR,.XTOUTNOD,XTOTLK)
+37 if (XTSTR'="")
SET @XTOTLK@(XTOUTNOD+1)=$$UUEN(XTSTR)
+38 SET @XTOTLK@(XTOUTNOD+2)=" "
+39 SET @XTOTLK@(XTOUTNOD+3)="end"
+40 ;
+41 SET VALMBCK="R"
+42 QUIT
+43 ;
UUBEGFN(XTFILENM) ; Construct uuencode "begin" coding
+1 ; Call with XTFILENM = name of uuencoded file attachmt
+2 ;
+3 ; Returns XTX = string with "begin..."_file name
+4 ;
+5 NEW XTX
+6 SET XTX="begin 644 "_XTFILENM
+7 QUIT XTX
+8 ;
ENCODE(XTSTR,XTDTANOD,XTOTLK) ;Encode a string, keep remainder for next line
+1 ;INPUT:
+2 ; XTSTR - String to send in msg; call by reference, Remainder returned in XTSTR
+3 ; XTDTANOD - Number of next Node to store msg line in array
+4 ; XTOTLK - Array containing msg text for network addresses
+5 ;
+6 NEW XTQUIT,XTLEN,XTX
+7 SET XTQUIT=0
SET XTLEN=$LENGTH(XTSTR)
+8 FOR
Begin DoDot:1
+9 IF $LENGTH(XTSTR)<45
SET XTQUIT=1
QUIT
+10 SET XTX=$EXTRACT(XTSTR,1,45)
+11 SET XTDTANOD=XTDTANOD+1
SET @XTOTLK@(XTDTANOD)=$$UUEN(XTX)
+12 SET XTSTR=$EXTRACT(XTSTR,46,XTLEN)
End DoDot:1
if XTQUIT
QUIT
+13 QUIT
+14 ;
UUEN(STR) ; Uuencode string passed in.
+1 ;Input
+2 ; STR - String to Encode
+3 ;
+4 ;Output
+5 ; TMP - Encoded string
+6 ;
+7 NEW J,K,LEN,XTI,XTX,S,TMP,X,Y
+8 SET TMP=""
SET LEN=$LENGTH(STR)
+9 FOR XTI=1:3:LEN
Begin DoDot:1
+10 SET XTX=$EXTRACT(STR,XTI,XTI+2)
+11 IF $LENGTH(XTX)<3
SET XTX=XTX_$EXTRACT(" ",1,3-$LENGTH(XTX))
+12 SET S=$ASCII(XTX,1)*256+$ASCII(XTX,2)*256+$ASCII(XTX,3)
SET Y=""
+13 FOR K=0:1:23
SET Y=(S\(2**K)#2)_Y
+14 FOR K=1:6:24
Begin DoDot:2
+15 SET J=$$DEC^XLFUTL($EXTRACT(Y,K,K+5),2)
+16 SET TMP=TMP_$CHAR(J+32)
End DoDot:2
End DoDot:1
+17 SET TMP=$CHAR(LEN+32)_TMP
+18 QUIT TMP
+19 ;
HANGCHAR(XTCHAR) ; Display Hang Characters
+1 ;Input
+2 ; XTCHAR - Last "Hang Character" displayed
+3 NEW XTBS,XTD,XTS
+4 if '$DATA(XTCHAR)
SET XTCHAR=0
+5 SET XTD="-"
+6 SET XTS="\"
+7 SET XTBS="/"
+8 NEW XTRESET,XTY
+9 SET XTY=$Y
+10 ;IA #3173
DO IOXY^XGF(IOSL-1,62)
+11 SET XTRESET=0
+12 if XTCHAR=0
SET XTCHAR=XTBS
+13 IF 'XTRESET
IF XTCHAR=XTD
SET XTCHAR=XTS
SET XTRESET=1
+14 IF 'XTRESET
IF XTCHAR=XTS
SET XTCHAR=XTBS
SET XTRESET=1
+15 IF 'XTRESET
IF XTCHAR=XTBS
SET XTCHAR=XTD
SET XTRESET=1
+16 WRITE XTCHAR
+17 ;Needed for ^DIC screen calls
IF 1
+18 QUIT
+19 ;
JUSTPAWS(MSG) ; Press Return to Continue
+1 NEW DIR,X,Y,DTOUT,DIRUT,DUOUT
+2 IF $GET(MSG)=""
SET MSG=""
+3 IF MSG]""
Begin DoDot:1
+4 SET DIR("A",1)=" "
+5 SET DIR("A",2)=" "_MSG
+6 SET DIR("A",3)=" "
End DoDot:1
+7 SET DIR("A")="Press Return to continue"
+8 SET DIR(0)="E"
+9 SET DIR("?")="Press the Enter/Return Key to continue"
+10 DO ^DIR
+11 QUIT
+12 ;
FEXT(XTMPARY) ;Return Package File Multiple entries
+1 ; INPUT: XTMPARY - Package Extract Array [^XTMP("XTSIZE")]
+2 ; OUTPUT: FILELIST - Pipe (|) delimited list of File Multiple entries
+3 ;
+4 NEW FILELIST,FLNMNODE
+5 SET FILELIST=""
+6 SET FLNMNODE=0
+7 FOR
SET FLNMNODE=$ORDER(@XTMPARY@(FLNMNODE))
if FLNMNODE=""
QUIT
Begin DoDot:1
+8 SET FILELIST=FILELIST_FLNMNODE_"|"
End DoDot:1
+9 QUIT FILELIST
+10 ;
LISTOUT(SELARY) ; List the packages for selection
+1 NEW ITEMNMBR,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
+2 SET Y=0
+3 SET ITEMNMBR=""
+4 FOR
SET ITEMNMBR=$ORDER(SELARY(ITEMNMBR))
if +ITEMNMBR=0
QUIT
if $DATA(DIRUT)
QUIT
WRITE !," ",ITEMNMBR,": ",SELARY(ITEMNMBR)
if '(ITEMNMBR#20)
DO PAUSE^VALM1
+5 QUIT
+6 ;
UNLCKPFL(FILENAME) ; UnLOCK a Parameter file
+1 NEW UNLKFNME,LOCKRSLT,DEFDIR
+2 SET LOCKRSLT=0
+3 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+4 SET UNLKFNME=$PIECE(FILENAME,".")_".LCK"
+5 ;
+6 ;Check PID owning LOCK
+7 KILL FLSLIST,LOCKLIST
+8 SET FLSLIST(UNLKFNME)=""
+9 SET LOCKRSLT=$$LIST^%ZISH(DEFDIR,"FLSLIST","LOCKLIST")
+10 KILL FLSLIST,LOCKLIST
+11 ;
+12 IF +LOCKRSLT=0
SET LOCKRSLT="-1^UNLOCK Failure: Parameter file "_FILENAME_" was not LOCKED."
+13 ;Do not check from XTVS PKG MGR PARAM UNLOCK ACTION
IF '$DATA(OPTUNLCK)
IF (+LOCKRSLT=1)
SET LOCKRSLT=$$CHKPID(DEFDIR,FILENAME)
+14 ;
+15 IF $PIECE(LOCKRSLT,"^")=1
Begin DoDot:1
+16 NEW DELLKFL
+17 SET DELLKFL(UNLKFNME)=""
+18 SET LOCKRSLT=$$DEL^%ZISH(DEFDIR,$NAME(DELLKFL))
+19 ;Delete Parameter Lock file
KILL DELLKFL(UNLKFNME)
+20 IF LOCKRSLT=1
SET LOCKRSLT="1^Parameter file "_FILENAME_" LOCK released."
+21 IF LOCKRSLT=0
SET LOCKRSLT="0^UNLOCK failed: Parameter file "_FILENAME_"!"
+22 ;
End DoDot:1
+23 QUIT LOCKRSLT
+24 ;
CHKPID(DEFDIR,FILENAME) ; Check PID in .LCK against $JOB
+1 NEW DOLRJ,CKDOLRJ,UNLKFNME
+2 SET UNLKFNME=$PIECE(FILENAME,".")_".LCK"
+3 SET DOLRJ=""
+4 DO OPEN^%ZISH("CKHNDL",DEFDIR,UNLKFNME,"R")
+5 ;Pop = 0, file opened
SET CKDOLRJ=$SELECT('POP:1,1:0)
+6 IF 'CKDOLRJ
SET CKDOLRJ="-1^LOCK Check Failure: Parameter file has been UNLOCKED by another process!"
+7 IF $PIECE(CKDOLRJ,"^")=1
Begin DoDot:1
+8 USE IO
+9 READ DOLRJ:5
+10 DO CLOSE^%ZISH("CKHNDL")
+11 IF $JOB=DOLRJ
SET CKDOLRJ=1
+12 IF $JOB'=DOLRJ
SET CKDOLRJ="0^Parameter file "_FILENAME_" LOCKED by another user."
End DoDot:1
+13 QUIT CKDOLRJ
+14 ;
REQLOCK(FILENAME) ; Check LOCK on a Parameter file. If unlocked, set LOCK
+1 ;RETURN: Code^msg
+2 ; Code 0 - Obtained LOCK
+3 ; 1 - LOCK failed
+4 NEW FILENME,LOCKRSLT,DOLRJ,EXTDIR
+5 KILL FLSLIST,LOCKLIST
+6 SET EXTDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+7 SET FILENME=$PIECE(FILENAME,".")_".LCK"
+8 SET FLSLIST(FILENME)=""
+9 ;
+10 ;Check for existing Lock
+11 SET LOCKRSLT=$$LIST^%ZISH(EXTDIR,"FLSLIST","LOCKLIST")
+12 KILL FLSLIST,LOCKLIST
+13 IF LOCKRSLT=1
Begin DoDot:1
+14 DO OPEN^%ZISH("CKHNDL",EXTDIR,FILENME,"R")
+15 USE IO
+16 FOR
SET DOLRJ=""
READ DOLRJ:5
if $$STATUS^%ZISH
QUIT
Begin DoDot:2
+17 SET LOCKRSLT=LOCKRSLT_"^Parameter file "_FILENAME_" LOCKED by $JOB PID "_$SELECT(DOLRJ]"":DOLRJ,1:"{unknown}")
End DoDot:2
+18 DO CLOSE^%ZISH("CKHNDL")
End DoDot:1
+19 ;
+20 ;File not locked, LOCK it
+21 IF LOCKRSLT=0
Begin DoDot:1
+22 NEW LOCKERR
+23 SET LOCKERR=0
+24 DO OPEN^%ZISH("LKHNDL",EXTDIR,FILENME,"W")
+25 SET LOCKERR=$SELECT(POP>0:1,1:0)
+26 IF 'LOCKERR
Begin DoDot:2
+27 USE IO
+28 WRITE $JOB
+29 SET LOCKRSLT=LOCKRSLT_"^"_FILENAME_" LOCK obtained."
End DoDot:2
+30 DO CLOSE^%ZISH("LKHNDL")
+31 IF LOCKERR
SET LOCKRSLT="1^LOCK request for parameter file "_FILENAME_" FAILED."
End DoDot:1
+32 QUIT LOCKRSLT
+33 ;
NOTCE(NTCTEXT,XTVSADDR,PKGNAME) ; Send Package extract notice msg to requester
+1 ; Input:
+2 ; NTCTEXT - Notice Text to share with reader (text~TAG^ROUTINE)
+3 ; XTVSADDR - Recipients E-Mail address
+4 ; PKGNAME - Name of package that had data cleanup during extract
+5 ;
+6 NEW XMERR,XMY,XMTEXT,XMDUZ,XMSUB,ERRTEXT
+7 KILL ^TMP("XTVS-REMOTE-ERROR",$JOB)
+8 IF PKGNAME]""
Begin DoDot:1
+9 SET ^TMP("XTVS-REMOTE-ERROR",$JOB,1)="Notice for Package Extract on "_^%ZOSF("PROD")_"."
+10 SET ^TMP("XTVS-REMOTE-ERROR",$JOB,2)="Data was cleaned up on "_PKGNAME_" extract."
+11 SET ^TMP("XTVS-REMOTE-ERROR",$JOB,3)=$PIECE(NTCTEXT,"~")
End DoDot:1
+12 SET XMDUZ="VISTA PACKAGE SIZE ANALYSIS MANAGER"
+13 SET XMY(XTVSADDR)=""
+14 SET XMTEXT="^TMP(""XTVS-REMOTE-ERROR"","_$JOB_","
+15 SET XMSUB="PACKAGE EXTRACT ("_^%ZOSF("PROD")_") ; data cleanup!"
+16 DO ^XMD
+17 IF +XMZ'>0
Begin DoDot:1
+18 SET ERRTEXT="'Extract cleanup notice message' FAILED to return to "_XTVSADDR_"."
+19 DO APPERROR^%ZTER($SELECT($PIECE(NTCTEXT,"~",2)]"":$PIECE(NTCTEXT,"~",2)_" : ",1:"")_"Package extract error")
End DoDot:1
+20 KILL ^TMP("XTVS-REMOTE-ERROR",$JOB)
+21 QUIT
+22 ;
RMTPKGMG(MSGTEXT,XTVSADDR,PKGNAME) ; Send Package extract notice msg to requester.
+1 ; Only invoked by SRVREXT^XTVSSVR when a remote package size report is requested for a single package and fails
+2 ; Input:
+3 ; MSGTEXT - Text to share with reader
+4 ; XTVSADDR - Recipients E-Mail address
+5 ; PKGNAME - Name of package that had data cleanup during extract
+6 ;
+7 NEW XMERR,XMY,XMTEXT,XMDUZ,XMSUB,ERRTEXT
+8 KILL ^TMP("XTVS-REMOTE-ERROR",$JOB)
+9 IF PKGNAME]""
Begin DoDot:1
+10 SET ^TMP("XTVS-REMOTE-ERROR",$JOB,1)="Package Size Report warning for "_^%ZOSF("PROD")_"."
+11 SET ^TMP("XTVS-REMOTE-ERROR",$JOB,2)=MSGTEXT
End DoDot:1
+12 SET XMDUZ=DUZ
+13 SET XMY(XTVSADDR)=""
+14 SET XMTEXT="^TMP(""XTVS-REMOTE-ERROR"","_$JOB_","
+15 SET XMSUB="PACKAGE REPORT NOTICE ("_^%ZOSF("PROD")_") ; Report process warning."
+16 DO ^XMD
+17 IF +XMZ'>0
Begin DoDot:1
+18 SET ERRTEXT="'Package Report Notice' FAILED to return to "_XTVSADDR_"."
+19 DO APPERROR^%ZTER("TALLYRPT^XTVSRFL : Package extract error")
End DoDot:1
+20 KILL ^TMP("XTVS-REMOTE-ERROR",$JOB)
+21 QUIT
+22 ;
INSRTX(X,SELARY,ITEMNUM) ;Insert item into SELARY in cardinal order
+1 NEW SELITNUM,INSRTPOS,CURITNME,CURITMNM
+2 SET INSRTPOS=0
+3 FOR SELITNUM=1:1:ITEMNUM
if INSRTPOS>0
QUIT
Begin DoDot:1
+4 SET CURITNME=$PIECE(SELARY(SELITNUM),"^")
+5 IF X']CURITNME
SET INSRTPOS=SELITNUM
End DoDot:1
+6 ;Move all entries following duplicate item
IF INSRTPOS>0
FOR CURITMNM=ITEMNUM:-1:INSRTPOS
SET SELARY(CURITMNM+1)=SELARY(CURITMNM)
+7 IF INSRTPOS=0
SET INSRTPOS=ITEMNUM+1
+8 SET SELARY(INSRTPOS)=X
+9 SET X=INSRTPOS
+10 SET ITEMNUM=ITEMNUM+1
+11 QUIT
+12 ;
XTMP2SEL(FIRSTITM,LASTITM,SELARY) ; Move XTMPSIZE from LM List to SELARY
+1 ; Default values if not defined:
+2 ; FIRSTITM - 1
+3 ; LASTITM - Larger of 1 or FIRSTITM when LASTITM > FIRSTITM
+4 ;
+5 ; E.G. Pull XTMPSIZE file from: ^TMP("XTVS PACKAGE MGR",7566,6,0)=" 1) XTMPSIZE_CLINICAL_6-15-21.DAT"
+6 ;
+7 NEW ITEMNUM,FILENME,LINENUM
+8 ;
+9 SET FIRSTITM=$SELECT($GET(FIRSTITM):+FIRSTITM,1:1)
+10 SET LASTITM=$SELECT($GET(LASTITM):+LASTITM,1:1)
+11 SET LASTITM=$SELECT(FIRSTITM>LASTITM:FIRSTITM,1:LASTITM)
+12 ;
+13 SET ITEMNUM=0
+14 FOR LINENUM=FIRSTITM:1:LASTITM
Begin DoDot:1
+15 SET FILENME=$PIECE(^TMP("XTVS PACKAGE MGR",$JOB,LINENUM,0),") ",2)
+16 SET ITEMNUM=ITEMNUM+1
+17 SET SELARY(ITEMNUM)=FILENME
End DoDot:1
+18 QUIT ITEMNUM
