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

PXRMTXCR.m

Go to the documentation of this file. 
  1. PXRMTXCR ;SLC/PKR - Taxonomies, copy from a range. ;05/07/2014
  1.  ;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
  1.  ;==========================================
  1. BLDCFR(IEN,NODE) ;Build the range, selectable diagnosis, and selectable
  1.  ;procedure lists.
  1.  N CODE,CODEIEN,CODESYS,HIGH,IND,LOW,TNODE,TEMP
  1.  K ^TMP($J,NODE)
  1.  F CODESYS="ICD","ICP","CPT" D
  1.  . S TNODE=$S(CODESYS="ICD":80,CODESYS="ICP":80.1,CODESYS="CPT":81)
  1.  . S IND=0
  1.  . F  S IND=+$O(^PXD(811.2,IEN,TNODE,IND)) Q:IND=0  D
  1.  .. S TEMP=^PXD(811.2,IEN,TNODE,IND,0)
  1.  .. S LOW=$P(TEMP,U,1),HIGH=$P(TEMP,U,2)
  1.  .. I HIGH="" S HIGH=LOW
  1.  .. S ^TMP($J,NODE,CODESYS,LOW,HIGH)=""
  1.  ;
  1.  S IND=0
  1.  F  S IND=+$O(^PXD(811.2,IEN,"SDX",IND)) Q:IND=0  D
  1.  . S CODEIEN=$P(^PXD(811.2,IEN,"SDX",IND,0),U,1)
  1.  .;DBIA #5747
  1.  . S TEMP=$$ICDDX^ICDEX(CODEIEN,DT,"ICD","I")
  1.  . S CODE=$P(TEMP,U,2)
  1.  . S ^TMP($J,NODE,"SDX",CODE)=TEMP
  1.  S IND=0
  1.  F  S IND=+$O(^PXD(811.2,IEN,"SPR",IND)) Q:IND=0  D
  1.  . S CODEIEN=$P(^PXD(811.2,IEN,"SPR",IND,0),U,1)
  1.  .;DBIA #1995-A
  1.  . S TEMP=$$CPT^ICPTCOD(CODEIEN)
  1.  . S CODE=$P(TEMP,U,2)
  1.  . S ^TMP($J,NODE,"SPR",CODE)=TEMP
  1.  Q
  1.  ;
  1.  ;==========================================
  1. CFR(IEN) ;Combine building selectable lists and copy from range.
  1.  D BLDCFR(IEN,"CFR")
  1.  D CFRANGE(IEN,"CFR")
  1.  Q
  1.  ;
  1.  ;==========================================
  1. CFRANGE(IEN,NODE) ;Copy from a range of codes to the Lexicon based structure.
  1.  N CODE,CODEIEN,CODESYS,CSYS,CSYSIND,FDA,IENS,IND,HIGH,LOW,MSG
  1.  N NCODES,NUID,TEMP,TERM,TERMIND,UID
  1.  K ^TMP("PXRMCFR",$J)
  1.  F CODESYS="ICD","ICP","CPT" D
  1.  . S LOW=""
  1.  . F  S LOW=$O(^TMP($J,NODE,CODESYS,LOW)) Q:LOW=""  D
  1.  .. S HIGH=""
  1.  .. F  S HIGH=$O(^TMP($J,NODE,CODESYS,LOW,HIGH)) Q:HIGH=""  D
  1.  ... S TERM="Copy from "_CODESYS_" range "_LOW_" to "_HIGH
  1.  ...;Check for existing entries for this term and remove them before
  1.  ...; storing the new set.
  1.  ... I $D(^PXD(811.2,IEN,20,"B",TERM)) D
  1.  .... S TERMIND=$O(^PXD(811.2,IEN,20,"B",TERM,""))
  1.  .... S IENS=TERMIND_","_IEN_","
  1.  .... S FDA(811.23,IENS,.01)="@"
  1.  .... D FILE^DIE("","FDA","MSG")
  1.  ... S CODE=LOW
  1.  ... F  Q:(CODE]HIGH)!(CODE="")  D
  1.  ....;DBIA #1997, #3991
  1.  .... S TEMP=$S(CODESYS="CPT":$$STATCHK^ICPTAPIU(CODE,""),1:$$STATCHK^ICDAPIU(CODE,""))
  1.  .... S CODEIEN=$P(TEMP,U,2)
  1.  .... I CODEIEN=-1 D  Q
  1.  ..... D MES^XPDUTL(" Warning - "_CODESYS_" code "_CODE_" is not valid.")
  1.  ..... S CODE=$S(CODESYS="CPT":$$NEXT^ICPTAPIU(CODE),1:$$NEXT^ICDAPIU(CODE))
  1.  .... S UID=0
  1.  ....;Mark as Use in Dialog if the code is marked as selectable.
  1.  .... I CODESYS="ICD",$D(^TMP($J,NODE,"SDX",CODE)) S UID=1
  1.  .... I CODESYS="CPT",$D(^TMP($J,NODE,"SPR",CODE)) S UID=1
  1.  .... S ^TMP("PXRMCFR",$J,TERM,CODESYS,CODE)=UID
  1.  .... S ^TMP($J,NODE,"STORED",CODESYS,CODE)=""
  1.  .... S CODE=$S(CODESYS="CPT":$$NEXT^ICPTAPIU(CODE),1:$$NEXT^ICDAPIU(CODE))
  1.  ;
  1.  ;Get selectable codes that are not in a range.
  1.  S TERM="Copy from selectable diagnosis"
  1.  ;Check for existing entries for this term and remove them before
  1.  ;storing the new set.
  1.  I $D(^PXD(811.2,IEN,20,"B",TERM)) D
  1.  . S TERMIND=$O(^PXD(811.2,IEN,20,"B",TERM,""))
  1.  . S IENS=TERMIND_","_IEN_","
  1.  . S FDA(811.23,IENS,.01)="@"
  1.  . D FILE^DIE("","FDA","MSG")
  1.  S CODE=""
  1.  F  S CODE=$O(^TMP($J,NODE,"SDX",CODE)) Q:CODE=""  D
  1.  .;Don't store codes that have already been stored.
  1.  . I $D(^TMP($J,NODE,"STORED","ICD",CODE)) Q
  1.  . S TEMP=^TMP($J,NODE,"SDX",CODE)
  1.  . I $P(TEMP,U,1)=-1 D  Q
  1.  .. D MES^XPDUTL(" Warning - selectable code "_CODE_" is not valid.")
  1.  . S ^TMP("PXRMCFR",$J,TERM,"ICD",CODE)=1
  1.  ;
  1.  S TERM="Copy from selectable procedure"
  1.  ;Check for existing entries for this term and remove them before
  1.  ;storing the new set.
  1.  I $D(^PXD(811.2,IEN,20,"B",TERM)) D
  1.  . S TERMIND=$O(^PXD(811.2,IEN,20,"B",TERM,""))
  1.  . S IENS=TERMIND_","_IEN_","
  1.  . S FDA(811.23,IENS,.01)="@"
  1.  . D FILE^DIE("","FDA","MSG")
  1.  S CODE=""
  1.  F  S CODE=$O(^TMP($J,NODE,"SPR",CODE)) Q:CODE=""  D
  1.  .;Don't store codes that have already been stored.
  1.  . I $D(^TMP($J,NODE,"STORED","CPT",CODE)) Q
  1.  . S TEMP=^TMP($J,NODE,"SPR",CODE)
  1.  . I $P(TEMP,U,1)=-1 D  Q
  1.  .. D MES^XPDUTL(" Warning - selectable procedure "_CODE_" is not valid.")
  1.  . S ^TMP("PXRMCFR",$J,TERM,"CPT",CODE)=1
  1.  ;
  1.  ;The pointer based system did not differentiate between CPC and CPT
  1.  ;codes, do that here.
  1.  S TERM=""
  1.  F  S TERM=$O(^TMP("PXRMCFR",$J,TERM)) Q:TERM=""  D
  1.  . I '$D(^TMP("PXRMCFR",$J,TERM,"CPT")) Q
  1.  . S CODE=""
  1.  . F  S CODE=$O(^TMP("PXRMCFR",$J,TERM,"CPT",CODE)) Q:CODE=""  D
  1.  ..;DBIA #1995
  1.  .. S CSYS=$P($$CPT^ICPTCOD(CODE),U,5)
  1.  .. I CSYS="C" Q
  1.  .. S ^TMP("PXRMCFR",$J,TERM,"CPC",CODE)=^TMP("PXRMCFR",$J,TERM,"CPT",CODE)
  1.  ;Remove extraneous CPT codes.
  1.  S TERM=""
  1.  F  S TERM=$O(^TMP("PXRMCFR",$J,TERM)) Q:TERM=""  D
  1.  . I '$D(^TMP("PXRMCFR",$J,TERM,"CPC")) Q
  1.  . S CODE=""
  1.  . F  S CODE=$O(^TMP("PXRMCFR",$J,TERM,"CPC",CODE)) Q:CODE=""  D
  1.  .. K ^TMP("PXRMCFR",$J,TERM,"CPT",CODE)
  1.  K ^TMP($J,NODE)
  1.  ;
  1.  ;Build the FDA and file it for each range.
  1.  S TERM="",TERMIND=0
  1.  F  S TERM=$O(^TMP("PXRMCFR",$J,TERM)) Q:TERM=""  D
  1.  . K FDA,MSG
  1.  . S TERMIND=TERMIND+1
  1.  . S IENS="+"_TERMIND_","_IEN_","
  1.  . S FDA(811.23,IENS,.01)=TERM
  1.  . S CODESYS="",CSYSIND=TERMIND
  1.  . F  S CODESYS=$O(^TMP("PXRMCFR",$J,TERM,CODESYS)) Q:CODESYS=""  D
  1.  .. S CSYSIND=CSYSIND+1
  1.  .. S CODE="",(NCODES,NUID)=0
  1.  .. F  S CODE=$O(^TMP("PXRMCFR",$J,TERM,CODESYS,CODE)) Q:CODE=""  D
  1.  ... S NCODES=NCODES+1
  1.  ... S IENS="+"_(NCODES+CSYSIND)_",+"_CSYSIND_",+"_TERMIND_","_IEN_","
  1.  ... S UID=^TMP("PXRMCFR",$J,TERM,CODESYS,CODE)
  1.  ... I UID=1 S NUID=NUID+1
  1.  ... S FDA(811.2312,IENS,.01)=CODE
  1.  ... S FDA(811.2312,IENS,1)=UID
  1.  .. S IENS="+"_CSYSIND_",+"_TERMIND_","_IEN_","
  1.  .. S FDA(811.231,IENS,.01)=CODESYS
  1.  .. S FDA(811.231,IENS,1)=NCODES
  1.  .. S FDA(811.231,IENS,3)=NUID
  1.  . D UPDATE^DIE("","FDA","","MSG")
  1.  K ^TMP("PXRMCFR",$J)
  1.  D CNTCHK(IEN)
  1.  Q
  1.  ;
  1.  ;==========================================
  1. CNTCHK(IEN) ;Compare the number of codes stored under the old pointer
  1.  ;structure with the number in the new structure.
  1.  N CODE,CODEIEN,NCPC,NCPT,NICD,NICD0,NICD9,NICP,NICPT,TEMP,TERM,TEXT
  1.  K ^TMP($J,"CPT"),^TMP($J,"ICD"),^TMP($J,"ICP")
  1.  ;Rebuild the expansion to make sure it is current.
  1.  D EXPAND^PXRMBXTL(IEN,"")
  1.  S TEMP=$G(^PXD(811.3,IEN,0))
  1.  S NICD0=+$P(TEMP,U,3),NICD9=+$P(TEMP,U,5),NICPT=+$P(TEMP,U,7)
  1.  S (NCPC,NCPT,NICD,NICP)=0
  1.  I NICD0>0 D
  1.  . S TERM=""
  1.  . F  S TERM=$O(^PXD(811.2,IEN,20,"ATCC",TERM)) Q:TERM=""  D
  1.  .. I $E(TERM,1,13)'="Copy from ICP" Q
  1.  .. S CODE=""
  1.  .. F  S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,"ICP",CODE)) Q:CODE=""  D
  1.  ... S CODEIEN=^PXD(811.2,IEN,20,"AE","ICP",CODE)
  1.  ... S ^TMP($J,"ICP",CODEIEN)=CODE
  1.  .;Count the unqiue entries.
  1.  . S CODEIEN=""
  1.  . F  S CODEIEN=$O(^TMP($J,"ICP",CODEIEN)) Q:CODEIEN=""  S NICP=NICP+1
  1.  I NICD9>0 D
  1.  . S TERM=""
  1.  . F  S TERM=$O(^PXD(811.2,IEN,20,"ATCC",TERM)) Q:TERM=""  D
  1.  .. I $E(TERM,1,13)'="Copy from ICD" Q
  1.  .. S CODE=""
  1.  .. F  S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,"ICD",CODE)) Q:CODE=""  D
  1.  ... S CODEIEN=^PXD(811.2,IEN,20,"AE","ICD",CODE)
  1.  ... S ^TMP($J,"ICD",CODEIEN)=CODE
  1.  .;Count the unqiue entries.
  1.  . S CODEIEN=""
  1.  . F  S CODEIEN=$O(^TMP($J,"ICD",CODEIEN)) Q:CODEIEN=""  S NICD=NICD+1
  1.  I NICPT>0 D
  1.  . S TERM=""
  1.  . F  S TERM=$O(^PXD(811.2,IEN,20,"ATCC",TERM)) Q:TERM=""  D
  1.  .. I $E(TERM,1,13)'="Copy from CPT" Q
  1.  .. S CODE=""
  1.  .. F  S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,"CPC",CODE)) Q:CODE=""  D
  1.  ... S NCPC=NCPC+1
  1.  ... S CODEIEN=^PXD(811.2,IEN,20,"AE","CPC",CODE)
  1.  ... S ^TMP($J,"CPT",CODEIEN)=CODE
  1.  .. S CODE=""
  1.  .. F  S CODE=$O(^PXD(811.2,IEN,20,"ATCC",TERM,"CPT",CODE)) Q:CODE=""  D
  1.  ... S CODEIEN=^PXD(811.2,IEN,20,"AE","CPT",CODE)
  1.  ... S ^TMP($J,"CPT",CODEIEN)=CODE
  1.  .;Count the unqiue entries.
  1.  . S CODEIEN=""
  1.  . F  S CODEIEN=$O(^TMP($J,"CPT",CODEIEN)) Q:CODEIEN=""  S NCPT=NCPT+1
  1.  I (NICD0>0),(NICD0'=NICP) D
  1.  . S TEXT(1)="Encountered a problem moving ICD-9 operation/procedure codes to the new structure."
  1.  . S TEXT(2)=" For taxonomy "_$P(^PXD(811.2,IEN,0),U,1)_" ("_IEN_")."
  1.  . S TEXT(3)=" Original number of codes: "_NICD0
  1.  . S TEXT(4)=" Number of copied codes: "_NICP
  1.  . D MES^XPDUTL(.TEXT)
  1.  I (NICD9>0),(NICD9'=NICD) D
  1.  . K TEXT
  1.  . S TEXT(1)="Encountered a problem moving ICD-9 diagnosis codes to the new structure."
  1.  . S TEXT(2)=" For taxonomy "_$P(^PXD(811.2,IEN,0),U,1)_" ("_IEN_")."
  1.  . S TEXT(3)=" Original number of codes: "_NICD9
  1.  . S TEXT(4)=" Number of copied codes: "_NICD
  1.  . D MES^XPDUTL(.TEXT)
  1.  I (NICPT>0),(NICPT'=NCPT) D
  1.  . K TEXT
  1.  . S TEXT(1)="Encountered a problem moving CPT codes to the new structure."
  1.  . S TEXT(2)=" For taxonomy "_$P(^PXD(811.2,IEN,0),U,1)_" ("_IEN_")."
  1.  . S TEXT(3)=" Original number of codes: "_NICPT
  1.  . S TEXT(4)=" Number of copied codes: "_(NCPC+NCPT)
  1.  . D MES^XPDUTL(.TEXT)
  1.  K ^TMP($J,"CPT"),^TMP($J,"ICD"),^TMP($J,"ICP")
  1.  Q
  1.  ;
  1.  ;==========================================
  1. CPALL ;Do a range of codes copy for all taxonomies.
  1.  N IEN,NAME
  1.  D BMES^XPDUTL("Copying ranges of codes for all taxonomies.")
  1.  S NAME=""
  1.  F  S NAME=$O(^PXD(811.2,"B",NAME)) Q:NAME=""  D
  1.  . S IEN=$O(^PXD(811.2,"B",NAME,""))
  1.  . D MES^XPDUTL("Copy codes for taxonomy "_NAME_" (IEN="_IEN_")")
  1.  . D CFR(IEN)
  1.  K ^TMP($J,"PXRMDLG")
  1.  Q
  1.  ;
  1.  ;==========================================
  1. EXCH(IEN,NODE) ;This entry point is used by Reminder Exchange to populate
  1.  ;the Selected Codes multiple for taxonomies that were packed before
  1.  ;the Selected Codes multiple existed.
  1.  ;^TMP($J,NODE) is built in TAX^PXRMEXU0
  1.  I '$D(^TMP($J,NODE)) Q
  1.  D CFRANGE(IEN,NODE)
  1.  Q
  1.  ;