LEXQIP3 ;ISL/KER - Query - ICD Procedure - Save ;05/23/2017
;;2.0;LEXICON UTILITY;**62,73,80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXQIPO") SACC 2.3.2.5.1
;
; External References
; $$VSEX^ICDEX ICR 5747
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXCDT Code Set Versioning Date
; LEXDG DRG Array
; LEXIEN Internal Entry Number
; LEXIIEN Include IENs flag
; LEXLEN Offset Length
; LEXSO Code
; LEXNAM Unversioned Name
; LEXST Status and Effective Dates
; LEXSD Versioned Short Description
; LEXLD Versioned Long Description
; LEXWN Warning
; LEXMOR Major O.R. Procedure
; LEXDG MDC/DRG
; LEXELDT External Last Date
; LEXLX Lexicon Expressioin
;
EN ; Main Entry Point
K ^TMP("LEXQIPO",$J) Q:'$L($G(LEXELDT)) I +($G(LEXST))<0 D FUT D:$D(^TMP("LEXQIPO",$J)) DSP^LEXQO("LEXQIPO") Q
D FUL D:$D(^TMP("LEXQIPO",$J)) DSP^LEXQO("LEXQIPO")
Q
FUT ; Future Activation
N LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXSTA S LEXI=+($G(LEXIEN)) Q:+LEXI'>0
S LEXL=+($G(LEXLEN)) Q:+LEXL'>0 S:LEXL>62 LEXL=62
Q:'$L(LEXSO) Q:'$L(LEXNAM) S LEXSTA=$G(LEXST)
S LEXEFF=$P(LEXSTA,"^",5),LEXSTA=$P(LEXSTA,"^",4)
Q:'$L(LEXSTA) Q:'$L(LEXEFF) S (LEX1,LEX2,LEX3)=""
D BOD(LEXELDT),COD(LEXSO,LEXNAM,$G(LEXCDT),+($G(LEXL))),STA(.LEXST,+($G(LEXL)))
Q
BOD(X) ; Based on Date
N LEXBOD S LEXBOD=$G(X),X="Display based on date: "_LEXBOD D BL,TL(X)
Q
COD(X,Y,LEXD,LEXLEN) ; Code Line
N LEXC,LEXN,LEXT,LEXIEN,LEXNAM S LEXC=$G(X),LEXN=$G(Y),LEXD=$G(LEXD),LEXIEN=$$CI(LEXC,LEXD)
S LEXNAM=$P(LEXN," (IEN ",1) S:$D(LEXIIEN)&($L(LEXIEN)) LEXNAM=LEXIEN
S LEXT="Code: "_LEXC S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXNAM D BL,TL(LEXT)
Q
STA(X,LEXLEN) ; Status Line
N LEX,LEXC,LEXX,LEXE,LEXI,LEXN,LEXS,LEXT,LEXW,LEXEFF,LEXSTA
S LEXX=$G(X),LEXSTA=$P(LEXX,"^",4),LEXEFF=$P(LEXX,"^",5)
S LEXEFF=$TR(LEXEFF,"()",""),LEXW=$P(LEXX,"^",6)
S LEXT=" Status: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXSTA
S LEXT=LEXT_$J(" ",(35-$L(LEXT)))
S:LEXEFF'["future" LEXT=LEXT_"Effective: "
S LEXT=LEXT_$$UP^XLFSTR($E(LEXEFF,1))_$E(LEXEFF,2,$L(LEXEFF)) D BL,TL(LEXT)
I $L(LEXW) D
. N LEX,LEXT,LEXC,LEXI,LEXN S LEX(1)=LEXW D PR^LEXU(.LEX,(LEXLEN-7))
. Q:+($O(LEX(" "),-1))'>0 S LEXT=$J(" ",((79-+($G(LEXLEN)))))
. S (LEXC,LEXI)=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D
. . N LEXN S LEXN=$$TM^LEXQM($G(LEX(LEXI))) S:$L(LEXN) LEXC=LEXC+1
. . D:LEXC=1 BL D TL((LEXT_LEXN))
Q
FUL ; Full Display
N LEXFUL,LEX,LEXL S LEXL=+($G(LEXLEN)) S:LEXL>62 LEXL=62
S LEXFUL="" D FUT
D LIM(+($G(LEXIEN)),+($G(LEXL)))
D SD(.LEXSD,+($G(LEXL)))
D LD(.LEXLD,+($G(LEXL)))
D LX(.LEXLX,+($G(LEXL)))
D WN(.LEXWN,+($G(LEXL)))
D MOR(.LEXMOR,+($G(LEXL)))
D DRG(.LEXDG,+($G(LEXL)))
Q
LIM(X,LEXLEN) ; Limitations - Sex
N LEXC,LEXH,LEXI,LEXS,LEXT S LEXC=0,LEXI=+($G(X)) S LEXS=$$VSEX^ICDEX(80.1,+LEXI,$G(LEXCDT)) Q:"^M^F^"'[("^"_LEXS_"^")
S LEXH="Use only with the " S:LEXS="F" LEXH=LEXH_"female sex" S:LEXS="M" LEXH=LEXH_"male sex"
S LEXT=" Limitations: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXH
D BL,TL(LEXT) S LEXC=1
Q
SD(X,LEXLEN) ; Short Description
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Short Name: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
Q
LD(X,LEXLEN) ; Long Description
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Description: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))) S LEXI=2 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
LX(X,LEXLEN) ; Lexicon Expression
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Lexicon Term:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=2 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
WN(X,LEXLEN) ; Warning
N LEXI,LEXH,LEXE,LEXN,LEXT,LEXC Q:'$D(X(1)) S LEXC=0,LEXN=$G(X(1)),LEXT="",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN
D:$L($G(LEXLD(2))) BL D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=1 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
MOR(X,LEXLEN) ; Major OR Procedure
Q
N LEXE,LEXH,LEXI,LEXID,LEXN,LEXT Q:'$D(X(1)) Q:'$D(X(1,1)) S LEXID=$G(X(1)) Q:'$L(LEXID) S LEXN=$G(X(1,1)) Q:'$L(LEXN)
S LEXT=" Major OR Proc",LEXE="Major O.R. Procedure",LEXE=LEXN,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXE D BL,TL(LEXT)
S LEXI=1 F S LEXI=$O(X(1,LEXI)) Q:+LEXI'>0 S LEXE=$G(X(1,LEXI)) I $L(LEXE) S LEXT=$J(" ",((79-+($G(LEXLEN)))))_LEXE D TL(LEXT)
Q
DRG(X,LEXLEN) ; Major Diagnostic Category/DRG
Q
N LEXE,LEXH,LEXI,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)) Q:'$L(LEXN) S LEXE=$G(X(0)) S:$L(LEXE,"/")'=3 LEXE=""
S LEXT=" MDC/DRG:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT) S LEXN=$G(X(2))
S LEXT=" "_LEXE,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT))) D TL((LEXT_LEXN)) S LEXT=$J(" ",(79-+($G(LEXLEN)))),LEXI=2
F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=$G(X(LEXI)) D:$L(LEXN) TL((LEXT_LEXN))
Q
;
; Miscellaneous
CI(X,LEXD) ; Code IENs
N LEXSO,LEXSDO,LEXLEX,LEXSAB S LEXSO=$G(X) Q:'$L(LEXSO) S LEXD=$G(LEXD) I LEXD'?7N D
. N LEXEF,LEXTD S LEXTD="",LEXEF=9999999 F S LEXEF=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF),-1) Q:+LEXEF'>0 D
. . N LEXIE S LEXIE=$O(^LEX(757.02," "),-1) F S LEXIE=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEF,LEXIE),-1) Q:+LEXIE'>0 D
. . . N LEXSR S LEXSR=$P($G(^LEX(757.02,+LEXIE,0)),"^",3) S:"^2^31^"[("^"_LEXSR_"^") LEXTD=LEXEF
. S:LEXTD?7N LEXD=LEXTD
S:LEXD'?7N LEXD=$$DT^XLFDT S LEXSDO=$O(^ICD0("BA",(LEXSO_" "),0)),LEXSAB=+($G(^ICD0(+LEXSDO,1))),LEXSAB=$S(LEXSAB=2:"ICP",1:"10P")
S LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB),LEXLEX=$P(LEXLEX,"^",2)
S LEXSDO=$S(+LEXSDO>0:("ICD Procedure IEN "_+LEXSDO),1:"") S LEXLEX=$S(+LEXLEX>0:("Lexicon IEN "_+LEXLEX),1:"")
S X="" S:$L(LEXSDO)&('$L(LEXLEX)) X=LEXSDO S:'$L(LEXSDO)&($L(LEXLEX)) X=LEXLEX S:$L(LEXSDO)&($L(LEXLEX)) X=(LEXSDO_"/"_LEXLEX)
Q X
BL ; Blank Line
D TL(" ") Q
TL(X) ; Text Line
I $D(LEXTEST) W !,$G(X) Q
N LEXI,LEXTEST S LEXI=+($O(^TMP("LEXQIPO",$J," "),-1))+1 S ^TMP("LEXQIPO",$J,LEXI)=$G(X),^TMP("LEXQIPO",$J,0)=LEXI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQIP3 7023 printed Nov 22, 2024@17:19 Page 2
LEXQIP3 ;ISL/KER - Query - ICD Procedure - Save ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,73,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXQIPO") SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; $$VSEX^ICDEX ICR 5747
+8 ; $$UP^XLFSTR ICR 10104
+9 ;
+10 ; Local Variables NEWed or KILLed Elsewhere
+11 ; LEXCDT Code Set Versioning Date
+12 ; LEXDG DRG Array
+13 ; LEXIEN Internal Entry Number
+14 ; LEXIIEN Include IENs flag
+15 ; LEXLEN Offset Length
+16 ; LEXSO Code
+17 ; LEXNAM Unversioned Name
+18 ; LEXST Status and Effective Dates
+19 ; LEXSD Versioned Short Description
+20 ; LEXLD Versioned Long Description
+21 ; LEXWN Warning
+22 ; LEXMOR Major O.R. Procedure
+23 ; LEXDG MDC/DRG
+24 ; LEXELDT External Last Date
+25 ; LEXLX Lexicon Expressioin
+26 ;
EN ; Main Entry Point
+1 KILL ^TMP("LEXQIPO",$JOB)
if '$LENGTH($GET(LEXELDT))
QUIT
IF +($GET(LEXST))<0
DO FUT
if $DATA(^TMP("LEXQIPO",$JOB))
DO DSP^LEXQO("LEXQIPO")
QUIT
+2 DO FUL
if $DATA(^TMP("LEXQIPO",$JOB))
DO DSP^LEXQO("LEXQIPO")
+3 QUIT
FUT ; Future Activation
+1 NEW LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXSTA
SET LEXI=+($GET(LEXIEN))
if +LEXI'>0
QUIT
+2 SET LEXL=+($GET(LEXLEN))
if +LEXL'>0
QUIT
if LEXL>62
SET LEXL=62
+3 if '$LENGTH(LEXSO)
QUIT
if '$LENGTH(LEXNAM)
QUIT
SET LEXSTA=$GET(LEXST)
+4 SET LEXEFF=$PIECE(LEXSTA,"^",5)
SET LEXSTA=$PIECE(LEXSTA,"^",4)
+5 if '$LENGTH(LEXSTA)
QUIT
if '$LENGTH(LEXEFF)
QUIT
SET (LEX1,LEX2,LEX3)=""
+6 DO BOD(LEXELDT)
DO COD(LEXSO,LEXNAM,$GET(LEXCDT),+($GET(LEXL)))
DO STA(.LEXST,+($GET(LEXL)))
+7 QUIT
BOD(X) ; Based on Date
+1 NEW LEXBOD
SET LEXBOD=$GET(X)
SET X="Display based on date: "_LEXBOD
DO BL
DO TL(X)
+2 QUIT
COD(X,Y,LEXD,LEXLEN) ; Code Line
+1 NEW LEXC,LEXN,LEXT,LEXIEN,LEXNAM
SET LEXC=$GET(X)
SET LEXN=$GET(Y)
SET LEXD=$GET(LEXD)
SET LEXIEN=$$CI(LEXC,LEXD)
+2 SET LEXNAM=$PIECE(LEXN," (IEN ",1)
if $DATA(LEXIIEN)&($LENGTH(LEXIEN))
SET LEXNAM=LEXIEN
+3 SET LEXT="Code: "_LEXC
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXNAM
DO BL
DO TL(LEXT)
+4 QUIT
STA(X,LEXLEN) ; Status Line
+1 NEW LEX,LEXC,LEXX,LEXE,LEXI,LEXN,LEXS,LEXT,LEXW,LEXEFF,LEXSTA
+2 SET LEXX=$GET(X)
SET LEXSTA=$PIECE(LEXX,"^",4)
SET LEXEFF=$PIECE(LEXX,"^",5)
+3 SET LEXEFF=$TRANSLATE(LEXEFF,"()","")
SET LEXW=$PIECE(LEXX,"^",6)
+4 SET LEXT=" Status: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXSTA
+5 SET LEXT=LEXT_$JUSTIFY(" ",(35-$LENGTH(LEXT)))
+6 if LEXEFF'["future"
SET LEXT=LEXT_"Effective: "
+7 SET LEXT=LEXT_$$UP^XLFSTR($EXTRACT(LEXEFF,1))_$EXTRACT(LEXEFF,2,$LENGTH(LEXEFF))
DO BL
DO TL(LEXT)
+8 IF $LENGTH(LEXW)
Begin DoDot:1
+9 NEW LEX,LEXT,LEXC,LEXI,LEXN
SET LEX(1)=LEXW
DO PR^LEXU(.LEX,(LEXLEN-7))
+10 if +($ORDER(LEX(" "),-1))'>0
QUIT
SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
+11 SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+12 NEW LEXN
SET LEXN=$$TM^LEXQM($GET(LEX(LEXI)))
if $LENGTH(LEXN)
SET LEXC=LEXC+1
+13 if LEXC=1
DO BL
DO TL((LEXT_LEXN))
End DoDot:2
End DoDot:1
+14 QUIT
FUL ; Full Display
+1 NEW LEXFUL,LEX,LEXL
SET LEXL=+($GET(LEXLEN))
if LEXL>62
SET LEXL=62
+2 SET LEXFUL=""
DO FUT
+3 DO LIM(+($GET(LEXIEN)),+($GET(LEXL)))
+4 DO SD(.LEXSD,+($GET(LEXL)))
+5 DO LD(.LEXLD,+($GET(LEXL)))
+6 DO LX(.LEXLX,+($GET(LEXL)))
+7 DO WN(.LEXWN,+($GET(LEXL)))
+8 DO MOR(.LEXMOR,+($GET(LEXL)))
+9 DO DRG(.LEXDG,+($GET(LEXL)))
+10 QUIT
LIM(X,LEXLEN) ; Limitations - Sex
+1 NEW LEXC,LEXH,LEXI,LEXS,LEXT
SET LEXC=0
SET LEXI=+($GET(X))
SET LEXS=$$VSEX^ICDEX(80.1,+LEXI,$GET(LEXCDT))
if "^M^F^"'[("^"_LEXS_"^")
QUIT
+2 SET LEXH="Use only with the "
if LEXS="F"
SET LEXH=LEXH_"female sex"
if LEXS="M"
SET LEXH=LEXH_"male sex"
+3 SET LEXT=" Limitations: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXH
+4 DO BL
DO TL(LEXT)
SET LEXC=1
+5 QUIT
SD(X,LEXLEN) ; Short Description
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Short Name: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(X(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+3 QUIT
LD(X,LEXLEN) ; Long Description
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Description: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(X(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+3 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=2
FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+4 QUIT
LX(X,LEXLEN) ; Lexicon Expression
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Lexicon Term:"
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(X(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+3 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=2
FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+4 QUIT
WN(X,LEXLEN) ; Warning
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT,LEXC
if '$DATA(X(1))
QUIT
SET LEXC=0
SET LEXN=$GET(X(1))
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
+2 if $LENGTH($GET(LEXLD(2)))
DO BL
DO TL(LEXT)
+3 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=1
FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+4 QUIT
MOR(X,LEXLEN) ; Major OR Procedure
+1 QUIT
+2 NEW LEXE,LEXH,LEXI,LEXID,LEXN,LEXT
if '$DATA(X(1))
QUIT
if '$DATA(X(1,1))
QUIT
SET LEXID=$GET(X(1))
if '$LENGTH(LEXID)
QUIT
SET LEXN=$GET(X(1,1))
if '$LENGTH(LEXN)
QUIT
+3 SET LEXT=" Major OR Proc"
SET LEXE="Major O.R. Procedure"
SET LEXE=LEXN
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXE
DO BL
DO TL(LEXT)
+4 SET LEXI=1
FOR
SET LEXI=$ORDER(X(1,LEXI))
if +LEXI'>0
QUIT
SET LEXE=$GET(X(1,LEXI))
IF $LENGTH(LEXE)
SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))_LEXE
DO TL(LEXT)
+5 QUIT
DRG(X,LEXLEN) ; Major Diagnostic Category/DRG
+1 QUIT
+2 NEW LEXE,LEXH,LEXI,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
if '$LENGTH(LEXN)
QUIT
SET LEXE=$GET(X(0))
if $LENGTH(LEXE,"/")'=3
SET LEXE=""
+3 SET LEXT=" MDC/DRG:"
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
SET LEXN=$GET(X(2))
+4 SET LEXT=" "_LEXE
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
DO TL((LEXT_LEXN))
SET LEXT=$JUSTIFY(" ",(79-+($GET(LEXLEN))))
SET LEXI=2
+5 FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXN=$GET(X(LEXI))
if $LENGTH(LEXN)
DO TL((LEXT_LEXN))
+6 QUIT
+7 ;
+8 ; Miscellaneous
CI(X,LEXD) ; Code IENs
+1 NEW LEXSO,LEXSDO,LEXLEX,LEXSAB
SET LEXSO=$GET(X)
if '$LENGTH(LEXSO)
QUIT
SET LEXD=$GET(LEXD)
IF LEXD'?7N
Begin DoDot:1
+2 NEW LEXEF,LEXTD
SET LEXTD=""
SET LEXEF=9999999
FOR
SET LEXEF=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF),-1)
if +LEXEF'>0
QUIT
Begin DoDot:2
+3 NEW LEXIE
SET LEXIE=$ORDER(^LEX(757.02," "),-1)
FOR
SET LEXIE=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEF,LEXIE),-1)
if +LEXIE'>0
QUIT
Begin DoDot:3
+4 NEW LEXSR
SET LEXSR=$PIECE($GET(^LEX(757.02,+LEXIE,0)),"^",3)
if "^2^31^"[("^"_LEXSR_"^")
SET LEXTD=LEXEF
End DoDot:3
End DoDot:2
+5 if LEXTD?7N
SET LEXD=LEXTD
End DoDot:1
+6 if LEXD'?7N
SET LEXD=$$DT^XLFDT
SET LEXSDO=$ORDER(^ICD0("BA",(LEXSO_" "),0))
SET LEXSAB=+($GET(^ICD0(+LEXSDO,1)))
SET LEXSAB=$SELECT(LEXSAB=2:"ICP",1:"10P")
+7 SET LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB)
SET LEXLEX=$PIECE(LEXLEX,"^",2)
+8 SET LEXSDO=$SELECT(+LEXSDO>0:("ICD Procedure IEN "_+LEXSDO),1:"")
SET LEXLEX=$SELECT(+LEXLEX>0:("Lexicon IEN "_+LEXLEX),1:"")
+9 SET X=""
if $LENGTH(LEXSDO)&('$LENGTH(LEXLEX))
SET X=LEXSDO
if '$LENGTH(LEXSDO)&($LENGTH(LEXLEX))
SET X=LEXLEX
if $LENGTH(LEXSDO)&($LENGTH(LEXLEX))
SET X=(LEXSDO_"/"_LEXLEX)
+10 QUIT X
BL ; Blank Line
+1 DO TL(" ")
QUIT
TL(X) ; Text Line
+1 IF $DATA(LEXTEST)
WRITE !,$GET(X)
QUIT
+2 NEW LEXI,LEXTEST
SET LEXI=+($ORDER(^TMP("LEXQIPO",$JOB," "),-1))+1
SET ^TMP("LEXQIPO",$JOB,LEXI)=$GET(X)
SET ^TMP("LEXQIPO",$JOB,0)=LEXI
+3 QUIT
