PXRMTAXD ; SLC/PKR - Routines used by taxonomy data dictionary. ;10/23/2015
;;2.0;CLINICAL REMINDERS;**26,47**;Feb 04, 2005;Build 291
;
;===================================
BLD30N(IEN) ;Build the 30 node (USE IN DIALOG CODES) after the 20 node
;has been built.
I '$D(^PXD(811.2,IEN,20,"AUID")) Q
S CODESYS=""
F S CODESYS=$O(^PXD(811.2,IEN,20,"AUID",CODESYS)) Q:CODESYS="" D
. S CODE=""
. F S CODE=$O(^PXD(811.2,IEN,20,"AUID",CODESYS,CODE)) Q:CODE="" D
.. D SAVEUIDC(IEN,CODESYS,CODE)
Q
;
;===================================
CDINPTR(CODE) ;Input transform for code field of Use in Dialogs Code multiple.
N CODESYS,CODESYSL,DATA,RESULT,TEXT,VALID
S VALID=$$VCODE^PXRMLEX(CODE)
I 'VALID D
. S TEXT(1)="Only valid codes from a supported coding system can be entered here."
. S TEXT(2)=CODE_" is not a valid code."
. D EN^DDIOL(.TEXT)
Q VALID
;
;========================================
CHGUID(IEN,CODESYS,CODE,UID) ;For all instances of coding system code pair in
;the 20 node change the value of UID.
N FDA,IENS,IND,JND,KND,MSG,NCHG,NUID,TEMP,TERM
S NCHG=0,TERM=""
F S TERM=$O(^PXD(811.2,IEN,20,"ATCC",TERM)) Q:TERM="" D
. I '$D(^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS,CODE)) Q
. S IND=$P(^PXD(811.2,IEN,20,"ATC",TERM,CODESYS),U,1)
. S JND=$P(^PXD(811.2,IEN,20,"ATC",TERM,CODESYS),U,2)
. S NUID=$P(^PXD(811.2,IEN,20,IND,1,JND,0),U,3)
. S KND=0
. F S KND=+$O(^PXD(811.2,IEN,20,IND,1,JND,1,KND)) Q:KND=0 D
.. S TEMP=^PXD(811.2,IEN,20,IND,1,JND,1,KND,0)
.. I $P(TEMP,U,1)'=CODE Q
..;If UID has not changed then skip this one
.. I $P(TEMP,U,2)=UID Q
.. S NCHG=NCHG+1
.. S IENS=KND_","_JND_","_IND_","_IEN_","
.. S FDA(811.2312,IENS,1)=UID
.. I UID=0 S NUID=NUID-1
.. I UID=1 S NUID=NUID+1
. S IENS=JND_","_IND_","_IEN_","
. S FDA(811.231,IENS,3)=NUID
I NCHG>0 D FILE^DIE("","FDA","MSG")
Q NCHG
;
;===================================
CSYSOPTR(CODESYS) ;Output transform for Coding System field of Use in Dialogs
;Codes multiple.
;DBIA #5679
Q $S($D(DDS):$P($$CSYS^LEXU(CODESYS),U,4),1:CODESYS)
;
;====================================
INUSE(TIEN,CHKTYP) ;Check to see if a taxonomy is in use. Used for the "DEL"
;node: ^DD(811.2,.01,"DEL",1,0) and inactivation check in
;POSTACT^PXRMTXSM.
N FNUM,IEN,NAME,NL,TEXT,TYPE
K ^TMP($J,"TDATA"),^TMP($J,"DLG FIND")
D BLDLIST^PXRMFRPT(811.2,"PXD(811.2,",TIEN,"TDATA")
I '$D(^TMP($J,"TDATA")) K ^TMP($J,"DLG FIND") Q 0
I CHKTYP="DEL" S TEXT(1)="This taxonomy cannot be deleted, it is used by the following:"
I CHKTYP="INACT" S TEXT(1)="Warning - this taxonomy has been inactivated but, it is used by the following:"
S NL=1,TYPE=""
F S TYPE=$O(^TMP($J,"TDATA",811.2,TIEN,TYPE)) Q:TYPE="" D
. S FNUM=$S(TYPE="DEF":811.9,TYPE="TERM":811.5,TYPE="DIALOG":801.41,TYPE="ROC":801,TYPE="OCRULE":801.1)
. S NL=NL+1,TEXT(NL)=" "_$S(TYPE="DEF":"Definitions:",TYPE="TERM":"Terms:",TYPE="DIALOG":"Dialogs:",TYPE="ROC":"Orderable Item Groups:",TYPE="OCRULE":"Order Check Rules:",1:"")
. S IEN=""
. F S IEN=$O(^TMP($J,"TDATA",811.2,TIEN,TYPE,IEN)) Q:IEN="" D
.. S NL=NL+1,TEXT(NL)=" "_$$GET1^DIQ(FNUM,IEN,.01)
. S NL=NL+1,TEXT(NL)=" "
D EN^DDIOL(.TEXT)
K ^TMP($J,"TDATA"),^TMP($J,"DLG FIND")
Q 1
;
;========================================
KENODE(DA,X) ;Kill the "AE" (coding system, code) index.
;X(1) is the code.
N CODESYS,COUNT
S CODESYS=$P(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
;Do not delete the entry if the code exists under another term/code.
S COUNT=$P(^PXD(811.2,DA(3),20,"AE",CODESYS,X(1)),U,2)-1
I COUNT>0 S $P(^PXD(811.2,DA(3),20,"AE",CODESYS,X(1)),U,2)=COUNT
I COUNT=0 K ^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))
Q
;
;========================================
KILLUIDC(IEN,CODE,CODESYS) ;Remove codes from the Use In Dialogs Codes multiple
;when Use In Dialog is false.
I '$D(^PXD(811.2,IEN,30,"ACC",CODE,CODESYS)) Q
N IENS,KFDA,MSG
S IENS=^PXD(811.2,IEN,30,"ACC",CODE,CODESYS)_","_IEN_","
S KFDA(811.24,IENS,.01)="@"
D FILE^DIE("","KFDA","MSG")
K ^PXD(811.2,IEN,30,"ACC",CODE,CODESYS)
Q
;
;========================================
KTC(DA,X) ;Kill the "ATC" (term, coding system) index.
;X(1) is the coding system.
N TERM
S TERM=^PXD(811.2,DA(2),20,DA(1),0)
K ^PXD(811.2,DA(2),20,"ATC",TERM,X(1))
Q
;
;========================================
KTCC(DA,X) ;KILL the "ATCC" (term, coding system, code) index.
;X(1) is the code, X(2) is Use in Dialog.
N CODESYS,TERM
S TERM=^PXD(811.2,DA(3),20,DA(2),0)
S CODESYS=$P(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
K ^PXD(811.2,DA(3),20,"ATCC",TERM,CODESYS,X(1))
Q
;
;========================================
KUID(DA,X) ;Kill the "AUID" Use in Dialog index and remove the code
;from the Use In Dialogs Codes multiple.
;X(1) is the code, X(2) is Use in Dialog.
N CODESYS
S CODESYS=$P(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
I '$D(^PXD(811.2,DA(3),20,"AUID",CODESYS,X(1))) Q
K ^PXD(811.2,DA(3),20,"AUID",CODESYS,X(1))
D KILLUIDC(DA(3),X(1),CODESYS)
Q
;
;========================================
KUIDC(DA,X) ;When a code is deleted from the Use In Dialog Codes multiple
;find the code in the Selected Codes Multiple and change
;UID to 0.
;X(1) is the code, X(2) is the coding system.
;DBIA #5746 Only execute this if called from PXRM DIALOG TAXONOMY EDIT.
I $P($G(DDS),U,2)'="PXRM DIALOG TAXONOMY EDIT" Q
K ^PXD(811.2,DA(1),30,"ACC",X(1),X(2))
N NCHG
;Search for the code in the Selected Codes Multiple and set UID=0.
S NCHG=$$CHGUID^PXRMTAXD(DA(1),X1(2),X1(1),0)
Q
;
;========================================
RBLD20I(D0) ;Rebuild all the indexes on the 20 node for a taxonomy. This
;also rebuilds the 30 node.
N CODESYS,D1,D2,D3,DA,NAME,NUID,TCCDA,TCCX,TEMP,UID,X
;X(1) is the code and X(2) is UID.
K ^PXD(811.2,D0,20,"AE")
K ^PXD(811.2,D0,20,"ATC")
K ^PXD(811.2,D0,20,"ATCC")
K ^PXD(811.2,D0,20,"AUID")
K ^PXD(811.2,D0,30)
S DA(3)=D0,D1=0,TCCDA(2)=D0
F S D1=+$O(^PXD(811.2,D0,20,D1)) Q:D1=0 D
. S DA(2)=D1,D2=0,TCCDA(1)=D1
. F S D2=+$O(^PXD(811.2,D0,20,D1,1,D2)) Q:D2=0 D
.. S NUID=0
.. S CODESYS=$P(^PXD(811.2,D0,20,D1,1,D2,0),U,1)
.. I $L(CODESYS)>3 D
... S CODESYS=$E(CODESYS,1,3)
... S $P(^PXD(811.2,D0,20,D1,1,D2,0),U,1)=CODESYS
.. S TCCX(1)=CODESYS
.. S DA(1)=D2,D3=0,TCCDA=D2
.. D STC^PXRMTAXD(.TCCDA,.TCCX)
.. F S D3=+$O(^PXD(811.2,D0,20,D1,1,D2,1,D3)) Q:D3=0 D
... S DA=D3
... S TEMP=^PXD(811.2,D0,20,D1,1,D2,1,D3,0)
... S X(1)=$P(TEMP,U,1)
... D SENODE^PXRMTAXD(.DA,.X)
... S X(2)=$P(TEMP,U,2)
... D STCC^PXRMTAXD(.DA,.X)
... I +X(2)=0 Q
... S NUID=NUID+1
... D SUID^PXRMTAXD(.DA,.X)
.. S $P(^PXD(811.2,D0,20,D1,1,D2,0),U,3)=NUID
D BLD30N(D0)
Q
;
;========================================
RBLD20IA ;Rebuild all the indexes on the 20 node.
N D0,NAME
D BMES^XPDUTL("Building the Selected Codes multiple indexes.")
S NAME=""
F S NAME=$O(^PXD(811.2,"B",NAME)) Q:NAME="" D
. S D0=$O(^PXD(811.2,"B",NAME,""))
. D MES^XPDUTL(" Taxonomy: "_NAME_"; IEN="_D0)
. D RBLD20I(D0)
Q
;
;========================================
RBLDUIDI(D0) ;Rebuild the "AUID" index for an individual taxonomy.
N D1,D2,D3,DA,NUID,TEMP,UID,X
;X(1) is the code and X(2) is UID.
K ^PXD(811.2,D0,20,"AUID")
K ^PXD(811.2,D0,30)
S DA(3)=D0,D1=0
F S D1=+$O(^PXD(811.2,D0,20,D1)) Q:D1=0 D
. S DA(2)=D1,D2=0
. F S D2=+$O(^PXD(811.2,D0,20,D1,1,D2)) Q:D2=0 D
.. S DA(1)=D2,D3=0,NUID=0
.. F S D3=+$O(^PXD(811.2,D0,20,D1,1,D2,1,D3)) Q:D3=0 D
... S DA=D3
... S TEMP=^PXD(811.2,D0,20,D1,1,D2,1,D3,0)
... S X(1)=$P(TEMP,U,1)
... S X(2)=$P(TEMP,U,2)
... I +X(2)=0 Q
... S NUID=NUID+1
... D SUID^PXRMTAXD(.DA,.X)
.. S $P(^PXD(811.2,D0,20,D1,1,D2,0),U,3)=NUID
Q
;
;========================================
RBLDUID ;Rebuild the "AUID" index for all taxonomies.
N D0,NAME
D BMES^XPDUTL("Building AUID index for all taxonomies.")
S NAME=""
F S NAME=$O(^PXD(811.2,"B",NAME)) Q:NAME="" D
. S D0=$O(^PXD(811.2,"B",NAME,""))
. D MES^XPDUTL(" Taxonomy: "_NAME_"; IEN="_D0)
. D RBLDUIDI(D0)
Q
;
;========================================
SAVEUIDC(IEN,CODESYS,CODE) ;Save codes marked as Use In Dialog in the
;Use In Dialogs Codes Multiple.
;This cannot be called from CFRANGE^PXRMTXCR while it is building the
;Selected Codes multiple because it will be an UPDATE^DIE call inside
;an UPDATE^DIE call.
I $D(PXRMCFR) Q
I $D(^PXD(811.2,IEN,30,"B",CODE)) Q
N IENS,FDA,MSG
S IENS="+1,"_IEN_","
S FDA(811.24,IENS,.01)=CODE
S FDA(811.24,IENS,1)=CODESYS
D UPDATE^DIE("","FDA","","MSG")
Q
;
;========================================
SENODE(DA,X) ;Set the "AE" (coding system, code) index.
;X(1) is the code.
N CODEP,CODESYS,COUNT
S CODESYS=$P(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
;The ICD and CPT coding systems are "grandfathered" to
;use the pointer in the Clinical Reminders Index for V CPT
;and V POV so save the code pointer.
S CODEP=X(1)
;DBIA #5747
I CODESYS="ICD" S CODEP=$P($$CODEN^ICDEX(X(1),80),"~",1)
I CODESYS="ICP" S CODEP=$P($$CODEN^ICDEX(X(1),80.1),"~",1)
I CODESYS="CPC" S CODEP=$P($$STATCHK^ICPTAPIU(X(1)),U,2)
I CODESYS="CPT" S CODEP=$P($$STATCHK^ICPTAPIU(X(1)),U,2)
;Increment COUNT for each term/code the code is stored under.
S COUNT=+$P($G(^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))),U,2)+1
S ^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))=CODEP_U_COUNT
Q
;
;========================================
STC(DA,X) ;Set the "ATC" (term, coding system) index.
;X(1) is the coding system.
N TERM
S TERM=^PXD(811.2,DA(2),20,DA(1),0)
S ^PXD(811.2,DA(2),20,"ATC",TERM,X(1))=DA(1)_U_DA
Q
;
;========================================
STCC(DA,X) ;Set the "ATCC" (term, coding system, code) index.
;X(1) is the code, X(2) is Use in Dialog.
N CODESYS,TERM
S TERM=^PXD(811.2,DA(3),20,DA(2),0)
S CODESYS=$P(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
S ^PXD(811.2,DA(3),20,"ATCC",TERM,CODESYS,X(1))=X(2)
Q
;
;========================================
SUID(DA,X) ;Set the "AUID" Use in Dialog index.
;X(1) is the code, X(2) is Use in Dialog.
N ACTDT,BDESC,CODESYS,DATA,INACTDT,LDESC,RESULT,TEMP,VP
I +X(2)=0 Q
S CODESYS=$P(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
I $D(^PXD(811.2,DA(3),20,"AUID",CODESYS,X(1))) Q
;DBIA #5679
S RESULT=$$PERIOD^LEXU(X(1),CODESYS,.DATA)
I +RESULT=-1 Q
S ACTDT=0
F S ACTDT=$O(DATA(ACTDT)) Q:ACTDT="" D
. S TEMP=DATA(ACTDT)
. S INACTDT=$P(TEMP,U,1)
. I INACTDT="" S INACTDT="DT"
. S VP=$P(TEMP,U,3)
. S LDESC=DATA(ACTDT,0)
. S BDESC=$P(TEMP,U,4)
. I BDESC="" S BDESC=LDESC
. S ^PXD(811.2,DA(3),20,"AUID",CODESYS,X(1),ACTDT,INACTDT)=$P(VP,";",1)_U_LDESC
;If UID=1 add the code to the Use In Dialog Codes Multiple.
;This cannot be done if the entry is being installed by Reminder
;Exchange because it causes an UPDATE^DIE call to make another
;UPDATE^DIE call. The Use In Dialog Codes Multiple is built after
;the entry is installed by a call to BLD30N^PXRMTAXD.
I $G(PXRMEXCH)=1 Q
D SAVEUIDC(DA(3),CODESYS,X(1))
Q
;
;========================================
SUIDC(DA,X) ;Copy codes from the Use in Dialog Codes multiple to the Selected
;Codes structure.
;X(1) is the code, X(2) is the coding system.
S ^PXD(811.2,DA(1),30,"ACC",X(1),X(2))=DA
;DBIA #5746 Only execute this if called from PXRM DIALOG TAXONOMY EDIT.
I $P($G(DDS),U,2)'="PXRM DIALOG TAXONOMY EDIT" Q
N NCHG
S NCHG=$$CHGUID^PXRMTAXD(DA(1),X(2),X(1),1)
I NCHG>0 Q
;No instances of this code were found in the 20 node so create one.
K ^TMP("PXRMCODES",$J)
S ^TMP("PXRMCODES",$J,X(1),X(2),X(1))=1
D SAVETC^PXRMTXIM(DA(1))
D POSTSAVE^PXRMTXSM(DA(1))
Q
;
;========================================
VCSYS(LEXSAB) ;Return true if the coding system is supported in taxonomies.
I LEXSAB="10D" Q 1
I LEXSAB="10P" Q 1
I LEXSAB="CPC" Q 1
I LEXSAB="CPT" Q 1
I LEXSAB="ICD" Q 1
I LEXSAB="ICP" Q 1
I LEXSAB="SCT" Q 1
D EN^DDIOL(LEXSAB_" is not a supported coding system.")
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTAXD 12127 printed Dec 13, 2024@01:49:20 Page 2
PXRMTAXD ; SLC/PKR - Routines used by taxonomy data dictionary. ;10/23/2015
+1 ;;2.0;CLINICAL REMINDERS;**26,47**;Feb 04, 2005;Build 291
+2 ;
+3 ;===================================
BLD30N(IEN) ;Build the 30 node (USE IN DIALOG CODES) after the 20 node
+1 ;has been built.
+2 IF '$DATA(^PXD(811.2,IEN,20,"AUID"))
QUIT
+3 SET CODESYS=""
+4 FOR
SET CODESYS=$ORDER(^PXD(811.2,IEN,20,"AUID",CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+5 SET CODE=""
+6 FOR
SET CODE=$ORDER(^PXD(811.2,IEN,20,"AUID",CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:2
+7 DO SAVEUIDC(IEN,CODESYS,CODE)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
+10 ;===================================
CDINPTR(CODE) ;Input transform for code field of Use in Dialogs Code multiple.
+1 NEW CODESYS,CODESYSL,DATA,RESULT,TEXT,VALID
+2 SET VALID=$$VCODE^PXRMLEX(CODE)
+3 IF 'VALID
Begin DoDot:1
+4 SET TEXT(1)="Only valid codes from a supported coding system can be entered here."
+5 SET TEXT(2)=CODE_" is not a valid code."
+6 DO EN^DDIOL(.TEXT)
End DoDot:1
+7 QUIT VALID
+8 ;
+9 ;========================================
CHGUID(IEN,CODESYS,CODE,UID) ;For all instances of coding system code pair in
+1 ;the 20 node change the value of UID.
+2 NEW FDA,IENS,IND,JND,KND,MSG,NCHG,NUID,TEMP,TERM
+3 SET NCHG=0
SET TERM=""
+4 FOR
SET TERM=$ORDER(^PXD(811.2,IEN,20,"ATCC",TERM))
if TERM=""
QUIT
Begin DoDot:1
+5 IF '$DATA(^PXD(811.2,IEN,20,"ATCC",TERM,CODESYS,CODE))
QUIT
+6 SET IND=$PIECE(^PXD(811.2,IEN,20,"ATC",TERM,CODESYS),U,1)
+7 SET JND=$PIECE(^PXD(811.2,IEN,20,"ATC",TERM,CODESYS),U,2)
+8 SET NUID=$PIECE(^PXD(811.2,IEN,20,IND,1,JND,0),U,3)
+9 SET KND=0
+10 FOR
SET KND=+$ORDER(^PXD(811.2,IEN,20,IND,1,JND,1,KND))
if KND=0
QUIT
Begin DoDot:2
+11 SET TEMP=^PXD(811.2,IEN,20,IND,1,JND,1,KND,0)
+12 IF $PIECE(TEMP,U,1)'=CODE
QUIT
+13 ;If UID has not changed then skip this one
+14 IF $PIECE(TEMP,U,2)=UID
QUIT
+15 SET NCHG=NCHG+1
+16 SET IENS=KND_","_JND_","_IND_","_IEN_","
+17 SET FDA(811.2312,IENS,1)=UID
+18 IF UID=0
SET NUID=NUID-1
+19 IF UID=1
SET NUID=NUID+1
End DoDot:2
+20 SET IENS=JND_","_IND_","_IEN_","
+21 SET FDA(811.231,IENS,3)=NUID
End DoDot:1
+22 IF NCHG>0
DO FILE^DIE("","FDA","MSG")
+23 QUIT NCHG
+24 ;
+25 ;===================================
CSYSOPTR(CODESYS) ;Output transform for Coding System field of Use in Dialogs
+1 ;Codes multiple.
+2 ;DBIA #5679
+3 QUIT $SELECT($DATA(DDS):$PIECE($$CSYS^LEXU(CODESYS),U,4),1:CODESYS)
+4 ;
+5 ;====================================
INUSE(TIEN,CHKTYP) ;Check to see if a taxonomy is in use. Used for the "DEL"
+1 ;node: ^DD(811.2,.01,"DEL",1,0) and inactivation check in
+2 ;POSTACT^PXRMTXSM.
+3 NEW FNUM,IEN,NAME,NL,TEXT,TYPE
+4 KILL ^TMP($JOB,"TDATA"),^TMP($JOB,"DLG FIND")
+5 DO BLDLIST^PXRMFRPT(811.2,"PXD(811.2,",TIEN,"TDATA")
+6 IF '$DATA(^TMP($JOB,"TDATA"))
KILL ^TMP($JOB,"DLG FIND")
QUIT 0
+7 IF CHKTYP="DEL"
SET TEXT(1)="This taxonomy cannot be deleted, it is used by the following:"
+8 IF CHKTYP="INACT"
SET TEXT(1)="Warning - this taxonomy has been inactivated but, it is used by the following:"
+9 SET NL=1
SET TYPE=""
+10 FOR
SET TYPE=$ORDER(^TMP($JOB,"TDATA",811.2,TIEN,TYPE))
if TYPE=""
QUIT
Begin DoDot:1
+11 SET FNUM=$SELECT(TYPE="DEF":811.9,TYPE="TERM":811.5,TYPE="DIALOG":801.41,TYPE="ROC":801,TYPE="OCRULE":801.1)
+12 SET NL=NL+1
SET TEXT(NL)=" "_$SELECT(TYPE="DEF":"Definitions:",TYPE="TERM":"Terms:",TYPE="DIALOG":"Dialogs:",TYPE="ROC":"Orderable Item Groups:",TYPE="OCRULE":"Order Check Rules:",1:"")
+13 SET IEN=""
+14 FOR
SET IEN=$ORDER(^TMP($JOB,"TDATA",811.2,TIEN,TYPE,IEN))
if IEN=""
QUIT
Begin DoDot:2
+15 SET NL=NL+1
SET TEXT(NL)=" "_$$GET1^DIQ(FNUM,IEN,.01)
End DoDot:2
+16 SET NL=NL+1
SET TEXT(NL)=" "
End DoDot:1
+17 DO EN^DDIOL(.TEXT)
+18 KILL ^TMP($JOB,"TDATA"),^TMP($JOB,"DLG FIND")
+19 QUIT 1
+20 ;
+21 ;========================================
KENODE(DA,X) ;Kill the "AE" (coding system, code) index.
+1 ;X(1) is the code.
+2 NEW CODESYS,COUNT
+3 SET CODESYS=$PIECE(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
+4 ;Do not delete the entry if the code exists under another term/code.
+5 SET COUNT=$PIECE(^PXD(811.2,DA(3),20,"AE",CODESYS,X(1)),U,2)-1
+6 IF COUNT>0
SET $PIECE(^PXD(811.2,DA(3),20,"AE",CODESYS,X(1)),U,2)=COUNT
+7 IF COUNT=0
KILL ^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))
+8 QUIT
+9 ;
+10 ;========================================
KILLUIDC(IEN,CODE,CODESYS) ;Remove codes from the Use In Dialogs Codes multiple
+1 ;when Use In Dialog is false.
+2 IF '$DATA(^PXD(811.2,IEN,30,"ACC",CODE,CODESYS))
QUIT
+3 NEW IENS,KFDA,MSG
+4 SET IENS=^PXD(811.2,IEN,30,"ACC",CODE,CODESYS)_","_IEN_","
+5 SET KFDA(811.24,IENS,.01)="@"
+6 DO FILE^DIE("","KFDA","MSG")
+7 KILL ^PXD(811.2,IEN,30,"ACC",CODE,CODESYS)
+8 QUIT
+9 ;
+10 ;========================================
KTC(DA,X) ;Kill the "ATC" (term, coding system) index.
+1 ;X(1) is the coding system.
+2 NEW TERM
+3 SET TERM=^PXD(811.2,DA(2),20,DA(1),0)
+4 KILL ^PXD(811.2,DA(2),20,"ATC",TERM,X(1))
+5 QUIT
+6 ;
+7 ;========================================
KTCC(DA,X) ;KILL the "ATCC" (term, coding system, code) index.
+1 ;X(1) is the code, X(2) is Use in Dialog.
+2 NEW CODESYS,TERM
+3 SET TERM=^PXD(811.2,DA(3),20,DA(2),0)
+4 SET CODESYS=$PIECE(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
+5 KILL ^PXD(811.2,DA(3),20,"ATCC",TERM,CODESYS,X(1))
+6 QUIT
+7 ;
+8 ;========================================
KUID(DA,X) ;Kill the "AUID" Use in Dialog index and remove the code
+1 ;from the Use In Dialogs Codes multiple.
+2 ;X(1) is the code, X(2) is Use in Dialog.
+3 NEW CODESYS
+4 SET CODESYS=$PIECE(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
+5 IF '$DATA(^PXD(811.2,DA(3),20,"AUID",CODESYS,X(1)))
QUIT
+6 KILL ^PXD(811.2,DA(3),20,"AUID",CODESYS,X(1))
+7 DO KILLUIDC(DA(3),X(1),CODESYS)
+8 QUIT
+9 ;
+10 ;========================================
KUIDC(DA,X) ;When a code is deleted from the Use In Dialog Codes multiple
+1 ;find the code in the Selected Codes Multiple and change
+2 ;UID to 0.
+3 ;X(1) is the code, X(2) is the coding system.
+4 ;DBIA #5746 Only execute this if called from PXRM DIALOG TAXONOMY EDIT.
+5 IF $PIECE($GET(DDS),U,2)'="PXRM DIALOG TAXONOMY EDIT"
QUIT
+6 KILL ^PXD(811.2,DA(1),30,"ACC",X(1),X(2))
+7 NEW NCHG
+8 ;Search for the code in the Selected Codes Multiple and set UID=0.
+9 SET NCHG=$$CHGUID^PXRMTAXD(DA(1),X1(2),X1(1),0)
+10 QUIT
+11 ;
+12 ;========================================
RBLD20I(D0) ;Rebuild all the indexes on the 20 node for a taxonomy. This
+1 ;also rebuilds the 30 node.
+2 NEW CODESYS,D1,D2,D3,DA,NAME,NUID,TCCDA,TCCX,TEMP,UID,X
+3 ;X(1) is the code and X(2) is UID.
+4 KILL ^PXD(811.2,D0,20,"AE")
+5 KILL ^PXD(811.2,D0,20,"ATC")
+6 KILL ^PXD(811.2,D0,20,"ATCC")
+7 KILL ^PXD(811.2,D0,20,"AUID")
+8 KILL ^PXD(811.2,D0,30)
+9 SET DA(3)=D0
SET D1=0
SET TCCDA(2)=D0
+10 FOR
SET D1=+$ORDER(^PXD(811.2,D0,20,D1))
if D1=0
QUIT
Begin DoDot:1
+11 SET DA(2)=D1
SET D2=0
SET TCCDA(1)=D1
+12 FOR
SET D2=+$ORDER(^PXD(811.2,D0,20,D1,1,D2))
if D2=0
QUIT
Begin DoDot:2
+13 SET NUID=0
+14 SET CODESYS=$PIECE(^PXD(811.2,D0,20,D1,1,D2,0),U,1)
+15 IF $LENGTH(CODESYS)>3
Begin DoDot:3
+16 SET CODESYS=$EXTRACT(CODESYS,1,3)
+17 SET $PIECE(^PXD(811.2,D0,20,D1,1,D2,0),U,1)=CODESYS
End DoDot:3
+18 SET TCCX(1)=CODESYS
+19 SET DA(1)=D2
SET D3=0
SET TCCDA=D2
+20 DO STC^PXRMTAXD(.TCCDA,.TCCX)
+21 FOR
SET D3=+$ORDER(^PXD(811.2,D0,20,D1,1,D2,1,D3))
if D3=0
QUIT
Begin DoDot:3
+22 SET DA=D3
+23 SET TEMP=^PXD(811.2,D0,20,D1,1,D2,1,D3,0)
+24 SET X(1)=$PIECE(TEMP,U,1)
+25 DO SENODE^PXRMTAXD(.DA,.X)
+26 SET X(2)=$PIECE(TEMP,U,2)
+27 DO STCC^PXRMTAXD(.DA,.X)
+28 IF +X(2)=0
QUIT
+29 SET NUID=NUID+1
+30 DO SUID^PXRMTAXD(.DA,.X)
End DoDot:3
+31 SET $PIECE(^PXD(811.2,D0,20,D1,1,D2,0),U,3)=NUID
End DoDot:2
End DoDot:1
+32 DO BLD30N(D0)
+33 QUIT
+34 ;
+35 ;========================================
RBLD20IA ;Rebuild all the indexes on the 20 node.
+1 NEW D0,NAME
+2 DO BMES^XPDUTL("Building the Selected Codes multiple indexes.")
+3 SET NAME=""
+4 FOR
SET NAME=$ORDER(^PXD(811.2,"B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+5 SET D0=$ORDER(^PXD(811.2,"B",NAME,""))
+6 DO MES^XPDUTL(" Taxonomy: "_NAME_"; IEN="_D0)
+7 DO RBLD20I(D0)
End DoDot:1
+8 QUIT
+9 ;
+10 ;========================================
RBLDUIDI(D0) ;Rebuild the "AUID" index for an individual taxonomy.
+1 NEW D1,D2,D3,DA,NUID,TEMP,UID,X
+2 ;X(1) is the code and X(2) is UID.
+3 KILL ^PXD(811.2,D0,20,"AUID")
+4 KILL ^PXD(811.2,D0,30)
+5 SET DA(3)=D0
SET D1=0
+6 FOR
SET D1=+$ORDER(^PXD(811.2,D0,20,D1))
if D1=0
QUIT
Begin DoDot:1
+7 SET DA(2)=D1
SET D2=0
+8 FOR
SET D2=+$ORDER(^PXD(811.2,D0,20,D1,1,D2))
if D2=0
QUIT
Begin DoDot:2
+9 SET DA(1)=D2
SET D3=0
SET NUID=0
+10 FOR
SET D3=+$ORDER(^PXD(811.2,D0,20,D1,1,D2,1,D3))
if D3=0
QUIT
Begin DoDot:3
+11 SET DA=D3
+12 SET TEMP=^PXD(811.2,D0,20,D1,1,D2,1,D3,0)
+13 SET X(1)=$PIECE(TEMP,U,1)
+14 SET X(2)=$PIECE(TEMP,U,2)
+15 IF +X(2)=0
QUIT
+16 SET NUID=NUID+1
+17 DO SUID^PXRMTAXD(.DA,.X)
End DoDot:3
+18 SET $PIECE(^PXD(811.2,D0,20,D1,1,D2,0),U,3)=NUID
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
+21 ;========================================
RBLDUID ;Rebuild the "AUID" index for all taxonomies.
+1 NEW D0,NAME
+2 DO BMES^XPDUTL("Building AUID index for all taxonomies.")
+3 SET NAME=""
+4 FOR
SET NAME=$ORDER(^PXD(811.2,"B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+5 SET D0=$ORDER(^PXD(811.2,"B",NAME,""))
+6 DO MES^XPDUTL(" Taxonomy: "_NAME_"; IEN="_D0)
+7 DO RBLDUIDI(D0)
End DoDot:1
+8 QUIT
+9 ;
+10 ;========================================
SAVEUIDC(IEN,CODESYS,CODE) ;Save codes marked as Use In Dialog in the
+1 ;Use In Dialogs Codes Multiple.
+2 ;This cannot be called from CFRANGE^PXRMTXCR while it is building the
+3 ;Selected Codes multiple because it will be an UPDATE^DIE call inside
+4 ;an UPDATE^DIE call.
+5 IF $DATA(PXRMCFR)
QUIT
+6 IF $DATA(^PXD(811.2,IEN,30,"B",CODE))
QUIT
+7 NEW IENS,FDA,MSG
+8 SET IENS="+1,"_IEN_","
+9 SET FDA(811.24,IENS,.01)=CODE
+10 SET FDA(811.24,IENS,1)=CODESYS
+11 DO UPDATE^DIE("","FDA","","MSG")
+12 QUIT
+13 ;
+14 ;========================================
SENODE(DA,X) ;Set the "AE" (coding system, code) index.
+1 ;X(1) is the code.
+2 NEW CODEP,CODESYS,COUNT
+3 SET CODESYS=$PIECE(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
+4 ;The ICD and CPT coding systems are "grandfathered" to
+5 ;use the pointer in the Clinical Reminders Index for V CPT
+6 ;and V POV so save the code pointer.
+7 SET CODEP=X(1)
+8 ;DBIA #5747
+9 IF CODESYS="ICD"
SET CODEP=$PIECE($$CODEN^ICDEX(X(1),80),"~",1)
+10 IF CODESYS="ICP"
SET CODEP=$PIECE($$CODEN^ICDEX(X(1),80.1),"~",1)
+11 IF CODESYS="CPC"
SET CODEP=$PIECE($$STATCHK^ICPTAPIU(X(1)),U,2)
+12 IF CODESYS="CPT"
SET CODEP=$PIECE($$STATCHK^ICPTAPIU(X(1)),U,2)
+13 ;Increment COUNT for each term/code the code is stored under.
+14 SET COUNT=+$PIECE($GET(^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))),U,2)+1
+15 SET ^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))=CODEP_U_COUNT
+16 QUIT
+17 ;
+18 ;========================================
STC(DA,X) ;Set the "ATC" (term, coding system) index.
+1 ;X(1) is the coding system.
+2 NEW TERM
+3 SET TERM=^PXD(811.2,DA(2),20,DA(1),0)
+4 SET ^PXD(811.2,DA(2),20,"ATC",TERM,X(1))=DA(1)_U_DA
+5 QUIT
+6 ;
+7 ;========================================
STCC(DA,X) ;Set the "ATCC" (term, coding system, code) index.
+1 ;X(1) is the code, X(2) is Use in Dialog.
+2 NEW CODESYS,TERM
+3 SET TERM=^PXD(811.2,DA(3),20,DA(2),0)
+4 SET CODESYS=$PIECE(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
+5 SET ^PXD(811.2,DA(3),20,"ATCC",TERM,CODESYS,X(1))=X(2)
+6 QUIT
+7 ;
+8 ;========================================
SUID(DA,X) ;Set the "AUID" Use in Dialog index.
+1 ;X(1) is the code, X(2) is Use in Dialog.
+2 NEW ACTDT,BDESC,CODESYS,DATA,INACTDT,LDESC,RESULT,TEMP,VP
+3 IF +X(2)=0
QUIT
+4 SET CODESYS=$PIECE(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
+5 IF $DATA(^PXD(811.2,DA(3),20,"AUID",CODESYS,X(1)))
QUIT
+6 ;DBIA #5679
+7 SET RESULT=$$PERIOD^LEXU(X(1),CODESYS,.DATA)
+8 IF +RESULT=-1
QUIT
+9 SET ACTDT=0
+10 FOR
SET ACTDT=$ORDER(DATA(ACTDT))
if ACTDT=""
QUIT
Begin DoDot:1
+11 SET TEMP=DATA(ACTDT)
+12 SET INACTDT=$PIECE(TEMP,U,1)
+13 IF INACTDT=""
SET INACTDT="DT"
+14 SET VP=$PIECE(TEMP,U,3)
+15 SET LDESC=DATA(ACTDT,0)
+16 SET BDESC=$PIECE(TEMP,U,4)
+17 IF BDESC=""
SET BDESC=LDESC
+18 SET ^PXD(811.2,DA(3),20,"AUID",CODESYS,X(1),ACTDT,INACTDT)=$PIECE(VP,";",1)_U_LDESC
End DoDot:1
+19 ;If UID=1 add the code to the Use In Dialog Codes Multiple.
+20 ;This cannot be done if the entry is being installed by Reminder
+21 ;Exchange because it causes an UPDATE^DIE call to make another
+22 ;UPDATE^DIE call. The Use In Dialog Codes Multiple is built after
+23 ;the entry is installed by a call to BLD30N^PXRMTAXD.
+24 IF $GET(PXRMEXCH)=1
QUIT
+25 DO SAVEUIDC(DA(3),CODESYS,X(1))
+26 QUIT
+27 ;
+28 ;========================================
SUIDC(DA,X) ;Copy codes from the Use in Dialog Codes multiple to the Selected
+1 ;Codes structure.
+2 ;X(1) is the code, X(2) is the coding system.
+3 SET ^PXD(811.2,DA(1),30,"ACC",X(1),X(2))=DA
+4 ;DBIA #5746 Only execute this if called from PXRM DIALOG TAXONOMY EDIT.
+5 IF $PIECE($GET(DDS),U,2)'="PXRM DIALOG TAXONOMY EDIT"
QUIT
+6 NEW NCHG
+7 SET NCHG=$$CHGUID^PXRMTAXD(DA(1),X(2),X(1),1)
+8 IF NCHG>0
QUIT
+9 ;No instances of this code were found in the 20 node so create one.
+10 KILL ^TMP("PXRMCODES",$JOB)
+11 SET ^TMP("PXRMCODES",$JOB,X(1),X(2),X(1))=1
+12 DO SAVETC^PXRMTXIM(DA(1))
+13 DO POSTSAVE^PXRMTXSM(DA(1))
+14 QUIT
+15 ;
+16 ;========================================
VCSYS(LEXSAB) ;Return true if the coding system is supported in taxonomies.
+1 IF LEXSAB="10D"
QUIT 1
+2 IF LEXSAB="10P"
QUIT 1
+3 IF LEXSAB="CPC"
QUIT 1
+4 IF LEXSAB="CPT"
QUIT 1
+5 IF LEXSAB="ICD"
QUIT 1
+6 IF LEXSAB="ICP"
QUIT 1
+7 IF LEXSAB="SCT"
QUIT 1
+8 DO EN^DDIOL(LEXSAB_" is not a supported coding system.")
+9 QUIT 0
+10 ;
