DGPTDRG ;ALB/ABS - DRG Information Report User Prompts ; 11/15/06 8:31am
;;5.3;Registration;**60,441,510,559,599,606,669,729,1015**;Aug 13, 1993;Build 21
;;ADL;Update for CSV Project;;Mar 28, 2003
S U="^" D Q,DT^DICRW
PAT D EFFDATE G Q:$D(DUOUT),Q:$D(DTOUT)
W !!,"Choose Patient from PATIENT file" S %=1 D YN^DICN G Q:%=-1
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
S DGPTHOW=% I %=2 S NAME="" G AGE
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
;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
S DGEXP=$S($D(^DPT(DFN,.35))#2:1,1:0) I DGEXP,'$P(^(.35),"^") S DGEXP=0
G EXP:DGEXP,TRS
AGE 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
SEX R !!,"Patient's SEX: MALE// ",X:DTIME G Q:X["^"!('$T) S Z="^MALE^FEMALE" I X="" S X="M" W X
D IN^DGHELP I %=-1 W !?3,"Enter <RET> for MALE if hypothetical patient is male",!?3,"Enter 'F' for Female" G SEX
S SEX=$E(X)
EXP 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
S DGEXP=$S(%=1:1,1:0) I DGEXP S (DGTRS,DGDMS)=0 G DX
TRS 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
S DGTRS=$S(%=1:1,1:0)
DMS 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
S DGDMS=$S(%=1:1,1:0)
DX N DXINF,ICDVDT S ICDVDT=DGDAT
S (DGDX,DGSURG)="" S PROMPT="Enter PRINCIPAL diagnosis: "
D ICDEN1^DGPTF5
Q:X["^"!(X="")
S Y=+$$CODEN^ICDCODE(X,80)
I $P($$ICDDX^ICDCODE(Y,DGDAT),U,5) D G DX
. W !,*7,">>>You have selected diagnosis code that is not considered"
. W !,"a primary diagnosis code. Please enter a PRIMARY code."
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
S PROMPT="Enter SECONDARY diagnosis: " W !
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
. I '$P(DGPTTMP,U,10) D INAC S DGI=DGI-1
G Q:X["^" S DIC(0)="AEQMZ",DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,0)",DIC="^ICD0(",DIC("A")="Enter Operation/Procedure: " W !
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)
; added next line for DG*5.3*441
S DGSURG=U_DGSURG
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
S DGDRGPRT=1 D ^DGPTICD,Q G PAT ;return DRG code even if inactive
Q 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
;
EFFDATE ;prompts for effective date for DRG grouper?
K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="Effective Date"
S DIR("?")="The effective to be used when calculating the DRG code for the patient."
D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
S DGDAT=Y
Q
INAC ;
W !,*7,">>> You have selected an INACTIVE diagnosis code."
W !," This code is not used by the grouper and may cause"
W !," the case to be grouped into DRG 470 - UNGROUPABLE.",!
W !," Therefore, this diagnosis code will NOT be passed"
W !," to the grouper. Please enter another code."
DGPTDRG ;ALB/ABS - DRG Information Report User Prompts ; 11/15/06 8:31am
+1 ;;5.3;Registration;**60,441,510,559,599,606,669,729,1015**;Aug 13, 1993;Build 21
+2 ;;ADL;Update for CSV Project;;Mar 28, 2003
+3 SET U="^"
DO Q
DO DT^DICRW
PAT DO EFFDATE
IF $DATA(DUOUT)
GOTO Q
IF $DATA(DTOUT)
GOTO Q
+1 WRITE !!,"Choose Patient from PATIENT file"
SET %=1
DO YN^DICN
IF %=-1
GOTO Q
+2 IF %Y["?"!('%)
WRITE !?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"
GOTO PAT
+3 SET DGPTHOW=%
IF %=2
SET NAME=""
GOTO AGE
+4 NEW DOB
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
WRITE !
DO ^DIC
IF Y'>0
GOTO Q
SET DFN=+Y
SET NAME=$PIECE(Y(0),"^")
SET (DOB,AGE)=$PIECE(Y(0),U,3)
SET SEX=$PIECE(Y(0),U,2)
SET X1=DT
SET X2=AGE
DO ^%DTC
SET AGE=X\365.25
WRITE " AGE:",AGE
+5 ;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
+6 SET DGEXP=$SELECT($DATA(^DPT(DFN,.35))#2:1,1:0)
IF DGEXP
IF '$PIECE(^(.35),"^")
SET DGEXP=0
+7 IF DGEXP
GOTO EXP
GOTO TRS
AGE READ !!,"Patient's AGE: ",AGE:DTIME
IF AGE["^"!('$TEST)
GOTO Q
IF AGE<0!(AGE="")!(AGE>124)!(AGE'?.N)
SET AGE="?"
IF AGE["?"
WRITE !,"Enter a number for patient's age in years (0-124)"
GOTO AGE
SEX READ !!,"Patient's SEX: MALE// ",X:DTIME
IF X["^"!('$TEST)
GOTO Q
SET Z="^MALE^FEMALE"
IF X=""
SET X="M"
WRITE X
+1 DO IN^DGHELP
IF %=-1
WRITE !?3,"Enter <RET> for MALE if hypothetical patient is male",!?3,"Enter 'F' for Female"
GOTO SEX
+2 SET SEX=$EXTRACT(X)
EXP WRITE !!,"Did patient die during this episode"
SET %=2
DO YN^DICN
IF %=-1
GOTO Q
IF %Y["?"!('%)
WRITE !?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"
GOTO EXP
+1 SET DGEXP=$SELECT(%=1:1,1:0)
IF DGEXP
SET (DGTRS,DGDMS)=0
GOTO DX
TRS WRITE !!,"Transfer to an acute care facility"
SET %=2
DO YN^DICN
IF %=-1
GOTO Q
IF %Y["?"!('%)
WRITE !?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"
GOTO TRS
+1 SET DGTRS=$SELECT(%=1:1,1:0)
DMS WRITE !!,"Discharged against medical advice"
SET %=2
DO YN^DICN
IF %=-1
GOTO Q
IF %Y["?"!('%)
WRITE !?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
GOTO DMS
+1 SET DGDMS=$SELECT(%=1:1,1:0)
DX NEW DXINF,ICDVDT
SET ICDVDT=DGDAT
+1 SET (DGDX,DGSURG)=""
SET PROMPT="Enter PRINCIPAL diagnosis: "
+2 DO ICDEN1^DGPTF5
+3 IF X["^"!(X="")
QUIT
+4 SET Y=+$$CODEN^ICDCODE(X,80)
+5 IF $PIECE($$ICDDX^ICDCODE(Y,DGDAT),U,5)
Begin DoDot:1
+6 WRITE !,*7,">>>You have selected diagnosis code that is not considered"
+7 WRITE !,"a primary diagnosis code. Please enter a PRIMARY code."
End DoDot:1
GOTO DX
+8 SET DGPTTMP=$$ICDDX^ICDCODE(+Y,DGDAT)
IF $PIECE(DGPTTMP,U,10)
SET DGDX=+Y
SET DXINF=$$ICDDX^ICDCODE(+Y,DGDAT)
SET DGDX(1)=$PIECE(DXINF,"^",2)_"^"_$PIECE(DXINF,"^",4)
IF '$$ISVALID^ICDGTDRG(+Y,DGDAT,9)
DO INAC
GOTO DX
+9 SET PROMPT="Enter SECONDARY diagnosis: "
WRITE !
+10 FOR DGI=2:1:5
DO ICDEN1^DGPTF5
IF X["^"!(X="")
QUIT
SET Y=+$$CODEN^ICDCODE(X,80)
IF +Y>0
SET DGPTTMP=$$ICDDX^ICDCODE(+Y,DGDAT)
IF DGPTTMP>0&($PIECE(DGPTTMP,U,10))
SET DGDX=DGDX_"^"_+Y
SET DXINF=$$ICDDX^ICDCODE(+Y,DGDAT)
SET DGDX(DGI)=$PIECE(DXINF,"^",2)_"^"_$PIECE(DXINF,"^",4)
Begin DoDot:1
+11 IF '$PIECE(DGPTTMP,U,10)
DO INAC
SET DGI=DGI-1
End DoDot:1
+12 IF X["^"
GOTO Q
SET DIC(0)="AEQMZ"
SET DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,0)"
SET DIC="^ICD0("
SET DIC("A")="Enter Operation/Procedure: "
WRITE !
+13 FOR DGI=1:1:4
DO ^DIC
IF X["^"!(X="")
QUIT
IF +Y>0
SET DGSURG=+Y_"^"_DGSURG
SET DXINF=$$ICDOP^ICDCODE(+Y,DGDAT)
SET DGSURG(DGI)=$PIECE(DXINF,U,2)_U_$PIECE(DXINF,U,5)
+14 ; added next line for DG*5.3*441
+15 SET DGSURG=U_DGSURG
+16 IF X["^"
GOTO Q
IF $DATA(DGPTODR)
SET DGVAR="AGE^NAME^SEX^DGDMS^DGEXP^DGTRS^DGDX#^DGSURG#^DGDAT"
SET DGPGM="^DGPTODR"
WRITE !
DO ZIS^DGUTQ
IF POP
GOTO Q
USE IO
DO ^DGPTODR
DO CLOSE^DGUTQ
DO Q
SET DGPTODR=1
GOTO PAT
+17 ;return DRG code even if inactive
SET DGDRGPRT=1
DO ^DGPTICD
DO Q
GOTO PAT
Q KILL DFN,DGI,DGPGM,AGE,NAME,DGDMS,DGDX,DGEXP,DGPTHOW,DGSURG,DGTRS,DGVAR,DGDRGPRT,DRG,DIC,SEX,POP,X,Y,Z,X1,X2,%,%Y
QUIT
+1 ;
EFFDATE ;prompts for effective date for DRG grouper?
+1 KILL DIR
SET DIR(0)="D^::AEX"
SET DIR("B")="TODAY"
SET DIR("A")="Effective Date"
+2 SET DIR("?")="The effective to be used when calculating the DRG code for the patient."
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET QUIT=1
QUIT
+4 SET DGDAT=Y
+5 QUIT
INAC ;
+1 WRITE !,*7,">>> You have selected an INACTIVE diagnosis code."
+2 WRITE !," This code is not used by the grouper and may cause"
+3 WRITE !," the case to be grouped into DRG 470 - UNGROUPABLE.",!
+4 WRITE !," Therefore, this diagnosis code will NOT be passed"
+5 WRITE !," to the grouper. Please enter another code."
