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

DG53P650.m

Go to the documentation of this file.
  1. DG53P650 ;ALB/KCL - PATCH DG*5.3*650 INSTALL UTILITIES ; 7/12/06 09:12am
  1. ;;5.3;Registration;**650**;Aug 13, 1993;Build 3
  1. ;
  1. QUIT
  1. ;
  1. ;--------------------------------------------------------------
  1. ;Patch DG*5.3*650: Environment, Pre-Install, and Post-Install
  1. ;entry points.
  1. ;--------------------------------------------------------------
  1. ;
  1. ENV ;Main entry point for Environment check point
  1. ;
  1. S XPDABORT=""
  1. D PROGCHK(.XPDABORT) ;checks programmer variables
  1. I XPDABORT="" K XPDABORT
  1. Q
  1. ;
  1. PRE ;Main entry point for Pre-Install items
  1. ;
  1. D PRE1 ;rename security key
  1. D PRE2 ;delete obsolete security keys
  1. Q
  1. ;
  1. POST ;Main entry point for Post-Install items
  1. ;
  1. ;
  1. D POST1 ;set query try limit parameter
  1. D POST2 ;enable primary site for PRF Assignment ownership
  1. D POST3 ;build "AOWN" index on file #26.13
  1. Q
  1. ;
  1. ;
  1. PROGCHK(XPDABORT) ;Checks for necessary programmer variables
  1. ;
  1. I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") DO
  1. .D BMES^XPDUTL("*****")
  1. .D MES^XPDUTL("Your programming variables are not set up properly.")
  1. .D MES^XPDUTL("Installation aborted.")
  1. .D MES^XPDUTL("*****")
  1. .S XPDABORT=2
  1. Q
  1. ;
  1. PRE1 ;Rename security keys
  1. ;
  1. N DGI,DGOLD,DGNEW
  1. ;
  1. S DGOLD(1)="DGPF RECORD FLAG ASSIGNMENT" ;old name
  1. S DGNEW(1)="DGPF ASSIGNMENT" ;new name
  1. ;
  1. S DGOLD(2)="DGPF LOCAL FLAG EDIT" ;old name
  1. S DGNEW(2)="DGPF MANAGER" ;new name
  1. ;
  1. D BMES^XPDUTL("*****")
  1. D MES^XPDUTL("Attempting to rename security keys...")
  1. ;
  1. ;loop through keys
  1. S DGI=0
  1. F S DGI=$O(DGOLD(DGI)) Q:'DGI D ;drops out of DO block on failure
  1. . ;
  1. . ;quit if key already renamed
  1. . I +$$LKUP^XPDKEY(DGNEW(DGI)) D Q
  1. . . D MES^XPDUTL("Security key "_DGOLD(DGI)_" already renamed to "_DGNEW(DGI)_".")
  1. . ;
  1. . ;attempt to rename key
  1. . I '$$RENAME^XPDKEY(DGOLD(DGI),DGNEW(DGI)) D Q
  1. . . D MES^XPDUTL("Could not rename "_DGOLD(DGI)_" security key.")
  1. . ;
  1. . D MES^XPDUTL("Security key "_DGOLD(DGI)_" renamed to "_DGNEW(DGI)_".")
  1. ;
  1. D MES^XPDUTL("*****")
  1. Q
  1. ;
  1. PRE2 ;Delete obsolete security keys
  1. ;
  1. N DGIEN,DGNAME
  1. ;
  1. D BMES^XPDUTL("*****")
  1. D MES^XPDUTL("Attempting to delete obsolete security keys...")
  1. ;
  1. ;loop thru obsolete keys
  1. F DGNAME="DGPF PRF ACCESS","DGPF PRF CONFIG" D
  1. . ;
  1. . ;lookup key
  1. . S DGIEN=$$LKUP^XPDKEY(DGNAME)
  1. . ;
  1. . ;quit with msg if key lookup fails
  1. . I '+$G(DGIEN) D Q
  1. . . D MES^XPDUTL("Security key "_DGNAME_" already deleted.")
  1. . ;
  1. . ;delete key
  1. . D DEL^XPDKEY(+$G(DGIEN))
  1. . D MES^XPDUTL("Security key "_DGNAME_" deleted. IEN="_DGIEN_".")
  1. ;
  1. D MES^XPDUTL("*****")
  1. Q
  1. ;
  1. POST1 ;set query try limit parameter
  1. ;
  1. N DGERR ;XPAR error result
  1. N DGPARM ;parameter name
  1. N DGRETRY ;# of retries
  1. ;
  1. S DGPARM="DGPF QUERY TRY LIMIT"
  1. S DGRETRY=5
  1. D EN^XPAR("PKG",DGPARM,1,DGRETRY,.DGERR)
  1. D BMES^XPDUTL("*****")
  1. I '$G(DGERR) D
  1. . D MES^XPDUTL(DGPARM_" parameter set to "_DGRETRY_" SUCCESSFULLY")
  1. E D
  1. . D MES^XPDUTL(DGPARM_" parameter set FAILED")
  1. D MES^XPDUTL("*****")
  1. ;
  1. Q
  1. ;
  1. POST2 ;enable primary site for PRF Assignment ownership
  1. ;
  1. N DGDIV ;pointer to MEDICAL CENTER DIVISION (#40.8) file
  1. N DGSITE ;$$SITE results
  1. ;
  1. S DGSITE=$$SITE^VASITE()
  1. S DGDIV=+$O(^DG(40.8,"AD",+DGSITE,0))
  1. D BMES^XPDUTL("*****")
  1. I DGDIV,$$STODIV^DGPFDIV1(DGDIV,1) D
  1. . D MES^XPDUTL($P(DGSITE,U,2)_" enabled for PRF Assignment ownership SUCCESSFULLY")
  1. E D
  1. . D MES^XPDUTL("Attempt to enable primary site for PRF Assignment ownership FAILED")
  1. D MES^XPDUTL("*****")
  1. ;
  1. Q
  1. ;
  1. POST3 ;populate "AOWN" index of PRF ASSIGNMENT (#26.13) file
  1. ;
  1. N DIK
  1. ;
  1. S DIK="^DGPF(26.13,"
  1. S DIK(1)=".04^AOWN"
  1. D ENALL^DIK
  1. ;
  1. Q