DG53P650 ;ALB/KCL - PATCH DG*5.3*650 INSTALL UTILITIES ; 7/12/06 09:12am
;;5.3;Registration;**650**;Aug 13, 1993;Build 3
;
QUIT
;
;--------------------------------------------------------------
;Patch DG*5.3*650: Environment, Pre-Install, and Post-Install
;entry points.
;--------------------------------------------------------------
;
ENV ;Main entry point for Environment check point
;
S XPDABORT=""
D PROGCHK(.XPDABORT) ;checks programmer variables
I XPDABORT="" K XPDABORT
Q
;
PRE ;Main entry point for Pre-Install items
;
D PRE1 ;rename security key
D PRE2 ;delete obsolete security keys
Q
;
POST ;Main entry point for Post-Install items
;
;
D POST1 ;set query try limit parameter
D POST2 ;enable primary site for PRF Assignment ownership
D POST3 ;build "AOWN" index on file #26.13
Q
;
;
PROGCHK(XPDABORT) ;Checks for necessary programmer variables
;
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") DO
.D BMES^XPDUTL("*****")
.D MES^XPDUTL("Your programming variables are not set up properly.")
.D MES^XPDUTL("Installation aborted.")
.D MES^XPDUTL("*****")
.S XPDABORT=2
Q
;
PRE1 ;Rename security keys
;
N DGI,DGOLD,DGNEW
;
S DGOLD(1)="DGPF RECORD FLAG ASSIGNMENT" ;old name
S DGNEW(1)="DGPF ASSIGNMENT" ;new name
;
S DGOLD(2)="DGPF LOCAL FLAG EDIT" ;old name
S DGNEW(2)="DGPF MANAGER" ;new name
;
D BMES^XPDUTL("*****")
D MES^XPDUTL("Attempting to rename security keys...")
;
;loop through keys
S DGI=0
F S DGI=$O(DGOLD(DGI)) Q:'DGI D ;drops out of DO block on failure
. ;
. ;quit if key already renamed
. I +$$LKUP^XPDKEY(DGNEW(DGI)) D Q
. . D MES^XPDUTL("Security key "_DGOLD(DGI)_" already renamed to "_DGNEW(DGI)_".")
. ;
. ;attempt to rename key
. I '$$RENAME^XPDKEY(DGOLD(DGI),DGNEW(DGI)) D Q
. . D MES^XPDUTL("Could not rename "_DGOLD(DGI)_" security key.")
. ;
. D MES^XPDUTL("Security key "_DGOLD(DGI)_" renamed to "_DGNEW(DGI)_".")
;
D MES^XPDUTL("*****")
Q
;
PRE2 ;Delete obsolete security keys
;
N DGIEN,DGNAME
;
D BMES^XPDUTL("*****")
D MES^XPDUTL("Attempting to delete obsolete security keys...")
;
;loop thru obsolete keys
F DGNAME="DGPF PRF ACCESS","DGPF PRF CONFIG" D
. ;
. ;lookup key
. S DGIEN=$$LKUP^XPDKEY(DGNAME)
. ;
. ;quit with msg if key lookup fails
. I '+$G(DGIEN) D Q
. . D MES^XPDUTL("Security key "_DGNAME_" already deleted.")
. ;
. ;delete key
. D DEL^XPDKEY(+$G(DGIEN))
. D MES^XPDUTL("Security key "_DGNAME_" deleted. IEN="_DGIEN_".")
;
D MES^XPDUTL("*****")
Q
;
POST1 ;set query try limit parameter
;
N DGERR ;XPAR error result
N DGPARM ;parameter name
N DGRETRY ;# of retries
;
S DGPARM="DGPF QUERY TRY LIMIT"
S DGRETRY=5
D EN^XPAR("PKG",DGPARM,1,DGRETRY,.DGERR)
D BMES^XPDUTL("*****")
I '$G(DGERR) D
. D MES^XPDUTL(DGPARM_" parameter set to "_DGRETRY_" SUCCESSFULLY")
E D
. D MES^XPDUTL(DGPARM_" parameter set FAILED")
D MES^XPDUTL("*****")
;
Q
;
POST2 ;enable primary site for PRF Assignment ownership
;
N DGDIV ;pointer to MEDICAL CENTER DIVISION (#40.8) file
N DGSITE ;$$SITE results
;
S DGSITE=$$SITE^VASITE()
S DGDIV=+$O(^DG(40.8,"AD",+DGSITE,0))
D BMES^XPDUTL("*****")
I DGDIV,$$STODIV^DGPFDIV1(DGDIV,1) D
. D MES^XPDUTL($P(DGSITE,U,2)_" enabled for PRF Assignment ownership SUCCESSFULLY")
E D
. D MES^XPDUTL("Attempt to enable primary site for PRF Assignment ownership FAILED")
D MES^XPDUTL("*****")
;
Q
;
POST3 ;populate "AOWN" index of PRF ASSIGNMENT (#26.13) file
;
N DIK
;
S DIK="^DGPF(26.13,"
S DIK(1)=".04^AOWN"
D ENALL^DIK
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53P650 3715 printed Apr 09, 2024@21:40:45 Page 2
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
+2 ;
+3 QUIT
+4 ;
+5 ;--------------------------------------------------------------
+6 ;Patch DG*5.3*650: Environment, Pre-Install, and Post-Install
+7 ;entry points.
+8 ;--------------------------------------------------------------
+9 ;
ENV ;Main entry point for Environment check point
+1 ;
+2 SET XPDABORT=""
+3 ;checks programmer variables
DO PROGCHK(.XPDABORT)
+4 IF XPDABORT=""
KILL XPDABORT
+5 QUIT
+6 ;
PRE ;Main entry point for Pre-Install items
+1 ;
+2 ;rename security key
DO PRE1
+3 ;delete obsolete security keys
DO PRE2
+4 QUIT
+5 ;
POST ;Main entry point for Post-Install items
+1 ;
+2 ;
+3 ;set query try limit parameter
DO POST1
+4 ;enable primary site for PRF Assignment ownership
DO POST2
+5 ;build "AOWN" index on file #26.13
DO POST3
+6 QUIT
+7 ;
+8 ;
PROGCHK(XPDABORT) ;Checks for necessary programmer variables
+1 ;
+2 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+3 DO BMES^XPDUTL("*****")
+4 DO MES^XPDUTL("Your programming variables are not set up properly.")
+5 DO MES^XPDUTL("Installation aborted.")
+6 DO MES^XPDUTL("*****")
+7 SET XPDABORT=2
End DoDot:1
+8 QUIT
+9 ;
PRE1 ;Rename security keys
+1 ;
+2 NEW DGI,DGOLD,DGNEW
+3 ;
+4 ;old name
SET DGOLD(1)="DGPF RECORD FLAG ASSIGNMENT"
+5 ;new name
SET DGNEW(1)="DGPF ASSIGNMENT"
+6 ;
+7 ;old name
SET DGOLD(2)="DGPF LOCAL FLAG EDIT"
+8 ;new name
SET DGNEW(2)="DGPF MANAGER"
+9 ;
+10 DO BMES^XPDUTL("*****")
+11 DO MES^XPDUTL("Attempting to rename security keys...")
+12 ;
+13 ;loop through keys
+14 SET DGI=0
+15 ;drops out of DO block on failure
FOR
SET DGI=$ORDER(DGOLD(DGI))
if 'DGI
QUIT
Begin DoDot:1
+16 ;
+17 ;quit if key already renamed
+18 IF +$$LKUP^XPDKEY(DGNEW(DGI))
Begin DoDot:2
+19 DO MES^XPDUTL("Security key "_DGOLD(DGI)_" already renamed to "_DGNEW(DGI)_".")
End DoDot:2
QUIT
+20 ;
+21 ;attempt to rename key
+22 IF '$$RENAME^XPDKEY(DGOLD(DGI),DGNEW(DGI))
Begin DoDot:2
+23 DO MES^XPDUTL("Could not rename "_DGOLD(DGI)_" security key.")
End DoDot:2
QUIT
+24 ;
+25 DO MES^XPDUTL("Security key "_DGOLD(DGI)_" renamed to "_DGNEW(DGI)_".")
End DoDot:1
+26 ;
+27 DO MES^XPDUTL("*****")
+28 QUIT
+29 ;
PRE2 ;Delete obsolete security keys
+1 ;
+2 NEW DGIEN,DGNAME
+3 ;
+4 DO BMES^XPDUTL("*****")
+5 DO MES^XPDUTL("Attempting to delete obsolete security keys...")
+6 ;
+7 ;loop thru obsolete keys
+8 FOR DGNAME="DGPF PRF ACCESS","DGPF PRF CONFIG"
Begin DoDot:1
+9 ;
+10 ;lookup key
+11 SET DGIEN=$$LKUP^XPDKEY(DGNAME)
+12 ;
+13 ;quit with msg if key lookup fails
+14 IF '+$GET(DGIEN)
Begin DoDot:2
+15 DO MES^XPDUTL("Security key "_DGNAME_" already deleted.")
End DoDot:2
QUIT
+16 ;
+17 ;delete key
+18 DO DEL^XPDKEY(+$GET(DGIEN))
+19 DO MES^XPDUTL("Security key "_DGNAME_" deleted. IEN="_DGIEN_".")
End DoDot:1
+20 ;
+21 DO MES^XPDUTL("*****")
+22 QUIT
+23 ;
POST1 ;set query try limit parameter
+1 ;
+2 ;XPAR error result
NEW DGERR
+3 ;parameter name
NEW DGPARM
+4 ;# of retries
NEW DGRETRY
+5 ;
+6 SET DGPARM="DGPF QUERY TRY LIMIT"
+7 SET DGRETRY=5
+8 DO EN^XPAR("PKG",DGPARM,1,DGRETRY,.DGERR)
+9 DO BMES^XPDUTL("*****")
+10 IF '$GET(DGERR)
Begin DoDot:1
+11 DO MES^XPDUTL(DGPARM_" parameter set to "_DGRETRY_" SUCCESSFULLY")
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 DO MES^XPDUTL(DGPARM_" parameter set FAILED")
End DoDot:1
+14 DO MES^XPDUTL("*****")
+15 ;
+16 QUIT
+17 ;
POST2 ;enable primary site for PRF Assignment ownership
+1 ;
+2 ;pointer to MEDICAL CENTER DIVISION (#40.8) file
NEW DGDIV
+3 ;$$SITE results
NEW DGSITE
+4 ;
+5 SET DGSITE=$$SITE^VASITE()
+6 SET DGDIV=+$ORDER(^DG(40.8,"AD",+DGSITE,0))
+7 DO BMES^XPDUTL("*****")
+8 IF DGDIV
IF $$STODIV^DGPFDIV1(DGDIV,1)
Begin DoDot:1
+9 DO MES^XPDUTL($PIECE(DGSITE,U,2)_" enabled for PRF Assignment ownership SUCCESSFULLY")
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 DO MES^XPDUTL("Attempt to enable primary site for PRF Assignment ownership FAILED")
End DoDot:1
+12 DO MES^XPDUTL("*****")
+13 ;
+14 QUIT
+15 ;
POST3 ;populate "AOWN" index of PRF ASSIGNMENT (#26.13) file
+1 ;
+2 NEW DIK
+3 ;
+4 SET DIK="^DGPF(26.13,"
+5 SET DIK(1)=".04^AOWN"
+6 DO ENALL^DIK
+7 ;
+8 QUIT
