PSO7P545.m

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

 ;

MENU ; Attach options to PSO EPCS UTILITY menu

 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

 ;

MENUADD ; Menu items to be added

 ;;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 ---PSO7P545   4601     printed  Mar 13, 2025@21:28:49                                                                                                                                                                                                    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       ;

MENU      ; Attach options to PSO EPCS UTILITY menu

 +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       ;

MENUADD   ; Menu items to be added

 +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