PXRMP42I ;SLC/PKR - Inits for PXRM*2.0*42. ;04/04/2019
;;2.0;CLINICAL REMINDERS;**42**;Feb 04, 2005;Build 245
Q
;==========================================
PRE ;Pre-init
;Disable options and protocols
D OPTIONS^PXRMUTIL("DISABLE","Install of PXRM*2.0*42")
D PROTCOLS^PXRMUTIL("DISABLE","Install of PXRM*2.0*42")
D RMOLDDDS^PXRMP42I
Q
;
;==========================================
POST ;Post-init
N RES
D RBLDAPDS^PXRMP42I
D RBLDD^PXRMP42I
D RMQUERIX^PXRMP42I
D UPCSPON^PXRMP42I
;Remove PXRM GEC REFERRAL REPORT from the Manager's Menu.
S RES=$$DELETE^XPDMENU("PXRM MANAGERS MENU","PXRM GEC REFERRAL REPORT")
I RES=1 D BMES^XPDUTL("PXRM GEC REFERRAL REPORT was removed from the PXRM MANAGERS MENU.")
D SETPVER^PXRMUTIL("2.0P42")
;Enable options and protocols
D OPTIONS^PXRMUTIL("ENABLE","Install of PXRM*2.0*42")
D PROTCOLS^PXRMUTIL("ENABLE","Install of PXRM*2.0*42")
D SENDIM^PXRMMSG("PXRM*2.0*42")
Q
;
;==========================================
RBLDAPDS ;Rebuild the "APDS" index for all taxonomies, to include
;V Standard Codes.
N IEN,NAME,PDS
D BMES^XPDUTL("Rebuilding the 'APDS' index for all taxonomies.")
S NAME=""
F S NAME=$O(^PXD(811.2,"B",NAME)) Q:NAME="" D
. S IEN=$O(^PXD(811.2,"B",NAME,""))
. S PDS=$P(^PXD(811.2,IEN,0),U,4)
. D SPDS^PXRMPDS(IEN,PDS)
Q
;
;==========================================
RBLDD ;Rebuild the "D" index for 811.9.
N DIK
D BMES^XPDUTL("Rebuilding the 'D' index for Reminder Definition Print Names.")
K ^PXD(811.9,"D")
S DIK="^PXD(811.9,",DIK(1)="1.2^D"
D ENALL^DIK
Q
;
;==========================================
RMOLDDDS ;Remove old data dictionaries.
N DIU,TEXT
D BMES^XPDUTL("Removing old data dictionaries.")
S DIU(0)=""
F DIU=811.6 D
. S TEXT=" Deleting data dictionary for file # "_DIU
. D MES^XPDUTL(TEXT)
. D EN^DIU2
Q
;
;==========================================
RMQUERIX ;Remove the QUERI extracts.
N IEN,IENS,KFDA,MSG,NAME,NAMES,NUM
;Deletion from file #19.2 covered by ICR #3732.
;Delete the Option Scheduling file entries.
D BMES^XPDUTL("Deleting the QUERI extracts.")
F NAME="PXRM EXTRACT VA-IHD QUERI","PXRM EXTRACT VA-MH QUERI" D
. S IEN=+$$FIND1^DIC(19.2,"","BX",NAME,"","","MSG")
. I IEN=0 Q
. D BMES^XPDUTL("Deleting scheduled option "_NAME)
. S IENS=IEN_","
. S KFDA(19.2,IENS,.01)="@"
. D FILE^DIE("","KFDA","MSG")
. I $D(MSG) D AWRITE^PXRMUTIL("MSG")
;Delete all the QUERI patient lists.
D BMES^XPDUTL("Deleting QUERI patient lists.")
F NAMESTART="VA-*IHD QUERI","VA-*MH QUERI" D
. S NAME=NAMESTART
. S NUM=0
. D BMES^XPDUTL("Deleting "_NAMESTART_" lists.")
. F S NAME=$O(^PXRMXP(810.5,"B",NAME)) Q:NAME'[NAMESTART D
.. S IEN=+$$FIND1^DIC(810.5,"","BX",NAME,"","","MSG")
.. I IEN=0 Q
.. D MES^XPDUTL("Deleting Patient List "_NAME)
.. S IENS=IEN_","
.. S KFDA(810.5,IENS,.01)="@"
.. D FILE^DIE("","KFDA","MSG")
.. I $D(MSG) D AWRITE^PXRMUTIL("MSG")
.. S NUM=NUM+1
. D BMES^XPDUTL("Deleted "_NUM_" "_NAMESTART_" lists.")
Q
;
;==========================================
UPCSPON ;Make all the .01s in the Sponsor file uppercase.
N FDA,NEWIEN,NEWNAME,MSG,OLDIEN,OLDNAME,RPL
D BMES^XPDUTL("Checking for Sponsor Names that need to be changed to all uppercase.")
S OLDNAME=""
F S OLDNAME=$O(^PXRMD(811.6,"B",OLDNAME)) Q:OLDNAME="" D
. I OLDNAME'?.E1.L.E Q
. S NEWNAME=$$UP^XLFSTR(OLDNAME)
.;If the uppercase name already exists repoint the lowercase one
.;to it.
. S NEWIEN=+$$FIND1^DIC(811.6,"","BXU",NEWNAME) I NEWIEN>0 D Q
.. K RPL
.. D BMES^XPDUTL("The uppercase version of "_OLDNAME_" already exists at IEN="_NEWIEN)
.. D MES^XPDUTL("repointing to it.")
.. S OLDIEN=$O(^PXRMD(811.6,"B",OLDNAME,""))
.. S RPL(1)=OLDIEN_U_NEWIEN
.. D EN^DITP(811.6,.RPL)
..;Remove the lowercase entry.
.. S FDA(811.6,OLDIEN_",",.01)="@"
.. D FILE^DIE("","FDA","MSG")
. D BMES^XPDUTL("Renaming: "_OLDNAME)
. D MES^XPDUTL("To: "_NEWNAME)
. D RENAME^PXRMUTIL(811.6,OLDNAME,NEWNAME)
;
;Remove the old 'B' and 'BN' indexes and build the new 'B'.
K ^PXRMD(811.6,"B"),^PXRMD(811.6,"BN")
D BMES^XPDUTL("Rebuilding Sponsor B index.")
N DIK
S DIK="^PXRMD(811.6,",DIK(1)=".01^B"
D ENALL^DIK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMP42I 4275 printed Dec 13, 2024@01:47:41 Page 2
PXRMP42I ;SLC/PKR - Inits for PXRM*2.0*42. ;04/04/2019
+1 ;;2.0;CLINICAL REMINDERS;**42**;Feb 04, 2005;Build 245
+2 QUIT
+3 ;==========================================
PRE ;Pre-init
+1 ;Disable options and protocols
+2 DO OPTIONS^PXRMUTIL("DISABLE","Install of PXRM*2.0*42")
+3 DO PROTCOLS^PXRMUTIL("DISABLE","Install of PXRM*2.0*42")
+4 DO RMOLDDDS^PXRMP42I
+5 QUIT
+6 ;
+7 ;==========================================
POST ;Post-init
+1 NEW RES
+2 DO RBLDAPDS^PXRMP42I
+3 DO RBLDD^PXRMP42I
+4 DO RMQUERIX^PXRMP42I
+5 DO UPCSPON^PXRMP42I
+6 ;Remove PXRM GEC REFERRAL REPORT from the Manager's Menu.
+7 SET RES=$$DELETE^XPDMENU("PXRM MANAGERS MENU","PXRM GEC REFERRAL REPORT")
+8 IF RES=1
DO BMES^XPDUTL("PXRM GEC REFERRAL REPORT was removed from the PXRM MANAGERS MENU.")
+9 DO SETPVER^PXRMUTIL("2.0P42")
+10 ;Enable options and protocols
+11 DO OPTIONS^PXRMUTIL("ENABLE","Install of PXRM*2.0*42")
+12 DO PROTCOLS^PXRMUTIL("ENABLE","Install of PXRM*2.0*42")
+13 DO SENDIM^PXRMMSG("PXRM*2.0*42")
+14 QUIT
+15 ;
+16 ;==========================================
RBLDAPDS ;Rebuild the "APDS" index for all taxonomies, to include
+1 ;V Standard Codes.
+2 NEW IEN,NAME,PDS
+3 DO BMES^XPDUTL("Rebuilding the 'APDS' index for all taxonomies.")
+4 SET NAME=""
+5 FOR
SET NAME=$ORDER(^PXD(811.2,"B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+6 SET IEN=$ORDER(^PXD(811.2,"B",NAME,""))
+7 SET PDS=$PIECE(^PXD(811.2,IEN,0),U,4)
+8 DO SPDS^PXRMPDS(IEN,PDS)
End DoDot:1
+9 QUIT
+10 ;
+11 ;==========================================
RBLDD ;Rebuild the "D" index for 811.9.
+1 NEW DIK
+2 DO BMES^XPDUTL("Rebuilding the 'D' index for Reminder Definition Print Names.")
+3 KILL ^PXD(811.9,"D")
+4 SET DIK="^PXD(811.9,"
SET DIK(1)="1.2^D"
+5 DO ENALL^DIK
+6 QUIT
+7 ;
+8 ;==========================================
RMOLDDDS ;Remove old data dictionaries.
+1 NEW DIU,TEXT
+2 DO BMES^XPDUTL("Removing old data dictionaries.")
+3 SET DIU(0)=""
+4 FOR DIU=811.6
Begin DoDot:1
+5 SET TEXT=" Deleting data dictionary for file # "_DIU
+6 DO MES^XPDUTL(TEXT)
+7 DO EN^DIU2
End DoDot:1
+8 QUIT
+9 ;
+10 ;==========================================
RMQUERIX ;Remove the QUERI extracts.
+1 NEW IEN,IENS,KFDA,MSG,NAME,NAMES,NUM
+2 ;Deletion from file #19.2 covered by ICR #3732.
+3 ;Delete the Option Scheduling file entries.
+4 DO BMES^XPDUTL("Deleting the QUERI extracts.")
+5 FOR NAME="PXRM EXTRACT VA-IHD QUERI","PXRM EXTRACT VA-MH QUERI"
Begin DoDot:1
+6 SET IEN=+$$FIND1^DIC(19.2,"","BX",NAME,"","","MSG")
+7 IF IEN=0
QUIT
+8 DO BMES^XPDUTL("Deleting scheduled option "_NAME)
+9 SET IENS=IEN_","
+10 SET KFDA(19.2,IENS,.01)="@"
+11 DO FILE^DIE("","KFDA","MSG")
+12 IF $DATA(MSG)
DO AWRITE^PXRMUTIL("MSG")
End DoDot:1
+13 ;Delete all the QUERI patient lists.
+14 DO BMES^XPDUTL("Deleting QUERI patient lists.")
+15 FOR NAMESTART="VA-*IHD QUERI","VA-*MH QUERI"
Begin DoDot:1
+16 SET NAME=NAMESTART
+17 SET NUM=0
+18 DO BMES^XPDUTL("Deleting "_NAMESTART_" lists.")
+19 FOR
SET NAME=$ORDER(^PXRMXP(810.5,"B",NAME))
if NAME'[NAMESTART
QUIT
Begin DoDot:2
+20 SET IEN=+$$FIND1^DIC(810.5,"","BX",NAME,"","","MSG")
+21 IF IEN=0
QUIT
+22 DO MES^XPDUTL("Deleting Patient List "_NAME)
+23 SET IENS=IEN_","
+24 SET KFDA(810.5,IENS,.01)="@"
+25 DO FILE^DIE("","KFDA","MSG")
+26 IF $DATA(MSG)
DO AWRITE^PXRMUTIL("MSG")
+27 SET NUM=NUM+1
End DoDot:2
+28 DO BMES^XPDUTL("Deleted "_NUM_" "_NAMESTART_" lists.")
End DoDot:1
+29 QUIT
+30 ;
+31 ;==========================================
UPCSPON ;Make all the .01s in the Sponsor file uppercase.
+1 NEW FDA,NEWIEN,NEWNAME,MSG,OLDIEN,OLDNAME,RPL
+2 DO BMES^XPDUTL("Checking for Sponsor Names that need to be changed to all uppercase.")
+3 SET OLDNAME=""
+4 FOR
SET OLDNAME=$ORDER(^PXRMD(811.6,"B",OLDNAME))
if OLDNAME=""
QUIT
Begin DoDot:1
+5 IF OLDNAME'?.E1.L.E
QUIT
+6 SET NEWNAME=$$UP^XLFSTR(OLDNAME)
+7 ;If the uppercase name already exists repoint the lowercase one
+8 ;to it.
+9 SET NEWIEN=+$$FIND1^DIC(811.6,"","BXU",NEWNAME)
IF NEWIEN>0
Begin DoDot:2
+10 KILL RPL
+11 DO BMES^XPDUTL("The uppercase version of "_OLDNAME_" already exists at IEN="_NEWIEN)
+12 DO MES^XPDUTL("repointing to it.")
+13 SET OLDIEN=$ORDER(^PXRMD(811.6,"B",OLDNAME,""))
+14 SET RPL(1)=OLDIEN_U_NEWIEN
+15 DO EN^DITP(811.6,.RPL)
+16 ;Remove the lowercase entry.
+17 SET FDA(811.6,OLDIEN_",",.01)="@"
+18 DO FILE^DIE("","FDA","MSG")
End DoDot:2
QUIT
+19 DO BMES^XPDUTL("Renaming: "_OLDNAME)
+20 DO MES^XPDUTL("To: "_NEWNAME)
+21 DO RENAME^PXRMUTIL(811.6,OLDNAME,NEWNAME)
End DoDot:1
+22 ;
+23 ;Remove the old 'B' and 'BN' indexes and build the new 'B'.
+24 KILL ^PXRMD(811.6,"B"),^PXRMD(811.6,"BN")
+25 DO BMES^XPDUTL("Rebuilding Sponsor B index.")
+26 NEW DIK
+27 SET DIK="^PXRMD(811.6,"
SET DIK(1)=".01^B"
+28 DO ENALL^DIK
+29 QUIT
+30 ;
