PXRMVALU ; SLC/KER - Validate Codes (utility) ; 05/16/2000
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
Q
FILE(X) ; Get File
;
; Requires:
;
; X in the form of a classification code
;
; Returns:
;
; <file #>^<DIC>^<code type>
;
S X=$G(X) Q:'$L(X) "80^ICD9(^ICD-9-CM diagnostic code"
N FI,DIC,TYPE S (FI,DIC,TYPE)=""
I +X>0 D Q (FI_"^"_DIC_"^"_TYPE)
. I $L($P(X,".",1))>3,X'["." S FI=81,DIC="ICPT(",TYPE="CPT-4 procedure code" Q
. I $L($P(X,".",1))>2 S FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code" Q
. I $L($P(X,".",1))'>2 D
. . N I,OK,SEARCH,CONTROL S SEARCH=$E(X,1,($L(X)-1))_$C($A($E(X,$L(X)))-1)_"~",CONTROL=X
. . S OK=0 F I=1:1 D Q:OK=1!($L($P(SEARCH,".",1))>3)
. . . I $O(^ICD9("BA",(SEARCH_" ")))=(CONTROL_" ") D Q
. . . . S OK=1,FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code" Q
. . . I $O(^ICD0("BA",(SEARCH_" ")))=(CONTROL_" ") D Q
. . . . S OK=1,FI=80.1,DIC="ICD9(",TYPE="ICD-9-CM procedure code" Q
. . . S SEARCH="0"_SEARCH,CONTROL="0"_CONTROL
. . I 'OK S SEARCH=$E(X,1,($L(X)-1))_$C($A($E(X,$L(X)))-1)_"~",CONTROL=X F I=1:1 D Q:OK=1!($L($P(SEARCH,".",1))>3)
. . . I $P($O(^ICD9("BA",(SEARCH_" "))),".",1)=$P(CONTROL,".",1),+($P($O(^ICD9("BA",(SEARCH_" "))),".",2))=0,+($P(CONTROL,".",2))=0 D Q
. . . . S OK=1,FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code" Q
. . . I $P($O(^ICD0("BA",(SEARCH_" "))),".",1)=$P(CONTROL,".",1),+($P($O(^ICD0("BA",(SEARCH_" "))),".",2))=0,+($P(CONTROL,".",2))=0 D Q
. . . . S OK=1,FI=80.1,DIC="ICD9(",TYPE="ICD-9-CM procedure code" Q
. . . S SEARCH="0"_SEARCH,CONTROL="0"_CONTROL
. S:TYPE="" FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code"
I +X=0 D Q (FI_"^"_DIC_"^"_TYPE)
. I $L($P(X,".",1))>4,X'["." S FI=81,DIC="ICPT(",TYPE="HCPCS procedure code" Q
. I X["-" S FI=81,DIC="ICPT(",TYPE="HCPCS procedure code" Q
. I $E(X,1)="E",X["." S FI=80,DIC="ICD9(",TYPE="ICD-9-CM ""E"" code (external causes)" Q
. I $E(X,1)="E",$L($E(X,2,$L(X)))=3 S FI=80,DIC="ICD9(",TYPE="ICD-9-CM ""E"" code (external causes)" Q
. I $E(X,1)="V",X["." S FI=80,DIC="ICD9(",TYPE="ICD-9-CM ""V"" code (health factors)" Q
. I $E(X,1)="V",$L($E(X,2,$L(X)))=2 S FI=80,DIC="ICD9(",TYPE="ICD-9-CM ""V"" code (health factors)" Q
. S FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code"
Q "80^ICD9(^ICD-9-CM diagnostic code"
TYPE(X,Y) ; Code type
;
; Requires:
;
; X in the form of a classification code
; Y file number or global root
;
; Returns:
;
; <type> free text string description of code type
;
; ICD-9-CM diagnosis
; ICD-9-CM "E" external causes
; ICD-9-CM "V" health factors
; ICD-9-CM procedures
; CPT-4 procedures
; HCPCS procedures
;
N TYPE,FI,CO S FI=$G(Y),CO=$G(X),TYPE="" S:+CO>0&(FI=80!(FI["ICD9")) TYPE="ICD-9-CM diagnosis" S:$E(CO,1)="E"&(FI=80!(FI["ICD9")) TYPE="ICD-9-CM ""E"" external causes"
S:$E(CO,1)="V"&(FI=80!(FI["ICD9")) TYPE="ICD-9-CM ""V"" health factors" S:+CO>0&(FI=80.1!(FI["ICD0")) TYPE="ICD-9-CM procedures"
S:+CO>0&(FI=81!(FI["ICPT")) TYPE="CPT-4 procedures" S:+CO=0&(FI=81!(FI["ICPT")) TYPE="HCPCS procedures"
S X=TYPE Q X
NEXT(X,FILE) ; Next code in file
;
; Requires:
;
; X in the form of a classification code
; FILE file number
;
; Returns:
;
; <code> Next code found in file
;
N NCODE,NEXT S FILE=+($G(FILE)),X=$$TRIM($G(X)) Q:X="" ""
I FILE=80 D Q X
. Q:$D(^ICD9("BA",X_" ")) S NEXT=$$TRIM($O(^ICD9("BA",(X_" ")))) I $E(NEXT,1,$L(X))=X S X=NEXT Q
. S:$E(NEXT,1,$L(X))'=X X=""
I FILE=80.1 D Q X
. Q:$D(^ICD0("BA",X_" ")) S NEXT=$$TRIM($O(^ICD0("BA",(X_" ")))) I $E(NEXT,1,$L(X))=X S X=NEXT Q
. S:$E(NEXT,1,$L(X))'=X X=""
I FILE=81 D Q X
. S NCODE=X I +NCODE>0,$E(NCODE,1)'="0",$L(NCODE)<5 F Q:$L(NCODE)=5 S NCODE="0"_NCODE
. S:$D(^ICPT("B",NCODE)) X=NCODE Q:$D(^ICPT("B",X)) S NEXT=$$TRIM($O(^ICPT("B",NCODE))) I $E(NEXT,1,$L(X))=X S X=NEXT Q
. S:$E(NEXT,1,$L(X))'=X X=""
Q X
TRIM(X) ; Trim leading/trailing spaces
S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
Q X
PXRMVALU ; SLC/KER - Validate Codes (utility) ; 05/16/2000
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 ;
+3 QUIT
FILE(X) ; Get File
+1 ;
+2 ; Requires:
+3 ;
+4 ; X in the form of a classification code
+5 ;
+6 ; Returns:
+7 ;
+8 ; <file #>^<DIC>^<code type>
+9 ;
+10 SET X=$GET(X)
IF '$LENGTH(X)
QUIT "80^ICD9(^ICD-9-CM diagnostic code"
+11 NEW FI,DIC,TYPE
SET (FI,DIC,TYPE)=""
+12 IF +X>0
Begin DoDot:1
+13 IF $LENGTH($PIECE(X,".",1))>3
IF X'["."
SET FI=81
SET DIC="ICPT("
SET TYPE="CPT-4 procedure code"
QUIT
+14 IF $LENGTH($PIECE(X,".",1))>2
SET FI=80
SET DIC="ICD9("
SET TYPE="ICD-9-CM diagnosis code"
QUIT
+15 IF $LENGTH($PIECE(X,".",1))'>2
Begin DoDot:2
+16 NEW I,OK,SEARCH,CONTROL
SET SEARCH=$EXTRACT(X,1,($LENGTH(X)-1))_$CHAR($ASCII($EXTRACT(X,$LENGTH(X)))-1)_"~"
SET CONTROL=X
+17 SET OK=0
FOR I=1:1
Begin DoDot:3
+18 IF $ORDER(^ICD9("BA",(SEARCH_" ")))=(CONTROL_" ")
Begin DoDot:4
+19 SET OK=1
SET FI=80
SET DIC="ICD9("
SET TYPE="ICD-9-CM diagnosis code"
QUIT
End DoDot:4
QUIT
+20 IF $ORDER(^ICD0("BA",(SEARCH_" ")))=(CONTROL_" ")
Begin DoDot:4
+21 SET OK=1
SET FI=80.1
SET DIC="ICD9("
SET TYPE="ICD-9-CM procedure code"
QUIT
End DoDot:4
QUIT
+22 SET SEARCH="0"_SEARCH
SET CONTROL="0"_CONTROL
End DoDot:3
IF OK=1!($LENGTH($PIECE(SEARCH,".",1))>3)
QUIT
+23 IF 'OK
SET SEARCH=$EXTRACT(X,1,($LENGTH(X)-1))_$CHAR($ASCII($EXTRACT(X,$LENGTH(X)))-1)_"~"
SET CONTROL=X
FOR I=1:1
Begin DoDot:3
+24 IF $PIECE($ORDER(^ICD9("BA",(SEARCH_" "))),".",1)=$PIECE(CONTROL,".",1)
IF +($PIECE($ORDER(^ICD9("BA",(SEARCH_" "))),".",2))=0
IF +($PIECE(CONTROL,".",2))=0
Begin DoDot:4
+25 SET OK=1
SET FI=80
SET DIC="ICD9("
SET TYPE="ICD-9-CM diagnosis code"
QUIT
End DoDot:4
QUIT
+26 IF $PIECE($ORDER(^ICD0("BA",(SEARCH_" "))),".",1)=$PIECE(CONTROL,".",1)
IF +($PIECE($ORDER(^ICD0("BA",(SEARCH_" "))),".",2))=0
IF +($PIECE(CONTROL,".",2))=0
Begin DoDot:4
+27 SET OK=1
SET FI=80.1
SET DIC="ICD9("
SET TYPE="ICD-9-CM procedure code"
QUIT
End DoDot:4
QUIT
+28 SET SEARCH="0"_SEARCH
SET CONTROL="0"_CONTROL
End DoDot:3
IF OK=1!($LENGTH($PIECE(SEARCH,".",1))>3)
QUIT
End DoDot:2
+29 IF TYPE=""
SET FI=80
SET DIC="ICD9("
SET TYPE="ICD-9-CM diagnosis code"
End DoDot:1
QUIT (FI_"^"_DIC_"^"_TYPE)
+30 IF +X=0
Begin DoDot:1
+31 IF $LENGTH($PIECE(X,".",1))>4
IF X'["."
SET FI=81
SET DIC="ICPT("
SET TYPE="HCPCS procedure code"
QUIT
+32 IF X["-"
SET FI=81
SET DIC="ICPT("
SET TYPE="HCPCS procedure code"
QUIT
+33 IF $EXTRACT(X,1)="E"
IF X["."
SET FI=80
SET DIC="ICD9("
SET TYPE="ICD-9-CM ""E"" code (external causes)"
QUIT
+34 IF $EXTRACT(X,1)="E"
IF $LENGTH($EXTRACT(X,2,$LENGTH(X)))=3
SET FI=80
SET DIC="ICD9("
SET TYPE="ICD-9-CM ""E"" code (external causes)"
QUIT
+35 IF $EXTRACT(X,1)="V"
IF X["."
SET FI=80
SET DIC="ICD9("
SET TYPE="ICD-9-CM ""V"" code (health factors)"
QUIT
+36 IF $EXTRACT(X,1)="V"
IF $LENGTH($EXTRACT(X,2,$LENGTH(X)))=2
SET FI=80
SET DIC="ICD9("
SET TYPE="ICD-9-CM ""V"" code (health factors)"
QUIT
+37 SET FI=80
SET DIC="ICD9("
SET TYPE="ICD-9-CM diagnosis code"
End DoDot:1
QUIT (FI_"^"_DIC_"^"_TYPE)
+38 QUIT "80^ICD9(^ICD-9-CM diagnostic code"
TYPE(X,Y) ; Code type
+1 ;
+2 ; Requires:
+3 ;
+4 ; X in the form of a classification code
+5 ; Y file number or global root
+6 ;
+7 ; Returns:
+8 ;
+9 ; <type> free text string description of code type
+10 ;
+11 ; ICD-9-CM diagnosis
+12 ; ICD-9-CM "E" external causes
+13 ; ICD-9-CM "V" health factors
+14 ; ICD-9-CM procedures
+15 ; CPT-4 procedures
+16 ; HCPCS procedures
+17 ;
+18 NEW TYPE,FI,CO
SET FI=$GET(Y)
SET CO=$GET(X)
SET TYPE=""
IF +CO>0&(FI=80!(FI["ICD9"))
SET TYPE="ICD-9-CM diagnosis"
IF $EXTRACT(CO,1)="E"&(FI=80!(FI["ICD9"))
SET TYPE="ICD-9-CM ""E"" external causes"
+19 IF $EXTRACT(CO,1)="V"&(FI=80!(FI["ICD9"))
SET TYPE="ICD-9-CM ""V"" health factors"
IF +CO>0&(FI=80.1!(FI["ICD0"))
SET TYPE="ICD-9-CM procedures"
+20 IF +CO>0&(FI=81!(FI["ICPT"))
SET TYPE="CPT-4 procedures"
IF +CO=0&(FI=81!(FI["ICPT"))
SET TYPE="HCPCS procedures"
+21 SET X=TYPE
QUIT X
NEXT(X,FILE) ; Next code in file
+1 ;
+2 ; Requires:
+3 ;
+4 ; X in the form of a classification code
+5 ; FILE file number
+6 ;
+7 ; Returns:
+8 ;
+9 ; <code> Next code found in file
+10 ;
+11 NEW NCODE,NEXT
SET FILE=+($GET(FILE))
SET X=$$TRIM($GET(X))
IF X=""
QUIT ""
+12 IF FILE=80
Begin DoDot:1
+13 IF $DATA(^ICD9("BA",X_" "))
QUIT
SET NEXT=$$TRIM($ORDER(^ICD9("BA",(X_" "))))
IF $EXTRACT(NEXT,1,$LENGTH(X))=X
SET X=NEXT
QUIT
+14 IF $EXTRACT(NEXT,1,$LENGTH(X))'=X
SET X=""
End DoDot:1
QUIT X
+15 IF FILE=80.1
Begin DoDot:1
+16 IF $DATA(^ICD0("BA",X_" "))
QUIT
SET NEXT=$$TRIM($ORDER(^ICD0("BA",(X_" "))))
IF $EXTRACT(NEXT,1,$LENGTH(X))=X
SET X=NEXT
QUIT
+17 IF $EXTRACT(NEXT,1,$LENGTH(X))'=X
SET X=""
End DoDot:1
QUIT X
+18 IF FILE=81
Begin DoDot:1
+19 SET NCODE=X
IF +NCODE>0
IF $EXTRACT(NCODE,1)'="0"
IF $LENGTH(NCODE)<5
FOR
IF $LENGTH(NCODE)=5
QUIT
SET NCODE="0"_NCODE
+20 IF $DATA(^ICPT("B",NCODE))
SET X=NCODE
IF $DATA(^ICPT("B",X))
QUIT
SET NEXT=$$TRIM($ORDER(^ICPT("B",NCODE)))
IF $EXTRACT(NEXT,1,$LENGTH(X))=X
SET X=NEXT
QUIT
+21 IF $EXTRACT(NEXT,1,$LENGTH(X))'=X
SET X=""
End DoDot:1
QUIT X
+22 QUIT X
TRIM(X) ; Trim leading/trailing spaces
+1 SET X=$GET(X)
FOR
IF $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
IF $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
