Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMTAXD

PXRMTAXD.m

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