DVBA187P ;ALB/GAK - PATCH DVBA*2.7*187 POST-INSTALL ROUTINE;08-OCT-2013
;;2.7;AMIE;**187**;Apr 10, 1995;Build 13
Q
;
ENTER ;
D AMIE
D SECKEY
Q
;
;
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
Q
;
;
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...")
Q
;
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
Q
;
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()
Q
;
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...")
Q
;
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")
Q
;
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")
Q
;
;***************************************************************************
; 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
;
Q
;
; **************************************************************************
; 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
;;
Q
;***************************************************************************
; 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
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBA187P 9729 printed Sep 23, 2025@19:15:24 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
