Routine: PXRMTXIC

PXRMTXIC ;SLC/PKR - Reminder Taxonomy integrity check and repair. ;04/22/2014

 ;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404

 ;===================================

CHECKALL ;Check all taxonomies.

 N IEN,NAME,TEXT

 D MES^XPDUTL("Check the integrity of all reminder taxonomies.")

 S NAME=""

 F  S NAME=$O(^PXD(811.2,"B",NAME)) Q:(NAME="")  D

 . S IEN=$O(^PXD(811.2,"B",NAME,""))

 . S TEXT(1)=" "

 . S TEXT(2)="Checking "_NAME_" (IEN="_IEN_")"

 . D MES^XPDUTL(.TEXT)

 . D INTCHK(IEN)

 ;===================================

CHECKONE ;Check selected definitions.

 N DIC,DTOUT,DUOUT,IEN,OK,Y

 S DIC="^PXD(811.2,"

 S DIC(0)="AEMQ"

 S DIC("A")="Select Reminder Taxonomy: "

GETTAX ;Get the taxonomy to check.

W !

 D ^DIC

 I ($D(DTOUT))!($D(DUOUT)) Q

 I Y=-1 Q

 S IEN=$P(Y,U,1)

 D INTCHK(IEN)

 G GETTAX

 ;===================================

INTCHK(TAXIEN) ;Taxonomy integrity check.

 ;Check for search term inconsistencies.

 N CODESYS,DA1,IENS,NPROB,NTC,SAVEOK,TC,TCLIST,TEXT

 S TC=""

 F  S TC=$O(^PXD(811.2,TAXIEN,20,"ATC",TC)) Q:TC=""  D

 . S CODESYS=""

 . F  S CODESYS=$O(^PXD(811.2,TAXIEN,20,"ATC",TC,CODESYS)) Q:CODESYS=""  D

 .. S DA1=$P(^PXD(811.2,TAXIEN,20,"ATC",TC,CODESYS),U,1)

 .. S TCLIST(DA1,TC,CODESYS)=""

 ;Count the number of search terms that were stored and overwritten

 ;at DA1. There is a problem if there is more than one.

 S DA1=0

 F  S DA1=$O(TCLIST(DA1)) Q:DA1=""  D

 . S NTC=0,TC=""

 . F  S TC=$O(TCLIST(DA1,TC)) Q:TC=""  D

 .. S NTC=NTC+1

 . S TCLIST(DA1)=NTC

 S (DA1,NPROB)=0

 F  S DA1=$O(TCLIST(DA1)) Q:DA1=""  D

 . I TCLIST(DA1)<2 Q

 . S NPROB=NPROB+1

 . S NL=0,TC=""

 . S NL=NL+1,TEXT(NL)="WARNING: "_TCLIST(DA1)_" different search terms have been stored as the number "_DA1_" search term."

 . S NL=NL+1,TEXT(NL)="There can only be one number "_DA1_" search term."

 . S NL=NL+1,TEXT(NL)="The search terms were:"

 . F  S TC=$O(TCLIST(DA1,TC)) Q:TC=""  D

 .. S CODESYS=""

 .. F  S CODESYS=$O(TCLIST(DA1,TC,CODESYS)) Q:CODESYS=""  D

 ... S NL=NL+1,TEXT(NL)=" "_TC_"; coding system - "_CODESYS

 D MES^XPDUTL(.TEXT)

 ;If there were no problems quit.

 I NPROB=0 D MES^XPDUTL("No problems were found.") Q

 ;Reconstruct the 20 node using the "ATCC" index.

 K ^TMP("PXRMCODES",$J)

 M ^TMP("PXRMCODES",$J)=^PXD(811.2,TAXIEN,20,"ATCC")

 ;Delete the 20 node, then rebuild it.

 K ^PXD(811.2,TAXIEN,20)

 S SAVEOK=$$SAVETC^PXRMTXIM(TAXIEN)

 I SAVEOK D POSTSAVE^PXRMTXSM(TAXIEN)

 K ^TMP("PXRMCODES",$J)

 S TEXT="Reconstruction done."

 D MES^XPDUTL(.TEXT)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTXIC   2569     printed  Mar 13, 2025@20:54:13                                                                                                                                                                                                    Page 2

PXRMTXIC  ;SLC/PKR - Reminder Taxonomy integrity check and repair. ;04/22/2014

 +1       ;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404

 +2       ;

 +3       ;===================================

CHECKALL  ;Check all taxonomies.

 +1        NEW IEN,NAME,TEXT

 +2        DO MES^XPDUTL("Check the integrity of all reminder taxonomies.")

 +3        SET NAME=""

 +4        FOR

               SET NAME=$ORDER(^PXD(811.2,"B",NAME))

               if (NAME="")

                   QUIT

               Begin DoDot:1

 +5                SET IEN=$ORDER(^PXD(811.2,"B",NAME,""))

 +6                SET TEXT(1)=" "

 +7                SET TEXT(2)="Checking "_NAME_" (IEN="_IEN_")"

 +8                DO MES^XPDUTL(.TEXT)

 +9                DO INTCHK(IEN)

               End DoDot:1

 +10       QUIT

 +11      ;

 +12      ;===================================

