XU8PE655 ;ISD/HGW Patch XU*8*655 Environment Check Routine ;03/26/15 12:04
;;8.0;KERNEL;**655**;Jul 10, 1995;Build 16
;Per VA Directive 6402, this routine should not be modified.
;
ENV ; Environment Check
;
; General
;
N XUXPTYPE,XUXLREV,XUXREQP,XUXBUILD,XUXIGHF,XUXFY,XUXQTR,XUXG,XUXB,XUXE,XUXR,XUXSTR,XUXOK
D IMP
K XPDDIQ("XPZ1","B"),XPDDIQ("XPI1","B") S XPDDIQ("XPZ1","B")="NO",XPDDIQ("XPI1","B")="NO"
S XUXSTR=$G(XUXPTYPE)
D BM(XUXSTR),M("")
S U="^"
; No user
D:+($$UR)'>0 ET("User not defined (DUZ)")
; No IO
D:+($$SY)'>0 ET("Undefined IO variable(s)")
I $D(XUXE) D ABRT Q
;
; Load Distribution
;
; XPDENV = 0 Environment Check during Load
;
N XUXOK,XUXG,XUXR,XUXB
; Check Required Patches
D:$O(XUXREQP(0))'>0 IMP I $O(XUXREQP(0))>0 D
. W ! N XUXPAT,XUXI,XUXPN,XUXP,XUXR,XUXC,XUXO,XUXC1,XUXC2,XUXC3,XUXC4,XUX
. S (XUXR,XUXC)=0 S XUXC1=3,XUXC2=23,XUXC3=35,XUXC4=47
. S XUXI=0 F S XUXI=$O(XUXREQP(XUXI)) Q:+XUXI'>0 D
. . S XUXC=XUXC+1,XUXPAT=$G(XUXREQP(XUXI))
. S XUXI=0 F S XUXI=$O(XUXREQP(XUXI)) Q:+XUXI'>0 D
. . N XUXPAT,XUXREL,XUXINS,XUXCOM,XUXINE,XUXREQ,XUXTX S XUXREQ=$G(XUXREQP(XUXI))
. . S XUXPAT=$P(XUXREQ,"^",1),XUXREL=$P(XUXREQ,"^",2),XUXCOM=$P(XUXREQ,"^",3)
. . S XUXPN=$$INS(XUXPAT) S XUXINS=$$INSD(XUXPAT),XUXINE=$P(XUXINS,"^",2)
. . I XUXI=1 D
. . . W !,?XUXC1,"Checking for ",!
. . . W !,?XUXC1,"Patch",?XUXC2,"Released",?XUXC3,"Installed",?XUXC4,"Content"
. . S XUXTX=$J(" ",XUXC1)_XUXPAT
. . S XUXTX=XUXTX_$J(" ",(XUXC2-$L(XUXTX)))
. . S:XUXREL?7N XUXTX=XUXTX_$P($$FMTE^XLFDT(XUXREL,"5DZ"),"@",1)
. . S XUXTX=XUXTX_$J(" ",(XUXC3-$L(XUXTX)))
. . I +XUXPN>0 D
. . . H 1 S XUXO=+($G(XUXO))+1 S:$L($G(XUXINE)) XUXTX=XUXTX_XUXINE
. . . S XUXTX=XUXTX_$J(" ",(XUXC4-$L(XUXTX)))
. . . S:$L(XUXCOM) XUXTX=XUXTX_XUXCOM
. . D M(XUXTX)
. . I +XUXPN'>0 D ET((" "_XUXPAT_" not found, please install "_XUXPAT_" before continuing"))
. W:+($G(XUXO))'=XUXC !
I $D(XUXE) D M(),ABRT Q
;
I '$$PROD^XUPROD D QUIT Q ;Quit if test account, no need to load global
;
S XUXG=$$RGBL
I $D(XUXE)&(+XUXG=0) D ABRT Q
I $D(XUXE)&(+XUXG<0) D ABRT Q
I '$D(XUXFULL)&(+($G(XPDENV))'=1) D QUIT Q
;
; Quit, Exit or Abort
;
QUIT ; Quit Passed Environment Check
K XUXFULL D OK
I $G(XPDENV)=1 S XPDDIQ("XPZ1")=0 ;Do not disable options/protocols
Q
EXIT ; Exit Failed Environment Check
D:$D(XUXE) ED S XPDQUIT=2 K XUXE,XUXFULL Q
ABRT ; Abort Failed Environment Check, KILL the distribution
D:$D(XUXE) ED S XPDABORT=1,XPDQUIT=1 S:$L($G(XUXBUILD)) XPDQUIT(XUXBUILD)=1
K XUXE,XUXFULL
Q
T1 ; Environment Check #1 (for testing only)
K XPDENV D ENV
Q
T2 ; Environment Check #2 (for testing only)
N XPDENV S XPDENV=1 D ENV
Q
;
; Checks
;
RGBL(X) ; Check for required globals
N XUXCPD,XUXS,XUXI,XUXX,XUXEC,XUXGBL,XUXRT,XUXT,XUXF,XUXB1,XUXB2
S XUXCPD=$$CPD,XUXS="",X=1 F XUXI=1:1 D Q:'$L(XUXX)
. S XUXX="" S XUXEC="S XUXX=$T(GD+"_XUXI_")" X XUXEC S XUXX=$$TRIM(XUXX) Q:'$L(XUXX) Q:'$L($TR(XUXX,";",""))
. S XUXGBL=$P(XUXX,";",3) Q:+XUXCPD>0&(XUXGBL="^XUXM(0)") S XUXRT=$P(XUXX,";",4),XUXT=$P(XUXX,";",5),XUXF=$P(XUXX,";",6)
. S (XUXB1,XUXB2)="",$P(XUXB1," ",(15-$L(XUXRT)))="",$P(XUXB2," ",(28-$L(XUXT)))=""
. I '$D(@XUXGBL) S:XUXS'[XUXRT XUXS=XUXS_", "_XUXRT S X=-1 S:XUXGBL["XUXM("&(X=1) X=0
I $L(XUXS),X'>0 D
. S:XUXS[", " XUXS=$P(XUXS,", ",1,($L(XUXS,", ")-1))_" and "_$P(XUXS,", ",$L(XUXS,", "))
. S:$E(XUXS,1,2)=", " XUXS=$E(XUXS,3,$L(XUXS)) S:$E(XUXS,1,7)[" and " XUXS=$P(XUXS," and ",2)
. D:X=-1 ET(("Global"_$S(XUXS[", "!(XUXS[" and "):"s",1:"")_" "_XUXS_" either not found or incomplete."))
. D:X=0 CM
Q X
INS(X) ; Installed
N XUX,XUXP,XUXV,XUXI,XUXS S XUX=$P($G(X)," ",1) I $L(XUX,"*")=3 S X=$$PATCH^XPDUTL(XUX) Q X
S XUXP=$$PKG^XPDUTL(XUX),XUXV=$$VER^XPDUTL(XUX),XUXI=$$VERSION^XPDUTL(XUXP)
Q:+XUXV>0&(XUXV=XUXI) 1
Q 0
INSD(X) ; Installed on
N DA,XUX,XUXDA,XUXE,XUXI,XUXMSG,XUXNS,XUXOUT,XUXPI,XUXPN,XUXSCR,XUXVI,XUXVD,XUXVI,XUXVR S XUX=$G(X)
S XUXNS=$$PKG^XPDUTL(XUX),XUXVR=$$VER^XPDUTL(XUX),XUXPN=$P(X,"*",3)
Q:'$L(XUXNS) "" S XUXVR=+XUXVR Q:XUXVR'>0 "" S XUXPN=+XUXPN S:XUXVR'["." XUXVR=XUXVR_".0"
S XUXSCR="I $G(^DIC(9.4,+($G(Y)),""VERSION""))="""_XUXVR_""""
D FIND^DIC(9.4,,.01,"O",XUXNS,10,"C",XUXSCR,,"XUXOUT","XUXMSG")
S XUXPI=$G(XUXOUT("DILIST",2,1)) K XUXOUT,XUXMSG Q:+XUXPI'>0 "" Q:'$D(@("^DIC(9.4,"_XUXPI_",22)")) ""
K DA S DA(1)=XUXPI S XUXDA=$$IENS^DILF(.DA)
D FIND^DIC(9.49,XUXDA,".01;1I;2I","O",XUXVR,10,"B",,,"XUXOUT","XUXMSG")
S XUXVD=$G(XUXOUT("DILIST","ID",1,2)) I $E(XUXVD,1,7)?7N&(+XUXPN'>0) D Q X
. S X=$E(XUXVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(XUXVD,1,7),"5DZ"),"@"," ")
S:$E(XUXVD,1,7)'?7N XUXVD=$G(XUXOUT("DILIST","ID",1,1)) I $E(XUXVD,1,7)?7N&(+XUXPN'>0) D Q X
. S X=$E(XUXVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(XUXVD,1,7),"5DZ"),"@"," ")
Q:+XUXPN'>0 "" S XUXVI=$G(XUXOUT("DILIST",2,1)) K XUXOUT,XUXMSG
Q:+XUXVI'>0 "" Q:'$D(@("^DIC(9.4,"_XUXPI_",22,"_XUXVI_",""PAH"")")) ""
K DA S DA(2)=XUXPI,DA(1)=XUXVI S XUXDA=$$IENS^DILF(.DA)
S XUXSCR="I $G(^DIC(9.4,"_XUXPI_",22,"_XUXVI_",""PAH"",+($G(Y)),0))[""SEQ #"""
D FIND^DIC(9.4901,XUXDA,".01;.02I",,XUXPN,10,"B",XUXSCR,,"XUXOUT","XUXMSG")
S XUXI=$G(XUXOUT("DILIST","ID",1,.02)) I '$L(XUXI) D
. S XUXSCR="" D FIND^DIC(9.4901,XUXDA,".01;.02I",,XUXPN,10,"B",XUXSCR,,"XUXOUT","XUXMSG")
. S XUXI=$G(XUXOUT("DILIST","ID",1,.02))
Q:'$L(XUXI) "" Q:$P(XUXI,".",1)'?7N "" S XUXE=$TR($$FMTE^XLFDT(XUXI,"5DZ"),"@"," ")
Q:'$L(XUXE) "" S X=XUXI_"^"_XUXE
Q X
SY(X) ; Check System variables
Q:'$D(IO)!('$D(IOF))!('$D(IOM))!('$D(ION))!('$D(IOSL))!('$D(IOST)) 0
Q 1
UR(X) ; Check User variables
Q:'$L($G(DUZ(0))) 0
Q:+($G(DUZ))=0!($$NOTDEF(+$G(DUZ))) 0
Q 1
CPD(X) ; Check Current Patched Data is installed
N INS S INS=1
Q 0
;
; Error messages
;
CM ; Missing ^XU8P655
N XUXPTYPE,XUXLREV,XUXREQP,XUXBUILD,XUXIGHF,XUXFY,XUXQTR D IMP D ET(""),ET("Missing import global ^XU8P655.") D CO
Q
CO ; Obtain new global
N XUXPTYPE,XUXLREV,XUXREQP,XUXBUILD,XUXIGHF,XUXFY,XUXQTR D IMP
D ET(""),ET(" Please obtain a copy of the import global ^XU8P655 contained in the ")
D ET((" global host file "_XUXIGHF_" before continuing with the "_XUXBUILD))
D ET((" installation."))
Q
ET(X) ; Error Text
N XUXI S XUXI=+($G(XUXE(0))),XUXI=XUXI+1,XUXE(XUXI)=" "_$G(X),XUXE(0)=XUXI
Q
ED ; Error Display
N XUXI S XUXI=0 F S XUXI=$O(XUXE(XUXI)) Q:+XUXI=0 D M(XUXE(XUXI))
D M(" ") K XUXE Q
;
; Miscellaneous
;
NOTDEF(IEN) ; Check to see if user is defined
N DA,DR,DIQ,XUX,DIC S DA=IEN,DR=.01,DIC=200,DIQ="XUX" D EN^DIQ1 Q '$D(XUX)
OK ; Environment is OK
N XUXPTYPE,XUXLREV,XUXREQP,XUXBUILD,XUXIGHF,XUXFY,XUXQTR,XUXT
D IMP S XUXT=" Environment "_$S($L(XUXBUILD):("for patch/build "_XUXBUILD_" "),1:"")_"is ok"
D BM(XUXT),M(" ")
Q
BM(X) ; Blank Line with Message
S X=$G(X) S:$E(X,1)'=" " X=" "_X D BMES^XPDUTL(X) Q
M(X) ; Message
S X=$G(X) S:$E(X,1)'=" " X=" "_X D MES^XPDUTL(X) Q
TRIM(X) ; Trim Spaces
S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
Q X
IMP ; Import names
;ZEXCEPT: XUXBUILD,XUXIGHF,XUXLREV,XUXPTYPE,XUXREQP ;global variables within this routine
S XUXPTYPE="VistA Kernel Patch XU*8.0*655"
; Revision
S XUXLREV=655
; Required Builds Array
; XUX(1)=build SEQ #^released date^subject
; XUX(n)=build SEQ #^released date^subject
S XUXREQP(1)="XU*8.0*240 SEQ #237^3030313^STDNAME~XLFNAME: CHECK FOR SUFFIX"
S XUXREQP(2)="XU*8.0*325 SEQ #337^3060526^XUPS PERSON QUERY"
S XUXREQP(3)="XU*8.0*514 SEQ #428^3100113^MISC KERNEL FIXES"
S XUXREQP(4)="XU*8.0*523 SEQ #433^3100428^BSE FOR IMAGING"
; This Build Name
S XUXBUILD="XU*8.0*655"
; This Build's Export Global Host Filename
S XUXIGHF="XU_8_655.GBL"
Q
EF ; Exported Files
;;^XU8P655("VACAA");^XU8P655("VACAA");Kernel;200
Q
GD ; Global Data
;;^XU8P655("VACAA");^XU8P655("VACAA");Kernel;200
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXU8PE655 8080 printed Oct 16, 2024@18:09:38 Page 2
XU8PE655 ;ISD/HGW Patch XU*8*655 Environment Check Routine ;03/26/15 12:04
+1 ;;8.0;KERNEL;**655**;Jul 10, 1995;Build 16
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
ENV ; Environment Check
+1 ;
+2 ; General
+3 ;
+4 NEW XUXPTYPE,XUXLREV,XUXREQP,XUXBUILD,XUXIGHF,XUXFY,XUXQTR,XUXG,XUXB,XUXE,XUXR,XUXSTR,XUXOK
+5 DO IMP
+6 KILL XPDDIQ("XPZ1","B"),XPDDIQ("XPI1","B")
SET XPDDIQ("XPZ1","B")="NO"
SET XPDDIQ("XPI1","B")="NO"
+7 SET XUXSTR=$GET(XUXPTYPE)
+8 DO BM(XUXSTR)
DO M("")
+9 SET U="^"
+10 ; No user
+11 if +($$UR)'>0
DO ET("User not defined (DUZ)")
+12 ; No IO
+13 if +($$SY)'>0
DO ET("Undefined IO variable(s)")
+14 IF $DATA(XUXE)
DO ABRT
QUIT
+15 ;
+16 ; Load Distribution
+17 ;
+18 ; XPDENV = 0 Environment Check during Load
+19 ;
+20 NEW XUXOK,XUXG,XUXR,XUXB
+21 ; Check Required Patches
+22 if $ORDER(XUXREQP(0))'>0
DO IMP
IF $ORDER(XUXREQP(0))>0
Begin DoDot:1
+23 WRITE !
NEW XUXPAT,XUXI,XUXPN,XUXP,XUXR,XUXC,XUXO,XUXC1,XUXC2,XUXC3,XUXC4,XUX
+24 SET (XUXR,XUXC)=0
SET XUXC1=3
SET XUXC2=23
SET XUXC3=35
SET XUXC4=47
+25 SET XUXI=0
FOR
SET XUXI=$ORDER(XUXREQP(XUXI))
if +XUXI'>0
QUIT
Begin DoDot:2
+26 SET XUXC=XUXC+1
SET XUXPAT=$GET(XUXREQP(XUXI))
End DoDot:2
+27 SET XUXI=0
FOR
SET XUXI=$ORDER(XUXREQP(XUXI))
if +XUXI'>0
QUIT
Begin DoDot:2
+28 NEW XUXPAT,XUXREL,XUXINS,XUXCOM,XUXINE,XUXREQ,XUXTX
SET XUXREQ=$GET(XUXREQP(XUXI))
+29 SET XUXPAT=$PIECE(XUXREQ,"^",1)
SET XUXREL=$PIECE(XUXREQ,"^",2)
SET XUXCOM=$PIECE(XUXREQ,"^",3)
+30 SET XUXPN=$$INS(XUXPAT)
SET XUXINS=$$INSD(XUXPAT)
SET XUXINE=$PIECE(XUXINS,"^",2)
+31 IF XUXI=1
Begin DoDot:3
+32 WRITE !,?XUXC1,"Checking for ",!
+33 WRITE !,?XUXC1,"Patch",?XUXC2,"Released",?XUXC3,"Installed",?XUXC4,"Content"
End DoDot:3
+34 SET XUXTX=$JUSTIFY(" ",XUXC1)_XUXPAT
+35 SET XUXTX=XUXTX_$JUSTIFY(" ",(XUXC2-$LENGTH(XUXTX)))
+36 if XUXREL?7N
SET XUXTX=XUXTX_$PIECE($$FMTE^XLFDT(XUXREL,"5DZ"),"@",1)
+37 SET XUXTX=XUXTX_$JUSTIFY(" ",(XUXC3-$LENGTH(XUXTX)))
+38 IF +XUXPN>0
Begin DoDot:3
+39 HANG 1
SET XUXO=+($GET(XUXO))+1
if $LENGTH($GET(XUXINE))
SET XUXTX=XUXTX_XUXINE
+40 SET XUXTX=XUXTX_$JUSTIFY(" ",(XUXC4-$LENGTH(XUXTX)))
+41 if $LENGTH(XUXCOM)
SET XUXTX=XUXTX_XUXCOM
End DoDot:3
+42 DO M(XUXTX)
+43 IF +XUXPN'>0
DO ET((" "_XUXPAT_" not found, please install "_XUXPAT_" before continuing"))
End DoDot:2
+44 if +($GET(XUXO))'=XUXC
WRITE !
End DoDot:1
+45 IF $DATA(XUXE)
DO M()
DO ABRT
QUIT
+46 ;
+47 ;Quit if test account, no need to load global
IF '$$PROD^XUPROD
DO QUIT
QUIT
+48 ;
+49 SET XUXG=$$RGBL
+50 IF $DATA(XUXE)&(+XUXG=0)
DO ABRT
QUIT
+51 IF $DATA(XUXE)&(+XUXG<0)
DO ABRT
QUIT
+52 IF '$DATA(XUXFULL)&(+($GET(XPDENV))'=1)
DO QUIT
QUIT
+53 ;
+54 ; Quit, Exit or Abort
+55 ;
QUIT ; Quit Passed Environment Check
+1 KILL XUXFULL
DO OK
+2 ;Do not disable options/protocols
IF $GET(XPDENV)=1
SET XPDDIQ("XPZ1")=0
+3 QUIT
EXIT ; Exit Failed Environment Check
+1 if $DATA(XUXE)
DO ED
SET XPDQUIT=2
KILL XUXE,XUXFULL
QUIT
ABRT ; Abort Failed Environment Check, KILL the distribution
+1 if $DATA(XUXE)
DO ED
SET XPDABORT=1
SET XPDQUIT=1
if $LENGTH($GET(XUXBUILD))
SET XPDQUIT(XUXBUILD)=1
+2 KILL XUXE,XUXFULL
+3 QUIT
T1 ; Environment Check #1 (for testing only)
+1 KILL XPDENV
DO ENV
+2 QUIT
T2 ; Environment Check #2 (for testing only)
+1 NEW XPDENV
SET XPDENV=1
DO ENV
+2 QUIT
+3 ;
+4 ; Checks
+5 ;
RGBL(X) ; Check for required globals
+1 NEW XUXCPD,XUXS,XUXI,XUXX,XUXEC,XUXGBL,XUXRT,XUXT,XUXF,XUXB1,XUXB2
+2 SET XUXCPD=$$CPD
SET XUXS=""
SET X=1
FOR XUXI=1:1
Begin DoDot:1
+3 SET XUXX=""
SET XUXEC="S XUXX=$T(GD+"_XUXI_")"
XECUTE XUXEC
SET XUXX=$$TRIM(XUXX)
if '$LENGTH(XUXX)
QUIT
if '$LENGTH($TRANSLATE(XUXX,";",""))
QUIT
+4 SET XUXGBL=$PIECE(XUXX,";",3)
if +XUXCPD>0&(XUXGBL="^XUXM(0)")
QUIT
SET XUXRT=$PIECE(XUXX,";",4)
SET XUXT=$PIECE(XUXX,";",5)
SET XUXF=$PIECE(XUXX,";",6)
+5 SET (XUXB1,XUXB2)=""
SET $PIECE(XUXB1," ",(15-$LENGTH(XUXRT)))=""
SET $PIECE(XUXB2," ",(28-$LENGTH(XUXT)))=""
+6 IF '$DATA(@XUXGBL)
if XUXS'[XUXRT
SET XUXS=XUXS_", "_XUXRT
SET X=-1
if XUXGBL["XUXM("&(X=1)
SET X=0
End DoDot:1
if '$LENGTH(XUXX)
QUIT
+7 IF $LENGTH(XUXS)
IF X'>0
Begin DoDot:1
+8 if XUXS[", "
SET XUXS=$PIECE(XUXS,", ",1,($LENGTH(XUXS,", ")-1))_" and "_$PIECE(XUXS,", ",$LENGTH(XUXS,", "))
+9 if $EXTRACT(XUXS,1,2)=", "
SET XUXS=$EXTRACT(XUXS,3,$LENGTH(XUXS))
if $EXTRACT(XUXS,1,7)[" and "
SET XUXS=$PIECE(XUXS," and ",2)
+10 if X=-1
DO ET(("Global"_$SELECT(XUXS[", "!(XUXS[" and "):"s",1:"")_" "_XUXS_" either not found or incomplete."))
+11 if X=0
DO CM
End DoDot:1
+12 QUIT X
INS(X) ; Installed
+1 NEW XUX,XUXP,XUXV,XUXI,XUXS
SET XUX=$PIECE($GET(X)," ",1)
IF $LENGTH(XUX,"*")=3
SET X=$$PATCH^XPDUTL(XUX)
QUIT X
+2 SET XUXP=$$PKG^XPDUTL(XUX)
SET XUXV=$$VER^XPDUTL(XUX)
SET XUXI=$$VERSION^XPDUTL(XUXP)
+3 if +XUXV>0&(XUXV=XUXI)
QUIT 1
+4 QUIT 0
INSD(X) ; Installed on
+1 NEW DA,XUX,XUXDA,XUXE,XUXI,XUXMSG,XUXNS,XUXOUT,XUXPI,XUXPN,XUXSCR,XUXVI,XUXVD,XUXVI,XUXVR
SET XUX=$GET(X)
+2 SET XUXNS=$$PKG^XPDUTL(XUX)
SET XUXVR=$$VER^XPDUTL(XUX)
SET XUXPN=$PIECE(X,"*",3)
+3 if '$LENGTH(XUXNS)
QUIT ""
SET XUXVR=+XUXVR
if XUXVR'>0
QUIT ""
SET XUXPN=+XUXPN
if XUXVR'["."
SET XUXVR=XUXVR_".0"
+4 SET XUXSCR="I $G(^DIC(9.4,+($G(Y)),""VERSION""))="""_XUXVR_""""
+5 DO FIND^DIC(9.4,,.01,"O",XUXNS,10,"C",XUXSCR,,"XUXOUT","XUXMSG")
+6 SET XUXPI=$GET(XUXOUT("DILIST",2,1))
KILL XUXOUT,XUXMSG
if +XUXPI'>0
QUIT ""
if '$DATA(@("^DIC(9.4,"_XUXPI_",22)"))
QUIT ""
+7 KILL DA
SET DA(1)=XUXPI
SET XUXDA=$$IENS^DILF(.DA)
+8 DO FIND^DIC(9.49,XUXDA,".01;1I;2I","O",XUXVR,10,"B",,,"XUXOUT","XUXMSG")
+9 SET XUXVD=$GET(XUXOUT("DILIST","ID",1,2))
IF $EXTRACT(XUXVD,1,7)?7N&(+XUXPN'>0)
Begin DoDot:1
+10 SET X=$EXTRACT(XUXVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(XUXVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+11 if $EXTRACT(XUXVD,1,7)'?7N
SET XUXVD=$GET(XUXOUT("DILIST","ID",1,1))
IF $EXTRACT(XUXVD,1,7)?7N&(+XUXPN'>0)
Begin DoDot:1
+12 SET X=$EXTRACT(XUXVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(XUXVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+13 if +XUXPN'>0
QUIT ""
SET XUXVI=$GET(XUXOUT("DILIST",2,1))
KILL XUXOUT,XUXMSG
+14 if +XUXVI'>0
QUIT ""
if '$DATA(@("^DIC(9.4,"_XUXPI_",22,"_XUXVI_",""PAH"")"))
QUIT ""
+15 KILL DA
SET DA(2)=XUXPI
SET DA(1)=XUXVI
SET XUXDA=$$IENS^DILF(.DA)
+16 SET XUXSCR="I $G(^DIC(9.4,"_XUXPI_",22,"_XUXVI_",""PAH"",+($G(Y)),0))[""SEQ #"""
+17 DO FIND^DIC(9.4901,XUXDA,".01;.02I",,XUXPN,10,"B",XUXSCR,,"XUXOUT","XUXMSG")
+18 SET XUXI=$GET(XUXOUT("DILIST","ID",1,.02))
IF '$LENGTH(XUXI)
Begin DoDot:1
+19 SET XUXSCR=""
DO FIND^DIC(9.4901,XUXDA,".01;.02I",,XUXPN,10,"B",XUXSCR,,"XUXOUT","XUXMSG")
+20 SET XUXI=$GET(XUXOUT("DILIST","ID",1,.02))
End DoDot:1
+21 if '$LENGTH(XUXI)
QUIT ""
if $PIECE(XUXI,".",1)'?7N
QUIT ""
SET XUXE=$TRANSLATE($$FMTE^XLFDT(XUXI,"5DZ"),"@"," ")
+22 if '$LENGTH(XUXE)
QUIT ""
SET X=XUXI_"^"_XUXE
+23 QUIT X
SY(X) ; Check System variables
+1 if '$DATA(IO)!('$DATA(IOF))!('$DATA(IOM))!('$DATA(ION))!('$DATA(IOSL))!('$DATA(IOST))
QUIT 0
+2 QUIT 1
UR(X) ; Check User variables
+1 if '$LENGTH($GET(DUZ(0)))
QUIT 0
+2 if +($GET(DUZ))=0!($$NOTDEF(+$GET(DUZ)))
QUIT 0
+3 QUIT 1
CPD(X) ; Check Current Patched Data is installed
+1 NEW INS
SET INS=1
+2 QUIT 0
+3 ;
+4 ; Error messages
+5 ;
CM ; Missing ^XU8P655
+1 NEW XUXPTYPE,XUXLREV,XUXREQP,XUXBUILD,XUXIGHF,XUXFY,XUXQTR
DO IMP
DO ET("")
DO ET("Missing import global ^XU8P655.")
DO CO
+2 QUIT
CO ; Obtain new global
+1 NEW XUXPTYPE,XUXLREV,XUXREQP,XUXBUILD,XUXIGHF,XUXFY,XUXQTR
DO IMP
+2 DO ET("")
DO ET(" Please obtain a copy of the import global ^XU8P655 contained in the ")
+3 DO ET((" global host file "_XUXIGHF_" before continuing with the "_XUXBUILD))
+4 DO ET((" installation."))
+5 QUIT
ET(X) ; Error Text
+1 NEW XUXI
SET XUXI=+($GET(XUXE(0)))
SET XUXI=XUXI+1
SET XUXE(XUXI)=" "_$GET(X)
SET XUXE(0)=XUXI
+2 QUIT
ED ; Error Display
+1 NEW XUXI
SET XUXI=0
FOR
SET XUXI=$ORDER(XUXE(XUXI))
if +XUXI=0
QUIT
DO M(XUXE(XUXI))
+2 DO M(" ")
KILL XUXE
QUIT
+3 ;
+4 ; Miscellaneous
+5 ;
NOTDEF(IEN) ; Check to see if user is defined
+1 NEW DA,DR,DIQ,XUX,DIC
SET DA=IEN
SET DR=.01
SET DIC=200
SET DIQ="XUX"
DO EN^DIQ1
QUIT '$DATA(XUX)
OK ; Environment is OK
+1 NEW XUXPTYPE,XUXLREV,XUXREQP,XUXBUILD,XUXIGHF,XUXFY,XUXQTR,XUXT
+2 DO IMP
SET XUXT=" Environment "_$SELECT($LENGTH(XUXBUILD):("for patch/build "_XUXBUILD_" "),1:"")_"is ok"
+3 DO BM(XUXT)
DO M(" ")
+4 QUIT
BM(X) ; Blank Line with Message
+1 SET X=$GET(X)
if $EXTRACT(X,1)'=" "
SET X=" "_X
DO BMES^XPDUTL(X)
QUIT
M(X) ; Message
+1 SET X=$GET(X)
if $EXTRACT(X,1)'=" "
SET X=" "_X
DO MES^XPDUTL(X)
QUIT
TRIM(X) ; Trim Spaces
+1 SET X=$GET(X)
FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
IMP ; Import names
+1 ;ZEXCEPT: XUXBUILD,XUXIGHF,XUXLREV,XUXPTYPE,XUXREQP ;global variables within this routine
+2 SET XUXPTYPE="VistA Kernel Patch XU*8.0*655"
+3 ; Revision
+4 SET XUXLREV=655
+5 ; Required Builds Array
+6 ; XUX(1)=build SEQ #^released date^subject
+7 ; XUX(n)=build SEQ #^released date^subject
+8 SET XUXREQP(1)="XU*8.0*240 SEQ #237^3030313^STDNAME~XLFNAME: CHECK FOR SUFFIX"
+9 SET XUXREQP(2)="XU*8.0*325 SEQ #337^3060526^XUPS PERSON QUERY"
+10 SET XUXREQP(3)="XU*8.0*514 SEQ #428^3100113^MISC KERNEL FIXES"
+11 SET XUXREQP(4)="XU*8.0*523 SEQ #433^3100428^BSE FOR IMAGING"
+12 ; This Build Name
+13 SET XUXBUILD="XU*8.0*655"
+14 ; This Build's Export Global Host Filename
+15 SET XUXIGHF="XU_8_655.GBL"
+16 QUIT
EF ; Exported Files
+1 ;;^XU8P655("VACAA");^XU8P655("VACAA");Kernel;200
+2 QUIT
GD ; Global Data
+1 ;;^XU8P655("VACAA");^XU8P655("VACAA");Kernel;200
