PXRMVAL ; SLC/KER - Validate Codes (ICD/ICP/CPT main) ; 05/16/2000
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
; This routine checks both the format of a classification code
; (pattern matching) and the value of a classification code
; provided by a user. Both the format and the value of the
; users input must be valid for this routine to return a "true"
; condition (1). If either the format or the value is not valid
; this routine will return a false condition (0) and the reason
; (error) the code was not found to be valid.
;
; Entry Points
;
; EN^PXRMVAL Standard Lookup
; ============================================================
;
; Optional input:
;
; X classification code (ICD/CPT)
;
; DIC global root/#
;
; If X equals then DIC should be set to
; ------------------------------------------
; ICD diagnosis ^ICD9( or 80
; ICD procedure ^ICD0( or 80.1
; CPT procedure ^ICPT( or 81
;
;
;
; $$CODE^PXRMVAL(<code>,<file>) Extrinsic Function
; ============================================================
;
; Mandatory input:
;
; <code> classification code (ICD/CPT), may be null
;
; <file> file number or global root
;
; If X equals then DIC should be set to
; ------------------------------------------
; ICD diagnosis ^ICD9( or 80
; ICD procedure ^ICD0( or 80.1
; CPT procedure ^ICPT( or 81
; HCPCS procedure ^ICPT( or 81
;
;
;
; EN^PXRMVAL returns the variable Y and
; $$CODE^PXRMVAL returns a value in the
; form of:
;
; <validity>^<input code>^<output code>^<error>^<file>^
; <root>^<type>^<input IEN>^<input inactive flag>^
; <output IEN>^<output inactive flag>^<description>
;
; 1 Validity 1=valid 0=invalid
; 2 Input code Code entered by user (input)
; 3 Output code Code (after transformation, output)
; 4 Error Error text
; 5 File # File number used to check code
; 6 Root Global root (location)
; 7 Type Type of code checked (ICD, CPT)
; 8 Input IEN Entry number of input code
; 9 Input flag ""=active 1=inactive
; 10 Output IEN Entry number of output code
; 11 Output flag ""=active 1=inactive
; 12 Name Descriptive name of Coded entry
;
;
; If X (code) or DIC (file) do not exist, then the user will be
; prompted for the missing data.
;
EN ; Validate a code format (ICD or CPT)
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"
; Quit if no code provided
S:'$L(X) (OX,X)=$$SO I '$L(X) S Y="0^"_OX_"^"_X_"^No ICD/CPT code provided" Q
; Quit if no file provided
I $G(DIC)="" S DIC=$G(FI) D FD I '$L(DIC) S DIC=$$FI(OX) D FD
I '$L(DIC)!(DIC="^")!(DIC="^^") S Y="0^"_OX_"^"_X_"^No classification code file provided (DIC)" Q
; Quit if no file found
S TY=$$TYPE^PXRMVALU(X,DIC),FI=$G(@(DIC_"0)")) I '$L(FI) S Y="0^"_OX_"^"_X_"^No "_TY_" file found^^^" Q
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
; Validate code
S Y=$$VAL(FI,X) Q
;
CODE(X,DIC) ; Extrinsic Function to check code format and value
S X=$G(X),DIC=$G(DIC) N Y D EN S X=Y Q X
;
VAL(X,Y) ; Validate code
N FILENUM,CODE S FILENUM=$G(X),CODE=$G(Y)
Q:+($G(FILENUM))=80 $$ICD^PXRMVALC(CODE)
Q:+($G(FILENUM))=80.1 $$ICP^PXRMVALC(CODE)
Q:+($G(FILENUM))=81 $$CPT^PXRMVALC(CODE)
Q "0^"_CODE_"^"_CODE_"^Unidentified code type"
;
SO(X) ; Prompt user for source code (CODE)
N DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT
S X=$G(X),DIR(0)="FAO^3:7"
S DIR("A")="Enter a classification code: "
S:$L(X)>4&($L(X)<8) DIR("B")=X
D ^DIR S X=Y S:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) X=""
Q X
;
FI(SO) ; Prompt user for file (FI,DIC)
N DIC,DO,DLAYGO,DINUM,X,Y,DTOUT,DUOUT,FILEDEF,FILENM
S SO=$G(SO) S FILEDEF="" S:$L(SO) FILEDEF=$$FILE^PXRMVALU(SO)
S FILENM=$$FN(+FILEDEF),FILEDEF=$S($L(FILENM):FILENM,1:"")
S:$L(FILEDEF) DIC("B")=FILEDEF S DIC("A")="Enter classification code file: "
S:$L($G(SO)) DIC("A")="Enter classification file for code """_SO_""": "
S DIC("S")="I +Y=80!(+Y=80.1)!(+Y=81)"
S DIC="^DIC(",DIC(0)="AEMQ" D ^DIC S SO=+($G(Y)) S:SO'>0 SO="" Q SO
;
FD ; File and file root based on DIC
S:'$L(DIC) (FI,DIC)="" Q:'$L(DIC)
I $L($$GL(+DIC)),+($$DD(+DIC))>0 D Q
. S FI=+DIC,DIC=$$GL(+DIC) S:FI'=80&(FI'=80.1)&(FI'=81) (FI,DIC)=""
I $E(DIC,1)="^",$L($P(DIC,"^",2)),$P(DIC,"^",2)["(",$L(DIC,"^")=2,$D(@(DIC_"0)")) D Q
. S FI=+($P($G(@(DIC_"0)")),"^",2)) S:FI'=80&(FI'=80.1)&(FI'=81) (FI,DIC)=""
S (FI,DIC)="" Q
DD(X) ; DD Exist? (DBIA #2052)
N PXRMF S X=+($G(X)) Q:X=0 ""
D FIELD^DID(X,.01,"N","LABEL","PXRMF") S X=$S($L($G(PXRMF("LABEL"))):1,1:0) Q X
GL(X) ; Global Location (DBIA #2052)
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
FN(X) ; File Name (DBIA #2052)
N PXRMF S X=+($G(X)) Q:X=0 "" D FILE^DID(X,"N","NAME","PXRMF") S X=$G(PXRMF("NAME")) Q X
PXRMVAL ; SLC/KER - Validate Codes (ICD/ICP/CPT main) ; 05/16/2000
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 ;
+3 ; This routine checks both the format of a classification code
+4 ; (pattern matching) and the value of a classification code
+5 ; provided by a user. Both the format and the value of the
+6 ; users input must be valid for this routine to return a "true"
+7 ; condition (1). If either the format or the value is not valid
+8 ; this routine will return a false condition (0) and the reason
+9 ; (error) the code was not found to be valid.
+10 ;
+11 ; Entry Points
+12 ;
+13 ; EN^PXRMVAL Standard Lookup
+14 ; ============================================================
+15 ;
+16 ; Optional input:
+17 ;
+18 ; X classification code (ICD/CPT)
+19 ;
+20 ; DIC global root/#
+21 ;
+22 ; If X equals then DIC should be set to
+23 ; ------------------------------------------
+24 ; ICD diagnosis ^ICD9( or 80
+25 ; ICD procedure ^ICD0( or 80.1
+26 ; CPT procedure ^ICPT( or 81
+27 ;
+28 ;
+29 ;
+30 ; $$CODE^PXRMVAL(<code>,<file>) Extrinsic Function
+31 ; ============================================================
+32 ;
+33 ; Mandatory input:
+34 ;
+35 ; <code> classification code (ICD/CPT), may be null
+36 ;
+37 ; <file> file number or global root
+38 ;
+39 ; If X equals then DIC should be set to
+40 ; ------------------------------------------
+41 ; ICD diagnosis ^ICD9( or 80
+42 ; ICD procedure ^ICD0( or 80.1
+43 ; CPT procedure ^ICPT( or 81
+44 ; HCPCS procedure ^ICPT( or 81
+45 ;
+46 ;
+47 ;
+48 ; EN^PXRMVAL returns the variable Y and
+49 ; $$CODE^PXRMVAL returns a value in the
+50 ; form of:
+51 ;
+52 ; <validity>^<input code>^<output code>^<error>^<file>^
+53 ; <root>^<type>^<input IEN>^<input inactive flag>^
+54 ; <output IEN>^<output inactive flag>^<description>
+55 ;
+56 ; 1 Validity 1=valid 0=invalid
+57 ; 2 Input code Code entered by user (input)
+58 ; 3 Output code Code (after transformation, output)
+59 ; 4 Error Error text
+60 ; 5 File # File number used to check code
+61 ; 6 Root Global root (location)
+62 ; 7 Type Type of code checked (ICD, CPT)
+63 ; 8 Input IEN Entry number of input code
+64 ; 9 Input flag ""=active 1=inactive
+65 ; 10 Output IEN Entry number of output code
+66 ; 11 Output flag ""=active 1=inactive
+67 ; 12 Name Descriptive name of Coded entry
+68 ;
+69 ;
+70 ; If X (code) or DIC (file) do not exist, then the user will be
+71 ; prompted for the missing data.
+72 ;
EN ; Validate a code format (ICD or CPT)
+1 KILL Y
NEW FI,TY,OX
SET FI=$GET(DIC)
SET (OX,X)=$GET(X)
NEW DIC
SET DIC=$GET(FI)
DO FD
SET Y="0^"_OX_"^"_X_"^Unknown error"
+2 ; Quit if no code provided
+3 IF '$LENGTH(X)
SET (OX,X)=$$SO
IF '$LENGTH(X)
SET Y="0^"_OX_"^"_X_"^No ICD/CPT code provided"
QUIT
+4 ; Quit if no file provided
+5 IF $GET(DIC)=""
SET DIC=$GET(FI)
DO FD
IF '$LENGTH(DIC)
SET DIC=$$FI(OX)
DO FD
+6 IF '$LENGTH(DIC)!(DIC="^")!(DIC="^^")
SET Y="0^"_OX_"^"_X_"^No classification code file provided (DIC)"
QUIT
+7 ; Quit if no file found
+8 SET TY=$$TYPE^PXRMVALU(X,DIC)
SET FI=$GET(@(DIC_"0)"))
IF '$LENGTH(FI)
SET Y="0^"_OX_"^"_X_"^No "_TY_" file found^^^"
QUIT
+9 SET FI=$SELECT(DIC["ICD9":80,DIC["ICD0":80.1,DIC["ICPT":81,1:0)
IF FI=0
SET Y="0^"_OX_"^"_X_"^No "_TY_" file found^^^"
QUIT
+10 ; Validate code
+11 SET Y=$$VAL(FI,X)
QUIT
+12 ;
CODE(X,DIC) ; Extrinsic Function to check code format and value
+1 SET X=$GET(X)
SET DIC=$GET(DIC)
NEW Y
DO EN
SET X=Y
QUIT X
+2 ;
VAL(X,Y) ; Validate code
+1 NEW FILENUM,CODE
SET FILENUM=$GET(X)
SET CODE=$GET(Y)
+2 IF +($GET(FILENUM))=80
QUIT $$ICD^PXRMVALC(CODE)
+3 IF +($GET(FILENUM))=80.1
QUIT $$ICP^PXRMVALC(CODE)
+4 IF +($GET(FILENUM))=81
QUIT $$CPT^PXRMVALC(CODE)
+5 QUIT "0^"_CODE_"^"_CODE_"^Unidentified code type"
+6 ;
SO(X) ; Prompt user for source code (CODE)
+1 NEW DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET X=$GET(X)
SET DIR(0)="FAO^3:7"
+3 SET DIR("A")="Enter a classification code: "
+4 IF $LENGTH(X)>4&($LENGTH(X)<8)
SET DIR("B")=X
+5 DO ^DIR
SET X=Y
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
SET X=""
+6 QUIT X
+7 ;
FI(SO) ; Prompt user for file (FI,DIC)
+1 NEW DIC,DO,DLAYGO,DINUM,X,Y,DTOUT,DUOUT,FILEDEF,FILENM
+2 SET SO=$GET(SO)
SET FILEDEF=""
IF $LENGTH(SO)
SET FILEDEF=$$FILE^PXRMVALU(SO)
+3 SET FILENM=$$FN(+FILEDEF)
SET FILEDEF=$SELECT($LENGTH(FILENM):FILENM,1:"")
+4 IF $LENGTH(FILEDEF)
SET DIC("B")=FILEDEF
SET DIC("A")="Enter classification code file: "
+5 IF $LENGTH($GET(SO))
SET DIC("A")="Enter classification file for code """_SO_""": "
+6 SET DIC("S")="I +Y=80!(+Y=80.1)!(+Y=81)"
+7 SET DIC="^DIC("
SET DIC(0)="AEMQ"
DO ^DIC
SET SO=+($GET(Y))
IF SO'>0
SET SO=""
QUIT SO
+8 ;
FD ; File and file root based on DIC
+1 IF '$LENGTH(DIC)
SET (FI,DIC)=""
IF '$LENGTH(DIC)
QUIT
+2 IF $LENGTH($$GL(+DIC))
IF +($$DD(+DIC))>0
Begin DoDot:1
+3 SET FI=+DIC
SET DIC=$$GL(+DIC)
IF FI'=80&(FI'=80.1)&(FI'=81)
SET (FI,DIC)=""
End DoDot:1
QUIT
+4 IF $EXTRACT(DIC,1)="^"
IF $LENGTH($PIECE(DIC,"^",2))
IF $PIECE(DIC,"^",2)["("
IF $LENGTH(DIC,"^")=2
IF $DATA(@(DIC_"0)"))
Begin DoDot:1
+5 SET FI=+($PIECE($GET(@(DIC_"0)")),"^",2))
IF FI'=80&(FI'=80.1)&(FI'=81)
SET (FI,DIC)=""
End DoDot:1
QUIT
+6 SET (FI,DIC)=""
QUIT
DD(X) ; DD Exist? (DBIA #2052)
+1 NEW PXRMF
SET X=+($GET(X))
IF X=0
QUIT ""
+2 DO FIELD^DID(X,.01,"N","LABEL","PXRMF")
SET X=$SELECT($LENGTH($GET(PXRMF("LABEL"))):1,1:0)
QUIT X
GL(X) ; Global Location (DBIA #2052)
+1 NEW PXRMF
SET X=+($GET(X))
IF X=0
QUIT ""
DO FILE^DID(X,"N","GLOBAL NAME","PXRMF")
SET X=$GET(PXRMF("GLOBAL NAME"))
QUIT X
FN(X) ; File Name (DBIA #2052)
+1 NEW PXRMF
SET X=+($GET(X))
IF X=0
QUIT ""
DO FILE^DID(X,"N","NAME","PXRMF")
SET X=$GET(PXRMF("NAME"))
QUIT X
