Changeset 623 for WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTICD.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTICD.m
r613 r623 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 1 DGPTICD ;ALB/MTC - PTF DRG Grouper Utility ; 2/19/02 3:08pm 2 ;;5.3;Registration;**375,441,510,559,599,606**;Aug 13, 1993 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 DRG=468!(DRG=469)!(DRG=470) W *7 52 S Y=ICDDATE D DD^%DT ; Y=external representation of effective date 53 W !!?9,"Effective Date:"," ",Y 54 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) 55 W !?17,"Weight: ",$J($P(DRG(0),"^",2),6) ;,?40,"Local Breakeven: ",$J($P(DRG(0),"^",12),6) 56 W !?12," Low Day(s): ",$J($P(DRG(0),"^",3),6) ;,?39,"Local Low Day(s): ",$J($P(DRG(0),"^",9),6) 57 W !?13," High Days: ",$J($P(DRG(0),"^",4),6) ;,?40,"Local High Days: ",$J($P(DRG(0),"^",10),6) 58 N DXD,DGDX 59 S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DGDAT),DGI=0 60 W !!,"DRG: ",DRG,"-" F S DGI=$O(DGDX(DGI)) Q:'+DGI Q:DGDX(DGI)=" " W ?10,DGDX(DGI),! 61 Q K ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICDTRS,ICDDATE Q
Note:
See TracChangeset
for help on using the changeset viewer.
