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

PXRMLEX.m

Go to the documentation of this file. 
  1. PXRMLEX ;SLC/PKR - Routines for working with Lexicon. ;03/02/2016
  1.  ;;2.0;CLINICAL REMINDERS;**17,18,26,47**;Feb 04, 2005;Build 291
  1.  ;
  1.  ;==========================================
  1. CODESYSL(CODESYSL) ;Return the list of Lexicon coding systems supported
  1.  ;by Clinical Reminders.
  1.  S CODESYSL("10D")="",CODESYSL("10P")=""
  1.  S CODESYSL("CPC")="",CODESYSL("CPT")=""
  1.  S CODESYSL("ICD")="",CODESYSL("ICP")=""
  1.  S CODESYSL("SCT")=""
  1.  Q
  1.  ;
  1.  ;==========================================
  1. GETCSYS(CODE) ;Given a code return the coding system.
  1.  ;Order the checking so the most commonly used coding systems
  1.  ;are done first.
  1.  ;
  1.  ;ICD-9 CM diagnosis patterns.
  1.  I CODE?3N1"."0.2N Q "ICD"
  1.  I CODE?1"E"3N1"."0.2N Q "ICD"
  1.  I CODE?1"V"2N1"."0.2N Q "ICD"
  1.  ;
  1. CHK10D ;ICD-10 CM diagnosis patterns.
  1.  N CN,F4C,OK
  1.  S F4C=$E(CODE,1,4)
  1.  S OK=(F4C?1U2N1".")!(F4C?1U1N1U1".") I 'OK G CHKCPT
  1.  S CN=$E(CODE,5),OK=(CN?1N)!(CN?1U)!(CN?1"") I 'OK G CHKCPT
  1.  S CN=$E(CODE,6),OK=(CN?1N)!(CN?1U)!(CN?1"") I 'OK G CHKCPT
  1.  S CN=$E(CODE,7),OK=(CN?1N)!(CN?1U)!(CN?1"") I 'OK G CHKCPT
  1.  S CN=$E(CODE,8),OK=(CN?1N)!(CN?1U)!(CN?1"") I 'OK G CHKCPT
  1.  Q "10D"
  1.  ;
  1. CHKCPT ;CPT-4 Procedure pattterns.
  1.  I (CODE?5N)!(CODE?4N1U) Q "CPT"
  1.  ;
  1. CHKCPC ;HCPS Procedure patterns.
  1.  I (CODE?1U4N) Q "CPC"
  1.  ;
  1. CHKICP ;ICD-9 Procedure patterns.
  1.  I CODE?2N1"."1.3N Q "ICP"
  1.  ;
  1. CHKSCT ;SNOMED CT patterns.
  1.  ;Cannot start with a 0.
  1.  I $E(CODE,1)=0 G CHK10P
  1.  ;If a code is 7 numeric characters it can be 10P or SCT.
  1.  N DATA
  1.  ;DBIA #5679
  1.  I (CODE?7N),(+$$HIST^LEXU(CODE,"10P",.DATA)=1) Q "10P"
  1.  I (CODE?6.18N) Q "SCT"
  1.  ;
  1. CHK10P ;ICD-10 Procedure patterns.
  1.  S CN=$E(CODE,1),OK=(CN?1N)!(CN?1U) I 'OK Q "UNK"
  1.  S CN=$E(CODE,2),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
  1.  S CN=$E(CODE,3),OK=(CN?1N)!(CN?1U) I 'OK Q "UNK"
  1.  S CN=$E(CODE,4),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
  1.  S CN=$E(CODE,5),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
  1.  S CN=$E(CODE,6),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
  1.  S CN=$E(CODE,7),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
  1.  Q "10P"
  1.  ;
  1.  Q "UNK"
  1.  ;
  1.  ;==========================================
  1. VCODE(CODE) ;Check that a code is valid.
  1.  N CODESYS,DATA,IEN,RESULT,VALID
  1.  S CODESYS=$$GETCSYS^PXRMLEX(CODE)
  1.  I CODESYS="UNK" Q 0
  1.  ;The code fits the pattern for a supported coding system, verify that
  1.  ;it is a valid code.
  1.  S VALID=0
  1.  ;DBIA #5679
  1.  S RESULT=$$HIST^LEXU(CODE,CODESYS,.DATA)
  1.  I $P(RESULT,U,1)'=-1 Q 1
  1.  I (CODESYS="CPC")!(CODESYS="CPT") D
  1.  .;DBIA #1995
  1.  . S RESULT=$$CPT^ICPTCOD(CODE)
  1.  . S IEN=$P(RESULT,U,1)
  1.  . I IEN=-1 S VALID=0 Q
  1.  . I CODESYS="CPC",$P(RESULT,U,5)="H" S VALID=1 Q
  1.  . I CODESYS="CPT",$P(RESULT,U,5)="C" S VALID=1 Q
  1.  I VALID=1 Q VALID
  1.  ;DBIA #3990
  1.  I CODESYS="ICD" S RESULT=$$ICDDX^ICDCODE(CODE,DT,"",0)
  1.  I CODESYS="ICP" S RESULT=$$ICDOP^ICDCODE(CODE,DT,"",0)
  1.  S IEN=$P(RESULT,U,1)
  1.  S VALID=$S(IEN=-1:0,1:1)
  1.  Q VALID
  1.  ;
  1.  ;==========================================
  1. VCODESYS(CODESYS) ;Make sure the coding system is one taxonomies support.
  1.  N CODESYSL
  1.  D CODESYSL^PXRMLEX(.CODESYSL)
  1.  Q $S($D(CODESYSL(CODESYS)):1,1:0)
  1.  ;