Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPTICD

DGPTICD.m

Go to the documentation of this file.
  1. 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
  1. ;variables to pass in:
  1. ; DGDX <- format: DX CODE1^DX CODE2^DX CODE3^... (REQUIRED)
  1. ; DGDXPOA <- format: poa1^poa2^poa3.... (REQUIRED for ICD-10 diag)
  1. ; DGSURG <- format: SURGERY CODE1^SURGERY CODE2^SURGERY CODE3^... (OPTIONAL)
  1. ; DGPROC <- format: PROCEDURE CODE1^PROCEDURE CODE2^PROCEDURE CODE3^... (OPTIONAL)
  1. ; DGTRS <- 1 if patient transferred to acute care facility (REQUIRED)
  1. ; DGEXP <- 1 if patient died during this episode (REQUIRED)
  1. ; DGDMS <- 1 if patient was discharged with an Irregular discharge (discharged against medical advice) (REQUIRED)
  1. ; AGE,SEX (REQUIRED)
  1. ;values of variables listed above are left unchanged by this routine
  1. ;variable passed back: DRG(0) <- zero node of DRG in DRG file
  1. ; : DRG <- IFN of DRG in DRG file
  1. ; DGDAT <- Effective date to be used in calculating DRG
  1. ;
  1. ;-- check for required variables
  1. ;
  1. Q:'$D(DGDX)!'$D(DGTRS)!'$D(DGEXP)!'$D(DGDMS)
  1. N DGI
  1. ;-- build ICDDX array
  1. K ICDDX,ICDPOA
  1. ;
  1. I $G(EFFDATE)="" D EFFDATE^DGPTIC10($G(PTF))
  1. S ICDEDT=EFFDATE
  1. S DGI=0 F S DGI=DGI+1 Q:$P(DGDX,U,DGI)="" D
  1. . S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGDX,U,DGI),EFFDATE)
  1. . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S ICDDX(DGI)=$P(DGDX,U,DGI) D
  1. .. I EFFDATE'<$$IMPDATE^LEXU("10D") S ICDPOA(DGI)=$S($G(DGDXPOA)'="":$P($G(DGDXPOA),U,DGI),1:"Y")
  1. I '$D(ICDDX) W ! G Q
  1. ;
  1. ;-- build ICDPRC array
  1. K ICDPRC
  1. ;-- build ICDPRC array eliminating dupes as we go
  1. K ICDPRC
  1. N I,J,X,Y,FLG,SUB S SUB=0
  1. I $D(DGPROC) F I=2:1 S X=$P(DGPROC,U,I) Q:X="" D
  1. . S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",X,+$G(EFFDATE))
  1. . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X
  1. I $D(DGSURG) F I=2:1 S X=$P(DGSURG,U,I) Q:X="" D
  1. . S J=0 F S J=$O(ICDPRC(J)) Q:'J
  1. . S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",X,+$G(EFFDATE))
  1. . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X
  1. . S ICDSURG(SUB)=$P(DGPTTMP,U,2)
  1. ;
  1. ;-- set other required variables
  1. S ICDTRS=DGTRS,ICDEXP=DGEXP,ICDDMS=DGDMS
  1. ;DRP S ICDDATE=$S($D(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE ;Ensure that DGDAT is defined prior to executing PRT
  1. S ICDDATE=$S(+$G(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE ;Ensure that DGDAT is defined prior to executing PRT
  1. ;
  1. ;-- calculate DRG
  1. ;reset ICD partition variables to prevent date/coding system conflicts
  1. K ICDCSYS,ICD0,ICDCDSY,ICDEDT
  1. D ^ICDDRG S DRG=ICDDRG I '$D(DGDRGPRT) G Q
  1. ;
  1. PRT ;print DRG and national HCFA values
  1. I (ICDDATE<3071001)&(DRG=468!(DRG=469)!(DRG=470)) W *7
  1. I DRG=998!(DRG=999) W *7
  1. S Y=ICDDATE D DD^%DT ; Y=external representation of effective date
  1. W !!?9,"Effective Date:"," ",Y
  1. 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)
  1. W !?17,"Weight: ",$J($P(DRG(0),"^",2),6) ;,?40,"Local Breakeven: ",$J($P(DRG(0),"^",12),6)
  1. W !?12," Low Day(s): ",$J($P(DRG(0),"^",3),6) ;,?39,"Local Low Day(s): ",$J($P(DRG(0),"^",9),6)
  1. W !?13," High Days: ",$J($P(DRG(0),"^",4),6) ;,?40,"Local High Days: ",$J($P(DRG(0),"^",10),6)
  1. N DXD,DGDX
  1. S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DGDAT),DGI=0
  1. W !!,"DRG: ",DRG,"-" F S DGI=$O(DGDX(DGI)) Q:'+DGI Q:DGDX(DGI)=" " W ?10,DGDX(DGI),!
  1. K ICDDATE
  1. Q K ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICDTRS Q
  1. ;
  1. 80 ;
  1. N DIC S DIC=80,DIC(0)="AEQLIM" D ^DIC
  1. S OUT=Y
  1. Q