- 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 Feb 18, 2025@23:15:43 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 ;