CIAVINIT ;MSC/IND/DKM - VueCentric KIDS inits ;15-Feb-2008 09:48;DKM
;;1.1V2;VUECENTRIC FRAMEWORK;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; Environment check
EC I $P(^DD(9000010,15001,0),U)'["VISIT ID"!(^DD(9000010,15003,0)'["S:STOP CODE") D
.D MES("Visit Tracking must be installed before proceeding",2)
D RTNTST("VADPT1",5.3,"PIMS 5.3")
D RTNTST("CIAU",1.1,"CIA UTILITIES 1.1")
D RTNTST("CIANBLIS",1.1,"CIA RPC BROKER 1.1")
I $$RTNVER("DI")<22 D
.D PATCH("DIR",41,"FILEMAN 21")
.D RTNTST("DDR",21,"FILEMAN 21 DELPHI COMPONENTS-RPCs (patch 34)")
D OBJCHK
I $G(XPDENV)=1 D
.N X
.F X="XPI1","XPO1","XPZ1" S XPDDIQ(X)=0
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
; 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
; Preinit
PRE N CIAX,CIAY
S @XPDGREF@("NEW")='$D(^CIAVOBJ(19930.2))
D MES(),OBJINST,SDINIT^CIAVUTIL(,60,1)
F D Q:'CIAX
.S CIAX=$$SHOWSESS^CIAVUTIL
.R:CIAX "Waiting for active sessions to terminate...",CIAY:10,!!
.I CIAX,CIAY=U,$$ASK^CIAU("There are still active sessions. Are you sure you want to proceed") S CIAX=0
D MES("Proceeding with installation...")
F CIAX=19930.2,19930.21,19930.3 D CLEANUP(CIAX)
D INITIAL,RENPRGID,SAVEREG,SAVEOPT
Q
; Postinit
POST N PAR,Y
X ^%ZOSF("EON"),^%ZOSF("TRMOFF")
D RESPTR,DEFPAR
D:$G(@XPDGREF@("NEW")) TEDH^XPAREDIT("CIAVM POSTINIT","BA")
D RESTREG,MMSG,RESTOPT,REGISTER^CIAVIN1,FINAL
D DELFIL(19930.1)
D MES("Registering VueCentric with Visit Tracking...")
I $$PKG^VSIT("CIAV",1)
W !!!
Q
; Execute initial preinit code, if any
INITIAL ; EP
X $G(@XPDGREF@("INITIAL"))
Q
; Execute final postinit code, if any
FINAL ; EP
X $G(@XPDGREF@("FINAL"))
Q
; Initializes default parameter values. Does not affect existing entries.
DEFPAR N PAR,ENT,VAL,INST,LP,Y
D MES("Setting up default site parameters...")
F LP=0:0 S LP=$O(@XPDGREF@("PARAM",LP)) Q:'LP K VAL M VAL=^(LP) D
.S Y=VAL,VAL=$$MSG^CIAU($P(Y,U,3,999),"|",0),PAR=$P(Y,U),INST=$P(Y,U,2)
.S ENT=$$ENT^CIAVMRPC(PAR),ENT=$P(ENT,U,$L(ENT,U))
.D:$L(ENT) ADD^XPAR(ENT,PAR,INST,.VAL)
Q
; Rename specified PROGIDs
RENPRGID ; EP
N OLD
S OLD=""
F S OLD=$O(@XPDGREF@("RENAME",OLD)) Q:'$L(OLD) D RENAME(OLD,$O(^(OLD,"")))
Q
; Rename a PROGID
RENAME(OLD,NEW) ; EP
N R,X,Y
S R=0,X=+$$PRGID^CIAVMCFG(OLD,.Y)
I X,'$$PRGID^CIAVMCFG(NEW) D
.K ^CIAVOBJ(19930.2,"B",Y,X)
.S $P(^CIAVOBJ(19930.2,X,0),U)=NEW,^CIAVOBJ(19930.2,"B",$E(NEW,1,30),X)="",R=1
; Rename any references in templates
F X=0:0 S X=$O(^CIAVTPL(X)) Q:'X S R=R!$$RENTPL(X,OLD,NEW)
D:R MES("Object "_OLD_" renamed to "_NEW_".")
Q
; Rename imbedded PROGIDs in a template
; TPL = Template name or IEN
; OLD = Old progid (if not specified, all aliases are scanned)
; NEW = New progid (as above)
RENTPL(TPL,OLD,NEW) ; EP
N LN,LO,X,F,R,P1,P2,Z,Z1
S (X,R)=0
I '$D(OLD) D
.F S X=$O(^CIAVOBJ(19930.2,X)),Z=0 Q:'X S NEW=$P($G(^(X,0)),U) D:$L(NEW)
..F S Z=$O(^CIAVOBJ(19930.2,X,10,Z)) Q:'Z S OLD=$TR($G(^(Z,0))," ") D:$L(OLD)
...S R=R!$$RENTPL(TPL,OLD,NEW)
E D
.S LN=$L(NEW),LO=$L(OLD)
.S:TPL'=+TPL TPL=$$TMPL^CIAVMCFG(TPL)
.F S X=$O(^CIAVTPL(TPL,1,X)) Q:'X S Z=$G(^(X,0)) D
..S (F,P2)=0,Z1=$$UP^XLFSTR(Z)
..F S P1=$F(Z1,OLD,P2) Q:'P1 D
...Q:$E(Z1,P1)?1AN
...Q:$E(Z1,P1-LO-1)?1AN
...S $E(Z1,P1-LO,P1-1)=NEW,$E(Z,P1-LO,P1-1)=NEW,P2=P1+LN-LO,F=1
..S:F ^CIAVTPL(TPL,1,X,0)=Z,R=1
Q:$Q R
Q
; Delete a file or subfile
; DIU = File or subfile #
DELFIL(DIU) ; EP
N $ET
S $ET="",@$$TRAP^CIAUOS("DELERR^CIAVINIT")
Q:'$D(^DD(DIU))
S DIU(0)=$S($D(^DIC(DIU)):"D",1:"S")
D EN^DIU2
Q
DELERR N ERR
S ERR=$$EC^%ZOSV
D MES("An error occurred deleting file #"_$G(DIU))
D MES("The error was: "_ERR)
D MES("Please delete the file manually after correcting the problem.")
Q
; Cleanup any duplicate entries in specified file
CLEANUP(FNUM) ;
N CIAX,CIAY,CIAY1,CIAZ,DIK,DA,GBL,OPN
S GBL=$$ROOT^DILFD(FNUM,,1),OPN=$$ROOT^DILFD(FNUM)
I $L(GBL),$D(@GBL) D
.D MES("Cleaning up "_$$GET1^DID(FNUM,,,"NAME")_"...")
.K DIK,DA,@GBL@("B")
.S DIK=OPN,DIK(1)=.01,CIAX=""
.D ENALL^DIK
.F S CIAX=$O(@GBL@("B",CIAX)),CIAY=0 Q:'$L(CIAX) D
..F S CIAY=$O(@GBL@("B",CIAX,CIAY)) Q:'CIAY D
...S CIAZ=$P(@GBL@(CIAY,0),U),CIAY1=0
...F S CIAY1=$O(@GBL@("B",CIAX,CIAY1)) Q:'CIAY1 D:CIAY'=CIAY1
....Q:$P(@GBL@(CIAY1,0),U)'=CIAZ
....K DIK,DA
....S DIK=OPN,DA=CIAY1
....D ^DIK
Q
; Save local settings for object registry and create new categories
SAVEREG ; EP
N NAM,CAT,IEN,SUB
D MES("Saving local object registry settings...")
S NAM=""
F S NAM=$O(@XPDGREF@("PTRS",19930.221,NAM)) Q:'$L(NAM) D
.S IEN=$$PRGID^CIAVMCFG(NAM)
.I IEN F SUB=2,3,5 D
..Q:$D(@XPDGREF@("OVERWRITE",NAM,SUB))
..M @XPDGREF@("REGSAVE",NAM,SUB)=^CIAVOBJ(19930.2,IEN,SUB)
D MES("Creating new object categories...")
F S NAM=$O(@XPDGREF@("PTRS",19930.206,NAM)),CAT="" Q:'$L(NAM) D
.F S CAT=$O(@XPDGREF@("PTRS",19930.206,NAM,CAT)) Q:'$L(CAT) D
..Q:$$FIND1^DIC(19930.21,,"X",CAT)
..N FDA
..S FDA(19930.21,"+1,",.01)=CAT
..D UPDATE^DIE("E","FDA")
Q
; Restore local settings for object registry
RESTREG ; EP
N NAM,IEN,SUB
D MES("Restoring local object registry settings...")
S NAM=""
F S NAM=$O(@XPDGREF@("REGSAVE",NAM)) Q:'$L(NAM) D
.S IEN=$$PRGID^CIAVMCFG(NAM),SUB=0
.I IEN F S SUB=$O(@XPDGREF@("REGSAVE",NAM,SUB)) Q:'SUB D
..K ^CIAVOBJ(19930.2,IEN,SUB)
..M ^CIAVOBJ(19930.2,IEN,SUB)=@XPDGREF@("REGSAVE",NAM,SUB)
Q
; Save ITEM and RPC entries for CIAV VUECENTRIC option
SAVEOPT N OPT
S OPT=$$FIND1^DIC(19,"","X","CIAV VUECENTRIC")
Q:'OPT
M @XPDGREF@("ITMSAVE")=^DIC(19,OPT,10,"B")
M @XPDGREF@("RPCSAVE")=^DIC(19,OPT,"RPC","B")
Q
; Restore ITEM and RPC entries for CIAV VUECENTRIC
RESTOPT N OPT,ITM,RPC
S OPT=$$FIND1^DIC(19,"","X","CIAV VUECENTRIC")
Q:'OPT
F ITM=0:0 S ITM=$O(@XPDGREF@("ITMSAVE",ITM)) Q:'ITM I $$REGCTX^CIAURPC(ITM,OPT)
F RPC=0:0 S RPC=$O(@XPDGREF@("RPCSAVE",RPC)) Q:'RPC I $$REGRPC^CIAURPC(RPC,OPT)
Q
; Resolve pointers in multiples (KIDS doesn't)
RESPTR ; EP
N TGT,SRC,SUB,NOD,NAM,VAL,IEN,CNT,SGB,PTR
S SUB=0
F S SUB=$O(@XPDGREF@("PTRS",SUB)) Q:'SUB S X=^(SUB) D
.S NOD=+X,SRC=$P(X,U,2),TGT=$P(X,U,3),SGB=$$ROOT^DILFD(SRC,,1),NAM=""
.F S NAM=$O(@XPDGREF@("PTRS",SUB,NAM)) Q:'$L(NAM) D
..S IEN=$$FIND1^DIC(SRC,"","QX",NAM),VAL="",CNT=0
..Q:IEN'>0
..K @SGB@(IEN,NOD)
..F S VAL=$O(@XPDGREF@("PTRS",SUB,NAM,VAL)) Q:'$L(VAL) D
...S PTR=$$FIND1^DIC(TGT,,"X",VAL)
...I 'PTR D MES(" Failed to resolve "_VAL) Q
...S CNT=CNT+1,@SGB@(IEN,NOD,CNT,0)=PTR,@SGB@(IEN,NOD,"B",PTR,CNT)=""
..S:CNT @SGB@(IEN,NOD,0)=U_SUB_"P^"_CNT_U_CNT
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
; 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)
Q
; Send mail message confirming VueCentric installation
MMSG Q:'$$PATCH^XPDUTL("XM*7.1*50")
N SUBJ,RECP,GBL
S GBL=$$TMPGBL^CIAVMRPC
S SUBJ="VueCentric Installation at "_$G(^XMB("NETNAME"))
S @GBL@(1)="VueCentric has just been installed at: "_$G(^XMB("NETNAME"))_"."
S @GBL@(2)="Version #: "_$P($T(+2),";",3)
S @GBL@(3)="Installer: "_$P($G(^VA(200,+$G(DUZ),0)),U)
S RECP("mail@ciainformatics.com")=""
D SENDMSG^XMXAPI(DUZ,SUBJ,GBL,.RECP)
K @GBL
Q
CIAVINIT ;MSC/IND/DKM - VueCentric KIDS inits ;15-Feb-2008 09:48;DKM
+1 ;;1.1V2;VUECENTRIC FRAMEWORK;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Environment check
EC IF $PIECE(^DD(9000010,15001,0),U)'["VISIT ID"!(^DD(9000010,15003,0)'["S:STOP CODE")
Begin DoDot:1
+1 DO MES("Visit Tracking must be installed before proceeding",2)
End DoDot:1
+2 DO RTNTST("VADPT1",5.3,"PIMS 5.3")
+3 DO RTNTST("CIAU",1.1,"CIA UTILITIES 1.1")
+4 DO RTNTST("CIANBLIS",1.1,"CIA RPC BROKER 1.1")
+5 IF $$RTNVER("DI")<22
Begin DoDot:1
+6 DO PATCH("DIR",41,"FILEMAN 21")
+7 DO RTNTST("DDR",21,"FILEMAN 21 DELPHI COMPONENTS-RPCs (patch 34)")
End DoDot:1
+8 DO OBJCHK
+9 IF $GET(XPDENV)=1
Begin DoDot:1
+10 NEW X
+11 FOR X="XPI1","XPO1","XPZ1"
SET XPDDIQ(X)=0
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 ; 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 ; Preinit
PRE NEW CIAX,CIAY
+1 SET @XPDGREF@("NEW")='$DATA(^CIAVOBJ(19930.2))
+2 DO MES()
DO OBJINST
DO SDINIT^CIAVUTIL(,60,1)
+3 FOR
Begin DoDot:1
+4 SET CIAX=$$SHOWSESS^CIAVUTIL
+5 IF CIAX
READ "Waiting for active sessions to terminate...",CIAY:10,!!
+6 IF CIAX
IF CIAY=U
IF $$ASK^CIAU("There are still active sessions. Are you sure you want to proceed")
SET CIAX=0
End DoDot:1
IF 'CIAX
QUIT
+7 DO MES("Proceeding with installation...")
+8 FOR CIAX=19930.2,19930.21,19930.3
DO CLEANUP(CIAX)
+9 DO INITIAL
DO RENPRGID
DO SAVEREG
DO SAVEOPT
+10 QUIT
+11 ; Postinit
POST NEW PAR,Y
+1 XECUTE ^%ZOSF("EON")
XECUTE ^%ZOSF("TRMOFF")
+2 DO RESPTR
DO DEFPAR
+3 IF $GET(@XPDGREF@("NEW"))
DO TEDH^XPAREDIT("CIAVM POSTINIT","BA")
+4 DO RESTREG
DO MMSG
DO RESTOPT
DO REGISTER^CIAVIN1
DO FINAL
+5 DO DELFIL(19930.1)
+6 DO MES("Registering VueCentric with Visit Tracking...")
+7 IF $$PKG^VSIT("CIAV",1)
+8 WRITE !!!
+9 QUIT
+10 ; Execute initial preinit code, if any
INITIAL ; EP
+1 XECUTE $GET(@XPDGREF@("INITIAL"))
+2 QUIT
+3 ; Execute final postinit code, if any
FINAL ; EP
+1 XECUTE $GET(@XPDGREF@("FINAL"))
+2 QUIT
+3 ; Initializes default parameter values. Does not affect existing entries.
DEFPAR NEW PAR,ENT,VAL,INST,LP,Y
+1 DO MES("Setting up default site parameters...")
+2 FOR LP=0:0
SET LP=$ORDER(@XPDGREF@("PARAM",LP))
IF 'LP
QUIT
KILL VAL
MERGE VAL=^(LP)
Begin DoDot:1
+3 SET Y=VAL
SET VAL=$$MSG^CIAU($PIECE(Y,U,3,999),"|",0)
SET PAR=$PIECE(Y,U)
SET INST=$PIECE(Y,U,2)
+4 SET ENT=$$ENT^CIAVMRPC(PAR)
SET ENT=$PIECE(ENT,U,$LENGTH(ENT,U))
+5 IF $LENGTH(ENT)
DO ADD^XPAR(ENT,PAR,INST,.VAL)
End DoDot:1
+6 QUIT
+7 ; Rename specified PROGIDs
RENPRGID ; EP
+1 NEW OLD
+2 SET OLD=""
+3 FOR
SET OLD=$ORDER(@XPDGREF@("RENAME",OLD))
IF '$LENGTH(OLD)
QUIT
DO RENAME(OLD,$ORDER(^(OLD,"")))
+4 QUIT
+5 ; Rename a PROGID
RENAME(OLD,NEW) ; EP
+1 NEW R,X,Y
+2 SET R=0
SET X=+$$PRGID^CIAVMCFG(OLD,.Y)
+3 IF X
IF '$$PRGID^CIAVMCFG(NEW)
Begin DoDot:1
+4 KILL ^CIAVOBJ(19930.2,"B",Y,X)
+5 SET $PIECE(^CIAVOBJ(19930.2,X,0),U)=NEW
SET ^CIAVOBJ(19930.2,"B",$EXTRACT(NEW,1,30),X)=""
SET R=1
End DoDot:1
+6 ; Rename any references in templates
+7 FOR X=0:0
SET X=$ORDER(^CIAVTPL(X))
IF 'X
QUIT
SET R=R!$$RENTPL(X,OLD,NEW)
+8 IF R
DO MES("Object "_OLD_" renamed to "_NEW_".")
+9 QUIT
+10 ; Rename imbedded PROGIDs in a template
+11 ; TPL = Template name or IEN
+12 ; OLD = Old progid (if not specified, all aliases are scanned)
+13 ; NEW = New progid (as above)
RENTPL(TPL,OLD,NEW) ; EP
+1 NEW LN,LO,X,F,R,P1,P2,Z,Z1
+2 SET (X,R)=0
+3 IF '$DATA(OLD)
Begin DoDot:1
+4 FOR
SET X=$ORDER(^CIAVOBJ(19930.2,X))
SET Z=0
IF 'X
QUIT
SET NEW=$PIECE($GET(^(X,0)),U)
IF $LENGTH(NEW)
Begin DoDot:2
+5 FOR
SET Z=$ORDER(^CIAVOBJ(19930.2,X,10,Z))
IF 'Z
QUIT
SET OLD=$TRANSLATE($GET(^(Z,0))," ")
IF $LENGTH(OLD)
Begin DoDot:3
+6 SET R=R!$$RENTPL(TPL,OLD,NEW)
End DoDot:3
End DoDot:2
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET LN=$LENGTH(NEW)
SET LO=$LENGTH(OLD)
+9 IF TPL'=+TPL
SET TPL=$$TMPL^CIAVMCFG(TPL)
+10 FOR
SET X=$ORDER(^CIAVTPL(TPL,1,X))
IF 'X
QUIT
SET Z=$GET(^(X,0))
Begin DoDot:2
+11 SET (F,P2)=0
SET Z1=$$UP^XLFSTR(Z)
+12 FOR
SET P1=$FIND(Z1,OLD,P2)
IF 'P1
QUIT
Begin DoDot:3
+13 IF $EXTRACT(Z1,P1)?1AN
QUIT
+14 IF $EXTRACT(Z1,P1-LO-1)?1AN
QUIT
+15 SET $EXTRACT(Z1,P1-LO,P1-1)=NEW
SET $EXTRACT(Z,P1-LO,P1-1)=NEW
SET P2=P1+LN-LO
SET F=1
End DoDot:3
+16 IF F
SET ^CIAVTPL(TPL,1,X,0)=Z
SET R=1
End DoDot:2
End DoDot:1
+17 IF $QUIT
QUIT R
+18 QUIT
+19 ; Delete a file or subfile
+20 ; DIU = File or subfile #
DELFIL(DIU) ; EP
+1 NEW $ETRAP
+2 SET $ETRAP=""
SET @$$TRAP^CIAUOS("DELERR^CIAVINIT")
+3 IF '$DATA(^DD(DIU))
QUIT
+4 SET DIU(0)=$SELECT($DATA(^DIC(DIU)):"D",1:"S")
+5 DO EN^DIU2
+6 QUIT
DELERR NEW ERR
+1 SET ERR=$$EC^%ZOSV
+2 DO MES("An error occurred deleting file #"_$GET(DIU))
+3 DO MES("The error was: "_ERR)
+4 DO MES("Please delete the file manually after correcting the problem.")
+5 QUIT
+6 ; Cleanup any duplicate entries in specified file
CLEANUP(FNUM) ;
+1 NEW CIAX,CIAY,CIAY1,CIAZ,DIK,DA,GBL,OPN
+2 SET GBL=$$ROOT^DILFD(FNUM,,1)
SET OPN=$$ROOT^DILFD(FNUM)
+3 IF $LENGTH(GBL)
IF $DATA(@GBL)
Begin DoDot:1
+4 DO MES("Cleaning up "_$$GET1^DID(FNUM,,,"NAME")_"...")
+5 KILL DIK,DA,@GBL@("B")
+6 SET DIK=OPN
SET DIK(1)=.01
SET CIAX=""
+7 DO ENALL^DIK
+8 FOR
SET CIAX=$ORDER(@GBL@("B",CIAX))
SET CIAY=0
IF '$LENGTH(CIAX)
QUIT
Begin DoDot:2
+9 FOR
SET CIAY=$ORDER(@GBL@("B",CIAX,CIAY))
IF 'CIAY
QUIT
Begin DoDot:3
+10 SET CIAZ=$PIECE(@GBL@(CIAY,0),U)
SET CIAY1=0
+11 FOR
SET CIAY1=$ORDER(@GBL@("B",CIAX,CIAY1))
IF 'CIAY1
QUIT
IF CIAY'=CIAY1
Begin DoDot:4
+12 IF $PIECE(@GBL@(CIAY1,0),U)'=CIAZ
QUIT
+13 KILL DIK,DA
+14 SET DIK=OPN
SET DA=CIAY1
+15 DO ^DIK
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ; Save local settings for object registry and create new categories
SAVEREG ; EP
+1 NEW NAM,CAT,IEN,SUB
+2 DO MES("Saving local object registry settings...")
+3 SET NAM=""
+4 FOR
SET NAM=$ORDER(@XPDGREF@("PTRS",19930.221,NAM))
IF '$LENGTH(NAM)
QUIT
Begin DoDot:1
+5 SET IEN=$$PRGID^CIAVMCFG(NAM)
+6 IF IEN
FOR SUB=2,3,5
Begin DoDot:2
+7 IF $DATA(@XPDGREF@("OVERWRITE",NAM,SUB))
QUIT
+8 MERGE @XPDGREF@("REGSAVE",NAM,SUB)=^CIAVOBJ(19930.2,IEN,SUB)
End DoDot:2
End DoDot:1
+9 DO MES("Creating new object categories...")
+10 FOR
SET NAM=$ORDER(@XPDGREF@("PTRS",19930.206,NAM))
SET CAT=""
IF '$LENGTH(NAM)
QUIT
Begin DoDot:1
+11 FOR
SET CAT=$ORDER(@XPDGREF@("PTRS",19930.206,NAM,CAT))
IF '$LENGTH(CAT)
QUIT
Begin DoDot:2
+12 IF $$FIND1^DIC(19930.21,,"X",CAT)
QUIT
+13 NEW FDA
+14 SET FDA(19930.21,"+1,",.01)=CAT
+15 DO UPDATE^DIE("E","FDA")
End DoDot:2
End DoDot:1
+16 QUIT
+17 ; Restore local settings for object registry
RESTREG ; EP
+1 NEW NAM,IEN,SUB
+2 DO MES("Restoring local object registry settings...")
+3 SET NAM=""
+4 FOR
SET NAM=$ORDER(@XPDGREF@("REGSAVE",NAM))
IF '$LENGTH(NAM)
QUIT
Begin DoDot:1
+5 SET IEN=$$PRGID^CIAVMCFG(NAM)
SET SUB=0
+6 IF IEN
FOR
SET SUB=$ORDER(@XPDGREF@("REGSAVE",NAM,SUB))
IF 'SUB
QUIT
Begin DoDot:2
+7 KILL ^CIAVOBJ(19930.2,IEN,SUB)
+8 MERGE ^CIAVOBJ(19930.2,IEN,SUB)=@XPDGREF@("REGSAVE",NAM,SUB)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ; Save ITEM and RPC entries for CIAV VUECENTRIC option
SAVEOPT NEW OPT
+1 SET OPT=$$FIND1^DIC(19,"","X","CIAV VUECENTRIC")
+2 IF 'OPT
QUIT
+3 MERGE @XPDGREF@("ITMSAVE")=^DIC(19,OPT,10,"B")
+4 MERGE @XPDGREF@("RPCSAVE")=^DIC(19,OPT,"RPC","B")
+5 QUIT
+6 ; Restore ITEM and RPC entries for CIAV VUECENTRIC
RESTOPT NEW OPT,ITM,RPC
+1 SET OPT=$$FIND1^DIC(19,"","X","CIAV VUECENTRIC")
+2 IF 'OPT
QUIT
+3 FOR ITM=0:0
SET ITM=$ORDER(@XPDGREF@("ITMSAVE",ITM))
IF 'ITM
QUIT
IF $$REGCTX^CIAURPC(ITM,OPT)
+4 FOR RPC=0:0
SET RPC=$ORDER(@XPDGREF@("RPCSAVE",RPC))
IF 'RPC
QUIT
IF $$REGRPC^CIAURPC(RPC,OPT)
+5 QUIT
+6 ; Resolve pointers in multiples (KIDS doesn't)
RESPTR ; EP
+1 NEW TGT,SRC,SUB,NOD,NAM,VAL,IEN,CNT,SGB,PTR
+2 SET SUB=0
+3 FOR
SET SUB=$ORDER(@XPDGREF@("PTRS",SUB))
IF 'SUB
QUIT
SET X=^(SUB)
Begin DoDot:1
+4 SET NOD=+X
SET SRC=$PIECE(X,U,2)
SET TGT=$PIECE(X,U,3)
SET SGB=$$ROOT^DILFD(SRC,,1)
SET NAM=""
+5 FOR
SET NAM=$ORDER(@XPDGREF@("PTRS",SUB,NAM))
IF '$LENGTH(NAM)
QUIT
Begin DoDot:2
+6 SET IEN=$$FIND1^DIC(SRC,"","QX",NAM)
SET VAL=""
SET CNT=0
+7 IF IEN'>0
QUIT
+8 KILL @SGB@(IEN,NOD)
+9 FOR
SET VAL=$ORDER(@XPDGREF@("PTRS",SUB,NAM,VAL))
IF '$LENGTH(VAL)
QUIT
Begin DoDot:3
+10 SET PTR=$$FIND1^DIC(TGT,,"X",VAL)
+11 IF 'PTR
DO MES(" Failed to resolve "_VAL)
QUIT
+12 SET CNT=CNT+1
SET @SGB@(IEN,NOD,CNT,0)=PTR
SET @SGB@(IEN,NOD,"B",PTR,CNT)=""
End DoDot:3
+13 IF CNT
SET @SGB@(IEN,NOD,0)=U_SUB_"P^"_CNT_U_CNT
End DoDot:2
End DoDot:1
+14 QUIT
+15 ; 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 ; 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)
End DoDot:1
+12 QUIT
+13 ; Send mail message confirming VueCentric installation
MMSG IF '$$PATCH^XPDUTL("XM*7.1*50")
QUIT
+1 NEW SUBJ,RECP,GBL
+2 SET GBL=$$TMPGBL^CIAVMRPC
+3 SET SUBJ="VueCentric Installation at "_$GET(^XMB("NETNAME"))
+4 SET @GBL@(1)="VueCentric has just been installed at: "_$GET(^XMB("NETNAME"))_"."
+5 SET @GBL@(2)="Version #: "_$PIECE($TEXT(+2),";",3)
+6 SET @GBL@(3)="Installer: "_$PIECE($GET(^VA(200,+$GET(DUZ),0)),U)
+7 SET RECP("mail@ciainformatics.com")=""
+8 DO SENDMSG^XMXAPI(DUZ,SUBJ,GBL,.RECP)
+9 KILL @GBL
+10 QUIT
