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 Sep 23, 2025@19:44:29 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
