- A1VSLAPI ;Albany FO/GTS - VistA Package Sizing Manager; 27-JUN-2016
- ;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
- ; APIs
- ;
- EMAILEXT ; Extract & E-Mail ^XTMP(""A1SIZE"","_$JOB_")
- ; -- Option: A1VS EXT-EMAIL PKG DATA
- ;
- NEW EXTRSLT
- SET EXTRSLT=$$PKGEXT^A1VSLNA1()
- IF 'EXTRSLT,$D(^XTMP("A1SIZE",$JOB)) 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,A1LPCNT,XDATE
- .. SET A1LPCNT=""
- .. FOR SET A1LPCNT=$O(^TMP("XMY",$J,A1LPCNT)) QUIT:A1LPCNT="" SET XMY(A1LPCNT)=""
- .. SET XMDUZ=DUZ
- .. SET XDATE=$P(^XTMP("A1SIZE",$JOB,0),"^")
- .. SET XDATE=$$FMTE^XLFDT(XDATE,"1P")
- .. SET XMSUB="PACKAGE FILE EXTRACT ("_$P(^XTMP("A1SIZE",$JOB,0),"^",2)_" ; "_XDATE_" ; $JOB#: "_$JOB_")"
- .. SET XMTEXT="^XTMP(""A1SIZE"","_$JOB_","
- .. DO ENT^XMPG
- .. IF +XMZ>0 DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_$JOB_") E-Mailed via PackMan. [MSG #:"_XMZ_"]")
- .. IF +XMZ'>0 DO JUSTPAWS^A1VSLAPI("Error: ^XTMP(""A1SIZE"","_$JOB_") not sent in Packman. ["_XMMG_"]")
- . IF $P(EXTRSLT,"^",2)'>0 KILL ^TMP("XMY",$J),^XTMP("A1SIZE",$JOB)
- ;
- IF EXTRSLT DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_$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 A1VS EDITOR key
- NEW A1VSSEC
- DO OWNSKEY^XUSRB(.A1VSSEC,"A1VS EDITOR")
- QUIT +$G(A1VSSEC(0))
- ;
- YNCHK(APROMPT) ; Yes/No Prompt
- ;INPUT
- ; APROMPT - Prompt to display before Y/N question
- ;OUTPUT
- ; value of Y returned from DIR Y/N prompt
- ;
- NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
- SET DIR("A")=APROMPT
- SET DIR(0)="Y^A"
- SET DIR("B")="NO"
- DO ^DIR
- Q Y
- ;
- SELXTMP(BEGIN,END,A1OFFSET) ;Select XTMPSIZE.DAT file
- ;
- SET:'$D(A1OFFSET) A1OFFSET=0
- D FULL^VALM1
- SET DIR("A",1)=""
- SET DIR("A")="Select the XTMPSIZE*.DAT Package Parameter file item number"
- SET DIR(0)="N:"_BEGIN_":"_END
- DO ^DIR
- IF ($D(DTOUT))!($D(DUOUT)) QUIT -1
- QUIT Y+A1OFFSET
- ;
- 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("A1VS PKG MGR RPT",$J,LMTMPNDE)) Q:+LMTMPNDE=0 DO
- .. W !,^TMP("A1VS PKG MGR RPT",$J,LMTMPNDE,0)
- . D CLOSE^%ZISH("DELIMFL1")
- QUIT
- ;
- SNDEXT(A1SVSUBJ,XQSND,A1EXTARY) ;Send VistA Size report
- ; -- Protocol: A1VS PKG MGR RPT MAIL ACTION
- ;
- ;INPUT:
- ; A1SVSUBJ - Subject of message generated
- ; XQSND - User's DUZ, Group Name, or S.server name
- ; A1EXTARY - Array containing msg text
- ;
- N A1INSTMM,A1INSTVA,A1TASKMM,A1TASKVA,A1TOMM,A1TOVA,XMERR,XMZ,A1LPCNT,A1TYPE
- ;
- DO FULL^VALM1
- ;
- S A1INSTMM("ADDR FLAGS")="R" ;Do not Restrict addressing
- S A1TYPE="S"
- K XMERR
- D TOWHOM^XMXAPIU(DUZ,,A1TYPE,.A1INSTMM)
- ;
- ;Check Network addresses and mail attachmt
- S A1INSTVA("ADDR FLAGS")="R" ;Do not Restrict addressing
- S A1INSTVA("FROM")="VISTA_PACKAGE_MANAGER_RPT"
- S A1SVSUBJ=$E(A1SVSUBJ,1,65)
- S A1LPCNT=""
- F S A1LPCNT=$O(^TMP("XMY",$J,A1LPCNT)) Q:A1LPCNT="" S A1TOVA(A1LPCNT)=""
- ;
- I +$G(XMERR)'>0 DO
- .W !," [Creating attachments..."
- .D OUTLKARY(A1EXTARY,"^TMP($J,""A1NETMSG"")",A1SVSUBJ,1)
- .D SENDMSG^XMXAPI(XQSND,A1SVSUBJ,"^TMP($J,""A1NETMSG"")",.A1TOVA,.A1INSTVA,.A1TASKVA)
- ;
- K ^TMP("XMY",$J),^TMP("XMY0",$J),^TMP($J,"A1NETMSG")
- SET VALMBCK="R"
- Q
- ;
- OUTLKARY(A1PMARY,A1OTLK,A1SVSUBJ,A1RT) ;Create attachmts array
- ;INPUT:
- ; A1PMARY - Array containing raw message text
- ; A1OTLK - Array containing message text for network addresses
- ; A1SVSUBJ - Message subject
- ; A1RT - Real Time processing from UI
- ;
- N A1FILNAM,A1DTTM,A1CRLF,A1STR,A1NODE,A1OUTNOD,A1NODATA,A1CHAR
- S:+$G(A1RT)=0 A1RT=0
- S:+$G(A1RT) A1CHAR=0
- S A1STR=""
- S A1NODATA=0
- S A1CRLF=$C(13,10)
- S A1DTTM=$$NOW^XLFDT
- K @A1OTLK
- S @A1OTLK@(1)="Attachment Generated......: "_$$FMTE^XLFDT(A1DTTM)_A1CRLF
- S @A1OTLK@(2)=" "
- S @A1OTLK@(3)="Extract Requested......: "_A1SVSUBJ_A1CRLF
- S @A1OTLK@(4)=" "
- ;
- S A1FILNAM="VistAPkgSize_"_$P(A1DTTM,".",1)_"_"_$P(A1DTTM,".",2)_".txt"
- S @A1OTLK@(5)="Attached VistA Size Report file.....: "_A1FILNAM_A1CRLF
- S:($O(@A1PMARY@(0))="") A1NODATA=1
- S @A1OTLK@(6)=" "
- S:(A1NODATA=0) @A1OTLK@(7)=" "
- S:(A1NODATA=1) @A1OTLK@(7)="No report!!"
- ;
- ;Begin file output
- S @A1OTLK@(8)=$$UUBEGFN(A1FILNAM)
- S A1NODE=0
- S A1OUTNOD=8
- F S A1NODE=$O(@A1PMARY@(A1NODE)) Q:(A1NODE="") Q:($P($G(@A1PMARY@(A1NODE)),"^",1)="CURRENT") DO
- . I +$G(A1RT) D:A1NODE#100=0 HANGCHAR(.A1CHAR) ; Display progress character
- . S A1STR=A1STR_@A1PMARY@(A1NODE,0)_A1CRLF
- . D ENCODE(.A1STR,.A1OUTNOD,A1OTLK)
- ;
- F Q:$L(A1STR<45) D ENCODE(.A1STR,.A1OUTNOD,A1OTLK)
- S:(A1STR'="") @A1OTLK@(A1OUTNOD+1)=$$UUEN(A1STR)
- S @A1OTLK@(A1OUTNOD+2)=" "
- S @A1OTLK@(A1OUTNOD+3)="end"
- ;
- SET VALMBCK="R"
- QUIT
- ;
- UUBEGFN(A1FILENM) ; Construct uuencode "begin" coding
- ; Call with A1FILENM = name of uuencoded file attachmt
- ;
- ; Returns A1X = string with "begin..."_file name
- ;
- N A1X
- S A1X="begin 644 "_A1FILENM
- Q A1X
- ;
- ENCODE(A1STR,A1DTANOD,A1OTLK) ;Encode a string, keep remainder for next line
- ;INPUT:
- ; A1STR - String to send in msg; call by reference, Remainder returned in A1STR
- ; A1DTANOD - Number of next Node to store msg line in array
- ; A1OTLK - Array containing msg text for network addresses
- ;
- N A1QUIT,A1LEN,A1X
- S A1QUIT=0,A1LEN=$L(A1STR)
- F D Q:A1QUIT
- . I $L(A1STR)<45 S A1QUIT=1 Q
- . S A1X=$E(A1STR,1,45)
- . S A1DTANOD=A1DTANOD+1,@A1OTLK@(A1DTANOD)=$$UUEN(A1X)
- . S A1STR=$E(A1STR,46,A1LEN)
- Q
- ;
- UUEN(STR) ; Uuencode string passed in.
- ;Input
- ; STR - String to Encode
- ;
- ;Output
- ; TMP - Encoded string
- ;
- N J,K,LEN,A1I,A1X,S,TMP,X,Y
- S TMP="",LEN=$L(STR)
- F A1I=1:3:LEN D
- . S A1X=$E(STR,A1I,A1I+2)
- . I $L(A1X)<3 S A1X=A1X_$E(" ",1,3-$L(A1X))
- . S S=$A(A1X,1)*256+$A(A1X,2)*256+$A(A1X,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(A1CHAR) ; Display Hang Characters
- ;Input
- ; A1CHAR - Last "Hang Character" displayed
- NEW A1BS,A1D,A1S
- SET:'$D(A1CHAR) A1CHAR=0
- SET A1D="-"
- SET A1S="\"
- SET A1BS="/"
- NEW A1RESET,A1Y
- SET A1Y=$Y
- DO IOXY^XGF(IOSL-1,62) ;IA #3173 ;;TO DO: GTS - instead of IOSL, use current line #
- SET A1RESET=0
- SET:A1CHAR=0 A1CHAR=A1BS
- IF 'A1RESET,A1CHAR=A1D SET A1CHAR=A1S SET A1RESET=1
- IF 'A1RESET,A1CHAR=A1S SET A1CHAR=A1BS SET A1RESET=1
- IF 'A1RESET,A1CHAR=A1BS SET A1CHAR=A1D SET A1RESET=1
- WRITE A1CHAR
- IF 1 ;Needed for ^DIC screen calls
- Q
- ;
- EXTPKG(LISTTMP) ;loop through PACKAGE file & extract data
- ;
- K ^XTMP("A1SIZE",$J) S ^XTMP("A1SIZE",$J,0)=DT
- S VPIEN=0 F S VPIEN=$O(^DIC(9.4,VPIEN)) Q:'VPIEN S VPNAME=$P(^DIC(9.4,VPIEN,0),"^") D SETXTMP
- K VPNAME,VPN,VPLOW,VPHIGH,VPOTHER,VPNAT,VPRNGE
- Q
- ;
- SETXTMP ; set ^XTMP global with PACKAGE data
- ;
- ; Piece 1 = Namespace
- ; Piece 2 = Lower File Number Range
- ; Piece 3 = Highest File Number Range
- ; Piece 4 = Other Namepaces separated by "|"
- ;
- NEW VPPARPKG,PARNTNME
- SET VPNAT=$G(^DIC(9.4,VPIEN,7)),VPNAT=$P(VPNAT,"^",3),VPPARPKG=$P($GET(^DIC(9.4,VPIEN,15002)),"^",2),PARNTNME=""
- QUIT:VPNAT'="I"
- S VPN=$P(^DIC(9.4,VPIEN,0),"^",2)
- S (VPEXCPT,VPOTHER,VPRNGE)=""
- S VP11=$G(^DIC(9.4,VPIEN,11)),VPLOW=$P(VP11,"^"),VPHIGH=$P(VP11,"^",2)
- S VPIEN2=0 F S VPIEN2=$O(^DIC(9.4,VPIEN,14,VPIEN2)) Q:'VPIEN2 S VPOTHER=VPOTHER_^DIC(9.4,VPIEN,14,VPIEN2,0)_"|"
- S VPIEN2=0 F S VPIEN2=$O(^DIC(9.4,VPIEN,"EX",VPIEN2)) Q:'VPIEN2 S VPEXCPT=VPEXCPT_^DIC(9.4,VPIEN,"EX",VPIEN2,0)_"|"
- ;
- ;Get Ranges from multiple field 15001.1
- IF +$$FLDNUM^DILFD(9.4,"LOW-HIGH RANGE")=15001.1,$D(^DIC(9.4,VPIEN,15001)) DO
- .S VPRNGE=""
- .S VPIEN2=0
- .F S VPIEN2=$O(^DIC(9.4,VPIEN,15001.1,VPIEN2)) Q:'VPIEN2 DO
- ..S VPLNUM=$P($G(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^")
- ..S VPHNUM=$P($G(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^",2)
- ..S VPRNGE=VPRNGE_VPLNUM_"-"_VPHNUM_"|"
- ;
- ;Get file numbers from multiple field 15001
- IF +$$FLDNUM^DILFD(9.4,"FILE NUMBER")=15001,$D(^DIC(9.4,VPIEN,15001)) DO
- .S VPIEN2=0
- .FOR S VPIEN2=$O(^DIC(9.4,VPIEN,15001,VPIEN2)) Q:'VPIEN2 DO
- ..S (VPFNUM,VPLNUM,VPHNUM)=""
- ..S VPFNUM=^DIC(9.4,VPIEN,15001,VPIEN2,0)
- ..S:+VPFNUM>0 ^XTMP("A1SIZE",$J,VPNAME,VPFNUM)=""
- ;
- ;Get PARENT PACKAGE field (#15003)
- IF VPPARPKG]"" DO
- .SET PARNTNME=$P($G(^DIC(9.4,VPPARPKG,0)),"^")
- ;
- SET ^XTMP("A1SIZE",$J,VPNAME)=VPN_"^"_VPLOW_"^"_VPHIGH_"^"_VPOTHER_"^"_VPEXCPT_"^"_VPRNGE_"^"_PARNTNME
- QUIT
- ;
- ;
- 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"
- DO ^DIR
- QUIT
- ;
- FEXT(XTMPARY) ;Return Package File Multiple entries
- ; INPUT: XTMPARY - Package Extract Array [^XTMP("A1SER")]
- ; 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1VSLAPI 11269 printed Feb 18, 2025@23:05:01 Page 2
- A1VSLAPI ;Albany FO/GTS - VistA Package Sizing Manager; 27-JUN-2016
- +1 ;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
- +2 ; APIs
- +3 ;
- EMAILEXT ; Extract & E-Mail ^XTMP(""A1SIZE"","_$JOB_")
- +1 ; -- Option: A1VS EXT-EMAIL PKG DATA
- +2 ;
- +3 NEW EXTRSLT
- +4 SET EXTRSLT=$$PKGEXT^A1VSLNA1()
- +5 IF 'EXTRSLT
- IF $DATA(^XTMP("A1SIZE",$JOB))
- Begin DoDot:1
- +6 NEW A1INSTMM,A1TOMM,XMERR,XMZ,A1TYPE
- +7 ;
- +8 KILL XMERR
- +9 ;Do not Restrict addressing
- SET A1INSTMM("ADDR FLAGS")="R"
- +10 SET A1TYPE="S"
- +11 DO TOWHOM^XMXAPIU(DUZ,,A1TYPE,.A1INSTMM)
- +12 IF +$GET(XMERR)'>0
- Begin DoDot:2
- +13 NEW XMY,XMTEXT,XMDUZ,XMSUB,A1LPCNT,XDATE
- +14 SET A1LPCNT=""
- +15 FOR
- SET A1LPCNT=$ORDER(^TMP("XMY",$JOB,A1LPCNT))
- if A1LPCNT=""
- QUIT
- SET XMY(A1LPCNT)=""
- +16 SET XMDUZ=DUZ
- +17 SET XDATE=$PIECE(^XTMP("A1SIZE",$JOB,0),"^")
- +18 SET XDATE=$$FMTE^XLFDT(XDATE,"1P")
- +19 SET XMSUB="PACKAGE FILE EXTRACT ("_$PIECE(^XTMP("A1SIZE",$JOB,0),"^",2)_" ; "_XDATE_" ; $JOB#: "_$JOB_")"
- +20 SET XMTEXT="^XTMP(""A1SIZE"","_$JOB_","
- +21 DO ENT^XMPG
- +22 IF +XMZ>0
- DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_$JOB_") E-Mailed via PackMan. [MSG #:"_XMZ_"]")
- +23 IF +XMZ'>0
- DO JUSTPAWS^A1VSLAPI("Error: ^XTMP(""A1SIZE"","_$JOB_") not sent in Packman. ["_XMMG_"]")
- End DoDot:2
- +24 IF $PIECE(EXTRSLT,"^",2)'>0
- KILL ^TMP("XMY",$JOB),^XTMP("A1SIZE",$JOB)
- End DoDot:1
- +25 ;
- +26 IF EXTRSLT
- DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_$JOB_") global exists. Use Extract Manager to access it.")
- +27 QUIT
- +28 ;
- 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 A1VS EDITOR key
- +1 NEW A1VSSEC
- +2 DO OWNSKEY^XUSRB(.A1VSSEC,"A1VS EDITOR")
- +3 QUIT +$GET(A1VSSEC(0))
- +4 ;
- YNCHK(APROMPT) ; Yes/No Prompt
- +1 ;INPUT
- +2 ; APROMPT - Prompt to display before Y/N question
- +3 ;OUTPUT
- +4 ; value of Y returned from DIR Y/N prompt
- +5 ;
- +6 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
- +7 SET DIR("A")=APROMPT
- +8 SET DIR(0)="Y^A"
- +9 SET DIR("B")="NO"
- +10 DO ^DIR
- +11 QUIT Y
- +12 ;
- SELXTMP(BEGIN,END,A1OFFSET) ;Select XTMPSIZE.DAT file
- +1 ;
- +2 if '$DATA(A1OFFSET)
- SET A1OFFSET=0
- +3 DO FULL^VALM1
- +4 SET DIR("A",1)=""
- +5 SET DIR("A")="Select the XTMPSIZE*.DAT Package Parameter file item number"
- +6 SET DIR(0)="N:"_BEGIN_":"_END
- +7 DO ^DIR
- +8 IF ($DATA(DTOUT))!($DATA(DUOUT))
- QUIT -1
- +9 QUIT Y+A1OFFSET
- +10 ;
- 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("A1VS PKG MGR RPT",$JOB,LMTMPNDE))
- if +LMTMPNDE=0
- QUIT
- Begin DoDot:2
- +12 WRITE !,^TMP("A1VS PKG MGR RPT",$JOB,LMTMPNDE,0)
- End DoDot:2
- +13 DO CLOSE^%ZISH("DELIMFL1")
- End DoDot:1
- if POPERR
- QUIT
- +14 QUIT
- +15 ;
- SNDEXT(A1SVSUBJ,XQSND,A1EXTARY) ;Send VistA Size report
- +1 ; -- Protocol: A1VS PKG MGR RPT MAIL ACTION
- +2 ;
- +3 ;INPUT:
- +4 ; A1SVSUBJ - Subject of message generated
- +5 ; XQSND - User's DUZ, Group Name, or S.server name
- +6 ; A1EXTARY - Array containing msg text
- +7 ;
- +8 NEW A1INSTMM,A1INSTVA,A1TASKMM,A1TASKVA,A1TOMM,A1TOVA,XMERR,XMZ,A1LPCNT,A1TYPE
- +9 ;
- +10 DO FULL^VALM1
- +11 ;
- +12 ;Do not Restrict addressing
- SET A1INSTMM("ADDR FLAGS")="R"
- +13 SET A1TYPE="S"
- +14 KILL XMERR
- +15 DO TOWHOM^XMXAPIU(DUZ,,A1TYPE,.A1INSTMM)
- +16 ;
- +17 ;Check Network addresses and mail attachmt
- +18 ;Do not Restrict addressing
- SET A1INSTVA("ADDR FLAGS")="R"
- +19 SET A1INSTVA("FROM")="VISTA_PACKAGE_MANAGER_RPT"
- +20 SET A1SVSUBJ=$EXTRACT(A1SVSUBJ,1,65)
- +21 SET A1LPCNT=""
- +22 FOR
- SET A1LPCNT=$ORDER(^TMP("XMY",$JOB,A1LPCNT))
- if A1LPCNT=""
- QUIT
- SET A1TOVA(A1LPCNT)=""
- +23 ;
- +24 IF +$GET(XMERR)'>0
- Begin DoDot:1
- +25 WRITE !," [Creating attachments..."
- +26 DO OUTLKARY(A1EXTARY,"^TMP($J,""A1NETMSG"")",A1SVSUBJ,1)
- +27 DO SENDMSG^XMXAPI(XQSND,A1SVSUBJ,"^TMP($J,""A1NETMSG"")",.A1TOVA,.A1INSTVA,.A1TASKVA)
- End DoDot:1
- +28 ;
- +29 KILL ^TMP("XMY",$JOB),^TMP("XMY0",$JOB),^TMP($JOB,"A1NETMSG")
- +30 SET VALMBCK="R"
- +31 QUIT
- +32 ;
- OUTLKARY(A1PMARY,A1OTLK,A1SVSUBJ,A1RT) ;Create attachmts array
- +1 ;INPUT:
- +2 ; A1PMARY - Array containing raw message text
- +3 ; A1OTLK - Array containing message text for network addresses
- +4 ; A1SVSUBJ - Message subject
- +5 ; A1RT - Real Time processing from UI
- +6 ;
- +7 NEW A1FILNAM,A1DTTM,A1CRLF,A1STR,A1NODE,A1OUTNOD,A1NODATA,A1CHAR
- +8 if +$GET(A1RT)=0
- SET A1RT=0
- +9 if +$GET(A1RT)
- SET A1CHAR=0
- +10 SET A1STR=""
- +11 SET A1NODATA=0
- +12 SET A1CRLF=$CHAR(13,10)
- +13 SET A1DTTM=$$NOW^XLFDT
- +14 KILL @A1OTLK
- +15 SET @A1OTLK@(1)="Attachment Generated......: "_$$FMTE^XLFDT(A1DTTM)_A1CRLF
- +16 SET @A1OTLK@(2)=" "
- +17 SET @A1OTLK@(3)="Extract Requested......: "_A1SVSUBJ_A1CRLF
- +18 SET @A1OTLK@(4)=" "
- +19 ;
- +20 SET A1FILNAM="VistAPkgSize_"_$PIECE(A1DTTM,".",1)_"_"_$PIECE(A1DTTM,".",2)_".txt"
- +21 SET @A1OTLK@(5)="Attached VistA Size Report file.....: "_A1FILNAM_A1CRLF
- +22 if ($ORDER(@A1PMARY@(0))="")
- SET A1NODATA=1
- +23 SET @A1OTLK@(6)=" "
- +24 if (A1NODATA=0)
- SET @A1OTLK@(7)=" "
- +25 if (A1NODATA=1)
- SET @A1OTLK@(7)="No report!!"
- +26 ;
- +27 ;Begin file output
- +28 SET @A1OTLK@(8)=$$UUBEGFN(A1FILNAM)
- +29 SET A1NODE=0
- +30 SET A1OUTNOD=8
- +31 FOR
- SET A1NODE=$ORDER(@A1PMARY@(A1NODE))
- if (A1NODE="")
- QUIT
- if ($PIECE($GET(@A1PMARY@(A1NODE)),"^",1)="CURRENT")
- QUIT
- Begin DoDot:1
- +32 ; Display progress character
- IF +$GET(A1RT)
- if A1NODE#100=0
- DO HANGCHAR(.A1CHAR)
- +33 SET A1STR=A1STR_@A1PMARY@(A1NODE,0)_A1CRLF
- +34 DO ENCODE(.A1STR,.A1OUTNOD,A1OTLK)
- End DoDot:1
- +35 ;
- +36 FOR
- if $LENGTH(A1STR<45)
- QUIT
- DO ENCODE(.A1STR,.A1OUTNOD,A1OTLK)
- +37 if (A1STR'="")
- SET @A1OTLK@(A1OUTNOD+1)=$$UUEN(A1STR)
- +38 SET @A1OTLK@(A1OUTNOD+2)=" "
- +39 SET @A1OTLK@(A1OUTNOD+3)="end"
- +40 ;
- +41 SET VALMBCK="R"
- +42 QUIT
- +43 ;
- UUBEGFN(A1FILENM) ; Construct uuencode "begin" coding
- +1 ; Call with A1FILENM = name of uuencoded file attachmt
- +2 ;
- +3 ; Returns A1X = string with "begin..."_file name
- +4 ;
- +5 NEW A1X
- +6 SET A1X="begin 644 "_A1FILENM
- +7 QUIT A1X
- +8 ;
- ENCODE(A1STR,A1DTANOD,A1OTLK) ;Encode a string, keep remainder for next line
- +1 ;INPUT:
- +2 ; A1STR - String to send in msg; call by reference, Remainder returned in A1STR
- +3 ; A1DTANOD - Number of next Node to store msg line in array
- +4 ; A1OTLK - Array containing msg text for network addresses
- +5 ;
- +6 NEW A1QUIT,A1LEN,A1X
- +7 SET A1QUIT=0
- SET A1LEN=$LENGTH(A1STR)
- +8 FOR
- Begin DoDot:1
- +9 IF $LENGTH(A1STR)<45
- SET A1QUIT=1
- QUIT
- +10 SET A1X=$EXTRACT(A1STR,1,45)
- +11 SET A1DTANOD=A1DTANOD+1
- SET @A1OTLK@(A1DTANOD)=$$UUEN(A1X)
- +12 SET A1STR=$EXTRACT(A1STR,46,A1LEN)
- End DoDot:1
- if A1QUIT
- 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,A1I,A1X,S,TMP,X,Y
- +8 SET TMP=""
- SET LEN=$LENGTH(STR)
- +9 FOR A1I=1:3:LEN
- Begin DoDot:1
- +10 SET A1X=$EXTRACT(STR,A1I,A1I+2)
- +11 IF $LENGTH(A1X)<3
- SET A1X=A1X_$EXTRACT(" ",1,3-$LENGTH(A1X))
- +12 SET S=$ASCII(A1X,1)*256+$ASCII(A1X,2)*256+$ASCII(A1X,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 ;
- +20 ;
- HANGCHAR(A1CHAR) ; Display Hang Characters
- +1 ;Input
- +2 ; A1CHAR - Last "Hang Character" displayed
- +3 NEW A1BS,A1D,A1S
- +4 if '$DATA(A1CHAR)
- SET A1CHAR=0
- +5 SET A1D="-"
- +6 SET A1S="\"
- +7 SET A1BS="/"
- +8 NEW A1RESET,A1Y
- +9 SET A1Y=$Y
- +10 ;IA #3173 ;;TO DO: GTS - instead of IOSL, use current line #
- DO IOXY^XGF(IOSL-1,62)
- +11 SET A1RESET=0
- +12 if A1CHAR=0
- SET A1CHAR=A1BS
- +13 IF 'A1RESET
- IF A1CHAR=A1D
- SET A1CHAR=A1S
- SET A1RESET=1
- +14 IF 'A1RESET
- IF A1CHAR=A1S
- SET A1CHAR=A1BS
- SET A1RESET=1
- +15 IF 'A1RESET
- IF A1CHAR=A1BS
- SET A1CHAR=A1D
- SET A1RESET=1
- +16 WRITE A1CHAR
- +17 ;Needed for ^DIC screen calls
- IF 1
- +18 QUIT
- +19 ;
- EXTPKG(LISTTMP) ;loop through PACKAGE file & extract data
- +1 ;
- +2 KILL ^XTMP("A1SIZE",$JOB)
- SET ^XTMP("A1SIZE",$JOB,0)=DT
- +3 SET VPIEN=0
- FOR
- SET VPIEN=$ORDER(^DIC(9.4,VPIEN))
- if 'VPIEN
- QUIT
- SET VPNAME=$PIECE(^DIC(9.4,VPIEN,0),"^")
- DO SETXTMP
- +4 KILL VPNAME,VPN,VPLOW,VPHIGH,VPOTHER,VPNAT,VPRNGE
- +5 QUIT
- +6 ;
- SETXTMP ; set ^XTMP global with PACKAGE data
- +1 ;
- +2 ; Piece 1 = Namespace
- +3 ; Piece 2 = Lower File Number Range
- +4 ; Piece 3 = Highest File Number Range
- +5 ; Piece 4 = Other Namepaces separated by "|"
- +6 ;
- +7 NEW VPPARPKG,PARNTNME
- +8 SET VPNAT=$GET(^DIC(9.4,VPIEN,7))
- SET VPNAT=$PIECE(VPNAT,"^",3)
- SET VPPARPKG=$PIECE($GET(^DIC(9.4,VPIEN,15002)),"^",2)
- SET PARNTNME=""
- +9 if VPNAT'="I"
- QUIT
- +10 SET VPN=$PIECE(^DIC(9.4,VPIEN,0),"^",2)
- +11 SET (VPEXCPT,VPOTHER,VPRNGE)=""
- +12 SET VP11=$GET(^DIC(9.4,VPIEN,11))
- SET VPLOW=$PIECE(VP11,"^")
- SET VPHIGH=$PIECE(VP11,"^",2)
- +13 SET VPIEN2=0
- FOR
- SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,14,VPIEN2))
- if 'VPIEN2
- QUIT
- SET VPOTHER=VPOTHER_^DIC(9.4,VPIEN,14,VPIEN2,0)_"|"
- +14 SET VPIEN2=0
- FOR
- SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,"EX",VPIEN2))
- if 'VPIEN2
- QUIT
- SET VPEXCPT=VPEXCPT_^DIC(9.4,VPIEN,"EX",VPIEN2,0)_"|"
- +15 ;
- +16 ;Get Ranges from multiple field 15001.1
- +17 IF +$$FLDNUM^DILFD(9.4,"LOW-HIGH RANGE")=15001.1
- IF $DATA(^DIC(9.4,VPIEN,15001))
- Begin DoDot:1
- +18 SET VPRNGE=""
- +19 SET VPIEN2=0
- +20 FOR
- SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,15001.1,VPIEN2))
- if 'VPIEN2
- QUIT
- Begin DoDot:2
- +21 SET VPLNUM=$PIECE($GET(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^")
- +22 SET VPHNUM=$PIECE($GET(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^",2)
- +23 SET VPRNGE=VPRNGE_VPLNUM_"-"_VPHNUM_"|"
- End DoDot:2
- End DoDot:1
- +24 ;
- +25 ;Get file numbers from multiple field 15001
- +26 IF +$$FLDNUM^DILFD(9.4,"FILE NUMBER")=15001
- IF $DATA(^DIC(9.4,VPIEN,15001))
- Begin DoDot:1
- +27 SET VPIEN2=0
- +28 FOR
- SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,15001,VPIEN2))
- if 'VPIEN2
- QUIT
- Begin DoDot:2
- +29 SET (VPFNUM,VPLNUM,VPHNUM)=""
- +30 SET VPFNUM=^DIC(9.4,VPIEN,15001,VPIEN2,0)
- +31 if +VPFNUM>0
- SET ^XTMP("A1SIZE",$JOB,VPNAME,VPFNUM)=""
- End DoDot:2
- End DoDot:1
- +32 ;
- +33 ;Get PARENT PACKAGE field (#15003)
- +34 IF VPPARPKG]""
- Begin DoDot:1
- +35 SET PARNTNME=$PIECE($GET(^DIC(9.4,VPPARPKG,0)),"^")
- End DoDot:1
- +36 ;
- +37 SET ^XTMP("A1SIZE",$JOB,VPNAME)=VPN_"^"_VPLOW_"^"_VPHIGH_"^"_VPOTHER_"^"_VPEXCPT_"^"_VPRNGE_"^"_PARNTNME
- +38 QUIT
- +39 ;
- +40 ;
- 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 DO ^DIR
- +10 QUIT
- +11 ;
- FEXT(XTMPARY) ;Return Package File Multiple entries
- +1 ; INPUT: XTMPARY - Package Extract Array [^XTMP("A1SER")]
- +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