- 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 Jan 18, 2025@03:53:27 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