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. ;21-Apr-2016 17:20;DU
  1.  ;;2.0;CLINICAL REMINDERS;**26,1007**;Feb 04, 2005;Build 12
  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 a coding system code pair in the 20
  1.  ;node change the value of UID.
  1.  N FDA,IENS,IND,JND,KND,MSG,NCHG,NUID,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.  .. I $P(^PXD(811.2,IEN,20,IND,1,JND,1,KND,0),U,1)=CODE D
  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
  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,"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.  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.  ;check to see if a special entry was made for this code in the
  1.  ;Selected Codes Multiple, if one is found delete it. If one is not
  1.  ;found then 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.  I '$D(^PXD(811.2,DA(1),30,"ACC",X1(1),X1(2))) Q
  1.  K ^PXD(811.2,DA(1),30,"ACC",X1(1),X1(2))
  1.  N IENS,KFDA,MSG,NCHG,TERM,TERMIND
  1.  I $D(^PXD(811.2,DA(1),20,"ATC",X1(1),X1(2))) D
  1.  . S TERMIND=$P(^PXD(811.2,DA(1),20,"ATC",X1(1),X1(2)),U,1)
  1.  . S IENS=TERMIND_","_DA(1)_","
  1.  . S KFDA(811.23,IENS,.01)="@"
  1.  . D FILE^DIE("","KFDA","MSG")
  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 ;Rebuild all the indexes on the 20 node.
  1.  N CODESYS,D0,D1,D2,D3,DA,NAME,TCCDA,TCCX,TEMP,UID,X
  1.  ;X(1) is the code and X(2) is UID.
  1.  D BMES^XPDUTL("Building 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.  . 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.  . 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 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.  .... D SUID^PXRMTAXD(.DA,.X)
  1.  Q
  1.  ;
  1.  ;========================================
  1. RBLDUID ;Rebuild the "AUID" index for all entries.
  1.  N D0,D1,D2,D3,DA,TEMP,UID,X
  1.  ;X(1) is the code and X(2) is UID.
  1.  S D0=0
  1.  F  S D0=+$O(^PXD(811.2,D0)) Q:D0=0  D
  1.  . K ^PXD(811.2,D0,20,"AUID")
  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
  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.  .... D SUID^PXRMTAXD(.DA,.X)
  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.  ;If the coding system code pair already exists quit.
  1.  I $D(^PXD(811.2,IEN,30,"ACC",CODE,CODESYS)) 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,ACTCODE
  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" D
  1.  .;IHS/MSC/MGH Patch 1007 Added a check for duplicate codes
  1.  .S ACTCODE=$$CHK(X(1))
  1.  .I ACTCODE="" S CODEP=$P($$STATCHK^ICPTAPIU(X(1)),U,2)
  1.  .E  S CODEP=ACTCODE
  1.  I CODESYS="CPT" S CODEP=$P($$STATCHK^ICPTAPIU(X(1)),U,2)
  1.  S ^PXD(811.2,DA(3),20,"AE",CODESYS,X(1))=CODEP
  1.  Q
  1.  ;
  1. CHK(CODE) ;IHS/MSC/MGHCheck to see if there is more than 1 IEN for this code Patch 1007
  1.  N NUM,IEN,SAVE,CPT
  1.  S NUM=0,IEN="",SAVE=""
  1.  F  S IEN=$O(^ICPT("B",CODE,IEN)) Q:IEN=""  D
  1.  .S NUM=NUM+1
  1.  .S CPT=$$CPT^ICPTCOD(IEN)
  1.  .I $P(CPT,U,7)=1 S SAVE=IEN
  1.  I NUM<2 S SAVE=""
  1.  Q SAVE
  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.  . ;1007 only use active codes in dialogs
  1.  . Q:+INACTDT
  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 TAX30^PXRMEXUO.
  1.  I $G(PXRMEXCH)=1 Q
  1.  I X(2)=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.  ;Check if this coding system code pair already exists.
  1.  I $D(^PXD(811.2,DA(1),30,"ACC",X(1),X(2))) Q
  1.  S ^PXD(811.2,DA(1),30,"ACC",X(1),X(2))=DA
  1.  I $D(^PXD(811.2,DA(1),20,"AUID",X(2),X(1))) 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. 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
  1.  ;patch that follows PXRM*2*26.
  1.  Q
  1.  N IEN,NUM
  1.  S (IEN,NUM)=0
  1.  F  S IEN=+$O(^PXD(811.3,IEN)) Q:IEN=0  S NUM=NUM+1
  1.  S $P(^PXD(811.3,0),U,3,4)=TAXIEN_U_NUM
  1.  Q
  1.  ;
  1.  ;========================================
  1. TAXEDIT(TAXIEN,KI) ;Whenever a taxonony item is edited rebuild the expanded
  1.  ;taxonomy. Called from new-style cross-reference on 811.2.
  1.  ;This code is obsolete and will be removed in the taxonomy cleanup
  1.  ;patch that follows PXRM*2*26.
  1.  Q
  1.  ;Do not execute as part of a verify fields.
  1.  I $G(DIUTIL)="VERIFY FIELDS" Q
  1.  ;Do not execute as part of exchange.
  1.  I $G(PXRMEXCH) Q
  1.  D DELEXTL^PXRMBXTL(TAXIEN)
  1.  D EXPAND^PXRMBXTL(TAXIEN,KI)
  1.  D TAXCOUNT(TAXIEN)
  1.  Q
  1.  ;
  1.  ;========================================
  1. TAXKILL(TAXIEN) ;Called whenever a taxonony item is killed. Called from new-
  1.  ;style cross-reference on 811.2.
  1.  ;This code is obsolete and will be removed in the taxonomy cleanup
  1.  ;patch that follows PXRM*2*26.
  1.  Q
  1.  ;Do not execute as part of a verify fields.
  1.  I $G(DIUTIL)="VERIFY FIELDS" Q
  1.  ;Do not execute as part of exchange.
  1.  I $G(PXRMEXCH) Q
  1.  D DELEXTL^PXRMBXTL(TAXIEN)
  1.  D TAXCOUNT(TAXIEN)
  1.  Q
  1.  ;