- 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."
