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