PXRMP42I.m

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 ---PXRMP42I   4275     printed  Feb 18, 2025@23:14:03                                                                                                                                                                                                    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      ;