ICDEXD2 ;SLC/KER - ICD Extractor - DRG APIs (cont) ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
;
; Global Variables
; ^ICDS( N/A
;
; External References
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; ^%DT ICR 10003
; ^DIR ICR 10026
;
Q
MD(FILE,IEN,CDT,ARY,FLAG) ; MDC DRGs
;
; Input
;
; FILE File Number/Identifier
; IEN Internal entry in file
; CDT Code Set Versioning Date
; .ARY Array name passed by reference
; FLAG Flag I=Internal (default)
; E=External
;
; Output
;
; ICD Procedures file 80.1 (multiple MDC)
;
; ARY(<fiscal year>,<MDC>)=DRG^;FY;STA
; ARY(<fiscal year>,<MDC>)="DRG^DRG^;FY;STA
;
; If Flag contains "E"
; ARY(<fiscal year>,"E",<MDC>)=MDC Name
; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
; ARY(<fiscal year>,"E",<MDC>)=MDC Name
; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
; ARY(<fiscal year>,"E","FY")=External FY
;
; ICD Diagnosis file 80 (single MDC)
;
; ARY(<fiscal year>,<MDC>)="DRG^DRG^;FY;STA
;
; If Flag contains "E"
; ARY(<fiscal year>,"E",<MDC>)=MDC Name
; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
; ARY(<fiscal year>,"E","FY")=External FY
;
; NOTE: If no Fiscal Year found for the input
; date then the first (earliest) Fiscal Year is
; used.
;
N DRG,FY,FYIEN,MDC,MDCIEN,MY,MYIEN,ROOT,STA,STR S FLAG=$G(FLAG) S:'$L(FLAG) FLAG="I"
S FILE=$G(FILE) S:FILE=9!(FILE["ICD9") FILE=80 S:FILE=0!(FILE["ICD0") FILE=80.1
Q:"^80^80.1^"'[("^"_FILE_"^") "-1;Invalid file selected"
S IEN=+($G(IEN)),CDT=$P($G(CDT),".",1)
S ROOT=$$ROOT^ICDEX(FILE) S:CDT'?7N CDT=$$DT^XLFDT
Q:'$L(ROOT) "-1;Invalid file selected"
K ARY I FILE=80.1 D
. S STA=1,FY=$O(^ICD0(IEN,2,"B",(CDT+.001)),-1)
. S:FY'?7N STA=0,FY=$O(^ICD0(IEN,2,"B","")) Q:FY'?7N
. S FYIEN=$O(^ICD0(IEN,2,"B",+$G(FY),0)) Q:+FYIEN'>0
. S MDC=0 F S MDC=$O(^ICD0(IEN,2,FYIEN,1,"B",MDC)) Q:'$L(MDC) D
. . S MDCIEN=0 F S MDCIEN=$O(^ICD0(IEN,2,FYIEN,1,"B",MDC,MDCIEN)) Q:+MDCIEN'>0 D
. . . S STR="",DRG=""
. . . F S DRG=$O(^ICD0(IEN,2,FYIEN,1,MDCIEN,1,"B",DRG)) Q:'$L(DRG) S STR=STR_DRG_"^"
. . S ARY(FY,MDC)=STR_";"_FY_";"_STA
. . I FLAG["E" D
. . . N ED,EMDC,DRGI,IDRG,DRGOUT
. . . S ED=$$FMTE^XLFDT(FY,"5DZ"),EMDC=$P($G(^ICM(+MDC,0)),"^",1)
. . . S ARY(FY,"E","FY")=ED,ARY(FY,"E",MDC)=EMDC
. . . F DRGI=1:1 Q:'$L($P($G(STR),"^",DRGI)) D
. . . . N IDRG,DRGOUT S IDRG=$P($G(STR),"^",DRGI) Q:+IDRG'>0
. . . . K DRGOUT D DRGD^ICDGTDRG(IDRG,"DRGOUT",,$G(CDT))
. . . . S:$L($G(DRGOUT(1)))&(+DRGI>0) ARY(FY,"E",MDC,IDRG)=$G(DRGOUT(1))
I FILE=80 D
. S STA=1,FY=$O(^ICD9(IEN,3,"B",(CDT+.001)),-1)
. S:FY'?7N STA=0,FY=$O(^ICD9(IEN,3,"B","")) Q:FY'?7N
. S MY=$O(^ICD9(IEN,4,"B",(FY+.001)))
. S:MY'?7N MY=$O(^ICD9(IEN,4,"B",""))
. S MYIEN=$O(^ICD9(IEN,4,"B",+$G(MY),0))
. S MDC=$P($G(^ICD9(IEN,4,+MYIEN,0)),"^",2)
. S FYIEN=$O(^ICD9(IEN,3,"B",+$G(FY),0)) Q:+FYIEN'>0
. S STR="",DRG=""
. F S DRG=$O(^ICD9(IEN,3,FYIEN,1,"B",DRG)) Q:'$L(DRG) S STR=STR_DRG_"^"
. I +MDC'>0 S MDC=$$DRGMDC^ICDEXD(+STR)
. S ARY(FY,MDC)=STR_";"_FY_";"_STA
. I FLAG["E" D
. . N ED,EMDC,DRGI,IDRG,DRGOUT
. . S ED=$$FMTE^XLFDT(FY,"5DZ"),EMDC=$P($G(^ICM(+MDC,0)),"^",1)
. . S ARY(FY,"E","FY")=ED,ARY(FY,"E",MDC)=EMDC
. . F DRGI=1:1 Q:'$L($P($G(STR),"^",DRGI)) D
. . . N IDRG,DRGOUT S IDRG=$P($G(STR),"^",DRGI) Q:+IDRG'>0
. . . K DRGOUT D DRGD^ICDGTDRG(IDRG,"DRGOUT",,$G(CDT))
. . . S:$L($G(DRGOUT(1)))&(+DRGI>0) ARY(FY,"E",MDC,IDRG)=$G(DRGOUT(1))
Q
VMDCDX(IEN,CDT) ; Get versioned MDC for Diagnosis Code
;
; Input
;
; IEN Internal Entry Number file 80
; CDT Code Set Versioning Date
;
; Output
;
; $$VMDCDX Versioned MDC
;
N ICDI,ICDD,ICDS,ICDM,ICDY S ICDI=+($G(IEN)) Q:'$D(^ICD9(ICDI,4,"B")) ""
S ICDS=$P($G(^ICD9(+ICDI,1)),"^",1),ICDD=$$DTBR^ICDEX($G(CDT),0,ICDS)
S (ICDM,ICDY)="",ICDY=$O(^ICD9(+ICDI,4,"B",+ICDD),-1)
S ICDM=$O(^ICD9(ICDI,4,"B",+ICDY,ICDM))
Q $P($G(^ICD9(ICDI,4,+ICDM,0)),U,2)
VMDCOP(IEN,MDC,CDT) ; Get versioned MDC for Op/Pro ICD code from previous years
;
; Input
;
; IEN Internal Entry Number file 80.1
; MDC Major Diagnostic Category
; CDT Code Set Versioning Date
;
; Output
;
; $$VMDCOP 4 piece "^" delimited string
;
; 1 Fiscal Year Fileman format
; 2 MDC Pointer to file 80.3
; 3 Fiscal Year pointer to sub-file 80.171
; (formerly known as DADRGFY)
; 4 MDC pointer to sub-file 80.1711
; (formerly known as DAMDC)
;
N ICDI,ICDC,ICDD,ICDO,ICDY,ICDM,ICDS S ICDI=+($G(IEN)) Q:'$D(^ICD0(ICDI,2,"B")) ""
S ICDC=$G(MDC) Q:'$L(MDC) "" S ICDS=$P($G(^ICD0(+ICDI,1)),"^",1)
S ICDD=$$DTBR^ICDEX($G(CDT),0,ICDS) S (ICDM,ICDY)=""
F S ICDD=$O(^ICD0(ICDI,2,"B",ICDD),-1) Q:'ICDD!(ICDM>0) D
. S ICDY=$O(^ICD0(ICDI,2,"B",+$G(ICDD),ICDY)),ICDO=ICDD
. S ICDM=$O(^ICD0(ICDI,2,+ICDY,1,"B",ICDC,ICDM))
Q:'$L($G(ICDO)) ""
Q (ICDO_"^"_ICDC_"^"_ICDY_"^"_ICDM)
;
MDCG(IEN,CDT,ARY) ; Set up ICDMDC() array
;
; Input
;
; IEN ICD Diagnosis (IEN)
; CDT Code Set Versioning Date
; .ARY Array name passed by reference
;
; Output
;
; ARY Array listing MDCs for all DRGs
;
; ARY=MDC
; ARY(MDC)=""
;
N I,ICDC,ICDO,ICDTMP,ICDS,ICDD,DRGS S IEN=$G(IEN) Q:+IEN'>0 S ICDS=$P($G(^ICD9(+IEN,1)),"^",1)
S ICDD=$$DTBR^ICDEX($G(CDT),0,ICDS) Q:'$L(IEN) S ICDO=$G(ARY) K ARY S:$L(ICDO) ARY=ICDO
S ICDTMP=$$GETDRG^ICDEX(80,IEN,ICDD) Q:'$P(ICDTMP,";",3) S DRGS=$P(ICDTMP,";")
F I=1:1 Q:'$L($P(DRGS,"^",I)) Q:'$P(DRGS,"^",I) D
. N DRG,MDC S DRG=$P(DRGS,"^",I) Q:DRG="" S MDC=$P($$DRG^ICDGTDRG(DRG,ICDD),"^",5) Q:MDC="" S ARY(MDC)=""
Q
MDCT(IEN,CDT,ARY,FMT) ; For Multiple MDC DX Codes
;
; Input:
;
; IEN Internal Entry Number for file 80.1
; CDT Code Set Versioning Date
; .ARY Array of MDCs passed by reference (required)
; FMT Output Format (optional)
;
; 0 Boolean value only (default)
; 1 2 piece "^" delimited string
; 1 Boolean value
; 2 String of matching MDCs delimited by ";"
; Output:
;
; $$MDCT Boolean value
;
; 0 The ICD Procedure code identified by IEN
; does not include any of the MDCs passed
; in .ARY(MDC) on the date specified (CDT)
;
; 1 The ICD Procedure code identified by IEN
; includes one or more of the MDCs passed
; in .ARY(MDC) on the date specified (CDT)
;
N FY,FYI,I,MD,MDC,OK,STR
S IEN=+($G(IEN)) Q:'$D(^ICD0(+IEN,0)) 0
Q:$P($G(^ICD0(IEN,1)),"^",7)>0 0
S CDT=$G(CDT) S:CDT'?7N CDT=$$DT^XLFDT
S FMT=+($G(FMT)),(STR,MD)="",OK=0 F I=1:1 S MD=$O(ARY(MD)) Q:MD="" D
. N FY,FYI,MDC S FY=$O(^ICD0(IEN,2,"B",(+CDT+.001)),-1) Q:FY'?7N
. S FYI=$O(^ICD0(IEN,2,"B",+FY,0))
. S MDC=$D(^ICD0(IEN,2,+FYI,1,"B",MD))
. S:MDC>0 STR=STR_";"_MD
. S:MDC>0 OK=1
F Q:$E(STR,1)'=";" S STR=$E(STR,2,$L(STR))
S OK=+OK S:FMT>0&($L(STR)) OK=OK_"^"_STR
Q OK
MDCD(IEN,MDC,CDT) ; Check for default MDC
;
; Input:
;
; IEN Internal Entry Number for file 80.1
; MDC Major Diagnostic Category
; CDT Code Set Versioning Date (optional)
; If not passed, the first FY is used
;
; Output:
;
; $$MDCD Boolean value
;
; 0 MDC Does not exist
; 1 MDC Exist
;
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
S ICDD=$G(CDT),ICDF=$O(^ICD0(+ICDY,2,"B",(ICDD+.001)),-1) S:ICDF'?7N ICDF=$O(^ICD0(+ICDY,2,"B",""))
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)
Q:ICDF>0 $S($D(^ICD0(ICDY,2,+ICDF,1,"B",ICDM))>0:1,1:0)
MDCN(IEN) ; Major Diagnostic Category Name
;
; Input:
;
; IEN Internal Entry Number for file 80.3
;
; Output:
;
; $$MDCN Major Diagnostic Category Name
;
; Replaces ICR 1586
;
Q $P($G(^ICM(+($G(IEN)),0)),"^",1)
MOR(IEN) ; Major O.R. Procedure
;
; Input:
;
; IEN Internal Entry Number for file 80.1
;
; Output:
;
; $$MOR Major O.R. Procedure
;
Q $G(^ICD0(+($G(IEN)),"M"))
;
UPDX(IEN) ; Unacceptable as Principle DX
;
; Input:
;
; IEN Internal Entry Number for file 80
;
; Output:
;
; $$UPDX Boolean value only (default)
;
; 0 No, Code is Acceptable as Principle DX
; 1 Yes, Code is Unacceptable as Principle DX
;
N ICDEXC S ICDEXC=$$EXC^ICDEX(80,+($G(IEN))) Q:+ICDEXC>0 1
Q +($P($G(^ICD9(+($G(IEN)),1)),"^",3))
EFM(X) ; Convert External Date to FM
;
; Input:
;
; X External Date
;
; Output:
;
; $$EFM Internal Fileman Date
;
; Replaces unsupported $$DGY2K^DGPTOD0(X)
;
N %DT,Y D ^%DT K %DT
Q Y
FY(X) ;Return FY
;
; Input:
;
; X Internal Fileman Date
;
; Output:
;
; $$FY FY Year YYYY
;
; Replaces unsupported $$FY^DGPTOD0(X)
;
S X=$P($G(X),".",1) Q:$L(X)>7 "" Q:$E(X,1,5)'?5N ""
S:$E(X,4,5)>9 X=$E(X,1,3)+1
Q (17+$E(X))_$E(X,2,3)
EFD(X) ; Get Effective date in range (interactive)
;
; Prompts for Effective Date for DRG grouper
;
; The lower boundary for the date is the ICD-9
; implementation date October 1, 1978.
;
; The upper boundary for date is either
;
; 3 years from the ICD-10 implementation date or
; 3 years from TODAY
;
; Whichever is further into the future
;
; Input:
;
; None
;
; Output:
;
; $$EFF 3 piece ^ delimited string
;
; 1 Date Fileman format nnnnnnn
; 2 Date External Short Format mm/dd/yyyy
; 3 Date External Long Format Mmm dd, yyyy
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDH,ICDI,ICDIMP,ICDT,Y
S ICDT=$$DT^XLFDT,ICDH="",ICDI=0
F S ICDI=$O(^ICDS(ICDI)) Q:+ICDI'>0 D
. N ICDIMP S ICDIMP=$P($G(^ICDS(ICDI,0)),"^",3)
. S:ICDIMP>ICDH ICDH=ICDIMP
S:ICDT>ICDH ICDH=ICDT S ICDH=$$FMADD^XLFDT(ICDH,1095)
S DIR(0)="DAO^2781001:"_ICDH_":AEX"
S DIR("B")="TODAY",DIR("A")=" Effective Date: " I ICDH?7N D
. S DIR("A")=" Effective Date ("_$$FMTE^XLFDT(2781001,"5Z")
. S DIR("A")=DIR("A")_" to "_$$FMTE^XLFDT($G(ICDH),"5Z")_"): "
S DIR("PRE")="S:X[""?"" X=""??""",(DIR("?"),DIR("??"))="^D EFFH^ICDEXD"
D ^DIR Q:$D(DIROUT) "^^" Q:$D(DIRUT) "^" Q:$D(DTOUT) ""
S X=Y S:X?7N X=X_"^"_$$FMTE^XLFDT(X,"5Z")_"^"_$$FMTE^XLFDT(X)
Q X
EFFH ; Effective Date Help
I $L($G(ICDH)) D
. W !,?5,"Enter an effective date from ",$$FMTE^XLFDT(2781001,"5Z")
. W " to ",$$FMTE^XLFDT($G(ICDH),"5Z")
. W !,?5,"to be used to select or calculated time sensitive data.",!
W !,?5,"Examples of Valid Dates:"
W !,?5," JAN 20 1980 or 20 JAN 80 or 1/20/57 or 012080"
W !,?5," T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc."
W !,?5," T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
W !,?5,"If the year is omitted, the computer uses CURRENT YEAR. "
W !,?5,"Two digit year assumes no more than 20 years in the future,"
W !,?5," or 80 years in the past."
Q
ISVALID(FILE,IEN,CDT) ; Is an ICD code Valid
;
; Input:
;
; FILE File or global root
; IEN Internal Entry Number
; CDT Effective date to use (default TODAY)
;
; Output:
;
; $$ISVALID This is a Boolean value
;
; 1 if the code is valid
; 0 if the code is not valid
;
N ICDO,ICDD,ICDF,ICDT,ICDX,ICDI,ICDR S ICDO=0
S FILE=$S(FILE="9":80,FILE="0":80.1,1:FILE)
S ICDD=$P($G(CDT),".",1) S:ICDD'?7N ICDD=$$DT^XLFDT
S ICDF=$$FILE^ICDEX(FILE) Q:"^80^80.1^"'[("^"_FILE_"^") ICDO
S ICDR=$$ROOT^ICDEX(FILE),ICDI=+($G(IEN))
Q:+ICDI'>0 ICDO Q:'$D(@(ICDR_+ICDI_",0)")) ICDO
S ICDX=$$EXC^ICDEX(ICDF,ICDI) Q:ICDX>0 ICDO
;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
;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
S:(+$P($$SAI^ICDEX(ICDF,ICDI,ICDD),"^")>0) ICDO=1 ;IHS/OIT/FBD&NKD REPLACED ICDDX/ICDOP CALLS WITH SAI
Q ICDO
REF(IEN,CDT) ; Return Reference Table
;
; Input:
;
; IEN Internal Entry Number
; CDT Effective date to use (default TODAY)
;
; Output:
;
; $$REF Table reference associated DRG entry
; or null if not found
;
N ICDI,ICDD,ICDR,ICDFY,ICDR
S ICDI=+($G(IEN)) Q:+IEN'>0!('$D(^ICD(IEN,2))) ""
S (ICDFY,ICDR)="",ICDD=$P($G(CDT),".",1)
S:ICDD'?7N ICDD=$$DT^XLFDT
S ICDFY=$O(^ICD(ICDI,2,"B",(+ICDD+.01)),-1)
S ICDR=$O(^ICD(ICDI,2,"B",+ICDFY,ICDR))
S ICDR=$P($G(^ICD(ICDI,2,+ICDR,0)),U,3)
Q ICDR
ICDEXD2 ;SLC/KER - ICD Extractor - DRG APIs (cont) ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
+2 ;
+3 ; Global Variables
+4 ; ^ICDS( N/A
+5 ;
+6 ; External References
+7 ; $$DT^XLFDT ICR 10103
+8 ; $$FMADD^XLFDT ICR 10103
+9 ; $$FMTE^XLFDT ICR 10103
+10 ; ^%DT ICR 10003
+11 ; ^DIR ICR 10026
+12 ;
+13 QUIT
MD(FILE,IEN,CDT,ARY,FLAG) ; MDC DRGs
+1 ;
+2 ; Input
+3 ;
+4 ; FILE File Number/Identifier
+5 ; IEN Internal entry in file
+6 ; CDT Code Set Versioning Date
+7 ; .ARY Array name passed by reference
+8 ; FLAG Flag I=Internal (default)
+9 ; E=External
+10 ;
+11 ; Output
+12 ;
+13 ; ICD Procedures file 80.1 (multiple MDC)
+14 ;
+15 ; ARY(<fiscal year>,<MDC>)=DRG^;FY;STA
+16 ; ARY(<fiscal year>,<MDC>)="DRG^DRG^;FY;STA
+17 ;
+18 ; If Flag contains "E"
+19 ; ARY(<fiscal year>,"E",<MDC>)=MDC Name
+20 ; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
+21 ; ARY(<fiscal year>,"E",<MDC>)=MDC Name
+22 ; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
+23 ; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
+24 ; ARY(<fiscal year>,"E","FY")=External FY
+25 ;
+26 ; ICD Diagnosis file 80 (single MDC)
+27 ;
+28 ; ARY(<fiscal year>,<MDC>)="DRG^DRG^;FY;STA
+29 ;
+30 ; If Flag contains "E"
+31 ; ARY(<fiscal year>,"E",<MDC>)=MDC Name
+32 ; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
+33 ; ARY(<fiscal year>,"E",<MDC>,<DRG>)=DRG Name
+34 ; ARY(<fiscal year>,"E","FY")=External FY
+35 ;
+36 ; NOTE: If no Fiscal Year found for the input
+37 ; date then the first (earliest) Fiscal Year is
+38 ; used.
+39 ;
+40 NEW DRG,FY,FYIEN,MDC,MDCIEN,MY,MYIEN,ROOT,STA,STR
SET FLAG=$GET(FLAG)
IF '$LENGTH(FLAG)
SET FLAG="I"
+41 SET FILE=$GET(FILE)
IF FILE=9!(FILE["ICD9")
SET FILE=80
IF FILE=0!(FILE["ICD0")
SET FILE=80.1
+42 IF "^80^80.1^"'[("^"_FILE_"^")
QUIT "-1;Invalid file selected"
+43 SET IEN=+($GET(IEN))
SET CDT=$PIECE($GET(CDT),".",1)
+44 SET ROOT=$$ROOT^ICDEX(FILE)
IF CDT'?7N
SET CDT=$$DT^XLFDT
+45 IF '$LENGTH(ROOT)
QUIT "-1;Invalid file selected"
+46 KILL ARY
IF FILE=80.1
Begin DoDot:1
+47 SET STA=1
SET FY=$ORDER(^ICD0(IEN,2,"B",(CDT+.001)),-1)
+48 IF FY'?7N
SET STA=0
SET FY=$ORDER(^ICD0(IEN,2,"B",""))
IF FY'?7N
QUIT
+49 SET FYIEN=$ORDER(^ICD0(IEN,2,"B",+$GET(FY),0))
IF +FYIEN'>0
QUIT
+50 SET MDC=0
FOR
SET MDC=$ORDER(^ICD0(IEN,2,FYIEN,1,"B",MDC))
IF '$LENGTH(MDC)
QUIT
Begin DoDot:2
+51 SET MDCIEN=0
FOR
SET MDCIEN=$ORDER(^ICD0(IEN,2,FYIEN,1,"B",MDC,MDCIEN))
IF +MDCIEN'>0
QUIT
Begin DoDot:3
+52 SET STR=""
SET DRG=""
+53 FOR
SET DRG=$ORDER(^ICD0(IEN,2,FYIEN,1,MDCIEN,1,"B",DRG))
IF '$LENGTH(DRG)
QUIT
SET STR=STR_DRG_"^"
End DoDot:3
+54 SET ARY(FY,MDC)=STR_";"_FY_";"_STA
+55 IF FLAG["E"
Begin DoDot:3
+56 NEW ED,EMDC,DRGI,IDRG,DRGOUT
+57 SET ED=$$FMTE^XLFDT(FY,"5DZ")
SET EMDC=$PIECE($GET(^ICM(+MDC,0)),"^",1)
+58 SET ARY(FY,"E","FY")=ED
SET ARY(FY,"E",MDC)=EMDC
+59 FOR DRGI=1:1
IF '$LENGTH($PIECE($GET(STR),"^",DRGI))
QUIT
Begin DoDot:4
+60 NEW IDRG,DRGOUT
SET IDRG=$PIECE($GET(STR),"^",DRGI)
IF +IDRG'>0
QUIT
+61 KILL DRGOUT
DO DRGD^ICDGTDRG(IDRG,"DRGOUT",,$GET(CDT))
+62 IF $LENGTH($GET(DRGOUT(1)))&(+DRGI>0)
SET ARY(FY,"E",MDC,IDRG)=$GET(DRGOUT(1))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+63 IF FILE=80
Begin DoDot:1
+64 SET STA=1
SET FY=$ORDER(^ICD9(IEN,3,"B",(CDT+.001)),-1)
+65 IF FY'?7N
SET STA=0
SET FY=$ORDER(^ICD9(IEN,3,"B",""))
IF FY'?7N
QUIT
+66 SET MY=$ORDER(^ICD9(IEN,4,"B",(FY+.001)))
+67 IF MY'?7N
SET MY=$ORDER(^ICD9(IEN,4,"B",""))
+68 SET MYIEN=$ORDER(^ICD9(IEN,4,"B",+$GET(MY),0))
+69 SET MDC=$PIECE($GET(^ICD9(IEN,4,+MYIEN,0)),"^",2)
+70 SET FYIEN=$ORDER(^ICD9(IEN,3,"B",+$GET(FY),0))
IF +FYIEN'>0
QUIT
+71 SET STR=""
SET DRG=""
+72 FOR
SET DRG=$ORDER(^ICD9(IEN,3,FYIEN,1,"B",DRG))
IF '$LENGTH(DRG)
QUIT
SET STR=STR_DRG_"^"
+73 IF +MDC'>0
SET MDC=$$DRGMDC^ICDEXD(+STR)
+74 SET ARY(FY,MDC)=STR_";"_FY_";"_STA
+75 IF FLAG["E"
Begin DoDot:2
+76 NEW ED,EMDC,DRGI,IDRG,DRGOUT
+77 SET ED=$$FMTE^XLFDT(FY,"5DZ")
SET EMDC=$PIECE($GET(^ICM(+MDC,0)),"^",1)
+78 SET ARY(FY,"E","FY")=ED
SET ARY(FY,"E",MDC)=EMDC
+79 FOR DRGI=1:1
IF '$LENGTH($PIECE($GET(STR),"^",DRGI))
QUIT
Begin DoDot:3
+80 NEW IDRG,DRGOUT
SET IDRG=$PIECE($GET(STR),"^",DRGI)
IF +IDRG'>0
QUIT
+81 KILL DRGOUT
DO DRGD^ICDGTDRG(IDRG,"DRGOUT",,$GET(CDT))
+82 IF $LENGTH($GET(DRGOUT(1)))&(+DRGI>0)
SET ARY(FY,"E",MDC,IDRG)=$GET(DRGOUT(1))
End DoDot:3
End DoDot:2
End DoDot:1
+83 QUIT
VMDCDX(IEN,CDT) ; Get versioned MDC for Diagnosis Code
+1 ;
+2 ; Input
+3 ;
+4 ; IEN Internal Entry Number file 80
+5 ; CDT Code Set Versioning Date
+6 ;
+7 ; Output
+8 ;
+9 ; $$VMDCDX Versioned MDC
+10 ;
+11 NEW ICDI,ICDD,ICDS,ICDM,ICDY
SET ICDI=+($GET(IEN))
IF '$DATA(^ICD9(ICDI,4,"B"))
QUIT ""
+12 SET ICDS=$PIECE($GET(^ICD9(+ICDI,1)),"^",1)
SET ICDD=$$DTBR^ICDEX($GET(CDT),0,ICDS)
+13 SET (ICDM,ICDY)=""
SET ICDY=$ORDER(^ICD9(+ICDI,4,"B",+ICDD),-1)
+14 SET ICDM=$ORDER(^ICD9(ICDI,4,"B",+ICDY,ICDM))
+15 QUIT $PIECE($GET(^ICD9(ICDI,4,+ICDM,0)),U,2)
VMDCOP(IEN,MDC,CDT) ; Get versioned MDC for Op/Pro ICD code from previous years
+1 ;
+2 ; Input
+3 ;
+4 ; IEN Internal Entry Number file 80.1
+5 ; MDC Major Diagnostic Category
+6 ; CDT Code Set Versioning Date
+7 ;
+8 ; Output
+9 ;
+10 ; $$VMDCOP 4 piece "^" delimited string
+11 ;
+12 ; 1 Fiscal Year Fileman format
+13 ; 2 MDC Pointer to file 80.3
+14 ; 3 Fiscal Year pointer to sub-file 80.171
+15 ; (formerly known as DADRGFY)
+16 ; 4 MDC pointer to sub-file 80.1711
+17 ; (formerly known as DAMDC)
+18 ;
+19 NEW ICDI,ICDC,ICDD,ICDO,ICDY,ICDM,ICDS
SET ICDI=+($GET(IEN))
IF '$DATA(^ICD0(ICDI,2,"B"))
QUIT ""
+20 SET ICDC=$GET(MDC)
IF '$LENGTH(MDC)
QUIT ""
SET ICDS=$PIECE($GET(^ICD0(+ICDI,1)),"^",1)
+21 SET ICDD=$$DTBR^ICDEX($GET(CDT),0,ICDS)
SET (ICDM,ICDY)=""
+22 FOR
SET ICDD=$ORDER(^ICD0(ICDI,2,"B",ICDD),-1)
IF 'ICDD!(ICDM>0)
QUIT
Begin DoDot:1
+23 SET ICDY=$ORDER(^ICD0(ICDI,2,"B",+$GET(ICDD),ICDY))
SET ICDO=ICDD
+24 SET ICDM=$ORDER(^ICD0(ICDI,2,+ICDY,1,"B",ICDC,ICDM))
End DoDot:1
+25 IF '$LENGTH($GET(ICDO))
QUIT ""
+26 QUIT (ICDO_"^"_ICDC_"^"_ICDY_"^"_ICDM)
+27 ;
MDCG(IEN,CDT,ARY) ; Set up ICDMDC() array
+1 ;
+2 ; Input
+3 ;
+4 ; IEN ICD Diagnosis (IEN)
+5 ; CDT Code Set Versioning Date
+6 ; .ARY Array name passed by reference
+7 ;
+8 ; Output
+9 ;
+10 ; ARY Array listing MDCs for all DRGs
+11 ;
+12 ; ARY=MDC
+13 ; ARY(MDC)=""
+14 ;
+15 NEW I,ICDC,ICDO,ICDTMP,ICDS,ICDD,DRGS
SET IEN=$GET(IEN)
IF +IEN'>0
QUIT
SET ICDS=$PIECE($GET(^ICD9(+IEN,1)),"^",1)
+16 SET ICDD=$$DTBR^ICDEX($GET(CDT),0,ICDS)
IF '$LENGTH(IEN)
QUIT
SET ICDO=$GET(ARY)
KILL ARY
IF $LENGTH(ICDO)
SET ARY=ICDO
+17 SET ICDTMP=$$GETDRG^ICDEX(80,IEN,ICDD)
IF '$PIECE(ICDTMP,";",3)
QUIT
SET DRGS=$PIECE(ICDTMP,";")
+18 FOR I=1:1
IF '$LENGTH($PIECE(DRGS,"^",I))
QUIT
IF '$PIECE(DRGS,"^",I)
QUIT
Begin DoDot:1
+19 NEW DRG,MDC
SET DRG=$PIECE(DRGS,"^",I)
IF DRG=""
QUIT
SET MDC=$PIECE($$DRG^ICDGTDRG(DRG,ICDD),"^",5)
IF MDC=""
QUIT
SET ARY(MDC)=""
End DoDot:1
+20 QUIT
MDCT(IEN,CDT,ARY,FMT) ; For Multiple MDC DX Codes
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number for file 80.1
+5 ; CDT Code Set Versioning Date
+6 ; .ARY Array of MDCs passed by reference (required)
+7 ; FMT Output Format (optional)
+8 ;
+9 ; 0 Boolean value only (default)
+10 ; 1 2 piece "^" delimited string
+11 ; 1 Boolean value
+12 ; 2 String of matching MDCs delimited by ";"
+13 ; Output:
+14 ;
+15 ; $$MDCT Boolean value
+16 ;
+17 ; 0 The ICD Procedure code identified by IEN
+18 ; does not include any of the MDCs passed
+19 ; in .ARY(MDC) on the date specified (CDT)
+20 ;
+21 ; 1 The ICD Procedure code identified by IEN
+22 ; includes one or more of the MDCs passed
+23 ; in .ARY(MDC) on the date specified (CDT)
+24 ;
+25 NEW FY,FYI,I,MD,MDC,OK,STR
+26 SET IEN=+($GET(IEN))
IF '$DATA(^ICD0(+IEN,0))
QUIT 0
+27 IF $PIECE($GET(^ICD0(IEN,1)),"^",7)>0
QUIT 0
+28 SET CDT=$GET(CDT)
IF CDT'?7N
SET CDT=$$DT^XLFDT
+29 SET FMT=+($GET(FMT))
SET (STR,MD)=""
SET OK=0
FOR I=1:1
SET MD=$ORDER(ARY(MD))
IF MD=""
QUIT
Begin DoDot:1
+30 NEW FY,FYI,MDC
SET FY=$ORDER(^ICD0(IEN,2,"B",(+CDT+.001)),-1)
IF FY'?7N
QUIT
+31 SET FYI=$ORDER(^ICD0(IEN,2,"B",+FY,0))
+32 SET MDC=$DATA(^ICD0(IEN,2,+FYI,1,"B",MD))
+33 IF MDC>0
SET STR=STR_";"_MD
+34 IF MDC>0
SET OK=1
End DoDot:1
+35 FOR
IF $EXTRACT(STR,1)'=";"
QUIT
SET STR=$EXTRACT(STR,2,$LENGTH(STR))
+36 SET OK=+OK
IF FMT>0&($LENGTH(STR))
SET OK=OK_"^"_STR
+37 QUIT OK
MDCD(IEN,MDC,CDT) ; Check for default MDC
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number for file 80.1
+5 ; MDC Major Diagnostic Category
+6 ; CDT Code Set Versioning Date (optional)
+7 ; If not passed, the first FY is used
+8 ;
+9 ; Output:
+10 ;
+11 ; $$MDCD Boolean value
+12 ;
+13 ; 0 MDC Does not exist
+14 ; 1 MDC Exist
+15 ;
+16 NEW ICDY,ICDM,ICDD,ICDF
SET ICDY=+($GET(IEN))
IF '$DATA(^ICD0(+IEN,2,1,1))
QUIT 0
SET ICDM=$GET(MDC)
IF '$LENGTH(ICDM)
QUIT 0
+17 SET ICDD=$GET(CDT)
SET ICDF=$ORDER(^ICD0(+ICDY,2,"B",(ICDD+.001)),-1)
IF ICDF'?7N
SET ICDF=$ORDER(^ICD0(+ICDY,2,"B",""))
+18 SET ICDF=$ORDER(^ICD0(+ICDY,2,"B",+ICDF,0))
IF ICDF'>0
QUIT $SELECT($DATA(^ICD0(ICDY,2,1,1,"B",ICDM))>0:1,1:0)
+19 IF ICDF>0
QUIT $SELECT($DATA(^ICD0(ICDY,2,+ICDF,1,"B",ICDM))>0:1,1:0)
MDCN(IEN) ; Major Diagnostic Category Name
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number for file 80.3
+5 ;
+6 ; Output:
+7 ;
+8 ; $$MDCN Major Diagnostic Category Name
+9 ;
+10 ; Replaces ICR 1586
+11 ;
+12 QUIT $PIECE($GET(^ICM(+($GET(IEN)),0)),"^",1)
MOR(IEN) ; Major O.R. Procedure
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number for file 80.1
+5 ;
+6 ; Output:
+7 ;
+8 ; $$MOR Major O.R. Procedure
+9 ;
+10 QUIT $GET(^ICD0(+($GET(IEN)),"M"))
+11 ;
UPDX(IEN) ; Unacceptable as Principle DX
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number for file 80
+5 ;
+6 ; Output:
+7 ;
+8 ; $$UPDX Boolean value only (default)
+9 ;
+10 ; 0 No, Code is Acceptable as Principle DX
+11 ; 1 Yes, Code is Unacceptable as Principle DX
+12 ;
+13 NEW ICDEXC
SET ICDEXC=$$EXC^ICDEX(80,+($GET(IEN)))
IF +ICDEXC>0
QUIT 1
+14 QUIT +($PIECE($GET(^ICD9(+($GET(IEN)),1)),"^",3))
EFM(X) ; Convert External Date to FM
+1 ;
+2 ; Input:
+3 ;
+4 ; X External Date
+5 ;
+6 ; Output:
+7 ;
+8 ; $$EFM Internal Fileman Date
+9 ;
+10 ; Replaces unsupported $$DGY2K^DGPTOD0(X)
+11 ;
+12 NEW %DT,Y
DO ^%DT
KILL %DT
+13 QUIT Y
FY(X) ;Return FY
+1 ;
+2 ; Input:
+3 ;
+4 ; X Internal Fileman Date
+5 ;
+6 ; Output:
+7 ;
+8 ; $$FY FY Year YYYY
+9 ;
+10 ; Replaces unsupported $$FY^DGPTOD0(X)
+11 ;
+12 SET X=$PIECE($GET(X),".",1)
IF $LENGTH(X)>7
QUIT ""
IF $EXTRACT(X,1,5)'?5N
QUIT ""
+13 IF $EXTRACT(X,4,5)>9
SET X=$EXTRACT(X,1,3)+1
+14 QUIT (17+$EXTRACT(X))_$EXTRACT(X,2,3)
EFD(X) ; Get Effective date in range (interactive)
+1 ;
+2 ; Prompts for Effective Date for DRG grouper
+3 ;
+4 ; The lower boundary for the date is the ICD-9
+5 ; implementation date October 1, 1978.
+6 ;
+7 ; The upper boundary for date is either
+8 ;
+9 ; 3 years from the ICD-10 implementation date or
+10 ; 3 years from TODAY
+11 ;
+12 ; Whichever is further into the future
+13 ;
+14 ; Input:
+15 ;
+16 ; None
+17 ;
+18 ; Output:
+19 ;
+20 ; $$EFF 3 piece ^ delimited string
+21 ;
+22 ; 1 Date Fileman format nnnnnnn
+23 ; 2 Date External Short Format mm/dd/yyyy
+24 ; 3 Date External Long Format Mmm dd, yyyy
+25 ;
+26 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDH,ICDI,ICDIMP,ICDT,Y
+27 SET ICDT=$$DT^XLFDT
SET ICDH=""
SET ICDI=0
+28 FOR
SET ICDI=$ORDER(^ICDS(ICDI))
IF +ICDI'>0
QUIT
Begin DoDot:1
+29 NEW ICDIMP
SET ICDIMP=$PIECE($GET(^ICDS(ICDI,0)),"^",3)
+30 IF ICDIMP>ICDH
SET ICDH=ICDIMP
End DoDot:1
+31 IF ICDT>ICDH
SET ICDH=ICDT
SET ICDH=$$FMADD^XLFDT(ICDH,1095)
+32 SET DIR(0)="DAO^2781001:"_ICDH_":AEX"
+33 SET DIR("B")="TODAY"
SET DIR("A")=" Effective Date: "
IF ICDH?7N
Begin DoDot:1
+34 SET DIR("A")=" Effective Date ("_$$FMTE^XLFDT(2781001,"5Z")
+35 SET DIR("A")=DIR("A")_" to "_$$FMTE^XLFDT($GET(ICDH),"5Z")_"): "
End DoDot:1
+36 SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D EFFH^ICDEXD"
+37 DO ^DIR
IF $DATA(DIROUT)
QUIT "^^"
IF $DATA(DIRUT)
QUIT "^"
IF $DATA(DTOUT)
QUIT ""
+38 SET X=Y
IF X?7N
SET X=X_"^"_$$FMTE^XLFDT(X,"5Z")_"^"_$$FMTE^XLFDT(X)
+39 QUIT X
EFFH ; Effective Date Help
+1 IF $LENGTH($GET(ICDH))
Begin DoDot:1
+2 WRITE !,?5,"Enter an effective date from ",$$FMTE^XLFDT(2781001,"5Z")
+3 WRITE " to ",$$FMTE^XLFDT($GET(ICDH),"5Z")
+4 WRITE !,?5,"to be used to select or calculated time sensitive data.",!
End DoDot:1
+5 WRITE !,?5,"Examples of Valid Dates:"
+6 WRITE !,?5," JAN 20 1980 or 20 JAN 80 or 1/20/57 or 012080"
+7 WRITE !,?5," T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc."
+8 WRITE !,?5," T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
+9 WRITE !,?5,"If the year is omitted, the computer uses CURRENT YEAR. "
+10 WRITE !,?5,"Two digit year assumes no more than 20 years in the future,"
+11 WRITE !,?5," or 80 years in the past."
+12 QUIT
ISVALID(FILE,IEN,CDT) ; Is an ICD code Valid
+1 ;
+2 ; Input:
+3 ;
+4 ; FILE File or global root
+5 ; IEN Internal Entry Number
+6 ; CDT Effective date to use (default TODAY)
+7 ;
+8 ; Output:
+9 ;
+10 ; $$ISVALID This is a Boolean value
+11 ;
+12 ; 1 if the code is valid
+13 ; 0 if the code is not valid
+14 ;
+15 NEW ICDO,ICDD,ICDF,ICDT,ICDX,ICDI,ICDR
SET ICDO=0
+16 SET FILE=$SELECT(FILE="9":80,FILE="0":80.1,1:FILE)
+17 SET ICDD=$PIECE($GET(CDT),".",1)
IF ICDD'?7N
SET ICDD=$$DT^XLFDT
+18 SET ICDF=$$FILE^ICDEX(FILE)
IF "^80^80.1^"'[("^"_FILE_"^")
QUIT ICDO
+19 SET ICDR=$$ROOT^ICDEX(FILE)
SET ICDI=+($GET(IEN))
+20 IF +ICDI'>0
QUIT ICDO
IF '$DATA(@(ICDR_+ICDI_",0)"))
QUIT ICDO
+21 SET ICDX=$$EXC^ICDEX(ICDF,ICDI)
IF ICDX>0
QUIT ICDO
+22 ;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
+23 ;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
+24 ;IHS/OIT/FBD&NKD REPLACED ICDDX/ICDOP CALLS WITH SAI
IF (+$PIECE($$SAI^ICDEX(ICDF,ICDI,ICDD),"^")>0)
SET ICDO=1
+25 QUIT ICDO
REF(IEN,CDT) ; Return Reference Table
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number
+5 ; CDT Effective date to use (default TODAY)
+6 ;
+7 ; Output:
+8 ;
+9 ; $$REF Table reference associated DRG entry
+10 ; or null if not found
+11 ;
+12 NEW ICDI,ICDD,ICDR,ICDFY,ICDR
+13 SET ICDI=+($GET(IEN))
IF +IEN'>0!('$DATA(^ICD(IEN,2)))
QUIT ""
+14 SET (ICDFY,ICDR)=""
SET ICDD=$PIECE($GET(CDT),".",1)
+15 IF ICDD'?7N
SET ICDD=$$DT^XLFDT
+16 SET ICDFY=$ORDER(^ICD(ICDI,2,"B",(+ICDD+.01)),-1)
+17 SET ICDR=$ORDER(^ICD(ICDI,2,"B",+ICDFY,ICDR))
+18 SET ICDR=$PIECE($GET(^ICD(ICDI,2,+ICDR,0)),U,3)
+19 QUIT ICDR
