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)
Q
;
;===================================
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
Q
;
;===================================
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)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTXIC 2569 printed Oct 16, 2024@17:50:24 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 ;
