PSO7P545 ;DAL/JCH - Post Install routine for patch PSO*7*545 ;12/3/2018
;;7.0;OUTPATIENT PHARMACY;**545**;DEC 1997;Build 270
; Reference to ^VA(200 in ICR #10060
; Reference to ^VA(200 in ICR #7420
; Reference to ACCESS^XQCHK in ICR #10078
; Reference to LKOPT^XPDMENU in ICR #1157
Q
;
POST ;
D PUT^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,1)
;
N BY,ENTRY,ERR,ROOT,WHEN,DUZ
N DIFROM
S DUZ=.5
;
; Check to see if PSO EPCS PSDRPH AUDIT is already scheduled.
K ROOT D OPTSTAT^XUTMOPT("PSO EPCS PSDRPH AUDIT",.ROOT)
I $D(ROOT(1)),$P(ROOT(1),"^",2)'="",$P(ROOT(1),"^",3)'="" G CONT1
;
; Change from XU EPCS PSDRPH AUDIT to PSO EPCS PSDRPH AUDIT
K ROOT D OPTSTAT^XUTMOPT("XU EPCS PSDRPH AUDIT",.ROOT)
I $D(ROOT(1)) F ENTRY=1:1:ROOT D
. I $P(ROOT(ENTRY),"^",2)="" Q
. I $P(ROOT(ENTRY),"^",3)="" Q
. S WHEN=$P(ROOT(ENTRY),"^",2),BY=$P(ROOT(ENTRY),"^",3)
. D RESCH^XUTMOPT("PSO EPCS PSDRPH AUDIT",WHEN,"",BY,"L",.ERR)
. D RESCH^XUTMOPT("XU EPCS PSDRPH AUDIT","@","","@","",.ERR)
CONT1 ;
;
; Check to see if PSO EPCS LOGICAL ACCESS is already scheduled.
K ROOT D OPTSTAT^XUTMOPT("PSO EPCS LOGICAL ACCESS",.ROOT)
I $D(ROOT(1)),$P(ROOT(1),"^",2)'="",$P(ROOT(1),"^",3)'="" G CONT2
;
; Change from XU EPCS LOGICAL ACCESS to PSO EPCS LOGICAL ACCESS
K ROOT D OPTSTAT^XUTMOPT("XU EPCS LOGICAL ACCESS",.ROOT)
I $D(ROOT(1)) F ENTRY=1:1:ROOT D
. I $P(ROOT(ENTRY),"^",2)="" Q
. I $P(ROOT(ENTRY),"^",3)="" Q
. S WHEN=$P(ROOT(ENTRY),"^",2),BY=$P(ROOT(ENTRY),"^",3)
. D RESCH^XUTMOPT("PSO EPCS LOGICAL ACCESS",WHEN,"",BY,"L",.ERR)
. D RESCH^XUTMOPT("XU EPCS LOGICAL ACCESS","@","","@","",.ERR)
CONT2 ;
; Attach options to menu
D MENU
; Extend ^XTMP Purge Date to 90 days
D DEAPRGDT
; Convert Users with XU EPCS EDIT DATA Secondary Menu to PSO EPCS GUI CONTEXT
D PSOSEC
;
Q
;
N MENU,OPTION,CHECK,CHOICE,SYN,ORD,TYPE,OFF,UPDATE
S TYPE="MENUADD" F OFF=1:1 S CHOICE=$P($T(@TYPE+OFF),";;",2) Q:CHOICE="DONE" D
. S OPTION=$P(CHOICE,"^"),MENU=$P(CHOICE,"^",2),SYN=$P(CHOICE,"^",3),ORD=$P(CHOICE,"^",4)
. S CHECK=$$ADD^XPDMENU(MENU,OPTION,SYN,ORD)
. D BMES^XPDUTL(">>> "_OPTION_" Option"_$S('CHECK:" NOT added to "_MENU,1:" added to "_MENU)_" <<<")
Q
;
;;PSO EPCS DEA INTEGRITY REPORT^PSO EPCS UTILITY FUNCTIONS^15^15
;;PSO EPCS DEA MANUAL ENTRY^PSO EPCS UTILITY FUNCTIONS^13^13
;;PSO EPCS DISUSER PRIVS^PSO EPCS UTILITY FUNCTIONS^3^3
;;PSO EPCS EDIT DEA# AND XDATE^PSO EPCS UTILITY FUNCTIONS^12^12
;;PSO EPCS EXPIRED DEA FAILOVER^PSO EPCS UTILITY FUNCTIONS^10^10
;;PSO EPCS MANUAL DEA REPORT^PSO EPCS UTILITY FUNCTIONS^14^14
;;PSO EPCS PRINT EDIT AUDIT^PSO EPCS UTILITY FUNCTIONS^6^6
;;PSO EPCS PRIVS^PSO EPCS UTILITY FUNCTIONS^2^2
;;PSO EPCS SET PARMS^PSO EPCS UTILITY FUNCTIONS^5^5
;;PSO VAMC MBM PHARMACY MODE^PSO EPCS UTILITY FUNCTIONS^11^11
;;DONE
Q
;
DEAPRGDT ; Change the DEA migration purge date in XTMP to 90 days in the future
N HANDPSO,MIGHDR,BEGDT,PRGDT
S HANDPSO=$O(^XTMP("PSODEAWB-3400101.0001"),-1)
Q:HANDPSO=""
S MIGHDR=$G(^XTMP(HANDPSO,0))
Q:MIGHDR'["DEA INITIAL IMPORT"
S BEGDT=$P(MIGHDR,"^",2)
S PURGDT=$$FMADD^XLFDT(BEGDT,90)
S $P(MIGHDR,"^")=PURGDT
S ^XTMP(HANDPSO,0)=MIGHDR
Q
;
;External reference to ^XUSEC supported by DBIA 10076
PSOSEC ; Add PSO EPCS GUI CONTEXT to active users holding the XUEPCSEDIT key and having the XU EPCS EDIT DATA option as a secondary menu.
; Active user defined as NOT Disuser'd, No Termination Date or Reason
N PSODUZ,PSOEPKEY,PSOMENI,PSNWMENI,NPFIL
S PSOEPKEY="XUEPCSEDIT"
S PSNWMENI=$$LKOPT^XPDMENU("PSO EPCS GUI CONTEXT") Q:'PSNWMENI
S PSOMENI=$$LKOPT^XPDMENU("XU EPCS EDIT DATA") Q:'PSOMENI
SET ^XTMP("PSOEPCS-GUIMENU",0)=$$FMADD^XLFDT($$DT^XLFDT(),180)_U_$$DT^XLFDT()_U_"Convert EPCS GUI Users Secondary Menu Option"
S PSODUZ=0 F S PSODUZ=$O(^XUSEC(PSOEPKEY,PSODUZ)) Q:'PSODUZ D
. N PSOERR,PSOFDA,PSOPTIEN,PSOFDA,PSOPTIENS
. Q:$$ACCESS^XQCHK(PSODUZ,PSNWMENI)>0 ; Quit if user already has PSO EPCS GUI CONTEXT
. Q:$$ACCESS^XQCHK(PSODUZ,PSOMENI)<1 ; Quit if user doesn't have old option XU EPCS EDIT DATA
. S PSOPTIEN=$$FIND1^DIC(200.03,","_PSODUZ_",",,"XU EPCS EDIT DATA") Q:'PSOPTIEN ; Shouldn't be possible unless x-ref is corrupted
. S PSOPTIENS=PSOPTIEN_","_PSODUZ_","
. S PSOFDA(200.03,PSOPTIENS,.01)=PSNWMENI
. S PSOFDA(200.03,PSOPTIENS,2)=""
. D FILE^DIE("","PSOFDA","PSOERR")
. SET ^XTMP("PSOEPCS-GUIMENU",PSODUZ)=$$GET1^DIQ(200,PSODUZ,.01)_"^"_$G(PSOERR("DIERR",1,"TEXT",1))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO7P545 4601 printed Sep 23, 2025@20:00:08 Page 2
PSO7P545 ;DAL/JCH - Post Install routine for patch PSO*7*545 ;12/3/2018
+1 ;;7.0;OUTPATIENT PHARMACY;**545**;DEC 1997;Build 270
+2 ; Reference to ^VA(200 in ICR #10060
+3 ; Reference to ^VA(200 in ICR #7420
+4 ; Reference to ACCESS^XQCHK in ICR #10078
+5 ; Reference to LKOPT^XPDMENU in ICR #1157
+6 QUIT
+7 ;
POST ;
+1 DO PUT^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,1)
+2 ;
+3 NEW BY,ENTRY,ERR,ROOT,WHEN,DUZ
+4 NEW DIFROM
+5 SET DUZ=.5
+6 ;
+7 ; Check to see if PSO EPCS PSDRPH AUDIT is already scheduled.
+8 KILL ROOT
DO OPTSTAT^XUTMOPT("PSO EPCS PSDRPH AUDIT",.ROOT)
+9 IF $DATA(ROOT(1))
IF $PIECE(ROOT(1),"^",2)'=""
IF $PIECE(ROOT(1),"^",3)'=""
GOTO CONT1
+10 ;
+11 ; Change from XU EPCS PSDRPH AUDIT to PSO EPCS PSDRPH AUDIT
+12 KILL ROOT
DO OPTSTAT^XUTMOPT("XU EPCS PSDRPH AUDIT",.ROOT)
+13 IF $DATA(ROOT(1))
FOR ENTRY=1:1:ROOT
Begin DoDot:1
+14 IF $PIECE(ROOT(ENTRY),"^",2)=""
QUIT
+15 IF $PIECE(ROOT(ENTRY),"^",3)=""
QUIT
+16 SET WHEN=$PIECE(ROOT(ENTRY),"^",2)
SET BY=$PIECE(ROOT(ENTRY),"^",3)
+17 DO RESCH^XUTMOPT("PSO EPCS PSDRPH AUDIT",WHEN,"",BY,"L",.ERR)
+18 DO RESCH^XUTMOPT("XU EPCS PSDRPH AUDIT","@","","@","",.ERR)
End DoDot:1
CONT1 ;
+1 ;
+2 ; Check to see if PSO EPCS LOGICAL ACCESS is already scheduled.
+3 KILL ROOT
DO OPTSTAT^XUTMOPT("PSO EPCS LOGICAL ACCESS",.ROOT)
+4 IF $DATA(ROOT(1))
IF $PIECE(ROOT(1),"^",2)'=""
IF $PIECE(ROOT(1),"^",3)'=""
GOTO CONT2
+5 ;
+6 ; Change from XU EPCS LOGICAL ACCESS to PSO EPCS LOGICAL ACCESS
+7 KILL ROOT
DO OPTSTAT^XUTMOPT("XU EPCS LOGICAL ACCESS",.ROOT)
+8 IF $DATA(ROOT(1))
FOR ENTRY=1:1:ROOT
Begin DoDot:1
+9 IF $PIECE(ROOT(ENTRY),"^",2)=""
QUIT
+10 IF $PIECE(ROOT(ENTRY),"^",3)=""
QUIT
+11 SET WHEN=$PIECE(ROOT(ENTRY),"^",2)
SET BY=$PIECE(ROOT(ENTRY),"^",3)
+12 DO RESCH^XUTMOPT("PSO EPCS LOGICAL ACCESS",WHEN,"",BY,"L",.ERR)
+13 DO RESCH^XUTMOPT("XU EPCS LOGICAL ACCESS","@","","@","",.ERR)
End DoDot:1
CONT2 ;
+1 ; Attach options to menu
+2 DO MENU
+3 ; Extend ^XTMP Purge Date to 90 days
+4 DO DEAPRGDT
+5 ; Convert Users with XU EPCS EDIT DATA Secondary Menu to PSO EPCS GUI CONTEXT
+6 DO PSOSEC
+7 ;
+8 QUIT
+9 ;
+1 NEW MENU,OPTION,CHECK,CHOICE,SYN,ORD,TYPE,OFF,UPDATE
+2 SET TYPE="MENUADD"
FOR OFF=1:1
SET CHOICE=$PIECE($TEXT(@TYPE+OFF),";;",2)
if CHOICE="DONE"
QUIT
Begin DoDot:1
+3 SET OPTION=$PIECE(CHOICE,"^")
SET MENU=$PIECE(CHOICE,"^",2)
SET SYN=$PIECE(CHOICE,"^",3)
SET ORD=$PIECE(CHOICE,"^",4)
+4 SET CHECK=$$ADD^XPDMENU(MENU,OPTION,SYN,ORD)
+5 DO BMES^XPDUTL(">>> "_OPTION_" Option"_$SELECT('CHECK:" NOT added to "_MENU,1:" added to "_MENU)_" <<<")
End DoDot:1
+6 QUIT
+7 ;
+1 ;;PSO EPCS DEA INTEGRITY REPORT^PSO EPCS UTILITY FUNCTIONS^15^15
+2 ;;PSO EPCS DEA MANUAL ENTRY^PSO EPCS UTILITY FUNCTIONS^13^13
+3 ;;PSO EPCS DISUSER PRIVS^PSO EPCS UTILITY FUNCTIONS^3^3
+4 ;;PSO EPCS EDIT DEA# AND XDATE^PSO EPCS UTILITY FUNCTIONS^12^12
+5 ;;PSO EPCS EXPIRED DEA FAILOVER^PSO EPCS UTILITY FUNCTIONS^10^10
+6 ;;PSO EPCS MANUAL DEA REPORT^PSO EPCS UTILITY FUNCTIONS^14^14
+7 ;;PSO EPCS PRINT EDIT AUDIT^PSO EPCS UTILITY FUNCTIONS^6^6
+8 ;;PSO EPCS PRIVS^PSO EPCS UTILITY FUNCTIONS^2^2
+9 ;;PSO EPCS SET PARMS^PSO EPCS UTILITY FUNCTIONS^5^5
+10 ;;PSO VAMC MBM PHARMACY MODE^PSO EPCS UTILITY FUNCTIONS^11^11
+11 ;;DONE
+12 QUIT
+13 ;
DEAPRGDT ; Change the DEA migration purge date in XTMP to 90 days in the future
+1 NEW HANDPSO,MIGHDR,BEGDT,PRGDT
+2 SET HANDPSO=$ORDER(^XTMP("PSODEAWB-3400101.0001"),-1)
+3 if HANDPSO=""
QUIT
+4 SET MIGHDR=$GET(^XTMP(HANDPSO,0))
+5 if MIGHDR'["DEA INITIAL IMPORT"
QUIT
+6 SET BEGDT=$PIECE(MIGHDR,"^",2)
+7 SET PURGDT=$$FMADD^XLFDT(BEGDT,90)
+8 SET $PIECE(MIGHDR,"^")=PURGDT
+9 SET ^XTMP(HANDPSO,0)=MIGHDR
+10 QUIT
+11 ;
+12 ;External reference to ^XUSEC supported by DBIA 10076
PSOSEC ; Add PSO EPCS GUI CONTEXT to active users holding the XUEPCSEDIT key and having the XU EPCS EDIT DATA option as a secondary menu.
+1 ; Active user defined as NOT Disuser'd, No Termination Date or Reason
+2 NEW PSODUZ,PSOEPKEY,PSOMENI,PSNWMENI,NPFIL
+3 SET PSOEPKEY="XUEPCSEDIT"
+4 SET PSNWMENI=$$LKOPT^XPDMENU("PSO EPCS GUI CONTEXT")
if 'PSNWMENI
QUIT
+5 SET PSOMENI=$$LKOPT^XPDMENU("XU EPCS EDIT DATA")
if 'PSOMENI
QUIT
+6 SET ^XTMP("PSOEPCS-GUIMENU",0)=$$FMADD^XLFDT($$DT^XLFDT(),180)_U_$$DT^XLFDT()_U_"Convert EPCS GUI Users Secondary Menu Option"
+7 SET PSODUZ=0
FOR
SET PSODUZ=$ORDER(^XUSEC(PSOEPKEY,PSODUZ))
if 'PSODUZ
QUIT
Begin DoDot:1
+8 NEW PSOERR,PSOFDA,PSOPTIEN,PSOFDA,PSOPTIENS
+9 ; Quit if user already has PSO EPCS GUI CONTEXT
if $$ACCESS^XQCHK(PSODUZ,PSNWMENI)>0
QUIT
+10 ; Quit if user doesn't have old option XU EPCS EDIT DATA
if $$ACCESS^XQCHK(PSODUZ,PSOMENI)<1
QUIT
+11 ; Shouldn't be possible unless x-ref is corrupted
SET PSOPTIEN=$$FIND1^DIC(200.03,","_PSODUZ_",",,"XU EPCS EDIT DATA")
if 'PSOPTIEN
QUIT
+12 SET PSOPTIENS=PSOPTIEN_","_PSODUZ_","
+13 SET PSOFDA(200.03,PSOPTIENS,.01)=PSNWMENI
+14 SET PSOFDA(200.03,PSOPTIENS,2)=""
+15 DO FILE^DIE("","PSOFDA","PSOERR")
+16 SET ^XTMP("PSOEPCS-GUIMENU",PSODUZ)=$$GET1^DIQ(200,PSODUZ,.01)_"^"_$GET(PSOERR("DIERR",1,"TEXT",1))
End DoDot:1
+17 QUIT
