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

CIAVINIT.m

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