DGPTICD ;ALB/MTC - PTF DRG Grouper Utility ;2/19/02 3:08pm
;;5.3;Registration;**375,441,510,559,599,606,775,785,850**;Aug 13, 1993;Build 171
;variables to pass in:
; DGDX <- format: DX CODE1^DX CODE2^DX CODE3^... (REQUIRED)
; DGDXPOA <- format: poa1^poa2^poa3.... (REQUIRED for ICD-10 diag)
; 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,ICDPOA
;
I $G(EFFDATE)="" D EFFDATE^DGPTIC10($G(PTF))
S ICDEDT=EFFDATE
S DGI=0 F S DGI=DGI+1 Q:$P(DGDX,U,DGI)="" D
. S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGDX,U,DGI),EFFDATE)
. I +DGPTTMP>0,($P(DGPTTMP,U,10)) S ICDDX(DGI)=$P(DGDX,U,DGI) D
.. I EFFDATE'<$$IMPDATE^LEXU("10D") S ICDPOA(DGI)=$S($G(DGDXPOA)'="":$P($G(DGDXPOA),U,DGI),1:"Y")
I '$D(ICDDX) W ! G Q
;
;-- build ICDPRC array
K ICDPRC
;-- 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=$$ICDDATA^ICDXCODE("PROC",X,+$G(EFFDATE))
. 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
. S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",X,+$G(EFFDATE))
. 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
;DRP S ICDDATE=$S($D(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE ;Ensure that DGDAT is defined prior to executing PRT
S ICDDATE=$S(+$G(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE ;Ensure that DGDAT is defined prior to executing PRT
;
;-- calculate DRG
;reset ICD partition variables to prevent date/coding system conflicts
K ICDCSYS,ICD0,ICDCDSY,ICDEDT
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),!
K ICDDATE
Q K ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICDTRS Q
;
80 ;
N DIC S DIC=80,DIC(0)="AEQLIM" D ^DIC
S OUT=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTICD 3571 printed Sep 23, 2025@20:28:39 Page 2
DGPTICD ;ALB/MTC - PTF DRG Grouper Utility ;2/19/02 3:08pm
+1 ;;5.3;Registration;**375,441,510,559,599,606,775,785,850**;Aug 13, 1993;Build 171
+2 ;variables to pass in:
+3 ; DGDX <- format: DX CODE1^DX CODE2^DX CODE3^... (REQUIRED)
+4 ; DGDXPOA <- format: poa1^poa2^poa3.... (REQUIRED for ICD-10 diag)
+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 ;
+18 if '$DATA(DGDX)!'$DATA(DGTRS)!'$DATA(DGEXP)!'$DATA(DGDMS)
QUIT
+19 NEW DGI
+20 ;-- build ICDDX array
+21 KILL ICDDX,ICDPOA
+22 ;
+23 IF $GET(EFFDATE)=""
DO EFFDATE^DGPTIC10($GET(PTF))
+24 SET ICDEDT=EFFDATE
+25 SET DGI=0
FOR
SET DGI=DGI+1
if $PIECE(DGDX,U,DGI)=""
QUIT
Begin DoDot:1
+26 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DGDX,U,DGI),EFFDATE)
+27 IF +DGPTTMP>0
IF ($PIECE(DGPTTMP,U,10))
SET ICDDX(DGI)=$PIECE(DGDX,U,DGI)
Begin DoDot:2
+28 IF EFFDATE'<$$IMPDATE^LEXU("10D")
SET ICDPOA(DGI)=$SELECT($GET(DGDXPOA)'="":$PIECE($GET(DGDXPOA),U,DGI),1:"Y")
End DoDot:2
End DoDot:1
+29 IF '$DATA(ICDDX)
WRITE !
GOTO Q
+30 ;
+31 ;-- build ICDPRC array
+32 KILL ICDPRC
+33 ;-- build ICDPRC array eliminating dupes as we go
+34 KILL ICDPRC
+35 NEW I,J,X,Y,FLG,SUB
SET SUB=0
+36 IF $DATA(DGPROC)
FOR I=2:1
SET X=$PIECE(DGPROC,U,I)
if X=""
QUIT
Begin DoDot:1
+37 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",X,+$GET(EFFDATE))
+38 IF +DGPTTMP>0
IF ($PIECE(DGPTTMP,U,10))
SET SUB=SUB+1
SET ICDPRC(SUB)=X
End DoDot:1
+39 IF $DATA(DGSURG)
FOR I=2:1
SET X=$PIECE(DGSURG,U,I)
if X=""
QUIT
Begin DoDot:1
+40 SET J=0
FOR
SET J=$ORDER(ICDPRC(J))
if 'J
QUIT
+41 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",X,+$GET(EFFDATE))
+42 IF +DGPTTMP>0
IF ($PIECE(DGPTTMP,U,10))
SET SUB=SUB+1
SET ICDPRC(SUB)=X
+43 SET ICDSURG(SUB)=$PIECE(DGPTTMP,U,2)
End DoDot:1
+44 ;
+45 ;-- set other required variables
+46 SET ICDTRS=DGTRS
SET ICDEXP=DGEXP
SET ICDDMS=DGDMS
+47 ;DRP S ICDDATE=$S($D(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE ;Ensure that DGDAT is defined prior to executing PRT
+48 ;Ensure that DGDAT is defined prior to executing PRT
SET ICDDATE=$SELECT(+$GET(DGDAT):DGDAT,1:DT)
SET DGDAT=ICDDATE
+49 ;
+50 ;-- calculate DRG
+51 ;reset ICD partition variables to prevent date/coding system conflicts
+52 KILL ICDCSYS,ICD0,ICDCDSY,ICDEDT
+53 DO ^ICDDRG
SET DRG=ICDDRG
IF '$DATA(DGDRGPRT)
GOTO Q
+54 ;
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),!
+12 KILL ICDDATE
Q KILL ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICDTRS
QUIT
+1 ;
80 ;
+1 NEW DIC
SET DIC=80
SET DIC(0)="AEQLIM"
DO ^DIC
+2 SET OUT=Y
+3 QUIT
