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

ICDEXD2.m

Go to the documentation of this file. 
  1. ICDEXD2 ;SLC/KER - ICD Extractor - DRG APIs (cont) ;04/21/2014
  1.  ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^ICDS(              N/A
  1.  ;               
  1.  ; External References
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$FMADD^XLFDT       ICR  10103
  1.  ;    $$FMTE^XLFDT        ICR  10103
  1.  ;    ^%DT                ICR  10003
  1.  ;    ^DIR                ICR  10026
  1.  ;               
  1.  Q
  1. MD(FILE,IEN,CDT,ARY,FLAG) ; MDC DRGs
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;    FILE   File Number/Identifier
  1.  ;    IEN    Internal entry in file
  1.  ;    CDT    Code Set Versioning Date
  1.  ;   .ARY    Array name passed by reference
  1.  ;    FLAG   Flag   I=Internal (default)
  1.  ;                  E=External
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   ICD Procedures file 80.1 (multiple MDC)
  1.  ;   
  1.  ;      ARY(<fiscal year>,<MDC>)=DRG^;FY;STA
  1.  ;      ARY(<fiscal year>,<MDC>)="DRG^DRG^;FY;STA
  1.  ;   
  1.  ;      If Flag contains "E"
  1.  ;      ARY(<fiscal year>,"E",<MDC>)=MDC Name
  1.  ;      ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
  1.  ;      ARY(<fiscal year>,"E",<MDC>)=MDC Name
  1.  ;      ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
  1.  ;      ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
  1.  ;      ARY(<fiscal year>,"E","FY")=External FY
  1.  ;   
  1.  ;   ICD Diagnosis file 80 (single MDC)
  1.  ;   
  1.  ;      ARY(<fiscal year>,<MDC>)="DRG^DRG^;FY;STA
  1.  ;   
  1.  ;      If Flag contains "E"
  1.  ;      ARY(<fiscal year>,"E",<MDC>)=MDC Name
  1.  ;      ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
  1.  ;      ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
  1.  ;      ARY(<fiscal year>,"E","FY")=External FY
  1.  ;   
  1.  ;   NOTE:  If no Fiscal Year found for the input 
  1.  ;   date then the first (earliest) Fiscal Year is 
  1.  ;   used.
  1.  ;
  1.  N DRG,FY,FYIEN,MDC,MDCIEN,MY,MYIEN,ROOT,STA,STR S FLAG=$G(FLAG) S:'$L(FLAG) FLAG="I"
  1.  S FILE=$G(FILE) S:FILE=9!(FILE["ICD9") FILE=80  S:FILE=0!(FILE["ICD0") FILE=80.1
  1.  Q:"^80^80.1^"'[("^"_FILE_"^") "-1;Invalid file selected"
  1.  S IEN=+($G(IEN)),CDT=$P($G(CDT),".",1)
  1.  S ROOT=$$ROOT^ICDEX(FILE) S:CDT'?7N CDT=$$DT^XLFDT
  1.  Q:'$L(ROOT) "-1;Invalid file selected"
  1.  K ARY I FILE=80.1 D
  1.  . S STA=1,FY=$O(^ICD0(IEN,2,"B",(CDT+.001)),-1)
  1.  . S:FY'?7N STA=0,FY=$O(^ICD0(IEN,2,"B","")) Q:FY'?7N
  1.  . S FYIEN=$O(^ICD0(IEN,2,"B",+$G(FY),0)) Q:+FYIEN'>0
  1.  . S MDC=0 F  S MDC=$O(^ICD0(IEN,2,FYIEN,1,"B",MDC)) Q:'$L(MDC)  D
  1.  . . S MDCIEN=0 F  S MDCIEN=$O(^ICD0(IEN,2,FYIEN,1,"B",MDC,MDCIEN)) Q:+MDCIEN'>0  D
  1.  . . . S STR="",DRG=""
  1.  . . . F  S DRG=$O(^ICD0(IEN,2,FYIEN,1,MDCIEN,1,"B",DRG)) Q:'$L(DRG)  S STR=STR_DRG_"^"
  1.  . . S ARY(FY,MDC)=STR_";"_FY_";"_STA
  1.  . . I FLAG["E" D
  1.  . . . N ED,EMDC,DRGI,IDRG,DRGOUT
  1.  . . . S ED=$$FMTE^XLFDT(FY,"5DZ"),EMDC=$P($G(^ICM(+MDC,0)),"^",1)
  1.  . . . S ARY(FY,"E","FY")=ED,ARY(FY,"E",MDC)=EMDC
  1.  . . . F DRGI=1:1 Q:'$L($P($G(STR),"^",DRGI))  D
  1.  . . . . N IDRG,DRGOUT S IDRG=$P($G(STR),"^",DRGI) Q:+IDRG'>0
  1.  . . . . K DRGOUT D DRGD^ICDGTDRG(IDRG,"DRGOUT",,$G(CDT))
  1.  . . . . S:$L($G(DRGOUT(1)))&(+DRGI>0) ARY(FY,"E",MDC,IDRG)=$G(DRGOUT(1))
  1.  I FILE=80 D
  1.  . S STA=1,FY=$O(^ICD9(IEN,3,"B",(CDT+.001)),-1)
  1.  . S:FY'?7N STA=0,FY=$O(^ICD9(IEN,3,"B","")) Q:FY'?7N
  1.  . S MY=$O(^ICD9(IEN,4,"B",(FY+.001)))
  1.  . S:MY'?7N MY=$O(^ICD9(IEN,4,"B",""))
  1.  . S MYIEN=$O(^ICD9(IEN,4,"B",+$G(MY),0))
  1.  . S MDC=$P($G(^ICD9(IEN,4,+MYIEN,0)),"^",2)
  1.  . S FYIEN=$O(^ICD9(IEN,3,"B",+$G(FY),0)) Q:+FYIEN'>0
  1.  . S STR="",DRG=""
  1.  . F  S DRG=$O(^ICD9(IEN,3,FYIEN,1,"B",DRG)) Q:'$L(DRG)  S STR=STR_DRG_"^"
  1.  . I +MDC'>0 S MDC=$$DRGMDC^ICDEXD(+STR)
  1.  . S ARY(FY,MDC)=STR_";"_FY_";"_STA
  1.  . I FLAG["E" D
  1.  . . N ED,EMDC,DRGI,IDRG,DRGOUT
  1.  . . S ED=$$FMTE^XLFDT(FY,"5DZ"),EMDC=$P($G(^ICM(+MDC,0)),"^",1)
  1.  . . S ARY(FY,"E","FY")=ED,ARY(FY,"E",MDC)=EMDC
  1.  . . F DRGI=1:1 Q:'$L($P($G(STR),"^",DRGI))  D
  1.  . . . N IDRG,DRGOUT S IDRG=$P($G(STR),"^",DRGI) Q:+IDRG'>0
  1.  . . . K DRGOUT D DRGD^ICDGTDRG(IDRG,"DRGOUT",,$G(CDT))
  1.  . . . S:$L($G(DRGOUT(1)))&(+DRGI>0) ARY(FY,"E",MDC,IDRG)=$G(DRGOUT(1))
  1.  Q
  1. VMDCDX(IEN,CDT) ; Get versioned MDC for Diagnosis Code
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;    IEN    Internal Entry Number file 80
  1.  ;    CDT    Code Set Versioning Date
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   $$VMDCDX  Versioned MDC
  1.  ;
  1.  N ICDI,ICDD,ICDS,ICDM,ICDY S ICDI=+($G(IEN)) Q:'$D(^ICD9(ICDI,4,"B")) ""
  1.  S ICDS=$P($G(^ICD9(+ICDI,1)),"^",1),ICDD=$$DTBR^ICDEX($G(CDT),0,ICDS)
  1.  S (ICDM,ICDY)="",ICDY=$O(^ICD9(+ICDI,4,"B",+ICDD),-1)
  1.  S ICDM=$O(^ICD9(ICDI,4,"B",+ICDY,ICDM))
  1.  Q $P($G(^ICD9(ICDI,4,+ICDM,0)),U,2)
  1. VMDCOP(IEN,MDC,CDT) ; Get versioned MDC for Op/Pro ICD code from previous years
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;    IEN    Internal Entry Number file 80.1
  1.  ;    MDC    Major Diagnostic Category
  1.  ;    CDT    Code Set Versioning Date
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;   $$VMDCOP  4 piece "^" delimited string
  1.  ;
  1.  ;             1   Fiscal Year  Fileman format
  1.  ;             2   MDC          Pointer to file 80.3
  1.  ;             3   Fiscal Year  pointer to sub-file 80.171
  1.  ;                              (formerly known as DADRGFY)
  1.  ;             4   MDC          pointer to sub-file 80.1711
  1.  ;                                (formerly known as DAMDC)
  1.  ;
  1.  N ICDI,ICDC,ICDD,ICDO,ICDY,ICDM,ICDS S ICDI=+($G(IEN)) Q:'$D(^ICD0(ICDI,2,"B")) ""
  1.  S ICDC=$G(MDC) Q:'$L(MDC) ""  S ICDS=$P($G(^ICD0(+ICDI,1)),"^",1)
  1.  S ICDD=$$DTBR^ICDEX($G(CDT),0,ICDS) S (ICDM,ICDY)=""
  1.  F  S ICDD=$O(^ICD0(ICDI,2,"B",ICDD),-1) Q:'ICDD!(ICDM>0)  D
  1.  . S ICDY=$O(^ICD0(ICDI,2,"B",+$G(ICDD),ICDY)),ICDO=ICDD
  1.  . S ICDM=$O(^ICD0(ICDI,2,+ICDY,1,"B",ICDC,ICDM))
  1.  Q:'$L($G(ICDO)) ""
  1.  Q (ICDO_"^"_ICDC_"^"_ICDY_"^"_ICDM)
  1.  ;
  1. MDCG(IEN,CDT,ARY) ; Set up ICDMDC() array
  1.  ;
  1.  ; Input
  1.  ;
  1.  ;    IEN    ICD Diagnosis (IEN)
  1.  ;    CDT    Code Set Versioning Date
  1.  ;   .ARY    Array name passed by reference
  1.  ;
  1.  ; Output
  1.  ;
  1.  ;    ARY    Array listing MDCs for all DRGs
  1.  ;
  1.  ;      ARY=MDC
  1.  ;      ARY(MDC)=""
  1.  ;
  1.  N I,ICDC,ICDO,ICDTMP,ICDS,ICDD,DRGS S IEN=$G(IEN) Q:+IEN'>0  S ICDS=$P($G(^ICD9(+IEN,1)),"^",1)
  1.  S ICDD=$$DTBR^ICDEX($G(CDT),0,ICDS) Q:'$L(IEN)  S ICDO=$G(ARY) K ARY S:$L(ICDO) ARY=ICDO
  1.  S ICDTMP=$$GETDRG^ICDEX(80,IEN,ICDD) Q:'$P(ICDTMP,";",3)  S DRGS=$P(ICDTMP,";")
  1.  F I=1:1 Q:'$L($P(DRGS,"^",I))  Q:'$P(DRGS,"^",I)  D
  1.  . N DRG,MDC S DRG=$P(DRGS,"^",I) Q:DRG=""  S MDC=$P($$DRG^ICDGTDRG(DRG,ICDD),"^",5) Q:MDC=""  S ARY(MDC)=""
  1.  Q
  1. MDCT(IEN,CDT,ARY,FMT) ; For Multiple MDC DX Codes
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;    IEN  Internal Entry Number for file 80.1
  1.  ;    CDT  Code Set Versioning Date
  1.  ;   .ARY  Array of MDCs passed by reference (required)
  1.  ;    FMT  Output Format (optional)
  1.  ;
  1.  ;           0   Boolean value only (default)
  1.  ;           1   2 piece "^" delimited string
  1.  ;                  1   Boolean value
  1.  ;                  2   String of matching MDCs delimited by ";"
  1.  ; Output:
  1.  ;
  1.  ;  $$MDCT  Boolean value
  1.  ;
  1.  ;           0  The ICD Procedure code identified by IEN
  1.  ;              does not include any of the MDCs passed 
  1.  ;              in .ARY(MDC) on the date specified (CDT)
  1.  ;
  1.  ;           1  The ICD Procedure code identified by IEN 
  1.  ;              includes one or more of the MDCs passed
  1.  ;              in .ARY(MDC) on the date specified (CDT)
  1.  ;
  1.  N FY,FYI,I,MD,MDC,OK,STR
  1.  S IEN=+($G(IEN)) Q:'$D(^ICD0(+IEN,0)) 0
  1.  Q:$P($G(^ICD0(IEN,1)),"^",7)>0 0
  1.  S CDT=$G(CDT) S:CDT'?7N CDT=$$DT^XLFDT
  1.  S FMT=+($G(FMT)),(STR,MD)="",OK=0 F I=1:1 S MD=$O(ARY(MD)) Q:MD=""  D
  1.  . N FY,FYI,MDC S FY=$O(^ICD0(IEN,2,"B",(+CDT+.001)),-1) Q:FY'?7N
  1.  . S FYI=$O(^ICD0(IEN,2,"B",+FY,0))
  1.  . S MDC=$D(^ICD0(IEN,2,+FYI,1,"B",MD))
  1.  . S:MDC>0 STR=STR_";"_MD
  1.  . S:MDC>0 OK=1
  1.  F  Q:$E(STR,1)'=";"  S STR=$E(STR,2,$L(STR))
  1.  S OK=+OK S:FMT>0&($L(STR)) OK=OK_"^"_STR
  1.  Q OK
  1. MDCD(IEN,MDC,CDT) ; Check for default MDC
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;    IEN  Internal Entry Number for file 80.1
  1.  ;    MDC  Major Diagnostic Category
  1.  ;    CDT  Code Set Versioning Date (optional)
  1.  ;         If not passed, the first FY is used
  1.  ;
  1.  ; Output:
  1.  ;
  1.  ;   $$MDCD  Boolean value
  1.  ;
  1.  ;           0  MDC Does not exist
  1.  ;           1  MDC Exist
  1.  ;
  1.  N ICDY,ICDM,ICDD,ICDF S ICDY=+($G(IEN)) Q:'$D(^ICD0(+IEN,2,1,1)) 0  S ICDM=$G(MDC) Q:'$L(ICDM) 0
  1.  S ICDD=$G(CDT),ICDF=$O(^ICD0(+ICDY,2,"B",(ICDD+.001)),-1) S:ICDF'?7N ICDF=$O(^ICD0(+ICDY,2,"B",""))
  1.  S ICDF=$O(^ICD0(+ICDY,2,"B",+ICDF,0)) Q:ICDF'>0 $S($D(^ICD0(ICDY,2,1,1,"B",ICDM))>0:1,1:0)
  1.  Q:ICDF>0 $S($D(^ICD0(ICDY,2,+ICDF,1,"B",ICDM))>0:1,1:0)
  1. MDCN(IEN) ; Major Diagnostic Category Name
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;    IEN    Internal Entry Number for file 80.3
  1.  ;
  1.  ; Output:
  1.  ;
  1.  ;   $$MDCN  Major Diagnostic Category Name
  1.  ;
  1.  ; Replaces ICR 1586
  1.  ; 
  1.  Q $P($G(^ICM(+($G(IEN)),0)),"^",1)
  1. MOR(IEN) ; Major O.R. Procedure
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;    IEN   Internal Entry Number for file 80.1
  1.  ;
  1.  ; Output:
  1.  ;
  1.  ;   $$MOR  Major O.R. Procedure
  1.  ;
  1.  Q $G(^ICD0(+($G(IEN)),"M"))
  1.  ;
  1. UPDX(IEN) ; Unacceptable as Principle DX
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;    IEN   Internal Entry Number for file 80
  1.  ;
  1.  ; Output:
  1.  ;
  1.  ;   $$UPDX  Boolean value only (default)
  1.  ;   
  1.  ;            0 No, Code is Acceptable as Principle DX
  1.  ;            1 Yes, Code is Unacceptable as Principle DX
  1.  ;
  1.  N ICDEXC S ICDEXC=$$EXC^ICDEX(80,+($G(IEN))) Q:+ICDEXC>0 1
  1.  Q +($P($G(^ICD9(+($G(IEN)),1)),"^",3))
  1. EFM(X) ; Convert External Date to FM
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;   X      External Date
  1.  ;
  1.  ; Output:
  1.  ;
  1.  ;   $$EFM  Internal Fileman Date
  1.  ;
  1.  ; Replaces unsupported $$DGY2K^DGPTOD0(X)
  1.  ;
  1.  N %DT,Y D ^%DT K %DT
  1.  Q Y
  1. FY(X) ;Return FY
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;   X      Internal Fileman Date
  1.  ;
  1.  ; Output:
  1.  ;
  1.  ;   $$FY   FY Year YYYY
  1.  ;
  1.  ; Replaces unsupported $$FY^DGPTOD0(X)
  1.  ; 
  1.  S X=$P($G(X),".",1) Q:$L(X)>7 ""  Q:$E(X,1,5)'?5N ""
  1.  S:$E(X,4,5)>9 X=$E(X,1,3)+1
  1.  Q (17+$E(X))_$E(X,2,3)
  1. EFD(X) ; Get Effective date in range (interactive)
  1.  ;
  1.  ; Prompts for Effective Date for DRG grouper
  1.  ; 
  1.  ; The lower boundary for the date is the ICD-9 
  1.  ; implementation date October 1, 1978.
  1.  ; 
  1.  ; The upper boundary for date is either
  1.  ; 
  1.  ;       3 years from the ICD-10 implementation date or
  1.  ;       3 years from TODAY
  1.  ;       
  1.  ;       Whichever is further into the future
  1.  ;
  1.  ; Input:   
  1.  ; 
  1.  ;   None
  1.  ;
  1.  ; Output:
  1.  ;
  1.  ;   $$EFF  3 piece ^ delimited string
  1.  ;   
  1.  ;          1   Date Fileman format         nnnnnnn
  1.  ;          2   Date External Short Format  mm/dd/yyyy
  1.  ;          3   Date External Long Format   Mmm dd, yyyy
  1.  ;
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDH,ICDI,ICDIMP,ICDT,Y
  1.  S ICDT=$$DT^XLFDT,ICDH="",ICDI=0
  1.  F  S ICDI=$O(^ICDS(ICDI)) Q:+ICDI'>0  D
  1.  . N ICDIMP S ICDIMP=$P($G(^ICDS(ICDI,0)),"^",3)
  1.  . S:ICDIMP>ICDH ICDH=ICDIMP
  1.  S:ICDT>ICDH ICDH=ICDT S ICDH=$$FMADD^XLFDT(ICDH,1095)
  1.  S DIR(0)="DAO^2781001:"_ICDH_":AEX"
  1.  S DIR("B")="TODAY",DIR("A")=" Effective Date:  " I ICDH?7N D 
  1.  . S DIR("A")=" Effective Date ("_$$FMTE^XLFDT(2781001,"5Z")
  1.  . S DIR("A")=DIR("A")_" to "_$$FMTE^XLFDT($G(ICDH),"5Z")_"):  "
  1.  S DIR("PRE")="S:X[""?"" X=""??""",(DIR("?"),DIR("??"))="^D EFFH^ICDEXD"
  1.  D ^DIR Q:$D(DIROUT) "^^"  Q:$D(DIRUT) "^"  Q:$D(DTOUT) ""
  1.  S X=Y S:X?7N X=X_"^"_$$FMTE^XLFDT(X,"5Z")_"^"_$$FMTE^XLFDT(X)
  1.  Q X
  1. EFFH ; Effective Date Help
  1.  I $L($G(ICDH)) D
  1.  . W !,?5,"Enter an effective date from ",$$FMTE^XLFDT(2781001,"5Z")
  1.  . W " to ",$$FMTE^XLFDT($G(ICDH),"5Z")
  1.  . W !,?5,"to be used to select or calculated time sensitive data.",!
  1.  W !,?5,"Examples of Valid Dates:"
  1.  W !,?5,"  JAN 20 1980 or 20 JAN 80 or 1/20/57 or 012080"
  1.  W !,?5,"  T   (for TODAY),  T+1 (for TOMORROW),  T+2,  T+7, etc."
  1.  W !,?5,"  T-1 (for YESTERDAY),  T-3W (for 3 WEEKS AGO), etc."
  1.  W !,?5,"If the year is omitted, the computer uses CURRENT YEAR. "
  1.  W !,?5,"Two digit year assumes no more than 20 years in the future,"
  1.  W !,?5," or 80 years in the past."
  1.  Q
  1. ISVALID(FILE,IEN,CDT) ; Is an ICD code Valid
  1.  ;
  1.  ; Input:
  1.  ; 
  1.  ;    FILE        File or global root
  1.  ;    IEN         Internal Entry Number
  1.  ;    CDT         Effective date to use (default TODAY)
  1.  ;
  1.  ; Output:
  1.  ; 
  1.  ;    $$ISVALID   This is a Boolean value
  1.  ;  
  1.  ;                  1 if the code is valid
  1.  ;                  0 if the code is not valid
  1.  ;
  1.  N ICDO,ICDD,ICDF,ICDT,ICDX,ICDI,ICDR S ICDO=0
  1.  S FILE=$S(FILE="9":80,FILE="0":80.1,1:FILE)
  1.  S ICDD=$P($G(CDT),".",1) S:ICDD'?7N ICDD=$$DT^XLFDT
  1.  S ICDF=$$FILE^ICDEX(FILE) Q:"^80^80.1^"'[("^"_FILE_"^") ICDO
  1.  S ICDR=$$ROOT^ICDEX(FILE),ICDI=+($G(IEN))
  1.  Q:+ICDI'>0 ICDO  Q:'$D(@(ICDR_+ICDI_",0)")) ICDO
  1.  S ICDX=$$EXC^ICDEX(ICDF,ICDI) Q:ICDX>0 ICDO
  1.  ;I ICDF=80.1 S ICDT=$$ICDOP^ICDCODE(ICDI,ICDD,,"I") I ICDT>0,$P(ICDT,U,10) S ICDO=1  ;IHS/OIT/FBD&NKD - ORIGINAL LINE - COMMENTD OUT
  1.  ;I ICDF=80 S ICDT=$$ICDDX^ICDEX(ICDI,ICDD,,"I") I ICDT>0,$P(ICDT,U,10) S ICDO=1  ;IHS/OIT/FBD&NKD - ORIGINAL LINE - COMMENTD OUT
  1.  S:(+$P($$SAI^ICDEX(ICDF,ICDI,ICDD),"^")>0) ICDO=1 ;IHS/OIT/FBD&NKD REPLACED ICDDX/ICDOP CALLS WITH SAI
  1.  Q ICDO
  1. REF(IEN,CDT) ; Return Reference Table
  1.  ;
  1.  ;  Input:
  1.  ;  
  1.  ;    IEN    Internal Entry Number
  1.  ;    CDT    Effective date to use (default TODAY)
  1.  ;
  1.  ;  Output:
  1.  ;  
  1.  ;    $$REF  Table reference associated DRG entry
  1.  ;           or null if not found
  1.  ; 
  1.  N ICDI,ICDD,ICDR,ICDFY,ICDR
  1.  S ICDI=+($G(IEN)) Q:+IEN'>0!('$D(^ICD(IEN,2))) ""
  1.  S (ICDFY,ICDR)="",ICDD=$P($G(CDT),".",1)
  1.  S:ICDD'?7N ICDD=$$DT^XLFDT
  1.  S ICDFY=$O(^ICD(ICDI,2,"B",(+ICDD+.01)),-1)
  1.  S ICDR=$O(^ICD(ICDI,2,"B",+ICDFY,ICDR))
  1.  S ICDR=$P($G(^ICD(ICDI,2,+ICDR,0)),U,3)
  1.  Q ICDR