- LEXQDRG3 ;ISL/KER - Query - DRG Calc. (DGPT) ;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
- ; ^DIC ICR 10006
- ; $$FIND1^DIC ICR 2051
- ; $$GET1^DIQ ICR 2056
- ; ^DIR ICR 10026
- ; ^ICDDRG ICR 371
- ; $$DT^XLFDT ICR 10103
- ; $$FMADD^XLFDT ICR 10103
- ; $$FMTE^XLFDT ICR 10103
- ; $$UP^XLFSTR ICR 10104
- ;
- ; ICDDATE Date
- ; ICDEXP Patient died during episode of care 1/0
- ; ICDTRS Was patient transferred to acute care 1/0
- ; ICDDMS Patient discharged against medical advice 1/0
- ; SEX Patient's Sex (pre-surgical M/F
- ; AGE Patient's Age Numeric
- ;
- ; ICDDX(1) Array of ICD Principal Diagnosis
- ; ICDDX(n) Array of ICD Secondary Diagnosis
- ; ICDPRC(n) Array of ICD Procedures
- ;
- EN ; Main Entry Point
- N AGE,DFN,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDDATE,ICDDMS,ICDDRG,ICDDX,ICDEXP
- N ICDPRC,ICDTRS,LEX1,LEXB,LEXC,LEXCODE,LEXD,LEXDCH,LEXDES,LEXDFN,LEXDOB
- N LEXDRG,LEXDT,LEXDX,LEXLEXP,LEXF,LEXFL,LEXFLG,LEXGDAT,LEXI,LEXI1,LEXI2,LEXI3
- N LEXID,LEXIEN,LEXIENS,LEXIPT,LEXIT,LEXMN,LEXMNE,LEXMX,LEXMXE,LEXN,LEXNAM
- N LEXOK,LEXOUT,LEXPDX,LEXPR,LEXPR1,LEXPRDT,LEXPRE,LEXPRS,LEXPTF,LEXSCC
- N LEXSDX,LEXSR,LEXSR1,LEXSRDT,LEXSRS,LEXT,LEXTD,LEXTMP,LEXVAP,SEX,X,Y
- S LEXVAP=$$VAP I +LEXVAP'>0,$L($P(LEXVAP,"^",2)) W !!," ",$P(LEXVAP,"^",2) Q
- I +LEXVAP'>0 W !!," Patient not selected" Q
- S X=$P($$EFF,".",1) I X'?7N,$L($P(X,"^",2)) W !!," ",$P(X,"^",2) Q
- I X'?7N W !!," 'Effective date' missing or invalid" Q
- S (LEXGDAT,ICDDATE)=X,LEXVAP=+($G(LEXVAP)) S LEXOK=$$GETPAT(LEXVAP)
- I LEXOK'>0,$L($P(LEXOK,"^",2)) W !!," ",$P(LEXOK,"^",2) Q
- I LEXOK'>0 W !!," 'Patient treatment information' missing or invalid" Q
- D ^ICDDRG I +($G(ICDDRG))>0 W:$L($G(IOF)) @IOF D DCD^LEXQDRG4,WRT^LEXQDRG4(ICDDRG,ICDDATE)
- Q
- EFF(X) ; Effective date
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXMN,LEXMNE,LEXMX,LEXMXE,LEXN,Y,LEXIMP
- S LEXIMP=$$IMPDATE^LEXU(30),LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60),LEXID="LEXQDRG "_$G(DUZ)_" DATE"
- S LEXB=$P($G(^XTMP(LEXID,"PRE")),".",1) S:LEXB?7N DIR("B")=$$UP^XLFSTR($$FMTE^XLFDT(LEXB,"1D"))
- S LEXMN=2781001,LEXMX=DT S:LEXMX'>LEXIMP LEXMX=LEXIMP S LEXMX=$$FMADD^XLFDT(LEXMX,730)
- S LEXMNE=$$FMTE^XLFDT(+($G(LEXMN)),"1D"),LEXMXE=$$FMTE^XLFDT(+($G(LEXMX)),"1D")
- S LEXMNE=$$UP^XLFSTR(LEXMNE),LEXMXE=$$UP^XLFSTR(LEXMXE) S DIR(0)="DAO^"_LEXMN_":"_LEXMX
- S DIR("?")="^D EFH1^LEXQDRG3" S DIR("??")="^D EFH2^LEXQDRG3"
- S DIR("A")=" Enter the diagnosis effective date: "
- W:+($G(LEXHAS))'>0&('$D(DFN)) ! D ^DIR Q:$D(DTOUT) "0^'Effective date' selection timed-out"
- I $D(DIROUT)!($D(DIRUT))!($D(DUOUT)) D Q X
- . S X="0^'Effective date' selection aborted"
- S Y=$P(Y,".",1) Q:Y'?7N "0^Missing or invalid 'effective date'"
- I Y?7N S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=Y N DFN
- S X=Y Q:X?7N X
- Q "0^Invalid 'effective date'"
- EFH1 ; Effective Date Help #1
- W !," Enter the effective date of the patient's diagnosis"
- I $L($G(LEXMXE)),$L($G(LEXMNE)) D
- . W !!," Select a date from ",LEXMNE," to ",LEXMXE
- Q
- EFH2 ; Effective Date Help #2
- D EFH1 W !
- W !," JAN 20 2012 or 20 JAN 12 or 1/20/12 or 012012"
- W !," T (for TODAY), T+1 (for TOMORROW), T+2, etc."
- W !," T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
- W !," If the year is omitted, the computer uses CURRENT"
- W !," YEAR. Two digit year assumes no more than 20 "
- W !," years in the future, or 80 years in the past."
- W:$L($G(DIR("B"))) !," Press return to accept the default date."
- W !," Enter ""^"" to abort."
- Q
- 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
- VAP(X) ; VA Patient File #2
- N DIC,DTOUT,DUOUT,LEXB,LEXDFN,LEXLEXP,LEXF,LEXID,LEXN,LEXNAM,LEXSCC,Y
- S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60),LEXID="LEXQDRG "_$G(DUZ)_" VAP"
- S LEXB=$G(^XTMP(LEXID,"PRE")),LEXB=$$GET1^DIQ(2,(+LEXB_","),.01)
- S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")=" Select VA Patient: ",DIC("S")="I +($$VAS^LEXQDRG3)>0"
- D ^DIC Q:$D(DTOUT) "0^'VA Patient' selection timed-out"
- I $D(DUOUT) S X="0^'VA Patient' selection aborted" Q X
- I +Y'>0 S X="0^'VA Patient' not selected" Q X
- S X=Y I +Y>0 S DFN=+Y,^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=+Y
- Q X
- VAS(X) ; VA Patient File #2 Screen (live/service connected)
- N LEXDFN,LEXNAM,LEXLEXP,LEXSCC S LEXDFN=+($G(Y)) Q:LEXDFN'>0 0
- S LEXNAM=$$GET1^DIQ(2,(+($G(Y))_","),.01) Q:'$L(LEXNAM) 0
- S LEXLEXP=$$GET1^DIQ(2,(+($G(Y))_","),.351,"I") Q:+LEXLEXP>0 0
- S LEXSCC=$$GET1^DIQ(2,(+($G(Y))_","),.301,"I") Q:$E(LEXSCC,1)'="Y" 0
- Q 1
- ;
- GETPAT(X) ; Get Patient Values
- N LEXDCH,LEXDFN,LEXDOB,LEXNAM,LEXOUT,LEXPTF
- K AGE,ICDDMS,ICDDX,ICDEXP,ICDPRC,ICDTRS,SEX
- S LEXOUT=1,LEXDFN=+($G(X))
- Q:$G(LEXDFN)'>0 "0^Patient (DFN) undefined"
- S LEXNAM=$$GET1^DIQ(2,(+($G(LEXDFN))_","),.01)
- Q:'$L(LEXNAM) "0^Patient (DFN) not found"
- S LEXPTF=$$FIND1^DIC(45,,"B",LEXNAM,"B")
- Q:LEXPTF'>0 "0^Patient Treatment Record not found"
- ; ICDEXP Did patient die during care 1/0
- S ICDEXP=$$GET1^DIQ(45,(+($G(LEXPTF))_","),72,"I"),ICDEXP=$S(ICDEXP>5:1,1:0)
- ; ICDDSM Discharged against medical advice 1/0
- S ICDDMS=$$GET1^DIQ(45,(+($G(LEXPTF))_","),72,"I"),ICDEXP=$S(ICDDMS=4:1,1:0)
- ; ICDTRS Transfer to acute care facility 1/0
- S ICDTRS=$$GET1^DIQ(45,(+($G(LEXPTF))_","),76.2),ICDTRS=$S(ICDEXP:1,1:0)
- ; SEX Sex M/F
- S SEX=$$GET1^DIQ(2,(+($G(LEXDFN))_","),.02,"I")
- ; AGE Age Numeric
- S LEXDCH=$$GET1^DIQ(45,(+($G(LEXPTF))_","),70,"I")
- S LEXDOB=$$GET1^DIQ(2,(+($G(LEXDFN))_","),.03,"I")
- S AGE=$S(LEXDCH:LEXDCH,1:DT)-LEXDOB\10000
- K LEXDX S LEXDX=$$DX^LEXQDRG4(LEXPTF)
- K LEXSR S LEXSR=$$SR^LEXQDRG4(LEXPTF)
- K LEXPR S LEXPR=$$PR^LEXQDRG4(LEXPTF)
- D ICDDXPR^LEXQDRG4
- S LEXOUT=1 S:"^1^0^"'[("^"_ICDEXP_"^") LEXOUT=-1
- S:"^1^0^"'[("^"_ICDTRS_"^") LEXOUT=-2
- S:"^1^0^"'[("^"_ICDDMS_"^") LEXOUT=-3
- S:"^M^F^"'[("^"_SEX_"^") LEXOUT=-4
- S:AGE'?1N.N LEXOUT=-5
- S:$O(ICDDX(0))'>0 LEXOUT=-6
- K:LEXOUT'>0 AGE,SEX,ICDDMS,ICDDX,ICDEXP,ICDPRC,ICDTRS
- S X=LEXOUT S:X'>0 X="0^Error extracting patient treatment information"
- Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQDRG3 7236 printed Mar 13, 2025@21:13:06 Page 2
- LEXQDRG3 ;ISL/KER - Query - DRG Calc. (DGPT) ;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 ; ^DIC ICR 10006
- +8 ; $$FIND1^DIC ICR 2051
- +9 ; $$GET1^DIQ ICR 2056
- +10 ; ^DIR ICR 10026
- +11 ; ^ICDDRG ICR 371
- +12 ; $$DT^XLFDT ICR 10103
- +13 ; $$FMADD^XLFDT ICR 10103
- +14 ; $$FMTE^XLFDT ICR 10103
- +15 ; $$UP^XLFSTR ICR 10104
- +16 ;
- +17 ; ICDDATE Date
- +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 medical advice 1/0
- +21 ; SEX Patient's Sex (pre-surgical M/F
- +22 ; AGE Patient's Age Numeric
- +23 ;
- +24 ; ICDDX(1) Array of ICD Principal Diagnosis
- +25 ; ICDDX(n) Array of ICD Secondary Diagnosis
- +26 ; ICDPRC(n) Array of ICD Procedures
- +27 ;
- EN ; Main Entry Point
- +1 NEW AGE,DFN,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ICDDATE,ICDDMS,ICDDRG,ICDDX,ICDEXP
- +2 NEW ICDPRC,ICDTRS,LEX1,LEXB,LEXC,LEXCODE,LEXD,LEXDCH,LEXDES,LEXDFN,LEXDOB
- +3 NEW LEXDRG,LEXDT,LEXDX,LEXLEXP,LEXF,LEXFL,LEXFLG,LEXGDAT,LEXI,LEXI1,LEXI2,LEXI3
- +4 NEW LEXID,LEXIEN,LEXIENS,LEXIPT,LEXIT,LEXMN,LEXMNE,LEXMX,LEXMXE,LEXN,LEXNAM
- +5 NEW LEXOK,LEXOUT,LEXPDX,LEXPR,LEXPR1,LEXPRDT,LEXPRE,LEXPRS,LEXPTF,LEXSCC
- +6 NEW LEXSDX,LEXSR,LEXSR1,LEXSRDT,LEXSRS,LEXT,LEXTD,LEXTMP,LEXVAP,SEX,X,Y
- +7 SET LEXVAP=$$VAP
- IF +LEXVAP'>0
- IF $LENGTH($PIECE(LEXVAP,"^",2))
- WRITE !!," ",$PIECE(LEXVAP,"^",2)
- QUIT
- +8 IF +LEXVAP'>0
- WRITE !!," Patient not selected"
- QUIT
- +9 SET X=$PIECE($$EFF,".",1)
- IF X'?7N
- IF $LENGTH($PIECE(X,"^",2))
- WRITE !!," ",$PIECE(X,"^",2)
- QUIT
- +10 IF X'?7N
- WRITE !!," 'Effective date' missing or invalid"
- QUIT
- +11 SET (LEXGDAT,ICDDATE)=X
- SET LEXVAP=+($GET(LEXVAP))
- SET LEXOK=$$GETPAT(LEXVAP)
- +12 IF LEXOK'>0
- IF $LENGTH($PIECE(LEXOK,"^",2))
- WRITE !!," ",$PIECE(LEXOK,"^",2)
- QUIT
- +13 IF LEXOK'>0
- WRITE !!," 'Patient treatment information' missing or invalid"
- QUIT
- +14 DO ^ICDDRG
- IF +($GET(ICDDRG))>0
- if $LENGTH($GET(IOF))
- WRITE @IOF
- DO DCD^LEXQDRG4
- DO WRT^LEXQDRG4(ICDDRG,ICDDATE)
- +15 QUIT
- EFF(X) ; Effective date
- +1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,LEXF,LEXID,LEXMN,LEXMNE,LEXMX,LEXMXE,LEXN,Y,LEXIMP
- +2 SET LEXIMP=$$IMPDATE^LEXU(30)
- SET LEXN=$$DT^XLFDT
- SET LEXF=$$FMADD^XLFDT(LEXN,60)
- SET LEXID="LEXQDRG "_$GET(DUZ)_" DATE"
- +3 SET LEXB=$PIECE($GET(^XTMP(LEXID,"PRE")),".",1)
- if LEXB?7N
- SET DIR("B")=$$UP^XLFSTR($$FMTE^XLFDT(LEXB,"1D"))
- +4 SET LEXMN=2781001
- SET LEXMX=DT
- if LEXMX'>LEXIMP
- SET LEXMX=LEXIMP
- SET LEXMX=$$FMADD^XLFDT(LEXMX,730)
- +5 SET LEXMNE=$$FMTE^XLFDT(+($GET(LEXMN)),"1D")
- SET LEXMXE=$$FMTE^XLFDT(+($GET(LEXMX)),"1D")
- +6 SET LEXMNE=$$UP^XLFSTR(LEXMNE)
- SET LEXMXE=$$UP^XLFSTR(LEXMXE)
- SET DIR(0)="DAO^"_LEXMN_":"_LEXMX
- +7 SET DIR("?")="^D EFH1^LEXQDRG3"
- SET DIR("??")="^D EFH2^LEXQDRG3"
- +8 SET DIR("A")=" Enter the diagnosis effective date: "
- +9 if +($GET(LEXHAS))'>0&('$DATA(DFN))
- WRITE !
- DO ^DIR
- if $DATA(DTOUT)
- QUIT "0^'Effective date' selection timed-out"
- +10 IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))
- Begin DoDot:1
- +11 SET X="0^'Effective date' selection aborted"
- End DoDot:1
- QUIT X
- +12 SET Y=$PIECE(Y,".",1)
- if Y'?7N
- QUIT "0^Missing or invalid 'effective date'"
- +13 IF Y?7N
- SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
- SET ^XTMP(LEXID,"PRE")=Y
- NEW DFN
- +14 SET X=Y
- if X?7N
- QUIT X
- +15 QUIT "0^Invalid 'effective date'"
- EFH1 ; Effective Date Help #1
- +1 WRITE !," Enter the effective date of the patient's diagnosis"
- +2 IF $LENGTH($GET(LEXMXE))
- IF $LENGTH($GET(LEXMNE))
- Begin DoDot:1
- +3 WRITE !!," Select a date from ",LEXMNE," to ",LEXMXE
- End DoDot:1
- +4 QUIT
- EFH2 ; Effective Date Help #2
- +1 DO EFH1
- WRITE !
- +2 WRITE !," JAN 20 2012 or 20 JAN 12 or 1/20/12 or 012012"
- +3 WRITE !," T (for TODAY), T+1 (for TOMORROW), T+2, etc."
- +4 WRITE !," T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
- +5 WRITE !," If the year is omitted, the computer uses CURRENT"
- +6 WRITE !," YEAR. Two digit year assumes no more than 20 "
- +7 WRITE !," years in the future, or 80 years in the past."
- +8 if $LENGTH($GET(DIR("B")))
- WRITE !," Press return to accept the default date."
- +9 WRITE !," Enter ""^"" to abort."
- +10 QUIT
- 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
- VAP(X) ; VA Patient File #2
- +1 NEW DIC,DTOUT,DUOUT,LEXB,LEXDFN,LEXLEXP,LEXF,LEXID,LEXN,LEXNAM,LEXSCC,Y
- +2 SET LEXN=$$DT^XLFDT
- SET LEXF=$$FMADD^XLFDT(LEXN,60)
- SET LEXID="LEXQDRG "_$GET(DUZ)_" VAP"
- +3 SET LEXB=$GET(^XTMP(LEXID,"PRE"))
- SET LEXB=$$GET1^DIQ(2,(+LEXB_","),.01)
- +4 SET DIC="^DPT("
- SET DIC(0)="AEQMZ"
- SET DIC("A")=" Select VA Patient: "
- SET DIC("S")="I +($$VAS^LEXQDRG3)>0"
- +5 DO ^DIC
- if $DATA(DTOUT)
- QUIT "0^'VA Patient' selection timed-out"
- +6 IF $DATA(DUOUT)
- SET X="0^'VA Patient' selection aborted"
- QUIT X
- +7 IF +Y'>0
- SET X="0^'VA Patient' not selected"
- QUIT X
- +8 SET X=Y
- IF +Y>0
- SET DFN=+Y
- SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
- SET ^XTMP(LEXID,"PRE")=+Y
- +9 QUIT X
- VAS(X) ; VA Patient File #2 Screen (live/service connected)
- +1 NEW LEXDFN,LEXNAM,LEXLEXP,LEXSCC
- SET LEXDFN=+($GET(Y))
- if LEXDFN'>0
- QUIT 0
- +2 SET LEXNAM=$$GET1^DIQ(2,(+($GET(Y))_","),.01)
- if '$LENGTH(LEXNAM)
- QUIT 0
- +3 SET LEXLEXP=$$GET1^DIQ(2,(+($GET(Y))_","),.351,"I")
- if +LEXLEXP>0
- QUIT 0
- +4 SET LEXSCC=$$GET1^DIQ(2,(+($GET(Y))_","),.301,"I")
- if $EXTRACT(LEXSCC,1)'="Y"
- QUIT 0
- +5 QUIT 1
- +6 ;
- GETPAT(X) ; Get Patient Values
- +1 NEW LEXDCH,LEXDFN,LEXDOB,LEXNAM,LEXOUT,LEXPTF
- +2 KILL AGE,ICDDMS,ICDDX,ICDEXP,ICDPRC,ICDTRS,SEX
- +3 SET LEXOUT=1
- SET LEXDFN=+($GET(X))
- +4 if $GET(LEXDFN)'>0
- QUIT "0^Patient (DFN) undefined"
- +5 SET LEXNAM=$$GET1^DIQ(2,(+($GET(LEXDFN))_","),.01)
- +6 if '$LENGTH(LEXNAM)
- QUIT "0^Patient (DFN) not found"
- +7 SET LEXPTF=$$FIND1^DIC(45,,"B",LEXNAM,"B")
- +8 if LEXPTF'>0
- QUIT "0^Patient Treatment Record not found"
- +9 ; ICDEXP Did patient die during care 1/0
- +10 SET ICDEXP=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),72,"I")
- SET ICDEXP=$SELECT(ICDEXP>5:1,1:0)
- +11 ; ICDDSM Discharged against medical advice 1/0
- +12 SET ICDDMS=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),72,"I")
- SET ICDEXP=$SELECT(ICDDMS=4:1,1:0)
- +13 ; ICDTRS Transfer to acute care facility 1/0
- +14 SET ICDTRS=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),76.2)
- SET ICDTRS=$SELECT(ICDEXP:1,1:0)
- +15 ; SEX Sex M/F
- +16 SET SEX=$$GET1^DIQ(2,(+($GET(LEXDFN))_","),.02,"I")
- +17 ; AGE Age Numeric
- +18 SET LEXDCH=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),70,"I")
- +19 SET LEXDOB=$$GET1^DIQ(2,(+($GET(LEXDFN))_","),.03,"I")
- +20 SET AGE=$SELECT(LEXDCH:LEXDCH,1:DT)-LEXDOB\10000
- +21 KILL LEXDX
- SET LEXDX=$$DX^LEXQDRG4(LEXPTF)
- +22 KILL LEXSR
- SET LEXSR=$$SR^LEXQDRG4(LEXPTF)
- +23 KILL LEXPR
- SET LEXPR=$$PR^LEXQDRG4(LEXPTF)
- +24 DO ICDDXPR^LEXQDRG4
- +25 SET LEXOUT=1
- if "^1^0^"'[("^"_ICDEXP_"^")
- SET LEXOUT=-1
- +26 if "^1^0^"'[("^"_ICDTRS_"^")
- SET LEXOUT=-2
- +27 if "^1^0^"'[("^"_ICDDMS_"^")
- SET LEXOUT=-3
- +28 if "^M^F^"'[("^"_SEX_"^")
- SET LEXOUT=-4
- +29 if AGE'?1N.N
- SET LEXOUT=-5
- +30 if $ORDER(ICDDX(0))'>0
- SET LEXOUT=-6
- +31 if LEXOUT'>0
- KILL AGE,SEX,ICDDMS,ICDDX,ICDEXP,ICDPRC,ICDTRS
- +32 SET X=LEXOUT
- if X'>0
- SET X="0^Error extracting patient treatment information"
- +33 QUIT X
