LEX10PR ;ISL/KER - ICD-10 Procedure Code ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX(757.033 N/A
; ^UTILITY($J ICR 10011
;
; External References
; ^DIWP ICR 10011
; $$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(.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(.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(.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(.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
PR(LEX,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,Z,LEXC,LEXI,LEXL
K ^UTILITY($J,"W") Q:'$D(LEX) S LEXL=+($G(X)) S:+LEXL'>0 LEXL=79
S LEXC=+($G(LEX)) S:+($G(LEXC))'>0 LEXC=$O(LEX(" "),-1) Q:+LEXC'>0
S DIWL=1,DIWF="C"_+LEXL S LEXI=0
F S LEXI=$O(LEX(LEXI)) Q:+LEXI=0 S X=$G(LEX(LEXI)) D ^DIWP
K LEX S (LEXC,LEXI)=0
F S LEXI=$O(^UTILITY($J,"W",1,LEXI)) Q:+LEXI=0 D
. S LEX(LEXI)=$$TM($G(^UTILITY($J,"W",1,LEXI,0))," "),LEXC=LEXC+1
S:$L(LEXC) LEX=LEXC K ^UTILITY($J,"W")
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
LEX10PR ;ISL/KER - ICD-10 Procedure Code ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.033 N/A
+5 ; ^UTILITY($J ICR 10011
+6 ;
+7 ; External References
+8 ; ^DIWP ICR 10011
+9 ; $$IMP^ICDEX ICR 5747
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMTE^XLFDT ICR 10103
+12 ;
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(.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(.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(.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(.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
PR(LEX,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,Z,LEXC,LEXI,LEXL
+2 KILL ^UTILITY($JOB,"W")
IF '$DATA(LEX)
QUIT
SET LEXL=+($GET(X))
IF +LEXL'>0
SET LEXL=79
+3 SET LEXC=+($GET(LEX))
IF +($GET(LEXC))'>0
SET LEXC=$ORDER(LEX(" "),-1)
IF +LEXC'>0
QUIT
+4 SET DIWL=1
SET DIWF="C"_+LEXL
SET LEXI=0
+5 FOR
SET LEXI=$ORDER(LEX(LEXI))
IF +LEXI=0
QUIT
SET X=$GET(LEX(LEXI))
DO ^DIWP
+6 KILL LEX
SET (LEXC,LEXI)=0
+7 FOR
SET LEXI=$ORDER(^UTILITY($JOB,"W",1,LEXI))
IF +LEXI=0
QUIT
Begin DoDot:1
+8 SET LEX(LEXI)=$$TM($GET(^UTILITY($JOB,"W",1,LEXI,0))," ")
SET LEXC=LEXC+1
End DoDot:1
+9 IF $LENGTH(LEXC)
SET LEX=LEXC
KILL ^UTILITY($JOB,"W")
+10 QUIT
+11 ;
+12 ; 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
