PSO690PI ;HDSO/TTN - PS0*7.0*690 Post-install routine; Sep 28, 2022@15:00
;;7.0;OUTPATIENT PHARMACY;**690**;DEC 1997;Build 15
;
; This post-install routine removes duplicate "RR" entries in
; protocol from the PSO LM HIDDEN OTHER and PSO LM HIDDEN OTHER #2
; protocols/menus. It also provides a method to restore the version of those
; menus prior to the installation via the RESTORE tag. That subroutine must
; be run from the programmer prompt.
;
; Reference to XREF^XQORM supported by ICR #10140
;
Q ; Must call from a specific tag. Call EN to start the process
;
EN ; Entry point for this post-install routine
N DA,DIE,DIK,PRTCIEN,PRTCNM,FOUND,XQORM,RRIEN
N DUPFLAG,PRTCITMIEN,RXRFLDATA,RXRFLMNMC,RXRFLIEN,RXRFLNM
;
D BMES^XPDUTL("*** Starting RR Duplicate Search for PSO*7*690 ***")
W !
K ^XTMP("PSO*7.0*690 POST INSTALL")
S ^XTMP("PSO*7.0*690 POST INSTALL",0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^PSO*7.0*690 POST INSTALL"
;
F PRTCNM="PSO LM HIDDEN OTHER","PSO LM HIDDEN OTHER #2" D MAIN
;
D BMES^XPDUTL("*** RR Duplicate Search for PSO*7*690 COMPLETED ***")
Q
;
MAIN ; Main processing for this patch
S FOUND=0,RRIEN=""
S PRTCIEN=+$O(^ORD(101,"B",PRTCNM,""))
Q:PRTCIEN=""
S XQORM=PRTCIEN_";ORD(101,"
;Save ^XUTL in case back out of the patch is necessary.
M ^XTMP("PSO*7.0*690 POST INSTALL","XUTL",PRTCIEN)=^XUTL("XQORM",XQORM)
;Keeping a complete picture of the protocol in case there are questions.
M ^XTMP("PSO*7.0*690 POST INSTALL",101,PRTCIEN)=^ORD(101,PRTCIEN)
;Check for dup "RR" in ORD(101) globals
D ORD101
; Below is check for dup "RR" in XUTL globals
F S RRIEN=$O(^XUTL("XQORM",XQORM,"B","RR",RRIEN)) Q:'RRIEN S FOUND=FOUND+1
I FOUND<2 D Q
. D MES^XPDUTL(" * No Duplicate RR entries found in the XUTL global for the")
. D MES^XPDUTL(" "_PRTCNM_" protocol. Search Completed. *")
. Q
; If we get here,we've found a dup record and we will recompiling to remove the dup.
D MES^XPDUTL(" * Duplicate RR entries have been found ")
D MES^XPDUTL(" * in the XUTL global for the "_PRTCNM_" protocol ... *")
W !
D MES^XPDUTL(" * Recompiling the "_PRTCNM_" protocol XUTL global... *")
W !
D XREF^XQORM
;Save in case patch needs to be backed out.
S ^XTMP("PSO*7.0*690 POST INSTALL","XUTL_DUP",XQORM)=""
Q
;
ORD101 ; Check for dup "RR" in ORD(101) globals
N PRITM101
S (DUPFLAG,PRTCITMIEN)=0
F S PRTCITMIEN=$O(^ORD(101,PRTCIEN,10,PRTCITMIEN)) Q:'PRTCITMIEN D
. S RXRFLDATA=$G(^ORD(101,PRTCIEN,10,PRTCITMIEN,0)) Q:RXRFLDATA=""
. S RXRFLMNMC=$P(RXRFLDATA,U,2) Q:RXRFLMNMC'="RR"
. S RXRFLIEN=$P(RXRFLDATA,U,1) Q:RXRFLIEN=""
. S RXRFLNM=$$GET1^DIQ(101,RXRFLIEN,1,"E")
. Q:(RXRFLNM="RxRenewal Request") ; This is the correct entry so don't touch
. S DUPFLAG=1
. ; If we get here, then we've found a record needing to be deleted
. ;Save in case patch needs to be backed out.
. S PRITM101=$P(^ORD(101,PRTCIEN,10,PRTCITMIEN,0),"^")
. S ^XTMP("PSO*7.0*690 POST INSTALL","DEL_101",PRTCIEN,PRITM101)=""
. S DA(1)=PRTCIEN,DA=PRTCITMIEN,DIK="^ORD(101,"_DA(1)_",10,"
. D ^DIK
. D MES^XPDUTL(" * The '"_RXRFLNM_"' menu option has been")
. D MES^XPDUTL(" removed from the "_PRTCNM_" protocol. *")
. W !
. I '$G(DUPFLAG) D
.. D MES^XPDUTL(" * No RR entries have been found ")
.. D MES^XPDUTL(" * in the "_PRTCNM_" protocol ... *")
.. W !
.. Q
Q
;
; ----------------------------------------------------------------------------
RESTORE ; Restore the previously backed up entry
W #
N DIR,Y,PRTCIEN,PRTCNM,XQORM
S DIR("A",1)="WARNING - This action will restore the 'PSO LM HIDDEN OTHER' and/or"
S DIR("A",2)="'PSO LM HIDDEN OTHER #2' protocol(s) to their setup prior to the"
S DIR("A",3)="installation of PSO*7.0*690."
S DIR("A",4)=""
S DIR("A")="Are you sure you wish to proceed",DIR("B")="NO",DIR(0)="Y"
D ^DIR
Q:Y<1
;
; Be sure we still have the backup global
I '$D(^XTMP("PSO*7.0*690 POST INSTALL")) D BMES^XPDUTL("*** No backup entry found. Not able to proceed. Quitting! ***") Q
;
D BMES^XPDUTL("*** Starting global restore from backup for the PSO*7.0*690 installation ***")
;
F PRTCNM="PSO LM HIDDEN OTHER","PSO LM HIDDEN OTHER #2" D
. S PRTCIEN=+$O(^ORD(101,"B",PRTCNM,""))
. I 'PRTCIEN D BMES^XPDUTL(" ** No current "_PRTCNM_" protocol record found. Quitting! **") Q
. S XQORM=PRTCIEN_";ORD(101,"
. I $D(^XTMP("PSO*7.0*690 POST INSTALL","XUTL_DUP",XQORM)) D
. . K ^XUTL("XQORM",XQORM)
. . M ^XUTL("XQORM",XQORM)=^XTMP("PSO*7.0*690 POST INSTALL","XUTL",PRTCIEN)
. . D BMES^XPDUTL(" ** "_PRTCNM_" protocol ^XUTL global restored successfully **")
. Q:'$D(^XTMP("PSO*7.0*690 POST INSTALL","DEL_101",PRTCIEN))
. N DIC,DR,DA,X
. S DIC="^ORD(101,"_PRTCIEN_",10,",DIC(0)=""
. S DA(1)=PRTCIEN
. S DA=""
. F S DA=$O(^XTMP("PSO*7.0*690 POST INSTALL","DEL_101",PRTCIEN,DA)) Q:DA="" D
. . S DIC("DR")=".01///"_DA_";2///RR",X=DA
. . D FILE^DICN
. D BMES^XPDUTL(" ** "_PRTCNM_" protocol IEN "_PRTCIEN_" restored successfully **")
. Q
;
D BMES^XPDUTL("*** Restore from backup for the PSO*7.0*690 installation complete ***")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO690PI 5182 printed Nov 22, 2024@17:33:30 Page 2
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
+2 ;
+3 ; This post-install routine removes duplicate "RR" entries in
+4 ; protocol from the PSO LM HIDDEN OTHER and PSO LM HIDDEN OTHER #2
+5 ; protocols/menus. It also provides a method to restore the version of those
+6 ; menus prior to the installation via the RESTORE tag. That subroutine must
+7 ; be run from the programmer prompt.
+8 ;
+9 ; Reference to XREF^XQORM supported by ICR #10140
+10 ;
+11 ; Must call from a specific tag. Call EN to start the process
QUIT
+12 ;
EN ; Entry point for this post-install routine
+1 NEW DA,DIE,DIK,PRTCIEN,PRTCNM,FOUND,XQORM,RRIEN
+2 NEW DUPFLAG,PRTCITMIEN,RXRFLDATA,RXRFLMNMC,RXRFLIEN,RXRFLNM
+3 ;
+4 DO BMES^XPDUTL("*** Starting RR Duplicate Search for PSO*7*690 ***")
+5 WRITE !
+6 KILL ^XTMP("PSO*7.0*690 POST INSTALL")
+7 SET ^XTMP("PSO*7.0*690 POST INSTALL",0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^PSO*7.0*690 POST INSTALL"
+8 ;
+9 FOR PRTCNM="PSO LM HIDDEN OTHER","PSO LM HIDDEN OTHER #2"
DO MAIN
+10 ;
+11 DO BMES^XPDUTL("*** RR Duplicate Search for PSO*7*690 COMPLETED ***")
+12 QUIT
+13 ;
MAIN ; Main processing for this patch
+1 SET FOUND=0
SET RRIEN=""
+2 SET PRTCIEN=+$ORDER(^ORD(101,"B",PRTCNM,""))
+3 if PRTCIEN=""
QUIT
+4 SET XQORM=PRTCIEN_";ORD(101,"
+5 ;Save ^XUTL in case back out of the patch is necessary.
+6 MERGE ^XTMP("PSO*7.0*690 POST INSTALL","XUTL",PRTCIEN)=^XUTL("XQORM",XQORM)
+7 ;Keeping a complete picture of the protocol in case there are questions.
+8 MERGE ^XTMP("PSO*7.0*690 POST INSTALL",101,PRTCIEN)=^ORD(101,PRTCIEN)
+9 ;Check for dup "RR" in ORD(101) globals
+10 DO ORD101
+11 ; Below is check for dup "RR" in XUTL globals
+12 FOR
SET RRIEN=$ORDER(^XUTL("XQORM",XQORM,"B","RR",RRIEN))
if 'RRIEN
QUIT
SET FOUND=FOUND+1
+13 IF FOUND<2
Begin DoDot:1
+14 DO MES^XPDUTL(" * No Duplicate RR entries found in the XUTL global for the")
+15 DO MES^XPDUTL(" "_PRTCNM_" protocol. Search Completed. *")
+16 QUIT
End DoDot:1
QUIT
+17 ; If we get here,we've found a dup record and we will recompiling to remove the dup.
+18 DO MES^XPDUTL(" * Duplicate RR entries have been found ")
+19 DO MES^XPDUTL(" * in the XUTL global for the "_PRTCNM_" protocol ... *")
+20 WRITE !
+21 DO MES^XPDUTL(" * Recompiling the "_PRTCNM_" protocol XUTL global... *")
+22 WRITE !
+23 DO XREF^XQORM
+24 ;Save in case patch needs to be backed out.
+25 SET ^XTMP("PSO*7.0*690 POST INSTALL","XUTL_DUP",XQORM)=""
+26 QUIT
+27 ;
ORD101 ; Check for dup "RR" in ORD(101) globals
+1 NEW PRITM101
+2 SET (DUPFLAG,PRTCITMIEN)=0
+3 FOR
SET PRTCITMIEN=$ORDER(^ORD(101,PRTCIEN,10,PRTCITMIEN))
if 'PRTCITMIEN
QUIT
Begin DoDot:1
+4 SET RXRFLDATA=$GET(^ORD(101,PRTCIEN,10,PRTCITMIEN,0))
if RXRFLDATA=""
QUIT
+5 SET RXRFLMNMC=$PIECE(RXRFLDATA,U,2)
if RXRFLMNMC'="RR"
QUIT
+6 SET RXRFLIEN=$PIECE(RXRFLDATA,U,1)
if RXRFLIEN=""
QUIT
+7 SET RXRFLNM=$$GET1^DIQ(101,RXRFLIEN,1,"E")
+8 ; This is the correct entry so don't touch
if (RXRFLNM="RxRenewal Request")
QUIT
+9 SET DUPFLAG=1
+10 ; If we get here, then we've found a record needing to be deleted
+11 ;Save in case patch needs to be backed out.
+12 SET PRITM101=$PIECE(^ORD(101,PRTCIEN,10,PRTCITMIEN,0),"^")
+13 SET ^XTMP("PSO*7.0*690 POST INSTALL","DEL_101",PRTCIEN,PRITM101)=""
+14 SET DA(1)=PRTCIEN
SET DA=PRTCITMIEN
SET DIK="^ORD(101,"_DA(1)_",10,"
+15 DO ^DIK
+16 DO MES^XPDUTL(" * The '"_RXRFLNM_"' menu option has been")
+17 DO MES^XPDUTL(" removed from the "_PRTCNM_" protocol. *")
+18 WRITE !
+19 IF '$GET(DUPFLAG)
Begin DoDot:2
+20 DO MES^XPDUTL(" * No RR entries have been found ")
+21 DO MES^XPDUTL(" * in the "_PRTCNM_" protocol ... *")
+22 WRITE !
+23 QUIT
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
+26 ; ----------------------------------------------------------------------------
RESTORE ; Restore the previously backed up entry
+1 WRITE #
+2 NEW DIR,Y,PRTCIEN,PRTCNM,XQORM
+3 SET DIR("A",1)="WARNING - This action will restore the 'PSO LM HIDDEN OTHER' and/or"
+4 SET DIR("A",2)="'PSO LM HIDDEN OTHER #2' protocol(s) to their setup prior to the"
+5 SET DIR("A",3)="installation of PSO*7.0*690."
+6 SET DIR("A",4)=""
+7 SET DIR("A")="Are you sure you wish to proceed"
SET DIR("B")="NO"
SET DIR(0)="Y"
+8 DO ^DIR
+9 if Y<1
QUIT
+10 ;
+11 ; Be sure we still have the backup global
+12 IF '$DATA(^XTMP("PSO*7.0*690 POST INSTALL"))
DO BMES^XPDUTL("*** No backup entry found. Not able to proceed. Quitting! ***")
QUIT
+13 ;
+14 DO BMES^XPDUTL("*** Starting global restore from backup for the PSO*7.0*690 installation ***")
+15 ;
+16 FOR PRTCNM="PSO LM HIDDEN OTHER","PSO LM HIDDEN OTHER #2"
Begin DoDot:1
+17 SET PRTCIEN=+$ORDER(^ORD(101,"B",PRTCNM,""))
+18 IF 'PRTCIEN
DO BMES^XPDUTL(" ** No current "_PRTCNM_" protocol record found. Quitting! **")
QUIT
+19 SET XQORM=PRTCIEN_";ORD(101,"
+20 IF $DATA(^XTMP("PSO*7.0*690 POST INSTALL","XUTL_DUP",XQORM))
Begin DoDot:2
+21 KILL ^XUTL("XQORM",XQORM)
+22 MERGE ^XUTL("XQORM",XQORM)=^XTMP("PSO*7.0*690 POST INSTALL","XUTL",PRTCIEN)
+23 DO BMES^XPDUTL(" ** "_PRTCNM_" protocol ^XUTL global restored successfully **")
End DoDot:2
+24 if '$DATA(^XTMP("PSO*7.0*690 POST INSTALL","DEL_101",PRTCIEN))
QUIT
+25 NEW DIC,DR,DA,X
+26 SET DIC="^ORD(101,"_PRTCIEN_",10,"
SET DIC(0)=""
+27 SET DA(1)=PRTCIEN
+28 SET DA=""
+29 FOR
SET DA=$ORDER(^XTMP("PSO*7.0*690 POST INSTALL","DEL_101",PRTCIEN,DA))
if DA=""
QUIT
Begin DoDot:2
+30 SET DIC("DR")=".01///"_DA_";2///RR"
SET X=DA
+31 DO FILE^DICN
End DoDot:2
+32 DO BMES^XPDUTL(" ** "_PRTCNM_" protocol IEN "_PRTCIEN_" restored successfully **")
+33 QUIT
End DoDot:1
+34 ;
+35 DO BMES^XPDUTL("*** Restore from backup for the PSO*7.0*690 installation complete ***")
+36 QUIT
