- 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
