PXRMVALC ; SLC/KR - VAL Validate Codes (format/value) ;31-May-2013 13:35;DU
;;2.0;CLINICAL REMINDERS;**4,1001**;Feb 04, 2005;Build 21
Q
;
; Entry points (extrinsic functions)
;
; ICD^PXRMVALC(<code>) Validate ICD-9-CM Diagnosis Code
; ICP^PXRMVALC(<code>) Validate ICD-9-CM Procedure Code
; CPT^PXRMVALC(<code>) Validate CPT-4 Procedure Code
;
; All entry points return:
;
; <validity>^<input>^<output>^<error>^<file #>^<global root>^
; <type of code>^<input IEN>^<input flag>^<output IEN>^
; <output flag>^<description>
;
ICD(X) ; Validate ICD-9-CM Diagnosis Code from file 80
S X=$G(X),U="^" N CHR,CHKD,CIN,CODE,COUT,DIC,ERR,ES,FNUM,FORM,IENI,IENO,IFIN,IFOUT,NAME,NUMERIC,PAT,TY,VAL,Y
S VAL=1,FNUM=80,DIC="ICD9(",(IFIN,IFOUT,NAME)="",CIN=$TR(X,"""",""),U="^"
S FORM=$S($E(X,1)="E":2,$E(X,1)="V":3,$E(X,1)?1N:1,1:1),TY=$S(FORM=2:"ICD ""E"" code",FORM=3:"ICD ""V"" code",FORM=1:"ICD code",1:"ICD code")
S ERR="Valid "_TY,CHKD=$S(FORM=2:"ICD-9-CM ""E"" external cause code",FORM=3:"ICD-9-CM ""V"" health factor code",FORM=1:"ICD-9-CM diagnosis code",1:"ICD-9-CM code")
S PAT=$S(FORM=2:"ENNN.nn",FORM=3:"VNN.nn",FORM=1:"NNN.nn",1:"ENNN.nn, VNN.nn or NNN.nn")
; Code transformation
S CODE=X S:CODE'["." CODE=CODE_"."
S:FORM=1&($L($P(CODE,".",1))=1)&(+($P(CODE,".",1))>0) $P(CODE,".",1)="00"_$P(CODE,".",1) S:FORM=1&($L($P(CODE,".",1))=2)&(+($P(CODE,".",1))>0) $P(CODE,".",1)="0"_$P(CODE,".",1) S X=CODE
S CODE=$P(CODE,".",1,2),CODE=$$NEXT^ICDAPIU(CODE),COUT=CODE,(IENI,IENO)=""
I +$$CODEN^ICDCODE(COUT,80)>0 D
.N ICD9,IFOUTX
.S IENO=+$$CODEN^ICDCODE(COUT,80)
.S ICD9=$$ICDDX^ICDCODE(+IENO)
.S NAME=$P(ICD9,U,4)
.S IFOUTX=$P(ICD9,U,10),IFOUT=$S(IFOUTX=0:1,IFOUTX=1:0,1:"")
S ES="Invalid "_TY_" format "
; Format
; not enough digits
I $E(CIN,1)="E",$L($P($E(CIN,2,$L(CIN)),".",1))<3 D ERR((ES_"(not enough digits, "_PAT_")")) G AQ
I $E(CIN,1)?1N,$L($P(CIN,".",1))<3 D ERR((ES_"(not enough digits, "_PAT_")")) G AQ
I $E(CIN,1)="V",$L($P($E(CIN,2,$L(CIN)),".",1))<2 D ERR((ES_"(not enough digits, "_PAT_")")) G AQ
; too many digits
I $E(CIN,1)="E",$L($P($E(CIN,2,$L(CIN)),".",1))>3 D ERR((ES_"(too many digits, "_PAT_")")) G AQ
I $E(CIN,1)?1N,$L($P(CIN,".",1))>3 D ERR((ES_"(too many digits, "_PAT_")")) G AQ
I $E(CIN,1)="V",$L($P($E(CIN,2,$L(CIN)),".",1))>2 D ERR((ES_"(too many digits, "_PAT_")")) G AQ
; missing decimal point
I CIN'["." D ERR((ES_"(missing decimal point "_PAT_")")) G AQ
; to many decimal points
I $L(CIN,".")>2 D ERR((ES_"(too many decimal points "_PAT_")")) G AQ
; to many decimal places
I $L($P(CIN,".",2))>2 D ERR((ES_"(too many decimals places, "_PAT_")")) G AQ
; non-numeric decimal
I $P(CIN,".",2)'?2N&($P(CIN,".",2)'?1N)&($P(CIN,".",2)'="") D ERR((ES_"(non-numeric decimal, "_PAT_")")) G AQ
; invalid pattern
I $E(CIN,1)="E",$P(CIN,".",1)'?1U3N D ERR((ES_"("_PAT_")")) G AQ
I $E(CIN,1)="V",$P(CIN,".",1)'?1U2N D ERR((ES_"("_PAT_")")) G AQ
I $E(CIN,1)?1N,$P(CIN,".",1)'?3N D ERR((ES_"("_PAT_")")) G AQ
; Value
; not found
I +$$CODEN^ICDCODE(CIN,80)<0 D G AQ
. N TC D ERR((TY_" not found in the ICD-9 file (#80)"))
. S TC=COUT S:'$L(TC) TC=CIN I $E(TC,$L(TC))="0" D
. . N SC,COUT S (SC,COUT)=TC F S TC=$E(TC,1,($L(TC)-1)) S:+$$CODEN^ICDCODE(TC,80)>0 SC=TC Q:$E(TC,$L(TC))'="0"!(SC'=COUT) Q:TC=""
. . S TC="" S:SC'=COUT TC=SC
. S:$L(TC) COUT=TC
. S:+$$CODEN^ICDCODE(CIN_"0")>0 COUT=CIN_"0"
. I +$$CODEN^ICDCODE(COUT,80)>0 D
. . N ICD9,IFOUTX
. . S IENO=+$$CODEN^ICDCODE(COUT,80)
. . S ICD9=$$ICDDX^ICDCODE(+IENO)
. . S NAME=$P(ICD9,U,4)
. . S IFOUTX=$P(ICD9,U,10),IFOUT=$S(IFOUTX=0:1,IFOUTX=1:0,1:"")
; found
I $$CODEN^ICDCODE(CIN,80)>0 D G AQ
. D ERR(("Valid "_TY)) S VAL=1
. S IENI=+$$CODEN^ICDCODE(CIN,80)
. N ICD9,IFINX
. S ICD9=$$ICDDX^ICDCODE(IENI)
. S NAME=$P(ICD9,U,4)
. S IFINX=$P(ICD9,U,10),IFIN=$S(IFINX=0:1,IFINX=1:0,1:"")
. S:(+(IFOUT)+(IFIN))>0 ERR="Inactive "_TY
G AQ
;
ICP(X) ; Validate ICD-9-CM Procedure Code from file 80.1
S X=$G(X),U="^" N CHR,CHKD,CIN,CODE,COUT,DIC,ERR,ES,FNUM,FORM,IENI,IENO,IFIN,IFOUT,NAME,NUMERIC,PAT,TY,VAL,Y
S FNUM=80.1,DIC="ICD0(",VAL=1,(NAME,IFIN,IFOUT)="",CIN=$TR(X,"""","")
; Code transformation
S CODE=X,TY="ICD Procedure code",PAT="NN.nn",CHKD=TY S:CODE'["." CODE=CODE_"." S:$L($P(CODE,".",1))=1 CODE="0"_CODE S CODE=$$NEXT^ICDAPIU(CODE),COUT=CODE
S VAL=1,ERR="Valid "_TY
I +$$CODEN^ICDCODE(CODE,80.1)>0 D
.S IENO=+$$CODEN^ICDCODE(CODE,80.1)
.N ICDO,IFOUTX
.S ICDO=$$ICDOP^ICDCODE(+IENO)
.S NAME=$P(ICDO,"^",5)
.S IFOUTX=$P(ICDO,U,10),IFOUT=$S(IFOUTX=0:1,IFOUTX=1:"",1:"")
S ES="Invalid "_TY_" format "
; Format
; not enough digits
I $L($P(CIN,".",1))<2 D ERR((ES_"(not enough digits, "_PAT_")")) G AQ
; too many digits
I $L($P(CIN,".",1))>2 D ERR((ES_"(too many digits, "_PAT_")")) G AQ
; missing decimal point
I CIN'["." D ERR((ES_"(missing decimal point "_PAT_")")) G AQ
; too many decimal points
I $L(CIN,".")>2 D ERR((ES_"(too many decimal points "_PAT_")")) G AQ
; too many decimal places
I $L($P(CIN,".",2))>2 D ERR((ES_"(too many decimals places, "_PAT_")")) G AQ
; non-numeric decimal
I $P(CIN,".",2)'?2N&($P(CIN,".",2)'?1N)&($P(CIN,".",2)'="") D ERR((ES_"(non-numeric decimal, "_PAT_")")) G AQ
; invalid pattern
I $P(CIN,".",1)'?2N D ERR((ES_"("_PAT_")")) G AQ
; Value
; not found
I +$$CODEN^ICDCODE(CIN,80.1)<0 D G AQ
. N TC D ERR((TY_" not found in the ICD-0 file (#80.1)")) S COUT=""
. S TC=COUT S:'$L(TC) TC=CIN I $E(TC,$L(TC))="0" D
. . N SC,COUT S (SC,COUT)=TC F S TC=$E(TC,1,($L(TC)-1)) S:+$$CODEN^ICDCODE(TC,80.1)>0 SC=TC Q:$E(TC,$L(TC))'="0"!(SC'=COUT) Q:TC=""
. . S TC="" S:SC'=COUT TC=SC
. S:$L(TC) COUT=TC
. S:+$$CODEN^ICDCODE(CIN_"0",80.1)>0 COUT=CIN_"0"
. I +$$CODEN^ICDCODE(COUT,80.1)>0 D
. . S IENO=+$$CODEN^ICDCODE(COUT,80.1)
. . N ICDO,IFOUTX
. . S ICDO=$$ICDOP^ICDCODE(+IENO)
. . S NAME=$P(ICDO,"^",5)
. . S IFOUTX=$P(ICDO,U,10),IFOUT=$S(IFOUTX=0:1,IFOUTX=1:"",1:"")
; found
I $$CODEN^ICDCODE(CIN,80.1)>0 D G AQ
. S VAL=1,ERR="Valid "_TY
. S IENI=+$$CODEN^ICDCODE(CIN,80.1)
. N ICDO,IFINX
. S ICDO=$$ICDOP^ICDCODE(+IENI)
. S NAME=$P(ICDO,"^",5)
. S IFINX=$P(ICDO,"^",10),IFIN=$S(IFINX=0:1,IFINX=1:"",1:"")
. S:(+(IFOUT)+(IFIN))>0 ERR="Inactive "_TY
G AQ
;
CPT(X) ; Validate Procedure Code from file 81
S X=$G(X),U="^"
N CHR,CHKD,CIN,CODE,COUT,DIC,ERR,ES,FNUM,FORM,IENI,IENO,IFIN,IFOUT
N NAME,NUMERIC,PAT,STATUS,TEMP,TY,VAL,Y
S VAL=1,FNUM=81,DIC="ICPT(",(IFIN,IFOUT,NAME)="",CIN=$TR(X,"""","")
S FORM=$S(CIN?5N:1,CIN?1A4N:2,CIN?4N1A:2,1:0)
S TY=$S(FORM=1:"CPT-4 code",FORM=2:"HCPCS code",1:"unknown")
S CHKD=$S(FORM=1:"CPT-4 procedure code",FORM=2:"HCPCS procedure code",1:"Unknown format")
S PAT=$S(FORM=1:"NNNNN",FORM=2:"ANNNN or NNNNA",1:"")
S ES="Invalid "_TY_" format "
; Code transformation
; HCPCS
S CODE=X I FORM=2 D
. N CHR,NUMERIC S CHR=$E(CODE,1),NUMERIC=$E(CODE,2,$L(CODE))
. S NUMERIC=$TR(NUMERIC,"~!@#$%^&*()_-+=[{]};:\|,./?<>QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm","0000000000000000000000000000000000000000000000000000000000000000000000000000000000")
. F Q:$E(NUMERIC,1)'="0" S NUMERIC=$E(NUMERIC,2,$L(NUMERIC))
. S NUMERIC=+NUMERIC F Q:$L(NUMERIC)>3 S NUMERIC="0"_NUMERIC
. S CODE=CHR_NUMERIC
; CPT-4
I FORM=1 D
. N NUMERIC S NUMERIC=CODE,NUMERIC=$TR(NUMERIC,"~!@#$%^&*()_-+=[{]};:\|,./?<>QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm","0000000000000000000000000000000000000000000000000000000000000000000000000000000000")
. I +NUMERIC>0,$E(NUMERIC,1)'="0",$L(NUMERIC)<5 F Q:$L(NUMERIC)=5 S NUMERIC="0"_NUMERIC
. I +NUMERIC>0,$E(NUMERIC,1)="0",$L(NUMERIC)<5 F Q:$L(NUMERIC)=5 S NUMERIC=NUMERIC_"0"
. F Q:$E(NUMERIC,1)'="0" S NUMERIC=$E(NUMERIC,2,$L(NUMERIC))
. S NUMERIC=+NUMERIC F Q:$L(NUMERIC)>4 S NUMERIC="0"_NUMERIC
. S CODE=NUMERIC
;S CODE=$$NEXT^ICPTAPIU(CODE),COUT=CODE S (IENI,IENO)="" ;Patch 1001
S CODE=$$NEXT^PXRMVALU(CODE),COUT=CODE S (IENI,IENO)="" ;Patch 1001 replaced call
I $L(COUT),+$$CODEN^ICPTCOD(COUT)>0 D
. S IENO=+$$CODEN^ICPTCOD(COUT)
. S TEMP=$$CPT^ICPTCOD(IENO)
. S NAME=$P(TEMP,U,3)
. S STATUS=$P(TEMP,U,7)
. S IFOUT=$S(STATUS:"",1:1)
; Format
; not enough characters
I $L(CIN)<5 D ERR((ES_"(not enough characters)")) G AQ
; too many characters
I $L(CIN)>5 D ERR((ES_"(too many characters)")) G AQ
; Invalid pattern
I FORM=0 D ERR(ES_PAT) G AQ
; Value not found
I +$$CODEN^ICPTCOD(CIN)<1 D ERR((TY_" not found in the CPT file (#81)")) S COUT="" G AQ
; found
I +$$CODEN^ICPTCOD(CIN)>0 D G AQ
. S VAL=1,ERR="Valid "_TY
. S IENI=+$$CODEN^ICPTCOD(CIN)
. S TEMP=$$CPT^ICPTCOD(IENI)
. S NAME=$P(TEMP,U,3)
. S STATUS=$P(TEMP,U,7)
. S IFIN=$S(STATUS:"",1:1)
. S:(+(IFOUT)+(IFIN))>0 ERR="Inactive "_TY
G AQ
AQ ; Assemble output string and quit
S X=$G(VAL)_U_$G(CIN)_U_$G(COUT)_U_$G(ERR)_U_FNUM
S X=X_U_DIC_U_$G(CHKD)_U_$G(IENI)_U_$G(IFIN)_U_$G(IENO)_U_$G(IFOUT)_U_$G(NAME)
F Q:$E(X,$L(X))'="^" S X=$E(X,1,($L(X)-1))
Q X
ERR(X) S VAL=0,ERR=$G(X) Q
PXRMVALC ; SLC/KR - VAL Validate Codes (format/value) ;31-May-2013 13:35;DU
+1 ;;2.0;CLINICAL REMINDERS;**4,1001**;Feb 04, 2005;Build 21
+2 QUIT
+3 ;
+4 ; Entry points (extrinsic functions)
+5 ;
+6 ; ICD^PXRMVALC(<code>) Validate ICD-9-CM Diagnosis Code
+7 ; ICP^PXRMVALC(<code>) Validate ICD-9-CM Procedure Code
+8 ; CPT^PXRMVALC(<code>) Validate CPT-4 Procedure Code
+9 ;
+10 ; All entry points return:
+11 ;
+12 ; <validity>^<input>^<output>^<error>^<file #>^<global root>^
+13 ; <type of code>^<input IEN>^<input flag>^<output IEN>^
+14 ; <output flag>^<description>
+15 ;
ICD(X) ; Validate ICD-9-CM Diagnosis Code from file 80
+1 SET X=$GET(X)
SET U="^"
NEW CHR,CHKD,CIN,CODE,COUT,DIC,ERR,ES,FNUM,FORM,IENI,IENO,IFIN,IFOUT,NAME,NUMERIC,PAT,TY,VAL,Y
+2 SET VAL=1
SET FNUM=80
SET DIC="ICD9("
SET (IFIN,IFOUT,NAME)=""
SET CIN=$TRANSLATE(X,"""","")
SET U="^"
+3 SET FORM=$SELECT($EXTRACT(X,1)="E":2,$EXTRACT(X,1)="V":3,$EXTRACT(X,1)?1N:1,1:1)
SET TY=$SELECT(FORM=2:"ICD ""E"" code",FORM=3:"ICD ""V"" code",FORM=1:"ICD code",1:"ICD code")
+4 SET ERR="Valid "_TY
SET CHKD=$SELECT(FORM=2:"ICD-9-CM ""E"" external cause code",FORM=3:"ICD-9-CM ""V"" health factor code",FORM=1:"ICD-9-CM diagnosis code",1:"ICD-9-CM code")
+5 SET PAT=$SELECT(FORM=2:"ENNN.nn",FORM=3:"VNN.nn",FORM=1:"NNN.nn",1:"ENNN.nn, VNN.nn or NNN.nn")
+6 ; Code transformation
+7 SET CODE=X
IF CODE'["."
SET CODE=CODE_"."
+8 IF FORM=1&($LENGTH($PIECE(CODE,".",1))=1)&(+($PIECE(CODE,".",1))>0)
SET $PIECE(CODE,".",1)="00"_$PIECE(CODE,".",1)
IF FORM=1&($LENGTH($PIECE(CODE,".",1))=2)&(+($PIECE(CODE,".",1))>0)
SET $PIECE(CODE,".",1)="0"_$PIECE(CODE,".",1)
SET X=CODE
+9 SET CODE=$PIECE(CODE,".",1,2)
SET CODE=$$NEXT^ICDAPIU(CODE)
SET COUT=CODE
SET (IENI,IENO)=""
+10 IF +$$CODEN^ICDCODE(COUT,80)>0
Begin DoDot:1
+11 NEW ICD9,IFOUTX
+12 SET IENO=+$$CODEN^ICDCODE(COUT,80)
+13 SET ICD9=$$ICDDX^ICDCODE(+IENO)
+14 SET NAME=$PIECE(ICD9,U,4)
+15 SET IFOUTX=$PIECE(ICD9,U,10)
SET IFOUT=$SELECT(IFOUTX=0:1,IFOUTX=1:0,1:"")
End DoDot:1
+16 SET ES="Invalid "_TY_" format "
+17 ; Format
+18 ; not enough digits
+19 IF $EXTRACT(CIN,1)="E"
IF $LENGTH($PIECE($EXTRACT(CIN,2,$LENGTH(CIN)),".",1))<3
DO ERR((ES_"(not enough digits, "_PAT_")"))
GOTO AQ
+20 IF $EXTRACT(CIN,1)?1N
IF $LENGTH($PIECE(CIN,".",1))<3
DO ERR((ES_"(not enough digits, "_PAT_")"))
GOTO AQ
+21 IF $EXTRACT(CIN,1)="V"
IF $LENGTH($PIECE($EXTRACT(CIN,2,$LENGTH(CIN)),".",1))<2
DO ERR((ES_"(not enough digits, "_PAT_")"))
GOTO AQ
+22 ; too many digits
+23 IF $EXTRACT(CIN,1)="E"
IF $LENGTH($PIECE($EXTRACT(CIN,2,$LENGTH(CIN)),".",1))>3
DO ERR((ES_"(too many digits, "_PAT_")"))
GOTO AQ
+24 IF $EXTRACT(CIN,1)?1N
IF $LENGTH($PIECE(CIN,".",1))>3
DO ERR((ES_"(too many digits, "_PAT_")"))
GOTO AQ
+25 IF $EXTRACT(CIN,1)="V"
IF $LENGTH($PIECE($EXTRACT(CIN,2,$LENGTH(CIN)),".",1))>2
DO ERR((ES_"(too many digits, "_PAT_")"))
GOTO AQ
+26 ; missing decimal point
+27 IF CIN'["."
DO ERR((ES_"(missing decimal point "_PAT_")"))
GOTO AQ
+28 ; to many decimal points
+29 IF $LENGTH(CIN,".")>2
DO ERR((ES_"(too many decimal points "_PAT_")"))
GOTO AQ
+30 ; to many decimal places
+31 IF $LENGTH($PIECE(CIN,".",2))>2
DO ERR((ES_"(too many decimals places, "_PAT_")"))
GOTO AQ
+32 ; non-numeric decimal
+33 IF $PIECE(CIN,".",2)'?2N&($PIECE(CIN,".",2)'?1N)&($PIECE(CIN,".",2)'="")
DO ERR((ES_"(non-numeric decimal, "_PAT_")"))
GOTO AQ
+34 ; invalid pattern
+35 IF $EXTRACT(CIN,1)="E"
IF $PIECE(CIN,".",1)'?1U3N
DO ERR((ES_"("_PAT_")"))
GOTO AQ
+36 IF $EXTRACT(CIN,1)="V"
IF $PIECE(CIN,".",1)'?1U2N
DO ERR((ES_"("_PAT_")"))
GOTO AQ
+37 IF $EXTRACT(CIN,1)?1N
IF $PIECE(CIN,".",1)'?3N
DO ERR((ES_"("_PAT_")"))
GOTO AQ
+38 ; Value
+39 ; not found
+40 IF +$$CODEN^ICDCODE(CIN,80)<0
Begin DoDot:1
+41 NEW TC
DO ERR((TY_" not found in the ICD-9 file (#80)"))
+42 SET TC=COUT
IF '$LENGTH(TC)
SET TC=CIN
IF $EXTRACT(TC,$LENGTH(TC))="0"
Begin DoDot:2
+43 NEW SC,COUT
SET (SC,COUT)=TC
FOR
SET TC=$EXTRACT(TC,1,($LENGTH(TC)-1))
IF +$$CODEN^ICDCODE(TC,80)>0
SET SC=TC
IF $EXTRACT(TC,$LENGTH(TC))'="0"!(SC'=COUT)
QUIT
IF TC=""
QUIT
+44 SET TC=""
IF SC'=COUT
SET TC=SC
End DoDot:2
+45 IF $LENGTH(TC)
SET COUT=TC
+46 IF +$$CODEN^ICDCODE(CIN_"0")>0
SET COUT=CIN_"0"
+47 IF +$$CODEN^ICDCODE(COUT,80)>0
Begin DoDot:2
+48 NEW ICD9,IFOUTX
+49 SET IENO=+$$CODEN^ICDCODE(COUT,80)
+50 SET ICD9=$$ICDDX^ICDCODE(+IENO)
+51 SET NAME=$PIECE(ICD9,U,4)
+52 SET IFOUTX=$PIECE(ICD9,U,10)
SET IFOUT=$SELECT(IFOUTX=0:1,IFOUTX=1:0,1:"")
End DoDot:2
End DoDot:1
GOTO AQ
+53 ; found
+54 IF $$CODEN^ICDCODE(CIN,80)>0
Begin DoDot:1
+55 DO ERR(("Valid "_TY))
SET VAL=1
+56 SET IENI=+$$CODEN^ICDCODE(CIN,80)
+57 NEW ICD9,IFINX
+58 SET ICD9=$$ICDDX^ICDCODE(IENI)
+59 SET NAME=$PIECE(ICD9,U,4)
+60 SET IFINX=$PIECE(ICD9,U,10)
SET IFIN=$SELECT(IFINX=0:1,IFINX=1:0,1:"")
+61 IF (+(IFOUT)+(IFIN))>0
SET ERR="Inactive "_TY
End DoDot:1
GOTO AQ
+62 GOTO AQ
+63 ;
ICP(X) ; Validate ICD-9-CM Procedure Code from file 80.1
+1 SET X=$GET(X)
SET U="^"
NEW CHR,CHKD,CIN,CODE,COUT,DIC,ERR,ES,FNUM,FORM,IENI,IENO,IFIN,IFOUT,NAME,NUMERIC,PAT,TY,VAL,Y
+2 SET FNUM=80.1
SET DIC="ICD0("
SET VAL=1
SET (NAME,IFIN,IFOUT)=""
SET CIN=$TRANSLATE(X,"""","")
+3 ; Code transformation
+4 SET CODE=X
SET TY="ICD Procedure code"
SET PAT="NN.nn"
SET CHKD=TY
IF CODE'["."
SET CODE=CODE_"."
IF $LENGTH($PIECE(CODE,".",1))=1
SET CODE="0"_CODE
SET CODE=$$NEXT^ICDAPIU(CODE)
SET COUT=CODE
+5 SET VAL=1
SET ERR="Valid "_TY
+6 IF +$$CODEN^ICDCODE(CODE,80.1)>0
Begin DoDot:1
+7 SET IENO=+$$CODEN^ICDCODE(CODE,80.1)
+8 NEW ICDO,IFOUTX
+9 SET ICDO=$$ICDOP^ICDCODE(+IENO)
+10 SET NAME=$PIECE(ICDO,"^",5)
+11 SET IFOUTX=$PIECE(ICDO,U,10)
SET IFOUT=$SELECT(IFOUTX=0:1,IFOUTX=1:"",1:"")
End DoDot:1
+12 SET ES="Invalid "_TY_" format "
+13 ; Format
+14 ; not enough digits
+15 IF $LENGTH($PIECE(CIN,".",1))<2
DO ERR((ES_"(not enough digits, "_PAT_")"))
GOTO AQ
+16 ; too many digits
+17 IF $LENGTH($PIECE(CIN,".",1))>2
DO ERR((ES_"(too many digits, "_PAT_")"))
GOTO AQ
+18 ; missing decimal point
+19 IF CIN'["."
DO ERR((ES_"(missing decimal point "_PAT_")"))
GOTO AQ
+20 ; too many decimal points
+21 IF $LENGTH(CIN,".")>2
DO ERR((ES_"(too many decimal points "_PAT_")"))
GOTO AQ
+22 ; too many decimal places
+23 IF $LENGTH($PIECE(CIN,".",2))>2
DO ERR((ES_"(too many decimals places, "_PAT_")"))
GOTO AQ
+24 ; non-numeric decimal
+25 IF $PIECE(CIN,".",2)'?2N&($PIECE(CIN,".",2)'?1N)&($PIECE(CIN,".",2)'="")
DO ERR((ES_"(non-numeric decimal, "_PAT_")"))
GOTO AQ
+26 ; invalid pattern
+27 IF $PIECE(CIN,".",1)'?2N
DO ERR((ES_"("_PAT_")"))
GOTO AQ
+28 ; Value
+29 ; not found
+30 IF +$$CODEN^ICDCODE(CIN,80.1)<0
Begin DoDot:1
+31 NEW TC
DO ERR((TY_" not found in the ICD-0 file (#80.1)"))
SET COUT=""
+32 SET TC=COUT
IF '$LENGTH(TC)
SET TC=CIN
IF $EXTRACT(TC,$LENGTH(TC))="0"
Begin DoDot:2
+33 NEW SC,COUT
SET (SC,COUT)=TC
FOR
SET TC=$EXTRACT(TC,1,($LENGTH(TC)-1))
IF +$$CODEN^ICDCODE(TC,80.1)>0
SET SC=TC
IF $EXTRACT(TC,$LENGTH(TC))'="0"!(SC'=COUT)
QUIT
IF TC=""
QUIT
+34 SET TC=""
IF SC'=COUT
SET TC=SC
End DoDot:2
+35 IF $LENGTH(TC)
SET COUT=TC
+36 IF +$$CODEN^ICDCODE(CIN_"0",80.1)>0
SET COUT=CIN_"0"
+37 IF +$$CODEN^ICDCODE(COUT,80.1)>0
Begin DoDot:2
+38 SET IENO=+$$CODEN^ICDCODE(COUT,80.1)
+39 NEW ICDO,IFOUTX
+40 SET ICDO=$$ICDOP^ICDCODE(+IENO)
+41 SET NAME=$PIECE(ICDO,"^",5)
+42 SET IFOUTX=$PIECE(ICDO,U,10)
SET IFOUT=$SELECT(IFOUTX=0:1,IFOUTX=1:"",1:"")
End DoDot:2
End DoDot:1
GOTO AQ
+43 ; found
+44 IF $$CODEN^ICDCODE(CIN,80.1)>0
Begin DoDot:1
+45 SET VAL=1
SET ERR="Valid "_TY
+46 SET IENI=+$$CODEN^ICDCODE(CIN,80.1)
+47 NEW ICDO,IFINX
+48 SET ICDO=$$ICDOP^ICDCODE(+IENI)
+49 SET NAME=$PIECE(ICDO,"^",5)
+50 SET IFINX=$PIECE(ICDO,"^",10)
SET IFIN=$SELECT(IFINX=0:1,IFINX=1:"",1:"")
+51 IF (+(IFOUT)+(IFIN))>0
SET ERR="Inactive "_TY
End DoDot:1
GOTO AQ
+52 GOTO AQ
+53 ;
CPT(X) ; Validate Procedure Code from file 81
+1 SET X=$GET(X)
SET U="^"
+2 NEW CHR,CHKD,CIN,CODE,COUT,DIC,ERR,ES,FNUM,FORM,IENI,IENO,IFIN,IFOUT
+3 NEW NAME,NUMERIC,PAT,STATUS,TEMP,TY,VAL,Y
+4 SET VAL=1
SET FNUM=81
SET DIC="ICPT("
SET (IFIN,IFOUT,NAME)=""
SET CIN=$TRANSLATE(X,"""","")
+5 SET FORM=$SELECT(CIN?5N:1,CIN?1A4N:2,CIN?4N1A:2,1:0)
+6 SET TY=$SELECT(FORM=1:"CPT-4 code",FORM=2:"HCPCS code",1:"unknown")
+7 SET CHKD=$SELECT(FORM=1:"CPT-4 procedure code",FORM=2:"HCPCS procedure code",1:"Unknown format")
+8 SET PAT=$SELECT(FORM=1:"NNNNN",FORM=2:"ANNNN or NNNNA",1:"")
+9 SET ES="Invalid "_TY_" format "
+10 ; Code transformation
+11 ; HCPCS
+12 SET CODE=X
IF FORM=2
Begin DoDot:1
+13 NEW CHR,NUMERIC
SET CHR=$EXTRACT(CODE,1)
SET NUMERIC=$EXTRACT(CODE,2,$LENGTH(CODE))
+14 SET NUMERIC=$TRANSLATE(NUMERIC,"~!@#$%^&*()_-+=[{]};:\|,./?<>QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm","0000000000000000000000000000000000000000000000000000000000000000000000000000000000")
+15 FOR
IF $EXTRACT(NUMERIC,1)'="0"
QUIT
SET NUMERIC=$EXTRACT(NUMERIC,2,$LENGTH(NUMERIC))
+16 SET NUMERIC=+NUMERIC
FOR
IF $LENGTH(NUMERIC)>3
QUIT
SET NUMERIC="0"_NUMERIC
+17 SET CODE=CHR_NUMERIC
End DoDot:1
+18 ; CPT-4
+19 IF FORM=1
Begin DoDot:1
+20 NEW NUMERIC
SET NUMERIC=CODE
SET NUMERIC=$TRANSLATE(NUMERIC,"~!@#$%^&*()_-+=[{]};:\|,./?<>QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm","0000000000000000000000000000000000000000000000000000000000000000000000000000000000")
+21 IF +NUMERIC>0
IF $EXTRACT(NUMERIC,1)'="0"
IF $LENGTH(NUMERIC)<5
FOR
IF $LENGTH(NUMERIC)=5
QUIT
SET NUMERIC="0"_NUMERIC
+22 IF +NUMERIC>0
IF $EXTRACT(NUMERIC,1)="0"
IF $LENGTH(NUMERIC)<5
FOR
IF $LENGTH(NUMERIC)=5
QUIT
SET NUMERIC=NUMERIC_"0"
+23 FOR
IF $EXTRACT(NUMERIC,1)'="0"
QUIT
SET NUMERIC=$EXTRACT(NUMERIC,2,$LENGTH(NUMERIC))
+24 SET NUMERIC=+NUMERIC
FOR
IF $LENGTH(NUMERIC)>4
QUIT
SET NUMERIC="0"_NUMERIC
+25 SET CODE=NUMERIC
End DoDot:1
+26 ;S CODE=$$NEXT^ICPTAPIU(CODE),COUT=CODE S (IENI,IENO)="" ;Patch 1001
+27 ;Patch 1001 replaced call
SET CODE=$$NEXT^PXRMVALU(CODE)
SET COUT=CODE
SET (IENI,IENO)=""
+28 IF $LENGTH(COUT)
IF +$$CODEN^ICPTCOD(COUT)>0
Begin DoDot:1
+29 SET IENO=+$$CODEN^ICPTCOD(COUT)
+30 SET TEMP=$$CPT^ICPTCOD(IENO)
+31 SET NAME=$PIECE(TEMP,U,3)
+32 SET STATUS=$PIECE(TEMP,U,7)
+33 SET IFOUT=$SELECT(STATUS:"",1:1)
End DoDot:1
+34 ; Format
+35 ; not enough characters
+36 IF $LENGTH(CIN)<5
DO ERR((ES_"(not enough characters)"))
GOTO AQ
+37 ; too many characters
+38 IF $LENGTH(CIN)>5
DO ERR((ES_"(too many characters)"))
GOTO AQ
+39 ; Invalid pattern
+40 IF FORM=0
DO ERR(ES_PAT)
GOTO AQ
+41 ; Value not found
+42 IF +$$CODEN^ICPTCOD(CIN)<1
DO ERR((TY_" not found in the CPT file (#81)"))
SET COUT=""
GOTO AQ
+43 ; found
+44 IF +$$CODEN^ICPTCOD(CIN)>0
Begin DoDot:1
+45 SET VAL=1
SET ERR="Valid "_TY
+46 SET IENI=+$$CODEN^ICPTCOD(CIN)
+47 SET TEMP=$$CPT^ICPTCOD(IENI)
+48 SET NAME=$PIECE(TEMP,U,3)
+49 SET STATUS=$PIECE(TEMP,U,7)
+50 SET IFIN=$SELECT(STATUS:"",1:1)
+51 IF (+(IFOUT)+(IFIN))>0
SET ERR="Inactive "_TY
End DoDot:1
GOTO AQ
+52 GOTO AQ
AQ ; Assemble output string and quit
+1 SET X=$GET(VAL)_U_$GET(CIN)_U_$GET(COUT)_U_$GET(ERR)_U_FNUM
+2 SET X=X_U_DIC_U_$GET(CHKD)_U_$GET(IENI)_U_$GET(IFIN)_U_$GET(IENO)_U_$GET(IFOUT)_U_$GET(NAME)
+3 FOR
IF $EXTRACT(X,$LENGTH(X))'="^"
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
ERR(X) SET VAL=0
SET ERR=$GET(X)
QUIT
