- 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 Mar 13, 2025@21:13:05 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
