PXRMLEX ;SLC/PKR - Routines for working with Lexicon. ;05/07/2014
;;2.0;CLINICAL REMINDERS;**17,18,26**;Feb 04, 2005;Build 404
;
;==========================================
CODESYSL(CODESYSL) ;Return the list of Lexicon coding systems supported
;by Clinical Reminders.
S CODESYSL("10D")="",CODESYSL("10P")=""
S CODESYSL("CPC")="",CODESYSL("CPT")=""
S CODESYSL("ICD")="",CODESYSL("ICP")=""
S CODESYSL("SCT")=""
Q
;
;==========================================
GETCSYS(CODE) ;Given a code return the coding system.
;Order the checking so the most commonly used coding systems
;are done first.
;
;ICD-9 CM diagnosis patterns.
I CODE?3N1"."0.2N Q "ICD"
I CODE?1"E"3N1"."0.2N Q "ICD"
I CODE?1"V"2N1"."0.2N Q "ICD"
;
CHK10D ;ICD-10 CM diagnosis patterns.
N CN,F4C,OK
S F4C=$E(CODE,1,4)
S OK=(F4C?1U2N1".")!(F4C?1U1N1U1".") I 'OK G CHKCPT
S CN=$E(CODE,5),OK=(CN?1N)!(CN?1U)!(CN?1"") I 'OK G CHKCPT
S CN=$E(CODE,6),OK=(CN?1N)!(CN?1U)!(CN?1"") I 'OK G CHKCPT
S CN=$E(CODE,7),OK=(CN?1N)!(CN?1U)!(CN?1"") I 'OK G CHKCPT
S CN=$E(CODE,8),OK=(CN?1N)!(CN?1U)!(CN?1"") I 'OK G CHKCPT
Q "10D"
;
CHKCPT ;CPT-4 Procedure pattterns.
I (CODE?5N)!(CODE?4N1U) Q "CPT"
;
CHKCPC ;HCPS Procedure patterns.
I (CODE?1U4N) Q "CPC"
;
CHKICP ;ICD-9 Procedure patterns.
I CODE?2N1"."1.3N Q "ICP"
;
CHKSCT ;SNOMED CT patterns.
;Cannot start with a 0.
I $E(CODE,1)=0 G CHK10P
;If a code is 7 numeric characters it can be 10P or SCT.
N DATA
;DBIA #5679
I (CODE?7N),(+$$HIST^LEXU(CODE,"10P",.DATA)=1) Q "10P"
I (CODE?6.18N) Q "SCT"
;
CHK10P ;ICD-10 Procedure patterns.
S CN=$E(CODE,1),OK=(CN?1N)!(CN?1U) I 'OK Q "UNK"
S CN=$E(CODE,2),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
S CN=$E(CODE,3),OK=(CN?1N)!(CN?1U) I 'OK Q "UNK"
S CN=$E(CODE,4),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
S CN=$E(CODE,5),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
S CN=$E(CODE,6),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
S CN=$E(CODE,7),OK=(CN?1N)!(CN?1U)!(CN?1"Z") I 'OK Q "UNK"
Q "10P"
;
Q "UNK"
;
;==========================================
LEXTEXT ;Get the codes from the Lexicon update text file.
N ACTION,ACTIONS,CODE,CODEIEN,CODETYPE,CTYPE,DES,DONE
N FIELD,FILE,FILENUM,GBL,HFILE,HT,IND,JND
N NEW,NDES,NFIELDS,NFOUND,NL,NOUT,PATH,RETVAL
N SDES,SUCCESS,TAX,TAXLIST,TEMP,TEXTIN,TEXTOUT
S HFILE=$$GETEHF^PXRMEXHF("TXT")
I HFILE="" Q
S ACTIONS("AD")="new code is added"
S ACTIONS("AG")="edits - (ie. Age_High, Age_Low, Gender)"
S ACTIONS("BR")="both short and long description are revised"
S ACTIONS("IA")="code has been deleted or inactivated"
S ACTIONS("FR")="long description is revised"
S ACTIONS("NA")="not applicable"
S ACTIONS("RA")="code is reactivated"
S ACTIONS("RU")="code is reactivated and revised"
S ACTIONS("SR")="short description is revised"
S ACTIONS("UN")="undo previous action"
S HT=$C(9)
S PATH=$P(HFILE,U,1)
S FILE=$P(HFILE,U,2)
K ^TMP($J,"HF")
S GBL="^TMP($J,""HF"",1,0)"
S GBL=$NA(@GBL)
S SUCCESS=$$FTG^%ZISH(PATH,FILE,GBL,3)
I 'SUCCESS W !,"Could not open the host file." Q
;The list of fields is on the first line.
S TEMP=^TMP($J,"HF",1,0)
S NFIELDS=$L(TEMP,HT)-1
F IND=1:1:NFIELDS S FIELD($P(TEMP,HT,IND))=IND
S CTYPE=$P(^TMP($J,"HF",2,0),HT,FIELD("CODE_SYSTEM"))
S FILENUM=$S(CTYPE="CPC":81,CTYPE="CPT":81,CTYPE="ICD9":80,CTYPE="ICP9":80.1,1:"")
I FILENUM="" Q
W !,"Processing Lexicon text update file ",FILE,";"
W !,"update for ",CTYPE," codes."
S IND=1
F S IND=$O(^TMP($J,"HF",IND)) Q:IND="" D
. S TEMP=^TMP($J,"HF",IND,0)
. S CODE=$P(TEMP,HT,FIELD("CODE"))
. S ACTION=$P(TEMP,HT,FIELD("ACTION"))
. S NEW=$S(ACTION="AD":1,ACTION="RA":1,ACTION="RU":1,1:0)
. I NEW D Q
.. S TEXTIN="For "_CTYPE_" code, "_CODE_" the action is: "_ACTIONS(ACTION)_"."
.. D FORMATS^PXRMTEXT(1,78,TEXTIN,.NOUT,.TEXTOUT)
.. W ! F NL=1:1:NOUT W !,TEXTOUT(NL)
.. S SDES=$P(TEMP,HT,FIELD("SHORT_DESCRIPTION"))
.. W !," Short description: ",SDES
.. S NDES=1,DES(1)="Long description: "_$P(TEMP,HT,FIELD("LONG_DESCRIPTION"))
..;Get the rest of the long description.
.. S DONE=0,JND=IND
.. F S JND=+$O(^TMP($J,"HF",JND)) Q:(DONE)!(JND=0) D
... S TEMP=^TMP($J,"HF",JND,0)
... I $P(TEMP,HT,FIELD("CODE"))'=CODE S DONE=1 Q
... S NDES=NDES+1,DES(NDES)=$P(TEMP,HT,FIELD("LONG_DESCRIPTION"))
.. D FORMAT^PXRMTEXT(2,78,NDES,.DES,.NOUT,.TEXTOUT)
.. F NL=1:1:NOUT W !,TEXTOUT(NL)
..;JND now is at the next code so back IND up by 2 so $O of IND
..;is at the next code. If JND=0 then there were no additional lines.
.. I JND>IND S IND=JND-2
. I ACTION'="" D
.. S RETVAL=$$CODE^PXRMVAL(CODE,FILENUM)
.. I +RETVAL=0 Q
.. S CODEIEN=$P(RETVAL,U,8)
.. S CODETYPE=$P(RETVAL,U,7)
.. D CSEARCH^PXRMTAXS(FILENUM,CODE,CODEIEN,CODETYPE,.NFOUND,.TAXLIST)
.. I NFOUND=0 Q
.. S TEXTIN="For "_CTYPE_" code, "_CODE_" the action is: "_ACTIONS(ACTION)_"."
.. D FORMATS^PXRMTEXT(1,78,TEXTIN,.NOUT,.TEXTOUT)
.. W ! F NL=1:1:NOUT W !,TEXTOUT(NL)
.. W !,CODETYPE," ",CODE," is used in the following taxonomies:"
.. S TAX=""
.. F S TAX=$O(TAXLIST(TAX)) Q:TAX="" W !," ",TAX
K ^TMP($J,"HF")
Q
;
;==========================================
VCODE(CODE) ;Check that a code is valid.
N CODESYS,DATA,RESULT,VALID
S CODESYS=$$GETCSYS^PXRMLEX(CODE)
I CODESYS="UNK" Q 0
;The code fits the pattern for a supported coding system, verify that
;it is a valid code.
S VALID=0
;DBIA #5679
S RESULT=$$HIST^LEXU(CODE,CODESYS,.DATA)
I +RESULT'=-1 Q 1
I (CODESYS="CPC")!(CODESYS="CPT") D
.;DBIA #1995
. S RESULT=$$CPT^ICPTCOD(CODE)
. I +RESULT=-1 S VALID=0 Q
. I CODESYS="CPC",$P(RESULT,U,5)="H" S VALID=1 Q
. I CODESYS="CPT",$P(RESULT,U,5)="C" S VALID=1 Q
I VALID=1 Q VALID
;DBIA #3990
I CODESYS="ICD" S RESULT=$$ICDDX^ICDCODE(CODE,DT,"",0)
I CODESYS="ICP" S RESULT=$$ICDOP^ICDCODE(CODE,DT,"",0)
I +RESULT'=-1 S VALID=1
Q VALID
;
;==========================================
VCODESYS(CODESYS) ;Make sure the coding system is one taxonomies support.
N CODESYSL
D CODESYSL^PXRMLEX(.CODESYSL)
Q $S($D(CODESYSL(CODESYS)):1,1:0)
;
PXRMLEX ;SLC/PKR - Routines for working with Lexicon. ;05/07/2014
+1 ;;2.0;CLINICAL REMINDERS;**17,18,26**;Feb 04, 2005;Build 404
+2 ;
+3 ;==========================================
CODESYSL(CODESYSL) ;Return the list of Lexicon coding systems supported
+1 ;by Clinical Reminders.
+2 SET CODESYSL("10D")=""
SET CODESYSL("10P")=""
+3 SET CODESYSL("CPC")=""
SET CODESYSL("CPT")=""
+4 SET CODESYSL("ICD")=""
SET CODESYSL("ICP")=""
+5 SET CODESYSL("SCT")=""
+6 QUIT
+7 ;
+8 ;==========================================
GETCSYS(CODE) ;Given a code return the coding system.
+1 ;Order the checking so the most commonly used coding systems
+2 ;are done first.
+3 ;
+4 ;ICD-9 CM diagnosis patterns.
+5 IF CODE?3N1"."0.2N
QUIT "ICD"
+6 IF CODE?1"E"3N1"."0.2N
QUIT "ICD"
+7 IF CODE?1"V"2N1"."0.2N
QUIT "ICD"
+8 ;
CHK10D ;ICD-10 CM diagnosis patterns.
+1 NEW CN,F4C,OK
+2 SET F4C=$EXTRACT(CODE,1,4)
+3 SET OK=(F4C?1U2N1".")!(F4C?1U1N1U1".")
IF 'OK
GOTO CHKCPT
+4 SET CN=$EXTRACT(CODE,5)
SET OK=(CN?1N)!(CN?1U)!(CN?1"")
IF 'OK
GOTO CHKCPT
+5 SET CN=$EXTRACT(CODE,6)
SET OK=(CN?1N)!(CN?1U)!(CN?1"")
IF 'OK
GOTO CHKCPT
+6 SET CN=$EXTRACT(CODE,7)
SET OK=(CN?1N)!(CN?1U)!(CN?1"")
IF 'OK
GOTO CHKCPT
+7 SET CN=$EXTRACT(CODE,8)
SET OK=(CN?1N)!(CN?1U)!(CN?1"")
IF 'OK
GOTO CHKCPT
+8 QUIT "10D"
+9 ;
CHKCPT ;CPT-4 Procedure pattterns.
+1 IF (CODE?5N)!(CODE?4N1U)
QUIT "CPT"
+2 ;
CHKCPC ;HCPS Procedure patterns.
+1 IF (CODE?1U4N)
QUIT "CPC"
+2 ;
CHKICP ;ICD-9 Procedure patterns.
+1 IF CODE?2N1"."1.3N
QUIT "ICP"
+2 ;
CHKSCT ;SNOMED CT patterns.
+1 ;Cannot start with a 0.
+2 IF $EXTRACT(CODE,1)=0
GOTO CHK10P
+3 ;If a code is 7 numeric characters it can be 10P or SCT.
+4 NEW DATA
+5 ;DBIA #5679
+6 IF (CODE?7N)
IF (+$$HIST^LEXU(CODE,"10P",.DATA)=1)
QUIT "10P"
+7 IF (CODE?6.18N)
QUIT "SCT"
+8 ;
CHK10P ;ICD-10 Procedure patterns.
+1 SET CN=$EXTRACT(CODE,1)
SET OK=(CN?1N)!(CN?1U)
IF 'OK
QUIT "UNK"
+2 SET CN=$EXTRACT(CODE,2)
SET OK=(CN?1N)!(CN?1U)!(CN?1"Z")
IF 'OK
QUIT "UNK"
+3 SET CN=$EXTRACT(CODE,3)
SET OK=(CN?1N)!(CN?1U)
IF 'OK
QUIT "UNK"
+4 SET CN=$EXTRACT(CODE,4)
SET OK=(CN?1N)!(CN?1U)!(CN?1"Z")
IF 'OK
QUIT "UNK"
+5 SET CN=$EXTRACT(CODE,5)
SET OK=(CN?1N)!(CN?1U)!(CN?1"Z")
IF 'OK
QUIT "UNK"
+6 SET CN=$EXTRACT(CODE,6)
SET OK=(CN?1N)!(CN?1U)!(CN?1"Z")
IF 'OK
QUIT "UNK"
+7 SET CN=$EXTRACT(CODE,7)
SET OK=(CN?1N)!(CN?1U)!(CN?1"Z")
IF 'OK
QUIT "UNK"
+8 QUIT "10P"
+9 ;
+10 QUIT "UNK"
+11 ;
+12 ;==========================================
LEXTEXT ;Get the codes from the Lexicon update text file.
+1 NEW ACTION,ACTIONS,CODE,CODEIEN,CODETYPE,CTYPE,DES,DONE
+2 NEW FIELD,FILE,FILENUM,GBL,HFILE,HT,IND,JND
+3 NEW NEW,NDES,NFIELDS,NFOUND,NL,NOUT,PATH,RETVAL
+4 NEW SDES,SUCCESS,TAX,TAXLIST,TEMP,TEXTIN,TEXTOUT
+5 SET HFILE=$$GETEHF^PXRMEXHF("TXT")
+6 IF HFILE=""
QUIT
+7 SET ACTIONS("AD")="new code is added"
+8 SET ACTIONS("AG")="edits - (ie. Age_High, Age_Low, Gender)"
+9 SET ACTIONS("BR")="both short and long description are revised"
+10 SET ACTIONS("IA")="code has been deleted or inactivated"
+11 SET ACTIONS("FR")="long description is revised"
+12 SET ACTIONS("NA")="not applicable"
+13 SET ACTIONS("RA")="code is reactivated"
+14 SET ACTIONS("RU")="code is reactivated and revised"
+15 SET ACTIONS("SR")="short description is revised"
+16 SET ACTIONS("UN")="undo previous action"
+17 SET HT=$CHAR(9)
+18 SET PATH=$PIECE(HFILE,U,1)
+19 SET FILE=$PIECE(HFILE,U,2)
+20 KILL ^TMP($JOB,"HF")
+21 SET GBL="^TMP($J,""HF"",1,0)"
+22 SET GBL=$NAME(@GBL)
+23 SET SUCCESS=$$FTG^%ZISH(PATH,FILE,GBL,3)
+24 IF 'SUCCESS
WRITE !,"Could not open the host file."
QUIT
+25 ;The list of fields is on the first line.
+26 SET TEMP=^TMP($JOB,"HF",1,0)
+27 SET NFIELDS=$LENGTH(TEMP,HT)-1
+28 FOR IND=1:1:NFIELDS
SET FIELD($PIECE(TEMP,HT,IND))=IND
+29 SET CTYPE=$PIECE(^TMP($JOB,"HF",2,0),HT,FIELD("CODE_SYSTEM"))
+30 SET FILENUM=$SELECT(CTYPE="CPC":81,CTYPE="CPT":81,CTYPE="ICD9":80,CTYPE="ICP9":80.1,1:"")
+31 IF FILENUM=""
QUIT
+32 WRITE !,"Processing Lexicon text update file ",FILE,";"
+33 WRITE !,"update for ",CTYPE," codes."
+34 SET IND=1
+35 FOR
SET IND=$ORDER(^TMP($JOB,"HF",IND))
IF IND=""
QUIT
Begin DoDot:1
+36 SET TEMP=^TMP($JOB,"HF",IND,0)
+37 SET CODE=$PIECE(TEMP,HT,FIELD("CODE"))
+38 SET ACTION=$PIECE(TEMP,HT,FIELD("ACTION"))
+39 SET NEW=$SELECT(ACTION="AD":1,ACTION="RA":1,ACTION="RU":1,1:0)
+40 IF NEW
Begin DoDot:2
+41 SET TEXTIN="For "_CTYPE_" code, "_CODE_" the action is: "_ACTIONS(ACTION)_"."
+42 DO FORMATS^PXRMTEXT(1,78,TEXTIN,.NOUT,.TEXTOUT)
+43 WRITE !
FOR NL=1:1:NOUT
WRITE !,TEXTOUT(NL)
+44 SET SDES=$PIECE(TEMP,HT,FIELD("SHORT_DESCRIPTION"))
+45 WRITE !," Short description: ",SDES
+46 SET NDES=1
SET DES(1)="Long description: "_$PIECE(TEMP,HT,FIELD("LONG_DESCRIPTION"))
+47 ;Get the rest of the long description.
+48 SET DONE=0
SET JND=IND
+49 FOR
SET JND=+$ORDER(^TMP($JOB,"HF",JND))
IF (DONE)!(JND=0)
QUIT
Begin DoDot:3
+50 SET TEMP=^TMP($JOB,"HF",JND,0)
+51 IF $PIECE(TEMP,HT,FIELD("CODE"))'=CODE
SET DONE=1
QUIT
+52 SET NDES=NDES+1
SET DES(NDES)=$PIECE(TEMP,HT,FIELD("LONG_DESCRIPTION"))
End DoDot:3
+53 DO FORMAT^PXRMTEXT(2,78,NDES,.DES,.NOUT,.TEXTOUT)
+54 FOR NL=1:1:NOUT
WRITE !,TEXTOUT(NL)
+55 ;JND now is at the next code so back IND up by 2 so $O of IND
+56 ;is at the next code. If JND=0 then there were no additional lines.
+57 IF JND>IND
SET IND=JND-2
End DoDot:2
QUIT
+58 IF ACTION'=""
Begin DoDot:2
+59 SET RETVAL=$$CODE^PXRMVAL(CODE,FILENUM)
+60 IF +RETVAL=0
QUIT
+61 SET CODEIEN=$PIECE(RETVAL,U,8)
+62 SET CODETYPE=$PIECE(RETVAL,U,7)
+63 DO CSEARCH^PXRMTAXS(FILENUM,CODE,CODEIEN,CODETYPE,.NFOUND,.TAXLIST)
+64 IF NFOUND=0
QUIT
+65 SET TEXTIN="For "_CTYPE_" code, "_CODE_" the action is: "_ACTIONS(ACTION)_"."
+66 DO FORMATS^PXRMTEXT(1,78,TEXTIN,.NOUT,.TEXTOUT)
+67 WRITE !
FOR NL=1:1:NOUT
WRITE !,TEXTOUT(NL)
+68 WRITE !,CODETYPE," ",CODE," is used in the following taxonomies:"
+69 SET TAX=""
+70 FOR
SET TAX=$ORDER(TAXLIST(TAX))
IF TAX=""
QUIT
WRITE !," ",TAX
End DoDot:2
End DoDot:1
+71 KILL ^TMP($JOB,"HF")
+72 QUIT
+73 ;
+74 ;==========================================
VCODE(CODE) ;Check that a code is valid.
+1 NEW CODESYS,DATA,RESULT,VALID
+2 SET CODESYS=$$GETCSYS^PXRMLEX(CODE)
+3 IF CODESYS="UNK"
QUIT 0
+4 ;The code fits the pattern for a supported coding system, verify that
+5 ;it is a valid code.
+6 SET VALID=0
+7 ;DBIA #5679
+8 SET RESULT=$$HIST^LEXU(CODE,CODESYS,.DATA)
+9 IF +RESULT'=-1
QUIT 1
+10 IF (CODESYS="CPC")!(CODESYS="CPT")
Begin DoDot:1
+11 ;DBIA #1995
+12 SET RESULT=$$CPT^ICPTCOD(CODE)
+13 IF +RESULT=-1
SET VALID=0
QUIT
+14 IF CODESYS="CPC"
IF $PIECE(RESULT,U,5)="H"
SET VALID=1
QUIT
+15 IF CODESYS="CPT"
IF $PIECE(RESULT,U,5)="C"
SET VALID=1
QUIT
End DoDot:1
+16 IF VALID=1
QUIT VALID
+17 ;DBIA #3990
+18 IF CODESYS="ICD"
SET RESULT=$$ICDDX^ICDCODE(CODE,DT,"",0)
+19 IF CODESYS="ICP"
SET RESULT=$$ICDOP^ICDCODE(CODE,DT,"",0)
+20 IF +RESULT'=-1
SET VALID=1
+21 QUIT VALID
+22 ;
+23 ;==========================================
VCODESYS(CODESYS) ;Make sure the coding system is one taxonomies support.
+1 NEW CODESYSL
+2 DO CODESYSL^PXRMLEX(.CODESYSL)
+3 QUIT $SELECT($DATA(CODESYSL(CODESYS)):1,1:0)
+4 ;