CHECKONE  ;Check selected definitions.

 +1        NEW DIC,DTOUT,DUOUT,IEN,OK,Y

 +2        SET DIC="^PXD(811.2,"

 +3        SET DIC(0)="AEMQ"

 +4        SET DIC("A")="Select Reminder Taxonomy: "

GETTAX    ;Get the taxonomy to check.

 +1        WRITE !

 +2        DO ^DIC

 +3        IF ($DATA(DTOUT))!($DATA(DUOUT))

               QUIT

 +4        IF Y=-1

               QUIT

 +5        SET IEN=$PIECE(Y,U,1)

 +6        DO INTCHK(IEN)

 +7        GOTO GETTAX

 +8        QUIT

 +9       ;

 +10      ;===================================

INTCHK(TAXIEN) ;Taxonomy integrity check.

 +1       ;Check for search term inconsistencies.

 +2        NEW CODESYS,DA1,IENS,NPROB,NTC,SAVEOK,TC,TCLIST,TEXT

 +3        SET TC=""

 +4        FOR

               SET TC=$ORDER(^PXD(811.2,TAXIEN,20,"ATC",TC))

               if TC=""

                   QUIT

               Begin DoDot:1

 +5                SET CODESYS=""

 +6                FOR

                       SET CODESYS=$ORDER(^PXD(811.2,TAXIEN,20,"ATC",TC,CODESYS))

                       if CODESYS=""

                           QUIT

                       Begin DoDot:2

 +7                        SET DA1=$PIECE(^PXD(811.2,TAXIEN,20,"ATC",TC,CODESYS),U,1)

 +8                        SET TCLIST(DA1,TC,CODESYS)=""

                       End DoDot:2

               End DoDot:1

 +9       ;Count the number of search terms that were stored and overwritten

 +10      ;at DA1. There is a problem if there is more than one.

 +11       SET DA1=0

 +12       FOR

               SET DA1=$ORDER(TCLIST(DA1))

               if DA1=""

                   QUIT

               Begin DoDot:1

 +13               SET NTC=0

                   SET TC=""

 +14               FOR

                       SET TC=$ORDER(TCLIST(DA1,TC))

                       if TC=""

                           QUIT

                       Begin DoDot:2

 +15                       SET NTC=NTC+1

                       End DoDot:2

 +16               SET TCLIST(DA1)=NTC

               End DoDot:1

 +17       SET (DA1,NPROB)=0

 +18       FOR

               SET DA1=$ORDER(TCLIST(DA1))

               if DA1=""

                   QUIT

               Begin DoDot:1

 +19               IF TCLIST(DA1)<2

                       QUIT

 +20               SET NPROB=NPROB+1

 +21               SET NL=0

                   SET TC=""

 +22               SET NL=NL+1

                   SET TEXT(NL)="WARNING: "_TCLIST(DA1)_" different search terms have been stored as the number "_DA1_" search term."

 +23               SET NL=NL+1

                   SET TEXT(NL)="There can only be one number "_DA1_" search term."

 +24               SET NL=NL+1

                   SET TEXT(NL)="The search terms were:"

 +25               FOR

                       SET TC=$ORDER(TCLIST(DA1,TC))

                       if TC=""

                           QUIT

                       Begin DoDot:2

 +26                       SET CODESYS=""

 +27                       FOR

                               SET CODESYS=$ORDER(TCLIST(DA1,TC,CODESYS))

                               if CODESYS=""

                                   QUIT

                               Begin DoDot:3

 +28                               SET NL=NL+1

                                   SET TEXT(NL)=" "_TC_"; coding system - "_CODESYS

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +29       DO MES^XPDUTL(.TEXT)

 +30      ;If there were no problems quit.

 +31       IF NPROB=0

               DO MES^XPDUTL("No problems were found.")

               QUIT

 +32      ;

 +33      ;Reconstruct the 20 node using the "ATCC" index.

 +34       KILL ^TMP("PXRMCODES",$JOB)

 +35       MERGE ^TMP("PXRMCODES",$JOB)=^PXD(811.2,TAXIEN,20,"ATCC")

 +36      ;Delete the 20 node, then rebuild it.

 +37       KILL ^PXD(811.2,TAXIEN,20)

 +38       SET SAVEOK=$$SAVETC^PXRMTXIM(TAXIEN)

 +39       IF SAVEOK

               DO POSTSAVE^PXRMTXSM(TAXIEN)

 +40       KILL ^TMP("PXRMCODES",$JOB)

 +41       SET TEXT="Reconstruction done."

 +42       DO MES^XPDUTL(.TEXT)

 +43       QUIT

 +44      ;

PXRMTXIC.m