PXRMTAXD ; SLC/PKR - Routines used by taxonomy data dictionary. ;21-Apr-2016 17:20;DU
;;2.0;CLINICAL REMINDERS;**26,1007**;Feb 04, 2005;Build 12
;
;===================================
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 a coding system code pair in the 20
;node change the value of UID.
N FDA,IENS,IND,JND,KND,MSG,NCHG,NUID,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
.. I $P(^PXD(811.2,IEN,20,IND,1,JND,1,KND,0),U,1)=CODE D
... 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
S CODESYS=$P(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
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")
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
;check to see if a special entry was made for this code in the
;Selected Codes Multiple, if one is found delete it. If one is not
;found then find the code in the Selected Codes Multiple and change
;UID to 0.
;X(1) is the code, X(2) is the coding system.
I '$D(^PXD(811.2,DA(1),30,"ACC",X1(1),X1(2))) Q
K ^PXD(811.2,DA(1),30,"ACC",X1(1),X1(2))
N IENS,KFDA,MSG,NCHG,TERM,TERMIND
I $D(^PXD(811.2,DA(1),20,"ATC",X1(1),X1(2))) D
. S TERMIND=$P(^PXD(811.2,DA(1),20,"ATC",X1(1),X1(2)),U,1)
. S IENS=TERMIND_","_DA(1)_","
. S KFDA(811.23,IENS,.01)="@"
. D FILE^DIE("","KFDA","MSG")
;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 ;Rebuild all the indexes on the 20 node.
N CODESYS,D0,D1,D2,D3,DA,NAME,TCCDA,TCCX,TEMP,UID,X
;X(1) is the code and X(2) is UID.
D BMES^XPDUTL("Building 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)
. 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")
. 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 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
.... D SUID^PXRMTAXD(.DA,.X)
Q
;
;========================================
RBLDUID ;Rebuild the "AUID" index for all entries.
N D0,D1,D2,D3,DA,TEMP,UID,X
;X(1) is the code and X(2) is UID.
S D0=0
F S D0=+$O(^PXD(811.2,D0)) Q:D0=0 D
. K ^PXD(811.2,D0,20,"AUID")
. 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
... 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
.... D SUID^PXRMTAXD(.DA,.X)
Q
;
;========================================
SAVEUIDC(IEN,CODESYS,CODE) ;Save codes marked as Use In Dialog in the
;Use In Dialogs Codes Multiple.
;If the coding system code pair already exists quit.
I $D(^PXD(811.2,IEN,30,"ACC",CODE,CODESYS)) 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,ACTCODE
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" D
.;IHS/MSC/MGH Patch 1007 Added a check for duplicate codes
.S ACTCODE=$$CHK(X(1))
.I ACTCODE="" S CODEP=$P($$STATCHK^ICPTAPIU(X(1)),U,2)
.E S CODEP=ACTCODE
I CODESYS="CPT" S CODEP=$P($$STATCHK^ICPTAPIU(X(1)),U,2)
S ^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))=CODEP
Q
;
CHK(CODE) ;IHS/MSC/MGHCheck to see if there is more than 1 IEN for this code Patch 1007
N NUM,IEN,SAVE,CPT
S NUM=0,IEN="",SAVE=""
F S IEN=$O(^ICPT("B",CODE,IEN)) Q:IEN="" D
.S NUM=NUM+1
.S CPT=$$CPT^ICPTCOD(IEN)
.I $P(CPT,U,7)=1 S SAVE=IEN
I NUM<2 S SAVE=""
Q SAVE
;========================================
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)
. ;1007 only use active codes in dialogs
. Q:+INACTDT
. 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 TAX30^PXRMEXUO.
I $G(PXRMEXCH)=1 Q
I X(2)=1 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.
;Check if this coding system code pair already exists.
I $D(^PXD(811.2,DA(1),30,"ACC",X(1),X(2))) Q
S ^PXD(811.2,DA(1),30,"ACC",X(1),X(2))=DA
I $D(^PXD(811.2,DA(1),20,"AUID",X(2),X(1))) 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
;
;========================================
TAXCOUNT(TAXIEN) ;Count the expanded taxonomy entries and set the 0 node.
;This code is obsolete and will be removed in the taxonomy cleanup
;patch that follows PXRM*2*26.
Q
N IEN,NUM
S (IEN,NUM)=0
F S IEN=+$O(^PXD(811.3,IEN)) Q:IEN=0 S NUM=NUM+1
S $P(^PXD(811.3,0),U,3,4)=TAXIEN_U_NUM
Q
;
;========================================
TAXEDIT(TAXIEN,KI) ;Whenever a taxonony item is edited rebuild the expanded
;taxonomy. Called from new-style cross-reference on 811.2.
;This code is obsolete and will be removed in the taxonomy cleanup
;patch that follows PXRM*2*26.
Q
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
D DELEXTL^PXRMBXTL(TAXIEN)
D EXPAND^PXRMBXTL(TAXIEN,KI)
D TAXCOUNT(TAXIEN)
Q
;
;========================================
TAXKILL(TAXIEN) ;Called whenever a taxonony item is killed. Called from new-
;style cross-reference on 811.2.
;This code is obsolete and will be removed in the taxonomy cleanup
;patch that follows PXRM*2*26.
Q
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
D DELEXTL^PXRMBXTL(TAXIEN)
D TAXCOUNT(TAXIEN)
Q
;
PXRMTAXD ; SLC/PKR - Routines used by taxonomy data dictionary. ;21-Apr-2016 17:20;DU
+1 ;;2.0;CLINICAL REMINDERS;**26,1007**;Feb 04, 2005;Build 12
+2 ;
+3 ;===================================
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 a coding system code pair in the 20
+1 ;node change the value of UID.
+2 NEW FDA,IENS,IND,JND,KND,MSG,NCHG,NUID,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 IF $PIECE(^PXD(811.2,IEN,20,IND,1,JND,1,KND,0),U,1)=CODE
Begin DoDot:3
+12 SET NCHG=NCHG+1
+13 SET IENS=KND_","_JND_","_IND_","_IEN_","
+14 SET FDA(811.2312,IENS,1)=UID
+15 IF UID=0
SET NUID=NUID-1
+16 IF UID=1
SET NUID=NUID+1
End DoDot:3
+17 SET IENS=JND_","_IND_","_IEN_","
+18 SET FDA(811.231,IENS,3)=NUID
End DoDot:2
End DoDot:1
+19 IF NCHG>0
DO FILE^DIE("","FDA","MSG")
+20 QUIT NCHG
+21 ;
+22 ;===================================
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
+3 SET CODESYS=$PIECE(^PXD(811.2,DA(3),20,DA(2),1,DA(1),0),U,1)
+4 KILL ^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))
+5 QUIT
+6 ;
+7 ;========================================
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 QUIT
+8 ;
+9 ;========================================
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 ;check to see if a special entry was made for this code in the
+2 ;Selected Codes Multiple, if one is found delete it. If one is not
+3 ;found then find the code in the Selected Codes Multiple and change
+4 ;UID to 0.
+5 ;X(1) is the code, X(2) is the coding system.
+6 IF '$DATA(^PXD(811.2,DA(1),30,"ACC",X1(1),X1(2)))
QUIT
+7 KILL ^PXD(811.2,DA(1),30,"ACC",X1(1),X1(2))
+8 NEW IENS,KFDA,MSG,NCHG,TERM,TERMIND
+9 IF $DATA(^PXD(811.2,DA(1),20,"ATC",X1(1),X1(2)))
Begin DoDot:1
+10 SET TERMIND=$PIECE(^PXD(811.2,DA(1),20,"ATC",X1(1),X1(2)),U,1)
+11 SET IENS=TERMIND_","_DA(1)_","
+12 SET KFDA(811.23,IENS,.01)="@"
+13 DO FILE^DIE("","KFDA","MSG")
End DoDot:1
+14 ;Search for the code in the Selected Codes Multiple and set UID=0.
+15 SET NCHG=$$CHGUID^PXRMTAXD(DA(1),X1(2),X1(1),0)
+16 QUIT
+17 ;
+18 ;========================================
RBLD20I ;Rebuild all the indexes on the 20 node.
+1 NEW CODESYS,D0,D1,D2,D3,DA,NAME,TCCDA,TCCX,TEMP,UID,X
+2 ;X(1) is the code and X(2) is UID.
+3 DO BMES^XPDUTL("Building Selected Codes multiple indexes.")
+4 SET NAME=""
+5 FOR
SET NAME=$ORDER(^PXD(811.2,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+6 SET D0=$ORDER(^PXD(811.2,"B",NAME,""))
+7 DO MES^XPDUTL(" Taxonomy: "_NAME_"; IEN="_D0)
+8 KILL ^PXD(811.2,D0,20,"AE")
+9 KILL ^PXD(811.2,D0,20,"ATC")
+10 KILL ^PXD(811.2,D0,20,"ATCC")
+11 KILL ^PXD(811.2,D0,20,"AUID")
+12 SET DA(3)=D0
SET D1=0
SET TCCDA(2)=D0
+13 FOR
SET D1=+$ORDER(^PXD(811.2,D0,20,D1))
IF D1=0
QUIT
Begin DoDot:2
+14 SET DA(2)=D1
SET D2=0
SET TCCDA(1)=D1
+15 FOR
SET D2=+$ORDER(^PXD(811.2,D0,20,D1,1,D2))
IF D2=0
QUIT
Begin DoDot:3
+16 SET CODESYS=$PIECE(^PXD(811.2,D0,20,D1,1,D2,0),U,1)
+17 IF $LENGTH(CODESYS)>3
Begin DoDot:4
+18 SET CODESYS=$EXTRACT(CODESYS,1,3)
+19 SET $PIECE(^PXD(811.2,D0,20,D1,1,D2,0),U,1)=CODESYS
End DoDot:4
+20 SET TCCX(1)=CODESYS
+21 SET DA(1)=D2
SET D3=0
SET TCCDA=D2
+22 DO STC^PXRMTAXD(.TCCDA,.TCCX)
+23 FOR
SET D3=+$ORDER(^PXD(811.2,D0,20,D1,1,D2,1,D3))
IF D3=0
QUIT
Begin DoDot:4
+24 SET DA=D3
+25 SET TEMP=^PXD(811.2,D0,20,D1,1,D2,1,D3,0)
+26 SET X(1)=$PIECE(TEMP,U,1)
+27 DO SENODE^PXRMTAXD(.DA,.X)
+28 SET X(2)=$PIECE(TEMP,U,2)
+29 DO STCC^PXRMTAXD(.DA,.X)
+30 IF +X(2)=0
QUIT
+31 DO SUID^PXRMTAXD(.DA,.X)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
+34 ;========================================
RBLDUID ;Rebuild the "AUID" index for all entries.
+1 NEW D0,D1,D2,D3,DA,TEMP,UID,X
+2 ;X(1) is the code and X(2) is UID.
+3 SET D0=0
+4 FOR
SET D0=+$ORDER(^PXD(811.2,D0))
IF D0=0
QUIT
Begin DoDot:1
+5 KILL ^PXD(811.2,D0,20,"AUID")
+6 SET DA(3)=D0
SET D1=0
+7 FOR
SET D1=+$ORDER(^PXD(811.2,D0,20,D1))
IF D1=0
QUIT
Begin DoDot:2
+8 SET DA(2)=D1
SET D2=0
+9 FOR
SET D2=+$ORDER(^PXD(811.2,D0,20,D1,1,D2))
IF D2=0
QUIT
Begin DoDot:3
+10 SET DA(1)=D2
SET D3=0
+11 FOR
SET D3=+$ORDER(^PXD(811.2,D0,20,D1,1,D2,1,D3))
IF D3=0
QUIT
Begin DoDot:4
+12 SET DA=D3
+13 SET TEMP=^PXD(811.2,D0,20,D1,1,D2,1,D3,0)
+14 SET X(1)=$PIECE(TEMP,U,1)
+15 SET X(2)=$PIECE(TEMP,U,2)
+16 IF +X(2)=0
QUIT
+17 DO SUID^PXRMTAXD(.DA,.X)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ;========================================
SAVEUIDC(IEN,CODESYS,CODE) ;Save codes marked as Use In Dialog in the
+1 ;Use In Dialogs Codes Multiple.
+2 ;If the coding system code pair already exists quit.
+3 IF $DATA(^PXD(811.2,IEN,30,"ACC",CODE,CODESYS))
QUIT
+4 NEW IENS,FDA,MSG
+5 SET IENS="+1,"_IEN_","
+6 SET FDA(811.24,IENS,.01)=CODE
+7 SET FDA(811.24,IENS,1)=CODESYS
+8 DO UPDATE^DIE("","FDA","","MSG")
+9 QUIT
+10 ;
+11 ;========================================
SENODE(DA,X) ;Set the "AE" (coding system, code) index.
+1 ;X(1) is the code.
+2 NEW CODEP,CODESYS,ACTCODE
+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"
Begin DoDot:1
+12 ;IHS/MSC/MGH Patch 1007 Added a check for duplicate codes
+13 SET ACTCODE=$$CHK(X(1))
+14 IF ACTCODE=""
SET CODEP=$PIECE($$STATCHK^ICPTAPIU(X(1)),U,2)
+15 IF '$TEST
SET CODEP=ACTCODE
End DoDot:1
+16 IF CODESYS="CPT"
SET CODEP=$PIECE($$STATCHK^ICPTAPIU(X(1)),U,2)
+17 SET ^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))=CODEP
+18 QUIT
+19 ;
CHK(CODE) ;IHS/MSC/MGHCheck to see if there is more than 1 IEN for this code Patch 1007
+1 NEW NUM,IEN,SAVE,CPT
+2 SET NUM=0
SET IEN=""
SET SAVE=""
+3 FOR
SET IEN=$ORDER(^ICPT("B",CODE,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+4 SET NUM=NUM+1
+5 SET CPT=$$CPT^ICPTCOD(IEN)
+6 IF $PIECE(CPT,U,7)=1
SET SAVE=IEN
End DoDot:1
+7 IF NUM<2
SET SAVE=""
+8 QUIT SAVE
+9 ;========================================
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 ;1007 only use active codes in dialogs
+14 IF +INACTDT
QUIT
+15 IF INACTDT=""
SET INACTDT="DT"
+16 SET VP=$PIECE(TEMP,U,3)
+17 SET LDESC=DATA(ACTDT,0)
+18 SET BDESC=$PIECE(TEMP,U,4)
+19 IF BDESC=""
SET BDESC=LDESC
+20 SET ^PXD(811.2,DA(3),20,"AUID",CODESYS,X(1),ACTDT,INACTDT)=$PIECE(VP,";",1)_U_LDESC
End DoDot:1
+21 ;If UID=1 add the code to the Use In Dialog Codes Multiple.
+22 ;This cannot be done if the entry is being installed by Reminder
+23 ;Exchange because it causes an UPDATE^DIE call to make another
+24 ;UPDATE^DIE call. The Use In Dialog Codes Multiple is built after
+25 ;the entry is installed by a call to TAX30^PXRMEXUO.
+26 IF $GET(PXRMEXCH)=1
QUIT
+27 IF X(2)=1
DO SAVEUIDC(DA(3),CODESYS,X(1))
+28 QUIT
+29 ;
+30 ;========================================
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 ;Check if this coding system code pair already exists.
+4 IF $DATA(^PXD(811.2,DA(1),30,"ACC",X(1),X(2)))
QUIT
+5 SET ^PXD(811.2,DA(1),30,"ACC",X(1),X(2))=DA
+6 IF $DATA(^PXD(811.2,DA(1),20,"AUID",X(2),X(1)))
QUIT
+7 NEW NCHG
+8 SET NCHG=$$CHGUID^PXRMTAXD(DA(1),X(2),X(1),1)
+9 IF NCHG>0
QUIT
+10 ;No instances of this code were found in the 20 node so create one.
+11 KILL ^TMP("PXRMCODES",$JOB)
+12 SET ^TMP("PXRMCODES",$JOB,X(1),X(2),X(1))=1
+13 DO SAVETC^PXRMTXIM(DA(1))
+14 DO POSTSAVE^PXRMTXSM(DA(1))
+15 QUIT
+16 ;
+17 ;========================================
TAXCOUNT(TAXIEN) ;Count the expanded taxonomy entries and set the 0 node.
+1 ;This code is obsolete and will be removed in the taxonomy cleanup
+2 ;patch that follows PXRM*2*26.
+3 QUIT
+4 NEW IEN,NUM
+5 SET (IEN,NUM)=0
+6 FOR
SET IEN=+$ORDER(^PXD(811.3,IEN))
IF IEN=0
QUIT
SET NUM=NUM+1
+7 SET $PIECE(^PXD(811.3,0),U,3,4)=TAXIEN_U_NUM
+8 QUIT
+9 ;
+10 ;========================================
TAXEDIT(TAXIEN,KI) ;Whenever a taxonony item is edited rebuild the expanded
+1 ;taxonomy. Called from new-style cross-reference on 811.2.
+2 ;This code is obsolete and will be removed in the taxonomy cleanup
+3 ;patch that follows PXRM*2*26.
+4 QUIT
+5 ;Do not execute as part of a verify fields.
+6 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+7 ;Do not execute as part of exchange.
+8 IF $GET(PXRMEXCH)
QUIT
+9 DO DELEXTL^PXRMBXTL(TAXIEN)
+10 DO EXPAND^PXRMBXTL(TAXIEN,KI)
+11 DO TAXCOUNT(TAXIEN)
+12 QUIT
+13 ;
+14 ;========================================
TAXKILL(TAXIEN) ;Called whenever a taxonony item is killed. Called from new-
+1 ;style cross-reference on 811.2.
+2 ;This code is obsolete and will be removed in the taxonomy cleanup
+3 ;patch that follows PXRM*2*26.
+4 QUIT
+5 ;Do not execute as part of a verify fields.
+6 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+7 ;Do not execute as part of exchange.
+8 IF $GET(PXRMEXCH)
QUIT
+9 DO DELEXTL^PXRMBXTL(TAXIEN)
+10 DO TAXCOUNT(TAXIEN)
+11 QUIT
+12 ;
