- 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 Feb 19, 2025@00:06:04 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