source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTDRG.m@ 1416

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

initial load of FOIAVistA 6/30/08 version

File size: 4.2 KB
Line 
1DGPTDRG ;ALB/ABS - DRG Information Report User Prompts ; 11/15/06 8:31am
2 ;;5.3;Registration;**60,441,510,559,599,606,669,729**;Aug 13, 1993;Build 59
3 ;;ADL;Update for CSV Project;;Mar 28, 2003
4 S U="^" D Q,DT^DICRW
5PAT D EFFDATE G Q:$D(DUOUT),Q:$D(DTOUT)
6 W !!,"Choose Patient from PATIENT file" S %=1 D YN^DICN G Q:%=-1
7 I %Y["?"!('%) W !?3,"Enter <RET> for YES if you want DRGs for a patient from your PATIENT File",!?3,"Answer 'N' for NO if you want DRGs for a hypothetical patient" G PAT
8 S DGPTHOW=% I %=2 S NAME="" G AGE
9 N DOB S DIC="^DPT(",DIC(0)="AEQMZ" W ! D ^DIC G Q:Y'>0 S DFN=+Y,NAME=$P(Y(0),"^"),(DOB,AGE)=$P(Y(0),U,3),SEX=$P(Y(0),U,2),X1=DT,X2=AGE D ^%DTC S AGE=X\365.25 W " AGE:",AGE
10 ;I AGE<0!(AGE>124) W !,"Unacceptable AGE",!,"Grouper accepts age values from 0-124 years.",!,"Verify patient's age in PATIENT File before continuing." G Q
11 S DGEXP=$S($D(^DPT(DFN,.35))#2:1,1:0) I DGEXP,'$P(^(.35),"^") S DGEXP=0
12 G EXP:DGEXP,TRS
13AGE R !!,"Patient's AGE: ",AGE:DTIME G Q:AGE["^"!('$T) S:AGE<0!(AGE="")!(AGE>124)!(AGE'?.N) AGE="?" I AGE["?" W !,"Enter a number for patient's age in years (0-124)" G AGE
14SEX R !!,"Patient's SEX: MALE// ",X:DTIME G Q:X["^"!('$T) S Z="^MALE^FEMALE" I X="" S X="M" W X
15 D IN^DGHELP I %=-1 W !?3,"Enter <RET> for MALE if hypothetical patient is male",!?3,"Enter 'F' for Female" G SEX
16 S SEX=$E(X)
17EXP W !!,"Did patient die during this episode" S %=2 D YN^DICN G Q:%=-1 I %Y["?"!('%) W !?3,"Enter <RET> for NO if patient did not die during the hospital",!?15,"stay for which this DRG is to be calculated",!?3,"Enter 'Y' for YES" G EXP
18 S DGEXP=$S(%=1:1,1:0) I DGEXP S (DGTRS,DGDMS)=0 G DX
19TRS W !!,"Transfer to an acute care facility" S %=2 D YN^DICN G Q:%=-1 I %Y["?"!('%) W !?3,"Enter <RET> for NO if patient not transfered to an acute care facility",!?3,"Enter 'Y' for YES if patient was transfered to acute care facility" G TRS
20 S DGTRS=$S(%=1:1,1:0)
21DMS W !!,"Discharged against medical advice" S %=2 D YN^DICN G Q:%=-1 I %Y["?"!('%) W !?3,"Enter <RET> for NO if patient did not leave against medical advice",!?3,"Enter 'Y' for YES if patient did leave against medical advice",!,*7 G DMS
22 S DGDMS=$S(%=1:1,1:0)
23DX N DXINF,ICDVDT S ICDVDT=DGDAT
24 S (DGDX,DGSURG)="" S PROMPT="Enter PRINCIPAL diagnosis: "
25 D ICDEN1^DGPTF5
26 Q:X["^"!(X="")
27 S Y=+$$CODEN^ICDCODE(X,80)
28 I $P($$ICDDX^ICDCODE(Y,DGDAT),U,5) D G DX
29 . W !,*7,">>>You have selected diagnosis code that is not considered"
30 . W !,"a primary diagnosis code. Please enter a PRIMARY code."
31 S DGPTTMP=$$ICDDX^ICDCODE(+Y,DGDAT) S:$P(DGPTTMP,U,10) DGDX=+Y,DXINF=$$ICDDX^ICDCODE(+Y,DGDAT),DGDX(1)=$P(DXINF,"^",2)_"^"_$P(DXINF,"^",4) I '$$ISVALID^ICDGTDRG(+Y,DGDAT,9) D INAC G DX
32 S PROMPT="Enter SECONDARY diagnosis: " W !
33 F DGI=2:1:5 D ICDEN1^DGPTF5 Q:X["^"!(X="") S Y=+$$CODEN^ICDCODE(X,80) I +Y>0 S DGPTTMP=$$ICDDX^ICDCODE(+Y,DGDAT) S:DGPTTMP>0&($P(DGPTTMP,U,10)) DGDX=DGDX_"^"_+Y,DXINF=$$ICDDX^ICDCODE(+Y,DGDAT),DGDX(DGI)=$P(DXINF,"^",2)_"^"_$P(DXINF,"^",4) D
34 . I '$P(DGPTTMP,U,10) D INAC S DGI=DGI-1
35 G Q:X["^" S DIC(0)="AEQMZ",DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,0)",DIC="^ICD0(",DIC("A")="Enter Operation/Procedure: " W !
36 F DGI=1:1:4 D ^DIC Q:X["^"!(X="") I +Y>0 S DGSURG=+Y_"^"_DGSURG,DXINF=$$ICDOP^ICDCODE(+Y,DGDAT),DGSURG(DGI)=$P(DXINF,U,2)_U_$P(DXINF,U,5)
37 ; added next line for DG*5.3*441
38 S DGSURG=U_DGSURG
39 G Q:X["^" I $D(DGPTODR) S DGVAR="AGE^NAME^SEX^DGDMS^DGEXP^DGTRS^DGDX#^DGSURG#^DGDAT",DGPGM="^DGPTODR" W ! D ZIS^DGUTQ G:POP Q U IO D ^DGPTODR,CLOSE^DGUTQ,Q S DGPTODR=1 G PAT
40 S DGDRGPRT=1 D ^DGPTICD,Q G PAT ;return DRG code even if inactive
41Q K DFN,DGI,DGPGM,AGE,NAME,DGDMS,DGDX,DGEXP,DGPTHOW,DGSURG,DGTRS,DGVAR,DGDRGPRT,DRG,DIC,SEX,POP,X,Y,Z,X1,X2,%,%Y Q
42 ;
43EFFDATE ;prompts for effective date for DRG grouper?
44 K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="Effective Date"
45 S DIR("?")="The effective to be used when calculating the DRG code for the patient."
46 D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
47 S DGDAT=Y
48 Q
49INAC ;
50 W !,*7,">>> You have selected an INACTIVE diagnosis code."
51 W !," This code is not used by the grouper and may cause"
52 W !," the case to be grouped into DRG 470 - UNGROUPABLE.",!
53 W !," Therefore, this diagnosis code will NOT be passed"
54 W !," to the grouper. Please enter another code."
Note: See TracBrowser for help on using the repository browser.