- LEXQID3 ;ISL/KER - Query - ICD Diagnosis - Extract (cont) ;05/23/2017
- ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
- ;
- ; 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")
- Q
- 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,LEXSI,LEXSO,LEXSD 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 LEXSI=+LEXD,LEXSO=$P(LEXD,"^",2),LEXSD=$$UP^XLFSTR($P(LEXD,"^",4))
- . Q:+LEXSI'>0 Q:'$L(LEXSO) Q:'$L(LEXSD)
- . S LEXT=LEXSO,LEXT=LEXT_$J(" ",(9-$L(LEXT)))_LEXSD
- . S:$D(LEXIIEN) LEXT=LEXT_" (IEN "_+LEXSI_")"
- . 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^LEXU(.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")
- Q
- 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,LEXSI,LEXSO,LEXSD 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 LEXSI=+LEXD,LEXSO=$P(LEXD,"^",2),LEXSD=$$UP^XLFSTR($P(LEXD,"^",4))
- . Q:+LEXSI'>0 Q:'$L(LEXSO) Q:'$L(LEXSD)
- . S LEXT=LEXSO,LEXT=LEXT_$J(" ",(9-$L(LEXT)))_LEXSD
- . S:$D(LEXIIEN) LEXT=LEXT_" (IEN "_+LEXSI_")"
- . 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^LEXU(.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,"NCC")
- Q
- 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,LEXSI,LEXSO,LEXSD
- . 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 LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
- . S LEXSI=+LEXD,LEXSO=$P(LEXD,"^",2),LEXSD=$$UP^XLFSTR($P(LEXD,"^",4))
- . Q:'$L(LEXSO) Q:'$L(LEXSD) Q:LEXSI'>0
- . S LEXT=LEXSO,LEXT=LEXT_$J(" ",(9-$L(LEXT)))_LEXSD
- . S:$D(LEXIIEN) LEXT=LEXT_" (IEN "_+LEXSI_")"
- . 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^LEXU(.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>
- ;
- K ^TMP("LEXQID",$J,"DRG")
- Q
- 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^LEXU(.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
- Q
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQID3 10247 printed Apr 23, 2025@18:22:59 Page 2
- LEXQID3 ;ISL/KER - Query - ICD Diagnosis - Extract (cont) ;05/23/2017
- +1 ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
- +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 QUIT
- +12 NEW LEX,LEXI,LEXC,LEXICD,LEXIEN,LEXISO,LEXSO,LEXSD,EXD,LEXT,LEXSTR,LEXO
- +13 SET LEXIEN=+($GET(X))
- if +LEXIEN'>0
- QUIT
- SET LEXVDT=+($GET(LEXVDT))
- if LEXVDT'?7N
- SET LEXVDT=$$DT^XLFDT
- +14 SET LEXISO=$$CODEC^ICDEX(80,+LEXIEN)
- if '$LENGTH(LEXISO)
- QUIT
- +15 SET LEXLEN=+$GET(LEXLEN)
- if +LEXLEN>62
- SET LEXLEN=62
- SET X=$$NOT^ICDEX(+($GET(LEXIEN)),"LEXQIDN",1)
- +16 SET LEXO=""
- FOR
- SET LEXO=$ORDER(^TMP("LEXQIDN",$JOB,"B",LEXO))
- if '$LENGTH(LEXO)
- QUIT
- Begin DoDot:1
- +17 NEW LEXD,LEXSI,LEXSO,LEXSD
- SET LEXICD=$ORDER(^TMP("LEXQIDN",$JOB,"B",LEXO,0))
- if +LEXICD'>0
- QUIT
- +18 SET LEXSYS=$$CSI^ICDEX(80,+LEXICD)
- +19 SET LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
- +20 SET LEXSI=+LEXD
- SET LEXSO=$PIECE(LEXD,"^",2)
- SET LEXSD=$$UP^XLFSTR($PIECE(LEXD,"^",4))
- +21 if +LEXSI'>0
- QUIT
- if '$LENGTH(LEXSO)
- QUIT
- if '$LENGTH(LEXSD)
- QUIT
- +22 SET LEXT=LEXSO
- SET LEXT=LEXT_$JUSTIFY(" ",(9-$LENGTH(LEXT)))_LEXSD
- +23 if $DATA(LEXIIEN)
- SET LEXT=LEXT_" (IEN "_+LEXSI_")"
- +24 SET ^TMP("LEXQID",$JOB,"NOT",3,(LEXSO_" "))=LEXT
- End DoDot:1
- +25 KILL ^TMP("LEXQIDN",$JOB)
- SET LEXC=0
- SET LEXI=""
- +26 FOR
- SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"NOT",3,LEXI))
- if '$LENGTH(LEXI)
- QUIT
- SET LEXC=LEXC+1
- +27 SET ^TMP("LEXQID",$JOB,"NOT",0)=+($GET(LEXC))
- +28 SET LEXI=+($GET(^TMP("LEXQID",$JOB,"NOT",0)))
- IF LEXI>0
- Begin DoDot:1
- +29 NEW LEX,LEXC,LEXSTR,LEXT
- SET LEXSTR="The following code"_$SELECT(LEXI>1:"s ",1:" ")_"cannot be used in conjunction with "
- +30 if $LENGTH($GET(LEXISO))
- SET LEXSTR=LEXSTR_"ICD Code "_LEXISO
- if '$LENGTH($GET(LEXISO))
- SET LEXSTR=LEXSTR_"this ICD Code"
- +31 SET LEX(1)=LEXSTR
- DO PR^LEXU(.LEX,(LEXLEN-7))
- SET (LEXC,LEXT)=0
- FOR
- SET LEXT=$ORDER(LEX(LEXT))
- if +LEXT'>0
- QUIT
- Begin DoDot:2
- +32 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
- +33 if $DATA(^TMP("LEXQID",$JOB,"NOT",2))
- SET ^TMP("LEXQID",$JOB,"NOT",1,1)="Not used"
- +34 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 QUIT
- +12 NEW LEX,LEXI,LEXC,LEXICD,LEXIEN,LEXISO,LEXSO,LEXSD,EXD,LEXT,LEXSTR,LEXO
- +13 SET LEXIEN=+($GET(X))
- if +LEXIEN'>0
- QUIT
- SET LEXVDT=+($GET(LEXVDT))
- if LEXVDT'?7N
- SET LEXVDT=$$DT^XLFDT
- +14 SET LEXISO=$$CODEC^ICDEX(80,+LEXIEN)
- if '$LENGTH(LEXISO)
- QUIT
- +15 SET LEXLEN=+$GET(LEXLEN)
- if +LEXLEN>62
- SET LEXLEN=62
- SET X=$$REQ^ICDEX(+($GET(LEXIEN)),"LEXQIDR",1)
- +16 SET LEXO=""
- FOR
- SET LEXO=$ORDER(^TMP("LEXQIDR",$JOB,"B",LEXO))
- if '$LENGTH(LEXO)
- QUIT
- Begin DoDot:1
- +17 NEW LEXD,LEXSI,LEXSO,LEXSD
- SET LEXICD=$ORDER(^TMP("LEXQIDR",$JOB,"B",LEXO,0))
- if +LEXICD'>0
- QUIT
- +18 SET LEXSYS=$$CSI^ICDEX(80,+LEXICD)
- +19 SET LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
- +20 SET LEXSI=+LEXD
- SET LEXSO=$PIECE(LEXD,"^",2)
- SET LEXSD=$$UP^XLFSTR($PIECE(LEXD,"^",4))
- +21 if +LEXSI'>0
- QUIT
- if '$LENGTH(LEXSO)
- QUIT
- if '$LENGTH(LEXSD)
- QUIT
- +22 SET LEXT=LEXSO
- SET LEXT=LEXT_$JUSTIFY(" ",(9-$LENGTH(LEXT)))_LEXSD
- +23 if $DATA(LEXIIEN)
- SET LEXT=LEXT_" (IEN "_+LEXSI_")"
- +24 SET ^TMP("LEXQID",$JOB,"REQ",3,(LEXSO_" "))=LEXT
- End DoDot:1
- +25 KILL ^TMP("LEXQIDR",$JOB)
- SET LEXC=0
- SET LEXI=""
- +26 FOR
- SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"REQ",3,LEXI))
- if '$LENGTH(LEXI)
- QUIT
- SET LEXC=LEXC+1
- +27 SET ^TMP("LEXQID",$JOB,"REQ",0)=+($GET(LEXC))
- +28 SET LEXI=+($GET(^TMP("LEXQID",$JOB,"REQ",0)))
- IF LEXI>0
- Begin DoDot:1
- +29 NEW LEX,LEXC,LEXSTR,LEXT
- if LEXI>1
- SET LEXSTR="One of the following codes is required when "
- +30 if LEXI>1
- SET LEXSTR="One of the following codes is required when "
- if LEXI'>1
- SET LEXSTR="The following code is required when "
- +31 if $LENGTH($GET(LEXISO))
- SET LEXSTR=LEXSTR_"ICD Code "_LEXISO_" "
- +32 if '$LENGTH($GET(LEXISO))
- SET LEXSTR=LEXSTR_"this ICD Code "
- SET LEXSTR=LEXSTR_"is used"
- +33 SET LEX(1)=LEXSTR
- DO PR^LEXU(.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,"REQ",2,LEXC)=LEXSTR
- End DoDot:2
- End DoDot:1
- +35 if $DATA(^TMP("LEXQID",$JOB,"REQ",2))
- SET ^TMP("LEXQID",$JOB,"REQ",1,1)="Required with"
- +36 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,"NCC")
- +11 QUIT
- +12 NEW LEX,LEXI,LEXC,LEXICD,LEXIEN,LEXISO,LEXSO,LEXSD,EXD,LEXT,LEXSTR,LEXO
- +13 SET LEXIEN=+($GET(X))
- if +LEXIEN'>0
- QUIT
- SET LEXVDT=+($GET(LEXVDT))
- if LEXVDT'?7N
- SET LEXVDT=$$DT^XLFDT
- +14 SET LEXISO=$$CODEC^ICDEX(80,+LEXIEN)
- if '$LENGTH(LEXISO)
- QUIT
- +15 SET LEXLEN=+$GET(LEXLEN)
- if +LEXLEN>62
- SET LEXLEN=62
- SET X=$$NCC^ICDEX(+($GET(LEXIEN)),"LEXQIDC",1)
- +16 SET LEXO=""
- FOR
- SET LEXO=$ORDER(^TMP("LEXQIDC",$JOB,"B",LEXO))
- if '$LENGTH(LEXO)
- QUIT
- Begin DoDot:1
- +17 NEW LEXD,LEXI,LEXC,LEXSI,LEXSO,LEXSD
- +18 SET LEXI=$ORDER(^TMP("LEXQIDC",$JOB,"B",LEXO,0))
- if +LEXI'>0
- QUIT
- +19 SET LEXC=$GET(^TMP("LEXQIDC",$JOB,LEXI))
- if '$LENGTH(LEXC)
- QUIT
- +20 SET LEXSYS=+($$CODECS^ICDEX(LEXC,80))
- if +LEXSYS'>0
- QUIT
- +21 SET LEXICD=$$CODEABA^ICDEX(LEXC,80,+LEXSYS)
- +22 SET LEXD=$$ICDDX^ICDEX(+LEXICD,LEXVDT,LEXSYS,"I")
- +23 SET LEXSI=+LEXD
- SET LEXSO=$PIECE(LEXD,"^",2)
- SET LEXSD=$$UP^XLFSTR($PIECE(LEXD,"^",4))
- +24 if '$LENGTH(LEXSO)
- QUIT
- if '$LENGTH(LEXSD)
- QUIT
- if LEXSI'>0
- QUIT
- +25 SET LEXT=LEXSO
- SET LEXT=LEXT_$JUSTIFY(" ",(9-$LENGTH(LEXT)))_LEXSD
- +26 if $DATA(LEXIIEN)
- SET LEXT=LEXT_" (IEN "_+LEXSI_")"
- +27 SET ^TMP("LEXQID",$JOB,"NCC",3,(LEXSO_" "))=LEXT
- End DoDot:1
- +28 KILL ^TMP("LEXQIDC",$JOB)
- SET LEXC=0
- SET LEXI=""
- +29 FOR
- SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"NCC",3,LEXI))
- if '$LENGTH(LEXI)
- QUIT
- SET LEXC=LEXC+1
- +30 SET ^TMP("LEXQID",$JOB,"NCC",0)=+($GET(LEXC))
- +31 SET LEXI=+($GET(^TMP("LEXQID",$JOB,"NCC",0)))
- IF LEXI>0
- Begin DoDot:1
- +32 NEW LEX,LEXC,LEXSTR,LEXT
- SET LEXSTR="ICD Code "
- if $LENGTH($GET(LEXISO))
- SET LEXSTR=LEXSTR_LEXISO_" "
- +33 SET LEXSTR=LEXSTR_"is not considered as Complication Comorbidity (CC) with the following code"_$SELECT(LEXI>1:"s",1:"")
- +34 SET LEX(1)=LEXSTR
- DO PR^LEXU(.LEX,(LEXLEN-7))
- SET (LEXC,LEXT)=0
- FOR
- SET LEXT=$ORDER(LEX(LEXT))
- if +LEXT'>0
- QUIT
- Begin DoDot:2
- +35 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
- +36 if $DATA(^TMP("LEXQID",$JOB,"NCC",2))
- SET ^TMP("LEXQID",$JOB,"NCC",1,1)="Not CC with"
- +37 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 KILL ^TMP("LEXQID",$JOB,"DRG")
- +9 QUIT
- +10 NEW LEXC,LEXDDD,LEXDDE,LEXDEF,LEXDDI,LEXDDT,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRP,LEXI,LEXIEN,LEXL,LEXN,LEXN0,LEXT
- +11 NEW LEXEFF,LEXPIE,LEXSTA
- SET LEXIEN=+($GET(X))
- if +LEXIEN'>0
- QUIT
- +12 SET LEXVDT=+($GET(LEXVDT))
- if LEXVDT'?7N
- SET LEXVDT=$$DT^XLFDT
- SET LEXLEN=+$GET(LEXLEN)
- if +LEXLEN>62
- SET LEXLEN=62
- +13 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)
- +14 IF '$LENGTH($TRANSLATE(LEXSTR,"^",""))
- Begin DoDot:1
- +15 SET ^TMP("LEXQID",$JOB,"DRG",0)=0
- SET ^TMP("LEXQID",$JOB,"DRG",1,1)="DRG Groups"
- +16 SET ^TMP("LEXQID",$JOB,"DRG",2,1)="No DRG Groups found to be active for the date provided"
- +17 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
- +18 FOR LEXPIE=1:1
- if '$LENGTH($PIECE(LEXSTR,"^",LEXPIE))
- QUIT
- SET LEXDRP=$PIECE(LEXSTR,"^",LEXPIE)
- Begin DoDot:1
- +19 SET LEXDRG=$PIECE($GET(^ICD(+LEXDRP,0)),"^",1)
- +20 KILL LEXDRGD
- DO DRGD^ICDGTDRG(LEXDRG,"LEXDRGD",,+LEXVDT)
- +21 SET LEXDRG=$TRANSLATE(LEXDRG,"DRG","")
- SET LEXDRG=+LEXDRG
- if +LEXDRG'>0
- QUIT
- +22 SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEXDRGD(LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:2
- +23 NEW LEXT
- SET LEXT=$$TM^LEXQM($GET(LEXDRGD(LEXI)))
- +24 IF '$LENGTH(LEXT)!(LEXT["CODE TEXT MAY BE INACCURATE")
- KILL LEXDRGD(LEXI)
- QUIT
- +25 SET LEXDRGD(LEXI)=LEXT
- End DoDot:2
- +26 SET LEXDRG1=LEXDRG
- SET LEXDRG1=LEXDRG1_$JUSTIFY(" ",(6-$LENGTH(LEXDRG1)))
- SET LEXDRG2=$JUSTIFY(" ",6)
- DO PR^LEXU(.LEXDRGD,(LEXLEN-8))
- +27 SET (LEXC,LEXI)=0
- FOR
- SET LEXI=$ORDER(LEXDRGD(LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:2
- +28 NEW LEXT,LEXL,LEXN
- SET LEXT=$$TM^LEXQM($GET(LEXDRGD(LEXI)))
- +29 if '$LENGTH(LEXT)
- QUIT
- SET LEXC=LEXC+1
- +30 if LEXC=1
- SET LEXL=LEXDRG1_LEXT
- SET LEXDRGC=+($GET(LEXDRGC))+1
- +31 if LEXC>1
- SET LEXL=LEXDRG2_LEXT
- +32 SET LEXN=$ORDER(^TMP("LEXQID",$JOB,"DRG",3," "),-1)+1
- +33 SET ^TMP("LEXQID",$JOB,"DRG",3,LEXN)=LEXL
- End DoDot:2
- End DoDot:1
- +34 SET ^TMP("LEXQID",$JOB,"DRG",0)=+($GET(LEXDRGC))
- SET ^TMP("LEXQID",$JOB,"DRG",1,1)="DRG Groups"
- +35 if $GET(LEXEFF)?7N
- SET ^TMP("LEXQID",$JOB,"DRG",1,2)=$$SD^LEXQM(LEXEFF)
- +36 if +($GET(LEXDRGC))>0
- SET ^TMP("LEXQID",$JOB,"DRG",2,1)=+($GET(LEXDRGC))_" Diagnosis Related Group"_$SELECT(+($GET(LEXDRGC))>1:"s",1:"")_" (DRG)"
- +37 QUIT
- CC(X,LEXVDT,LEX) ; Complication/Comorbidity
- +1 QUIT
- +2 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
- +3 SET LEXCCI=$$VCC^ICDEX(+LEXIEN,LEXVDT,1)
- SET LEXCCD=$PIECE(LEXCCI,"^",2)
- SET LEXCCI=$PIECE(LEXCCI,"^",1)
- if "^0^1^2^"'[("^"_LEXCCI_"^")
- QUIT
- +4 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:"")
- +5 if '$LENGTH(LEXCCE)
- QUIT
- SET LEX=1
- SET LEX(0)=$$SD^LEXQM(LEXCCD)
- SET LEX(1)=LEXCCE
- +6 QUIT
- +7 ;
- +8 ; 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
