LEXQDRG2 ;ISL/KER - Query - DRG Calc. (PDX/SDX/PRO/PRE) ;12/19/2014
;;2.0;LEXICON UTILITY;**86**;Sep 23, 1996;Build 1
;
; Global Variables
; ^ICD9( ICR 4485
; ^ICD0( ICR 4486
; ^XTMP(ID) SACC 2.3.2.5.2
;
; External References
; EN^DDIOL ICR 10142
; ^DIC ICR 10006
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; $$HAC^ICDEX ICR 5747
; $$CODEC^ICDEX ICR 5747
; $$ROOT^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
;
; 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
; ICDPOA Present on Admission Y/N/U/W
; SEX Patient's Sex (pre-surgical M/F
; AGE Patient's Age Numeric
;
; Get Codes
PDX(X) ; Principal DX
N DIC,DTOUT,DUOUT,LEXC,LEXF,LEXID,LEXIEN,LEXPDX,LEXN,LEXSYS,LEXPOA,LEXIT,Y,ICDDATE
S LEXIT=0,ICDDATE=$G(X) Q:$P(ICDDATE,".",1)'?7N "0^Date not Passed"
S LEXSYS="10D" S:ICDDATE<$$IMPDATE^LEXU(30) LEXSYS="ICD"
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60),LEXID="LEXQDRG "_$G(DUZ)_" DX1"_" "_LEXSYS
S LEXIEN=$G(^XTMP(LEXID,"PRE")),LEXC=$$CODEC^ICDEX(80,LEXIEN)
S:$L(LEXC)&(LEXC'["^") DIC("B")=LEXC
S DIC=$$ROOT^ICDEX(80),DIC(0)="AEQMZI"
S DIC("A")=" Enter the Principal Diagnosis: "
S DIC("S")="I '$P($$ICDDX^ICDEX(+Y,$G(ICDDATE),,""I""),U,5),$$ISVALID^ICDEX(80,+Y,$G(ICDDATE))"
D ^DIC I $G(X)["^^" D
. S DUOUT=1 N LEXID,LEXB,LEXQ
. S LEXID="LEXQDRG "_$G(DUZ)_" DX1"_" "_LEXSYS K ^XTMP(LEXID)
. S LEXBG=2,LEXQ=0 F LEXS=LEXBG:1 D Q:LEXQ
. . N LEXID,LEXIEN S LEXID="LEXQDRG "_$G(DUZ)_" DX"_LEXS_" "_LEXSYS
. . S LEXIEN=$G(^XTMP(LEXID,"PRE")) K:LEXIEN>0 ^XTMP(LEXID) S:LEXIEN'>0 LEXQ=1
. S LEXBG=1,LEXQ=0 F LEXS=LEXBG:1 D Q:LEXQ
. . N LEXID,LEXIEN S LEXID="LEXQDRG "_$G(DUZ)_" PR"_LEXS_" "_LEXSYS
. . S LEXIEN=$G(^XTMP(LEXID,"PRE")) K:LEXIEN>0 ^XTMP(LEXID) S:LEXIEN'>0 LEXQ=1
Q:$D(DTOUT) "0^Principal diagnosis selection timed-out"
Q:$D(DUOUT) "0^Principal diagnosis selection aborted"
Q:+Y'>0 "0^Missing or invalid principal diagnosis" S LEXPDX=+Y,LEXPOA="",LEXIT=0
I LEXSYS="10D",+LEXPDX>0 S LEXPOA=$$POA(+LEXPDX) S:LEXPOA["^" LEXIT=1
Q:LEXIT "0^Missing or invalid data"
Q:LEXSYS="10D"&('$L($G(LEXPOA))) "0^Missing POA"
Q:LEXSYS="10D"&($G(LEXPOA)["^") "0^Invalid POA"
I +($G(LEXPDX))>0 D Q 1
. S ICDDX(1)=+($G(LEXPDX)),ICDDX("B",+($G(LEXPDX)))=1
. S:$G(LEXSYS)="10D"&($L($G(LEXPOA))) ICDPOA(1)=LEXPOA
. S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=+($G(LEXPDX))
Q 0
SEC(X) ; Seconary DX
N DIC,DICA,DTOUT,DUOUT,LEXBG,LEXC,LEXF,LEXID,LEXIEN,LEXIT,LEXLS,LEXSYS,LEXN,LEXS,Y,ICDDATE
S ICDDATE=$G(X) Q:$P(ICDDATE,".",1)'?7N "0^Date not Passed" K DICA
S LEXSYS="10D" S:ICDDATE<$$IMPDATE^LEXU(30) LEXSYS="ICD"
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60)
S LEXIT=0,LEXLS=1 F S LEXLS=$O(ICDDX(LEXLS)) Q:+LEXLS'>0 D
. N LEXIEN S LEXIEN=$G(ICDDX(LEXLS)) K:+LEXIEN>0 ICDDX("B",+LEXIEN),ICDDX(LEXLS)
S LEXLS=0 F LEXS=2:1 D Q:LEXIT
. S:LEXS>5 LEXIT=1 Q:LEXIT N DIC,LEXIEN,LEXC,LEXSEC,LEXPOA,LEXIT2
. S DIC=$$ROOT^ICDEX(80),DIC(0)="AEQMZI"
. S LEXID="LEXQDRG "_$G(DUZ)_" DX"_LEXS_" "_LEXSYS
. S LEXIEN=$G(^XTMP(LEXID,"PRE"))
. S LEXC=$$CODEC^ICDEX(80,LEXIEN) S:$L(LEXC)&(LEXC'["^") DIC("B")=LEXC
. S DIC("A")=" Enter a Secondary Diagnosis: " S:$L($G(DICA)) DIC("A")=$G(DICA)
. S DIC("S")="I $$ISVALID^ICDEX(80,+Y,$G(ICDDATE)),'$D(ICDDX(""B"",+Y))"
. D ^DIC I $G(X)["^^" D
. . S DUOUT=1 N LEXBG,LEXS,LEXQ S LEXBG=2,LEXQ=0 F LEXS=LEXBG:1 D Q:LEXQ
. . . N LEXID,LEXIEN S LEXID="LEXQDRG "_$G(DUZ)_" DX"_LEXS_" "_LEXSYS
. . . S LEXIEN=$G(^XTMP(LEXID,"PRE")) K:LEXIEN>0 ^XTMP(LEXID) S:LEXIEN'>0 LEXQ=1
. I '$L(X)!($D(DTOUT))!($D(DUOUT))!(+Y'>0) S LEXIT=1 Q
. S DICA=" Enter another Secondary Diagnosis: "
. S LEXSEC=+($G(Y)),LEXPOA="",LEXIT2=0 I LEXSYS="10D",+LEXSEC>0 D
. . S LEXPOA=$$POA(+LEXSEC) S:LEXPOA["^" LEXIT2=1 Q:LEXIT
. Q:LEXIT2 Q:LEXSYS="10D"&('$L($G(LEXPOA))) Q:LEXSYS="10D"&($G(LEXPOA)["^")
. S ICDDX(LEXS)=+Y,ICDDX("B",+Y)=LEXS,ICDPOA(LEXS)=LEXPOA
. S LEXLS=LEXS S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=+Y
Q:$D(DTOUT) "0^Secondary diagnosis selection timed-out"
Q:$G(X)["^^" "0^Secondary diagnosis selection aborted"
N LEXBG,LEXS,LEXIT S LEXBG=LEXLS+1,LEXIT=0 F LEXS=LEXBG:1 D Q:LEXIT
. Q:LEXS=1 N LEXID,LEXIEN,LEXAI S LEXID="LEXQDRG "_$G(DUZ)_" DX"_LEXS_" "_LEXSYS
. S LEXIEN=$G(^XTMP(LEXID,"PRE")) K:LEXIEN>0 ^XTMP(LEXID) S:LEXIEN'>0 LEXIT=1
. S LEXAI=$G(ICDDX("B",+LEXIEN)) K:+LEXAI>1 ICDDX(+LEXAI),ICDDX("B",+LEXIEN)
Q 1
PRO(X) ; Procedures
N DIC,DICA,DTOUT,DUOUT,LEXBG,LEXC,LEXF,LEXID,LEXIEN,LEXIT,LEXLS,LEXSYS,LEXN,LEXS,Y,ICDDATE
S ICDDATE=$G(X) Q:$P(ICDDATE,".",1)'?7N "0^Date not Passed" K DICA
S LEXSYS="10P" S:ICDDATE<$$IMPDATE^LEXU(31) LEXSYS="ICP"
S (LEXIT,LEXLS)=0 F S LEXLS=$O(ICDPRC(LEXLS)) Q:+LEXLS'>0 D
. N LEXIEN S LEXIEN=$G(ICDPRC(LEXLS)) K:+LEXIEN>0 ICDPRC("B",+LEXIEN),ICDPRC(LEXLS)
S (LEXLS,LEXIT)=0 S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60) F LEXS=1:1 D Q:LEXIT
. S:LEXS>5 LEXIT=1 Q:LEXIT N DIC,LEXIEN,LEXC S DIC=$$ROOT^ICDEX(80.1),DIC(0)="AEQMZI"
. S LEXID="LEXQDRG "_$G(DUZ)_" PR"_LEXS_" "_LEXSYS,LEXIEN=$G(^XTMP(LEXID,"PRE"))
. S LEXC=$$CODEC^ICDEX(80.1,LEXIEN) S:$L(LEXC)&(LEXC'["^") DIC("B")=LEXC
. S DIC("A")=" Enter an Operation/Procedure: " S:$L($G(DICA)) DIC("A")=DICA
. S DIC("S")="I $$ISVALID^ICDEX(80.1,+Y,$G(ICDDATE)),'$D(ICDPRC(""B"",+Y))"
. D ^DIC I $G(X)["^^" D
. . S DUOUT=1 N LEXBG,LEXS,LEXQ S LEXBG=1,LEXQ=0 F LEXS=LEXBG:1 D Q:LEXQ
. . . N LEXID,LEXIEN S LEXID="LEXQDRG "_$G(DUZ)_" PR"_LEXS_" "_LEXSYS
. . . S LEXIEN=$G(^XTMP(LEXID,"PRE")) K:LEXIEN>0 ^XTMP(LEXID) S:LEXIEN'>0 LEXQ=1
. I '$L(X)!($D(DTOUT))!($D(DUOUT))!(+Y'>0) S LEXIT=1 Q
. S DICA=" Enter another Operation/Procedure: "
. S ICDPRC(LEXS)=+Y,ICDPRC("B",+Y)=LEXS,LEXID=("LEXQDRG "_$G(DUZ)_" PR"_LEXS_" "_LEXSYS)
. S LEXLS=LEXS S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=+Y
Q:$D(DTOUT) "0^Procedure selection timed-out"
Q:$G(X)["^^" "0^Procedure selection aborted"
N LEXBG,LEXS,LEXIT S LEXBG=LEXLS+1,LEXIT=0 F LEXS=LEXBG:1 D Q:LEXIT
. N LEXID,LEXIEN,LEXAI S LEXID="LEXQDRG "_$G(DUZ)_" PR"_LEXS_" "_LEXSYS
. S LEXIEN=$G(^XTMP(LEXID,"PRE")) K:LEXIEN>0 ^XTMP(LEXID) S:LEXIEN'>0 LEXIT=1
. S LEXAI=$G(ICDPRC("B",+LEXIEN)) K:+LEXAI>1 ICDPRC(+LEXAI),ICDPRC("B",+LEXIEN)
Q 1
;
POA(X) ; Present On Admission
N DIR,DUOUT,DTOUT,DIRUT,DIROUT,Y,LEXPR,LEXIEN,LEXHAC,LEXPOAE,LEXQ S LEXIEN=+($G(X)) Q:'$D(^ICD9(+LEXIEN,0)) "^"
S LEXPOAE=$$POAE^ICDEX(LEXIEN) Q:LEXPOAE>0 "N" S LEXHAC=+($$HAC^ICDEX(LEXIEN))
K DIR S DIR("A")=" Present on Admission: ",DIR(0)="SOA^Y:YES;N:NO;U:Unknown;W:Clinically undetermined"
S:LEXHAC'>0 DIR("B")="NO" S DIR("PRE")="S LEXQ=X S:X[""?"" X=""??"""
S DIR("??")="^D POAH2^LEXQDRG2",DIR("?")="^D POAH1^LEXQDRG2"
D ^DIR I ($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) Q "^"
I X="" D
. I $$GET1^DIQ(80,LEXIEN,1.9,"I")'=1 D
. . S LEXPR(1)=" Diagnosis "_$$GET1^DIQ(80,LEXIEN,.01,"I")_" is not contained in the POA Exempt"
. . S LEXPR(2)=" list so the POA field should not be blank. If left blank, it will be"
. . S LEXPR(3)=" treated as if it were a No (""N"")" W !
. . D EN^DDIOL(.LEXPR) W !
. . K DIR S DIR(0)="YAO",DIR("A")=" Do you wish to continue? (Y/N) ",DIR("B")="YES" D ^DIR I ($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) S Y="^"
. . S:Y=0 Y="^" Q:Y["^" S Y="N"
. E S Y="Y"
S X=$$UP^XLFSTR(Y)
Q X
POAH1 ; Present On Admission ? Help
W !,?9,"Was the diagnosis present on admission? Answer Yes, No,"
W:+($G(LEXHAC))'>0 !,?9,"Unknown or Clinical undtermined"
W:+($G(LEXHAC))>0 !,?9,"Unknown, Clinical undtermined or <enter>."
Q
POAH2 ; Present On Admission ?? Help
I $G(LEXQ)["?",$G(LEXQ)'["??" D POAH1 S LEXQ="" Q
W !,?9,"Apply the Present on Admission (POA) indicator for each diagnosis"
W !,?9,"and external cause of injury code(s) reported as the final set of"
W !,?9,"diagnosis codes assigned. One of the following values should be"
W !,?9,"assigned in accordance with the official coding guidelines:"
W !,?9,""
W !,?9,"Y = present at the time of inpatient admission;"
W !,?9,"N = not present at the time of inpatient admission;"
W !,?9,"U = documentation is insufficient to determine if"
W !,?9," condition is present on admission;"
W !,?9,"W = provider is unable to clinically determine"
W !,?9," whether condition was present on admission or not"
W:+($G(LEXHAC))>0 !,?9,"<enter> = use only if diagnosis is exempt from POA reporting"
Q
;
; Previous Values
GETPRE(X) ; Get Previous Values
N LEXI,LEXS,LEXX,LEXSYS,LEXIMP K ICDDX,ICDPRC
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" DATE"),"PRE"))
S:$P(LEXX,".",1)'?7N LEXX=$$DT^XLFDT S ICDDATE=LEXX
S LEXIMP=$$IMPDATE^LEXU(30),LEXSYS="10D" S:ICDDATE<LEXIMP LEXSYS="ICD"
F LEXI=1:1 Q:'$D(^XTMP(("LEXQDRG "_$G(DUZ)_" DX"_LEXI_" "_LEXSYS))) D
. N LEXX S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" DX"_LEXI_" "_LEXSYS),"PRE"))
. I +LEXX>0 S LEXS=$O(ICDDX(" "),-1)+1,ICDDX(LEXS)=LEXX
S LEXSYS="10P" S:ICDDATE<LEXIMP LEXSYS="ICP"
F LEXI=1:1 Q:'$D(^XTMP(("LEXQDRG "_$G(DUZ)_" PR"_LEXI_" "_LEXSYS))) D
. N LEXX S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" PR"_LEXI_" "_LEXSYS),"PRE"))
. I +LEXX>0 S LEXS=$O(ICDPRC(" "),-1)+1,ICDPRC(LEXS)=LEXX
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" AGE"),"PRE"))
S:LEXX'>0 LEXX=40 S AGE=LEXX
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" SEX"),"PRE"))
S:'$L(LEXX) LEXX="M" S SEX=LEXX
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" DMS"),"PRE"))
S:'$L(LEXX) LEXX=0 S ICDDMS=LEXX
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" TRS"),"PRE"))
S:'$L(LEXX) LEXX=0 S ICDTRS=LEXX
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" DATE"),"EXP"))
S:'$L(LEXX) LEXX=0 S ICDEXP=LEXX
Q:'$D(ICDDX(1)) "0^Missing Principal Diagnois"
Q:$G(AGE)'?1N.N "0^Missing or invalid 'age'"
Q:"^M^F^"'[("^"_$G(SEX)_"^") "0^Missing or invalid 'sex'"
Q:"^1^0^"'[("^"_$G(ICDDMS)_"^") "0^Missing or invalid 'discharged against medical advice'"
Q:"^1^0^"'[("^"_$G(ICDTRS)_"^") "0^Missing or invalid 'transferred to acute care facility'"
Q:"^1^0^"'[("^"_$G(ICDEXP)_"^") "0^Missing or invalid 'died during episode of care'"
Q 1
SETPRE ; Set Previous Values
N LEXF,LEXI,LEXID,LEXN,LEXV,LEXIMP,LEXSYS
S LEXN=$$DT^XLFDT,LEXF=$$FMADD^XLFDT(LEXN,60) D PURPRE
S LEXIMP=$$IMPDATE^LEXU(30),LEXSYS="10D" S:$G(ICDDATE)<LEXIMP LEXSYS="ICD"
S LEXI=0 F S LEXI=$O(ICDDX(LEXI)) Q:+LEXI'>0 D
. N LEXV S LEXV=$P($G(ICDDX(LEXI)),"^",1)
. Q:+LEXV'>0 S LEXID="LEXQDRG "_$G(DUZ)_" DX"_LEXI_" "_LEXSYS
. S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=LEXV
S LEXSYS="10P" S:$G(ICDDATE)<LEXIMP LEXSYS="ICP"
S LEXI=0 F S LEXI=$O(ICDPRC(LEXI)) Q:+LEXI'>0 D
. N LEXV S LEXV=$P($G(ICDPRC(LEXI)),"^",1)
. Q:+LEXV'>0 S LEXID="LEXQDRG "_$G(DUZ)_" PR"_LEXI_" "_LEXSYS
. S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=LEXV
S LEXV=$G(AGE) S:LEXV'>0 LEXV=40 S LEXID="LEXQDRG "_$G(DUZ)_" AGE"
S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=LEXV
S LEXV=$G(SEX) S:"^M^F^"'[("^"_LEXV_"^") LEXV="M" S LEXID="LEXQDRG "_$G(DUZ)_" SEX"
S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=LEXV
S LEXV=$G(ICDDATE) S:$P(LEXV,".",1)'?7N LEXV=$$NOW^XLFDT S LEXID="LEXQDRG "_$G(DUZ)_" DATE"
S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=LEXV
S LEXV=$G(ICDDMS) S:'$L(LEXV) LEXV=0 S LEXID="LEXQDRG "_$G(DUZ)_" DMS"
S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=LEXV
S LEXV=$G(ICDTRS) S:'$L(LEXV) LEXV=0 S LEXID="LEXQDRG "_$G(DUZ)_" TRS"
S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=LEXV
S LEXV=$G(ICDEXP) S:'$L(LEXV) LEXV=0 S LEXID="LEXQDRG "_$G(DUZ)_" EXP"
S ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous",^XTMP(LEXID,"PRE")=LEXV
Q
PURPRE ; Purge Saved Values
N LEXI,LEXIMP,LEXSYS Q:+($G(ICDDATE))'>0 S LEXIMP=$$IMPDATE^LEXU(30),LEXSYS="10D"
S:$G(ICDDATE)<LEXIMP LEXSYS="ICD" K ^XTMP(("LEXQDRG "_$G(DUZ)_" DX1 "_LEXSYS))
F LEXI=2:1 Q:'$D(^XTMP(("LEXQDRG "_$G(DUZ)_" DX"_LEXI_" "_LEXSYS))) K ^XTMP(("LEXQDRG "_$G(DUZ)_" DX"_LEXI_" "_LEXSYS))
F LEXI=1:1 Q:'$D(^XTMP(("LEXQDRG "_$G(DUZ)_" PR"_LEXI))) K ^XTMP(("LEXQDRG "_$G(DUZ)_" PR"_LEXI))
Q
HASPRE(X) ; User Has Previous Values
N LEXX,LEX9 S LEX9=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" DX1 ICD"),"PRE"))
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" DX1 10D"),"PRE")) Q:+LEXX'>0&(+LEX9'>0) -1
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" AGE"),"PRE")) Q:+LEXX'>0 -2
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" DATE"),"PRE")) Q:$P(LEXX,".",1)'?7N -3
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" SEX"),"PRE")) Q:"^M^F^"'[("^"_LEXX_"^") -4
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" EXP"),"PRE")) Q:"^1^0^"'[("^"_LEXX_"^") -5
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" DMS"),"PRE")) Q:"^1^0^"'[("^"_LEXX_"^") -6
S LEXX=$G(^XTMP(("LEXQDRG "_$G(DUZ)_" TRS"),"PRE")) Q:"^1^0^"'[("^"_LEXX_"^") -7
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQDRG2 13471 printed Sep 23, 2025@19:44:28 Page 2
LEXQDRG2 ;ISL/KER - Query - DRG Calc. (PDX/SDX/PRO/PRE) ;12/19/2014
+1 ;;2.0;LEXICON UTILITY;**86**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^ICD9( ICR 4485
+5 ; ^ICD0( ICR 4486
+6 ; ^XTMP(ID) SACC 2.3.2.5.2
+7 ;
+8 ; External References
+9 ; EN^DDIOL ICR 10142
+10 ; ^DIC ICR 10006
+11 ; $$GET1^DIQ ICR 2056
+12 ; ^DIR ICR 10026
+13 ; $$HAC^ICDEX ICR 5747
+14 ; $$CODEC^ICDEX ICR 5747
+15 ; $$ROOT^ICDEX ICR 5747
+16 ; $$DT^XLFDT ICR 10103
+17 ; $$FMADD^XLFDT ICR 10103
+18 ; $$NOW^XLFDT ICR 10103
+19 ; $$UP^XLFSTR ICR 10104
+20 ;
+21 ; Local Variables NEWed or KILLed Elsewhere
+22 ;
+23 ; ICDDATE Effective Date nnnnnnn
+24 ; ICDEXP Patient died during episode of care 1/0
+25 ; ICDTRS Was patient transferred to acute care 1/0
+26 ; ICDDMS Patient discharged against med advice 1/0
+27 ; ICDPOA Present on Admission Y/N/U/W
+28 ; SEX Patient's Sex (pre-surgical M/F
+29 ; AGE Patient's Age Numeric
+30 ;
+31 ; Get Codes
PDX(X) ; Principal DX
+1 NEW DIC,DTOUT,DUOUT,LEXC,LEXF,LEXID,LEXIEN,LEXPDX,LEXN,LEXSYS,LEXPOA,LEXIT,Y,ICDDATE
+2 SET LEXIT=0
SET ICDDATE=$GET(X)
if $PIECE(ICDDATE,".",1)'?7N
QUIT "0^Date not Passed"
+3 SET LEXSYS="10D"
if ICDDATE<$$IMPDATE^LEXU(30)
SET LEXSYS="ICD"
+4 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
SET LEXID="LEXQDRG "_$GET(DUZ)_" DX1"_" "_LEXSYS
+5 SET LEXIEN=$GET(^XTMP(LEXID,"PRE"))
SET LEXC=$$CODEC^ICDEX(80,LEXIEN)
+6 if $LENGTH(LEXC)&(LEXC'["^")
SET DIC("B")=LEXC
+7 SET DIC=$$ROOT^ICDEX(80)
SET DIC(0)="AEQMZI"
+8 SET DIC("A")=" Enter the Principal Diagnosis: "
+9 SET DIC("S")="I '$P($$ICDDX^ICDEX(+Y,$G(ICDDATE),,""I""),U,5),$$ISVALID^ICDEX(80,+Y,$G(ICDDATE))"
+10 DO ^DIC
IF $GET(X)["^^"
Begin DoDot:1
+11 SET DUOUT=1
NEW LEXID,LEXB,LEXQ
+12 SET LEXID="LEXQDRG "_$GET(DUZ)_" DX1"_" "_LEXSYS
KILL ^XTMP(LEXID)
+13 SET LEXBG=2
SET LEXQ=0
FOR LEXS=LEXBG:1
Begin DoDot:2
+14 NEW LEXID,LEXIEN
SET LEXID="LEXQDRG "_$GET(DUZ)_" DX"_LEXS_" "_LEXSYS
+15 SET LEXIEN=$GET(^XTMP(LEXID,"PRE"))
if LEXIEN>0
KILL ^XTMP(LEXID)
if LEXIEN'>0
SET LEXQ=1
End DoDot:2
if LEXQ
QUIT
+16 SET LEXBG=1
SET LEXQ=0
FOR LEXS=LEXBG:1
Begin DoDot:2
+17 NEW LEXID,LEXIEN
SET LEXID="LEXQDRG "_$GET(DUZ)_" PR"_LEXS_" "_LEXSYS
+18 SET LEXIEN=$GET(^XTMP(LEXID,"PRE"))
if LEXIEN>0
KILL ^XTMP(LEXID)
if LEXIEN'>0
SET LEXQ=1
End DoDot:2
if LEXQ
QUIT
End DoDot:1
+19 if $DATA(DTOUT)
QUIT "0^Principal diagnosis selection timed-out"
+20 if $DATA(DUOUT)
QUIT "0^Principal diagnosis selection aborted"
+21 if +Y'>0
QUIT "0^Missing or invalid principal diagnosis"
SET LEXPDX=+Y
SET LEXPOA=""
SET LEXIT=0
+22 IF LEXSYS="10D"
IF +LEXPDX>0
SET LEXPOA=$$POA(+LEXPDX)
if LEXPOA["^"
SET LEXIT=1
+23 if LEXIT
QUIT "0^Missing or invalid data"
+24 if LEXSYS="10D"&('$LENGTH($GET(LEXPOA)))
QUIT "0^Missing POA"
+25 if LEXSYS="10D"&($GET(LEXPOA)["^")
QUIT "0^Invalid POA"
+26 IF +($GET(LEXPDX))>0
Begin DoDot:1
+27 SET ICDDX(1)=+($GET(LEXPDX))
SET ICDDX("B",+($GET(LEXPDX)))=1
+28 if $GET(LEXSYS)="10D"&($LENGTH($GET(LEXPOA)))
SET ICDPOA(1)=LEXPOA
+29 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=+($GET(LEXPDX))
End DoDot:1
QUIT 1
+30 QUIT 0
SEC(X) ; Seconary DX
+1 NEW DIC,DICA,DTOUT,DUOUT,LEXBG,LEXC,LEXF,LEXID,LEXIEN,LEXIT,LEXLS,LEXSYS,LEXN,LEXS,Y,ICDDATE
+2 SET ICDDATE=$GET(X)
if $PIECE(ICDDATE,".",1)'?7N
QUIT "0^Date not Passed"
KILL DICA
+3 SET LEXSYS="10D"
if ICDDATE<$$IMPDATE^LEXU(30)
SET LEXSYS="ICD"
+4 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
+5 SET LEXIT=0
SET LEXLS=1
FOR
SET LEXLS=$ORDER(ICDDX(LEXLS))
if +LEXLS'>0
QUIT
Begin DoDot:1
+6 NEW LEXIEN
SET LEXIEN=$GET(ICDDX(LEXLS))
if +LEXIEN>0
KILL ICDDX("B",+LEXIEN),ICDDX(LEXLS)
End DoDot:1
+7 SET LEXLS=0
FOR LEXS=2:1
Begin DoDot:1
+8 if LEXS>5
SET LEXIT=1
if LEXIT
QUIT
NEW DIC,LEXIEN,LEXC,LEXSEC,LEXPOA,LEXIT2
+9 SET DIC=$$ROOT^ICDEX(80)
SET DIC(0)="AEQMZI"
+10 SET LEXID="LEXQDRG "_$GET(DUZ)_" DX"_LEXS_" "_LEXSYS
+11 SET LEXIEN=$GET(^XTMP(LEXID,"PRE"))
+12 SET LEXC=$$CODEC^ICDEX(80,LEXIEN)
if $LENGTH(LEXC)&(LEXC'["^")
SET DIC("B")=LEXC
+13 SET DIC("A")=" Enter a Secondary Diagnosis: "
if $LENGTH($GET(DICA))
SET DIC("A")=$GET(DICA)
+14 SET DIC("S")="I $$ISVALID^ICDEX(80,+Y,$G(ICDDATE)),'$D(ICDDX(""B"",+Y))"
+15 DO ^DIC
IF $GET(X)["^^"
Begin DoDot:2
+16 SET DUOUT=1
NEW LEXBG,LEXS,LEXQ
SET LEXBG=2
SET LEXQ=0
FOR LEXS=LEXBG:1
Begin DoDot:3
+17 NEW LEXID,LEXIEN
SET LEXID="LEXQDRG "_$GET(DUZ)_" DX"_LEXS_" "_LEXSYS
+18 SET LEXIEN=$GET(^XTMP(LEXID,"PRE"))
if LEXIEN>0
KILL ^XTMP(LEXID)
if LEXIEN'>0
SET LEXQ=1
End DoDot:3
if LEXQ
QUIT
End DoDot:2
+19 IF '$LENGTH(X)!($DATA(DTOUT))!($DATA(DUOUT))!(+Y'>0)
SET LEXIT=1
QUIT
+20 SET DICA=" Enter another Secondary Diagnosis: "
+21 SET LEXSEC=+($GET(Y))
SET LEXPOA=""
SET LEXIT2=0
IF LEXSYS="10D"
IF +LEXSEC>0
Begin DoDot:2
+22 SET LEXPOA=$$POA(+LEXSEC)
if LEXPOA["^"
SET LEXIT2=1
if LEXIT
QUIT
End DoDot:2
+23 if LEXIT2
QUIT
if LEXSYS="10D"&('$LENGTH($GET(LEXPOA)))
QUIT
if LEXSYS="10D"&($GET(LEXPOA)["^")
QUIT
+24 SET ICDDX(LEXS)=+Y
SET ICDDX("B",+Y)=LEXS
SET ICDPOA(LEXS)=LEXPOA
+25 SET LEXLS=LEXS
SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=+Y
End DoDot:1
if LEXIT
QUIT
+26 if $DATA(DTOUT)
QUIT "0^Secondary diagnosis selection timed-out"
+27 if $GET(X)["^^"
QUIT "0^Secondary diagnosis selection aborted"
+28 NEW LEXBG,LEXS,LEXIT
SET LEXBG=LEXLS+1
SET LEXIT=0
FOR LEXS=LEXBG:1
Begin DoDot:1
+29 if LEXS=1
QUIT
NEW LEXID,LEXIEN,LEXAI
SET LEXID="LEXQDRG "_$GET(DUZ)_" DX"_LEXS_" "_LEXSYS
+30 SET LEXIEN=$GET(^XTMP(LEXID,"PRE"))
if LEXIEN>0
KILL ^XTMP(LEXID)
if LEXIEN'>0
SET LEXIT=1
+31 SET LEXAI=$GET(ICDDX("B",+LEXIEN))
if +LEXAI>1
KILL ICDDX(+LEXAI),ICDDX("B",+LEXIEN)
End DoDot:1
if LEXIT
QUIT
+32 QUIT 1
PRO(X) ; Procedures
+1 NEW DIC,DICA,DTOUT,DUOUT,LEXBG,LEXC,LEXF,LEXID,LEXIEN,LEXIT,LEXLS,LEXSYS,LEXN,LEXS,Y,ICDDATE
+2 SET ICDDATE=$GET(X)
if $PIECE(ICDDATE,".",1)'?7N
QUIT "0^Date not Passed"
KILL DICA
+3 SET LEXSYS="10P"
if ICDDATE<$$IMPDATE^LEXU(31)
SET LEXSYS="ICP"
+4 SET (LEXIT,LEXLS)=0
FOR
SET LEXLS=$ORDER(ICDPRC(LEXLS))
if +LEXLS'>0
QUIT
Begin DoDot:1
+5 NEW LEXIEN
SET LEXIEN=$GET(ICDPRC(LEXLS))
if +LEXIEN>0
KILL ICDPRC("B",+LEXIEN),ICDPRC(LEXLS)
End DoDot:1
+6 SET (LEXLS,LEXIT)=0
SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
FOR LEXS=1:1
Begin DoDot:1
+7 if LEXS>5
SET LEXIT=1
if LEXIT
QUIT
NEW DIC,LEXIEN,LEXC
SET DIC=$$ROOT^ICDEX(80.1)
SET DIC(0)="AEQMZI"
+8 SET LEXID="LEXQDRG "_$GET(DUZ)_" PR"_LEXS_" "_LEXSYS
SET LEXIEN=$GET(^XTMP(LEXID,"PRE"))
+9 SET LEXC=$$CODEC^ICDEX(80.1,LEXIEN)
if $LENGTH(LEXC)&(LEXC'["^")
SET DIC("B")=LEXC
+10 SET DIC("A")=" Enter an Operation/Procedure: "
if $LENGTH($GET(DICA))
SET DIC("A")=DICA
+11 SET DIC("S")="I $$ISVALID^ICDEX(80.1,+Y,$G(ICDDATE)),'$D(ICDPRC(""B"",+Y))"
+12 DO ^DIC
IF $GET(X)["^^"
Begin DoDot:2
+13 SET DUOUT=1
NEW LEXBG,LEXS,LEXQ
SET LEXBG=1
SET LEXQ=0
FOR LEXS=LEXBG:1
Begin DoDot:3
+14 NEW LEXID,LEXIEN
SET LEXID="LEXQDRG "_$GET(DUZ)_" PR"_LEXS_" "_LEXSYS
+15 SET LEXIEN=$GET(^XTMP(LEXID,"PRE"))
if LEXIEN>0
KILL ^XTMP(LEXID)
if LEXIEN'>0
SET LEXQ=1
End DoDot:3
if LEXQ
QUIT
End DoDot:2
+16 IF '$LENGTH(X)!($DATA(DTOUT))!($DATA(DUOUT))!(+Y'>0)
SET LEXIT=1
QUIT
+17 SET DICA=" Enter another Operation/Procedure: "
+18 SET ICDPRC(LEXS)=+Y
SET ICDPRC("B",+Y)=LEXS
SET LEXID=("LEXQDRG "_$GET(DUZ)_" PR"_LEXS_" "_LEXSYS)
+19 SET LEXLS=LEXS
SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=+Y
End DoDot:1
if LEXIT
QUIT
+20 if $DATA(DTOUT)
QUIT "0^Procedure selection timed-out"
+21 if $GET(X)["^^"
QUIT "0^Procedure selection aborted"
+22 NEW LEXBG,LEXS,LEXIT
SET LEXBG=LEXLS+1
SET LEXIT=0
FOR LEXS=LEXBG:1
Begin DoDot:1
+23 NEW LEXID,LEXIEN,LEXAI
SET LEXID="LEXQDRG "_$GET(DUZ)_" PR"_LEXS_" "_LEXSYS
+24 SET LEXIEN=$GET(^XTMP(LEXID,"PRE"))
if LEXIEN>0
KILL ^XTMP(LEXID)
if LEXIEN'>0
SET LEXIT=1
+25 SET LEXAI=$GET(ICDPRC("B",+LEXIEN))
if +LEXAI>1
KILL ICDPRC(+LEXAI),ICDPRC("B",+LEXIEN)
End DoDot:1
if LEXIT
QUIT
+26 QUIT 1
+27 ;
POA(X) ; Present On Admission
+1 NEW DIR,DUOUT,DTOUT,DIRUT,DIROUT,Y,LEXPR,LEXIEN,LEXHAC,LEXPOAE,LEXQ
SET LEXIEN=+($GET(X))
if '$DATA(^ICD9(+LEXIEN,0))
QUIT "^"
+2 SET LEXPOAE=$$POAE^ICDEX(LEXIEN)
if LEXPOAE>0
QUIT "N"
SET LEXHAC=+($$HAC^ICDEX(LEXIEN))
+3 KILL DIR
SET DIR("A")=" Present on Admission: "
SET DIR(0)="SOA^Y:YES;N:NO;U:Unknown;W:Clinically undetermined"
+4 if LEXHAC'>0
SET DIR("B")="NO"
SET DIR("PRE")="S LEXQ=X S:X[""?"" X=""??"""
+5 SET DIR("??")="^D POAH2^LEXQDRG2"
SET DIR("?")="^D POAH1^LEXQDRG2"
+6 DO ^DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))
QUIT "^"
+7 IF X=""
Begin DoDot:1
+8 IF $$GET1^DIQ(80,LEXIEN,1.9,"I")'=1
Begin DoDot:2
+9 SET LEXPR(1)=" Diagnosis "_$$GET1^DIQ(80,LEXIEN,.01,"I")_" is not contained in the POA Exempt"
+10 SET LEXPR(2)=" list so the POA field should not be blank. If left blank, it will be"
+11 SET LEXPR(3)=" treated as if it were a No (""N"")"
WRITE !
+12 DO EN^DDIOL(.LEXPR)
WRITE !
+13 KILL DIR
SET DIR(0)="YAO"
SET DIR("A")=" Do you wish to continue? (Y/N) "
SET DIR("B")="YES"
DO ^DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))
SET Y="^"
+14 if Y=0
SET Y="^"
if Y["^"
QUIT
SET Y="N"
End DoDot:2
+15 IF '$TEST
SET Y="Y"
End DoDot:1
+16 SET X=$$UP^XLFSTR(Y)
+17 QUIT X
POAH1 ; Present On Admission ? Help
+1 WRITE !,?9,"Was the diagnosis present on admission? Answer Yes, No,"
+2 if +($GET(LEXHAC))'>0
WRITE !,?9,"Unknown or Clinical undtermined"
+3 if +($GET(LEXHAC))>0
WRITE !,?9,"Unknown, Clinical undtermined or <enter>."
+4 QUIT
POAH2 ; Present On Admission ?? Help
+1 IF $GET(LEXQ)["?"
IF $GET(LEXQ)'["??"
DO POAH1
SET LEXQ=""
QUIT
+2 WRITE !,?9,"Apply the Present on Admission (POA) indicator for each diagnosis"
+3 WRITE !,?9,"and external cause of injury code(s) reported as the final set of"
+4 WRITE !,?9,"diagnosis codes assigned. One of the following values should be"
+5 WRITE !,?9,"assigned in accordance with the official coding guidelines:"
+6 WRITE !,?9,""
+7 WRITE !,?9,"Y = present at the time of inpatient admission;"
+8 WRITE !,?9,"N = not present at the time of inpatient admission;"
+9 WRITE !,?9,"U = documentation is insufficient to determine if"
+10 WRITE !,?9," condition is present on admission;"
+11 WRITE !,?9,"W = provider is unable to clinically determine"
+12 WRITE !,?9," whether condition was present on admission or not"
+13 if +($GET(LEXHAC))>0
WRITE !,?9,"<enter> = use only if diagnosis is exempt from POA reporting"
+14 QUIT
+15 ;
+16 ; Previous Values
GETPRE(X) ; Get Previous Values
+1 NEW LEXI,LEXS,LEXX,LEXSYS,LEXIMP
KILL ICDDX,ICDPRC
+2 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" DATE"),"PRE"))
+3 if $PIECE(LEXX,".",1)'?7N
SET LEXX=$$DT^XLFDT
SET ICDDATE=LEXX
+4 SET LEXIMP=$$IMPDATE^LEXU(30)
SET LEXSYS="10D"
if ICDDATE<LEXIMP
SET LEXSYS="ICD"
+5 FOR LEXI=1:1
if '$DATA(^XTMP(("LEXQDRG "_$GET(DUZ)_" DX"_LEXI_" "_LEXSYS)))
QUIT
Begin DoDot:1
+6 NEW LEXX
SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" DX"_LEXI_" "_LEXSYS),"PRE"))
+7 IF +LEXX>0
SET LEXS=$ORDER(ICDDX(" "),-1)+1
SET ICDDX(LEXS)=LEXX
End DoDot:1
+8 SET LEXSYS="10P"
if ICDDATE<LEXIMP
SET LEXSYS="ICP"
+9 FOR LEXI=1:1
if '$DATA(^XTMP(("LEXQDRG "_$GET(DUZ)_" PR"_LEXI_" "_LEXSYS)))
QUIT
Begin DoDot:1
+10 NEW LEXX
SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" PR"_LEXI_" "_LEXSYS),"PRE"))
+11 IF +LEXX>0
SET LEXS=$ORDER(ICDPRC(" "),-1)+1
SET ICDPRC(LEXS)=LEXX
End DoDot:1
+12 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" AGE"),"PRE"))
+13 if LEXX'>0
SET LEXX=40
SET AGE=LEXX
+14 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" SEX"),"PRE"))
+15 if '$LENGTH(LEXX)
SET LEXX="M"
SET SEX=LEXX
+16 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" DMS"),"PRE"))
+17 if '$LENGTH(LEXX)
SET LEXX=0
SET ICDDMS=LEXX
+18 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" TRS"),"PRE"))
+19 if '$LENGTH(LEXX)
SET LEXX=0
SET ICDTRS=LEXX
+20 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" DATE"),"EXP"))
+21 if '$LENGTH(LEXX)
SET LEXX=0
SET ICDEXP=LEXX
+22 if '$DATA(ICDDX(1))
QUIT "0^Missing Principal Diagnois"
+23 if $GET(AGE)'?1N.N
QUIT "0^Missing or invalid 'age'"
+24 if "^M^F^"'[("^"_$GET(SEX)_"^")
QUIT "0^Missing or invalid 'sex'"
+25 if "^1^0^"'[("^"_$GET(ICDDMS)_"^")
QUIT "0^Missing or invalid 'discharged against medical advice'"
+26 if "^1^0^"'[("^"_$GET(ICDTRS)_"^")
QUIT "0^Missing or invalid 'transferred to acute care facility'"
+27 if "^1^0^"'[("^"_$GET(ICDEXP)_"^")
QUIT "0^Missing or invalid 'died during episode of care'"
+28 QUIT 1
SETPRE ; Set Previous Values
+1 NEW LEXF,LEXI,LEXID,LEXN,LEXV,LEXIMP,LEXSYS
+2 SET LEXN=$$DT^XLFDT
SET LEXF=$$FMADD^XLFDT(LEXN,60)
DO PURPRE
+3 SET LEXIMP=$$IMPDATE^LEXU(30)
SET LEXSYS="10D"
if $GET(ICDDATE)<LEXIMP
SET LEXSYS="ICD"
+4 SET LEXI=0
FOR
SET LEXI=$ORDER(ICDDX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+5 NEW LEXV
SET LEXV=$PIECE($GET(ICDDX(LEXI)),"^",1)
+6 if +LEXV'>0
QUIT
SET LEXID="LEXQDRG "_$GET(DUZ)_" DX"_LEXI_" "_LEXSYS
+7 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=LEXV
End DoDot:1
+8 SET LEXSYS="10P"
if $GET(ICDDATE)<LEXIMP
SET LEXSYS="ICP"
+9 SET LEXI=0
FOR
SET LEXI=$ORDER(ICDPRC(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+10 NEW LEXV
SET LEXV=$PIECE($GET(ICDPRC(LEXI)),"^",1)
+11 if +LEXV'>0
QUIT
SET LEXID="LEXQDRG "_$GET(DUZ)_" PR"_LEXI_" "_LEXSYS
+12 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=LEXV
End DoDot:1
+13 SET LEXV=$GET(AGE)
if LEXV'>0
SET LEXV=40
SET LEXID="LEXQDRG "_$GET(DUZ)_" AGE"
+14 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=LEXV
+15 SET LEXV=$GET(SEX)
if "^M^F^"'[("^"_LEXV_"^")
SET LEXV="M"
SET LEXID="LEXQDRG "_$GET(DUZ)_" SEX"
+16 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=LEXV
+17 SET LEXV=$GET(ICDDATE)
if $PIECE(LEXV,".",1)'?7N
SET LEXV=$$NOW^XLFDT
SET LEXID="LEXQDRG "_$GET(DUZ)_" DATE"
+18 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=LEXV
+19 SET LEXV=$GET(ICDDMS)
if '$LENGTH(LEXV)
SET LEXV=0
SET LEXID="LEXQDRG "_$GET(DUZ)_" DMS"
+20 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=LEXV
+21 SET LEXV=$GET(ICDTRS)
if '$LENGTH(LEXV)
SET LEXV=0
SET LEXID="LEXQDRG "_$GET(DUZ)_" TRS"
+22 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=LEXV
+23 SET LEXV=$GET(ICDEXP)
if '$LENGTH(LEXV)
SET LEXV=0
SET LEXID="LEXQDRG "_$GET(DUZ)_" EXP"
+24 SET ^XTMP(LEXID,0)=LEXF_"^"_LEXN_"^Previous"
SET ^XTMP(LEXID,"PRE")=LEXV
+25 QUIT
PURPRE ; Purge Saved Values
+1 NEW LEXI,LEXIMP,LEXSYS
if +($GET(ICDDATE))'>0
QUIT
SET LEXIMP=$$IMPDATE^LEXU(30)
SET LEXSYS="10D"
+2 if $GET(ICDDATE)<LEXIMP
SET LEXSYS="ICD"
KILL ^XTMP(("LEXQDRG "_$GET(DUZ)_" DX1 "_LEXSYS))
+3 FOR LEXI=2:1
if '$DATA(^XTMP(("LEXQDRG "_$GET(DUZ)_" DX"_LEXI_" "_LEXSYS)))
QUIT
KILL ^XTMP(("LEXQDRG "_$GET(DUZ)_" DX"_LEXI_" "_LEXSYS))
+4 FOR LEXI=1:1
if '$DATA(^XTMP(("LEXQDRG "_$GET(DUZ)_" PR"_LEXI)))
QUIT
KILL ^XTMP(("LEXQDRG "_$GET(DUZ)_" PR"_LEXI))
+5 QUIT
HASPRE(X) ; User Has Previous Values
+1 NEW LEXX,LEX9
SET LEX9=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" DX1 ICD"),"PRE"))
+2 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" DX1 10D"),"PRE"))
if +LEXX'>0&(+LEX9'>0)
QUIT -1
+3 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" AGE"),"PRE"))
if +LEXX'>0
QUIT -2
+4 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" DATE"),"PRE"))
if $PIECE(LEXX,".",1)'?7N
QUIT -3
+5 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" SEX"),"PRE"))
if "^M^F^"'[("^"_LEXX_"^")
QUIT -4
+6 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" EXP"),"PRE"))
if "^1^0^"'[("^"_LEXX_"^")
QUIT -5
+7 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" DMS"),"PRE"))
if "^1^0^"'[("^"_LEXX_"^")
QUIT -6
+8 SET LEXX=$GET(^XTMP(("LEXQDRG "_$GET(DUZ)_" TRS"),"PRE"))
if "^1^0^"'[("^"_LEXX_"^")
QUIT -7
+9 QUIT 1
