source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMVALU.m@ 789

Last change on this file since 789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1PXRMVALU ; SLC/KER - Validate Codes (utility) ; 05/16/2000
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;
4 Q
5FILE(X) ; Get File
6 ;
7 ; Requires:
8 ;
9 ; X in the form of a classification code
10 ;
11 ; Returns:
12 ;
13 ; <file #>^<DIC>^<code type>
14 ;
15 S X=$G(X) Q:'$L(X) "80^ICD9(^ICD-9-CM diagnostic code"
16 N FI,DIC,TYPE S (FI,DIC,TYPE)=""
17 I +X>0 D Q (FI_"^"_DIC_"^"_TYPE)
18 . I $L($P(X,".",1))>3,X'["." S FI=81,DIC="ICPT(",TYPE="CPT-4 procedure code" Q
19 . I $L($P(X,".",1))>2 S FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code" Q
20 . I $L($P(X,".",1))'>2 D
21 . . N I,OK,SEARCH,CONTROL S SEARCH=$E(X,1,($L(X)-1))_$C($A($E(X,$L(X)))-1)_"~",CONTROL=X
22 . . S OK=0 F I=1:1 D Q:OK=1!($L($P(SEARCH,".",1))>3)
23 . . . I $O(^ICD9("BA",(SEARCH_" ")))=(CONTROL_" ") D Q
24 . . . . S OK=1,FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code" Q
25 . . . I $O(^ICD0("BA",(SEARCH_" ")))=(CONTROL_" ") D Q
26 . . . . S OK=1,FI=80.1,DIC="ICD9(",TYPE="ICD-9-CM procedure code" Q
27 . . . S SEARCH="0"_SEARCH,CONTROL="0"_CONTROL
28 . . 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)
29 . . . I $P($O(^ICD9("BA",(SEARCH_" "))),".",1)=$P(CONTROL,".",1),+($P($O(^ICD9("BA",(SEARCH_" "))),".",2))=0,+($P(CONTROL,".",2))=0 D Q
30 . . . . S OK=1,FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code" Q
31 . . . I $P($O(^ICD0("BA",(SEARCH_" "))),".",1)=$P(CONTROL,".",1),+($P($O(^ICD0("BA",(SEARCH_" "))),".",2))=0,+($P(CONTROL,".",2))=0 D Q
32 . . . . S OK=1,FI=80.1,DIC="ICD9(",TYPE="ICD-9-CM procedure code" Q
33 . . . S SEARCH="0"_SEARCH,CONTROL="0"_CONTROL
34 . S:TYPE="" FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code"
35 I +X=0 D Q (FI_"^"_DIC_"^"_TYPE)
36 . I $L($P(X,".",1))>4,X'["." S FI=81,DIC="ICPT(",TYPE="HCPCS procedure code" Q
37 . I X["-" S FI=81,DIC="ICPT(",TYPE="HCPCS procedure code" Q
38 . I $E(X,1)="E",X["." S FI=80,DIC="ICD9(",TYPE="ICD-9-CM ""E"" code (external causes)" Q
39 . 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
40 . I $E(X,1)="V",X["." S FI=80,DIC="ICD9(",TYPE="ICD-9-CM ""V"" code (health factors)" Q
41 . 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
42 . S FI=80,DIC="ICD9(",TYPE="ICD-9-CM diagnosis code"
43 Q "80^ICD9(^ICD-9-CM diagnostic code"
44TYPE(X,Y) ; Code type
45 ;
46 ; Requires:
47 ;
48 ; X in the form of a classification code
49 ; Y file number or global root
50 ;
51 ; Returns:
52 ;
53 ; <type> free text string description of code type
54 ;
55 ; ICD-9-CM diagnosis
56 ; ICD-9-CM "E" external causes
57 ; ICD-9-CM "V" health factors
58 ; ICD-9-CM procedures
59 ; CPT-4 procedures
60 ; HCPCS procedures
61 ;
62 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"
63 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"
64 S:+CO>0&(FI=81!(FI["ICPT")) TYPE="CPT-4 procedures" S:+CO=0&(FI=81!(FI["ICPT")) TYPE="HCPCS procedures"
65 S X=TYPE Q X
66NEXT(X,FILE) ; Next code in file
67 ;
68 ; Requires:
69 ;
70 ; X in the form of a classification code
71 ; FILE file number
72 ;
73 ; Returns:
74 ;
75 ; <code> Next code found in file
76 ;
77 N NCODE,NEXT S FILE=+($G(FILE)),X=$$TRIM($G(X)) Q:X="" ""
78 I FILE=80 D Q X
79 . Q:$D(^ICD9("BA",X_" ")) S NEXT=$$TRIM($O(^ICD9("BA",(X_" ")))) I $E(NEXT,1,$L(X))=X S X=NEXT Q
80 . S:$E(NEXT,1,$L(X))'=X X=""
81 I FILE=80.1 D Q X
82 . Q:$D(^ICD0("BA",X_" ")) S NEXT=$$TRIM($O(^ICD0("BA",(X_" ")))) I $E(NEXT,1,$L(X))=X S X=NEXT Q
83 . S:$E(NEXT,1,$L(X))'=X X=""
84 I FILE=81 D Q X
85 . S NCODE=X I +NCODE>0,$E(NCODE,1)'="0",$L(NCODE)<5 F Q:$L(NCODE)=5 S NCODE="0"_NCODE
86 . 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
87 . S:$E(NEXT,1,$L(X))'=X X=""
88 Q X
89TRIM(X) ; Trim leading/trailing spaces
90 S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
91 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
92 Q X
Note: See TracBrowser for help on using the repository browser.