CIANBINI.m

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