ICDEXA3 ;SLC/KER - ICD Extractor - APIs/Utilities (cont) ;12/19/2014
;;18.0;DRG Grouper;**57,67**;Oct 20, 2000;Build 1
;
; Global Variables
; ^ICDS( N/A
; ^ICDS("F") N/A
;
; External References
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
; ^DIR ICR 10026
;
OBA(FILE,CODE,SYS,REV) ; Replace $Order for "ABA" and "BA" indexes
;
; Input:
;
; CODE = ICD Code, can be null
; FILE File Number 80 or 80.1
; SYS Coding System (internal, file 80.4)
; REV Reverse $Order if set to 1
;
; Output:
;
; $$OBA Next or Previous Code
;
; This API replaces the need to access the BA Index
; in a FOR loop.
;
; $$OBA(<file>,<code>,<system>) replaces:
;
; $O(^ICD9("BA",(<code>_" ")) and
; $O(^ICD0("BA",(<code>_" "))
;
; F S CODE=$$OBA^ICDEX(80,CODE,1) Q:'$L(CODE) D
; F S CODE=$$OBA^ICDEX(80,CODE,30) Q:'$L(CODE) D
; F S CODE=$$OBA^ICDEX(80.1,CODE,2) Q:'$L(CODE) D
; F S CODE=$$OBA^ICDEX(80.1,CODE,31) Q:'$L(CODE) D
;
; Retire IA 5388, 5404
;
N ICDC,ICDG,ICDF,ICDI,ICDID,ICDR,ICDU,ICDS,ICDO,ICDN,ICDX,ICDD
S ICDC=$TR($G(CODE)," ",""),ICDU=$$UP^XLFSTR(ICDC) S ICDS=$G(SYS)
S ICDF=$G(FILE) Q:"^80^80.1^"'[("^"_ICDF_"^") ""
I $L(ICDS) S ICDS=$$SYS^ICDEX(ICDS) Q:+ICDS'>0 ""
S ICDR=$$ROOT^ICDEX(ICDF) Q:'$L(ICDR) "" S ICDD=+($G(REV))
I +ICDS>0 D Q ICDO
. N ICDX,ICDN,ICDI S ICDX="ABA"
. I ICDD'>0 D
. . N ICD1,ICD2
. . S ICD1=$TR($O(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDC_" ")_""")"))," ","")
. . S ICD2=$TR($O(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDU_" ")_""")"))," ","")
. . S:ICD1]ICD2!(ICD1=ICD2) ICDN=ICD2 S:ICD2]ICD1 ICDN=ICD1
. S:ICDD>0&('$L(ICDC)) ICDC="~"
. I ICDD>0 D
. . N ICD1,ICD2
. . S ICD1=$TR($O(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDC_" ")_""")"),-1)," ","")
. . S ICD2=$TR($O(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDU_" ")_""")"),-1)," ","")
. . S:ICD1]ICD2!(ICD1=ICD2) ICDN=ICD2 S:ICD2]ICD1 ICDN=ICD1
. S ICDI=$$CODEABA^ICDEX(ICDN,ICDR,ICDS)
. S ICDO=ICDN S:'$L(ICDN)!(+ICDI'>0) ICDO=""
I '$L(ICDS) D Q ICDO
. N ICDX,ICDN,ICDI S ICDX="BA"
. I +ICDD'>0 D
. . N ICD1,ICD2
. . S ICD1=$TR($O(@(ICDR_""""_ICDX_""","""_(ICDC_" ")_""")"))," ","")
. . S ICD2=$TR($O(@(ICDR_""""_ICDX_""","""_(ICDU_" ")_""")"))," ","")
. . S:ICD1]ICD2!(ICD1=ICD2) ICDN=ICD2 S:ICD2]ICD1 ICDN=ICD1
. S:ICDD>0&('$L(ICDC)) ICDC="~"
. I +ICDD>0 D
. . N ICD1,ICD2
. . S ICD1=$TR($O(@(ICDR_""""_ICDX_""","""_(ICDC_" ")_""")"),-1)," ","")
. . S ICD2=$TR($O(@(ICDR_""""_ICDX_""","""_(ICDU_" ")_""")"),-1)," ","")
. . S:ICD1]ICD2!(ICD1=ICD2) ICDN=ICD2 S:ICD2]ICD1 ICDN=ICD1
. S ICDI=$$CODEBA^ICDEX(ICDN,ICDR)
. S ICDO=ICDN S:'$L(ICDN)!(+ICDI'>0) ICDO=""
Q ""
OD(FILE,WORD,SYS,REV) ; Replace $Order on "D" Index
;
; Input:
;
; FILE File Number
; WORD Word, can be null or a 2 piece string
; containing Word and IEN where the word
; is stored
; SYS Coding System (internal)
; Acceptable values can be found on the ASYS
; Index and includes:
;
; File 80
; 1 ICD-9-CM
; 30 ICD-10-CM
;
; File 80.1
; 2 ICD-9 Proc
; 31 ICD-10-PCS
;
; REV Reverse $Order if set to 1
;
; Output:
;
; 2 Piece "^" delimited string
;
; 1 WORD Next or Previous word in D Index
; 2 IEN Internal Entry Number where WORD is found
;
; Retire IA 5388, 5404
;
N ICDW,ICDWI,ICDG,ICDF,ICDI,ICDR,ICDS,ICDO,ICDN,ICDX,ICDD
S ICDW=$$UP^XLFSTR($G(WORD)),ICDWI=+($P(ICDW,"^",2)),ICDW=$P(ICDW,"^",1)
S ICDS=$G(SYS) S ICDF=$G(FILE) Q:"^80^80.1^"'[("^"_ICDF_"^") ""
I $L(ICDS) S ICDS=$$SYS^ICDEX(ICDS) Q:+ICDS'>0 ""
S ICDR=$$ROOT^ICDEX(ICDF) Q:'$L(ICDR) "" S ICDD=+($G(REV))
I +ICDS>0 D Q ICDO
. N ICDX,ICDN,ICDNI,ICDI S ICDX="AD"
. I ICDD'>0 D Q
. . S ICDNI=0 S:$L($G(ICDW)) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"))
. . I ICDNI>0 S ICDO=ICDW_"^"_ICDNI Q
. . S ICDNI="",ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"))
. . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_0_")"))
. . S ICDO=ICDN_"^"_ICDNI
. I ICDD>0 D Q
. . I $L(ICDW) D Q
. . . S ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"),-1)
. . . I ICDNI>0 S ICDO=ICDW_"^"_ICDNI Q
. . . S ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
. . . I '$L(ICDN) S ICDO="" Q
. . . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","" "")"),-1)
. . . I +ICDNI>0 S ICDO=ICDN_"^"_ICDNI Q
. . S ICDW="~",ICDWI=""" """ S ICDNI=""
. . S ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
. . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_ICDWI_")"),-1)
. . S ICDO=ICDN_"^"_ICDNI
I '$L(ICDS) D Q ICDO
. N ICDX,ICDN,ICDNI,ICDI S ICDX="D"
. I +ICDD'>0 D Q
. . S ICDNI=0 S:$L($G(ICDW)) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"))
. . I ICDNI>0 S ICDO=ICDW_"^"_ICDNI Q
. . S ICDNI="",ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"))
. . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_0_")"))
. . S ICDO=ICDN_"^"_ICDNI
. I ICDD>0 D Q
. . I $L(ICDW) D Q
. . . S ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"),-1)
. . . I ICDNI>0 S ICDO=ICDW_"^"_ICDNI Q
. . . S ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
. . . I '$L(ICDN) S ICDO="" Q
. . . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","" "")"),-1)
. . . I +ICDNI>0 S ICDO=ICDN_"^"_ICDNI Q
. . S ICDW="~",ICDWI=""" """ S ICDNI=""
. . S ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
. . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_ICDWI_")"),-1)
. . S ICDO=ICDN_"^"_ICDNI
Q ""
DLM(FILE,IEN,FIELD,CDT) ; Date Last Modified
;
; Input
;
; FILE File Number (required)
; IEN Internal Entry Number (required)
; FIELD Field Number of Versioned Data (optional)
;
; File 80
;
; 10 Sex 5;0
; 11 Age Low 6;0
; 12 Age High 7;0
; 66 Status 66;0
; 67 Diagnosis 67;0
; 68 Description 68;0
; 71 DRG Grouper 3;0
; 72 Major Diagnostic Category 4;0
; 103 Complication/Comorbidity 69;0
;
; File 80.1
;
; 10 Sex 3;0
; 66 Status 66;0
; 67 Operation/Procedure 67;0
; 68 Description 68;0
; 71 DRG Grouper 2;0
;
; If the field is passed, then the date last
; modified (based on date) for the field is
; returned. If the field is not passed, then
; the date last modified (based on date) for
; the record at IEN is returned.
;
; CDT Date to base output on (default is today)
; Business rules apply
;
; Output:
;
; $$DLM Date Last Modified
;
; or -1 ^ message on error
;
N ICD0,ICDA,ICDC,ICDD,ICDE,ICDF,ICDH,ICDI,ICDL,ICDN,ICDNS,ICDO,ICDP,ICDR
S ICDI=$G(IEN) Q:+ICDI'>0 "-1^Invalid IEN"
S ICDF=$G(FILE) Q:"^80^80.1^"'[("^"_ICDF_"^") "-1^Invalid File"
S ICDR=$$ROOT^ICDEX(ICDF) Q:'$L(ICDR) "-1^Invalid File Root"
S ICDC=+($P($G(@(ICDR_+ICDI_",1)")),"^",1))
Q:+ICDC'>0 "-1^Invalid Coding System "_ICDC
Q:'$D(@(ICDR_+ICDI_",0)")) "-1^IEN not found"
S ICDL=$G(FIELD)
S ICDD=$G(CDT) S:ICDD'?7N ICDD=$$DT^XLFDT
S ICDD=$$DTBR^ICDEX($G(ICDD),0,ICDC)
Q:ICDD'?7N "-1^Invalid Date for File"
I '$L(ICDL) D Q ICDO
. N ICDA,ICDNS,ICDP,ICDN,ICDE,ICDH,ICD0,ICDL
. K ICDA S ICDNS="",ICDO="-1^Date Last Modified not found"
. S:ICDF=80 ICDNS="3^4^5^6^7^66^67^68^69" S:ICDF=80.1 ICDNS="2^3^66^67^68" Q:'$L(ICDNS)
. F ICDP=1:1 Q:'$L($P(ICDNS,"^",ICDP)) D
. . S ICDN=$P(ICDNS,"^",ICDP)
. . S ICDE=$O(@(ICDR_+ICDI_","_ICDN_",""B"","_(ICDD+.001)_")"),-1) Q:ICDE'?7N
. . S ICDH=$O(@(ICDR_+ICDI_","_ICDN_",""B"","_ICDE_","" "")"),-1)
. . S ICD0=$G(@(ICDR_+ICDI_","_ICDN_","_ICDH_",0)"))
. . S:$P(ICD0,"^",1)?7N ICDA($P(ICD0,"^",1))=""
. S ICDL=$O(ICDA(" "),-1) S:ICDL?7N ICDO=ICDL K ICDA
S:ICDF=80 ICDN=$S(ICDL=10:5,ICDL=11:6,ICDL=12:7,ICDL=66:66,ICDL=67:67,ICDL=68:68,ICDL=71:3,ICDL=72:4,ICDL=103:69,1:"")
S:ICDF=80.1 ICDN=$S(ICDL=10:3,ICDL=66:66,ICDL=67:67,ICDL=68:68,ICDL=71:2,1:"")
Q:+ICDL'>0!('$L(ICDN)) "-1^Invalid Field"
Q:$O(@(ICDR_+ICDI_","_ICDN_",0)"))'>0 "-1^Field #"_ICDL_" not found for IEN "_ICDI
S ICDE=$O(@(ICDR_+ICDI_","_ICDN_",""B"","_(ICDD+.001)_")"),-1)
Q:ICDE'?7N ("-1^Date Last Modified not found based on "_$$FMTE^XLFDT($G(ICDD),"5DZ"))
S ICDH=$O(@(ICDR_+ICDI_","_ICDN_",""B"","_ICDE_","" "")"),-1)
Q:+ICDH'>0 "-1^Modified Data Not Found"
S ICDO="-1^Modified Data Not Found"
S ICD0=$G(@(ICDR_+ICDI_","_ICDN_","_ICDH_",0)"))
S ICDL=$P(ICD0,"^",1)
S:ICDL?7N ICDO=ICDL
Q ICDO
CS(FILE,FMT,CDT) ; Select Coding System (lookup)
;
; Input
;
; FILE File Number 80 or 80.1 (optional)
; If not provided, you will be prompted
; for the ICD File, there is no default
; value.
;
; FMT Format
;
; E Display External only (default)
; I Display Internal with External for selection
;
; CDT Code Set Date (optional) if not supplied then
; it is not used
; Output
;
; $$CS 2 piece "^" delimited string
;
; 1 Coding System (internal)
; 2 Coding System (external)
;
; or -1 on error or non-selection
; ^^ double up-arrows
; ^ timeout or single up-arrow
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDDIR,ICD0,ICD1,ICD2,ICDA,ICDC,ICDD,ICDE
N ICDIMP,ICDF,ICDI,ICDM,ICDR,ICDT,ICDTMP,ICDO,ICDV,ICDX,X,Y
S ICDIMP=$$IMP^ICDEX(30),ICDD=$S($P($G(CDT),".")?7N:$P($G(CDT),"."),1:"")
S ICDF=$$FIT($G(FILE),1) Q:ICDF["^" ICDF S ICDDIR="Select ICD file number" S:+ICDF'>0 ICDF=$$FI
Q:"^80^80.1^"'[("^"_ICDF_"^") "-1^Invalid File"
S ICDR=$$ROOT^ICDEX(ICDF) Q:'$L(ICDR) "-1^Invalid File"
K ICDA S ICDA(0)=0
I $G(ICDD)?7N D
. N ICDAA,ICDE,ICDI,ICDS S (ICDC,ICDI)=0 F S ICDI=$O(^ICDS("F",ICDF,ICDI)) Q:+ICDI'>0 D
. . S ICDE=$P($G(^ICDS(+ICDI,0)),"^",1) Q:'$L(ICDE)
. . S ICDTMP=$P($G(^ICDS(+ICDI,0)),"^",4) Q:$G(ICDD)?7N&((ICDD+.001)'>ICDTMP)
. . S ICDAA(ICDTMP,ICDI)=ICDI_"^"_ICDE
. S ICDE=$O(ICDAA(" "),-1)
. S ICDI=$O(ICDAA(+ICDE," "),-1)
. S ICDS=$G(ICDAA(+ICDE,+ICDI))
. S:ICDE?7N&(ICDI>0)&($L(ICDS)) ICDC=1,ICDA(ICDC)=ICDS,ICDA(0)=1
I $G(ICDD)'?7N!($O(ICDA(0))'>0) D
. S (ICDC,ICDI)=0 F S ICDI=$O(^ICDS("F",ICDF,ICDI)) Q:+ICDI'>0 D
. . S ICDE=$P($G(^ICDS(+ICDI,0)),"^",1) Q:'$L(ICDE)
. . S ICDTMP=$P($G(^ICDS(+ICDI,0)),"^",4)
. . S ICDC=ICDC+1,ICDA(ICDC)=ICDI_"^"_ICDE,ICDA(0)=ICDC
Q:ICDA(0)=1&($L($G(ICDA(1)))) $G(ICDA(1)) Q:ICDA(0)=1&('$L($G(ICDA(1)))) "-1^Invalid Selection"
S ICDX=$G(FMT) S:ICDX'="I" ICDX="E" S ICDM=$O(ICDA(" "),-1) Q:ICDM'>0 "-1^Invalid Selection"
Q:ICDM=1&($D(ICDA(1))) $G(ICDA(1)) Q:ICDM'>1 "-1^Invalid Selection" S DIR(0)="NAO^1:"_ICDM_":0"
S DIR("A",1)=" Coding System Selection for file "_ICDF,DIR("A",2)=" "
S DIR("A")=" Select Coding System (1-"_ICDM_"): "
S ICDC=0,ICDI=0 F S ICDI=$O(ICDA(ICDI)) Q:+ICDI'>0 D
. N ICD1,ICD2,ICDT S ICD1=$P($G(ICDA(ICDI)),"^",1) Q:ICD1'>0 S ICD2=$P($G(ICDA(ICDI)),"^",2) Q:'$L(ICD2)
. S ICDT=ICD2 S:$G(ICDX)="I" ICDT=ICDT_$J(" ",(15-$L(ICDT)))_"(#"_ICD1_")"
. S ICDC=ICDC+1 S DIR("A",(ICDC+2))=" "_$J(ICDC,2)_" "_ICDT
S:ICDC>1 ICDC=ICDC+1,DIR("A",(ICDC+2))=" " S DIR("PRE")="S:X[""?"" X=""??""",(DIR("?"),DIR("??"))="^D CSH^ICDEXA3"
W ! D ^DIR Q:$D(DIROUT) "^^" Q:$D(DTOUT)!($D(DUOUT)) "^" Q:'$L(Y) "-1^No Coding System Selected" Q:+Y>0&($D(ICDA(+Y))) $G(ICDA(+Y))
Q "-1^Invalid Selection"
CSH ; Select Coding System Help
W:+($G(ICDM))'>1 !,?5,"This response must be a number."
W:+($G(ICDM))>1 !,?5,"This response must be a number from 1 to ",+($G(ICDM)),"."
Q
;
FI(X) ; Select ICD File
;
; Input
;
; X File Number 80 or 80.1 or NULL
;
; Output
;
; $$FI File Number or -1 on error
;
; or -1 on error or non-selection
; ^^ double up-arrows
; ^ timeout or single up-arrow
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICD1,ICD2,ICDA,ICDC,ICDE,ICDF,ICDI,ICDM,ICDR,ICDT,Y
S X=$G(X),ICDO=$$FIT(X,1) Q:"^80^80.1^"[("^"_ICDO_"^") ICDO S ICD0=""
S DIR("A")=" Select ICD file: " S ICDDIR=$$TRIM($G(ICDDIR))
S DIR("A",1)=" ICD file" S:$L($G(ICDDIR)) DIR("A",1)=" "_$G(ICDDIR) K ICDDIR
S DIR("A",2)=" "
S DIR("A",3)=" 1 ICD Diagnosis file #80 ^ICD9("
S DIR("A",4)=" 2 ICD Operations/Procedures file #80.1 ^ICD0("
S DIR("A",5)=" "
S DIR(0)="NAO^1:2:0"
S DIR("PRE")="S X=$$FIT^ICDEXA3(X)",(DIR("?"),DIR("??"))="^D FIH^ICDEXA3"
D ^DIR Q:'$L($G(X)) "-1^No Selection" Q:$D(DIROUT) "^^" Q:$D(DTOUT)!($D(DUOUT)) "^"
S ICDO=$$FIT(Y,1) S X="-1^Invalid File Selection"
S:"^80^80.1^"[("^"_ICDO_"^") X=ICDO
Q X
FIH ; File Help
W !,?5,"This response must be a number from 1 to 2."
Q
DP(X) ; Select Diagnosis or Procedure
;
; Input
;
; X Date
;
; Output
;
; $$DP Coding System based on Date or -1 on error
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICCD,ICDCS,ICDIMP,ICD1,ICD2,ICDA,ICDC,ICDE,ICDF,ICDI,ICDM,ICDR,ICDT,ICDTY,Y
S ICDD=$P($G(X),".",1),ICD0="",ICDIMP=$$IMP^ICDEX(30),ICDTY="",ICDCS="" S:ICDD'?7N ICDD=$$DT^XLFDT
F ICDI=0 F S ICDI=$O(^ICDS("F",80,ICDI)) Q:+ICDI'>0 D
. N ICDS,ICDSD S ICDS=$G(^ICDS(ICDI,0)),ICDSD=$P(ICDS,"^",4) Q:ICDSD'?7N
. S:ICDSD<(ICDD+.0001) ICDTY=$P($P(ICDS,"^",1)," ",1) S:$L(ICDTY,"-")=2 ICDTY=$P(ICDTY,"-",1,2)
S:'$L(ICDTY) ICDTY="ICD" S DIR("A")=" Select ICD Code Type: " S ICDDIR=$$TRIM($G(ICDDIR))
S DIR("A",1)=" Select one of the following:"
S:$L($G(ICDDIR)) DIR("A",1)=" "_$G(ICDDIR) K ICDDIR
S DIR("A",2)=" "
S DIR("A",3)=" 1 "_ICDTY_" Diagnosis Code"
S DIR("A",4)=" 2 "_ICDTY_" Operations/Procedures Code"
S DIR("A",5)=" "
S DIR(0)="NAO^1:2:0"
S DIR("PRE")="S:X[""?"" X=""??""",(DIR("?"),DIR("??"))="^D DPH^ICDEXA3"
D ^DIR Q:'$L($G(X)) "-1^No Selection" Q:$D(DIROUT) "^^" Q:$D(DTOUT)!($D(DUOUT)) "^"
S:"^80^80.1^"[("^"_ICDO_"^") X=ICDO
Q X
DPH ; File Help
W !,?5,"This response must be a number from 1 to 2."
Q
;
FIT(FILE,FMT) ; File Input Transform
N ICDF,ICDT,ICDO S ICDF=$G(FILE),ICDT=+($G(FMT)) Q:'ICDT&(ICDF["^^") "^^" Q:'ICDT&(ICDF["^") "^"
S ICDO="" S:ICDF["?" ICDO="??" Q:'ICDT&($L(ICDO)) ICDO
S:ICDF="80"!(ICDF="1")!(ICDF="30")!(ICDF["ICD9")!(ICDF["ICD-9")!(ICDF["DX")!(ICDF["DIAG")!(ICDF="ICD")!(ICDF="10D") ICDO=1
S:ICDF="80.1"!(ICDF="2")!(ICDF="31")!(ICDF["ICD0")!(ICDF["ICP")!(ICDF["OP")!(ICDF["PR")!(ICDF["PROC")!(ICDF="ICP")!(ICDF="10P") ICDO=2
S:ICDT ICDO=$S(ICDO=1:80,ICDO=2:80.1,1:"")
Q ICDO
TRIM(X,Y) ; Trim Character
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXA3 15899 printed Sep 23, 2025@19:26:33 Page 2
ICDEXA3 ;SLC/KER - ICD Extractor - APIs/Utilities (cont) ;12/19/2014
+1 ;;18.0;DRG Grouper;**57,67**;Oct 20, 2000;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^ICDS( N/A
+5 ; ^ICDS("F") N/A
+6 ;
+7 ; External References
+8 ; $$DT^XLFDT ICR 10103
+9 ; $$FMTE^XLFDT ICR 10103
+10 ; $$UP^XLFSTR ICR 10104
+11 ; ^DIR ICR 10026
+12 ;
OBA(FILE,CODE,SYS,REV) ; Replace $Order for "ABA" and "BA" indexes
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE = ICD Code, can be null
+5 ; FILE File Number 80 or 80.1
+6 ; SYS Coding System (internal, file 80.4)
+7 ; REV Reverse $Order if set to 1
+8 ;
+9 ; Output:
+10 ;
+11 ; $$OBA Next or Previous Code
+12 ;
+13 ; This API replaces the need to access the BA Index
+14 ; in a FOR loop.
+15 ;
+16 ; $$OBA(<file>,<code>,<system>) replaces:
+17 ;
+18 ; $O(^ICD9("BA",(<code>_" ")) and
+19 ; $O(^ICD0("BA",(<code>_" "))
+20 ;
+21 ; F S CODE=$$OBA^ICDEX(80,CODE,1) Q:'$L(CODE) D
+22 ; F S CODE=$$OBA^ICDEX(80,CODE,30) Q:'$L(CODE) D
+23 ; F S CODE=$$OBA^ICDEX(80.1,CODE,2) Q:'$L(CODE) D
+24 ; F S CODE=$$OBA^ICDEX(80.1,CODE,31) Q:'$L(CODE) D
+25 ;
+26 ; Retire IA 5388, 5404
+27 ;
+28 NEW ICDC,ICDG,ICDF,ICDI,ICDID,ICDR,ICDU,ICDS,ICDO,ICDN,ICDX,ICDD
+29 SET ICDC=$TRANSLATE($GET(CODE)," ","")
SET ICDU=$$UP^XLFSTR(ICDC)
SET ICDS=$GET(SYS)
+30 SET ICDF=$GET(FILE)
if "^80^80.1^"'[("^"_ICDF_"^")
QUIT ""
+31 IF $LENGTH(ICDS)
SET ICDS=$$SYS^ICDEX(ICDS)
if +ICDS'>0
QUIT ""
+32 SET ICDR=$$ROOT^ICDEX(ICDF)
if '$LENGTH(ICDR)
QUIT ""
SET ICDD=+($GET(REV))
+33 IF +ICDS>0
Begin DoDot:1
+34 NEW ICDX,ICDN,ICDI
SET ICDX="ABA"
+35 IF ICDD'>0
Begin DoDot:2
+36 NEW ICD1,ICD2
+37 SET ICD1=$TRANSLATE($ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDC_" ")_""")"))," ","")
+38 SET ICD2=$TRANSLATE($ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDU_" ")_""")"))," ","")
+39 if ICD1]ICD2!(ICD1=ICD2)
SET ICDN=ICD2
if ICD2]ICD1
SET ICDN=ICD1
End DoDot:2
+40 if ICDD>0&('$LENGTH(ICDC))
SET ICDC="~"
+41 IF ICDD>0
Begin DoDot:2
+42 NEW ICD1,ICD2
+43 SET ICD1=$TRANSLATE($ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDC_" ")_""")"),-1)," ","")
+44 SET ICD2=$TRANSLATE($ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDU_" ")_""")"),-1)," ","")
+45 if ICD1]ICD2!(ICD1=ICD2)
SET ICDN=ICD2
if ICD2]ICD1
SET ICDN=ICD1
End DoDot:2
+46 SET ICDI=$$CODEABA^ICDEX(ICDN,ICDR,ICDS)
+47 SET ICDO=ICDN
if '$LENGTH(ICDN)!(+ICDI'>0)
SET ICDO=""
End DoDot:1
QUIT ICDO
+48 IF '$LENGTH(ICDS)
Begin DoDot:1
+49 NEW ICDX,ICDN,ICDI
SET ICDX="BA"
+50 IF +ICDD'>0
Begin DoDot:2
+51 NEW ICD1,ICD2
+52 SET ICD1=$TRANSLATE($ORDER(@(ICDR_""""_ICDX_""","""_(ICDC_" ")_""")"))," ","")
+53 SET ICD2=$TRANSLATE($ORDER(@(ICDR_""""_ICDX_""","""_(ICDU_" ")_""")"))," ","")
+54 if ICD1]ICD2!(ICD1=ICD2)
SET ICDN=ICD2
if ICD2]ICD1
SET ICDN=ICD1
End DoDot:2
+55 if ICDD>0&('$LENGTH(ICDC))
SET ICDC="~"
+56 IF +ICDD>0
Begin DoDot:2
+57 NEW ICD1,ICD2
+58 SET ICD1=$TRANSLATE($ORDER(@(ICDR_""""_ICDX_""","""_(ICDC_" ")_""")"),-1)," ","")
+59 SET ICD2=$TRANSLATE($ORDER(@(ICDR_""""_ICDX_""","""_(ICDU_" ")_""")"),-1)," ","")
+60 if ICD1]ICD2!(ICD1=ICD2)
SET ICDN=ICD2
if ICD2]ICD1
SET ICDN=ICD1
End DoDot:2
+61 SET ICDI=$$CODEBA^ICDEX(ICDN,ICDR)
+62 SET ICDO=ICDN
if '$LENGTH(ICDN)!(+ICDI'>0)
SET ICDO=""
End DoDot:1
QUIT ICDO
+63 QUIT ""
OD(FILE,WORD,SYS,REV) ; Replace $Order on "D" Index
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File Number
+5 ; WORD Word, can be null or a 2 piece string
+6 ; containing Word and IEN where the word
+7 ; is stored
+8 ; SYS Coding System (internal)
+9 ; Acceptable values can be found on the ASYS
+10 ; Index and includes:
+11 ;
+12 ; File 80
+13 ; 1 ICD-9-CM
+14 ; 30 ICD-10-CM
+15 ;
+16 ; File 80.1
+17 ; 2 ICD-9 Proc
+18 ; 31 ICD-10-PCS
+19 ;
+20 ; REV Reverse $Order if set to 1
+21 ;
+22 ; Output:
+23 ;
+24 ; 2 Piece "^" delimited string
+25 ;
+26 ; 1 WORD Next or Previous word in D Index
+27 ; 2 IEN Internal Entry Number where WORD is found
+28 ;
+29 ; Retire IA 5388, 5404
+30 ;
+31 NEW ICDW,ICDWI,ICDG,ICDF,ICDI,ICDR,ICDS,ICDO,ICDN,ICDX,ICDD
+32 SET ICDW=$$UP^XLFSTR($GET(WORD))
SET ICDWI=+($PIECE(ICDW,"^",2))
SET ICDW=$PIECE(ICDW,"^",1)
+33 SET ICDS=$GET(SYS)
SET ICDF=$GET(FILE)
if "^80^80.1^"'[("^"_ICDF_"^")
QUIT ""
+34 IF $LENGTH(ICDS)
SET ICDS=$$SYS^ICDEX(ICDS)
if +ICDS'>0
QUIT ""
+35 SET ICDR=$$ROOT^ICDEX(ICDF)
if '$LENGTH(ICDR)
QUIT ""
SET ICDD=+($GET(REV))
+36 IF +ICDS>0
Begin DoDot:1
+37 NEW ICDX,ICDN,ICDNI,ICDI
SET ICDX="AD"
+38 IF ICDD'>0
Begin DoDot:2
+39 SET ICDNI=0
if $LENGTH($GET(ICDW))
SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"))
+40 IF ICDNI>0
SET ICDO=ICDW_"^"_ICDNI
QUIT
+41 SET ICDNI=""
SET ICDN=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"))
+42 if $LENGTH(ICDN)
SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_0_")"))
+43 SET ICDO=ICDN_"^"_ICDNI
End DoDot:2
QUIT
+44 IF ICDD>0
Begin DoDot:2
+45 IF $LENGTH(ICDW)
Begin DoDot:3
+46 SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"),-1)
+47 IF ICDNI>0
SET ICDO=ICDW_"^"_ICDNI
QUIT
+48 SET ICDN=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
+49 IF '$LENGTH(ICDN)
SET ICDO=""
QUIT
+50 if $LENGTH(ICDN)
SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","" "")"),-1)
+51 IF +ICDNI>0
SET ICDO=ICDN_"^"_ICDNI
QUIT
End DoDot:3
QUIT
+52 SET ICDW="~"
SET ICDWI=""" """
SET ICDNI=""
+53 SET ICDN=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
+54 if $LENGTH(ICDN)
SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_ICDWI_")"),-1)
+55 SET ICDO=ICDN_"^"_ICDNI
End DoDot:2
QUIT
End DoDot:1
QUIT ICDO
+56 IF '$LENGTH(ICDS)
Begin DoDot:1
+57 NEW ICDX,ICDN,ICDNI,ICDI
SET ICDX="D"
+58 IF +ICDD'>0
Begin DoDot:2
+59 SET ICDNI=0
if $LENGTH($GET(ICDW))
SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"))
+60 IF ICDNI>0
SET ICDO=ICDW_"^"_ICDNI
QUIT
+61 SET ICDNI=""
SET ICDN=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"))
+62 if $LENGTH(ICDN)
SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_0_")"))
+63 SET ICDO=ICDN_"^"_ICDNI
End DoDot:2
QUIT
+64 IF ICDD>0
Begin DoDot:2
+65 IF $LENGTH(ICDW)
Begin DoDot:3
+66 SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"),-1)
+67 IF ICDNI>0
SET ICDO=ICDW_"^"_ICDNI
QUIT
+68 SET ICDN=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
+69 IF '$LENGTH(ICDN)
SET ICDO=""
QUIT
+70 if $LENGTH(ICDN)
SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","" "")"),-1)
+71 IF +ICDNI>0
SET ICDO=ICDN_"^"_ICDNI
QUIT
End DoDot:3
QUIT
+72 SET ICDW="~"
SET ICDWI=""" """
SET ICDNI=""
+73 SET ICDN=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
+74 if $LENGTH(ICDN)
SET ICDNI=$ORDER(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_ICDWI_")"),-1)
+75 SET ICDO=ICDN_"^"_ICDNI
End DoDot:2
QUIT
End DoDot:1
QUIT ICDO
+76 QUIT ""
DLM(FILE,IEN,FIELD,CDT) ; Date Last Modified
+1 ;
+2 ; Input
+3 ;
+4 ; FILE File Number (required)
+5 ; IEN Internal Entry Number (required)
+6 ; FIELD Field Number of Versioned Data (optional)
+7 ;
+8 ; File 80
+9 ;
+10 ; 10 Sex 5;0
+11 ; 11 Age Low 6;0
+12 ; 12 Age High 7;0
+13 ; 66 Status 66;0
+14 ; 67 Diagnosis 67;0
+15 ; 68 Description 68;0
+16 ; 71 DRG Grouper 3;0
+17 ; 72 Major Diagnostic Category 4;0
+18 ; 103 Complication/Comorbidity 69;0
+19 ;
+20 ; File 80.1
+21 ;
+22 ; 10 Sex 3;0
+23 ; 66 Status 66;0
+24 ; 67 Operation/Procedure 67;0
+25 ; 68 Description 68;0
+26 ; 71 DRG Grouper 2;0
+27 ;
+28 ; If the field is passed, then the date last
+29 ; modified (based on date) for the field is
+30 ; returned. If the field is not passed, then
+31 ; the date last modified (based on date) for
+32 ; the record at IEN is returned.
+33 ;
+34 ; CDT Date to base output on (default is today)
+35 ; Business rules apply
+36 ;
+37 ; Output:
+38 ;
+39 ; $$DLM Date Last Modified
+40 ;
+41 ; or -1 ^ message on error
+42 ;
+43 NEW ICD0,ICDA,ICDC,ICDD,ICDE,ICDF,ICDH,ICDI,ICDL,ICDN,ICDNS,ICDO,ICDP,ICDR
+44 SET ICDI=$GET(IEN)
if +ICDI'>0
QUIT "-1^Invalid IEN"
+45 SET ICDF=$GET(FILE)
if "^80^80.1^"'[("^"_ICDF_"^")
QUIT "-1^Invalid File"
+46 SET ICDR=$$ROOT^ICDEX(ICDF)
if '$LENGTH(ICDR)
QUIT "-1^Invalid File Root"
+47 SET ICDC=+($PIECE($GET(@(ICDR_+ICDI_",1)")),"^",1))
+48 if +ICDC'>0
QUIT "-1^Invalid Coding System "_ICDC
+49 if '$DATA(@(ICDR_+ICDI_",0)"))
QUIT "-1^IEN not found"
+50 SET ICDL=$GET(FIELD)
+51 SET ICDD=$GET(CDT)
if ICDD'?7N
SET ICDD=$$DT^XLFDT
+52 SET ICDD=$$DTBR^ICDEX($GET(ICDD),0,ICDC)
+53 if ICDD'?7N
QUIT "-1^Invalid Date for File"
+54 IF '$LENGTH(ICDL)
Begin DoDot:1
+55 NEW ICDA,ICDNS,ICDP,ICDN,ICDE,ICDH,ICD0,ICDL
+56 KILL ICDA
SET ICDNS=""
SET ICDO="-1^Date Last Modified not found"
+57 if ICDF=80
SET ICDNS="3^4^5^6^7^66^67^68^69"
if ICDF=80.1
SET ICDNS="2^3^66^67^68"
if '$LENGTH(ICDNS)
QUIT
+58 FOR ICDP=1:1
if '$LENGTH($PIECE(ICDNS,"^",ICDP))
QUIT
Begin DoDot:2
+59 SET ICDN=$PIECE(ICDNS,"^",ICDP)
+60 SET ICDE=$ORDER(@(ICDR_+ICDI_","_ICDN_",""B"","_(ICDD+.001)_")"),-1)
if ICDE'?7N
QUIT
+61 SET ICDH=$ORDER(@(ICDR_+ICDI_","_ICDN_",""B"","_ICDE_","" "")"),-1)
+62 SET ICD0=$GET(@(ICDR_+ICDI_","_ICDN_","_ICDH_",0)"))
+63 if $PIECE(ICD0,"^",1)?7N
SET ICDA($PIECE(ICD0,"^",1))=""
End DoDot:2
+64 SET ICDL=$ORDER(ICDA(" "),-1)
if ICDL?7N
SET ICDO=ICDL
KILL ICDA
End DoDot:1
QUIT ICDO
+65 if ICDF=80
SET ICDN=$SELECT(ICDL=10:5,ICDL=11:6,ICDL=12:7,ICDL=66:66,ICDL=67:67,ICDL=68:68,ICDL=71:3,ICDL=72:4,ICDL=103:69,1:"")
+66 if ICDF=80.1
SET ICDN=$SELECT(ICDL=10:3,ICDL=66:66,ICDL=67:67,ICDL=68:68,ICDL=71:2,1:"")
+67 if +ICDL'>0!('$LENGTH(ICDN))
QUIT "-1^Invalid Field"
+68 if $ORDER(@(ICDR_+ICDI_","_ICDN_",0)"))'>0
QUIT "-1^Field #"_ICDL_" not found for IEN "_ICDI
+69 SET ICDE=$ORDER(@(ICDR_+ICDI_","_ICDN_",""B"","_(ICDD+.001)_")"),-1)
+70 if ICDE'?7N
QUIT ("-1^Date Last Modified not found based on "_$$FMTE^XLFDT($GET(ICDD),"5DZ"))
+71 SET ICDH=$ORDER(@(ICDR_+ICDI_","_ICDN_",""B"","_ICDE_","" "")"),-1)
+72 if +ICDH'>0
QUIT "-1^Modified Data Not Found"
+73 SET ICDO="-1^Modified Data Not Found"
+74 SET ICD0=$GET(@(ICDR_+ICDI_","_ICDN_","_ICDH_",0)"))
+75 SET ICDL=$PIECE(ICD0,"^",1)
+76 if ICDL?7N
SET ICDO=ICDL
+77 QUIT ICDO
CS(FILE,FMT,CDT) ; Select Coding System (lookup)
+1 ;
+2 ; Input
+3 ;
+4 ; FILE File Number 80 or 80.1 (optional)
+5 ; If not provided, you will be prompted
+6 ; for the ICD File, there is no default
+7 ; value.
+8 ;
+9 ; FMT Format
+10 ;
+11 ; E Display External only (default)
+12 ; I Display Internal with External for selection
+13 ;
+14 ; CDT Code Set Date (optional) if not supplied then
+15 ; it is not used
+16 ; Output
+17 ;
+18 ; $$CS 2 piece "^" delimited string
+19 ;
+20 ; 1 Coding System (internal)
+21 ; 2 Coding System (external)
+22 ;
+23 ; or -1 on error or non-selection
+24 ; ^^ double up-arrows
+25 ; ^ timeout or single up-arrow
+26 ;
+27 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDDIR,ICD0,ICD1,ICD2,ICDA,ICDC,ICDD,ICDE
+28 NEW ICDIMP,ICDF,ICDI,ICDM,ICDR,ICDT,ICDTMP,ICDO,ICDV,ICDX,X,Y
+29 SET ICDIMP=$$IMP^ICDEX(30)
SET ICDD=$SELECT($PIECE($GET(CDT),".")?7N:$PIECE($GET(CDT),"."),1:"")
+30 SET ICDF=$$FIT($GET(FILE),1)
if ICDF["^"
QUIT ICDF
SET ICDDIR="Select ICD file number"
if +ICDF'>0
SET ICDF=$$FI
+31 if "^80^80.1^"'[("^"_ICDF_"^")
QUIT "-1^Invalid File"
+32 SET ICDR=$$ROOT^ICDEX(ICDF)
if '$LENGTH(ICDR)
QUIT "-1^Invalid File"
+33 KILL ICDA
SET ICDA(0)=0
+34 IF $GET(ICDD)?7N
Begin DoDot:1
+35 NEW ICDAA,ICDE,ICDI,ICDS
SET (ICDC,ICDI)=0
FOR
SET ICDI=$ORDER(^ICDS("F",ICDF,ICDI))
if +ICDI'>0
QUIT
Begin DoDot:2
+36 SET ICDE=$PIECE($GET(^ICDS(+ICDI,0)),"^",1)
if '$LENGTH(ICDE)
QUIT
+37 SET ICDTMP=$PIECE($GET(^ICDS(+ICDI,0)),"^",4)
if $GET(ICDD)?7N&((ICDD+.001)'>ICDTMP)
QUIT
+38 SET ICDAA(ICDTMP,ICDI)=ICDI_"^"_ICDE
End DoDot:2
+39 SET ICDE=$ORDER(ICDAA(" "),-1)
+40 SET ICDI=$ORDER(ICDAA(+ICDE," "),-1)
+41 SET ICDS=$GET(ICDAA(+ICDE,+ICDI))
+42 if ICDE?7N&(ICDI>0)&($LENGTH(ICDS))
SET ICDC=1
SET ICDA(ICDC)=ICDS
SET ICDA(0)=1
End DoDot:1
+43 IF $GET(ICDD)'?7N!($ORDER(ICDA(0))'>0)
Begin DoDot:1
+44 SET (ICDC,ICDI)=0
FOR
SET ICDI=$ORDER(^ICDS("F",ICDF,ICDI))
if +ICDI'>0
QUIT
Begin DoDot:2
+45 SET ICDE=$PIECE($GET(^ICDS(+ICDI,0)),"^",1)
if '$LENGTH(ICDE)
QUIT
+46 SET ICDTMP=$PIECE($GET(^ICDS(+ICDI,0)),"^",4)
+47 SET ICDC=ICDC+1
SET ICDA(ICDC)=ICDI_"^"_ICDE
SET ICDA(0)=ICDC
End DoDot:2
End DoDot:1
+48 if ICDA(0)=1&($LENGTH($GET(ICDA(1))))
QUIT $GET(ICDA(1))
if ICDA(0)=1&('$LENGTH($GET(ICDA(1))))
QUIT "-1^Invalid Selection"
+49 SET ICDX=$GET(FMT)
if ICDX'="I"
SET ICDX="E"
SET ICDM=$ORDER(ICDA(" "),-1)
if ICDM'>0
QUIT "-1^Invalid Selection"
+50 if ICDM=1&($DATA(ICDA(1)))
QUIT $GET(ICDA(1))
if ICDM'>1
QUIT "-1^Invalid Selection"
SET DIR(0)="NAO^1:"_ICDM_":0"
+51 SET DIR("A",1)=" Coding System Selection for file "_ICDF
SET DIR("A",2)=" "
+52 SET DIR("A")=" Select Coding System (1-"_ICDM_"): "
+53 SET ICDC=0
SET ICDI=0
FOR
SET ICDI=$ORDER(ICDA(ICDI))
if +ICDI'>0
QUIT
Begin DoDot:1
+54 NEW ICD1,ICD2,ICDT
SET ICD1=$PIECE($GET(ICDA(ICDI)),"^",1)
if ICD1'>0
QUIT
SET ICD2=$PIECE($GET(ICDA(ICDI)),"^",2)
if '$LENGTH(ICD2)
QUIT
+55 SET ICDT=ICD2
if $GET(ICDX)="I"
SET ICDT=ICDT_$JUSTIFY(" ",(15-$LENGTH(ICDT)))_"(#"_ICD1_")"
+56 SET ICDC=ICDC+1
SET DIR("A",(ICDC+2))=" "_$JUSTIFY(ICDC,2)_" "_ICDT
End DoDot:1
+57 if ICDC>1
SET ICDC=ICDC+1
SET DIR("A",(ICDC+2))=" "
SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D CSH^ICDEXA3"
+58 WRITE !
DO ^DIR
if $DATA(DIROUT)
QUIT "^^"
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
if '$LENGTH(Y)
QUIT "-1^No Coding System Selected"
if +Y>0&($DATA(ICDA(+Y)))
QUIT $GET(ICDA(+Y))
+59 QUIT "-1^Invalid Selection"
CSH ; Select Coding System Help
+1 if +($GET(ICDM))'>1
WRITE !,?5,"This response must be a number."
+2 if +($GET(ICDM))>1
WRITE !,?5,"This response must be a number from 1 to ",+($GET(ICDM)),"."
+3 QUIT
+4 ;
FI(X) ; Select ICD File
+1 ;
+2 ; Input
+3 ;
+4 ; X File Number 80 or 80.1 or NULL
+5 ;
+6 ; Output
+7 ;
+8 ; $$FI File Number or -1 on error
+9 ;
+10 ; or -1 on error or non-selection
+11 ; ^^ double up-arrows
+12 ; ^ timeout or single up-arrow
+13 ;
+14 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICD1,ICD2,ICDA,ICDC,ICDE,ICDF,ICDI,ICDM,ICDR,ICDT,Y
+15 SET X=$GET(X)
SET ICDO=$$FIT(X,1)
if "^80^80.1^"[("^"_ICDO_"^")
QUIT ICDO
SET ICD0=""
+16 SET DIR("A")=" Select ICD file: "
SET ICDDIR=$$TRIM($GET(ICDDIR))
+17 SET DIR("A",1)=" ICD file"
if $LENGTH($GET(ICDDIR))
SET DIR("A",1)=" "_$GET(ICDDIR)
KILL ICDDIR
+18 SET DIR("A",2)=" "
+19 SET DIR("A",3)=" 1 ICD Diagnosis file #80 ^ICD9("
+20 SET DIR("A",4)=" 2 ICD Operations/Procedures file #80.1 ^ICD0("
+21 SET DIR("A",5)=" "
+22 SET DIR(0)="NAO^1:2:0"
+23 SET DIR("PRE")="S X=$$FIT^ICDEXA3(X)"
SET (DIR("?"),DIR("??"))="^D FIH^ICDEXA3"
+24 DO ^DIR
if '$LENGTH($GET(X))
QUIT "-1^No Selection"
if $DATA(DIROUT)
QUIT "^^"
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
+25 SET ICDO=$$FIT(Y,1)
SET X="-1^Invalid File Selection"
+26 if "^80^80.1^"[("^"_ICDO_"^")
SET X=ICDO
+27 QUIT X
FIH ; File Help
+1 WRITE !,?5,"This response must be a number from 1 to 2."
+2 QUIT
DP(X) ; Select Diagnosis or Procedure
+1 ;
+2 ; Input
+3 ;
+4 ; X Date
+5 ;
+6 ; Output
+7 ;
+8 ; $$DP Coding System based on Date or -1 on error
+9 ;
+10 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICCD,ICDCS,ICDIMP,ICD1,ICD2,ICDA,ICDC,ICDE,ICDF,ICDI,ICDM,ICDR,ICDT,ICDTY,Y
+11 SET ICDD=$PIECE($GET(X),".",1)
SET ICD0=""
SET ICDIMP=$$IMP^ICDEX(30)
SET ICDTY=""
SET ICDCS=""
if ICDD'?7N
SET ICDD=$$DT^XLFDT
+12 FOR ICDI=0
FOR
SET ICDI=$ORDER(^ICDS("F",80,ICDI))
if +ICDI'>0
QUIT
Begin DoDot:1
+13 NEW ICDS,ICDSD
SET ICDS=$GET(^ICDS(ICDI,0))
SET ICDSD=$PIECE(ICDS,"^",4)
if ICDSD'?7N
QUIT
+14 if ICDSD<(ICDD+.0001)
SET ICDTY=$PIECE($PIECE(ICDS,"^",1)," ",1)
if $LENGTH(ICDTY,"-")=2
SET ICDTY=$PIECE(ICDTY,"-",1,2)
End DoDot:1
+15 if '$LENGTH(ICDTY)
SET ICDTY="ICD"
SET DIR("A")=" Select ICD Code Type: "
SET ICDDIR=$$TRIM($GET(ICDDIR))
+16 SET DIR("A",1)=" Select one of the following:"
+17 if $LENGTH($GET(ICDDIR))
SET DIR("A",1)=" "_$GET(ICDDIR)
KILL ICDDIR
+18 SET DIR("A",2)=" "
+19 SET DIR("A",3)=" 1 "_ICDTY_" Diagnosis Code"
+20 SET DIR("A",4)=" 2 "_ICDTY_" Operations/Procedures Code"
+21 SET DIR("A",5)=" "
+22 SET DIR(0)="NAO^1:2:0"
+23 SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D DPH^ICDEXA3"
+24 DO ^DIR
if '$LENGTH($GET(X))
QUIT "-1^No Selection"
if $DATA(DIROUT)
QUIT "^^"
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
+25 if "^80^80.1^"[("^"_ICDO_"^")
SET X=ICDO
+26 QUIT X
DPH ; File Help
+1 WRITE !,?5,"This response must be a number from 1 to 2."
+2 QUIT
+3 ;
FIT(FILE,FMT) ; File Input Transform
+1 NEW ICDF,ICDT,ICDO
SET ICDF=$GET(FILE)
SET ICDT=+($GET(FMT))
if 'ICDT&(ICDF["^^")
QUIT "^^"
if 'ICDT&(ICDF["^")
QUIT "^"
+2 SET ICDO=""
if ICDF["?"
SET ICDO="??"
if 'ICDT&($LENGTH(ICDO))
QUIT ICDO
+3 if ICDF="80"!(ICDF="1")!(ICDF="30")!(ICDF["ICD9")!(ICDF["ICD-9")!(ICDF["DX")!(ICDF["DIAG")!(ICDF="ICD")!(ICDF="10D")
SET ICDO=1
+4 if ICDF="80.1"!(ICDF="2")!(ICDF="31")!(ICDF["ICD0")!(ICDF["ICP")!(ICDF["OP")!(ICDF["PR")!(ICDF["PROC")!(ICDF="ICP")!(ICDF="10P")
SET ICDO=2
+5 if ICDT
SET ICDO=$SELECT(ICDO=1:80,ICDO=2:80.1,1:"")
+6 QUIT ICDO
TRIM(X,Y) ; Trim Character
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
