- 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