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