Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMVALU

PXRMVALU.m

Go to the documentation of this file.
  1. PXRMVALU ; SLC/KER - Validate Codes (utility) ; 05/16/2000
  1. ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  1. ;
  1. Q
  1. FILE(X) ; Get File
  1. ;
  1. ; Requires:
  1. ;
  1. ; X in the form of a classification code
  1. ;
  1. ; Returns:
  1. ;
  1. ; <file #>^<DIC>^<code type>
  1. ;
  1. S X=$G(X) Q:'$L(X) "80^ICD9(^ICD-9-CM diagnostic code"
  1. N FI,DIC,TYPE S (FI,DIC,TYPE)=""
  1. I +X>0 D Q (FI_"^"_DIC_"^"_TYPE)
  1. . I $L($P(X,".",1))>3,X'["." S FI=81,DIC="ICPT(",TYPE="CPT-4 procedure code" Q
  1. . I $L($P(X,".",1))>2 S FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code" Q
  1. . I $L($P(X,".",1))'>2 D
  1. . . N I,OK,SEARCH,CONTROL S SEARCH=$E(X,1,($L(X)-1))_$C($A($E(X,$L(X)))-1)_"~",CONTROL=X
  1. . . S OK=0 F I=1:1 D Q:OK=1!($L($P(SEARCH,".",1))>3)
  1. . . . I $O(^ICD9("BA",(SEARCH_" ")))=(CONTROL_" ") D Q
  1. . . . . S OK=1,FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code" Q
  1. . . . I $O(^ICD0("BA",(SEARCH_" ")))=(CONTROL_" ") D Q
  1. . . . . S OK=1,FI=80.1,DIC="ICD9(",TYPE="ICD-9-CM procedure code" Q
  1. . . . S SEARCH="0"_SEARCH,CONTROL="0"_CONTROL
  1. . . 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)
  1. . . . I $P($O(^ICD9("BA",(SEARCH_" "))),".",1)=$P(CONTROL,".",1),+($P($O(^ICD9("BA",(SEARCH_" "))),".",2))=0,+($P(CONTROL,".",2))=0 D Q
  1. . . . . S OK=1,FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code" Q
  1. . . . I $P($O(^ICD0("BA",(SEARCH_" "))),".",1)=$P(CONTROL,".",1),+($P($O(^ICD0("BA",(SEARCH_" "))),".",2))=0,+($P(CONTROL,".",2))=0 D Q
  1. . . . . S OK=1,FI=80.1,DIC="ICD9(",TYPE="ICD-9-CM procedure code" Q
  1. . . . S SEARCH="0"_SEARCH,CONTROL="0"_CONTROL
  1. . S:TYPE="" FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code"
  1. I +X=0 D Q (FI_"^"_DIC_"^"_TYPE)
  1. . I $L($P(X,".",1))>4,X'["." S FI=81,DIC="ICPT(",TYPE="HCPCS procedure code" Q
  1. . I X["-" S FI=81,DIC="ICPT(",TYPE="HCPCS procedure code" Q
  1. . I $E(X,1)="E",X["." S FI=80,DIC="ICD9(",TYPE="ICD-9-CM ""E"" code (external causes)" Q
  1. . 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
  1. . I $E(X,1)="V",X["." S FI=80,DIC="ICD9(",TYPE="ICD-9-CM ""V"" code (health factors)" Q
  1. . 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
  1. . S FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code"
  1. Q "80^ICD9(^ICD-9-CM diagnostic code"
  1. TYPE(X,Y) ; Code type
  1. ;
  1. ; Requires:
  1. ;
  1. ; X in the form of a classification code
  1. ; Y file number or global root
  1. ;
  1. ; Returns:
  1. ;
  1. ; <type> free text string description of code type
  1. ;
  1. ; ICD-9-CM diagnosis
  1. ; ICD-9-CM "E" external causes
  1. ; ICD-9-CM "V" health factors
  1. ; ICD-9-CM procedures
  1. ; CPT-4 procedures
  1. ; HCPCS procedures
  1. ;
  1. 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"
  1. 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"
  1. S:+CO>0&(FI=81!(FI["ICPT")) TYPE="CPT-4 procedures" S:+CO=0&(FI=81!(FI["ICPT")) TYPE="HCPCS procedures"
  1. S X=TYPE Q X
  1. NEXT(X,FILE) ; Next code in file
  1. ;
  1. ; Requires:
  1. ;
  1. ; X in the form of a classification code
  1. ; FILE file number
  1. ;
  1. ; Returns:
  1. ;
  1. ; <code> Next code found in file
  1. ;
  1. N NCODE,NEXT S FILE=+($G(FILE)),X=$$TRIM($G(X)) Q:X="" ""
  1. I FILE=80 D Q X
  1. . Q:$D(^ICD9("BA",X_" ")) S NEXT=$$TRIM($O(^ICD9("BA",(X_" ")))) I $E(NEXT,1,$L(X))=X S X=NEXT Q
  1. . S:$E(NEXT,1,$L(X))'=X X=""
  1. I FILE=80.1 D Q X
  1. . Q:$D(^ICD0("BA",X_" ")) S NEXT=$$TRIM($O(^ICD0("BA",(X_" ")))) I $E(NEXT,1,$L(X))=X S X=NEXT Q
  1. . S:$E(NEXT,1,$L(X))'=X X=""
  1. I FILE=81 D Q X
  1. . S NCODE=X I +NCODE>0,$E(NCODE,1)'="0",$L(NCODE)<5 F Q:$L(NCODE)=5 S NCODE="0"_NCODE
  1. . 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
  1. . S:$E(NEXT,1,$L(X))'=X X=""
  1. Q X
  1. TRIM(X) ; Trim leading/trailing spaces
  1. S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
  1. F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
  1. Q X