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

ICDDRGM.m

Go to the documentation of this file. 
  1. ICDDRGM ;ALB/GRR/EG/ADL - Grouper Driver ;04/21/2014
  1.  ;;18.0;DRG Grouper;**7,36,57**;Oct 20, 2000;Build 7
  1.  ;
  1.  ; ADL  Add Date prompt and passing of effective date for DRG CSV project
  1.  ; ADL  Update DIC("S") code to screen using new function calls
  1.  ; ADL  Update to access DRG file using new API for CSV Project
  1.  ; KER  Remove direct global reads, update for ICD-10
  1.  ; 
  1.  ; Global Variables
  1.  ;    ^DPT(               ICR  10035
  1.  ;               
  1.  ; External References
  1.  ;    ^%DTC               ICR  10000
  1.  ;    ^DIC                ICR  10006
  1.  ;    ^DIR                ICR  10026
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    H^XUS               ICR  10044
  1.  ;    ^ICDDRG             ICR  N/A
  1.  ;    $$DRG^ICDEX         ICR  N/A
  1.  ;    $$DRGD^ICDEX        ICR  N/A
  1.  ;    $$ROOT^ICDEX        ICR  N/A
  1.  ;               
  1.  ; Local Variables NEWed or KILLed Elsewhere
  1.  ;     DIRUT,ICDDATE,QUIT,Y
  1.  ; 
  1.  S U="^",DT=$$DT^XLFDT W !!?11,"DRG Grouper    Version ",$P($T(+2),";",3),!!
  1. PAT ; Patient
  1.  D KILL
  1.  S ICDQU=0 K ICDEXP,SEX,ICDDX,ICDSURG
  1.  D EFFDATE G KILL:$D(DUOUT),OUT:$D(DTOUT)
  1.  S DIR(0)="Y",DIR("A")="DRGs for Registered PATIENTS  (Y/N)",DIR("B")="YES"
  1.  S DIR("?")="Enter 'Yes' if the patient has been previously registered, enter 'No' for other patient, or '^' to quit."
  1.  D ^DIR K DIR S ICDPT=Y G KILL:$D(DUOUT),OUT:$D(DTOUT)
  1. PAT0 ; Patient - Ask Again
  1.  G:ICDPT=0 ASK
  1. VA ; VA Patient File #2
  1.  S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:X=""!(X[U)!(Y'>0),OUT:$D(DTOUT) S DFN=+Y,(DOB,AGE)=$P(Y(0),U,3),SEX=$P(Y(0),U,2)
  1.  D TAC G:ICDQU PAT D DAM G:ICDQU PAT
  1. EN1 ; Entry point - Patient is Known (DFN)
  1.  I $D(^DPT(DFN,.35)),$L(^DPT(DFN,.35)) D ALIVE G:ICDQU PAT
  1.  S ICDEXP=$S($D(ICDEXP):ICDEXP,1:0)
  1.  I AGE]"" N %,X,X1,X2 S X1=DT,X2=AGE D ^%DTC S AGE=X\365.25 W "  AGE: ",AGE
  1. CD ; Primary and Secondary DX
  1.  K DIC S CC=0,DIC=$$ROOT^ICDEX(80),DIC(0)="AEQMZ",DIC("A")="Enter Primary diagnosis: " D  D ^DIC K DIC G Q:X=""!(X[U)!(Y'>0),OUT:$D(DTOUT) S ICDDX(1)=+Y
  1.  . S DIC("S")="I '$P($$ICDDX^ICDEX(+Y,ICDDATE,,""I""),U,5),$$ISVALID^ICDEX(80,+Y,ICDDATE)"
  1.  F ICDNSD=2:1 D  Q:X=""!(X[U)!(Y'>0)  G:$D(DTOUT) OUT S ICDDX(ICDNSD)=+Y
  1.  . S DIC=$$ROOT^ICDEX(80),DIC(0)="AEQMZ"
  1.  . S DIC("A")="Enter SECONDARY diagnosis: ",DIC("S")="I $$ISVALID^ICDEX(80,+Y,ICDDATE)"
  1.  . D ^DIC K DIC
  1.  G Q:X[U
  1. OP ; Operation/Procedures
  1.  S DIC("S")="I $$ISVALID^ICDEX(80.1,+Y,ICDDATE)" K ICDPRC
  1.  W ! F ICDNOR=1:1 S DIC=$$ROOT^ICDEX(80.1),DIC(0)="AEQMZ",DIC("A")="Enter Operation/Procedure: " D ^DIC K DIC Q:X=""!(X[U)!(Y'>0)  G:$D(DTOUT) OUT S ICDPRC(ICDNOR)=+Y,ICDSURG(ICDNOR)=X
  1.  K DIC G Q:X["^" D ^ICDDRG
  1.  D WRT G PAT0
  1. WRT ; Write Output
  1.  S ICDDRG(0)=$$DRG^ICDEX(+ICDDRG,ICDDATE)
  1.  W !!?9,"Effective Date: ","   ",ICDDSP
  1.  W !,"Diagnosis Related Group: ",$J(ICDDRG,6),?40,"Avg len of stay: ",$J($P(ICDDRG(0),"^",8),6)
  1.  W !?17,"Weight: ",$J($P(ICDDRG(0),"^",2),6),?40,"Local Breakeven: ",$J($P(ICDDRG(0),"^",12),6)
  1.  W !?12," Low day(s): ",$J($P(ICDDRG(0),"^",3),6),?39,"Local low day(s): ",$J($P(ICDDRG(0),"^",9),6)
  1.  W !?13," High days: ",$J($P(ICDDRG(0),"^",4),6),?40,"Local High days: ",$J($P(ICDDRG(0),"^",10),6)
  1.  N ICDXD,ICDGDX,ICDGI S ICDXD=$$DRGD^ICDEX(ICDDRG,"ICDGDX",ICDDATE),ICDGI=0
  1.  W !!,"DRG: ",ICDDRG,"-" F  S ICDGI=$O(ICDGDX(ICDGI)) Q:'+ICDGI  Q:ICDGDX(ICDGI)=" "  W ?10,ICDGDX(ICDGI),!
  1.  Q
  1. ERROR ; Write Errors
  1.  D WRT I ICDRTC<5 W !!,"Invalid ",$S(ICDRTC=1:"Principal Diagnosis",ICDRTC=2:"Operation/Procedure",ICDRTC=3:"Age",ICDRTC=4:"Sex",1:"") G PAT0
  1.  I ICDRTC=5 W !!,"Grouper needs to know if patient died during this episode!" G PAT0
  1.  I ICDRTC=6 W !!,"Grouper needs to know if patient was transferred to an acute care facility!" G PAT0
  1.  I ICDRTC=7 W !!,"Grouper needs to know if patient was discharged against medical advice!" G PAT0
  1.  I ICDRTC=8 W !!,"Patient assigned newborn diagnosis code.  Check diagnosis!" G PAT0
  1.  G PAT0
  1. KILL ; Clean up Environment
  1.  K DIC,DFN,DUOUT,DTOUT,ICDNOR,ICDDX,ICDPRC,ICDEXP,ICDTRS,ICDDMS,ICDDRG,ICDMDC,ICDO24,ICDP24,ICDP25,ICDRTC,ICDPT,ICDQU,ICDNSD,ICDNMDC
  1.  K ICDMAJ,ICDS25,ICDSEX,AGE,DOB,CC,HICDRG,ICD,ICDCC3,ICDJ,ICDJJ,ICDL39,ICDFZ,ICDDT,ICDDSP,QUIT
  1.  Q
  1. Q ; Quit Current Patient
  1.  G PAT
  1. AGE ; Ask Patient Age
  1.  S DIR(0)="NOA^0:124:0",DIR("A")="Patient's age: ",DIR("?")="Enter how old the patient is (0-124)." D ^DIR K DIR S AGE=Y G QQ:$D(DUOUT),OUT:$D(DTOUT)
  1.  Q
  1. ALIVE ; Ask if Patient died during this episode of care
  1.  S DIR(0)="YO",DIR("A")="Did patient die during this episode" D ^DIR K DIR S ICDEXP=Y G QQ:$D(DUOUT),OUT:$D(DTOUT)
  1.  Q
  1. TAC ; Ask if Patient was Transferred to Acute Care
  1.  S DIR(0)="YO",DIR("A")="Was patient transferred to an acute care facility" D ^DIR K DIR S ICDTRS=Y G QQ:$D(DUOUT),OUT:$D(DTOUT)
  1.  Q
  1. DAM ; Ask if Patient was Discharged against Medical Advice
  1.  S DIR(0)="YO",DIR("A")="Was patient discharged against medical advice" D ^DIR K DIR S ICDDMS=Y G QQ:$D(DUOUT),OUT:$D(DTOUT)
  1.  Q
  1. SEX ; Ask for Patient's Sex
  1.  S DIR(0)="SBO^M:MALE;F:FEMALE",DIR("?")="Enter M for Male and F for Female",DIR("A")="Patient's Sex" D ^DIR K DIR S SEX=Y G QQ:$D(DUOUT),OUT:$D(DTOUT)
  1.  Q
  1. QQ ; Quit All
  1.  S ICDQU=1 Q
  1. EFFDATE ; Prompts for effective date for DRG grouper?
  1.  K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="Effective Date"
  1.  S DIR("?")="The effective to be used when calculating the DRG code for the patient."
  1.  D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
  1.  S ICDDATE=Y,ICDDSP=Y(0)
  1.  Q
  1. ASK ; Ask all
  1.  K DTOUT,DUOUT D AGE G:ICDQU PAT D ALIVE G:ICDQU PAT D TAC G:ICDQU PAT D DAM G:ICDQU PAT D SEX G:ICDQU PAT G CD
  1. OUT ; Exit Application
  1.  G H^XUS