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

PSO690PI.m

Go to the documentation of this file. 
  1. PSO690PI ;HDSO/TTN - PS0*7.0*690 Post-install routine; Sep 28, 2022@15:00
  1.  ;;7.0;OUTPATIENT PHARMACY;**690**;DEC 1997;Build 15
  1.  ;
  1.  ; This post-install routine removes duplicate "RR" entries in 
  1.  ; protocol from the PSO LM HIDDEN OTHER and PSO LM HIDDEN OTHER #2 
  1.  ; protocols/menus. It also provides a method to restore the version of those 
  1.  ; menus prior to the installation via the RESTORE tag. That subroutine must 
  1.  ; be run from the programmer prompt.
  1.  ;
  1.  ; Reference to XREF^XQORM supported by ICR #10140
  1.  ;
  1.  Q  ; Must call from a specific tag. Call EN to start the process
  1.  ;
  1. EN ; Entry point for this post-install routine
  1.  N DA,DIE,DIK,PRTCIEN,PRTCNM,FOUND,XQORM,RRIEN
  1.  N DUPFLAG,PRTCITMIEN,RXRFLDATA,RXRFLMNMC,RXRFLIEN,RXRFLNM
  1.  ;
  1.  D BMES^XPDUTL("*** Starting RR Duplicate Search for PSO*7*690 ***")
  1.  W !
  1.  K ^XTMP("PSO*7.0*690 POST INSTALL")
  1.  S ^XTMP("PSO*7.0*690 POST INSTALL",0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^PSO*7.0*690 POST INSTALL"
  1.  ;
  1.  F PRTCNM="PSO LM HIDDEN OTHER","PSO LM HIDDEN OTHER #2" D MAIN
  1.  ;
  1.  D BMES^XPDUTL("*** RR Duplicate Search for PSO*7*690 COMPLETED ***")
  1.  Q
  1.  ;
  1. MAIN ; Main processing for this patch
  1.  S FOUND=0,RRIEN=""
  1.  S PRTCIEN=+$O(^ORD(101,"B",PRTCNM,""))
  1.  Q:PRTCIEN=""
  1.  S XQORM=PRTCIEN_";ORD(101,"
  1.  ;Save ^XUTL in case back out of the patch is necessary.
  1.  M ^XTMP("PSO*7.0*690 POST INSTALL","XUTL",PRTCIEN)=^XUTL("XQORM",XQORM)
  1.  ;Keeping a complete picture of the protocol in case there are questions.
  1.  M ^XTMP("PSO*7.0*690 POST INSTALL",101,PRTCIEN)=^ORD(101,PRTCIEN)
  1.  ;Check for dup "RR" in ORD(101) globals
  1.  D ORD101
  1.  ; Below is check for dup "RR" in XUTL globals
  1.  F  S RRIEN=$O(^XUTL("XQORM",XQORM,"B","RR",RRIEN)) Q:'RRIEN  S FOUND=FOUND+1
  1.  I FOUND<2 D  Q
  1.  . D MES^XPDUTL("     * No Duplicate RR entries found in the XUTL global for the")
  1.  . D MES^XPDUTL("       "_PRTCNM_" protocol. Search Completed. *")
  1.  . Q
  1.  ; If we get here,we've found a dup record and we will recompiling to remove the dup.
  1.  D MES^XPDUTL("     * Duplicate RR entries have been found ")
  1.  D MES^XPDUTL("     * in the XUTL global for the "_PRTCNM_" protocol ... *")
  1.  W !
  1.  D MES^XPDUTL("     * Recompiling the "_PRTCNM_" protocol XUTL global... *")
  1.  W !
  1.  D XREF^XQORM
  1.  ;Save in case patch needs to be backed out.
  1.  S ^XTMP("PSO*7.0*690 POST INSTALL","XUTL_DUP",XQORM)=""
  1.  Q
  1.  ;
  1. ORD101 ; Check for dup "RR" in ORD(101) globals
  1.  N PRITM101
  1.  S (DUPFLAG,PRTCITMIEN)=0
  1.  F  S PRTCITMIEN=$O(^ORD(101,PRTCIEN,10,PRTCITMIEN)) Q:'PRTCITMIEN  D
  1.  . S RXRFLDATA=$G(^ORD(101,PRTCIEN,10,PRTCITMIEN,0)) Q:RXRFLDATA=""
  1.  . S RXRFLMNMC=$P(RXRFLDATA,U,2) Q:RXRFLMNMC'="RR"
  1.  . S RXRFLIEN=$P(RXRFLDATA,U,1) Q:RXRFLIEN=""
  1.  . S RXRFLNM=$$GET1^DIQ(101,RXRFLIEN,1,"E")
  1.  . Q:(RXRFLNM="RxRenewal Request")  ; This is the correct entry so don't touch
  1.  . S DUPFLAG=1
  1.  . ; If we get here, then we've found a record needing to be deleted
  1.  . ;Save in case patch needs to be backed out.
  1.  . S PRITM101=$P(^ORD(101,PRTCIEN,10,PRTCITMIEN,0),"^")
  1.  . S ^XTMP("PSO*7.0*690 POST INSTALL","DEL_101",PRTCIEN,PRITM101)=""
  1.  . S DA(1)=PRTCIEN,DA=PRTCITMIEN,DIK="^ORD(101,"_DA(1)_",10,"
  1.  . D ^DIK
  1.  . D MES^XPDUTL("     * The '"_RXRFLNM_"' menu option has been")
  1.  . D MES^XPDUTL("       removed from the "_PRTCNM_" protocol. *")
  1.  . W !
  1.  . I '$G(DUPFLAG) D
  1.  .. D MES^XPDUTL("     * No RR entries have been found ")
  1.  .. D MES^XPDUTL("     * in the "_PRTCNM_" protocol ... *")
  1.  .. W !
  1.  .. Q
  1.  Q
  1.  ;
  1.  ; ----------------------------------------------------------------------------
  1. RESTORE ; Restore the previously backed up entry
  1.  W #
  1.  N DIR,Y,PRTCIEN,PRTCNM,XQORM
  1.  S DIR("A",1)="WARNING - This action will restore the 'PSO LM HIDDEN OTHER' and/or"
  1.  S DIR("A",2)="'PSO LM HIDDEN OTHER #2' protocol(s) to their setup prior to the"
  1.  S DIR("A",3)="installation of PSO*7.0*690."
  1.  S DIR("A",4)=""
  1.  S DIR("A")="Are you sure you wish to proceed",DIR("B")="NO",DIR(0)="Y"
  1.  D ^DIR
  1.  Q:Y<1
  1.  ;
  1.  ; Be sure we still have the backup global
  1.  I '$D(^XTMP("PSO*7.0*690 POST INSTALL")) D BMES^XPDUTL("*** No backup entry found. Not able to proceed. Quitting! ***") Q
  1.  ;
  1.  D BMES^XPDUTL("*** Starting global restore from backup for the PSO*7.0*690 installation ***")
  1.  ;
  1.  F PRTCNM="PSO LM HIDDEN OTHER","PSO LM HIDDEN OTHER #2" D
  1.  . S PRTCIEN=+$O(^ORD(101,"B",PRTCNM,""))
  1.  . I 'PRTCIEN D BMES^XPDUTL("  ** No current "_PRTCNM_" protocol record found. Quitting! **") Q
  1.  . S XQORM=PRTCIEN_";ORD(101,"
  1.  . I $D(^XTMP("PSO*7.0*690 POST INSTALL","XUTL_DUP",XQORM)) D
  1.  . . K ^XUTL("XQORM",XQORM)
  1.  . . M ^XUTL("XQORM",XQORM)=^XTMP("PSO*7.0*690 POST INSTALL","XUTL",PRTCIEN)
  1.  . . D BMES^XPDUTL("  ** "_PRTCNM_" protocol ^XUTL global restored successfully **")
  1.  . Q:'$D(^XTMP("PSO*7.0*690 POST INSTALL","DEL_101",PRTCIEN))
  1.  . N DIC,DR,DA,X
  1.  . S DIC="^ORD(101,"_PRTCIEN_",10,",DIC(0)=""
  1.  . S DA(1)=PRTCIEN
  1.  . S DA=""
  1.  . F  S DA=$O(^XTMP("PSO*7.0*690 POST INSTALL","DEL_101",PRTCIEN,DA)) Q:DA=""  D
  1.  . . S DIC("DR")=".01///"_DA_";2///RR",X=DA
  1.  . . D FILE^DICN
  1.  . D BMES^XPDUTL("  ** "_PRTCNM_" protocol IEN "_PRTCIEN_" restored successfully **")
  1.  . Q
  1.  ;
  1.  D BMES^XPDUTL("*** Restore from backup for the PSO*7.0*690 installation complete ***")
  1.  Q