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