Routine: DVBA187P

DVBA187P ;ALB/GAK - PATCH DVBA*2.7*187 POST-INSTALL ROUTINE;08-OCT-2013

 ;;2.7;AMIE;**187**;Apr 10, 1995;Build 13

ENTER ;

 D AMIE

 D SECKEY

AMIE ;Update for the AMIE EXAM (#396.6) file

 ;Used to inactivate old entries and/or create new entries for designated worksheet updates

 D BMES^XPDUTL(" Update to AMIE EXAM (#396.6) file...")

 I '$D(^DVB(396.6)) D BMES^XPDUTL("Missing AMIE EXAM (#396.6) file") Q

 I $D(^DVB(396.6)) D

 . ;Add new SHA entry to AMIE EXAM file

 . D NEW

 .  ;Rename existing Medical Opinion 1 entry in AMIE EXAM file

 . D RENAMIE

 . ;Inactivate existing entires in AMIE EXAM file

 . D INACAMIE

 . ; Rename Medical Opinion PRINT NAME field

 . D RENMEDOP

NEW ;Add new exam entry

 N DVBAI,DVBLINE,DVBIEN,DVBEXM,DVBPNM,DVBBDY,DVBROU,DVBSTAT,DVBWKS

 D BMES^XPDUTL(" Adding new AMIE EXAM (#396.6) file entry...")

 F DVBAI=1:1 S DVBLINE=$P($T(AMIENEW+DVBAI),";;",2) Q:DVBLINE="QUIT"  D

 . N DVBAMSG

 . S DVBIEN=$P(DVBLINE,";",1)  ;ien

 . S DVBEXM=$P(DVBLINE,";",2)  ;exam name

 . S DVBPNM=$P(DVBLINE,";",3)  ;print name

 . S DVBBDY=$P(DVBLINE,";",4)  ;body system

 . S DVBROU=$P(DVBLINE,";",5)  ;routine name

 . S DVBSTAT=$P(DVBLINE,";",6) ;status

 . S DVBWKS=$P(DVBLINE,";",8)  ;worksheet number

 . D BMES^XPDUTL("  Attempting to add Entry #"_DVBIEN_"...")

 . D NEWEXAM^DVBAUTLP(DVBIEN,DVBEXM,DVBPNM,DVBBDY,DVBROU,DVBSTAT,DVBWKS,.DVBAMSG)

 . ; Display status message returned if any

 . D:$D(DVBAMSG)>0 MES^XPDUTL(.DVBAMSG)

 . D BMES^XPDUTL(" Completed adding new AMIE EXAM (#396.6) file entry...")

RENAMIE ;Rename existing DBQ exam file entries

 N DVBAI,DVBLINE,DVBIEN,DVBEXMO,DVBEXMN

 D BMES^XPDUTL("Renaming AMIE EXAM (#396.6) file entries...")

 F DVBAI=1:1 S DVBLINE=$P($T(EXOLDNEW+DVBAI),";;",2) Q:DVBLINE="QUIT"  D

 . S DVBIEN=$P(DVBLINE,";",1)  ;ien

 . S DVBEXMO=$P(DVBLINE,";",2)  ;old exam name

 . S DVBEXMN=$P(DVBLINE,";",3)  ;new exam name

 . D RENEXAM

 D BMES^XPDUTL("Completed Renaming AMIE EXAM (#396.6) file entries...")

 K DVBEXMO,DVBEXMN

RENEXAM ;

 ;Quit if critical variables missing. For each EXOLDNEW entry, do this.

 I $G(DVBIEN)'>0!($G(DVBEXMO)']"")!($G(DVBEXMN)']"") D  Q

 . D BMES^XPDUTL("Insufficient data to process change at #"_DVBIEN_")")

 ; Update existing entry

 N DVBAERR,DVBAFDA

 ; Check for existing entry

 I $G(^DVB(396.6,DVBIEN,0))']"" D  Q

 . D BMES^XPDUTL("No entry found at #"_DVBIEN)

 ; Check for previous update

 I $P(^DVB(396.6,DVBIEN,0),"^",1)=DVBEXMN D  Q

 . D BMES^XPDUTL("Entry at ien #"_DVBIEN_" has previously been updated")

 ; Check for correct entry NAME to update

 I $P(^DVB(396.6,DVBIEN,0),"^",1)'=DVBEXMO D  Q

 . D BMES^XPDUTL("Entry at ien #"_DVBIEN_" does not match expected name "_DVBEXMO_" No updating will take place")

 ; Update entry

 S DVBAFDA(396.6,+DVBIEN_",",.01)=$G(DVBEXMN) D

 . D FILE^DIE("","DVBAFDA","DVBAERR")

 ; Report sucessful update

 I $D(DVBAERR("DIERR"))'>0 D  Q

 . D BMES^XPDUTL("Renamed entry #"_DVBIEN_" from "_DVBEXMO_" to "_DVBEXMN)

 ; Report update error

 I $D(DVBAERR("DIERR"))>0 D

 . D BMES^XPDUTL("   *** Warning - Unable to update entry #"_DVBIEN_" *** ")

 . D MSG^DIALOG()

INACAMIE   ;Inactivate exams

 N DVBAI,DVBLINE,DVBIEN,DVBEXM

 D BMES^XPDUTL(" Inactivating AMIE EXAM (#396.6) file entries...")

 D MES^XPDUTL("")

 F DVBAI=1:1 S DVBLINE=$P($T(AMIEOLD+DVBAI),";;",2) Q:DVBLINE="QUIT"  D

 . N DVBAMSG

 . S DVBIEN=$P(DVBLINE,";",1)

 . S DVBEXM=$P(DVBLINE,";",2)

 . ;D BMES^XPDUTL("Going to INACTEXM^DVBAUTLP with DVBIEN="_DVBIEN_", DVBEXM="_DVBEXM_", and the message array passed")

 . D INACTEXM^DVBAUTLP(DVBIEN,DVBEXM,.DVBAMSG)

 . ; Display status message returned, if any

 . D:$D(DVBAMSG)>0 MES^XPDUTL(.DVBAMSG)

 . D MES^XPDUTL("")

 D BMES^XPDUTL(" Completed Inactivating AMIE EXAM (#396.6) file entries...")

RENMEDOP ;

 D BMES^XPDUTL(" Changing PRINT NAME of DBQ Medical Opinion to DBQ MEDICAL OPINION")

 I $P($G(^DVB(396.6,437,0)),"^",1)'="DBQ Medical Opinion" D  Q

 . D BMES^XPDUTL(" Could not change PRINT NAME of DBQ Medical Opinion to DBQ MEDICAL OPINION")

 N DVBAERR

 S DVBAFDA(396.6,437_",",6)="DBQ MEDICAL OPINION" D FILE^DIE("","DVBAFDA","DVBAERR")

 I $D(DVBAERR("DIERR"))'>0 D

 . D BMES^XPDUTL("DBQ Medical Opinion print name changed to DBQ MEDICAL OPINION")

 I $D(DVBAERR("DIERR"))>0 D

 . D BMES^XPDUTL("Could not change DBQ Medical Opinion print name to DBQ MEDICAL OPINION")

SECKEY ;

 N XDUZ,KEYNUM,XIEN,XMNU,STOP1,ZTST,OPTIEN,PERDUZ,MSG,ERR,KEYIEN,PERSON,TODAY,X,ZZ

 S ZZ="" D OWNSKEY^XUSRB(.ZZ,"XUMGR",DUZ)

 I $G(ZZ(0))'=1 D  Q

 . D BMES^XPDUTL("NOTE: THE NEW SECURITY KEY 'DVBA CAPRI GETVBADOCS' DID NOT SUCCESSFULLY UPDATE WITH THE REQUIRED HOLDERS.")

 . D BMES^XPDUTL("THE USER RUNNING THIS POST INSTALL ROUTINE DOES NOT HAVE XUMGR KEY ASSIGNED TO THEM.")

 . D BMES^XPDUTL("PLEASE RUN SECKEY^DVBA187P AGAIN WITH USER WHO IS A HOLDER OF THE 'XUMGR' SECURITY KEY.")

 K ^TMP($J,"DVBA187P")

 D NOW^%DTC S TODAY=X

 ;FIND DVBA CAPRI GUI IN OPTION FILE (SHOULD ALWAYS BE 9510) BUT CHECKING JUST THE SAME

 S STOP1=0,OPTIEN=""

 S XIEN=0 F  S XIEN=$O(^DIC(19,XIEN)) Q:XIEN=""!('XIEN)!(STOP1=1)  D

 . S ZTST=$G(^DIC(19,XIEN,0),"")

 . S ZTST=$P(ZTST,"^",1)

 . I ZTST="DVBA CAPRI GUI" S STOP1=1,OPTIEN=XIEN

 I OPTIEN="" D BMES^XPDUTL("'DVBA CAPRI GUI' OPTION NOT FOUND IN OPTION FILE. USERS OF DVBA CAPRI GETVBADOCS COULD NOT BE SETUP") Q

 ;FIND PERSONS WITH DVBA CAPRI GUI OPTION

 I OPTIEN'="" D

 . S PERDUZ=0 F  S PERDUZ=$O(^VA(200,PERDUZ)) Q:PERDUZ=""!('PERDUZ)  D

 .. K MSG,ERR

 .. D GETS^DIQ(200,PERDUZ_",","9.2","I","MSG","ERR")

 .. I $G(MSG(200,PERDUZ_",",9.2,"I"))'="",($G(MSG(200,PERDUZ_",",9.2,"I"))<=TODAY) D  Q

 ... S ^TMP($J,"DVBA187P",PERDUZ,"TERMEDPERSON")=""

 .. ;

 .. I $G(^VA(200,PERDUZ,201)) I $P(^VA(200,PERDUZ,201),"^",1)=OPTIEN S ^TMP($J,"DVBA187P",PERDUZ,"USERSWITHOPTION")="" Q

 .. Q:'$D(^VA(200,PERDUZ,203))

 .. S STOP1=0

 .. S XMNU=0 F  S XMNU=$O(^VA(200,PERDUZ,203,XMNU)) Q:XMNU=""!('XMNU)!(STOP1=1)  D

 ... I $G(^VA(200,PERDUZ,203,XMNU,0)) I $P(^VA(200,PERDUZ,203,XMNU,0),"^",1)=OPTIEN S STOP1=1,^TMP($J,"DVBA187P",PERDUZ,"USERSWITHOPTION")=""

 ;DOES THE USER HAVE ACCESS TO THE CURRENT KEY

 S KEYNUM=$$LKUP^XPDKEY("DVBA CAPRI DENY_GETVBADOCS")

 I $G(KEYNUM)="" D BMES^XPDUTL("'DVBA CAPRI DENY_GETVBADOCS' SECURITY KEY HAS ALREADY BEEN DELETED. SECKEY^DVBA187P CAN NOT CONTINUE") Q

 S PERDUZ=0 F  S PERDUZ=$O(^VA(200,PERDUZ)) Q:PERDUZ=""!('PERDUZ)  D

 . I $D(^VA(200,PERDUZ,51,KEYNUM)) D  Q

 .. S ^TMP($J,"DVBA187P",PERDUZ,"DVBA CAPRI DENY_GETVBADOCS")=""

 .. I $D(^TMP($J,"DVBA187P",PERDUZ,"USERSWITHOPTION")) S ^TMP($J,"DVBA187P",PERDUZ,"USERSWITHOPTION")="DVBA CAPRI DENY_GETVBADOCS"

 ;ADD NEW SECURITY KEY TO ALL NON-TERMED PERSONS WHO DON'T HAVE OLD KEY

 S KEYNUM=$$LKUP^XPDKEY("DVBA CAPRI GETVBADOCS")

 I $G(KEYNUM)="" D BMES^XPDUTL("'DVBA CAPRI GETVBADOCS' SECURITY KEY HAS NOT BEEN INSTALLED ON SYSTEM. INSTALL AND RERUN SECKEY^DVBA187P") Q

 S PERDUZ=0 F  S PERDUZ=$O(^TMP($J,"DVBA187P",PERDUZ)) Q:PERDUZ=""!('PERDUZ)  D

 . Q:$D(^VA(200,PERDUZ,3,"B","VISITOR"))=10  ;DO NOT INCLUDE USERS WHO ARE VISITORS

 . Q:'$D(^TMP($J,"DVBA187P",PERDUZ,"USERSWITHOPTION"))

 . Q:$D(^TMP($J,"DVBA187P",PERDUZ,"TERMEDPERSON"))

 . Q:$D(^TMP($J,"DVBA187P",PERDUZ,"DVBA CAPRI DENY_GETVBADOCS"))

 . ;IF AFTER FIRST RUN THIS ROUTINE IS RUN AGAIN EXCLUDE PERSON WITH KEY FROM FIRST RUN

 . Q:$D(^XUSEC("DVBA CAPRI GETVBADOCS",PERDUZ))

 . K FDA,ERR,DIERR,KEYIEN

 . S FDA(200.051,"+1,"_PERDUZ_",",.01)=KEYNUM

 . S FDA(200.051,"+1,"_PERDUZ_",",1)=DUZ

 . S FDA(200.051,"+1,"_PERDUZ_",",2)=TODAY

 . S KEYIEN(1)=KEYNUM

 . D UPDATE^DIE("","FDA","KEYIEN","ERR")

 . S PERSON=$P(^VA(200,PERDUZ,0),"^",1)

 . I $D(DIERR) D BMES^XPDUTL("PERSON DUZ: "_PERDUZ_" ("_PERSON_") SHOULD BE ASSIGNED THE SECURITY KEY 'DVBA CAPRI GETVBADOCS' BUT COULD NOT IN THE DVBA*2.7*187 POST INSTALL ROUTINE. PLEASE SET THIS PERSON MANUALLY") Q

 . D BMES^XPDUTL("PERSON DUZ: "_PERDUZ_" ("_PERSON_") HAS BEEN ASSIGNED THE NEW SECURITY KEY 'DVBA CAPRI GETVBADOCS'")

 K ^TMP($J,"DVBA187P")

 D BMES^XPDUTL("OK to delete DVBA187P")

 ;***************************************************************************

 ; AMIE EXAM (#396.6) file exam(s) to activate (create or update).

 ; Data should be in internal format.

 ; format: ien;exam name (60 chars);print name;body system;routine;status;;wks#

 ;***************************************************************************

AMIENEW ;

 ;;463;DBQ Medical SHA;DBQ SEPRATN HEALTH ASMNT;1;DVBCQDRV;A; ; ;

 ;;QUIT

 ; **************************************************************************

 ; AMIE EXAM (#396.6) file exam(s) to rename. Data should be in internal format.

 ; Format: ;;ien;"old" exam name(up to 60 chars);"new" exam name(up to 60 chars)

 ; **************************************************************************

EXOLDNEW ;

 ;;437;DBQ Medical Opinion 1;DBQ Medical Opinion

 ;;QUIT

;;

 ;***************************************************************************

 ; AMIE EXAM (#396.6) file exam(s) to deactivate. Data should be in

 ; internal format.

 ; Format: ien;exam name (60 chars);

 ;***************************************************************************

AMIEOLD  ;

 ;;416;DBQ MUSC Flatfoot (pes planus);16;DVBCQDRV;I;;

 ;;433;DBQ CARDIO Ischemic heart disease;6;DVBCQDRV;I;;

 ;;438;DBQ Medical Opinion 2;17;DVBCQDRV;I;;

 ;;439;DBQ Medical Opinion 3;17;DVBCQDRV;I;;

 ;;440;DBQ Medical Opinion 4;17;DVBCQDRV;I;;

 ;;441;DBQ Medical Opinion 5;17;DVBCQDRV;I;;

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBA187P   9729     printed  Mar 13, 2025@20:44:05                                                                                                                                                                                                    Page 2

DVBA187P  ;ALB/GAK - PATCH DVBA*2.7*187 POST-INSTALL ROUTINE;08-OCT-2013

 +1       ;;2.7;AMIE;**187**;Apr 10, 1995;Build 13

 +2        QUIT

 +3       ;

ENTER     ;

 +1        DO AMIE

 +2        DO SECKEY

 +3        QUIT

 +4       ;

 +5       ;

AMIE      ;Update for the AMIE EXAM (#396.6) file

 +1       ;

 +2       ;Used to inactivate old entries and/or create new entries for designated worksheet updates

 +3       ;

 +4        DO BMES^XPDUTL(" Update to AMIE EXAM (#396.6) file...")

 +5        IF '$DATA(^DVB(396.6))

               DO BMES^XPDUTL("Missing AMIE EXAM (#396.6) file")

               QUIT

 +6        IF $DATA(^DVB(396.6))

               Begin DoDot:1

 +7       ;Add new SHA entry to AMIE EXAM file

 +8                DO NEW

 +9       ;Rename existing Medical Opinion 1 entry in AMIE EXAM file

 +10               DO RENAMIE

 +11      ;Inactivate existing entires in AMIE EXAM file

 +12               DO INACAMIE

 +13      ; Rename Medical Opinion PRINT NAME field

 +14               DO RENMEDOP

               End DoDot:1

 +15       QUIT

 +16      ;

 +17      ;

NEW       ;Add new exam entry

 +1       ;

 +2        NEW DVBAI,DVBLINE,DVBIEN,DVBEXM,DVBPNM,DVBBDY,DVBROU,DVBSTAT,DVBWKS

 +3       ;

 +4        DO BMES^XPDUTL(" Adding new AMIE EXAM (#396.6) file entry...")

 +5        FOR DVBAI=1:1

               SET DVBLINE=$PIECE($TEXT(AMIENEW+DVBAI),";;",2)

               if DVBLINE="QUIT"

                   QUIT

               Begin DoDot:1

 +6                NEW DVBAMSG

 +7       ;ien

                   SET DVBIEN=$PIECE(DVBLINE,";",1)

 +8       ;exam name

                   SET DVBEXM=$PIECE(DVBLINE,";",2)

 +9       ;print name

                   SET DVBPNM=$PIECE(DVBLINE,";",3)

 +10      ;body system

                   SET DVBBDY=$PIECE(DVBLINE,";",4)

 +11      ;routine name

                   SET DVBROU=$PIECE(DVBLINE,";",5)

 +12      ;status

                   SET DVBSTAT=$PIECE(DVBLINE,";",6)

 +13      ;worksheet number

                   SET DVBWKS=$PIECE(DVBLINE,";",8)

 +14               DO BMES^XPDUTL("  Attempting to add Entry #"_DVBIEN_"...")

 +15               DO NEWEXAM^DVBAUTLP(DVBIEN,DVBEXM,DVBPNM,DVBBDY,DVBROU,DVBSTAT,DVBWKS,.DVBAMSG)

 +16      ; Display status message returned if any

 +17               if $DATA(DVBAMSG)>0

                       DO MES^XPDUTL(.DVBAMSG)

 +18               DO BMES^XPDUTL(" Completed adding new AMIE EXAM (#396.6) file entry...")

               End DoDot:1

 +19       QUIT

 +20      ;

RENAMIE   ;Rename existing DBQ exam file entries

 +1       ;

 +2        NEW DVBAI,DVBLINE,DVBIEN,DVBEXMO,DVBEXMN

 +3       ;

 +4        DO BMES^XPDUTL("Renaming AMIE EXAM (#396.6) file entries...")

 +5        FOR DVBAI=1:1

               SET DVBLINE=$PIECE($TEXT(EXOLDNEW+DVBAI),";;",2)

               if DVBLINE="QUIT"

                   QUIT

               Begin DoDot:1

 +6       ;ien

                   SET DVBIEN=$PIECE(DVBLINE,";",1)

 +7       ;old exam name

                   SET DVBEXMO=$PIECE(DVBLINE,";",2)

 +8       ;new exam name

                   SET DVBEXMN=$PIECE(DVBLINE,";",3)

 +9                DO RENEXAM

               End DoDot:1

 +10       DO BMES^XPDUTL("Completed Renaming AMIE EXAM (#396.6) file entries...")

 +11       KILL DVBEXMO,DVBEXMN

 +12       QUIT

 +13      ;

RENEXAM   ;

 +1       ;Quit if critical variables missing. For each EXOLDNEW entry, do this.

 +2        IF $GET(DVBIEN)'>0!($GET(DVBEXMO)']"")!($GET(DVBEXMN)']"")

               Begin DoDot:1

 +3                DO BMES^XPDUTL("Insufficient data to process change at #"_DVBIEN_")")

               End DoDot:1

               QUIT

 +4       ;

 +5       ; Update existing entry

 +6       ;

 +7        NEW DVBAERR,DVBAFDA

 +8       ;

 +9       ; Check for existing entry

 +10       IF $GET(^DVB(396.6,DVBIEN,0))']""

               Begin DoDot:1

 +11               DO BMES^XPDUTL("No entry found at #"_DVBIEN)

               End DoDot:1

               QUIT

 +12      ;

 +13      ; Check for previous update

 +14       IF $PIECE(^DVB(396.6,DVBIEN,0),"^",1)=DVBEXMN

               Begin DoDot:1

 +15               DO BMES^XPDUTL("Entry at ien #"_DVBIEN_" has previously been updated")

               End DoDot:1

               QUIT

 +16      ;

 +17      ; Check for correct entry NAME to update

 +18       IF $PIECE(^DVB(396.6,DVBIEN,0),"^",1)'=DVBEXMO

               Begin DoDot:1

 +19               DO BMES^XPDUTL("Entry at ien #"_DVBIEN_" does not match expected name "_DVBEXMO_" No updating will take place")

               End DoDot:1

               QUIT

 +20      ;

 +21      ; Update entry

 +22       SET DVBAFDA(396.6,+DVBIEN_",",.01)=$GET(DVBEXMN)

           Begin DoDot:1

 +23           DO FILE^DIE("","DVBAFDA","DVBAERR")

           End DoDot:1

 +24      ;

 +25      ; Report sucessful update

 +26      ;

 +27       IF $DATA(DVBAERR("DIERR"))'>0

               Begin DoDot:1

 +28               DO BMES^XPDUTL("Renamed entry #"_DVBIEN_" from "_DVBEXMO_" to "_DVBEXMN)

               End DoDot:1

               QUIT

 +29      ;

 +30      ; Report update error

 +31      ;

 +32       IF $DATA(DVBAERR("DIERR"))>0

               Begin DoDot:1

 +33               DO BMES^XPDUTL("   *** Warning - Unable to update entry #"_DVBIEN_" *** ")

 +34               DO MSG^DIALOG()

               End DoDot:1

 +35       QUIT

 +36      ;

INACAMIE  ;Inactivate exams

 +1       ;

 +2        NEW DVBAI,DVBLINE,DVBIEN,DVBEXM

 +3       ;

 +4        DO BMES^XPDUTL(" Inactivating AMIE EXAM (#396.6) file entries...")

 +5        DO MES^XPDUTL("")

 +6        FOR DVBAI=1:1

               SET DVBLINE=$PIECE($TEXT(AMIEOLD+DVBAI),";;",2)

               if DVBLINE="QUIT"

                   QUIT

               Begin DoDot:1

 +7                NEW DVBAMSG

 +8                SET DVBIEN=$PIECE(DVBLINE,";",1)

 +9                SET DVBEXM=$PIECE(DVBLINE,";",2)

 +10      ;D BMES^XPDUTL("Going to INACTEXM^DVBAUTLP with DVBIEN="_DVBIEN_", DVBEXM="_DVBEXM_", and the message array passed")

 +11               DO INACTEXM^DVBAUTLP(DVBIEN,DVBEXM,.DVBAMSG)

 +12      ; Display status message returned, if any

 +13               if $DATA(DVBAMSG)>0

                       DO MES^XPDUTL(.DVBAMSG)

 +14               DO MES^XPDUTL("")

               End DoDot:1

 +15       DO BMES^XPDUTL(" Completed Inactivating AMIE EXAM (#396.6) file entries...")

 +16       QUIT

 +17      ;

RENMEDOP  ;

 +1        DO BMES^XPDUTL(" Changing PRINT NAME of DBQ Medical Opinion to DBQ MEDICAL OPINION")

 +2        IF $PIECE($GET(^DVB(396.6,437,0)),"^",1)'="DBQ Medical Opinion"

               Begin DoDot:1

 +3                DO BMES^XPDUTL(" Could not change PRINT NAME of DBQ Medical Opinion to DBQ MEDICAL OPINION")

               End DoDot:1

               QUIT

 +4        NEW DVBAERR

 +5        SET DVBAFDA(396.6,437_",",6)="DBQ MEDICAL OPINION"

           DO FILE^DIE("","DVBAFDA","DVBAERR")

 +6        IF $DATA(DVBAERR("DIERR"))'>0

               Begin DoDot:1

 +7                DO BMES^XPDUTL("DBQ Medical Opinion print name changed to DBQ MEDICAL OPINION")

               End DoDot:1

 +8        IF $DATA(DVBAERR("DIERR"))>0

               Begin DoDot:1

 +9                DO BMES^XPDUTL("Could not change DBQ Medical Opinion print name to DBQ MEDICAL OPINION")

               End DoDot:1

 +10       QUIT

 +11      ;

SECKEY    ;

 +1       ;

 +2        NEW XDUZ,KEYNUM,XIEN,XMNU,STOP1,ZTST,OPTIEN,PERDUZ,MSG,ERR,KEYIEN,PERSON,TODAY,X,ZZ

 +3       ;

 +4        SET ZZ=""

           DO OWNSKEY^XUSRB(.ZZ,"XUMGR",DUZ)

 +5        IF $GET(ZZ(0))'=1

               Begin DoDot:1

 +6                DO BMES^XPDUTL("NOTE: THE NEW SECURITY KEY 'DVBA CAPRI GETVBADOCS' DID NOT SUCCESSFULLY UPDATE WITH THE REQUIRED HOLDERS.")

 +7                DO BMES^XPDUTL("THE USER RUNNING THIS POST INSTALL ROUTINE DOES NOT HAVE XUMGR KEY ASSIGNED TO THEM.")

 +8                DO BMES^XPDUTL("PLEASE RUN SECKEY^DVBA187P AGAIN WITH USER WHO IS A HOLDER OF THE 'XUMGR' SECURITY KEY.")

               End DoDot:1

               QUIT

 +9       ;

 +10       KILL ^TMP($JOB,"DVBA187P")

 +11      ;

 +12       DO NOW^%DTC

           SET TODAY=X

 +13      ;

 +14      ;FIND DVBA CAPRI GUI IN OPTION FILE (SHOULD ALWAYS BE 9510) BUT CHECKING JUST THE SAME

 +15       SET STOP1=0

           SET OPTIEN=""

 +16       SET XIEN=0

FOR

               SET XIEN=$ORDER(^DIC(19,XIEN))

               if XIEN=""!('XIEN)!(STOP1=1)

                   QUIT

               Begin DoDot:1

 +17               SET ZTST=$GET(^DIC(19,XIEN,0),"")

 +18               SET ZTST=$PIECE(ZTST,"^",1)

 +19               IF ZTST="DVBA CAPRI GUI"

                       SET STOP1=1

                       SET OPTIEN=XIEN

               End DoDot:1

 +20       IF OPTIEN=""

               DO BMES^XPDUTL("'DVBA CAPRI GUI' OPTION NOT FOUND IN OPTION FILE. USERS OF DVBA CAPRI GETVBADOCS COULD NOT BE SETUP")

               QUIT

 +21      ;

 +22      ;FIND PERSONS WITH DVBA CAPRI GUI OPTION

 +23       IF OPTIEN'=""

               Begin DoDot:1

 +24               SET PERDUZ=0

FOR

                       SET PERDUZ=$ORDER(^VA(200,PERDUZ))

                       if PERDUZ=""!('PERDUZ)

                           QUIT

                       Begin DoDot:2

 +25                       KILL MSG,ERR

 +26                       DO GETS^DIQ(200,PERDUZ_",","9.2","I","MSG","ERR")

 +27                       IF $GET(MSG(200,PERDUZ_",",9.2,"I"))'=""

                               IF ($GET(MSG(200,PERDUZ_",",9.2,"I"))<=TODAY)

                                   Begin DoDot:3

 +28                                   SET ^TMP($JOB,"DVBA187P",PERDUZ,"TERMEDPERSON")=""

                                   End DoDot:3

                                   QUIT

 +29      ;

 +30                       IF $GET(^VA(200,PERDUZ,201))

                               IF $PIECE(^VA(200,PERDUZ,201),"^",1)=OPTIEN

                                   SET ^TMP($JOB,"DVBA187P",PERDUZ,"USERSWITHOPTION")=""

                                   QUIT

 +31                       if '$DATA(^VA(200,PERDUZ,203))

                               QUIT

 +32                       SET STOP1=0

 +33                       SET XMNU=0

FOR

                               SET XMNU=$ORDER(^VA(200,PERDUZ,203,XMNU))

                               if XMNU=""!('XMNU)!(STOP1=1)

                                   QUIT

                               Begin DoDot:3

 +34                               IF $GET(^VA(200,PERDUZ,203,XMNU,0))

                                       IF $PIECE(^VA(200,PERDUZ,203,XMNU,0),"^",1)=OPTIEN

                                           SET STOP1=1

                                           SET ^TMP($JOB,"DVBA187P",PERDUZ,"USERSWITHOPTION")=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +35      ;

 +36      ;DOES THE USER HAVE ACCESS TO THE CURRENT KEY

 +37       SET KEYNUM=$$LKUP^XPDKEY("DVBA CAPRI DENY_GETVBADOCS")

 +38       IF $GET(KEYNUM)=""

               DO BMES^XPDUTL("'DVBA CAPRI DENY_GETVBADOCS' SECURITY KEY HAS ALREADY BEEN DELETED. SECKEY^DVBA187P CAN NOT CONTINUE")

               QUIT

 +39       SET PERDUZ=0

FOR

               SET PERDUZ=$ORDER(^VA(200,PERDUZ))

               if PERDUZ=""!('PERDUZ)

                   QUIT

               Begin DoDot:1

 +40               IF $DATA(^VA(200,PERDUZ,51,KEYNUM))

                       Begin DoDot:2

 +41                       SET ^TMP($JOB,"DVBA187P",PERDUZ,"DVBA CAPRI DENY_GETVBADOCS")=""

 +42                       IF $DATA(^TMP($JOB,"DVBA187P",PERDUZ,"USERSWITHOPTION"))

                               SET ^TMP($JOB,"DVBA187P",PERDUZ,"USERSWITHOPTION")="DVBA CAPRI DENY_GETVBADOCS"

                       End DoDot:2

                       QUIT

               End DoDot:1

 +43      ;

 +44      ;ADD NEW SECURITY KEY TO ALL NON-TERMED PERSONS WHO DON'T HAVE OLD KEY

 +45       SET KEYNUM=$$LKUP^XPDKEY("DVBA CAPRI GETVBADOCS")

 +46       IF $GET(KEYNUM)=""

               DO BMES^XPDUTL("'DVBA CAPRI GETVBADOCS' SECURITY KEY HAS NOT BEEN INSTALLED ON SYSTEM. INSTALL AND RERUN SECKEY^DVBA187P")

               QUIT

 +47       SET PERDUZ=0

FOR

               SET PERDUZ=$ORDER(^TMP($JOB,"DVBA187P",PERDUZ))

               if PERDUZ=""!('PERDUZ)

                   QUIT

               Begin DoDot:1

 +48      ;DO NOT INCLUDE USERS WHO ARE VISITORS

                   if $DATA(^VA(200,PERDUZ,3,"B","VISITOR"))=10

                       QUIT

 +49               if '$DATA(^TMP($JOB,"DVBA187P",PERDUZ,"USERSWITHOPTION"))

                       QUIT

 +50               if $DATA(^TMP($JOB,"DVBA187P",PERDUZ,"TERMEDPERSON"))

                       QUIT

 +51               if $DATA(^TMP($JOB,"DVBA187P",PERDUZ,"DVBA CAPRI DENY_GETVBADOCS"))

                       QUIT

 +52      ;IF AFTER FIRST RUN THIS ROUTINE IS RUN AGAIN EXCLUDE PERSON WITH KEY FROM FIRST RUN

 +53               if $DATA(^XUSEC("DVBA CAPRI GETVBADOCS",PERDUZ))

                       QUIT

 +54               KILL FDA,ERR,DIERR,KEYIEN

 +55               SET FDA(200.051,"+1,"_PERDUZ_",",.01)=KEYNUM

 +56               SET FDA(200.051,"+1,"_PERDUZ_",",1)=DUZ

 +57               SET FDA(200.051,"+1,"_PERDUZ_",",2)=TODAY

 +58               SET KEYIEN(1)=KEYNUM

 +59               DO UPDATE^DIE("","FDA","KEYIEN","ERR")

 +60               SET PERSON=$PIECE(^VA(200,PERDUZ,0),"^",1)

 +61               IF $DATA(DIERR)

                       DO BMES^XPDUTL("PERSON DUZ: "_PERDUZ_" ("_PERSON_") SHOULD BE ASSIGNED THE SECURITY KEY 'DVBA CAPRI GETVBADOCS' BUT COULD NOT IN THE DVBA*2.7*187 POST INSTALL ROUTINE. PLEASE SET THIS PERSON MANUALLY")

                       QUIT

 +62               DO BMES^XPDUTL("PERSON DUZ: "_PERDUZ_" ("_PERSON_") HAS BEEN ASSIGNED THE NEW SECURITY KEY 'DVBA CAPRI GETVBADOCS'")

               End DoDot:1

 +63      ;

 +64       KILL ^TMP($JOB,"DVBA187P")

 +65       DO BMES^XPDUTL("OK to delete DVBA187P")

 +66       QUIT

 +67      ;

 +68      ;***************************************************************************

 +69      ; AMIE EXAM (#396.6) file exam(s) to activate (create or update).

 +70      ; Data should be in internal format.

 +71      ; format: ien;exam name (60 chars);print name;body system;routine;status;;wks#

 +72      ;***************************************************************************

 +73      ;

AMIENEW   ;

 +1       ;;463;DBQ Medical SHA;DBQ SEPRATN HEALTH ASMNT;1;DVBCQDRV;A; ; ;

 +2       ;;QUIT

 +3       ;

 +4        QUIT

 +5       ;

 +6       ; **************************************************************************

 +7       ; AMIE EXAM (#396.6) file exam(s) to rename. Data should be in internal format.

 +8       ; Format: ;;ien;"old" exam name(up to 60 chars);"new" exam name(up to 60 chars)

 +9       ;

 +10      ; **************************************************************************

EXOLDNEW  ;

 +1       ;;437;DBQ Medical Opinion 1;DBQ Medical Opinion

 +2       ;;QUIT

 +3       ;;

 +4        QUIT

 +5       ;***************************************************************************

 +6       ; AMIE EXAM (#396.6) file exam(s) to deactivate. Data should be in

 +7       ; internal format.

 +8       ; Format: ien;exam name (60 chars);

 +9       ;***************************************************************************

 +10      ;

AMIEOLD   ;

 +1       ;;416;DBQ MUSC Flatfoot (pes planus);16;DVBCQDRV;I;;

 +2       ;;433;DBQ CARDIO Ischemic heart disease;6;DVBCQDRV;I;;

 +3       ;;438;DBQ Medical Opinion 2;17;DVBCQDRV;I;;

 +4       ;;439;DBQ Medical Opinion 3;17;DVBCQDRV;I;;

 +5       ;;440;DBQ Medical Opinion 4;17;DVBCQDRV;I;;

 +6       ;;441;DBQ Medical Opinion 5;17;DVBCQDRV;I;;

 +7       ;;QUIT

 +8       ;

 +9        QUIT

DVBA187P.m