PXRMLEX ;SLC/PKR - Routines for working with Lexicon. ;03/02/2016
;;2.0;CLINICAL REMINDERS;**17,18,26,47**;Feb 04, 2005;Build 291
;
;==========================================
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"
;
;==========================================
VCODE(CODE) ;Check that a code is valid.
N CODESYS,DATA,IEN,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 $P(RESULT,U,1)'=-1 Q 1
I (CODESYS="CPC")!(CODESYS="CPT") D
.;DBIA #1995
. S RESULT=$$CPT^ICPTCOD(CODE)
. S IEN=$P(RESULT,U,1)
. I IEN=-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)
S IEN=$P(RESULT,U,1)
S VALID=$S(IEN=-1:0,1: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)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLEX 3090 printed Nov 22, 2024@16:56:35 Page 2
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
+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 ;==========================================
VCODE(CODE) ;Check that a code is valid.
+1 NEW CODESYS,DATA,IEN,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 $PIECE(RESULT,U,1)'=-1
QUIT 1
+10 IF (CODESYS="CPC")!(CODESYS="CPT")
Begin DoDot:1
+11 ;DBIA #1995
+12 SET RESULT=$$CPT^ICPTCOD(CODE)
+13 SET IEN=$PIECE(RESULT,U,1)
+14 IF IEN=-1
SET VALID=0
QUIT
+15 IF CODESYS="CPC"
IF $PIECE(RESULT,U,5)="H"
SET VALID=1
QUIT
+16 IF CODESYS="CPT"
IF $PIECE(RESULT,U,5)="C"
SET VALID=1
QUIT
End DoDot:1
+17 IF VALID=1
QUIT VALID
+18 ;DBIA #3990
+19 IF CODESYS="ICD"
SET RESULT=$$ICDDX^ICDCODE(CODE,DT,"",0)
+20 IF CODESYS="ICP"
SET RESULT=$$ICDOP^ICDCODE(CODE,DT,"",0)
+21 SET IEN=$PIECE(RESULT,U,1)
+22 SET VALID=$SELECT(IEN=-1:0,1:1)
+23 QUIT VALID
+24 ;
+25 ;==========================================
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 ;
