CIANBINI ;MSC/IND/DKM - MSC RPC Broker Installation ;25-Jun-2012 15:27;PLS
;;1.1;CIA NETWORK COMPONENTS;**001007,001009**;Sep 18, 2007
;;Copyright 2000-2012, Medsphere Systems Corporation
;=================================================================
; Environment check
EC D PATCH("XPAREDT2","26,35,52","KERNEL TOOLKIT")
D RTNTST("CIAU",1.2,"CIA UTILITIES 1.2")
D OBJCHK
I '$G(XPDQUIT),$G(XPDENV)=1 D
.N X
.L +^XTMP("CIANBLIS"):0
.I L -^XTMP("CIANBLIS") Q
.D MES("One or more broker processes are currently running."),MES()
.I '$$ASK^CIAU(" Do you wish to continue the installation") S XPDABORT=2
.E D:$L($T(+0^CIANBLIS)) STOPALL^CIANBLIS
.F X="XPI1","XPO1","XPZ1" S XPDDIQ(X)=0
.S XPDNOQUE=1
Q
; Check if specified routine is installed
RTNTST(RTN,VN,MSG) ;
D:$$RTNVER(RTN)<VN MES(MSG_" must be installed before proceeding.",2)
Q
; Get version # for specified routine
RTNVER(RTN) ;
Q $P($T(+2^@RTN),";",3)
; Check patch #s for specified routine
PATCH(RTN,PN,MSG) ;
N X,Y,L,F
F X=1:1:$L(PN,",") D
.S Y=$P(PN,",",X),F=0
.F L=2,3 D Q:F
..S F=$TR($P($T(+L^@RTN),";",5),"*",",")[(","_Y_",")
.D:'F MES(MSG_" patch #"_Y_" must be installed before proceeding.",2)
Q
; Check binary version against M system
OBJCHK ; EP
N VER,MSYS
D GETMSYS(.MSYS,.VER)
Q:'$D(MSYS)
I '$D(VER) D
.D MES("This package contains object code that is not supported on "_MSYS_" installations.",2)
E I VER="" D
.D MES("This package does not contain object code for this version of "_MSYS_" installations.",2)
Q
; Get M system type and target version
GETMSYS(MSYS,VER) ;
K MSYS,VER
Q:'$D(@XPDGREF@("OBJ"))
S MSYS=$$UP^XLFSTR($P($$VERSION^%ZOSV(1)," ")),MSYS(0)=$S(MSYS="CACHE":1,MSYS="JUMPS":2,1:0)
Q:'$D(@XPDGREF@("OBJ",MSYS(0)))
S VER=$TR($$VERSION^%ZOSV()," ")
F Q:'$L(VER) Q:$D(@XPDGREF@("OBJ",MSYS(0),VER)) S VER=$P(VER,".",1,$L(VER,".")-1)
Q
; Display message in MSG and optionally set quit flag to QUIT
MES(MSG,QUIT) ;
D BMES^XPDUTL(" "_$G(MSG))
S:$G(QUIT) XPDQUIT=QUIT
Q
; Pre-init
PRE S @XPDGREF@("NEW")=$D(^CIANB)<10
D OBJINST
X $G(@XPDGREF@("INITIAL"))
Q
; Post-init
POST X ^%ZOSF("EON"),^%ZOSF("TRMOFF")
D CVT,DEFPAR
X $G(@XPDGREF@("FINAL"))
D:$G(@XPDGREF@("NEW")) TEDH^XPAREDIT("CIANB SITE PARAMETERS","BA")
D CLEANUP^CIANBUTL,STARTALL^CIANBLIS
K ^DIC(19941.24,0,"RD")
Q
; Convert entries from old event file
CVT N X,FN
S FN=19941.21
Q:$O(^CIANB(FN,0))!'$O(^CIAVEVT(0))
S X=$P(^CIANB(FN,0),U,1,2)
M ^CIANB(FN)=^CIAVEVT
S $P(^CIANB(FN,0),U,1,2)=X,X=0
F S X=$O(^CIANB(FN,X)) Q:'X D
.D CVTX(2,99,99)
.D CVTX(3,20,"2P")
Q
; Move multiples to new nodes and fix sfn
CVTX(NF,NT,SN) ;
M ^CIANB(FN,X,NT)=^CIANB(FN,X,NF)
K ^CIANB(FN,X,NF)
S $P(^CIANB(FN,X,NT,0),U,2)=FN_SN
Q
; Initializes default parameter values. Does not affect existing entries.
DEFPAR N V,X,Y,Z
D MES("Setting up default site parameters...")
D DEL^XPAR("PKG","CIANB AUTHENTICATION",1)
F X=0:0 S X=$O(@XPDGREF@("PARAM",X)) Q:'X M Z=^(X) D
.S Y=Z,Z=$$MSG^CIAU($P(Y,U,3,999),"|",0),V=$$MSG^CIAU($P(Y,U,2),"|"),Y=$P(Y,U)
.D ADD^XPAR("PKG",Y,V,.Z)
Q
; Install routine binaries
OBJINST ; EP
N MSYS,RTN,OBJ,SUB,GBL
D GETMSYS(.MSYS,.VER)
Q:'$D(MSYS)
Q:$D(@XPDGREF@("OBJ",MSYS(0)))<10
S RTN=""
D MES("Installing Routine Binaries...")
F S RTN=$O(@XPDGREF@("OBJ",MSYS(0),VER,RTN)) Q:'$L(RTN) D
.X "ZR ZS @RTN"
.S OBJ="",SUB=0,GBL=$NA(@$S(MSYS(0)=1:"^rOBJ(RTN)",1:"^$R(RTN,""OBJECT"")"))
.F S SUB=$O(@XPDGREF@("OBJ",MSYS(0),VER,RTN,SUB)) Q:'SUB S OBJ=OBJ_^(SUB,0)
.S @GBL=$S(MSYS(0)=1:$$DECODE^CIAUUU(OBJ),1:OBJ)
.D MES(" "_RTN_" installed.")
Q
CIANBINI ;MSC/IND/DKM - MSC RPC Broker Installation ;25-Jun-2012 15:27;PLS
+1 ;;1.1;CIA NETWORK COMPONENTS;**001007,001009**;Sep 18, 2007
+2 ;;Copyright 2000-2012, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Environment check
EC DO PATCH("XPAREDT2","26,35,52","KERNEL TOOLKIT")
+1 DO RTNTST("CIAU",1.2,"CIA UTILITIES 1.2")
+2 DO OBJCHK
+3 IF '$GET(XPDQUIT)
IF $GET(XPDENV)=1
Begin DoDot:1
+4 NEW X
+5 LOCK +^XTMP("CIANBLIS"):0
+6 IF $TEST
LOCK -^XTMP("CIANBLIS")
QUIT
+7 DO MES("One or more broker processes are currently running.")
DO MES()
+8 IF '$$ASK^CIAU(" Do you wish to continue the installation")
SET XPDABORT=2
+9 IF '$TEST
IF $LENGTH($TEXT(+0^CIANBLIS))
DO STOPALL^CIANBLIS
+10 FOR X="XPI1","XPO1","XPZ1"
SET XPDDIQ(X)=0
+11 SET XPDNOQUE=1
End DoDot:1
+12 QUIT
+13 ; Check if specified routine is installed
RTNTST(RTN,VN,MSG) ;
+1 IF $$RTNVER(RTN)<VN
DO MES(MSG_" must be installed before proceeding.",2)
+2 QUIT
+3 ; Get version # for specified routine
RTNVER(RTN) ;
+1 QUIT $PIECE($TEXT(+2^@RTN),";",3)
+2 ; Check patch #s for specified routine
PATCH(RTN,PN,MSG) ;
+1 NEW X,Y,L,F
+2 FOR X=1:1:$LENGTH(PN,",")
Begin DoDot:1
+3 SET Y=$PIECE(PN,",",X)
SET F=0
+4 FOR L=2,3
Begin DoDot:2
+5 SET F=$TRANSLATE($PIECE($TEXT(+L^@RTN),";",5),"*",",")[(","_Y_",")
End DoDot:2
IF F
QUIT
+6 IF 'F
DO MES(MSG_" patch #"_Y_" must be installed before proceeding.",2)
End DoDot:1
+7 QUIT
+8 ; Check binary version against M system
OBJCHK ; EP
+1 NEW VER,MSYS
+2 DO GETMSYS(.MSYS,.VER)
+3 IF '$DATA(MSYS)
QUIT
+4 IF '$DATA(VER)
Begin DoDot:1
+5 DO MES("This package contains object code that is not supported on "_MSYS_" installations.",2)
End DoDot:1
+6 IF '$TEST
IF VER=""
Begin DoDot:1
+7 DO MES("This package does not contain object code for this version of "_MSYS_" installations.",2)
End DoDot:1
+8 QUIT
+9 ; Get M system type and target version
GETMSYS(MSYS,VER) ;
+1 KILL MSYS,VER
+2 IF '$DATA(@XPDGREF@("OBJ"))
QUIT
+3 SET MSYS=$$UP^XLFSTR($PIECE($$VERSION^%ZOSV(1)," "))
SET MSYS(0)=$SELECT(MSYS="CACHE":1,MSYS="JUMPS":2,1:0)
+4 IF '$DATA(@XPDGREF@("OBJ",MSYS(0)))
QUIT
+5 SET VER=$TRANSLATE($$VERSION^%ZOSV()," ")
+6 FOR
IF '$LENGTH(VER)
QUIT
IF $DATA(@XPDGREF@("OBJ",MSYS(0),VER))
QUIT
SET VER=$PIECE(VER,".",1,$LENGTH(VER,".")-1)
+7 QUIT
+8 ; Display message in MSG and optionally set quit flag to QUIT
MES(MSG,QUIT) ;
+1 DO BMES^XPDUTL(" "_$GET(MSG))
+2 IF $GET(QUIT)
SET XPDQUIT=QUIT
+3 QUIT
+4 ; Pre-init
PRE SET @XPDGREF@("NEW")=$DATA(^CIANB)<10
+1 DO OBJINST
+2 XECUTE $GET(@XPDGREF@("INITIAL"))
+3 QUIT
+4 ; Post-init
POST XECUTE ^%ZOSF("EON")
XECUTE ^%ZOSF("TRMOFF")
+1 DO CVT
DO DEFPAR
+2 XECUTE $GET(@XPDGREF@("FINAL"))
+3 IF $GET(@XPDGREF@("NEW"))
DO TEDH^XPAREDIT("CIANB SITE PARAMETERS","BA")
+4 DO CLEANUP^CIANBUTL
DO STARTALL^CIANBLIS
+5 KILL ^DIC(19941.24,0,"RD")
+6 QUIT
+7 ; Convert entries from old event file
CVT NEW X,FN
+1 SET FN=19941.21
+2 IF $ORDER(^CIANB(FN,0))!'$ORDER(^CIAVEVT(0))
QUIT
+3 SET X=$PIECE(^CIANB(FN,0),U,1,2)
+4 MERGE ^CIANB(FN)=^CIAVEVT
+5 SET $PIECE(^CIANB(FN,0),U,1,2)=X
SET X=0
+6 FOR
SET X=$ORDER(^CIANB(FN,X))
IF 'X
QUIT
Begin DoDot:1
+7 DO CVTX(2,99,99)
+8 DO CVTX(3,20,"2P")
End DoDot:1
+9 QUIT
+10 ; Move multiples to new nodes and fix sfn
CVTX(NF,NT,SN) ;
+1 MERGE ^CIANB(FN,X,NT)=^CIANB(FN,X,NF)
+2 KILL ^CIANB(FN,X,NF)
+3 SET $PIECE(^CIANB(FN,X,NT,0),U,2)=FN_SN
+4 QUIT
+5 ; Initializes default parameter values. Does not affect existing entries.
DEFPAR NEW V,X,Y,Z
+1 DO MES("Setting up default site parameters...")
+2 DO DEL^XPAR("PKG","CIANB AUTHENTICATION",1)
+3 FOR X=0:0
SET X=$ORDER(@XPDGREF@("PARAM",X))
IF 'X
QUIT
MERGE Z=^(X)
Begin DoDot:1
+4 SET Y=Z
SET Z=$$MSG^CIAU($PIECE(Y,U,3,999),"|",0)
SET V=$$MSG^CIAU($PIECE(Y,U,2),"|")
SET Y=$PIECE(Y,U)
+5 DO ADD^XPAR("PKG",Y,V,.Z)
End DoDot:1
+6 QUIT
+7 ; Install routine binaries
OBJINST ; EP
+1 NEW MSYS,RTN,OBJ,SUB,GBL
+2 DO GETMSYS(.MSYS,.VER)
+3 IF '$DATA(MSYS)
QUIT
+4 IF $DATA(@XPDGREF@("OBJ",MSYS(0)))<10
QUIT
+5 SET RTN=""
+6 DO MES("Installing Routine Binaries...")
+7 FOR
SET RTN=$ORDER(@XPDGREF@("OBJ",MSYS(0),VER,RTN))
IF '$LENGTH(RTN)
QUIT
Begin DoDot:1
+8 XECUTE "ZR ZS @RTN"
+9 SET OBJ=""
SET SUB=0
SET GBL=$NAME(@$SELECT(MSYS(0)=1:"^rOBJ(RTN)",1:"^$R(RTN,""OBJECT"")"))
+10 FOR
SET SUB=$ORDER(@XPDGREF@("OBJ",MSYS(0),VER,RTN,SUB))
IF 'SUB
QUIT
SET OBJ=OBJ_^(SUB,0)
+11 SET @GBL=$SELECT(MSYS(0)=1:$$DECODE^CIAUUU(OBJ),1:OBJ)
+12 DO MES(" "_RTN_" installed.")
End DoDot:1
+13 QUIT
