Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICDEXA3

ICDEXA3.m

Go to the documentation of this file. 
  1. ICDEXA3 ;SLC/KER - ICD Extractor - APIs/Utilities (cont) ;04/21/2014
  1.  ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^ICDS(              N/A
  1.  ;    ^ICDS("F")          N/A
  1.  ;               
  1.  ; External References
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$FMTE^XLFDT        ICR  10103
  1.  ;    $$UP^XLFSTR         ICR  10104
  1.  ;    ^DIR                ICR  10026
  1.  ;               
  1. OBA(FILE,CODE,SYS,REV) ; Replace $Order for "ABA" and "BA" indexes
  1.  ;
  1.  ; Input:
  1.  ; 
  1.  ;    CODE = ICD Code, can be null
  1.  ;    FILE   File Number 80 or 80.1
  1.  ;    SYS    Coding System (internal, file 80.4)
  1.  ;    REV    Reverse $Order if set to 1
  1.  ;    
  1.  ; Output:
  1.  ; 
  1.  ;    $$OBA  Next or Previous Code
  1.  ;
  1.  ;  This API replaces the need to access the BA Index
  1.  ;  in a FOR loop.
  1.  ;  
  1.  ;     $$OBA(<file>,<code>,<system>) replaces:
  1.  ; 
  1.  ;        $O(^ICD9("BA",(<code>_" ")) and
  1.  ;        $O(^ICD0("BA",(<code>_" "))
  1.  ;        
  1.  ;     F  S CODE=$$OBA^ICDEX(80,CODE,1) Q:'$L(CODE)  D
  1.  ;     F  S CODE=$$OBA^ICDEX(80,CODE,30) Q:'$L(CODE)  D
  1.  ;     F  S CODE=$$OBA^ICDEX(80.1,CODE,2) Q:'$L(CODE)  D
  1.  ;     F  S CODE=$$OBA^ICDEX(80.1,CODE,31) Q:'$L(CODE)  D
  1.  ;  
  1.  ;  Retire IA 5388, 5404
  1.  ;  
  1.  N ICDC,ICDG,ICDF,ICDI,ICDID,ICDR,ICDU,ICDS,ICDO,ICDN,ICDX,ICDD
  1.  S ICDC=$TR($G(CODE)," ",""),ICDU=$$UP^XLFSTR(ICDC) S ICDS=$G(SYS)
  1.  S ICDF=$G(FILE) Q:"^80^80.1^"'[("^"_ICDF_"^") ""
  1.  I $L(ICDS) S ICDS=$$SYS^ICDEX(ICDS) Q:+ICDS'>0 ""
  1.  S ICDR=$$ROOT^ICDEX(ICDF) Q:'$L(ICDR) ""  S ICDD=+($G(REV))
  1.  I +ICDS>0 D  Q ICDO
  1.  . N ICDX,ICDN,ICDI S ICDX="ABA"
  1.  . I ICDD'>0 D
  1.  . . N ICD1,ICD2
  1.  . . 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
  1.  . S:ICDD>0&('$L(ICDC)) ICDC="~"
  1.  . I ICDD>0 D
  1.  . . N ICD1,ICD2
  1.  . . S ICD1=$TR($O(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDC_" ")_""")"),-1)," ","")
  1.  . . S ICD2=$TR($O(@(ICDR_""""_ICDX_""","_+ICDS_","""_(ICDU_" ")_""")"),-1)," ","")
  1.  . . S:ICD1]ICD2!(ICD1=ICD2) ICDN=ICD2 S:ICD2]ICD1 ICDN=ICD1
  1.  . S ICDI=$$CODEABA^ICDEX(ICDN,ICDR,ICDS)
  1.  . S ICDO=ICDN S:'$L(ICDN)!(+ICDI'>0) ICDO=""
  1.  I '$L(ICDS) D  Q ICDO
  1.  . N ICDX,ICDN,ICDI S ICDX="BA"
  1.  . I +ICDD'>0 D
  1.  . . N ICD1,ICD2
  1.  . . 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
  1.  . S:ICDD>0&('$L(ICDC)) ICDC="~"
  1.  . I +ICDD>0 D
  1.  . . N ICD1,ICD2
  1.  . . S ICD1=$TR($O(@(ICDR_""""_ICDX_""","""_(ICDC_" ")_""")"),-1)," ","")
  1.  . . S ICD2=$TR($O(@(ICDR_""""_ICDX_""","""_(ICDU_" ")_""")"),-1)," ","")
  1.  . . S:ICD1]ICD2!(ICD1=ICD2) ICDN=ICD2 S:ICD2]ICD1 ICDN=ICD1
  1.  . S ICDI=$$CODEBA^ICDEX(ICDN,ICDR)
  1.  . S ICDO=ICDN S:'$L(ICDN)!(+ICDI'>0) ICDO=""
  1.  Q ""
  1. OD(FILE,WORD,SYS,REV) ; Replace $Order on "D" Index
  1.  ; 
  1.  ; Input:
  1.  ; 
  1.  ;    FILE   File Number
  1.  ;    WORD   Word, can be null or a 2 piece string
  1.  ;           containing Word and IEN where the word
  1.  ;           is stored
  1.  ;    SYS    Coding System (internal)
  1.  ;             Acceptable values can be found on the ASYS
  1.  ;             Index and includes:
  1.  ;             
  1.  ;             File 80
  1.  ;                1   ICD-9-CM
  1.  ;               30   ICD-10-CM
  1.  ;                 
  1.  ;             File 80.1
  1.  ;                2   ICD-9 Proc
  1.  ;               31   ICD-10-PCS
  1.  ;    
  1.  ;    REV    Reverse $Order if set to 1
  1.  ;    
  1.  ; Output:
  1.  ; 
  1.  ;    2 Piece "^" delimited string
  1.  ;    
  1.  ;         1   WORD   Next or Previous word in D Index
  1.  ;         2   IEN    Internal Entry Number where WORD is found
  1.  ;  
  1.  ;  Retire IA 5388, 5404
  1.  ;  
  1.  N ICDW,ICDWI,ICDG,ICDF,ICDI,ICDR,ICDS,ICDO,ICDN,ICDX,ICDD
  1.  S ICDW=$$UP^XLFSTR($G(WORD)),ICDWI=+($P(ICDW,"^",2)),ICDW=$P(ICDW,"^",1)
  1.  S ICDS=$G(SYS) S ICDF=$G(FILE) Q:"^80^80.1^"'[("^"_ICDF_"^") ""
  1.  I $L(ICDS) S ICDS=$$SYS^ICDEX(ICDS) Q:+ICDS'>0 ""
  1.  S ICDR=$$ROOT^ICDEX(ICDF) Q:'$L(ICDR) ""  S ICDD=+($G(REV))
  1.  I +ICDS>0 D  Q ICDO
  1.  . N ICDX,ICDN,ICDNI,ICDI S ICDX="AD"
  1.  . I ICDD'>0 D  Q
  1.  . . S ICDNI=0 S:$L($G(ICDW)) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"))
  1.  . . I ICDNI>0 S ICDO=ICDW_"^"_ICDNI Q
  1.  . . S ICDNI="",ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"))
  1.  . . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_0_")"))
  1.  . . S ICDO=ICDN_"^"_ICDNI
  1.  . I ICDD>0 D  Q
  1.  . . I $L(ICDW) D  Q
  1.  . . . S ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"),-1)
  1.  . . . I ICDNI>0 S ICDO=ICDW_"^"_ICDNI Q
  1.  . . . S ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
  1.  . . . I '$L(ICDN) S ICDO="" Q
  1.  . . . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","" "")"),-1)
  1.  . . . I +ICDNI>0 S ICDO=ICDN_"^"_ICDNI Q
  1.  . . S ICDW="~",ICDWI=""" """ S ICDNI=""
  1.  . . S ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
  1.  . . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_ICDWI_")"),-1)
  1.  . . S ICDO=ICDN_"^"_ICDNI
  1.  I '$L(ICDS) D  Q ICDO
  1.  . N ICDX,ICDN,ICDNI,ICDI S ICDX="D"
  1.  . I +ICDD'>0 D  Q
  1.  . . S ICDNI=0 S:$L($G(ICDW)) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"))
  1.  . . I ICDNI>0 S ICDO=ICDW_"^"_ICDNI Q
  1.  . . S ICDNI="",ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"))
  1.  . . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_0_")"))
  1.  . . S ICDO=ICDN_"^"_ICDNI
  1.  . I ICDD>0 D  Q
  1.  . . I $L(ICDW) D  Q
  1.  . . . S ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""","_+ICDWI_")"),-1)
  1.  . . . I ICDNI>0 S ICDO=ICDW_"^"_ICDNI Q
  1.  . . . S ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
  1.  . . . I '$L(ICDN) S ICDO="" Q
  1.  . . . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","" "")"),-1)
  1.  . . . I +ICDNI>0 S ICDO=ICDN_"^"_ICDNI Q
  1.  . . S ICDW="~",ICDWI=""" """ S ICDNI=""
  1.  . . S ICDN=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDW_""")"),-1)
  1.  . . S:$L(ICDN) ICDNI=$O(@(ICDR_""""_ICDX_""","_+ICDS_","""_ICDN_""","_ICDWI_")"),-1)
  1.  . . S ICDO=ICDN_"^"_ICDNI
  1.  Q ""
  1. DLM(FILE,IEN,FIELD,CDT) ; Date Last Modified
  1.  ;
  1.  ; Input
  1.  ;    
  1.  ;    FILE     File Number (required)
  1.  ;    IEN      Internal Entry Number (required)
  1.  ;    FIELD    Field Number of Versioned Data  (optional)
  1.  ;    
  1.  ;               File 80
  1.  ;              
  1.  ;                  10   Sex                          5;0
  1.  ;                  11   Age Low                      6;0
  1.  ;                  12   Age High                     7;0
  1.  ;                  66   Status                      66;0
  1.  ;                  67   Diagnosis                   67;0
  1.  ;                  68   Description                 68;0
  1.  ;                  71   DRG Grouper                  3;0
  1.  ;                  72   Major Diagnostic Category    4;0
  1.  ;                 103   Complication/Comorbidity    69;0
  1.  ;
  1.  ;               File 80.1
  1.  ;              
  1.  ;                  10   Sex                          3;0
  1.  ;                  66   Status                      66;0
  1.  ;                  67   Operation/Procedure         67;0
  1.  ;                  68   Description                 68;0
  1.  ;                  71   DRG Grouper                  2;0
  1.  ;                 
  1.  ;             If the field is passed, then the date last 
  1.  ;             modified (based on date) for the field is
  1.  ;             returned.  If the field is not passed, then
  1.  ;             the date last modified (based on date) for 
  1.  ;             the record at IEN is returned.
  1.  ;           
  1.  ;    CDT     Date to base output on (default is today)
  1.  ;            Business rules apply
  1.  ;    
  1.  ; Output:
  1.  ; 
  1.  ;    $$DLM   Date Last Modified
  1.  ;    
  1.  ;     or -1 ^ message on error
  1.  ;  
  1.  N ICD0,ICDA,ICDC,ICDD,ICDE,ICDF,ICDH,ICDI,ICDL,ICDN,ICDNS,ICDO,ICDP,ICDR
  1.  S ICDI=$G(IEN) Q:+ICDI'>0 "-1^Invalid IEN"
  1.  S ICDF=$G(FILE) Q:"^80^80.1^"'[("^"_ICDF_"^") "-1^Invalid File"
  1.  S ICDR=$$ROOT^ICDEX(ICDF) Q:'$L(ICDR) "-1^Invalid File Root"
  1.  S ICDC=+($P($G(@(ICDR_+ICDI_",1)")),"^",1))
  1.  Q:+ICDC'>0 "-1^Invalid Coding System "_ICDC
  1.  Q:'$D(@(ICDR_+ICDI_",0)")) "-1^IEN not found"
  1.  S ICDL=$G(FIELD)
  1.  S ICDD=$G(CDT) S:ICDD'?7N ICDD=$$DT^XLFDT
  1.  S ICDD=$$DTBR^ICDEX($G(ICDD),0,ICDC)
  1.  Q:ICDD'?7N "-1^Invalid Date for File"
  1.  I '$L(ICDL) D  Q ICDO
  1.  . N ICDA,ICDNS,ICDP,ICDN,ICDE,ICDH,ICD0,ICDL
  1.  . K ICDA S ICDNS="",ICDO="-1^Date Last Modified not found"
  1.  . 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)
  1.  . F ICDP=1:1 Q:'$L($P(ICDNS,"^",ICDP))  D
  1.  . . S ICDN=$P(ICDNS,"^",ICDP)
  1.  . . S ICDE=$O(@(ICDR_+ICDI_","_ICDN_",""B"","_(ICDD+.001)_")"),-1) Q:ICDE'?7N
  1.  . . S ICDH=$O(@(ICDR_+ICDI_","_ICDN_",""B"","_ICDE_","" "")"),-1)
  1.  . . S ICD0=$G(@(ICDR_+ICDI_","_ICDN_","_ICDH_",0)"))
  1.  . . S:$P(ICD0,"^",1)?7N ICDA($P(ICD0,"^",1))=""
  1.  . S ICDL=$O(ICDA(" "),-1) S:ICDL?7N ICDO=ICDL K ICDA
  1.  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:"")
  1.  S:ICDF=80.1 ICDN=$S(ICDL=10:3,ICDL=66:66,ICDL=67:67,ICDL=68:68,ICDL=71:2,1:"")
  1.  Q:+ICDL'>0!('$L(ICDN)) "-1^Invalid Field"
  1.  Q:$O(@(ICDR_+ICDI_","_ICDN_",0)"))'>0 "-1^Field #"_ICDL_" not found for IEN "_ICDI
  1.  S ICDE=$O(@(ICDR_+ICDI_","_ICDN_",""B"","_(ICDD+.001)_")"),-1)
  1.  Q:ICDE'?7N ("-1^Date Last Modified not found based on "_$$FMTE^XLFDT($G(ICDD),"5DZ"))
  1.  S ICDH=$O(@(ICDR_+ICDI_","_ICDN_",""B"","_ICDE_","" "")"),-1)
  1.  Q:+ICDH'>0 "-1^Modified Data Not Found"
  1.  S ICDO="-1^Modified Data Not Found"
  1.  S ICD0=$G(@(ICDR_+ICDI_","_ICDN_","_ICDH_",0)"))
  1.  S ICDL=$P(ICD0,"^",1)
  1.  S:ICDL?7N ICDO=ICDL
  1.  Q ICDO
  1. CS(FILE,FMT,CDT) ; Select Coding System (lookup)
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;    FILE   File Number 80 or 80.1 (optional)
  1.  ;           If not provided, you will be prompted
  1.  ;           for the ICD File, there is no default
  1.  ;           value.
  1.  ; 
  1.  ;    FMT    Format
  1.  ;    
  1.  ;             E  Display External only (default)
  1.  ;             I  Display Internal with External for selection
  1.  ;             
  1.  ;    CDT    Code Set Date (optional) if not supplied then
  1.  ;           it is not used
  1.  ; Output
  1.  ;     
  1.  ;    $$CS   2 piece "^" delimited string
  1.  ;    
  1.  ;              1  Coding System (internal)
  1.  ;              2  Coding System (external)
  1.  ;      
  1.  ;           or -1 on error or non-selection
  1.  ;              ^^ double up-arrows
  1.  ;               ^ timeout or single up-arrow
  1.  ;    
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDDIR,ICD0,ICD1,ICD2,ICDA,ICDC,ICDD,ICDE
  1.  N ICDIMP,ICDF,ICDI,ICDM,ICDR,ICDT,ICDTMP,ICDO,ICDV,ICDX,X,Y
  1.  S ICDIMP=$$IMP^ICDEX(30),ICDD=$S($P($G(CDT),".")?7N:$P($G(CDT),"."),1:"")
  1.  S ICDF=$$FIT($G(FILE),1) Q:ICDF["^" ICDF  S ICDDIR="Select ICD file number" S:+ICDF'>0 ICDF=$$FI
  1.  Q:"^80^80.1^"'[("^"_ICDF_"^") "-1^Invalid File"
  1.  S ICDR=$$ROOT^ICDEX(ICDF) Q:'$L(ICDR) "-1^Invalid File"
  1.  K ICDA S ICDA(0)=0
  1.  I $G(ICDD)?7N D
  1.  . N ICDAA,ICDE,ICDI,ICDS S (ICDC,ICDI)=0 F  S ICDI=$O(^ICDS("F",ICDF,ICDI)) Q:+ICDI'>0  D
  1.  . . S ICDE=$P($G(^ICDS(+ICDI,0)),"^",1) Q:'$L(ICDE)
  1.  . . S ICDTMP=$P($G(^ICDS(+ICDI,0)),"^",4) Q:$G(ICDD)?7N&((ICDD+.001)'>ICDTMP)
  1.  . . S ICDAA(ICDTMP,ICDI)=ICDI_"^"_ICDE
  1.  . S ICDE=$O(ICDAA(" "),-1)
  1.  . S ICDI=$O(ICDAA(+ICDE," "),-1)
  1.  . S ICDS=$G(ICDAA(+ICDE,+ICDI))
  1.  . S:ICDE?7N&(ICDI>0)&($L(ICDS)) ICDC=1,ICDA(ICDC)=ICDS,ICDA(0)=1
  1.  I $G(ICDD)'?7N!($O(ICDA(0))'>0) D
  1.  . S (ICDC,ICDI)=0 F  S ICDI=$O(^ICDS("F",ICDF,ICDI)) Q:+ICDI'>0  D
  1.  . . S ICDE=$P($G(^ICDS(+ICDI,0)),"^",1) Q:'$L(ICDE)
  1.  . . S ICDTMP=$P($G(^ICDS(+ICDI,0)),"^",4)
  1.  . . S ICDC=ICDC+1,ICDA(ICDC)=ICDI_"^"_ICDE,ICDA(0)=ICDC
  1.  Q:ICDA(0)=1&($L($G(ICDA(1)))) $G(ICDA(1)) Q:ICDA(0)=1&('$L($G(ICDA(1)))) "-1^Invalid Selection"
  1.  S ICDX=$G(FMT) S:ICDX'="I" ICDX="E" S ICDM=$O(ICDA(" "),-1) Q:ICDM'>0 "-1^Invalid Selection"
  1.  Q:ICDM=1&($D(ICDA(1))) $G(ICDA(1))  Q:ICDM'>1 "-1^Invalid Selection"  S DIR(0)="NAO^1:"_ICDM_":0"
  1.  S DIR("A",1)=" Coding System Selection for file "_ICDF,DIR("A",2)=" "
  1.  S DIR("A")=" Select Coding System (1-"_ICDM_"):  "
  1.  S ICDC=0,ICDI=0 F  S ICDI=$O(ICDA(ICDI)) Q:+ICDI'>0  D
  1.  . N ICD1,ICD2,ICDT S ICD1=$P($G(ICDA(ICDI)),"^",1) Q:ICD1'>0  S ICD2=$P($G(ICDA(ICDI)),"^",2) Q:'$L(ICD2)
  1.  . S ICDT=ICD2 S:$G(ICDX)="I" ICDT=ICDT_$J(" ",(15-$L(ICDT)))_"(#"_ICD1_")"
  1.  . S ICDC=ICDC+1 S DIR("A",(ICDC+2))="    "_$J(ICDC,2)_"   "_ICDT
  1.  S:ICDC>1 ICDC=ICDC+1,DIR("A",(ICDC+2))=" " S DIR("PRE")="S:X[""?"" X=""??""",(DIR("?"),DIR("??"))="^D CSH^ICDEXA3"
  1.  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))
  1.  Q "-1^Invalid Selection"
  1. CSH ; Select Coding System Help
  1.  W:+($G(ICDM))'>1 !,?5,"This response must be a number."
  1.  W:+($G(ICDM))>1 !,?5,"This response must be a number from 1 to ",+($G(ICDM)),"."
  1.  Q
  1.  ;
  1. FI(X) ; Select ICD File
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;    X      File Number 80 or 80.1 or NULL
  1.  ; 
  1.  ; Output
  1.  ;     
  1.  ;    $$FI   File Number or -1 on error
  1.  ;    
  1.  ;           or -1 on error or non-selection
  1.  ;              ^^ double up-arrows
  1.  ;               ^ timeout or single up-arrow
  1.  ;  
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICD1,ICD2,ICDA,ICDC,ICDE,ICDF,ICDI,ICDM,ICDR,ICDT,Y
  1.  S X=$G(X),ICDO=$$FIT(X,1) Q:"^80^80.1^"[("^"_ICDO_"^") ICDO  S ICD0=""
  1.  S DIR("A")=" Select ICD file:  " S ICDDIR=$$TRIM($G(ICDDIR))
  1.  S DIR("A",1)=" ICD file" S:$L($G(ICDDIR)) DIR("A",1)=" "_$G(ICDDIR) K ICDDIR
  1.  S DIR("A",2)=" "
  1.  S DIR("A",3)="     1   ICD Diagnosis file              #80     ^ICD9("
  1.  S DIR("A",4)="     2   ICD Operations/Procedures file  #80.1   ^ICD0("
  1.  S DIR("A",5)=" "
  1.  S DIR(0)="NAO^1:2:0"
  1.  S DIR("PRE")="S X=$$FIT^ICDEXA3(X)",(DIR("?"),DIR("??"))="^D FIH^ICDEXA3"
  1.  D ^DIR Q:'$L($G(X)) "-1^No Selection"  Q:$D(DIROUT) "^^" Q:$D(DTOUT)!($D(DUOUT)) "^"
  1.  S ICDO=$$FIT(Y,1)  S X="-1^Invalid File Selection"
  1.  S:"^80^80.1^"[("^"_ICDO_"^") X=ICDO
  1.  Q X
  1. FIH ; File Help
  1.  W !,?5,"This response must be a number from 1 to 2."
  1.  Q
  1. DP(X) ; Select Diagnosis or Procedure
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;    X      Date
  1.  ; 
  1.  ; Output
  1.  ;     
  1.  ;    $$DP   Coding System based on Date or -1 on error
  1.  ;    
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICCD,ICDCS,ICDIMP,ICD1,ICD2,ICDA,ICDC,ICDE,ICDF,ICDI,ICDM,ICDR,ICDT,ICDTY,Y
  1.  S ICDD=$P($G(X),".",1),ICD0="",ICDIMP=$$IMP^ICDEX(30),ICDTY="",ICDCS="" S:ICDD'?7N ICDD=$$DT^XLFDT
  1.  F ICDI=0 F  S ICDI=$O(^ICDS("F",80,ICDI)) Q:+ICDI'>0  D
  1.  . N ICDS,ICDSD S ICDS=$G(^ICDS(ICDI,0)),ICDSD=$P(ICDS,"^",4) Q:ICDSD'?7N
  1.  . S:ICDSD<(ICDD+.0001) ICDTY=$P($P(ICDS,"^",1)," ",1) S:$L(ICDTY,"-")=2 ICDTY=$P(ICDTY,"-",1,2)
  1.  S:'$L(ICDTY) ICDTY="ICD" S DIR("A")=" Select ICD Code Type:  " S ICDDIR=$$TRIM($G(ICDDIR))
  1.  S DIR("A",1)=" Select one of the following:"
  1.  S:$L($G(ICDDIR)) DIR("A",1)=" "_$G(ICDDIR) K ICDDIR
  1.  S DIR("A",2)=" "
  1.  S DIR("A",3)="     1   "_ICDTY_" Diagnosis Code"
  1.  S DIR("A",4)="     2   "_ICDTY_" Operations/Procedures Code"
  1.  S DIR("A",5)=" "
  1.  S DIR(0)="NAO^1:2:0"
  1.  S DIR("PRE")="S:X[""?"" X=""??""",(DIR("?"),DIR("??"))="^D DPH^ICDEXA3"
  1.  D ^DIR Q:'$L($G(X)) "-1^No Selection"  Q:$D(DIROUT) "^^" Q:$D(DTOUT)!($D(DUOUT)) "^"
  1.  S:"^80^80.1^"[("^"_ICDO_"^") X=ICDO
  1.  Q X
  1. DPH ; File Help
  1.  W !,?5,"This response must be a number from 1 to 2."
  1.  Q
  1.  ;
  1. FIT(FILE,FMT) ; File Input Transform
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;   FILE  File number or identifier
  1.  ;   FMT   Format
  1.  ;           
  1.  ;           0  Fileman DIR format (default)
  1.  ;           1 - File number 80 or 80.1 or null
  1.  ;
  1.  ; Output:
  1.  ; 
  1.  ;   X     Fileman output format 1, 2, ??, ^ or ^^
  1.  ;         File number output format 80, 80.1 or null
  1.  ;
  1.  N ICDF,ICDT,ICDO S ICDF=$G(FILE),ICDT=+($G(FMT)) Q:'ICDT&(ICDF["^^") "^^"  Q:'ICDT&(ICDF["^") "^"
  1.  S ICDO="" S:ICDF["?" ICDO="??" Q:'ICDT&($L(ICDO)) ICDO
  1.  S:ICDF="80"!(ICDF="1")!(ICDF="30")!(ICDF["ICD9")!(ICDF["ICD-9")!(ICDF["DX")!(ICDF["DIAG")!(ICDF="ICD")!(ICDF="10D") ICDO=1
  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
  1.  S:ICDT ICDO=$S(ICDO=1:80,ICDO=2:80.1,1:"")
  1.  Q ICDO
  1. TRIM(X,Y) ; Trim Character
  1.  S X=$G(X) Q:X="" X  S Y=$G(Y) S:'$L(Y) Y=" "
  1.  F  Q:$E(X,1)'=Y  S X=$E(X,2,$L(X))
  1.  F  Q:$E(X,$L(X))'=Y  S X=$E(X,1,($L(X)-1))
  1.  Q X