ICDEXD6 ;SLC/KER - ICD Extractor - DRG APIs (cont) ;12/19/2014
;;18.0;DRG Grouper;**67**;Oct 20, 2000;Build 1
;
; 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
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))
POAE(X) ; Present on Admission (POA) Exempt
;
; Input:
;
; IEN Internal Entry Number for file 80
;
; Output:
;
; $$POAE Boolean value only
;
; 0 No, Code is not exempt for POA
; 1 Yes, Code is exempt for POA
;
Q:+($G(X))'>0 0 Q:'$L($G(^ICD9(+($G(IEN)),1))) 0
Q +($P($G(^ICD9(+($G(IEN)),1)),"^",9))
HAC(X) ; Hospital Acquired Conditions (HACS)
;
; Input:
;
; IEN Internal Entry Number for file 80
;
; Output:
;
; $$HAC Boolean value only
;
; 0 No, Code is not a Hospital Acquired Condition
; 1 Yes, Code is a Hospital Acquired Condition
;
Q:+($G(X))'>0 0 Q:'$L($G(^ICD9(+($G(IEN)),1))) 0
I $D(^ICDHAC("C",+($G(IEN)))) Q 1
Q 0
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)
DRGN(CODE) ; Return the IEN of DRG
;
; Input:
;
; CODE DRG code
;
; Output:
;
; $$DRGN IEN of DRG code
;
; or
;
; -1 on error
;
Q:$G(CODE)="" -1
N COD S COD=+$O(^ICD("B",CODE,0))
Q $S(COD>0:COD,1:-1)
Q
DRGC(IEN) ; DRG Code
;
; Input:
;
; IEN Internal Entry Number file 80.2
;
; Output:
;
; $$DRGC Code (field .01)
;
; Replaces ICR 370
;
S IEN=+($G(IEN)) Q:'$D(^ICD(+IEN,0)) ""
Q $P($G(^ICD(+IEN,0)),"^",1)
DRGW(IEN) ; DRG Weighted Work Unit (WWU)
;
; Input:
;
; IEN Internal Entry Number file 80.2
;
; Output:
;
; $$WT Weight
;
; Replaces ICR 48
;
S IEN=+($G(IEN)) Q:'$D(^ICD(+IEN,0)) ""
Q $P($G(^ICD(+IEN,0)),"^",2)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXD6 4912 printed Sep 02, 2024@18:35:55 Page 2
ICDEXD6 ;SLC/KER - ICD Extractor - DRG APIs (cont) ;12/19/2014
+1 ;;18.0;DRG Grouper;**67**;Oct 20, 2000;Build 1
+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
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))
POAE(X) ; Present on Admission (POA) Exempt
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number for file 80
+5 ;
+6 ; Output:
+7 ;
+8 ; $$POAE Boolean value only
+9 ;
+10 ; 0 No, Code is not exempt for POA
+11 ; 1 Yes, Code is exempt for POA
+12 ;
+13 if +($GET(X))'>0
QUIT 0
if '$LENGTH($GET(^ICD9(+($GET(IEN)),1)))
QUIT 0
+14 QUIT +($PIECE($GET(^ICD9(+($GET(IEN)),1)),"^",9))
HAC(X) ; Hospital Acquired Conditions (HACS)
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number for file 80
+5 ;
+6 ; Output:
+7 ;
+8 ; $$HAC Boolean value only
+9 ;
+10 ; 0 No, Code is not a Hospital Acquired Condition
+11 ; 1 Yes, Code is a Hospital Acquired Condition
+12 ;
+13 if +($GET(X))'>0
QUIT 0
if '$LENGTH($GET(^ICD9(+($GET(IEN)),1)))
QUIT 0
+14 IF $DATA(^ICDHAC("C",+($GET(IEN))))
QUIT 1
+15 QUIT 0
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)
DRGN(CODE) ; Return the IEN of DRG
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE DRG code
+5 ;
+6 ; Output:
+7 ;
+8 ; $$DRGN IEN of DRG code
+9 ;
+10 ; or
+11 ;
+12 ; -1 on error
+13 ;
+14 if $GET(CODE)=""
QUIT -1
+15 NEW COD
SET COD=+$ORDER(^ICD("B",CODE,0))
+16 QUIT $SELECT(COD>0:COD,1:-1)
+17 QUIT
DRGC(IEN) ; DRG Code
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number file 80.2
+5 ;
+6 ; Output:
+7 ;
+8 ; $$DRGC Code (field .01)
+9 ;
+10 ; Replaces ICR 370
+11 ;
+12 SET IEN=+($GET(IEN))
if '$DATA(^ICD(+IEN,0))
QUIT ""
+13 QUIT $PIECE($GET(^ICD(+IEN,0)),"^",1)
DRGW(IEN) ; DRG Weighted Work Unit (WWU)
+1 ;
+2 ; Input:
+3 ;
+4 ; IEN Internal Entry Number file 80.2
+5 ;
+6 ; Output:
+7 ;
+8 ; $$WT Weight
+9 ;
+10 ; Replaces ICR 48
+11 ;
+12 SET IEN=+($GET(IEN))
if '$DATA(^ICD(+IEN,0))
QUIT ""
+13 QUIT $PIECE($GET(^ICD(+IEN,0)),"^",2)
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
