| 1 | DGPTICD ;ALB/MTC - PTF DRG Grouper Utility ; 2/19/02 3:08pm
|
|---|
| 2 | ;;5.3;Registration;**375,441,510,559,599,606,775**;Aug 13, 1993;Build 3
|
|---|
| 3 | ;variables to pass in:
|
|---|
| 4 | ; DGDX <- format: DX CODE1^DX CODE2^DX CODE3^... (REQUIRED)
|
|---|
| 5 | ; DGSURG <- format: SURGERY CODE1^SURGERY CODE2^SURGERY CODE3^... (OPTIONAL)
|
|---|
| 6 | ; DGPROC <- format: PROCEDURE CODE1^PROCEDURE CODE2^PROCEDURE CODE3^... (OPTIONAL)
|
|---|
| 7 | ; DGTRS <- 1 if patient transferred to acute care facility (REQUIRED)
|
|---|
| 8 | ; DGEXP <- 1 if patient died during this episode (REQUIRED)
|
|---|
| 9 | ; DGDMS <- 1 if patient was discharged with an Irregular discharge (discharged against medical advice) (REQUIRED)
|
|---|
| 10 | ; AGE,SEX (REQUIRED)
|
|---|
| 11 | ;values of variables listed above are left unchanged by this routine
|
|---|
| 12 | ;variable passed back: DRG(0) <- zero node of DRG in DRG file
|
|---|
| 13 | ; : DRG <- IFN of DRG in DRG file
|
|---|
| 14 | ; DGDAT <- Effective date to be used in calculating DRG
|
|---|
| 15 | ;
|
|---|
| 16 | ;-- check for required variables
|
|---|
| 17 | Q:'$D(DGDX)!'$D(DGTRS)!'$D(DGEXP)!'$D(DGDMS)
|
|---|
| 18 | N DGI
|
|---|
| 19 | ;-- build ICDDX array
|
|---|
| 20 | K ICDDX
|
|---|
| 21 | S DGI=0 F S DGI=DGI+1 Q:$P(DGDX,U,DGI)="" D
|
|---|
| 22 | . S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGDX,U,DGI),+$G(DGDAT))
|
|---|
| 23 | . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S ICDDX(DGI)=$P(DGDX,U,DGI)
|
|---|
| 24 | G Q:'$D(ICDDX)
|
|---|
| 25 | ;
|
|---|
| 26 | ;-- build ICDPRC array
|
|---|
| 27 | ;K ICDPRC
|
|---|
| 28 | ;I $D(DGPROC) S DGSURG=$S('$D(DGSURG):DGPROC,1:DGSURG_DGPROC)
|
|---|
| 29 | ;I $D(DGSURG) S DGI=0 F S DGI=DGI+1 Q:$P(DGSURG,U,DGI)="" D
|
|---|
| 30 | ;. I $D(^ICD0($P(DGSURG,U,DGI),0)) S ICDPRC(DGI)=$P(DGSURG,U,DGI)
|
|---|
| 31 | ;-- build ICDPRC array eliminating dupes as we go
|
|---|
| 32 | K ICDPRC
|
|---|
| 33 | N I,J,X,Y,FLG,SUB S SUB=0
|
|---|
| 34 | I $D(DGPROC) F I=2:1 S X=$P(DGPROC,U,I) Q:X="" D
|
|---|
| 35 | . S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT))
|
|---|
| 36 | . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X
|
|---|
| 37 | I $D(DGSURG) F I=2:1 S X=$P(DGSURG,U,I) Q:X="" D
|
|---|
| 38 | . S FLG=0,J=0 F S J=$O(ICDPRC(J)) Q:'J I X=$G(ICDPRC(J)) S FLG=1 Q
|
|---|
| 39 | . I FLG Q
|
|---|
| 40 | . S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT))
|
|---|
| 41 | . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X
|
|---|
| 42 | ;
|
|---|
| 43 | ;-- set other required variables
|
|---|
| 44 | S ICDTRS=DGTRS,ICDEXP=DGEXP,ICDDMS=DGDMS
|
|---|
| 45 | S ICDDATE=$S($D(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE ;Ensure that DGDAT is defined prior to executing PRT
|
|---|
| 46 | ;
|
|---|
| 47 | ;-- calculate DRG
|
|---|
| 48 | D ^ICDDRG S DRG=ICDDRG I '$D(DGDRGPRT) G Q
|
|---|
| 49 | ;
|
|---|
| 50 | PRT ;print DRG and national HCFA values
|
|---|
| 51 | I (ICDDATE<3071001)&(DRG=468!(DRG=469)!(DRG=470)) W *7
|
|---|
| 52 | I DRG=998!(DRG=999) W *7
|
|---|
| 53 | S Y=ICDDATE D DD^%DT ; Y=external representation of effective date
|
|---|
| 54 | W !!?9,"Effective Date:"," ",Y
|
|---|
| 55 | S DRG(0)=$$DRG^ICDGTDRG(DRG,DGDAT) W !!,"Diagnosis Related Group: ",$J(DRG,6),?36,"Average Length of Stay(ALOS): ",$J($P(DRG(0),"^",8),6)
|
|---|
| 56 | W !?17,"Weight: ",$J($P(DRG(0),"^",2),6) ;,?40,"Local Breakeven: ",$J($P(DRG(0),"^",12),6)
|
|---|
| 57 | W !?12," Low Day(s): ",$J($P(DRG(0),"^",3),6) ;,?39,"Local Low Day(s): ",$J($P(DRG(0),"^",9),6)
|
|---|
| 58 | W !?13," High Days: ",$J($P(DRG(0),"^",4),6) ;,?40,"Local High Days: ",$J($P(DRG(0),"^",10),6)
|
|---|
| 59 | N DXD,DGDX
|
|---|
| 60 | S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DGDAT),DGI=0
|
|---|
| 61 | W !!,"DRG: ",DRG,"-" F S DGI=$O(DGDX(DGI)) Q:'+DGI Q:DGDX(DGI)=" " W ?10,DGDX(DGI),!
|
|---|
| 62 | Q K ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICDTRS,ICDDATE Q
|
|---|
