LEXQDRG ;ISL/KER - Query - DRG Calc. ;12/19/2014
;;2.0;LEXICON UTILITY;**86**;Sep 23, 1996;Build 1
;
; Global Variables
; ^XTMP(ID) SACC 2.3.2.5.2
;
; External References
; HOME^%ZIS ICR 10086
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; ^ICDDRG ICR 371
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Non-Namespaced variables used
;
; ICDDATE Effective Date nnnnnnn
; ICDEXP Patient died during episode of care 1/0
; ICDTRS Was patient transferred to acute care 1/0
; ICDDMS Patient discharged against med advice 1/0
; SEX Patient's Sex (pre-surgical) M/F
; AGE Patient's Age Numeric
; ICDDX(1) ICD Principal Diagnosis file 80 IEN
; ICDDX(n) ICD Secondary Diagnosis file 80 IENs
; ICDPRC(n) ICD Procedures file 80.1 IENs
; ICDPOA(n) Presence on Admission (Y,N,W,U or BLANK)
;
EN ; Main Entry Point
N AGE,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDDATE,ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDPOA
N ICDPRC,ICDTRS,LEX,LEXB,LEXBG,LEXC,LEXCUR,LEXENV,LEXF,LEXGDAT,LEXHAS
N LEXI,LEXID,LEXIEN,LEXIT,LEXLS,LEXN,LEXOK,LEXPTF,LEXS,LEXV,LEXX,SEX,X,Y
S LEXENV=$$EV Q:'$L(LEXENV)
S U="^",(LEXOK,LEXPTF,LEXCUR)=0 S:$D(LEXDEV) LEXPTF=$$PAT
I +LEXPTF'>0,$L($P(LEXPTF,"^",2)) W !!," ",$P(LEXPTF,"^",2) Q
I LEXPTF>0 D EN^LEXQDRG3 Q
S LEXHAS=$$HASPRE^LEXQDRG2 S:LEXHAS>0 LEXCUR=$$UC S:LEXCUR>0 LEXOK=$$GETPRE^LEXQDRG2
I LEXCUR>0,LEXOK'>0,$L($P(LEXOK,"^",2)) W !!," ",$P(LEXOK,"^",2) Q
I LEXCUR>0,LEXOK'>0 W !!," Missing or invalid input variables" Q
S:LEXCUR'>0 LEXOK=$$ASK I +LEXOK'>0 D Q
. I $L($P(LEXOK,"^",2)) W !!," ",$P(LEXOK,"^",2) Q
. W !!," Missing or invalid input variables"
D ^ICDDRG I +($G(ICDDRG))>0 D
. W:$L($G(IOF)) @IOF D DCD^LEXQDRG4,WRT^LEXQDRG4($G(ICDDRG),$G(ICDDATE))
Q
UC(X) ; Use Previously Saved Values
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,LEXV,Y
S LEXID="LEXQDRG "_$G(DUZ)_" UC"
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60)
S DIR(0)="YAO",DIR("A")=" Use previously saved values: (Y/N) "
S (X,DIR("PRE"))="S X=$$UCP^LEXQDRG($G(X))"
S LEXB=$G(^XTMP(LEXID,"UC")) S:$L(LEXB) DIR("B")=LEXB
D ^DIR Q:$D(DTOUT) "-1^'Use previously saved values' selection timed-out"
I $D(DIROUT)!($D(DIRUT))!($D(DUOUT)) D Q X
. S X="-1^'Use previously saved values' selection aborted"
S:"^0^1^"'[("^"_Y_"^") Y="^"
Q:"^0^1^"'[("^"_Y_"^") "-1^'Use previously saved values' selection aborted"
S X=Y,LEXV=$S(Y="0":"No",Y="1":"Yes",1:"") I $L(LEXV) D
. S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Use Previous"
. S ^XTMP(LEXID,"UC")=LEXV
Q X
UCP(X) ; Use Previously Saved Values (Preprocess)
S X=$G(X) Q:'$L(X) "" Q:X["?" "??"
I $G(DIR(0))["YAO",$E(X,1)'="^","^Y^N^"'[("^"_$$UP^XLFSTR($E(X,1)_"^")) Q "??"
Q X
ASK(X) ; Ask for input parameters
N LEXIMP S LEXIMP=$$IMPDATE^LEXU(30)
S X=$$EFF^LEXQDRG3 Q:X'?7N X S (LEXGDAT,ICDDATE)=X
I ICDDATE<LEXIMP S X=$$AGE Q:X'?1N.N!(X["^") X S AGE=X
S X=$$SEX Q:"^M^F^"'[("^"_X_"^") X S SEX=X
S X=$$EXP Q:"^1^0^"'[("^"_X_"^") X S ICDEXP=X
S:$G(ICDEXP)>0 (ICDDMS,ICDTRS)=0
I $G(ICDEXP)'>0 S X=$$DMS Q:"^1^0^"'[("^"_X_"^") X S ICDDMS=X
I $G(ICDEXP)'>0 S X=$$TRS Q:"^1^0^"'[("^"_X_"^") X S ICDTRS=X
K ICDDX W ! S X=$$PDX^LEXQDRG2(ICDDATE) Q:+X'>0 X W ! S X=$$SEC^LEXQDRG2(ICDDATE) Q:+X'>0 X
K ICDDX("B") K ICDPRC W ! S X=$$PRO^LEXQDRG2(ICDDATE) Q:+X'>0 X K ICDPRC("B")
Q 1
AGE(X) ; What is the patient's age
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,LEXX,Y
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60),LEXID="LEXQDRG "_$G(DUZ)_" AGE"
S LEXB=$G(^XTMP(LEXID,"PRE")) S:LEXB>0 DIR("B")=LEXB
S DIR(0)="NOA^0:124:0",DIR("A")=" Enter the patient's age: (0-124) "
S (DIR("?"),DIR("??"))="^D AGEH^LEXQDRG"
S DIR("PRE")="S:X[""?"" X=""??"" S LEXX=X"
D ^DIR Q:X["^"!($D(DIROUT))!($D(DIRUT))!($D(DTOUT))!($D(DUOUT)) "^"
W:'$L($G(LEXX))&(+Y>0)&(+Y<125) +Y," year",$S(X>1:"s",1:"")," old"
W:$L($G(LEXX))&(+Y>0)&(+Y<125) " year",$S(X>1:"s",1:"")," old"
I +Y>0 S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=Y
S X=Y
Q X
AGEH ; What is the patient's age Help
W !," Enter the patient's age, 0-124."
Q
SEX(X) ; What is the sex of the patient
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60),LEXID="LEXQDRG "_$G(DUZ)_" SEX"
S LEXB=$G(^XTMP(LEXID,"PRE")) S:'$L(LEXB) LEXB="Male"
S LEXB=$S(LEXB="M":"Male",LEXB="F":"Female",1:"") S:$L(LEXB) DIR("B")=LEXB
S DIR(0)="SAO^M:Male;F:Female",DIR("A")=" Enter the patient's sex: (M/F) "
S (DIR("??"),DIR("?"))="^D SEXH^LEXQDRG"
S DIR("PRE")="S X=$$UP^XLFSTR(X) S:$E(X,1)'=""M""&($E(X,1)'=""F"")&($L(X)) X=""??"" S:X[""?"" X=""??"""
D ^DIR Q:X["^"!($D(DIROUT))!($D(DIRUT))!($D(DTOUT))!($D(DUOUT)) "^"
I "^M^F^"[("^"_Y_"^") S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=Y
S X=Y
Q X
SEXH ; What is the sex of the patient Help
W !," Answer M for Male or F for Female."
Q
DMS(X) ; Discharged against medical advice
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60),LEXID="LEXQDRG "_$G(DUZ)_" DMS"
S LEXB=$G(^XTMP(LEXID,"PRE")),LEXB=$S(LEXB="1":"YES",LEXB="0":"NO",1:"") S:$L(LEXB) DIR("B")=LEXB
S DIR(0)="YAO",DIR("A")=" Was the patient discharged against medical advice? (Y/N) "
S DIR("?")=" Answer YES if the patient was discharged against medical advice."
S DIR("PRE")="S:X[""?"" X=""?""" D ^DIR
Q:$D(DTOUT) "0^'Discharged against medical advice' selection timed-out"
I $D(DIROUT)!($D(DIRUT))!($D(DUOUT))!("^1^0^"'[("^"_Y_"^")) D Q X
. S X="0^'Discharged against medical advice' selection aborted"
I "^1^0^"[("^"_Y_"^") S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=Y
S X=Y
Q X
TRS(X) ; Was the patient transferred to acute care
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60),LEXID="LEXQDRG "_$G(DUZ)_" TRS"
S LEXB=$G(^XTMP(LEXID,"PRE")),LEXB=$S(LEXB="1":"YES",LEXB="0":"NO",1:"") S:$L(LEXB) DIR("B")=LEXB
S DIR(0)="YAO",DIR("A")=" Was the patient transferred to an acute care facility? (Y/N) "
S DIR("?")=" Answer YES if the patient was transferred to an acute care facility."
S DIR("PRE")="S:X[""?"" X=""?"""
D ^DIR Q:$D(DTOUT) "0^'Was the patient transferred to acute care' selection timed-out"
I $D(DIROUT)!($D(DIRUT))!($D(DUOUT))!("^1^0^"'[("^"_Y_"^")) D Q X
. S X="0^'Was the patient transferred to acute care' selection aborted"
I "^1^0^"[("^"_Y_"^") S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=Y
S X=Y
Q X
EXP(X) ; Did the patient die during episode of care
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60),LEXID="LEXQDRG "_$G(DUZ)_" EXP"
S LEXB=$G(^XTMP(LEXID,"PRE")),LEXB=$S(LEXB="1":"YES",LEXB="0":"NO",1:"") S:$L(LEXB) DIR("B")=LEXB
S DIR(0)="YAO",DIR("A")=" Did the patient die during this episode of care? (Y/N) "
S DIR("?")=" Answer YES if the patient died during this episode of care."
S DIR("PRE")="S:X[""?"" X=""?""" D ^DIR
Q:$D(DTOUT) "0^'Did the patient die during episode of care' selection timed-out"
I $D(DIROUT)!($D(DIRUT))!($D(DUOUT))!("^1^0^"'[("^"_Y_"^")) D Q X
. S X="0^'Did the patient die during episode of care' selection aborted"
I "^1^0^"[("^"_Y_"^") S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=Y
S X=Y
Q X
PAT(X) ; Patient
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60),LEXID="LEXQDRG "_$G(DUZ)_" PAT"
S LEXB=$G(^XTMP(LEXID,"PRE")),LEXB=$S(LEXB="1":"YES",1:"NO") S:$L(LEXB) DIR("B")=LEXB
S DIR(0)="YAO",DIR("A")=" Calculate DRGs for a Registered Patient? (Y/N) "
S DIR("?")="Enter 'Yes' if the patient has been previously registered, enter 'No' for other patient."
S DIR("PRE")="S:X[""?"" X=""?""" D ^DIR
Q:$D(DTOUT) "0^'Calculate DRGs for a Registered Patient' selection timed-out"
I $D(DIROUT)!($D(DIRUT))!($D(DUOUT))!("^1^0^"'[("^"_Y_"^")) D Q X
. S X="0^'Calculate DRGs for a Registered Patient' selection aborted"
I "^1^0^"[("^"_Y_"^") S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=Y
S X=Y
Q X
SXTMP ; Show ^XTMP DX/PR
N LEXSYS F LEXSYS="ICD","ICP","10D","ICP" D
. N LEXCT,LEXIN S LEXCT=0
. F LEXIN=1:1:10 D
. . N LEXNN,LEXNC,LEXID
. . S LEXID="LEXQDRG "_+($G(DUZ))_" DX"_LEXIN_" "_LEXSYS
. . S LEXNN="^XTMP("""_LEXID_""")",LEXNC="^XTMP("""_LEXID_""","
. . F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
. . . S LEXCT=LEXCT+1 W:LEXCT=1 ! W !,LEXNN,"=",@LEXNN
. F LEXIN=1:1:10 D
. . N LEXNN,LEXNC,LEXID S LEXID="LEXQDRG "_+($G(DUZ))_" PR"_LEXIN_" "_LEXSYS
. . S LEXNN="^XTMP("""_LEXID_""")",LEXNC="^XTMP("""_LEXID_""","
. . F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
. . . S LEXCT=LEXCT+1 W:LEXCT=1 ! W !,LEXNN,"=",@LEXNN
W !
Q
EV(X) ; Check environment
N LEX,LEXDEV S DT=$$DT^XLFDT D HOME^%ZIS S U="^" I +($G(DUZ))=0 W !!,?5,"DUZ not defined" Q 0
S LEX=$$GET1^DIQ(200,(DUZ_","),.01) I '$L(LEX) W !!,?5,"DUZ not valid" Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQDRG 9415 printed Sep 23, 2025@19:44:27 Page 2
LEXQDRG ;ISL/KER - Query - DRG Calc. ;12/19/2014
+1 ;;2.0;LEXICON UTILITY;**86**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^XTMP(ID) SACC 2.3.2.5.2
+5 ;
+6 ; External References
+7 ; HOME^%ZIS ICR 10086
+8 ; $$GET1^DIQ ICR 2056
+9 ; ^DIR ICR 10026
+10 ; ^ICDDRG ICR 371
+11 ; $$DT^XLFDT ICR 10103
+12 ; $$FMADD^XLFDT ICR 10103
+13 ; $$UP^XLFSTR ICR 10104
+14 ;
+15 ; Non-Namespaced variables used
+16 ;
+17 ; ICDDATE Effective Date nnnnnnn
+18 ; ICDEXP Patient died during episode of care 1/0
+19 ; ICDTRS Was patient transferred to acute care 1/0
+20 ; ICDDMS Patient discharged against med advice 1/0
+21 ; SEX Patient's Sex (pre-surgical) M/F
+22 ; AGE Patient's Age Numeric
+23 ; ICDDX(1) ICD Principal Diagnosis file 80 IEN
+24 ; ICDDX(n) ICD Secondary Diagnosis file 80 IENs
+25 ; ICDPRC(n) ICD Procedures file 80.1 IENs
+26 ; ICDPOA(n) Presence on Admission (Y,N,W,U or BLANK)
+27 ;
EN ; Main Entry Point
+1 NEW AGE,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDDATE,ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDPOA
+2 NEW ICDPRC,ICDTRS,LEX,LEXB,LEXBG,LEXC,LEXCUR,LEXENV,LEXF,LEXGDAT,LEXHAS
+3 NEW LEXI,LEXID,LEXIEN,LEXIT,LEXLS,LEXN,LEXOK,LEXPTF,LEXS,LEXV,LEXX,SEX,X,Y
+4 SET LEXENV=$$EV
if '$LENGTH(LEXENV)
QUIT
+5 SET U="^"
SET (LEXOK,LEXPTF,LEXCUR)=0
if $DATA(LEXDEV)
SET LEXPTF=$$PAT
+6 IF +LEXPTF'>0
IF $LENGTH($PIECE(LEXPTF,"^",2))
WRITE !!," ",$PIECE(LEXPTF,"^",2)
QUIT
+7 IF LEXPTF>0
DO EN^LEXQDRG3
QUIT
+8 SET LEXHAS=$$HASPRE^LEXQDRG2
if LEXHAS>0
SET LEXCUR=$$UC
if LEXCUR>0
SET LEXOK=$$GETPRE^LEXQDRG2
+9 IF LEXCUR>0
IF LEXOK'>0
IF $LENGTH($PIECE(LEXOK,"^",2))
WRITE !!," ",$PIECE(LEXOK,"^",2)
QUIT
+10 IF LEXCUR>0
IF LEXOK'>0
WRITE !!," Missing or invalid input variables"
QUIT
+11 if LEXCUR'>0
SET LEXOK=$$ASK
IF +LEXOK'>0
Begin DoDot:1
+12 IF $LENGTH($PIECE(LEXOK,"^",2))
WRITE !!," ",$PIECE(LEXOK,"^",2)
QUIT
+13 WRITE !!," Missing or invalid input variables"
End DoDot:1
QUIT
+14 DO ^ICDDRG
IF +($GET(ICDDRG))>0
Begin DoDot:1
+15 if $LENGTH($GET(IOF))
WRITE @IOF
DO DCD^LEXQDRG4
DO WRT^LEXQDRG4($GET(ICDDRG),$GET(ICDDATE))
End DoDot:1
+16 QUIT
UC(X) ; Use Previously Saved Values
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,LEXV,Y
+2 SET LEXID="LEXQDRG "_$GET(DUZ)_" UC"
+3 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
+4 SET DIR(0)="YAO"
SET DIR("A")=" Use previously saved values: (Y/N) "
+5 SET (X,DIR("PRE"))="S X=$$UCP^LEXQDRG($G(X))"
+6 SET LEXB=$GET(^XTMP(LEXID,"UC"))
if $LENGTH(LEXB)
SET DIR("B")=LEXB
+7 DO ^DIR
if $DATA(DTOUT)
QUIT "-1^'Use previously saved values' selection timed-out"
+8 IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))
Begin DoDot:1
+9 SET X="-1^'Use previously saved values' selection aborted"
End DoDot:1
QUIT X
+10 if "^0^1^"'[("^"_Y_"^")
SET Y="^"
+11 if "^0^1^"'[("^"_Y_"^")
QUIT "-1^'Use previously saved values' selection aborted"
+12 SET X=Y
SET LEXV=$SELECT(Y="0":"No",Y="1":"Yes",1:"")
IF $LENGTH(LEXV)
Begin DoDot:1
+13 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Use Previous"
+14 SET ^XTMP(LEXID,"UC")=LEXV
End DoDot:1
+15 QUIT X
UCP(X) ; Use Previously Saved Values (Preprocess)
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT ""
if X["?"
QUIT "??"
+2 IF $GET(DIR(0))["YAO"
IF $EXTRACT(X,1)'="^"
IF "^Y^N^"'[("^"_$$UP^XLFSTR($EXTRACT(X,1)_"^"))
QUIT "??"
+3 QUIT X
ASK(X) ; Ask for input parameters
+1 NEW LEXIMP
SET LEXIMP=$$IMPDATE^LEXU(30)
+2 SET X=$$EFF^LEXQDRG3
if X'?7N
QUIT X
SET (LEXGDAT,ICDDATE)=X
+3 IF ICDDATE<LEXIMP
SET X=$$AGE
if X'?1N.N!(X["^")
QUIT X
SET AGE=X
+4 SET X=$$SEX
if "^M^F^"'[("^"_X_"^")
QUIT X
SET SEX=X
+5 SET X=$$EXP
if "^1^0^"'[("^"_X_"^")
QUIT X
SET ICDEXP=X
+6 if $GET(ICDEXP)>0
SET (ICDDMS,ICDTRS)=0
+7 IF $GET(ICDEXP)'>0
SET X=$$DMS
if "^1^0^"'[("^"_X_"^")
QUIT X
SET ICDDMS=X
+8 IF $GET(ICDEXP)'>0
SET X=$$TRS
if "^1^0^"'[("^"_X_"^")
QUIT X
SET ICDTRS=X
+9 KILL ICDDX
WRITE !
SET X=$$PDX^LEXQDRG2(ICDDATE)
if +X'>0
QUIT X
WRITE !
SET X=$$SEC^LEXQDRG2(ICDDATE)
if +X'>0
QUIT X
+10 KILL ICDDX("B")
KILL ICDPRC
WRITE !
SET X=$$PRO^LEXQDRG2(ICDDATE)
if +X'>0
QUIT X
KILL ICDPRC("B")
+11 QUIT 1
AGE(X) ; What is the patient's age
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,LEXX,Y
+2 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
SET LEXID="LEXQDRG "_$GET(DUZ)_" AGE"
+3 SET LEXB=$GET(^XTMP(LEXID,"PRE"))
if LEXB>0
SET DIR("B")=LEXB
+4 SET DIR(0)="NOA^0:124:0"
SET DIR("A")=" Enter the patient's age: (0-124) "
+5 SET (DIR("?"),DIR("??"))="^D AGEH^LEXQDRG"
+6 SET DIR("PRE")="S:X[""?"" X=""??"" S LEXX=X"
+7 DO ^DIR
if X["^"!($DATA(DIROUT))!($DATA(DIRUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT "^"
+8 if '$LENGTH($GET(LEXX))&(+Y>0)&(+Y<125)
WRITE +Y," year",$SELECT(X>1:"s",1:"")," old"
+9 if $LENGTH($GET(LEXX))&(+Y>0)&(+Y<125)
WRITE " year",$SELECT(X>1:"s",1:"")," old"
+10 IF +Y>0
SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=Y
+11 SET X=Y
+12 QUIT X
AGEH ; What is the patient's age Help
+1 WRITE !," Enter the patient's age, 0-124."
+2 QUIT
SEX(X) ; What is the sex of the patient
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
+2 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
SET LEXID="LEXQDRG "_$GET(DUZ)_" SEX"
+3 SET LEXB=$GET(^XTMP(LEXID,"PRE"))
if '$LENGTH(LEXB)
SET LEXB="Male"
+4 SET LEXB=$SELECT(LEXB="M":"Male",LEXB="F":"Female",1:"")
if $LENGTH(LEXB)
SET DIR("B")=LEXB
+5 SET DIR(0)="SAO^M:Male;F:Female"
SET DIR("A")=" Enter the patient's sex: (M/F) "
+6 SET (DIR("??"),DIR("?"))="^D SEXH^LEXQDRG"
+7 SET DIR("PRE")="S X=$$UP^XLFSTR(X) S:$E(X,1)'=""M""&($E(X,1)'=""F"")&($L(X)) X=""??"" S:X[""?"" X=""??"""
+8 DO ^DIR
if X["^"!($DATA(DIROUT))!($DATA(DIRUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT "^"
+9 IF "^M^F^"[("^"_Y_"^")
SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=Y
+10 SET X=Y
+11 QUIT X
SEXH ; What is the sex of the patient Help
+1 WRITE !," Answer M for Male or F for Female."
+2 QUIT
DMS(X) ; Discharged against medical advice
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
+2 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
SET LEXID="LEXQDRG "_$GET(DUZ)_" DMS"
+3 SET LEXB=$GET(^XTMP(LEXID,"PRE"))
SET LEXB=$SELECT(LEXB="1":"YES",LEXB="0":"NO",1:"")
if $LENGTH(LEXB)
SET DIR("B")=LEXB
+4 SET DIR(0)="YAO"
SET DIR("A")=" Was the patient discharged against medical advice? (Y/N) "
+5 SET DIR("?")=" Answer YES if the patient was discharged against medical advice."
+6 SET DIR("PRE")="S:X[""?"" X=""?"""
DO ^DIR
+7 if $DATA(DTOUT)
QUIT "0^'Discharged against medical advice' selection timed-out"
+8 IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))!("^1^0^"'[("^"_Y_"^"))
Begin DoDot:1
+9 SET X="0^'Discharged against medical advice' selection aborted"
End DoDot:1
QUIT X
+10 IF "^1^0^"[("^"_Y_"^")
SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=Y
+11 SET X=Y
+12 QUIT X
TRS(X) ; Was the patient transferred to acute care
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
+2 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
SET LEXID="LEXQDRG "_$GET(DUZ)_" TRS"
+3 SET LEXB=$GET(^XTMP(LEXID,"PRE"))
SET LEXB=$SELECT(LEXB="1":"YES",LEXB="0":"NO",1:"")
if $LENGTH(LEXB)
SET DIR("B")=LEXB
+4 SET DIR(0)="YAO"
SET DIR("A")=" Was the patient transferred to an acute care facility? (Y/N) "
+5 SET DIR("?")=" Answer YES if the patient was transferred to an acute care facility."
+6 SET DIR("PRE")="S:X[""?"" X=""?"""
+7 DO ^DIR
if $DATA(DTOUT)
QUIT "0^'Was the patient transferred to acute care' selection timed-out"
+8 IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))!("^1^0^"'[("^"_Y_"^"))
Begin DoDot:1
+9 SET X="0^'Was the patient transferred to acute care' selection aborted"
End DoDot:1
QUIT X
+10 IF "^1^0^"[("^"_Y_"^")
SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=Y
+11 SET X=Y
+12 QUIT X
EXP(X) ; Did the patient die during episode of care
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
+2 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
SET LEXID="LEXQDRG "_$GET(DUZ)_" EXP"
+3 SET LEXB=$GET(^XTMP(LEXID,"PRE"))
SET LEXB=$SELECT(LEXB="1":"YES",LEXB="0":"NO",1:"")
if $LENGTH(LEXB)
SET DIR("B")=LEXB
+4 SET DIR(0)="YAO"
SET DIR("A")=" Did the patient die during this episode of care? (Y/N) "
+5 SET DIR("?")=" Answer YES if the patient died during this episode of care."
+6 SET DIR("PRE")="S:X[""?"" X=""?"""
DO ^DIR
+7 if $DATA(DTOUT)
QUIT "0^'Did the patient die during episode of care' selection timed-out"
+8 IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))!("^1^0^"'[("^"_Y_"^"))
Begin DoDot:1
+9 SET X="0^'Did the patient die during episode of care' selection aborted"
End DoDot:1
QUIT X
+10 IF "^1^0^"[("^"_Y_"^")
SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=Y
+11 SET X=Y
+12 QUIT X
PAT(X) ; Patient
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXN,Y
+2 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
SET LEXID="LEXQDRG "_$GET(DUZ)_" PAT"
+3 SET LEXB=$GET(^XTMP(LEXID,"PRE"))
SET LEXB=$SELECT(LEXB="1":"YES",1:"NO")
if $LENGTH(LEXB)
SET DIR("B")=LEXB
+4 SET DIR(0)="YAO"
SET DIR("A")=" Calculate DRGs for a Registered Patient? (Y/N) "
+5 SET DIR("?")="Enter 'Yes' if the patient has been previously registered, enter 'No' for other patient."
+6 SET DIR("PRE")="S:X[""?"" X=""?"""
DO ^DIR
+7 if $DATA(DTOUT)
QUIT "0^'Calculate DRGs for a Registered Patient' selection timed-out"
+8 IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))!("^1^0^"'[("^"_Y_"^"))
Begin DoDot:1
+9 SET X="0^'Calculate DRGs for a Registered Patient' selection aborted"
End DoDot:1
QUIT X
+10 IF "^1^0^"[("^"_Y_"^")
SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=Y
+11 SET X=Y
+12 QUIT X
SXTMP ; Show ^XTMP DX/PR
+1 NEW LEXSYS
FOR LEXSYS="ICD","ICP","10D","ICP"
Begin DoDot:1
+2 NEW LEXCT,LEXIN
SET LEXCT=0
+3 FOR LEXIN=1:1:10
Begin DoDot:2
+4 NEW LEXNN,LEXNC,LEXID
+5 SET LEXID="LEXQDRG "_+($GET(DUZ))_" DX"_LEXIN_" "_LEXSYS
+6 SET LEXNN="^XTMP("""_LEXID_""")"
SET LEXNC="^XTMP("""_LEXID_""","
+7 FOR
SET LEXNN=$QUERY(@LEXNN)
if '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
Begin DoDot:3
+8 SET LEXCT=LEXCT+1
if LEXCT=1
WRITE !
WRITE !,LEXNN,"=",@LEXNN
End DoDot:3
End DoDot:2
+9 FOR LEXIN=1:1:10
Begin DoDot:2
+10 NEW LEXNN,LEXNC,LEXID
SET LEXID="LEXQDRG "_+($GET(DUZ))_" PR"_LEXIN_" "_LEXSYS
+11 SET LEXNN="^XTMP("""_LEXID_""")"
SET LEXNC="^XTMP("""_LEXID_""","
+12 FOR
SET LEXNN=$QUERY(@LEXNN)
if '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
Begin DoDot:3
+13 SET LEXCT=LEXCT+1
if LEXCT=1
WRITE !
WRITE !,LEXNN,"=",@LEXNN
End DoDot:3
End DoDot:2
End DoDot:1
+14 WRITE !
+15 QUIT
EV(X) ; Check environment
+1 NEW LEX,LEXDEV
SET DT=$$DT^XLFDT
DO HOME^%ZIS
SET U="^"
IF +($GET(DUZ))=0
WRITE !!,?5,"DUZ not defined"
QUIT 0
+2 SET LEX=$$GET1^DIQ(200,(DUZ_","),.01)
IF '$LENGTH(LEX)
WRITE !!,?5,"DUZ not valid"
QUIT 0
+3 QUIT 1
