source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMVAL.m@ 1806

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

initial load of WorldVistAEHR
File size: 5.4 KB
RevLine 
[613]1PXRMVAL ; SLC/KER - Validate Codes (ICD/ICP/CPT main) ; 05/16/2000
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;
4 ; This routine checks both the format of a classification code
5 ; (pattern matching) and the value of a classification code
6 ; provided by a user. Both the format and the value of the
7 ; users input must be valid for this routine to return a "true"
8 ; condition (1). If either the format or the value is not valid
9 ; this routine will return a false condition (0) and the reason
10 ; (error) the code was not found to be valid.
11 ;
12 ; Entry Points
13 ;
14 ; EN^PXRMVAL Standard Lookup
15 ; ============================================================
16 ;
17 ; Optional input:
18 ;
19 ; X classification code (ICD/CPT)
20 ;
21 ; DIC global root/#
22 ;
23 ; If X equals then DIC should be set to
24 ; ------------------------------------------
25 ; ICD diagnosis ^ICD9( or 80
26 ; ICD procedure ^ICD0( or 80.1
27 ; CPT procedure ^ICPT( or 81
28 ;
29 ;
30 ;
31 ; $$CODE^PXRMVAL(<code>,<file>) Extrinsic Function
32 ; ============================================================
33 ;
34 ; Mandatory input:
35 ;
36 ; <code> classification code (ICD/CPT), may be null
37 ;
38 ; <file> file number or global root
39 ;
40 ; If X equals then DIC should be set to
41 ; ------------------------------------------
42 ; ICD diagnosis ^ICD9( or 80
43 ; ICD procedure ^ICD0( or 80.1
44 ; CPT procedure ^ICPT( or 81
45 ; HCPCS procedure ^ICPT( or 81
46 ;
47 ;
48 ;
49 ; EN^PXRMVAL returns the variable Y and
50 ; $$CODE^PXRMVAL returns a value in the
51 ; form of:
52 ;
53 ; <validity>^<input code>^<output code>^<error>^<file>^
54 ; <root>^<type>^<input IEN>^<input inactive flag>^
55 ; <output IEN>^<output inactive flag>^<description>
56 ;
57 ; 1 Validity 1=valid 0=invalid
58 ; 2 Input code Code entered by user (input)
59 ; 3 Output code Code (after transformation, output)
60 ; 4 Error Error text
61 ; 5 File # File number used to check code
62 ; 6 Root Global root (location)
63 ; 7 Type Type of code checked (ICD, CPT)
64 ; 8 Input IEN Entry number of input code
65 ; 9 Input flag ""=active 1=inactive
66 ; 10 Output IEN Entry number of output code
67 ; 11 Output flag ""=active 1=inactive
68 ; 12 Name Descriptive name of Coded entry
69 ;
70 ;
71 ; If X (code) or DIC (file) do not exist, then the user will be
72 ; prompted for the missing data.
73 ;
74EN ; Validate a code format (ICD or CPT)
75 K Y N FI,TY,OX S FI=$G(DIC) S (OX,X)=$G(X) N DIC S DIC=$G(FI) D FD S Y="0^"_OX_"^"_X_"^Unknown error"
76 ; Quit if no code provided
77 S:'$L(X) (OX,X)=$$SO I '$L(X) S Y="0^"_OX_"^"_X_"^No ICD/CPT code provided" Q
78 ; Quit if no file provided
79 I $G(DIC)="" S DIC=$G(FI) D FD I '$L(DIC) S DIC=$$FI(OX) D FD
80 I '$L(DIC)!(DIC="^")!(DIC="^^") S Y="0^"_OX_"^"_X_"^No classification code file provided (DIC)" Q
81 ; Quit if no file found
82 S TY=$$TYPE^PXRMVALU(X,DIC),FI=$G(@(DIC_"0)")) I '$L(FI) S Y="0^"_OX_"^"_X_"^No "_TY_" file found^^^" Q
83 S FI=$S(DIC["ICD9":80,DIC["ICD0":80.1,DIC["ICPT":81,1:0) I FI=0 S Y="0^"_OX_"^"_X_"^No "_TY_" file found^^^" Q
84 ; Validate code
85 S Y=$$VAL(FI,X) Q
86 ;
87CODE(X,DIC) ; Extrinsic Function to check code format and value
88 S X=$G(X),DIC=$G(DIC) N Y D EN S X=Y Q X
89 ;
90VAL(X,Y) ; Validate code
91 N FILENUM,CODE S FILENUM=$G(X),CODE=$G(Y)
92 Q:+($G(FILENUM))=80 $$ICD^PXRMVALC(CODE)
93 Q:+($G(FILENUM))=80.1 $$ICP^PXRMVALC(CODE)
94 Q:+($G(FILENUM))=81 $$CPT^PXRMVALC(CODE)
95 Q "0^"_CODE_"^"_CODE_"^Unidentified code type"
96 ;
97SO(X) ; Prompt user for source code (CODE)
98 N DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT
99 S X=$G(X),DIR(0)="FAO^3:7"
100 S DIR("A")="Enter a classification code: "
101 S:$L(X)>4&($L(X)<8) DIR("B")=X
102 D ^DIR S X=Y S:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) X=""
103 Q X
104 ;
105FI(SO) ; Prompt user for file (FI,DIC)
106 N DIC,DO,DLAYGO,DINUM,X,Y,DTOUT,DUOUT,FILEDEF,FILENM
107 S SO=$G(SO) S FILEDEF="" S:$L(SO) FILEDEF=$$FILE^PXRMVALU(SO)
108 S FILENM=$$FN(+FILEDEF),FILEDEF=$S($L(FILENM):FILENM,1:"")
109 S:$L(FILEDEF) DIC("B")=FILEDEF S DIC("A")="Enter classification code file: "
110 S:$L($G(SO)) DIC("A")="Enter classification file for code """_SO_""": "
111 S DIC("S")="I +Y=80!(+Y=80.1)!(+Y=81)"
112 S DIC="^DIC(",DIC(0)="AEMQ" D ^DIC S SO=+($G(Y)) S:SO'>0 SO="" Q SO
113 ;
114FD ; File and file root based on DIC
115 S:'$L(DIC) (FI,DIC)="" Q:'$L(DIC)
116 I $L($$GL(+DIC)),+($$DD(+DIC))>0 D Q
117 . S FI=+DIC,DIC=$$GL(+DIC) S:FI'=80&(FI'=80.1)&(FI'=81) (FI,DIC)=""
118 I $E(DIC,1)="^",$L($P(DIC,"^",2)),$P(DIC,"^",2)["(",$L(DIC,"^")=2,$D(@(DIC_"0)")) D Q
119 . S FI=+($P($G(@(DIC_"0)")),"^",2)) S:FI'=80&(FI'=80.1)&(FI'=81) (FI,DIC)=""
120 S (FI,DIC)="" Q
121DD(X) ; DD Exist? (DBIA #2052)
122 N PXRMF S X=+($G(X)) Q:X=0 ""
123 D FIELD^DID(X,.01,"N","LABEL","PXRMF") S X=$S($L($G(PXRMF("LABEL"))):1,1:0) Q X
124GL(X) ; Global Location (DBIA #2052)
125 N PXRMF S X=+($G(X)) Q:X=0 "" D FILE^DID(X,"N","GLOBAL NAME","PXRMF") S X=$G(PXRMF("GLOBAL NAME")) Q X
126FN(X) ; File Name (DBIA #2052)
127 N PXRMF S X=+($G(X)) Q:X=0 "" D FILE^DID(X,"N","NAME","PXRMF") S X=$G(PXRMF("NAME")) Q X
Note: See TracBrowser for help on using the repository browser.