LEX10PR ;ISL/KER - ICD-10 Procedure Code ;05/23/2017
;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.033 N/A
;
; External References
; $$IMP^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
;
NEXT(LEXC,LEXA,LEXD) ; Next Allowable Character
;
; Input
;
; LEXC Partial Proc Code Required
; .LEXA Local Array (by Ref) Required
; LEXD Date (FM Format) Optional (Default TODAY)
;
; Output
;
; LEXA(<input>,0)= # of characters
; LEXA(<input>,<character>)=""
;
N LEX1,LEX2,LEXCDT,LEXCHK,LEXCHR,LEXCT,LEXE,LEXLEN,LEXID,LEXNC,LEXNN
N LEXNAM,LEXOR,LEXPRE,LEXS,LEXSO S LEXC=$$TM(LEXC) S (LEXID,LEXSO)=LEXC
S LEXCDT=$G(LEXD) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT S LEXLEN=$L(LEXC)
I LEXLEN>6 D Q X
. S X="-1^Input is of Maximum length, no next character available"
I LEXLEN>1 D
. S LEXOR=$E(LEXSO,1,($L(LEXSO)-1))_$C($A($E(LEXSO,$L(LEXSO)))-1)_"~"
S:LEXLEN=1 LEXOR=$C($A(LEXSO)-1)_"~" S:LEXLEN'>0 LEXOR="/~"
S LEXCHK=0 S:LEXLEN'>0 LEXCHK=1 S:LEXLEN>0&(LEXLEN<7) LEXCHK=LEXLEN+1
Q:+LEXCHK'>0 "-1^Character position not specified"
S:LEXLEN=0 LEXID="<null>" S:'$L(LEXID) LEXID="<unknown>"
S LEXNN="^LEX(757.02,""APR"","""_LEXOR_" "")"
S LEXNC="^LEX(757.02,""APR"","""_LEXSO,LEXCT=0
F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
. N LEXC,LEXD,LEXE,LEXS,LEX1,LEX2
. S LEXC=$P(LEXNN,",",3),LEXC=$TR(LEXC,"""",""),LEXC=$$TM(LEXC)
. S LEXD=+($P(LEXNN,",",4)) Q:LEXD'?7N Q:(LEXCDT+.001)'>LEXD
. I $E(LEXC,1,$L(LEXSO))=LEXSO,$L(LEXC)'<LEXCHK D Q
. . N LEXCHR,LEXFUL S LEXCHR=$E(LEXC,LEXCHK) Q:'$L(LEXCHR)
. . S LEXFUL=LEXID_LEXCHR Q:$$IS(LEXFUL)'>0
. . I '$D(LEXA(LEXID,LEXCHR)) D
. . . N LEXNAM S LEXNAM=$$NAM((LEXID_LEXCHR))
. . . S LEXA(LEXID,LEXCHR)=LEXNAM,LEXCT=LEXCT+1
. . S LEXOR=$E(LEXC,1,LEXCHK)_"~"
. . S LEXNN="^LEX(757.02,""APR"","""_LEXOR_""")"
S LEXNAM=$$NAM(LEXID) S:$L(LEXNAM) LEXA(LEXID)=LEXNAM
I $L(LEXID)>1 D
. F LEX1=($L(LEXID)-1):-1:1 D
. . N LEXNN S LEXNN=$E(LEXID,1,LEX1),LEXNAM=$$NAM(LEXNN)
. . S:$L(LEXNN)&($L(LEXNAM)) LEXA(LEXNN)=LEXNAM
Q +($G(LEXCT))
NAM(X) ; Name
N LEXC,LEXCIEN,LEXEFF,LEXNAM S LEXC=$G(X) Q:'$L(LEXC) ""
S LEXEFF=$O(^LEX(757.033,"AFRAG",31,(LEXC_" "),(LEXCDT+.001)),-1)
S LEXCIEN=$O(^LEX(757.033,"AFRAG",31,(LEXC_" "),LEXEFF," "),-1)
S LEXNAM=$$SN(LEXCIEN) S X=LEXNAM
Q X
SN(X,EFF) ; Short Name
N IEN,CDT,IMP,EFF,HIS S IEN=+($G(X)),CDT=$G(LEXVDT) S:$G(EFF)?7N CDT=$G(EFF)
S IMP=$$IMP^ICDEX(31) S:CDT'?7N CDT=$$DT^XLFDT S:CDT'>IMP&(IMP?7N) CDT=IMP
S EFF=$O(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
S HIS=$O(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
S X=$G(^LEX(757.033,+IEN,2,+HIS,1))
Q X
IS(X) ; Is a Root Code
N LEXC,LEXL,LEXO,LEXN S LEXC=$G(X) Q:'$L(LEXC) 0 S LEXL=$L(LEXC)
S:LEXL>1 LEXO=$E(LEXC,1,($L(LEXC)-1))_$C($A($E(LEXC,$L(LEXC)))-1)_"~"
S:LEXL=1 LEXO=$C($A(LEXC)-1)_"~" S LEXN=$O(^LEX(757.02,"APR",(LEXOR_" ")))
I $E(LEXN,1,LEXL)=LEXC Q 1
Q 0
FIN(X,LEXVDT,ARY) ; Fragment Info
;
; Input
;
; X IEN of Code Fragment
; LEXVDT Versioning date (busines rules apply)
; .ARY Local Array, passed by reference
;
; Output
;
; $$FIN 1 on success
; -1 ^ error message on error
;
; ARY(0) 5 piece "^" delimited strig
; 1 Unique Id
; 2 Code Fragment
; 3 Date Entered
; 4 Source
; 5 Details
;
; ARY(1) 4 piece "^" delimited string
; 1 Effective Date
; 2 Status
; 3 Effective Date External
; 4 Status External
;
; ARY(2) Name/Title
; ARY(3) Description
; ARY(4) Explanation
; ARY(5,0) # of synonyms included
; ARY(5,n) included synonyms
;
N CDT,EFF,ENT,FRG,IEN,IMP,N0,NOD,NODC,NODI,REC,SAB,SRC K ARY
S U="^",IEN=+($G(X)) Q:IEN'>0 "-1^Invalid IEN number"
S N0=$G(^LEX(757.033,IEN,0)) Q:'$L(N0) "-1^IEN not found number"
S SAB=$E(N0,1,3),FRG=$P(N0,U,2),ENT=$P(N0,U,3),SRC=$P(N0,U,4)
S IMP=$$IMPDATE^LEXU(SRC) S CDT=$G(LEXVDT) S:'$L(CDT) CDT=$$DT^XLFDT
S:CDT?7N&(IMP?7N)&(CDT<IMP) CDT=IMP
S EFF=$O(^LEX(757.033,+IEN,1,"B",(CDT+.001)),-1)
S REC=$O(^LEX(757.033,+IEN,1,"B",+EFF," "),-1)
S NOD=$G(^LEX(757.033,IEN,1,+REC,0)) S ARY(0)=N0
S ARY(0,"TXT")="Unique ID^Code Fragment^Date Entered^Source"
S ARY(1)=NOD_"^"_$$FMTE^XLFDT($P(NOD,"^",1),"5Z")_"^"_$S($P(NOD,"^",2)="1":"Active",$P(NOD,"^",2)="0":"Inactive",1:"")
S ARY(1,"TXT")="Effective Date^Status"
S EFF=$O(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
S REC=$O(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
S NOD=$G(^LEX(757.033,IEN,2,+REC,1))
S:$L(NOD) ARY(2)=NOD
S:$L(NOD) ARY(2,"TXT")="Name/Title"
S EFF=$O(^LEX(757.033,+IEN,3,"B",(CDT+.001)),-1)
S REC=$O(^LEX(757.033,+IEN,3,"B",+EFF," "),-1)
S NOD=$G(^LEX(757.033,IEN,3,+REC,1))
S:$L(NOD) ARY(3)=NOD
S:$L(NOD) ARY(3,"TXT")="Description"
S EFF=$O(^LEX(757.033,+IEN,4,"B",(CDT+.001)),-1)
S REC=$O(^LEX(757.033,+IEN,4,"B",+EFF," "),-1)
S NOD=$G(^LEX(757.033,IEN,4,+REC,1))
S:$L(NOD) ARY(4)=NOD
S:$L(NOD) ARY(4,"TXT")="Explanation"
S EFF=$O(^LEX(757.033,+IEN,5,"B",(CDT+.001)),-1)
S REC=$O(^LEX(757.033,+IEN,5,"B",+EFF," "),-1)
S (NODC,NODI)=0 F S NODI=$O(^LEX(757.033,IEN,5,+REC,1,NODI)) Q:+NODI'>0 D
. S NOD=$$TM($G(^LEX(757.033,IEN,5,REC,1,NODI,0))) Q:'$L(NOD)
. S NODC=NODC+1 S ARY(5,0)=NODC,ARY(5,"TXT")="Include",ARY(5,NODC)=NOD
Q 1
INF(X) ;
N FRAG,CDT,IMP,C1,C2,ARY,IEN S C1=15,C2=26 K ARY
S FRAG=$G(X) Q:'$L(FRAG) S CDT=$G(LEXVDT) S:CDT'?7N CDT=$$DT^XLFDT S IMP=$$IMP^ICDEX(31)
S IEN=$O(^LEX(757.033,"B",("10P"_FRAG),0))
S:CDT?7N&(IMP?7N)&(CDT<IMP) CDT=IMP K ARY S X=$$FIN(IEN,CDT,.ARY)
W:$L(FRAG) !," Fragment:",?C1,FRAG
W:$L(FRAG) ?C2,"Character: ",$E(FRAG,$L(FRAG))
S TMP=$G(ARY(1)),EFF=$P(TMP,"^",3),STA=$P(TMP,"^",4)
I $L(EFF),$L(STA) D
. W !," Status:",?C1,STA,?C2,"Effective: ",EFF
S TMP=$G(ARY(2))
I $L(TMP) D
. N TXT,I S TXT(1)=TMP D PR^LEXU(.TXT,(79-C1)) Q:'$L($G(TXT(1)))
. W !!," Title:",?C1,$G(TXT(1))
. S I=1 F S I=$O(TXT(I)) Q:+I'>0 W !,?C1,$G(TXT(I))
S TMP=$G(ARY(3))
I $L(TMP) D
. N TXT,I S TXT(1)=TMP D PR^LEXU(.TXT,(79-C1)) Q:'$L($G(TXT(1)))
. W !!," Definition:",?C1,$G(TXT(1))
. S I=1 F S I=$O(TXT(I)) Q:+I'>0 W !,?C1,$G(TXT(I))
S TMP=$G(ARY(4))
I $L(TMP) D
. N TXT,I S TXT(1)=TMP D PR^LEXU(.TXT,(79-C1)) Q:'$L($G(TXT(1)))
. W !!," Explanation:",?C1,$G(TXT(1))
. S I=1 F S I=$O(TXT(I)) Q:+I'>0 W !,?C1,$G(TXT(I))
N INI,INC S (INI,INC)=0 F S INI=$O(ARY(5,INI)) Q:+INI'>0 D
. N INT S INT(1)=$G(ARY(5,INI)) D PR^LEXU(.INT,(79-C1))
. S:$L($G(INT(1))) INC=INC+1
. W:INC=1 !!," Include(s):" W:INC>1 ! W ?C1,$G(INT(1))
. S I=1 F S I=$O(INT(I)) Q:+I'>0 W !,?C1,$G(INT(I))
Q
; Miscellaneous
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10PR 7191 printed Nov 22, 2024@17:13:44 Page 2
LEX10PR ;ISL/KER - ICD-10 Procedure Code ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.033 N/A
+5 ;
+6 ; External References
+7 ; $$IMP^ICDEX ICR 5747
+8 ; $$DT^XLFDT ICR 10103
+9 ; $$FMTE^XLFDT ICR 10103
+10 ;
NEXT(LEXC,LEXA,LEXD) ; Next Allowable Character
+1 ;
+2 ; Input
+3 ;
+4 ; LEXC Partial Proc Code Required
+5 ; .LEXA Local Array (by Ref) Required
+6 ; LEXD Date (FM Format) Optional (Default TODAY)
+7 ;
+8 ; Output
+9 ;
+10 ; LEXA(<input>,0)= # of characters
+11 ; LEXA(<input>,<character>)=""
+12 ;
+13 NEW LEX1,LEX2,LEXCDT,LEXCHK,LEXCHR,LEXCT,LEXE,LEXLEN,LEXID,LEXNC,LEXNN
+14 NEW LEXNAM,LEXOR,LEXPRE,LEXS,LEXSO
SET LEXC=$$TM(LEXC)
SET (LEXID,LEXSO)=LEXC
+15 SET LEXCDT=$GET(LEXD)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
SET LEXLEN=$LENGTH(LEXC)
+16 IF LEXLEN>6
Begin DoDot:1
+17 SET X="-1^Input is of Maximum length, no next character available"
End DoDot:1
QUIT X
+18 IF LEXLEN>1
Begin DoDot:1
+19 SET LEXOR=$EXTRACT(LEXSO,1,($LENGTH(LEXSO)-1))_$CHAR($ASCII($EXTRACT(LEXSO,$LENGTH(LEXSO)))-1)_"~"
End DoDot:1
+20 if LEXLEN=1
SET LEXOR=$CHAR($ASCII(LEXSO)-1)_"~"
if LEXLEN'>0
SET LEXOR="/~"
+21 SET LEXCHK=0
if LEXLEN'>0
SET LEXCHK=1
if LEXLEN>0&(LEXLEN<7)
SET LEXCHK=LEXLEN+1
+22 if +LEXCHK'>0
QUIT "-1^Character position not specified"
+23 if LEXLEN=0
SET LEXID="<null>"
if '$LENGTH(LEXID)
SET LEXID="<unknown>"
+24 SET LEXNN="^LEX(757.02,""APR"","""_LEXOR_" "")"
+25 SET LEXNC="^LEX(757.02,""APR"","""_LEXSO
SET LEXCT=0
+26 FOR
SET LEXNN=$QUERY(@LEXNN)
if '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
Begin DoDot:1
+27 NEW LEXC,LEXD,LEXE,LEXS,LEX1,LEX2
+28 SET LEXC=$PIECE(LEXNN,",",3)
SET LEXC=$TRANSLATE(LEXC,"""","")
SET LEXC=$$TM(LEXC)
+29 SET LEXD=+($PIECE(LEXNN,",",4))
if LEXD'?7N
QUIT
if (LEXCDT+.001)'>LEXD
QUIT
+30 IF $EXTRACT(LEXC,1,$LENGTH(LEXSO))=LEXSO
IF $LENGTH(LEXC)'<LEXCHK
Begin DoDot:2
+31 NEW LEXCHR,LEXFUL
SET LEXCHR=$EXTRACT(LEXC,LEXCHK)
if '$LENGTH(LEXCHR)
QUIT
+32 SET LEXFUL=LEXID_LEXCHR
if $$IS(LEXFUL)'>0
QUIT
+33 IF '$DATA(LEXA(LEXID,LEXCHR))
Begin DoDot:3
+34 NEW LEXNAM
SET LEXNAM=$$NAM((LEXID_LEXCHR))
+35 SET LEXA(LEXID,LEXCHR)=LEXNAM
SET LEXCT=LEXCT+1
End DoDot:3
+36 SET LEXOR=$EXTRACT(LEXC,1,LEXCHK)_"~"
+37 SET LEXNN="^LEX(757.02,""APR"","""_LEXOR_""")"
End DoDot:2
QUIT
End DoDot:1
+38 SET LEXNAM=$$NAM(LEXID)
if $LENGTH(LEXNAM)
SET LEXA(LEXID)=LEXNAM
+39 IF $LENGTH(LEXID)>1
Begin DoDot:1
+40 FOR LEX1=($LENGTH(LEXID)-1):-1:1
Begin DoDot:2
+41 NEW LEXNN
SET LEXNN=$EXTRACT(LEXID,1,LEX1)
SET LEXNAM=$$NAM(LEXNN)
+42 if $LENGTH(LEXNN)&($LENGTH(LEXNAM))
SET LEXA(LEXNN)=LEXNAM
End DoDot:2
End DoDot:1
+43 QUIT +($GET(LEXCT))
NAM(X) ; Name
+1 NEW LEXC,LEXCIEN,LEXEFF,LEXNAM
SET LEXC=$GET(X)
if '$LENGTH(LEXC)
QUIT ""
+2 SET LEXEFF=$ORDER(^LEX(757.033,"AFRAG",31,(LEXC_" "),(LEXCDT+.001)),-1)
+3 SET LEXCIEN=$ORDER(^LEX(757.033,"AFRAG",31,(LEXC_" "),LEXEFF," "),-1)
+4 SET LEXNAM=$$SN(LEXCIEN)
SET X=LEXNAM
+5 QUIT X
SN(X,EFF) ; Short Name
+1 NEW IEN,CDT,IMP,EFF,HIS
SET IEN=+($GET(X))
SET CDT=$GET(LEXVDT)
if $GET(EFF)?7N
SET CDT=$GET(EFF)
+2 SET IMP=$$IMP^ICDEX(31)
if CDT'?7N
SET CDT=$$DT^XLFDT
if CDT'>IMP&(IMP?7N)
SET CDT=IMP
+3 SET EFF=$ORDER(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
+4 SET HIS=$ORDER(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
+5 SET X=$GET(^LEX(757.033,+IEN,2,+HIS,1))
+6 QUIT X
IS(X) ; Is a Root Code
+1 NEW LEXC,LEXL,LEXO,LEXN
SET LEXC=$GET(X)
if '$LENGTH(LEXC)
QUIT 0
SET LEXL=$LENGTH(LEXC)
+2 if LEXL>1
SET LEXO=$EXTRACT(LEXC,1,($LENGTH(LEXC)-1))_$CHAR($ASCII($EXTRACT(LEXC,$LENGTH(LEXC)))-1)_"~"
+3 if LEXL=1
SET LEXO=$CHAR($ASCII(LEXC)-1)_"~"
SET LEXN=$ORDER(^LEX(757.02,"APR",(LEXOR_" ")))
+4 IF $EXTRACT(LEXN,1,LEXL)=LEXC
QUIT 1
+5 QUIT 0
FIN(X,LEXVDT,ARY) ; Fragment Info
+1 ;
+2 ; Input
+3 ;
+4 ; X IEN of Code Fragment
+5 ; LEXVDT Versioning date (busines rules apply)
+6 ; .ARY Local Array, passed by reference
+7 ;
+8 ; Output
+9 ;
+10 ; $$FIN 1 on success
+11 ; -1 ^ error message on error
+12 ;
+13 ; ARY(0) 5 piece "^" delimited strig
+14 ; 1 Unique Id
+15 ; 2 Code Fragment
+16 ; 3 Date Entered
+17 ; 4 Source
+18 ; 5 Details
+19 ;
+20 ; ARY(1) 4 piece "^" delimited string
+21 ; 1 Effective Date
+22 ; 2 Status
+23 ; 3 Effective Date External
+24 ; 4 Status External
+25 ;
+26 ; ARY(2) Name/Title
+27 ; ARY(3) Description
+28 ; ARY(4) Explanation
+29 ; ARY(5,0) # of synonyms included
+30 ; ARY(5,n) included synonyms
+31 ;
+32 NEW CDT,EFF,ENT,FRG,IEN,IMP,N0,NOD,NODC,NODI,REC,SAB,SRC
KILL ARY
+33 SET U="^"
SET IEN=+($GET(X))
if IEN'>0
QUIT "-1^Invalid IEN number"
+34 SET N0=$GET(^LEX(757.033,IEN,0))
if '$LENGTH(N0)
QUIT "-1^IEN not found number"
+35 SET SAB=$EXTRACT(N0,1,3)
SET FRG=$PIECE(N0,U,2)
SET ENT=$PIECE(N0,U,3)
SET SRC=$PIECE(N0,U,4)
+36 SET IMP=$$IMPDATE^LEXU(SRC)
SET CDT=$GET(LEXVDT)
if '$LENGTH(CDT)
SET CDT=$$DT^XLFDT
+37 if CDT?7N&(IMP?7N)&(CDT<IMP)
SET CDT=IMP
+38 SET EFF=$ORDER(^LEX(757.033,+IEN,1,"B",(CDT+.001)),-1)
+39 SET REC=$ORDER(^LEX(757.033,+IEN,1,"B",+EFF," "),-1)
+40 SET NOD=$GET(^LEX(757.033,IEN,1,+REC,0))
SET ARY(0)=N0
+41 SET ARY(0,"TXT")="Unique ID^Code Fragment^Date Entered^Source"
+42 SET ARY(1)=NOD_"^"_$$FMTE^XLFDT($PIECE(NOD,"^",1),"5Z")_"^"_$SELECT($PIECE(NOD,"^",2)="1":"Active",$PIECE(NOD,"^",2)="0":"Inactive",1:"")
+43 SET ARY(1,"TXT")="Effective Date^Status"
+44 SET EFF=$ORDER(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
+45 SET REC=$ORDER(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
+46 SET NOD=$GET(^LEX(757.033,IEN,2,+REC,1))
+47 if $LENGTH(NOD)
SET ARY(2)=NOD
+48 if $LENGTH(NOD)
SET ARY(2,"TXT")="Name/Title"
+49 SET EFF=$ORDER(^LEX(757.033,+IEN,3,"B",(CDT+.001)),-1)
+50 SET REC=$ORDER(^LEX(757.033,+IEN,3,"B",+EFF," "),-1)
+51 SET NOD=$GET(^LEX(757.033,IEN,3,+REC,1))
+52 if $LENGTH(NOD)
SET ARY(3)=NOD
+53 if $LENGTH(NOD)
SET ARY(3,"TXT")="Description"
+54 SET EFF=$ORDER(^LEX(757.033,+IEN,4,"B",(CDT+.001)),-1)
+55 SET REC=$ORDER(^LEX(757.033,+IEN,4,"B",+EFF," "),-1)
+56 SET NOD=$GET(^LEX(757.033,IEN,4,+REC,1))
+57 if $LENGTH(NOD)
SET ARY(4)=NOD
+58 if $LENGTH(NOD)
SET ARY(4,"TXT")="Explanation"
+59 SET EFF=$ORDER(^LEX(757.033,+IEN,5,"B",(CDT+.001)),-1)
+60 SET REC=$ORDER(^LEX(757.033,+IEN,5,"B",+EFF," "),-1)
+61 SET (NODC,NODI)=0
FOR
SET NODI=$ORDER(^LEX(757.033,IEN,5,+REC,1,NODI))
if +NODI'>0
QUIT
Begin DoDot:1
+62 SET NOD=$$TM($GET(^LEX(757.033,IEN,5,REC,1,NODI,0)))
if '$LENGTH(NOD)
QUIT
+63 SET NODC=NODC+1
SET ARY(5,0)=NODC
SET ARY(5,"TXT")="Include"
SET ARY(5,NODC)=NOD
End DoDot:1
+64 QUIT 1
INF(X) ;
+1 NEW FRAG,CDT,IMP,C1,C2,ARY,IEN
SET C1=15
SET C2=26
KILL ARY
+2 SET FRAG=$GET(X)
if '$LENGTH(FRAG)
QUIT
SET CDT=$GET(LEXVDT)
if CDT'?7N
SET CDT=$$DT^XLFDT
SET IMP=$$IMP^ICDEX(31)
+3 SET IEN=$ORDER(^LEX(757.033,"B",("10P"_FRAG),0))
+4 if CDT?7N&(IMP?7N)&(CDT<IMP)
SET CDT=IMP
KILL ARY
SET X=$$FIN(IEN,CDT,.ARY)
+5 if $LENGTH(FRAG)
WRITE !," Fragment:",?C1,FRAG
+6 if $LENGTH(FRAG)
WRITE ?C2,"Character: ",$EXTRACT(FRAG,$LENGTH(FRAG))
+7 SET TMP=$GET(ARY(1))
SET EFF=$PIECE(TMP,"^",3)
SET STA=$PIECE(TMP,"^",4)
+8 IF $LENGTH(EFF)
IF $LENGTH(STA)
Begin DoDot:1
+9 WRITE !," Status:",?C1,STA,?C2,"Effective: ",EFF
End DoDot:1
+10 SET TMP=$GET(ARY(2))
+11 IF $LENGTH(TMP)
Begin DoDot:1
+12 NEW TXT,I
SET TXT(1)=TMP
DO PR^LEXU(.TXT,(79-C1))
if '$LENGTH($GET(TXT(1)))
QUIT
+13 WRITE !!," Title:",?C1,$GET(TXT(1))
+14 SET I=1
FOR
SET I=$ORDER(TXT(I))
if +I'>0
QUIT
WRITE !,?C1,$GET(TXT(I))
End DoDot:1
+15 SET TMP=$GET(ARY(3))
+16 IF $LENGTH(TMP)
Begin DoDot:1
+17 NEW TXT,I
SET TXT(1)=TMP
DO PR^LEXU(.TXT,(79-C1))
if '$LENGTH($GET(TXT(1)))
QUIT
+18 WRITE !!," Definition:",?C1,$GET(TXT(1))
+19 SET I=1
FOR
SET I=$ORDER(TXT(I))
if +I'>0
QUIT
WRITE !,?C1,$GET(TXT(I))
End DoDot:1
+20 SET TMP=$GET(ARY(4))
+21 IF $LENGTH(TMP)
Begin DoDot:1
+22 NEW TXT,I
SET TXT(1)=TMP
DO PR^LEXU(.TXT,(79-C1))
if '$LENGTH($GET(TXT(1)))
QUIT
+23 WRITE !!," Explanation:",?C1,$GET(TXT(1))
+24 SET I=1
FOR
SET I=$ORDER(TXT(I))
if +I'>0
QUIT
WRITE !,?C1,$GET(TXT(I))
End DoDot:1
+25 NEW INI,INC
SET (INI,INC)=0
FOR
SET INI=$ORDER(ARY(5,INI))
if +INI'>0
QUIT
Begin DoDot:1
+26 NEW INT
SET INT(1)=$GET(ARY(5,INI))
DO PR^LEXU(.INT,(79-C1))
+27 if $LENGTH($GET(INT(1)))
SET INC=INC+1
+28 if INC=1
WRITE !!," Include(s):"
if INC>1
WRITE !
WRITE ?C1,$GET(INT(1))
+29 SET I=1
FOR
SET I=$ORDER(INT(I))
if +I'>0
QUIT
WRITE !,?C1,$GET(INT(I))
End DoDot:1
+30 QUIT
+31 ; Miscellaneous
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
