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. ;05/07/2014
  1.  ;;2.0;CLINICAL REMINDERS;**17,18,26**;Feb 04, 2005;Build 404
  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. LEXTEXT ;Get the codes from the Lexicon update text file.
  1.  N ACTION,ACTIONS,CODE,CODEIEN,CODETYPE,CTYPE,DES,DONE
  1.  N FIELD,FILE,FILENUM,GBL,HFILE,HT,IND,JND
  1.  N NEW,NDES,NFIELDS,NFOUND,NL,NOUT,PATH,RETVAL
  1.  N SDES,SUCCESS,TAX,TAXLIST,TEMP,TEXTIN,TEXTOUT
  1.  S HFILE=$$GETEHF^PXRMEXHF("TXT")
  1.  I HFILE="" Q
  1.  S ACTIONS("AD")="new code is added"
  1.  S ACTIONS("AG")="edits - (ie. Age_High, Age_Low, Gender)"
  1.  S ACTIONS("BR")="both short and long description are revised"
  1.  S ACTIONS("IA")="code has been deleted or inactivated"
  1.  S ACTIONS("FR")="long description is revised"
  1.  S ACTIONS("NA")="not applicable"
  1.  S ACTIONS("RA")="code is reactivated"
  1.  S ACTIONS("RU")="code is reactivated and revised"
  1.  S ACTIONS("SR")="short description is revised"
  1.  S ACTIONS("UN")="undo previous action"
  1.  S HT=$C(9)
  1.  S PATH=$P(HFILE,U,1)
  1.  S FILE=$P(HFILE,U,2)
  1.  K ^TMP($J,"HF")
  1.  S GBL="^TMP($J,""HF"",1,0)"
  1.  S GBL=$NA(@GBL)
  1.  S SUCCESS=$$FTG^%ZISH(PATH,FILE,GBL,3)
  1.  I 'SUCCESS W !,"Could not open the host file." Q
  1.  ;The list of fields is on the first line.
  1.  S TEMP=^TMP($J,"HF",1,0)
  1.  S NFIELDS=$L(TEMP,HT)-1
  1.  F IND=1:1:NFIELDS S FIELD($P(TEMP,HT,IND))=IND
  1.  S CTYPE=$P(^TMP($J,"HF",2,0),HT,FIELD("CODE_SYSTEM"))
  1.  S FILENUM=$S(CTYPE="CPC":81,CTYPE="CPT":81,CTYPE="ICD9":80,CTYPE="ICP9":80.1,1:"")
  1.  I FILENUM="" Q
  1.  W !,"Processing Lexicon text update file ",FILE,";"
  1.  W !,"update for ",CTYPE," codes."
  1.  S IND=1
  1.  F  S IND=$O(^TMP($J,"HF",IND)) Q:IND=""  D
  1.  . S TEMP=^TMP($J,"HF",IND,0)
  1.  . S CODE=$P(TEMP,HT,FIELD("CODE"))
  1.  . S ACTION=$P(TEMP,HT,FIELD("ACTION"))
  1.  . S NEW=$S(ACTION="AD":1,ACTION="RA":1,ACTION="RU":1,1:0)
  1.  . I NEW D  Q
  1.  .. S TEXTIN="For "_CTYPE_" code, "_CODE_" the action is: "_ACTIONS(ACTION)_"."
  1.  .. D FORMATS^PXRMTEXT(1,78,TEXTIN,.NOUT,.TEXTOUT)
  1.  .. W ! F NL=1:1:NOUT W !,TEXTOUT(NL)
  1.  .. S SDES=$P(TEMP,HT,FIELD("SHORT_DESCRIPTION"))
  1.  .. W !," Short description: ",SDES
  1.  .. S NDES=1,DES(1)="Long description: "_$P(TEMP,HT,FIELD("LONG_DESCRIPTION"))
  1.  ..;Get the rest of the long description.
  1.  .. S DONE=0,JND=IND
  1.  .. F  S JND=+$O(^TMP($J,"HF",JND)) Q:(DONE)!(JND=0)  D
  1.  ... S TEMP=^TMP($J,"HF",JND,0)
  1.  ... I $P(TEMP,HT,FIELD("CODE"))'=CODE S DONE=1 Q
  1.  ... S NDES=NDES+1,DES(NDES)=$P(TEMP,HT,FIELD("LONG_DESCRIPTION"))
  1.  .. D FORMAT^PXRMTEXT(2,78,NDES,.DES,.NOUT,.TEXTOUT)
  1.  .. F NL=1:1:NOUT W !,TEXTOUT(NL)
  1.  ..;JND now is at the next code so back IND up by 2 so $O of IND
  1.  ..;is at the next code. If JND=0 then there were no additional lines.
  1.  .. I JND>IND S IND=JND-2
  1.  . I ACTION'="" D
  1.  .. S RETVAL=$$CODE^PXRMVAL(CODE,FILENUM)
  1.  .. I +RETVAL=0 Q
  1.  .. S CODEIEN=$P(RETVAL,U,8)
  1.  .. S CODETYPE=$P(RETVAL,U,7)
  1.  .. D CSEARCH^PXRMTAXS(FILENUM,CODE,CODEIEN,CODETYPE,.NFOUND,.TAXLIST)
  1.  .. I NFOUND=0 Q
  1.  .. S TEXTIN="For "_CTYPE_" code, "_CODE_" the action is: "_ACTIONS(ACTION)_"."
  1.  .. D FORMATS^PXRMTEXT(1,78,TEXTIN,.NOUT,.TEXTOUT)
  1.  .. W ! F NL=1:1:NOUT W !,TEXTOUT(NL)
  1.  .. W !,CODETYPE," ",CODE," is used in the following taxonomies:"
  1.  .. S TAX=""
  1.  .. F  S TAX=$O(TAXLIST(TAX)) Q:TAX=""  W !," ",TAX
  1.  K ^TMP($J,"HF")
  1.  Q
  1.  ;
  1.  ;==========================================
  1. VCODE(CODE) ;Check that a code is valid.
  1.  N CODESYS,DATA,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 +RESULT'=-1 Q 1
  1.  I (CODESYS="CPC")!(CODESYS="CPT") D
  1.  .;DBIA #1995
  1.  . S RESULT=$$CPT^ICPTCOD(CODE)
  1.  . I +RESULT=-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.  I +RESULT'=-1 S VALID=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.  ;