LEXQDRG4 ;ISL/KER - Query - DRG Calc. (DGPT - DX/SR/PR) ;05/23/2017
;;2.0;LEXICON UTILITY;**86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^DGPT( ICR 92
;
; External References
; $$GET1^DIQ ICR 2056
; $$CODEC^ICDEX ICR 5747
; $$DRG^ICDEX ICR 5747
; $$DRGD^ICDEX ICR 5747
; $$GETDATE^ICDEX ICR 5747
; $$ICDDX^ICDEX ICR 5747
; $$ICDOP^ICDEX ICR 5747
; $$VCC^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
;
; ICDDX(1) Array of ICD Principal Diagnosis
; ICDDX(n) Array of ICD Secondary Diagnosis
; ICDPRC(n) Array of ICD Procedures
; ICDPOA(n) Array of ICD-10 Present on Admission
; ICDDATE Date
;
; PTF Diagnosis and Procedures
DX(X) ; LEXDX Diagnosis String DX^DX^DX
N LEX1,LEXDCH,LEXDT,LEXFL,LEXIEN,LEXIENS,LEXIPT,LEXIT,LEXPDX,LEXPRE,LEXPTF
N LEXSDX,LEXTMP S LEXSDX="",LEXPTF=$G(X) Q:$G(LEXPTF)'>0 ""
S LEXDCH=$$GET1^DIQ(45,(+($G(LEXPTF))_","),70,"I")
; Diagnosis - after Oct 1, 1986
I 'LEXDCH!(+LEXDCH>2861000) D
. N LEXIT,LEXFL S LEXIT=0
. F LEXFL=79.16,79.17,79.18,79.19,79.201,79.21,79.22,79.23,79.24 D Q:LEXIT
. . N LEXIPT,LEXDT,LEXTMP S LEXIPT=$$GET1^DIQ(45,(+($G(LEXPTF))_","),LEXFL,"I")
. . S:LEXIPT'>0 LEXIT=1 Q:LEXIT S LEXDT=$$GETDATE^ICDEX($G(LEXPTF))
. . S LEXTMP=$$ICDDX^ICDEX(LEXIPT,LEXDT,,"I"),LEXIEN=+LEXTMP
. . I +LEXTMP>0,$P(LEXTMP,"^",10) S LEXSDX=LEXSDX_"^"_+LEXTMP
; Diagnosis - before Oct 1, 1986
I +LEXDCH,+LEXDCH<2861000 D
. N LEXDT F LEXDT=0:0 S LEXDT=$O(^DGPT(LEXPTF,"M","AM",LEXDT)) Q:LEXDT'>0 D
. . N LEXTMP S LEX1=$O(^DGPT(LEXPTF,"M","AM",LEXDT,0))
. . S LEXTMP="" F LEXFL=5:1:9 D
. . . N LEXIEN,LEXIENS S LEXIENS=LEX1_","_LEXPTF_","
. . . S LEXIEN=$$GET1^DIQ(45.02,LEXIENS,LEXFL,"I")
. . . S:$$CODEC^ICDEX(80,LEXIEN)'["^" LEXTMP=LEXTMP_"^"_LEXIEN
. . S LEXSDX=LEXTMP_$P(LEXSDX,"^",1,40)
S LEXPDX=$$GET1^DIQ(45,(+($G(LEXPTF))_","),79,"I")
S LEXPRE=$$GET1^DIQ(45,(+($G(LEXPTF))_","),80,"I")
S LEXSDX=$S(LEXPDX:LEXPDX,1:LEXPRE)_LEXSDX
S X=$G(LEXSDX) K LEXSDX
Q X
SR(X) ; LEXSR Surgery String SR^SR^SR
N LEXDCH,LEXI1,LEXI2,LEXIENS,LEXPTF,LEXSR,LEXSR1,LEXSRDT
N LEXSRS,LEXTMP K LEXSR S LEXPTF=+($G(X)) q:$G(LEXPTF)'>0 ""
Q:'$D(^DGPT(LEXPTF,"S")) "" S LEXDCH=$$GET1^DIQ(45,(+($G(LEXPTF))_","),70,"I")
F LEXI1=0:0 S LEXI1=$O(^DGPT(LEXPTF,"S",LEXI1)) Q:LEXI1'>0 D
. N LEXSRS,LEXIENS S LEXIENS=LEXI1_","_LEXPTF_","
. S LEXSRDT=$$GET1^DIQ(45.01,LEXIENS,.01,"I") I $L(LEXSRDT) D
. . N LEXSR1 S LEXSRDT=$S('$D(LEXSR(LEXSRDT)):LEXSRDT,LEXSRDT[".":LEXSRDT_LEXI1_1,1:LEXSRDT_".0000"_LEXI1_1)
. . S:$D(LEXSR(LEXSRDT)) LEXSRDT=$S(LEXSRDT[".":LEXSRDT_LEXI1_1,1:LEXSRDT_".0000"_LEXI1_1)
. . S LEXSR(LEXSRDT)="" N LEXI2
. . F LEXI2=8,9,10,11,12 S LEXSR1=$$GET1^DIQ(45.01,LEXIENS,LEXI2,"I") I LEXSR1]"" D
. . . N LEXTMP S LEXTMP=$$ICDOP^ICDEX(LEXSR1,$P(LEXDCH,"."),,"I")
. . . I +LEXTMP>0,$P(LEXTMP,"^",10) S LEXSR(LEXSRDT)=LEXSR(LEXSRDT)_LEXSR1_"^"
I $D(LEXSR) S LEXSR="^" F LEXI1=0:0 S LEXI1=$O(LEXSR(LEXI1)) Q:LEXI1'>0 D
. N LEXSR1,LEXSRS,LEXI2 S LEXSRS=LEXSR(LEXI1) F LEXI2=1:1:5 S LEXSR1=$P(LEXSRS,"^",LEXI2) Q:LEXSR1="" D
. . Q:$L(LEXSR)>240 S:LEXSR'[("^"_LEXSR1_"^") LEXSR=LEXSR_LEXSR1_"^"
S X=$G(LEXSR) K LEXSR
Q X
PR(X) ; LEXPR Procedures String PR^PR^PR
N LEXDCH,LEXDT,LEXFL,LEXI1,LEXI2,LEXIEN,LEXIENS,LEXPR1,LEXPRDT,LEXPRS
N LEXPTF,LEXTMP K LEXPR S LEXPTF=$G(X) Q:$G(LEXPTF)'>0 ""
S LEXDCH=$$GET1^DIQ(45,(+($G(LEXPTF))_","),70,"I"),LEXPR=""
I +LEXDCH,LEXDCH<2871000 D
. N LEXFL F LEXFL=45.01,45.02,45.03,45.04,45.05 D
. . N LEXPR1,LEXDT S LEXPR1=$$GET1^DIQ(45,(+($G(LEXPTF))_","),LEXFL,"I")
. . S LEXDT=$$GETDATE^ICDEX($G(LEXPTF))
. . S LEXTMP=$$ICDOP^ICDEX(LEXPR1,LEXDT,,"I")
. . I +LEXTMP>0,$P(LEXTMP,"^",10) S LEXPR=LEXPR_LEXPR1_"^"
I +LEXDCH'>0!(LEXDCH'<2871000) D
. F LEXI1=0:0 S LEXI1=$O(^DGPT(LEXPTF,"P",LEXI1)) Q:LEXI1'>0 D
. . N LEXPRDT,LEXIEN,LEXIENS,LEXFL
. . S LEXIENS=LEXI1_","_LEXPTF_","
. . S LEXPRDT=$$GET1^DIQ(45.05,LEXIENS,.01,"I") Q:'$L(LEXPRDT)
. . S:$D(LEXPR(LEXPRDT)) LEXPRDT=$S(LEXPRDT[".":LEXPRDT_LEXI1_1,1:LEXPRDT_".0000"_LEXI1_1)
. . S LEXPR(LEXPRDT)="" F LEXFL=4,5,6,7,8 D
. . . N LEXIEN,LEXTMP S LEXIEN=$$GET1^DIQ(45.05,LEXIENS,LEXFL,"I")
. . . Q:+LEXIEN'>0 S LEXTMP=$$ICDOP^ICDEX(LEXIEN,LEXDCH,,"I")
. . . I +LEXTMP>0,$P(LEXTMP,"^",10) D
. . . . S LEXPR(LEXPRDT)=LEXPR(LEXPRDT)_+LEXTMP_"^"
. I $D(LEXPR) S LEXPR="^" F LEXI1=0:0 S LEXI1=$O(LEXPR(LEXI1)) Q:LEXI1'>0 D
. . N LEXPRS,LEXPR1 S LEXPRS=LEXPR(LEXI1) F LEXI2=1:1:5 S LEXPR1=$P(LEXPRS,"^",LEXI2) Q:LEXPR1="" D
. . . Q:$L(LEXPR)>240 S:LEXPR'[("^"_LEXPR1_"^") LEXPR=LEXPR_LEXPR1_"^"
S X=$G(LEXPR) K LEXPR
Q X
;
ICDDXPR ; Create ICDDX() and ICDPRC() arrays
; ICDDX(n) Diagnosis Array (n)=IEN
N LEXDT,LEXFLG,LEXGDAT,LEXI1,LEXI2,LEXI3,LEXPR1,LEXTMP K ICDDX,ICDPRC
S LEXDT=$P($G(LEXGDAT),".",1)
S:LEXDT'?7N LEXDT=$$DT^XLFDT I $D(LEXDX) D
. N LEXI1 S LEXI1=0 F S LEXI1=LEXI1+1 Q:$P(LEXDX,"^",LEXI1)="" D
. . N LEXTMP S LEXTMP=$$ICDDX^ICDEX(+$P(LEXDX,"^",LEXI1),$G(LEXDT),,"I")
. . I +LEXTMP>0,($P(LEXTMP,"^",10)) S ICDDX(LEXI1)=$P(LEXDX,"^",LEXI1)
; ICDPRC(n) Procedure Array (n)=IEN
N LEXDX I $D(LEXPR) D
. N LEXI1,LEXPR1
. F LEXI1=2:1 S LEXPR1=$P(LEXPR,"^",LEXI1) Q:LEXPR1="" D
. . N LEXTMP S LEXTMP=$$ICDOP^ICDEX(LEXPR1,$G(LEXDT),,"I")
. . I +LEXTMP>0,($P(LEXTMP,"^",10)) D
. . . N LEXI3 S LEXI3=$O(ICDPRC(" "),-1)+1,ICDPRC(LEXI3)=LEXPR1
I $D(LEXSR) D
. N LEXI1,LEXPR1 F LEXI1=2:11 S LEXPR1=$P(LEXSR,"^",LEXI1) Q:LEXPR1="" D
. . N LEXFLG,LEXI2,LEXTMP S LEXFLG=0,LEXI2=0
. . F S LEXI2=$O(ICDPRC(LEXI2)) Q:'LEXI2 I LEXPR1=$G(ICDPRC(LEXI2)) S LEXFLG=1 Q
. . Q:LEXFLG S LEXTMP=$$ICDOP^ICDEX(LEXPR1,$G(LEXDT),,"I")
. . I +LEXTMP>0,($P(LEXTMP,"^",10)) D
. . . N LEXI3 S LEXI3=$O(ICDPRC(" "),-1)+1,ICDPRC(LEXI3)=LEXPR1
Q
;
DCD ; Display Codes Used
N LEXI,LEXC,LEXC2,LEXC3,LEXLEN,LEXT,LEXTX,LEXTD,LEXTI,LEXIEN,LEXCODE,LEXPOA,LEXCC,LEXEXT,LEXSTR,LEXSYS
S LEXTD=$$DT^XLFDT,LEXSYS="10P" S:$G(ICDDATE)<$$IMPDATE^LEXU(30) LEXSYS="ICD"
S LEXC2=16,LEXC3=25,LEXLEN=(79-LEXC3),LEXIEN=$G(ICDDX(1)) Q:+LEXIEN'>0
S LEXCODE=$$CODEC^ICDEX(80,LEXIEN) Q:'$L(LEXCODE)
S LEXPOA=$$POA(1),LEXCC=$$CC(1) S:LEXSYS="ICD" LEXPOA=""
S LEXEXT="" S:$L(LEXCC) LEXEXT=LEXCC
S:'$L(LEXCC)&($L(LEXPOA)) LEXEXT="POA: "_LEXPOA
S:$L(LEXCC)&($L(LEXPOA)) LEXEXT=LEXEXT_", POA: "_LEXPOA
S:$L(LEXEXT) LEXEXT=" ("_LEXEXT_")"
W !!," Principal DX:"
S LEXSTR=$P($$ICDDX^ICDEX(LEXIEN,LEXTD,,"I"),"^",4)_LEXEXT
K LEXTX S LEXTX(1)=$$UP^XLFSTR(LEXSTR) D PR^LEXU(.LEXTX,LEXLEN)
W ?LEXC2,LEXCODE,?LEXC3,$G(LEXTX(1)),! S LEXTI=1 F S LEXTI=$O(LEXTX(LEXTI)) Q:+LEXTI'>0 D
. N LEXS S LEXS=$$TM($G(LEXTX(LEXTI))) W:$L(LEXS) ?LEXC3,LEXS,!
S (LEXC,LEXT)=0,LEXI=1 F S LEXI=$O(ICDDX(LEXI)) Q:+LEXI'>0 D
. N LEXIEN,LEXCODE,LEXPOA,LEXCC,LEXEXT,LEXSTR,LEXTX
. S LEXIEN=$G(ICDDX(LEXI)) Q:+LEXIEN'>0
. S LEXCODE=$$CODEC^ICDEX(80,LEXIEN) Q:'$L(LEXCODE)
. S LEXPOA=$$POA(LEXI),LEXCC=$$CC(LEXI) S:LEXSYS="ICD" LEXPOA=""
. S LEXEXT="" S:$L(LEXCC) LEXEXT=LEXCC
. S:'$L(LEXCC)&($L(LEXPOA)) LEXEXT="POA: "_LEXPOA
. S:$L(LEXCC)&($L(LEXPOA)) LEXEXT=LEXEXT_", POA: "_LEXPOA
. S:$L(LEXEXT) LEXEXT=" ("_LEXEXT_")"
. S LEXC=LEXC+1 W:LEXC=1 " Secondary DX:"
. S LEXSTR=$P($$ICDDX^ICDEX(LEXIEN,LEXTD,,"I"),"^",4)_LEXEXT
. K LEXTX S LEXTX(1)=$$UP^XLFSTR(LEXSTR) D PR^LEXU(.LEXTX,LEXLEN)
. W ?LEXC2,LEXCODE,?LEXC3,$G(LEXTX(1)),! S LEXTI=1 F S LEXTI=$O(LEXTX(LEXTI)) Q:+LEXTI'>0 D
. . N LEXS S LEXS=$$TM($G(LEXTX(LEXTI))) W:$L(LEXS) ?LEXC3,LEXS,!
S (LEXI,LEXC)=0 F S LEXI=$O(ICDPRC(LEXI)) Q:+LEXI'>0 D
. N LEXIEN,LEXCODE S LEXIEN=$G(ICDPRC(LEXI)),LEXCODE=$$CODEC^ICDEX(80.1,LEXIEN)
. Q:'$L(LEXCODE) S LEXC=LEXC+1 W:LEXC=1 " Procedures:"
. K LEXTX S LEXTX(1)=$$UP^XLFSTR($P($$ICDOP^ICDEX(LEXIEN,LEXTD,,"I"),"^",5)) D PR^LEXU(.LEXTX,LEXLEN)
. W ?LEXC2,LEXCODE,?LEXC3,$G(LEXTX(1)),! S LEXTI=1 F S LEXTI=$O(LEXTX(LEXTI)) Q:+LEXTI'>0 D
. . N LEXS S LEXS=$$TM($G(LEXTX(LEXTI))) W:$L(LEXS) ?LEXC3,LEXS,!
Q
POA(X) ; Present on Admission
Q:+($G(X))'>0 "" S X=$G(ICDPOA(+($G(X))))
S X=$S(X="Y":"Yes",X="U":"Unknown",X="W":"Clinically Undetermined",1:"No")
Q X
CC(X) ; Complication/Comorbidity
Q:+($G(X))'>0 "" S X=$G(ICDDX(+($G(X)))) Q:+($G(X))'>0 ""
S X=$$VCC^ICDEX(X,$G(ICDDATE))
S X=$S(X=1:"CC",X=2:"Major CC",X=3:"MCC when patient is discharged alive",1:"")
Q X
WRT(X,Y) ; Write Output
N LEXD,LEXDES,LEXDRG,LEXDT,LEXI,LEXN S LEXDRG=$G(X),LEXDT=$G(Y)
S LEXD=$$DRG^ICDEX(+LEXDRG,LEXDT) D ATTR
W !?10,"Effective Date: "," ",$$FMTE^XLFDT($P(LEXDT,".",1),"5Z")
W !," Diagnosis Related Group: ",$J(LEXDRG,6),?41,"Avg len of stay: ",$J($P(LEXD,"^",8),6)
W !?18,"Weight: ",$J($P(LEXD,"^",2),6),?41,"Local Breakeven: ",$J($P(LEXD,"^",12),6)
W !?13," Low day(s): ",$J($P(LEXD,"^",3),6),?40,"Local low day(s): ",$J($P(LEXD,"^",9),6)
W !?14," High days: ",$J($P(LEXD,"^",4),6),?41,"Local High days: ",$J($P(LEXD,"^",10),6)
N LEXN,LEXDES,LEXI S LEXN=$$DRGDES^ICDEX(LEXDRG,LEXDT,.LEXDES,(78-12)) S LEXI=0
W !!," DRG: ",$G(BOLD),LEXDRG,$G(NORM)," - "
F S LEXI=$O(LEXDES(LEXI)) Q:'+LEXI Q:LEXDES(LEXI)=" " W ?12,LEXDES(LEXI),!
D KATTR
Q
TM(X,Y) ; Trim Y
N ICDDATE,ICDPOA S Y=$G(Y) S:'$L(Y) Y=" " F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
ATTR ; Screen Attributes
N X,IOINHI,IOINORM S X="IOINHI;IOINORM" D ENDR^%ZISS S BOLD=$G(IOINHI),NORM=$G(IOINORM)
Q
KATTR ; Kill Screen Attributes
D KILL^%ZISS K IOINHI,IOINORM,BOLD,NORM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQDRG4 9935 printed Sep 23, 2025@19:44:30 Page 2
LEXQDRG4 ;ISL/KER - Query - DRG Calc. (DGPT - DX/SR/PR) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^DGPT( ICR 92
+5 ;
+6 ; External References
+7 ; $$GET1^DIQ ICR 2056
+8 ; $$CODEC^ICDEX ICR 5747
+9 ; $$DRG^ICDEX ICR 5747
+10 ; $$DRGD^ICDEX ICR 5747
+11 ; $$GETDATE^ICDEX ICR 5747
+12 ; $$ICDDX^ICDEX ICR 5747
+13 ; $$ICDOP^ICDEX ICR 5747
+14 ; $$VCC^ICDEX ICR 5747
+15 ; $$DT^XLFDT ICR 10103
+16 ; $$FMTE^XLFDT ICR 10103
+17 ; $$UP^XLFSTR ICR 10104
+18 ;
+19 ; Local Variables NEWed or KILLed Elsewhere
+20 ;
+21 ; ICDDX(1) Array of ICD Principal Diagnosis
+22 ; ICDDX(n) Array of ICD Secondary Diagnosis
+23 ; ICDPRC(n) Array of ICD Procedures
+24 ; ICDPOA(n) Array of ICD-10 Present on Admission
+25 ; ICDDATE Date
+26 ;
+27 ; PTF Diagnosis and Procedures
DX(X) ; LEXDX Diagnosis String DX^DX^DX
+1 NEW LEX1,LEXDCH,LEXDT,LEXFL,LEXIEN,LEXIENS,LEXIPT,LEXIT,LEXPDX,LEXPRE,LEXPTF
+2 NEW LEXSDX,LEXTMP
SET LEXSDX=""
SET LEXPTF=$GET(X)
if $GET(LEXPTF)'>0
QUIT ""
+3 SET LEXDCH=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),70,"I")
+4 ; Diagnosis - after Oct 1, 1986
+5 IF 'LEXDCH!(+LEXDCH>2861000)
Begin DoDot:1
+6 NEW LEXIT,LEXFL
SET LEXIT=0
+7 FOR LEXFL=79.16,79.17,79.18,79.19,79.201,79.21,79.22,79.23,79.24
Begin DoDot:2
+8 NEW LEXIPT,LEXDT,LEXTMP
SET LEXIPT=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),LEXFL,"I")
+9 if LEXIPT'>0
SET LEXIT=1
if LEXIT
QUIT
SET LEXDT=$$GETDATE^ICDEX($GET(LEXPTF))
+10 SET LEXTMP=$$ICDDX^ICDEX(LEXIPT,LEXDT,,"I")
SET LEXIEN=+LEXTMP
+11 IF +LEXTMP>0
IF $PIECE(LEXTMP,"^",10)
SET LEXSDX=LEXSDX_"^"_+LEXTMP
End DoDot:2
if LEXIT
QUIT
End DoDot:1
+12 ; Diagnosis - before Oct 1, 1986
+13 IF +LEXDCH
IF +LEXDCH<2861000
Begin DoDot:1
+14 NEW LEXDT
FOR LEXDT=0:0
SET LEXDT=$ORDER(^DGPT(LEXPTF,"M","AM",LEXDT))
if LEXDT'>0
QUIT
Begin DoDot:2
+15 NEW LEXTMP
SET LEX1=$ORDER(^DGPT(LEXPTF,"M","AM",LEXDT,0))
+16 SET LEXTMP=""
FOR LEXFL=5:1:9
Begin DoDot:3
+17 NEW LEXIEN,LEXIENS
SET LEXIENS=LEX1_","_LEXPTF_","
+18 SET LEXIEN=$$GET1^DIQ(45.02,LEXIENS,LEXFL,"I")
+19 if $$CODEC^ICDEX(80,LEXIEN)'["^"
SET LEXTMP=LEXTMP_"^"_LEXIEN
End DoDot:3
+20 SET LEXSDX=LEXTMP_$PIECE(LEXSDX,"^",1,40)
End DoDot:2
End DoDot:1
+21 SET LEXPDX=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),79,"I")
+22 SET LEXPRE=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),80,"I")
+23 SET LEXSDX=$SELECT(LEXPDX:LEXPDX,1:LEXPRE)_LEXSDX
+24 SET X=$GET(LEXSDX)
KILL LEXSDX
+25 QUIT X
SR(X) ; LEXSR Surgery String SR^SR^SR
+1 NEW LEXDCH,LEXI1,LEXI2,LEXIENS,LEXPTF,LEXSR,LEXSR1,LEXSRDT
+2 NEW LEXSRS,LEXTMP
KILL LEXSR
SET LEXPTF=+($GET(X))
if $GET(LEXPTF)'>0
QUIT ""
+3 if '$DATA(^DGPT(LEXPTF,"S"))
QUIT ""
SET LEXDCH=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),70,"I")
+4 FOR LEXI1=0:0
SET LEXI1=$ORDER(^DGPT(LEXPTF,"S",LEXI1))
if LEXI1'>0
QUIT
Begin DoDot:1
+5 NEW LEXSRS,LEXIENS
SET LEXIENS=LEXI1_","_LEXPTF_","
+6 SET LEXSRDT=$$GET1^DIQ(45.01,LEXIENS,.01,"I")
IF $LENGTH(LEXSRDT)
Begin DoDot:2
+7 NEW LEXSR1
SET LEXSRDT=$SELECT('$DATA(LEXSR(LEXSRDT)):LEXSRDT,LEXSRDT[".":LEXSRDT_LEXI1_1,1:LEXSRDT_".0000"_LEXI1_1)
+8 if $DATA(LEXSR(LEXSRDT))
SET LEXSRDT=$SELECT(LEXSRDT[".":LEXSRDT_LEXI1_1,1:LEXSRDT_".0000"_LEXI1_1)
+9 SET LEXSR(LEXSRDT)=""
NEW LEXI2
+10 FOR LEXI2=8,9,10,11,12
SET LEXSR1=$$GET1^DIQ(45.01,LEXIENS,LEXI2,"I")
IF LEXSR1]""
Begin DoDot:3
+11 NEW LEXTMP
SET LEXTMP=$$ICDOP^ICDEX(LEXSR1,$PIECE(LEXDCH,"."),,"I")
+12 IF +LEXTMP>0
IF $PIECE(LEXTMP,"^",10)
SET LEXSR(LEXSRDT)=LEXSR(LEXSRDT)_LEXSR1_"^"
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF $DATA(LEXSR)
SET LEXSR="^"
FOR LEXI1=0:0
SET LEXI1=$ORDER(LEXSR(LEXI1))
if LEXI1'>0
QUIT
Begin DoDot:1
+14 NEW LEXSR1,LEXSRS,LEXI2
SET LEXSRS=LEXSR(LEXI1)
FOR LEXI2=1:1:5
SET LEXSR1=$PIECE(LEXSRS,"^",LEXI2)
if LEXSR1=""
QUIT
Begin DoDot:2
+15 if $LENGTH(LEXSR)>240
QUIT
if LEXSR'[("^"_LEXSR1_"^")
SET LEXSR=LEXSR_LEXSR1_"^"
End DoDot:2
End DoDot:1
+16 SET X=$GET(LEXSR)
KILL LEXSR
+17 QUIT X
PR(X) ; LEXPR Procedures String PR^PR^PR
+1 NEW LEXDCH,LEXDT,LEXFL,LEXI1,LEXI2,LEXIEN,LEXIENS,LEXPR1,LEXPRDT,LEXPRS
+2 NEW LEXPTF,LEXTMP
KILL LEXPR
SET LEXPTF=$GET(X)
if $GET(LEXPTF)'>0
QUIT ""
+3 SET LEXDCH=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),70,"I")
SET LEXPR=""
+4 IF +LEXDCH
IF LEXDCH<2871000
Begin DoDot:1
+5 NEW LEXFL
FOR LEXFL=45.01,45.02,45.03,45.04,45.05
Begin DoDot:2
+6 NEW LEXPR1,LEXDT
SET LEXPR1=$$GET1^DIQ(45,(+($GET(LEXPTF))_","),LEXFL,"I")
+7 SET LEXDT=$$GETDATE^ICDEX($GET(LEXPTF))
+8 SET LEXTMP=$$ICDOP^ICDEX(LEXPR1,LEXDT,,"I")
+9 IF +LEXTMP>0
IF $PIECE(LEXTMP,"^",10)
SET LEXPR=LEXPR_LEXPR1_"^"
End DoDot:2
End DoDot:1
+10 IF +LEXDCH'>0!(LEXDCH'<2871000)
Begin DoDot:1
+11 FOR LEXI1=0:0
SET LEXI1=$ORDER(^DGPT(LEXPTF,"P",LEXI1))
if LEXI1'>0
QUIT
Begin DoDot:2
+12 NEW LEXPRDT,LEXIEN,LEXIENS,LEXFL
+13 SET LEXIENS=LEXI1_","_LEXPTF_","
+14 SET LEXPRDT=$$GET1^DIQ(45.05,LEXIENS,.01,"I")
if '$LENGTH(LEXPRDT)
QUIT
+15 if $DATA(LEXPR(LEXPRDT))
SET LEXPRDT=$SELECT(LEXPRDT[".":LEXPRDT_LEXI1_1,1:LEXPRDT_".0000"_LEXI1_1)
+16 SET LEXPR(LEXPRDT)=""
FOR LEXFL=4,5,6,7,8
Begin DoDot:3
+17 NEW LEXIEN,LEXTMP
SET LEXIEN=$$GET1^DIQ(45.05,LEXIENS,LEXFL,"I")
+18 if +LEXIEN'>0
QUIT
SET LEXTMP=$$ICDOP^ICDEX(LEXIEN,LEXDCH,,"I")
+19 IF +LEXTMP>0
IF $PIECE(LEXTMP,"^",10)
Begin DoDot:4
+20 SET LEXPR(LEXPRDT)=LEXPR(LEXPRDT)_+LEXTMP_"^"
End DoDot:4
End DoDot:3
End DoDot:2
+21 IF $DATA(LEXPR)
SET LEXPR="^"
FOR LEXI1=0:0
SET LEXI1=$ORDER(LEXPR(LEXI1))
if LEXI1'>0
QUIT
Begin DoDot:2
+22 NEW LEXPRS,LEXPR1
SET LEXPRS=LEXPR(LEXI1)
FOR LEXI2=1:1:5
SET LEXPR1=$PIECE(LEXPRS,"^",LEXI2)
if LEXPR1=""
QUIT
Begin DoDot:3
+23 if $LENGTH(LEXPR)>240
QUIT
if LEXPR'[("^"_LEXPR1_"^")
SET LEXPR=LEXPR_LEXPR1_"^"
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET X=$GET(LEXPR)
KILL LEXPR
+25 QUIT X
+26 ;
ICDDXPR ; Create ICDDX() and ICDPRC() arrays
+1 ; ICDDX(n) Diagnosis Array (n)=IEN
+2 NEW LEXDT,LEXFLG,LEXGDAT,LEXI1,LEXI2,LEXI3,LEXPR1,LEXTMP
KILL ICDDX,ICDPRC
+3 SET LEXDT=$PIECE($GET(LEXGDAT),".",1)
+4 if LEXDT'?7N
SET LEXDT=$$DT^XLFDT
IF $DATA(LEXDX)
Begin DoDot:1
+5 NEW LEXI1
SET LEXI1=0
FOR
SET LEXI1=LEXI1+1
if $PIECE(LEXDX,"^",LEXI1)=""
QUIT
Begin DoDot:2
+6 NEW LEXTMP
SET LEXTMP=$$ICDDX^ICDEX(+$PIECE(LEXDX,"^",LEXI1),$GET(LEXDT),,"I")
+7 IF +LEXTMP>0
IF ($PIECE(LEXTMP,"^",10))
SET ICDDX(LEXI1)=$PIECE(LEXDX,"^",LEXI1)
End DoDot:2
End DoDot:1
+8 ; ICDPRC(n) Procedure Array (n)=IEN
+9 NEW LEXDX
IF $DATA(LEXPR)
Begin DoDot:1
+10 NEW LEXI1,LEXPR1
+11 FOR LEXI1=2:1
SET LEXPR1=$PIECE(LEXPR,"^",LEXI1)
if LEXPR1=""
QUIT
Begin DoDot:2
+12 NEW LEXTMP
SET LEXTMP=$$ICDOP^ICDEX(LEXPR1,$GET(LEXDT),,"I")
+13 IF +LEXTMP>0
IF ($PIECE(LEXTMP,"^",10))
Begin DoDot:3
+14 NEW LEXI3
SET LEXI3=$ORDER(ICDPRC(" "),-1)+1
SET ICDPRC(LEXI3)=LEXPR1
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF $DATA(LEXSR)
Begin DoDot:1
+16 NEW LEXI1,LEXPR1
FOR LEXI1=2:11
SET LEXPR1=$PIECE(LEXSR,"^",LEXI1)
if LEXPR1=""
QUIT
Begin DoDot:2
+17 NEW LEXFLG,LEXI2,LEXTMP
SET LEXFLG=0
SET LEXI2=0
+18 FOR
SET LEXI2=$ORDER(ICDPRC(LEXI2))
if 'LEXI2
QUIT
IF LEXPR1=$GET(ICDPRC(LEXI2))
SET LEXFLG=1
QUIT
+19 if LEXFLG
QUIT
SET LEXTMP=$$ICDOP^ICDEX(LEXPR1,$GET(LEXDT),,"I")
+20 IF +LEXTMP>0
IF ($PIECE(LEXTMP,"^",10))
Begin DoDot:3
+21 NEW LEXI3
SET LEXI3=$ORDER(ICDPRC(" "),-1)+1
SET ICDPRC(LEXI3)=LEXPR1
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
DCD ; Display Codes Used
+1 NEW LEXI,LEXC,LEXC2,LEXC3,LEXLEN,LEXT,LEXTX,LEXTD,LEXTI,LEXIEN,LEXCODE,LEXPOA,LEXCC,LEXEXT,LEXSTR,LEXSYS
+2 SET LEXTD=$$DT^XLFDT
SET LEXSYS="10P"
if $GET(ICDDATE)<$$IMPDATE^LEXU(30)
SET LEXSYS="ICD"
+3 SET LEXC2=16
SET LEXC3=25
SET LEXLEN=(79-LEXC3)
SET LEXIEN=$GET(ICDDX(1))
if +LEXIEN'>0
QUIT
+4 SET LEXCODE=$$CODEC^ICDEX(80,LEXIEN)
if '$LENGTH(LEXCODE)
QUIT
+5 SET LEXPOA=$$POA(1)
SET LEXCC=$$CC(1)
if LEXSYS="ICD"
SET LEXPOA=""
+6 SET LEXEXT=""
if $LENGTH(LEXCC)
SET LEXEXT=LEXCC
+7 if '$LENGTH(LEXCC)&($LENGTH(LEXPOA))
SET LEXEXT="POA: "_LEXPOA
+8 if $LENGTH(LEXCC)&($LENGTH(LEXPOA))
SET LEXEXT=LEXEXT_", POA: "_LEXPOA
+9 if $LENGTH(LEXEXT)
SET LEXEXT=" ("_LEXEXT_")"
+10 WRITE !!," Principal DX:"
+11 SET LEXSTR=$PIECE($$ICDDX^ICDEX(LEXIEN,LEXTD,,"I"),"^",4)_LEXEXT
+12 KILL LEXTX
SET LEXTX(1)=$$UP^XLFSTR(LEXSTR)
DO PR^LEXU(.LEXTX,LEXLEN)
+13 WRITE ?LEXC2,LEXCODE,?LEXC3,$GET(LEXTX(1)),!
SET LEXTI=1
FOR
SET LEXTI=$ORDER(LEXTX(LEXTI))
if +LEXTI'>0
QUIT
Begin DoDot:1
+14 NEW LEXS
SET LEXS=$$TM($GET(LEXTX(LEXTI)))
if $LENGTH(LEXS)
WRITE ?LEXC3,LEXS,!
End DoDot:1
+15 SET (LEXC,LEXT)=0
SET LEXI=1
FOR
SET LEXI=$ORDER(ICDDX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+16 NEW LEXIEN,LEXCODE,LEXPOA,LEXCC,LEXEXT,LEXSTR,LEXTX
+17 SET LEXIEN=$GET(ICDDX(LEXI))
if +LEXIEN'>0
QUIT
+18 SET LEXCODE=$$CODEC^ICDEX(80,LEXIEN)
if '$LENGTH(LEXCODE)
QUIT
+19 SET LEXPOA=$$POA(LEXI)
SET LEXCC=$$CC(LEXI)
if LEXSYS="ICD"
SET LEXPOA=""
+20 SET LEXEXT=""
if $LENGTH(LEXCC)
SET LEXEXT=LEXCC
+21 if '$LENGTH(LEXCC)&($LENGTH(LEXPOA))
SET LEXEXT="POA: "_LEXPOA
+22 if $LENGTH(LEXCC)&($LENGTH(LEXPOA))
SET LEXEXT=LEXEXT_", POA: "_LEXPOA
+23 if $LENGTH(LEXEXT)
SET LEXEXT=" ("_LEXEXT_")"
+24 SET LEXC=LEXC+1
if LEXC=1
WRITE " Secondary DX:"
+25 SET LEXSTR=$PIECE($$ICDDX^ICDEX(LEXIEN,LEXTD,,"I"),"^",4)_LEXEXT
+26 KILL LEXTX
SET LEXTX(1)=$$UP^XLFSTR(LEXSTR)
DO PR^LEXU(.LEXTX,LEXLEN)
+27 WRITE ?LEXC2,LEXCODE,?LEXC3,$GET(LEXTX(1)),!
SET LEXTI=1
FOR
SET LEXTI=$ORDER(LEXTX(LEXTI))
if +LEXTI'>0
QUIT
Begin DoDot:2
+28 NEW LEXS
SET LEXS=$$TM($GET(LEXTX(LEXTI)))
if $LENGTH(LEXS)
WRITE ?LEXC3,LEXS,!
End DoDot:2
End DoDot:1
+29 SET (LEXI,LEXC)=0
FOR
SET LEXI=$ORDER(ICDPRC(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+30 NEW LEXIEN,LEXCODE
SET LEXIEN=$GET(ICDPRC(LEXI))
SET LEXCODE=$$CODEC^ICDEX(80.1,LEXIEN)
+31 if '$LENGTH(LEXCODE)
QUIT
SET LEXC=LEXC+1
if LEXC=1
WRITE " Procedures:"
+32 KILL LEXTX
SET LEXTX(1)=$$UP^XLFSTR($PIECE($$ICDOP^ICDEX(LEXIEN,LEXTD,,"I"),"^",5))
DO PR^LEXU(.LEXTX,LEXLEN)
+33 WRITE ?LEXC2,LEXCODE,?LEXC3,$GET(LEXTX(1)),!
SET LEXTI=1
FOR
SET LEXTI=$ORDER(LEXTX(LEXTI))
if +LEXTI'>0
QUIT
Begin DoDot:2
+34 NEW LEXS
SET LEXS=$$TM($GET(LEXTX(LEXTI)))
if $LENGTH(LEXS)
WRITE ?LEXC3,LEXS,!
End DoDot:2
End DoDot:1
+35 QUIT
POA(X) ; Present on Admission
+1 if +($GET(X))'>0
QUIT ""
SET X=$GET(ICDPOA(+($GET(X))))
+2 SET X=$SELECT(X="Y":"Yes",X="U":"Unknown",X="W":"Clinically Undetermined",1:"No")
+3 QUIT X
CC(X) ; Complication/Comorbidity
+1 if +($GET(X))'>0
QUIT ""
SET X=$GET(ICDDX(+($GET(X))))
if +($GET(X))'>0
QUIT ""
+2 SET X=$$VCC^ICDEX(X,$GET(ICDDATE))
+3 SET X=$SELECT(X=1:"CC",X=2:"Major CC",X=3:"MCC when patient is discharged alive",1:"")
+4 QUIT X
WRT(X,Y) ; Write Output
+1 NEW LEXD,LEXDES,LEXDRG,LEXDT,LEXI,LEXN
SET LEXDRG=$GET(X)
SET LEXDT=$GET(Y)
+2 SET LEXD=$$DRG^ICDEX(+LEXDRG,LEXDT)
DO ATTR
+3 WRITE !?10,"Effective Date: "," ",$$FMTE^XLFDT($PIECE(LEXDT,".",1),"5Z")
+4 WRITE !," Diagnosis Related Group: ",$JUSTIFY(LEXDRG,6),?41,"Avg len of stay: ",$JUSTIFY($PIECE(LEXD,"^",8),6)
+5 WRITE !?18,"Weight: ",$JUSTIFY($PIECE(LEXD,"^",2),6),?41,"Local Breakeven: ",$JUSTIFY($PIECE(LEXD,"^",12),6)
+6 WRITE !?13," Low day(s): ",$JUSTIFY($PIECE(LEXD,"^",3),6),?40,"Local low day(s): ",$JUSTIFY($PIECE(LEXD,"^",9),6)
+7 WRITE !?14," High days: ",$JUSTIFY($PIECE(LEXD,"^",4),6),?41,"Local High days: ",$JUSTIFY($PIECE(LEXD,"^",10),6)
+8 NEW LEXN,LEXDES,LEXI
SET LEXN=$$DRGDES^ICDEX(LEXDRG,LEXDT,.LEXDES,(78-12))
SET LEXI=0
+9 WRITE !!," DRG: ",$GET(BOLD),LEXDRG,$GET(NORM)," - "
+10 FOR
SET LEXI=$ORDER(LEXDES(LEXI))
if '+LEXI
QUIT
if LEXDES(LEXI)=" "
QUIT
WRITE ?12,LEXDES(LEXI),!
+11 DO KATTR
+12 QUIT
TM(X,Y) ; Trim Y
+1 NEW ICDDATE,ICDPOA
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
ATTR ; Screen Attributes
+1 NEW X,IOINHI,IOINORM
SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
SET BOLD=$GET(IOINHI)
SET NORM=$GET(IOINORM)
+2 QUIT
KATTR ; Kill Screen Attributes
+1 DO KILL^%ZISS
KILL IOINHI,IOINORM,BOLD,NORM
+2 QUIT
