Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XU8PE655

XU8PE655.m

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