LEXQID3 ;ISL/KER - Query - ICD Diagnosis - Extract (cont) ;04/21/2014
;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^ICD( ICR 4487
; ^TMP("LEXQID" SACC 2.3.2.5.1
; ^TMP("LEXQIDC" SACC 2.3.2.5.1
; ^TMP("LEXQIDN" SACC 2.3.2.5.1
; ^TMP("LEXQIDR" SACC 2.3.2.5.1
;
; External References
; $$CODEABA^ICDEX ICR 5747
; $$CODECS^ICDEX ICR 5747
; $$CODEC^ICDEX ICR 5747
; $$CSI^ICDEX ICR 5747
; $$GETDRG^ICDEX ICR 5747
; $$ICDDX^ICDEX ICR 5747
; $$NCC^ICDEX ICR 5747
; $$NOT^ICDEX ICR 5747
; $$REQ^ICDEX ICR 5747
; $$VCC^ICDEX ICR 5747
; DRGD^ICDGTDRG ICR 4052
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
Q
NOT(X,LEXVDT,LEXLEN) ; Include ICD Codes not to use with ***.**
;
; ^TMP("LEXQIDN",$J,IEN)=CODE
; ^TMP("LEXQIDN",$J,"B",(CODE_" "),IEN)=""
;
; ^TMP("LEXQID",$J,"NOT",0)=<total>
; ^TMP("LEXQID",$J,"NOT",1,1)=<header>
; ^TMP("LEXQID",$J,"NOT",2,#)=<header text>
; ^TMP("LEXQID",$J,"NOT",3,<code >)=<code>_" "_<diagnosis>
;
K ^TMP("LEXQIDN",$J),^TMP("LEXQID",$J,"NOT")
N LEX,LEXI,LEXC,LEXICD,LEXIEN,LEXISO,LEXSO,LEXSD,EXD,LEXT,LEXSTR,LEXO
S LEXIEN=+($G(X)) Q:+LEXIEN'>0 S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
S LEXISO=$$CODEC^ICDEX(80,+LEXIEN) Q:'$L(LEXISO)
S LEXLEN=+$G(LEXLEN) S:+LEXLEN>62 LEXLEN=62 S X=$$NOT^ICDEX(+($G(LEXIEN)),"LEXQIDN",1)
S LEXO="" F S LEXO=$O(^TMP("LEXQIDN",$J,"B",LEXO)) Q:'$L(LEXO) D
. N LEXD S LEXICD=$O(^TMP("LEXQIDN",$J,"B",LEXO,0)) Q:+LEXICD'>0
. S LEXSYS=$$CSI^ICDEX(80,+LEXICD)
. S LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
. S LEXSO=$P(LEXD,"^",2),LEXSD=$$UP^XLFSTR($P(LEXD,"^",4)) Q:'$L(LEXSO) Q:'$L(LEXSD)
. S LEXT=LEXSO,LEXT=LEXT_$J(" ",(9-$L(LEXT)))_LEXSD
. S ^TMP("LEXQID",$J,"NOT",3,(LEXSO_" "))=LEXT
K ^TMP("LEXQIDN",$J) S LEXC=0,LEXI=""
F S LEXI=$O(^TMP("LEXQID",$J,"NOT",3,LEXI)) Q:'$L(LEXI) S LEXC=LEXC+1
S ^TMP("LEXQID",$J,"NOT",0)=+($G(LEXC))
S LEXI=+($G(^TMP("LEXQID",$J,"NOT",0))) I LEXI>0 D
. N LEX,LEXC,LEXSTR,LEXT S LEXSTR="The following code"_$S(LEXI>1:"s ",1:" ")_"cannot be used in conjunction with "
. S:$L($G(LEXISO)) LEXSTR=LEXSTR_"ICD Code "_LEXISO S:'$L($G(LEXISO)) LEXSTR=LEXSTR_"this ICD Code"
. S LEX(1)=LEXSTR D PR^LEXQM(.LEX,(LEXLEN-7)) S (LEXC,LEXT)=0 F S LEXT=$O(LEX(LEXT)) Q:+LEXT'>0 D
. . S LEXSTR=$$TM^LEXQM($G(LEX(LEXT))) S:$L(LEXSTR) LEXC=LEXC+1,^TMP("LEXQID",$J,"NOT",2,LEXC)=LEXSTR
S:$D(^TMP("LEXQID",$J,"NOT",2)) ^TMP("LEXQID",$J,"NOT",1,1)="Not used"
Q
REQ(X,LEXVDT,LEXLEN) ; Include ICD Codes required with ***.**
;
; ^TMP("LEXQIDR",$J,IEN)=CODE
; ^TMP("LEXQIDR",$J,"B",(CODE_" "),IEN)=""
;
; ^TMP("LEXQID",$J,"REQ",0)=<total>
; ^TMP("LEXQID",$J,"REQ",1,1)=<header>
; ^TMP("LEXQID",$J,"REQ",2,#)=<header text>
; ^TMP("LEXQID",$J,"REQ",3,<code >)=<code>_" "_<diagnosis>
;
K ^TMP("LEXQIDR",$J),^TMP("LEXQID",$J,"NOT")
N LEX,LEXI,LEXC,LEXICD,LEXIEN,LEXISO,LEXSO,LEXSD,EXD,LEXT,LEXSTR,LEXO
S LEXIEN=+($G(X)) Q:+LEXIEN'>0 S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
S LEXISO=$$CODEC^ICDEX(80,+LEXIEN) Q:'$L(LEXISO)
S LEXLEN=+$G(LEXLEN) S:+LEXLEN>62 LEXLEN=62 S X=$$REQ^ICDEX(+($G(LEXIEN)),"LEXQIDR",1)
S LEXO="" F S LEXO=$O(^TMP("LEXQIDR",$J,"B",LEXO)) Q:'$L(LEXO) D
. N LEXD S LEXICD=$O(^TMP("LEXQIDR",$J,"B",LEXO,0)) Q:+LEXICD'>0
. S LEXSYS=$$CSI^ICDEX(80,+LEXICD)
. S LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
. S LEXSO=$P(LEXD,"^",2),LEXSD=$$UP^XLFSTR($P(LEXD,"^",4)) Q:'$L(LEXSO) Q:'$L(LEXSD)
. S LEXT=LEXSO,LEXT=LEXT_$J(" ",(9-$L(LEXT)))_LEXSD
. S ^TMP("LEXQID",$J,"REQ",3,(LEXSO_" "))=LEXT
K ^TMP("LEXQIDR",$J) S LEXC=0,LEXI=""
F S LEXI=$O(^TMP("LEXQID",$J,"REQ",3,LEXI)) Q:'$L(LEXI) S LEXC=LEXC+1
S ^TMP("LEXQID",$J,"REQ",0)=+($G(LEXC))
S LEXI=+($G(^TMP("LEXQID",$J,"REQ",0))) I LEXI>0 D
. N LEX,LEXC,LEXSTR,LEXT S:LEXI>1 LEXSTR="One of the following codes is required when "
. S:LEXI>1 LEXSTR="One of the following codes is required when " S:LEXI'>1 LEXSTR="The following code is required when "
. S:$L($G(LEXISO)) LEXSTR=LEXSTR_"ICD Code "_LEXISO_" "
. S:'$L($G(LEXISO)) LEXSTR=LEXSTR_"this ICD Code " S LEXSTR=LEXSTR_"is used"
. S LEX(1)=LEXSTR D PR^LEXQM(.LEX,(LEXLEN-7)) S (LEXC,LEXT)=0 F S LEXT=$O(LEX(LEXT)) Q:+LEXT'>0 D
. . S LEXSTR=$$TM^LEXQM($G(LEX(LEXT))) S:$L(LEXSTR) LEXC=LEXC+1,^TMP("LEXQID",$J,"REQ",2,LEXC)=LEXSTR
S:$D(^TMP("LEXQID",$J,"REQ",2)) ^TMP("LEXQID",$J,"REQ",1,1)="Required with"
Q
NCC(X,LEXVDT,LEXLEN) ; Include the codes that ***.** is not CC with
;
; ^TMP("LEXQIDC",$J,IEN)=CODE
; ^TMP("LEXQIDC",$J,"B",(CODE_" "),IEN)=""
;
; ^TMP("LEXQID",$J,"NCC",0)=<total>
; ^TMP("LEXQID",$J,"NCC",1,1)=<header>
; ^TMP("LEXQID",$J,"NCC",2,#)=<header text>
; ^TMP("LEXQID",$J,"NCC",3,<code >)=<code>_" "_<diagnosis>
;
K ^TMP("LEXQIDC",$J),^TMP("LEXQID",$J,"NOT")
N LEX,LEXI,LEXC,LEXICD,LEXIEN,LEXISO,LEXSO,LEXSD,EXD,LEXT,LEXSTR,LEXO
S LEXIEN=+($G(X)) Q:+LEXIEN'>0 S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
S LEXISO=$$CODEC^ICDEX(80,+LEXIEN) Q:'$L(LEXISO)
S LEXLEN=+$G(LEXLEN) S:+LEXLEN>62 LEXLEN=62 S X=$$NCC^ICDEX(+($G(LEXIEN)),"LEXQIDC",1)
S LEXO="" F S LEXO=$O(^TMP("LEXQIDC",$J,"B",LEXO)) Q:'$L(LEXO) D
. N LEXD,LEXI,LEXC
. S LEXI=$O(^TMP("LEXQIDC",$J,"B",LEXO,0)) Q:+LEXI'>0
. S LEXC=$G(^TMP("LEXQIDC",$J,LEXI)) Q:'$L(LEXC)
. S LEXSYS=+($$CODECS^ICDEX(LEXC,80)) Q:+LEXSYS'>0
. S LEXICD=$$CODEABA^ICDEX(LEXC,80,+LEXSYS)
. ; S LEXICD=$O(^TMP("LEXQIDC",$J,"B",LEXO,0)) Q:+LEXICD'>0
. ; S LEXSYS=$$CSI^ICDEX(80,+LEXICD)
. S LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
. S LEXSO=$P(LEXD,"^",2),LEXSD=$$UP^XLFSTR($P(LEXD,"^",4)) Q:'$L(LEXSO) Q:'$L(LEXSD)
. S LEXT=LEXSO,LEXT=LEXT_$J(" ",(9-$L(LEXT)))_LEXSD
. S ^TMP("LEXQID",$J,"NCC",3,(LEXSO_" "))=LEXT
K ^TMP("LEXQIDC",$J) S LEXC=0,LEXI=""
F S LEXI=$O(^TMP("LEXQID",$J,"NCC",3,LEXI)) Q:'$L(LEXI) S LEXC=LEXC+1
S ^TMP("LEXQID",$J,"NCC",0)=+($G(LEXC))
S LEXI=+($G(^TMP("LEXQID",$J,"NCC",0))) I LEXI>0 D
. N LEX,LEXC,LEXSTR,LEXT S LEXSTR="ICD Code " S:$L($G(LEXISO)) LEXSTR=LEXSTR_LEXISO_" "
. S LEXSTR=LEXSTR_"is not considered as Complication Comorbidity (CC) with the following code"_$S(LEXI>1:"s",1:"")
. S LEX(1)=LEXSTR D PR^LEXQM(.LEX,(LEXLEN-7)) S (LEXC,LEXT)=0 F S LEXT=$O(LEX(LEXT)) Q:+LEXT'>0 D
. . S LEXSTR=$$TM^LEXQM($G(LEX(LEXT))) S:$L(LEXSTR) LEXC=LEXC+1,^TMP("LEXQID",$J,"NCC",2,LEXC)=LEXSTR
S:$D(^TMP("LEXQID",$J,"NCC",2)) ^TMP("LEXQID",$J,"NCC",1,1)="Not CC with"
Q
DRG(X,LEXVDT,LEXLEN) ; Diagnosis Related Group
;
; ^TMP("LEXQID",$J,"DRG",0)=<total>
; ^TMP("LEXQID",$J,"DRG",1,1)=<header>
; ^TMP("LEXQID",$J,"DRG",1,2)=<effective date>
; ^TMP("LEXQID",$J,"DRG",2,1)=<header text>
; ^TMP("LEXQID",$J,"DRG",3,#)=<DRG list>
;
N LEXC,LEXDDD,LEXDDE,LEXDEF,LEXDDI,LEXDDT,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRP,LEXI,LEXIEN,LEXL,LEXN,LEXN0,LEXT
N LEXEFF,LEXPIE,LEXSTA S LEXIEN=+($G(X)) Q:+LEXIEN'>0
S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXLEN=+$G(LEXLEN) S:+LEXLEN>62 LEXLEN=62
S LEXSTR=$$GETDRG^ICDEX(80,LEXIEN,LEXVDT),LEXSTA=$P(LEXSTR,";",3) Q:LEXSTA'>0 S LEXEFF=$P(LEXSTR,";",2) Q:LEXEFF'?7N S LEXSTR=$P(LEXSTR,";",1)
I '$L($TR(LEXSTR,"^","")) D Q
. S ^TMP("LEXQID",$J,"DRG",0)=0,^TMP("LEXQID",$J,"DRG",1,1)="DRG Groups"
. S ^TMP("LEXQID",$J,"DRG",2,1)="No DRG Groups found to be active for the date provided"
. S:LEXVDT?7N ^TMP("LEXQID",$J,"DRG",2,1)="No DRG Groups found to be active on "_$$SD^LEXQM(LEXVDT)
F LEXPIE=1:1 Q:'$L($P(LEXSTR,"^",LEXPIE)) S LEXDRP=$P(LEXSTR,"^",LEXPIE) D
. S LEXDRG=$P($G(^ICD(+LEXDRP,0)),"^",1)
. K LEXDRGD D DRGD^ICDGTDRG(LEXDRG,"LEXDRGD",,+LEXVDT)
. S LEXDRG=$TR(LEXDRG,"DRG",""),LEXDRG=+LEXDRG Q:+LEXDRG'>0
. S LEXI=0 F S LEXI=$O(LEXDRGD(LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT=$$TM^LEXQM($G(LEXDRGD(LEXI)))
. . I '$L(LEXT)!(LEXT["CODE TEXT MAY BE INACCURATE") K LEXDRGD(LEXI) Q
. . S LEXDRGD(LEXI)=LEXT
. S LEXDRG1=LEXDRG,LEXDRG1=LEXDRG1_$J(" ",(6-$L(LEXDRG1))),LEXDRG2=$J(" ",6) D PR^LEXQM(.LEXDRGD,(LEXLEN-8))
. S (LEXC,LEXI)=0 F S LEXI=$O(LEXDRGD(LEXI)) Q:+LEXI'>0 D
. . N LEXT,LEXL,LEXN S LEXT=$$TM^LEXQM($G(LEXDRGD(LEXI)))
. . Q:'$L(LEXT) S LEXC=LEXC+1
. . S:LEXC=1 LEXL=LEXDRG1_LEXT,LEXDRGC=+($G(LEXDRGC))+1
. . S:LEXC>1 LEXL=LEXDRG2_LEXT
. . S LEXN=$O(^TMP("LEXQID",$J,"DRG",3," "),-1)+1
. . S ^TMP("LEXQID",$J,"DRG",3,LEXN)=LEXL
S ^TMP("LEXQID",$J,"DRG",0)=+($G(LEXDRGC)),^TMP("LEXQID",$J,"DRG",1,1)="DRG Groups"
S:$G(LEXEFF)?7N ^TMP("LEXQID",$J,"DRG",1,2)=$$SD^LEXQM(LEXEFF)
S:+($G(LEXDRGC))>0 ^TMP("LEXQID",$J,"DRG",2,1)=+($G(LEXDRGC))_" Diagnosis Related Group"_$S(+($G(LEXDRGC))>1:"s",1:"")_" (DRG)"
Q
CC(X,LEXVDT,LEX) ; Complication/Comorbidity
N LEXCCE,LEXCCI,LEXCCD K LEX S LEX=0,LEXIEN=+($G(X)) Q:+LEXIEN'>0 S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
S LEXCCI=$$VCC^ICDEX(+LEXIEN,LEXVDT,1),LEXCCD=$P(LEXCCI,"^",2),LEXCCI=$P(LEXCCI,"^",1) Q:"^0^1^2^"'[("^"_LEXCCI_"^")
Q:LEXCCD'?7N S LEXCCE=$S(+LEXCCI=0:"Non-Complication/Comorbidity (Non-CC)",+LEXCCI=1:"Complication/Comorbidity (CC)",+LEXCCI=2:"Major Complication/Comorbidity (MCC)",1:"")
Q:'$L(LEXCCE) S LEX=1,LEX(0)=$$SD^LEXQM(LEXCCD),LEX(1)=LEXCCE
Q
;
; Miscellaneous
SD(X) ; Short Date
Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
IA(X) ; Inaccurate
N LEXBRD,LEXVDT,LEXSYS S LEXVDT=+($G(X)),LEXSYS=1,LEXVDT=$S($G(LEXVDT)="":$$DT^XLFDT,1:$$DBR(LEXVDT)),LEXBRD=3021001,X=$S(LEXVDT<LEXBRD:1,1:0)
Q X
DBR(X) ; Date Business Rules
N LEXVDT S LEXVDT=$G(X) Q:'$G(LEXVDT)!($P(LEXVDT,".")'?7N) $$DT^XLFDT
S:LEXVDT#10000=0 LEXVDT=LEXVDT+101 S:LEXVDT#100=0 LEXVDT=LEXVDT+1 S X=$S(LEXVDT<2781001:2781001,1:LEXVDT)
Q X
LEXQID3 ;ISL/KER - Query - ICD Diagnosis - Extract (cont) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^ICD( ICR 4487
+5 ; ^TMP("LEXQID" SACC 2.3.2.5.1
+6 ; ^TMP("LEXQIDC" SACC 2.3.2.5.1
+7 ; ^TMP("LEXQIDN" SACC 2.3.2.5.1
+8 ; ^TMP("LEXQIDR" SACC 2.3.2.5.1
+9 ;
+10 ; External References
+11 ; $$CODEABA^ICDEX ICR 5747
+12 ; $$CODECS^ICDEX ICR 5747
+13 ; $$CODEC^ICDEX ICR 5747
+14 ; $$CSI^ICDEX ICR 5747
+15 ; $$GETDRG^ICDEX ICR 5747
+16 ; $$ICDDX^ICDEX ICR 5747
+17 ; $$NCC^ICDEX ICR 5747
+18 ; $$NOT^ICDEX ICR 5747
+19 ; $$REQ^ICDEX ICR 5747
+20 ; $$VCC^ICDEX ICR 5747
+21 ; DRGD^ICDGTDRG ICR 4052
+22 ; $$DT^XLFDT ICR 10103
+23 ; $$FMTE^XLFDT ICR 10103
+24 ; $$UP^XLFSTR ICR 10104
+25 ;
+26 QUIT
NOT(X,LEXVDT,LEXLEN) ; Include ICD Codes not to use with ***.**
+1 ;
+2 ; ^TMP("LEXQIDN",$J,IEN)=CODE
+3 ; ^TMP("LEXQIDN",$J,"B",(CODE_" "),IEN)=""
+4 ;
+5 ; ^TMP("LEXQID",$J,"NOT",0)=<total>
+6 ; ^TMP("LEXQID",$J,"NOT",1,1)=<header>
+7 ; ^TMP("LEXQID",$J,"NOT",2,#)=<header text>
+8 ; ^TMP("LEXQID",$J,"NOT",3,<code >)=<code>_" "_<diagnosis>
+9 ;
+10 KILL ^TMP("LEXQIDN",$JOB),^TMP("LEXQID",$JOB,"NOT")
+11 NEW LEX,LEXI,LEXC,LEXICD,LEXIEN,LEXISO,LEXSO,LEXSD,EXD,LEXT,LEXSTR,LEXO
+12 SET LEXIEN=+($GET(X))
IF +LEXIEN'>0
QUIT
SET LEXVDT=+($GET(LEXVDT))
IF LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
+13 SET LEXISO=$$CODEC^ICDEX(80,+LEXIEN)
IF '$LENGTH(LEXISO)
QUIT
+14 SET LEXLEN=+$GET(LEXLEN)
IF +LEXLEN>62
SET LEXLEN=62
SET X=$$NOT^ICDEX(+($GET(LEXIEN)),"LEXQIDN",1)
+15 SET LEXO=""
FOR
SET LEXO=$ORDER(^TMP("LEXQIDN",$JOB,"B",LEXO))
IF '$LENGTH(LEXO)
QUIT
Begin DoDot:1
+16 NEW LEXD
SET LEXICD=$ORDER(^TMP("LEXQIDN",$JOB,"B",LEXO,0))
IF +LEXICD'>0
QUIT
+17 SET LEXSYS=$$CSI^ICDEX(80,+LEXICD)
+18 SET LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
+19 SET LEXSO=$PIECE(LEXD,"^",2)
SET LEXSD=$$UP^XLFSTR($PIECE(LEXD,"^",4))
IF '$LENGTH(LEXSO)
QUIT
IF '$LENGTH(LEXSD)
QUIT
+20 SET LEXT=LEXSO
SET LEXT=LEXT_$JUSTIFY(" ",(9-$LENGTH(LEXT)))_LEXSD
+21 SET ^TMP("LEXQID",$JOB,"NOT",3,(LEXSO_" "))=LEXT
End DoDot:1
+22 KILL ^TMP("LEXQIDN",$JOB)
SET LEXC=0
SET LEXI=""
+23 FOR
SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"NOT",3,LEXI))
IF '$LENGTH(LEXI)
QUIT
SET LEXC=LEXC+1
+24 SET ^TMP("LEXQID",$JOB,"NOT",0)=+($GET(LEXC))
+25 SET LEXI=+($GET(^TMP("LEXQID",$JOB,"NOT",0)))
IF LEXI>0
Begin DoDot:1
+26 NEW LEX,LEXC,LEXSTR,LEXT
SET LEXSTR="The following code"_$SELECT(LEXI>1:"s ",1:" ")_"cannot be used in conjunction with "
+27 IF $LENGTH($GET(LEXISO))
SET LEXSTR=LEXSTR_"ICD Code "_LEXISO
IF '$LENGTH($GET(LEXISO))
SET LEXSTR=LEXSTR_"this ICD Code"
+28 SET LEX(1)=LEXSTR
DO PR^LEXQM(.LEX,(LEXLEN-7))
SET (LEXC,LEXT)=0
FOR
SET LEXT=$ORDER(LEX(LEXT))
IF +LEXT'>0
QUIT
Begin DoDot:2
+29 SET LEXSTR=$$TM^LEXQM($GET(LEX(LEXT)))
IF $LENGTH(LEXSTR)
SET LEXC=LEXC+1
SET ^TMP("LEXQID",$JOB,"NOT",2,LEXC)=LEXSTR
End DoDot:2
End DoDot:1
+30 IF $DATA(^TMP("LEXQID",$JOB,"NOT",2))
SET ^TMP("LEXQID",$JOB,"NOT",1,1)="Not used"
+31 QUIT
REQ(X,LEXVDT,LEXLEN) ; Include ICD Codes required with ***.**
+1 ;
+2 ; ^TMP("LEXQIDR",$J,IEN)=CODE
+3 ; ^TMP("LEXQIDR",$J,"B",(CODE_" "),IEN)=""
+4 ;
+5 ; ^TMP("LEXQID",$J,"REQ",0)=<total>
+6 ; ^TMP("LEXQID",$J,"REQ",1,1)=<header>
+7 ; ^TMP("LEXQID",$J,"REQ",2,#)=<header text>
+8 ; ^TMP("LEXQID",$J,"REQ",3,<code >)=<code>_" "_<diagnosis>
+9 ;
+10 KILL ^TMP("LEXQIDR",$JOB),^TMP("LEXQID",$JOB,"NOT")
+11 NEW LEX,LEXI,LEXC,LEXICD,LEXIEN,LEXISO,LEXSO,LEXSD,EXD,LEXT,LEXSTR,LEXO
+12 SET LEXIEN=+($GET(X))
IF +LEXIEN'>0
QUIT
SET LEXVDT=+($GET(LEXVDT))
IF LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
+13 SET LEXISO=$$CODEC^ICDEX(80,+LEXIEN)
IF '$LENGTH(LEXISO)
QUIT
+14 SET LEXLEN=+$GET(LEXLEN)
IF +LEXLEN>62
SET LEXLEN=62
SET X=$$REQ^ICDEX(+($GET(LEXIEN)),"LEXQIDR",1)
+15 SET LEXO=""
FOR
SET LEXO=$ORDER(^TMP("LEXQIDR",$JOB,"B",LEXO))
IF '$LENGTH(LEXO)
QUIT
Begin DoDot:1
+16 NEW LEXD
SET LEXICD=$ORDER(^TMP("LEXQIDR",$JOB,"B",LEXO,0))
IF +LEXICD'>0
QUIT
+17 SET LEXSYS=$$CSI^ICDEX(80,+LEXICD)
+18 SET LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
+19 SET LEXSO=$PIECE(LEXD,"^",2)
SET LEXSD=$$UP^XLFSTR($PIECE(LEXD,"^",4))
IF '$LENGTH(LEXSO)
QUIT
IF '$LENGTH(LEXSD)
QUIT
+20 SET LEXT=LEXSO
SET LEXT=LEXT_$JUSTIFY(" ",(9-$LENGTH(LEXT)))_LEXSD
+21 SET ^TMP("LEXQID",$JOB,"REQ",3,(LEXSO_" "))=LEXT
End DoDot:1
+22 KILL ^TMP("LEXQIDR",$JOB)
SET LEXC=0
SET LEXI=""
+23 FOR
SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"REQ",3,LEXI))
IF '$LENGTH(LEXI)
QUIT
SET LEXC=LEXC+1
+24 SET ^TMP("LEXQID",$JOB,"REQ",0)=+($GET(LEXC))
+25 SET LEXI=+($GET(^TMP("LEXQID",$JOB,"REQ",0)))
IF LEXI>0
Begin DoDot:1
+26 NEW LEX,LEXC,LEXSTR,LEXT
IF LEXI>1
SET LEXSTR="One of the following codes is required when "
+27 IF LEXI>1
SET LEXSTR="One of the following codes is required when "
IF LEXI'>1
SET LEXSTR="The following code is required when "
+28 IF $LENGTH($GET(LEXISO))
SET LEXSTR=LEXSTR_"ICD Code "_LEXISO_" "
+29 IF '$LENGTH($GET(LEXISO))
SET LEXSTR=LEXSTR_"this ICD Code "
SET LEXSTR=LEXSTR_"is used"
+30 SET LEX(1)=LEXSTR
DO PR^LEXQM(.LEX,(LEXLEN-7))
SET (LEXC,LEXT)=0
FOR
SET LEXT=$ORDER(LEX(LEXT))
IF +LEXT'>0
QUIT
Begin DoDot:2
+31 SET LEXSTR=$$TM^LEXQM($GET(LEX(LEXT)))
IF $LENGTH(LEXSTR)
SET LEXC=LEXC+1
SET ^TMP("LEXQID",$JOB,"REQ",2,LEXC)=LEXSTR
End DoDot:2
End DoDot:1
+32 IF $DATA(^TMP("LEXQID",$JOB,"REQ",2))
SET ^TMP("LEXQID",$JOB,"REQ",1,1)="Required with"
+33 QUIT
NCC(X,LEXVDT,LEXLEN) ; Include the codes that ***.** is not CC with
+1 ;
+2 ; ^TMP("LEXQIDC",$J,IEN)=CODE
+3 ; ^TMP("LEXQIDC",$J,"B",(CODE_" "),IEN)=""
+4 ;
+5 ; ^TMP("LEXQID",$J,"NCC",0)=<total>
+6 ; ^TMP("LEXQID",$J,"NCC",1,1)=<header>
+7 ; ^TMP("LEXQID",$J,"NCC",2,#)=<header text>
+8 ; ^TMP("LEXQID",$J,"NCC",3,<code >)=<code>_" "_<diagnosis>
+9 ;
+10 KILL ^TMP("LEXQIDC",$JOB),^TMP("LEXQID",$JOB,"NOT")
+11 NEW LEX,LEXI,LEXC,LEXICD,LEXIEN,LEXISO,LEXSO,LEXSD,EXD,LEXT,LEXSTR,LEXO
+12 SET LEXIEN=+($GET(X))
IF +LEXIEN'>0
QUIT
SET LEXVDT=+($GET(LEXVDT))
IF LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
+13 SET LEXISO=$$CODEC^ICDEX(80,+LEXIEN)
IF '$LENGTH(LEXISO)
QUIT
+14 SET LEXLEN=+$GET(LEXLEN)
IF +LEXLEN>62
SET LEXLEN=62
SET X=$$NCC^ICDEX(+($GET(LEXIEN)),"LEXQIDC",1)
+15 SET LEXO=""
FOR
SET LEXO=$ORDER(^TMP("LEXQIDC",$JOB,"B",LEXO))
IF '$LENGTH(LEXO)
QUIT
Begin DoDot:1
+16 NEW LEXD,LEXI,LEXC
+17 SET LEXI=$ORDER(^TMP("LEXQIDC",$JOB,"B",LEXO,0))
IF +LEXI'>0
QUIT
+18 SET LEXC=$GET(^TMP("LEXQIDC",$JOB,LEXI))
IF '$LENGTH(LEXC)
QUIT
+19 SET LEXSYS=+($$CODECS^ICDEX(LEXC,80))
IF +LEXSYS'>0
QUIT
+20 SET LEXICD=$$CODEABA^ICDEX(LEXC,80,+LEXSYS)
+21 ; S LEXICD=$O(^TMP("LEXQIDC",$J,"B",LEXO,0)) Q:+LEXICD'>0
+22 ; S LEXSYS=$$CSI^ICDEX(80,+LEXICD)
+23 SET LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
+24 SET LEXSO=$PIECE(LEXD,"^",2)
SET LEXSD=$$UP^XLFSTR($PIECE(LEXD,"^",4))
IF '$LENGTH(LEXSO)
QUIT
IF '$LENGTH(LEXSD)
QUIT
+25 SET LEXT=LEXSO
SET LEXT=LEXT_$JUSTIFY(" ",(9-$LENGTH(LEXT)))_LEXSD
+26 SET ^TMP("LEXQID",$JOB,"NCC",3,(LEXSO_" "))=LEXT
End DoDot:1
+27 KILL ^TMP("LEXQIDC",$JOB)
SET LEXC=0
SET LEXI=""
+28 FOR
SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"NCC",3,LEXI))
IF '$LENGTH(LEXI)
QUIT
SET LEXC=LEXC+1
+29 SET ^TMP("LEXQID",$JOB,"NCC",0)=+($GET(LEXC))
+30 SET LEXI=+($GET(^TMP("LEXQID",$JOB,"NCC",0)))
IF LEXI>0
Begin DoDot:1
+31 NEW LEX,LEXC,LEXSTR,LEXT
SET LEXSTR="ICD Code "
IF $LENGTH($GET(LEXISO))
SET LEXSTR=LEXSTR_LEXISO_" "
+32 SET LEXSTR=LEXSTR_"is not considered as Complication Comorbidity (CC) with the following code"_$SELECT(LEXI>1:"s",1:"")
+33 SET LEX(1)=LEXSTR
DO PR^LEXQM(.LEX,(LEXLEN-7))
SET (LEXC,LEXT)=0
FOR
SET LEXT=$ORDER(LEX(LEXT))
IF +LEXT'>0
QUIT
Begin DoDot:2
+34 SET LEXSTR=$$TM^LEXQM($GET(LEX(LEXT)))
IF $LENGTH(LEXSTR)
SET LEXC=LEXC+1
SET ^TMP("LEXQID",$JOB,"NCC",2,LEXC)=LEXSTR
End DoDot:2
End DoDot:1
+35 IF $DATA(^TMP("LEXQID",$JOB,"NCC",2))
SET ^TMP("LEXQID",$JOB,"NCC",1,1)="Not CC with"
+36 QUIT
DRG(X,LEXVDT,LEXLEN) ; Diagnosis Related Group
+1 ;
+2 ; ^TMP("LEXQID",$J,"DRG",0)=<total>
+3 ; ^TMP("LEXQID",$J,"DRG",1,1)=<header>
+4 ; ^TMP("LEXQID",$J,"DRG",1,2)=<effective date>
+5 ; ^TMP("LEXQID",$J,"DRG",2,1)=<header text>
+6 ; ^TMP("LEXQID",$J,"DRG",3,#)=<DRG list>
+7 ;
+8 NEW LEXC,LEXDDD,LEXDDE,LEXDEF,LEXDDI,LEXDDT,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRP,LEXI,LEXIEN,LEXL,LEXN,LEXN0,LEXT
+9 NEW LEXEFF,LEXPIE,LEXSTA
SET LEXIEN=+($GET(X))
IF +LEXIEN'>0
QUIT
+10 SET LEXVDT=+($GET(LEXVDT))
IF LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET LEXLEN=+$GET(LEXLEN)
IF +LEXLEN>62
SET LEXLEN=62
+11 SET LEXSTR=$$GETDRG^ICDEX(80,LEXIEN,LEXVDT)
SET LEXSTA=$PIECE(LEXSTR,";",3)
IF LEXSTA'>0
QUIT
SET LEXEFF=$PIECE(LEXSTR,";",2)
IF LEXEFF'?7N
QUIT
SET LEXSTR=$PIECE(LEXSTR,";",1)
+12 IF '$LENGTH($TRANSLATE(LEXSTR,"^",""))
Begin DoDot:1
+13 SET ^TMP("LEXQID",$JOB,"DRG",0)=0
SET ^TMP("LEXQID",$JOB,"DRG",1,1)="DRG Groups"
+14 SET ^TMP("LEXQID",$JOB,"DRG",2,1)="No DRG Groups found to be active for the date provided"
+15 IF LEXVDT?7N
SET ^TMP("LEXQID",$JOB,"DRG",2,1)="No DRG Groups found to be active on "_$$SD^LEXQM(LEXVDT)
End DoDot:1
QUIT
+16 FOR LEXPIE=1:1
IF '$LENGTH($PIECE(LEXSTR,"^",LEXPIE))
QUIT
SET LEXDRP=$PIECE(LEXSTR,"^",LEXPIE)
Begin DoDot:1
+17 SET LEXDRG=$PIECE($GET(^ICD(+LEXDRP,0)),"^",1)
+18 KILL LEXDRGD
DO DRGD^ICDGTDRG(LEXDRG,"LEXDRGD",,+LEXVDT)
+19 SET LEXDRG=$TRANSLATE(LEXDRG,"DRG","")
SET LEXDRG=+LEXDRG
IF +LEXDRG'>0
QUIT
+20 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXDRGD(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:2
+21 NEW LEXT
SET LEXT=$$TM^LEXQM($GET(LEXDRGD(LEXI)))
+22 IF '$LENGTH(LEXT)!(LEXT["CODE TEXT MAY BE INACCURATE")
KILL LEXDRGD(LEXI)
QUIT
+23 SET LEXDRGD(LEXI)=LEXT
End DoDot:2
+24 SET LEXDRG1=LEXDRG
SET LEXDRG1=LEXDRG1_$JUSTIFY(" ",(6-$LENGTH(LEXDRG1)))
SET LEXDRG2=$JUSTIFY(" ",6)
DO PR^LEXQM(.LEXDRGD,(LEXLEN-8))
+25 SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(LEXDRGD(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:2
+26 NEW LEXT,LEXL,LEXN
SET LEXT=$$TM^LEXQM($GET(LEXDRGD(LEXI)))
+27 IF '$LENGTH(LEXT)
QUIT
SET LEXC=LEXC+1
+28 IF LEXC=1
SET LEXL=LEXDRG1_LEXT
SET LEXDRGC=+($GET(LEXDRGC))+1
+29 IF LEXC>1
SET LEXL=LEXDRG2_LEXT
+30 SET LEXN=$ORDER(^TMP("LEXQID",$JOB,"DRG",3," "),-1)+1
+31 SET ^TMP("LEXQID",$JOB,"DRG",3,LEXN)=LEXL
End DoDot:2
End DoDot:1
+32 SET ^TMP("LEXQID",$JOB,"DRG",0)=+($GET(LEXDRGC))
SET ^TMP("LEXQID",$JOB,"DRG",1,1)="DRG Groups"
+33 IF $GET(LEXEFF)?7N
SET ^TMP("LEXQID",$JOB,"DRG",1,2)=$$SD^LEXQM(LEXEFF)
+34 IF +($GET(LEXDRGC))>0
SET ^TMP("LEXQID",$JOB,"DRG",2,1)=+($GET(LEXDRGC))_" Diagnosis Related Group"_$SELECT(+($GET(LEXDRGC))>1:"s",1:"")_" (DRG)"
+35 QUIT
CC(X,LEXVDT,LEX) ; Complication/Comorbidity
+1 NEW LEXCCE,LEXCCI,LEXCCD
KILL LEX
SET LEX=0
SET LEXIEN=+($GET(X))
IF +LEXIEN'>0
QUIT
SET LEXVDT=+($GET(LEXVDT))
IF LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
+2 SET LEXCCI=$$VCC^ICDEX(+LEXIEN,LEXVDT,1)
SET LEXCCD=$PIECE(LEXCCI,"^",2)
SET LEXCCI=$PIECE(LEXCCI,"^",1)
IF "^0^1^2^"'[("^"_LEXCCI_"^")
QUIT
+3 IF LEXCCD'?7N
QUIT
SET LEXCCE=$SELECT(+LEXCCI=0:"Non-Complication/Comorbidity (Non-CC)",+LEXCCI=1:"Complication/Comorbidity (CC)",+LEXCCI=2:"Major Complication/Comorbidity (MCC)",1:"")
+4 IF '$LENGTH(LEXCCE)
QUIT
SET LEX=1
SET LEX(0)=$$SD^LEXQM(LEXCCD)
SET LEX(1)=LEXCCE
+5 QUIT
+6 ;
+7 ; Miscellaneous
SD(X) ; Short Date
+1 QUIT $TRANSLATE($$FMTE^XLFDT(+($GET(X)),"5DZ"),"@"," ")
IA(X) ; Inaccurate
+1 NEW LEXBRD,LEXVDT,LEXSYS
SET LEXVDT=+($GET(X))
SET LEXSYS=1
SET LEXVDT=$SELECT($GET(LEXVDT)="":$$DT^XLFDT,1:$$DBR(LEXVDT))
SET LEXBRD=3021001
SET X=$SELECT(LEXVDT<LEXBRD:1,1:0)
+2 QUIT X
DBR(X) ; Date Business Rules
+1 NEW LEXVDT
SET LEXVDT=$GET(X)
IF '$GET(LEXVDT)!($PIECE(LEXVDT,".")'?7N)
QUIT $$DT^XLFDT
+2 IF LEXVDT#10000=0
SET LEXVDT=LEXVDT+101
IF LEXVDT#100=0
SET LEXVDT=LEXVDT+1
SET X=$SELECT(LEXVDT<2781001:2781001,1:LEXVDT)
+3 QUIT X
