LEXQDRG4.m

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 ---LEXQDRG4   9935     printed  Mar 13, 2025@21:13:07                                                                                                                                                                                                    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