source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRGM.m@ 1123

Last change on this file since 1123 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.4 KB
Line 
1ICDDRGM ;ALB/GRR/EG/ADL - GROUPER DRIVER ; 10/23/00 11:45am
2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000
3 ;;ADL;Add Date prompt and passing of effective date for DRG CSV project
4 ;;ADL;Update DIC("S") code to screen using new function calls
5 ;;ADL;Update to access DRG file using new API for CSV Project
6 S U="^",DT=$$DT^XLFDT W !!?11,"DRG Grouper Version ","18.0",!! ;$$VERSION^XPDUTL("ICD"),!!
7PAT D KILL ; clean up old variables
8 S ICDQU=0 K ICDEXP,SEX,ICDDX
9 D EFFDATE G KILL:$D(DUOUT),OUT:$D(DTOUT)
10 S DIR(0)="Y",DIR("A")="DRGs for Registered PATIENTS (Y/N)",DIR("B")="YES"
11 S DIR("?")="Enter 'Yes' if the patient has been previously registered, enter 'No' for other patient, or '^' to quit."
12 D ^DIR K DIR S ICDPT=Y G KILL:$D(DUOUT),OUT:$D(DTOUT)
13PAT0 G:ICDPT=0 ASK
14VA 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)
15 D TAC G:ICDQU PAT D DAM G:ICDQU PAT
16EN1 I $D(^DPT(DFN,.35)),$L(^DPT(DFN,.35)) D ALIVE G:ICDQU PAT
17 S ICDEXP=$S($D(ICDEXP):ICDEXP,1:0)
18 I AGE]"" N %,X,X1,X2 S X1=DT,X2=AGE D ^%DTC S AGE=X\365.25 W " AGE: ",AGE
19CD K DIC S CC=0,DIC="^ICD9(",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
20 . S DIC("S")="I '$P($$ICDDX^ICDCODE(+Y,ICDDATE),U,5),$$ISVALID^ICDGTDRG(+Y,ICDDATE,9)"
21 F ICDNSD=2:1 S DIC="^ICD9(",DIC(0)="AEQMZ",DIC("A")="Enter SECONDARY diagnosis: ",DIC("S")="I $$ISVALID^ICDGTDRG(+Y,ICDDATE,9)" D ^DIC K DIC Q:X=""!(X[U)!(Y'>0) G:$D(DTOUT) OUT S ICDDX(ICDNSD)=+Y
22 G Q:X[U
23OP S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,ICDDATE,0)" K ICDPRC
24 W ! F ICDNOR=1:1 S DIC="^ICD0(",DIC(0)="AEQMZ",DIC("A")="Enter Operation/Procedure: " D ^DIC Q:X=""!(X[U)!(Y'>0) G:$D(DTOUT) OUT S ICDPRC(ICDNOR)=+Y
25 K DIC G Q:X["^"
26 D ^ICDDRG S:ICDDRG=470 ICDRTC=470 K ICDEXP,SEX,ICDDX I ICDRTC'=0 G ERROR
27 D WRT G PAT0
28WRT S ICDDRG(0)=$$DRG^ICDGTDRG(+ICDDRG,ICDDATE) ; new CSV code
29 W !!?9,"Effective Date: "," ",ICDDSP
30 W !,"Diagnosis Related Group: ",$J(ICDDRG,6),?40,"Avg len of stay: ",$J($P(ICDDRG(0),"^",8),6)
31 W !?17,"Weight: ",$J($P(ICDDRG(0),"^",2),6),?40,"Local Breakeven: ",$J($P(ICDDRG(0),"^",12),6)
32 W !?12," Low day(s): ",$J($P(ICDDRG(0),"^",3),6),?39,"Local low day(s): ",$J($P(ICDDRG(0),"^",9),6)
33 W !?13," High days: ",$J($P(ICDDRG(0),"^",4),6),?40,"Local High days: ",$J($P(ICDDRG(0),"^",10),6)
34 ;W !!,"DRG: ",ICDDRG,"-" F I=0:0 S I=$N(^ICD(ICDDRG,1,I)) Q:I'>0 W ?10,$P(^(I,0),U,1),!
35 W !!,"DRG: ",ICDDRG,"-" F I=0:0 S I=$O(^ICD(ICDDRG,1,I)) Q:(I="")!(I'?.N) W ?10,$P(^(I,0),U,1),!
36 Q
37ERROR D WRT
38 I ICDRTC<5 W !!,"Invalid ",$S(ICDRTC=1:"Principal Diagnosis",ICDRTC=2:"Operation/Procedure",ICDRTC=3:"Age",ICDRTC=4:"Sex",1:"") G PAT0
39 I ICDRTC=5 W !!,"Grouper needs to know if patient died during this episode!" G PAT0
40 I ICDRTC=6 W !!,"Grouper needs to know if patient was transferred to an acute care facility!" G PAT0
41 I ICDRTC=7 W !!,"Grouper needs to know if patient was discharged against medical advice!" G PAT0
42 I ICDRTC=8 W !!,"Patient assigned newborn diagnosis code. Check diagnosis!" G PAT0
43 I ICDRTC=470 W !!,"Grouping function error - contact IRMFO"
44 G PAT0
45KILL K DIC,DFN,DUOUT,DTOUT,ICDNOR,ICDDX,ICDPRC,ICDEXP,ICDTRS,ICDDMS,ICDDRG,ICDMDC,ICDO24,ICDP24,ICDP25,ICDRTC,ICDPT,ICDQU,ICDNSD,ICDNMDC
46 K ICDMAJ,ICDS25,ICDSEX,AGE,DOB,CC,HICDRG,ICD,ICDCC3,ICDJ,ICDJJ,ICDL39,ICDFZ,ICDDT,ICDDSP
47 Q
48Q G PAT
49AGE 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)
50 Q
51ALIVE 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)
52 Q
53TAC 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)
54 Q
55DAM 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)
56 Q
57SEX 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)
58 Q
59QQ S ICDQU=1 Q
60EFFDATE ;prompts for effective date for DRG grouper?
61 K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="Effective Date"
62 S DIR("?")="The effective to be used when calculating the DRG code for the patient."
63 D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
64 S ICDDATE=Y,ICDDSP=Y(0)
65 Q
66ASK 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
67OUT G H^XUS
Note: See TracBrowser for help on using the repository browser.