LEXQHL5 ;ISL/KER - Query History - Lexicon ICD/CPT Extract ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXQHL") SACC 2.3.2.5.1
;
; External References
; None
;
Q
CP(X) ; 4 Lexicon CPT
N LEX,LEXC,LEXCT,LEXD,LEXE,LEXEIEN,LEXLEX,LEXH,LEXI,LEXN,LEXS,LEXSAB,LEXSIEN,LEXSO,LEXT,LEXX S LEXSO=$G(X),(LEXCT,LEXSIEN)=0
F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXN,LEXEIEN,LEXSAB,LEXLEX,LEXH,LEXD,LEXE S LEXN=$G(^LEX(757.02,+LEXSIEN,0)),LEXEIEN=+LEXN,LEXSAB=$P(LEXN,U,3) Q:"^3^4^"'[("^"_+LEXSAB_"^")
. Q:+$P(LEXN,U,5)'>0 S LEXLEX=$P($G(^LEX(757.01,+LEXEIEN,0)),U,1),LEXH=0 F S LEXH=$O(^LEX(757.02,+LEXSIEN,4,LEXH)) Q:+LEXH'>0 D
. . N LEXN S LEXN=$G(^LEX(757.02,+LEXSIEN,4,LEXH,0)) Q:+($P(LEXN,U,2))'>0
. . S LEXE=$P(LEXN,U,1) Q:LEXE'?7N S LEXD=$$SD^LEXQHLM(LEXE),LEXX(LEXE)=LEXD_U_LEXLEX
S LEXCT=0,LEXE="" F S LEXE=$O(LEXX(LEXE)) Q:'$L(LEXE) D
. N LEXN,LEXD,LEXT,LEXS,LEX S LEXN=$G(LEXX(LEXE)),LEXD=$P(LEXN,U,1),LEXT=$P(LEXN,U,2) Q:'$L(LEXD) Q:'$L(LEXT)
. S LEX(1)=LEXT D PR^LEXU(.LEX,63) Q:'$L($G(LEX(1))) S LEXCT=LEXCT+1
. S LEXS=$S(+LEXCT=1:"Initial Lexicon Expression",+LEXCT>1:"Updated Lexicon Expression",1:"Lexicon Expression")
. S:$O(LEXX(LEXE))=""&(LEXCT>1) LEXS=LEXS_" (final change)"
. S ^TMP("LEXQHL",$J,LEXE,4,1)=LEXD_U_LEXS
. S LEXI=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D
. . N LEXC S LEXT=$G(LEX(LEXI)) Q:'$L(LEXT) S LEXC=$O(^TMP("LEXQHL",$J,LEXE,4," "),-1)+1 S ^TMP("LEXQHL",$J,LEXE,4,LEXC)=U_LEXT
Q
ID(X) ; 4 Lexicon ICD
N LEX,LEXC,LEXCT,LEXD,LEXE,LEXEIEN,LEXLEX,LEXH,LEXI,LEXN,LEXS,LEXSAB,LEXSIEN,LEXSO,LEXT,LEXX S LEXSO=$G(X),(LEXCT,LEXSIEN)=0
F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXN,LEXEIEN,LEXSAB,LEXLEX,LEXH,LEXD,LEXE S LEXN=$G(^LEX(757.02,+LEXSIEN,0)),LEXEIEN=+LEXN,LEXSAB=$P(LEXN,U,3) Q:"^1^"'[("^"_+LEXSAB_"^")
. Q:+$P(LEXN,U,5)'>0 S LEXLEX=$P($G(^LEX(757.01,+LEXEIEN,0)),U,1),LEXH=0 F S LEXH=$O(^LEX(757.02,+LEXSIEN,4,LEXH)) Q:+LEXH'>0 D
. . N LEXN S LEXN=$G(^LEX(757.02,+LEXSIEN,4,LEXH,0)) Q:+($P(LEXN,U,2))'>0
. . S LEXE=$P(LEXN,U,1) Q:LEXE'?7N S LEXD=$$SD^LEXQHLM(LEXE),LEXX(LEXE)=LEXD_U_LEXLEX
S LEXCT=0,LEXE="" F S LEXE=$O(LEXX(LEXE)) Q:'$L(LEXE) D
. N LEXN,LEXD,LEXT,LEXS,LEX S LEXN=$G(LEXX(LEXE)),LEXD=$P(LEXN,U,1),LEXT=$P(LEXN,U,2) Q:'$L(LEXD) Q:'$L(LEXT)
. S LEX(1)=LEXT D PR^LEXU(.LEX,63) Q:'$L($G(LEX(1))) S LEXCT=LEXCT+1
. S LEXS=$S(+LEXCT=1:"Initial Lexicon Expression",+LEXCT>1:"Updated Lexicon Expression",1:"Lexicon Expression")
. S:$O(LEXX(LEXE))=""&(LEXCT>1) LEXS=LEXS_" (final change)"
. S ^TMP("LEXQHL",$J,LEXE,4,1)=LEXD_U_LEXS
. S LEXI=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D
. . N LEXC S LEXT=$G(LEX(LEXI)) Q:'$L(LEXT) S LEXC=$O(^TMP("LEXQHL",$J,LEXE,4," "),-1)+1 S ^TMP("LEXQHL",$J,LEXE,4,LEXC)=U_LEXT
Q
IX(X,Y) ; 4 Lexicon ICD 10
N LEX,LEXC,LEXCT,LEXD,LEXE,LEXEIEN,LEXLEX,LEXH,LEXI,LEXN,LEXS,LEXSR,LEXSAB,LEXSIEN,LEXSO,LEXT,LEXX S LEXSO=$G(X),(LEXCT,LEXSIEN)=0
S LEXSR=$G(Y) S:'$L(LEXSR) LEXSR="30^31" S LEXSR="^"_LEXSR_"^" F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXN,LEXEIEN,LEXSAB,LEXLEX,LEXH,LEXD,LEXE S LEXN=$G(^LEX(757.02,+LEXSIEN,0)),LEXEIEN=+LEXN,LEXSAB=$P(LEXN,U,3)
. Q:LEXSR'[("^"_+LEXSAB_"^")
. Q:+$P(LEXN,U,5)'>0 S LEXLEX=$P($G(^LEX(757.01,+LEXEIEN,0)),U,1),LEXH=0 F S LEXH=$O(^LEX(757.02,+LEXSIEN,4,LEXH)) Q:+LEXH'>0 D
. . N LEXN S LEXN=$G(^LEX(757.02,+LEXSIEN,4,LEXH,0)) Q:+($P(LEXN,U,2))'>0
. . S LEXE=$P(LEXN,U,1) Q:LEXE'?7N S LEXD=$$SD^LEXQHLM(LEXE),LEXX(LEXE)=LEXD_U_LEXLEX
S LEXCT=0,LEXE="" F S LEXE=$O(LEXX(LEXE)) Q:'$L(LEXE) D
. N LEXN,LEXD,LEXT,LEXS,LEX S LEXN=$G(LEXX(LEXE)),LEXD=$P(LEXN,U,1),LEXT=$P(LEXN,U,2) Q:'$L(LEXD) Q:'$L(LEXT)
. S LEX(1)=LEXT D PR^LEXU(.LEX,63) Q:'$L($G(LEX(1))) S LEXCT=LEXCT+1
. S LEXS=$S(+LEXCT=1:"Initial Lexicon Expression",+LEXCT>1:"Updated Lexicon Expression",1:"Lexicon Expression")
. S:$O(LEXX(LEXE))=""&(LEXCT>1) LEXS=LEXS_" (final change)"
. S ^TMP("LEXQHL",$J,LEXE,4,1)=LEXD_U_LEXS
. S LEXI=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D
. . N LEXC S LEXT=$G(LEX(LEXI)) Q:'$L(LEXT) S LEXC=$O(^TMP("LEXQHL",$J,LEXE,4," "),-1)+1 S ^TMP("LEXQHL",$J,LEXE,4,LEXC)=U_LEXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQHL5 4346 printed Sep 23, 2025@19:44:37 Page 2
LEXQHL5 ;ISL/KER - Query History - Lexicon ICD/CPT Extract ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXQHL") SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; None
+8 ;
+9 QUIT
CP(X) ; 4 Lexicon CPT
+1 NEW LEX,LEXC,LEXCT,LEXD,LEXE,LEXEIEN,LEXLEX,LEXH,LEXI,LEXN,LEXS,LEXSAB,LEXSIEN,LEXSO,LEXT,LEXX
SET LEXSO=$GET(X)
SET (LEXCT,LEXSIEN)=0
+2 FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+3 NEW LEXN,LEXEIEN,LEXSAB,LEXLEX,LEXH,LEXD,LEXE
SET LEXN=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXEIEN=+LEXN
SET LEXSAB=$PIECE(LEXN,U,3)
if "^3^4^"'[("^"_+LEXSAB_"^")
QUIT
+4 if +$PIECE(LEXN,U,5)'>0
QUIT
SET LEXLEX=$PIECE($GET(^LEX(757.01,+LEXEIEN,0)),U,1)
SET LEXH=0
FOR
SET LEXH=$ORDER(^LEX(757.02,+LEXSIEN,4,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+5 NEW LEXN
SET LEXN=$GET(^LEX(757.02,+LEXSIEN,4,LEXH,0))
if +($PIECE(LEXN,U,2))'>0
QUIT
+6 SET LEXE=$PIECE(LEXN,U,1)
if LEXE'?7N
QUIT
SET LEXD=$$SD^LEXQHLM(LEXE)
SET LEXX(LEXE)=LEXD_U_LEXLEX
End DoDot:2
End DoDot:1
+7 SET LEXCT=0
SET LEXE=""
FOR
SET LEXE=$ORDER(LEXX(LEXE))
if '$LENGTH(LEXE)
QUIT
Begin DoDot:1
+8 NEW LEXN,LEXD,LEXT,LEXS,LEX
SET LEXN=$GET(LEXX(LEXE))
SET LEXD=$PIECE(LEXN,U,1)
SET LEXT=$PIECE(LEXN,U,2)
if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXT)
QUIT
+9 SET LEX(1)=LEXT
DO PR^LEXU(.LEX,63)
if '$LENGTH($GET(LEX(1)))
QUIT
SET LEXCT=LEXCT+1
+10 SET LEXS=$SELECT(+LEXCT=1:"Initial Lexicon Expression",+LEXCT>1:"Updated Lexicon Expression",1:"Lexicon Expression")
+11 if $ORDER(LEXX(LEXE))=""&(LEXCT>1)
SET LEXS=LEXS_" (final change)"
+12 SET ^TMP("LEXQHL",$JOB,LEXE,4,1)=LEXD_U_LEXS
+13 SET LEXI=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+14 NEW LEXC
SET LEXT=$GET(LEX(LEXI))
if '$LENGTH(LEXT)
QUIT
SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXE,4," "),-1)+1
SET ^TMP("LEXQHL",$JOB,LEXE,4,LEXC)=U_LEXT
End DoDot:2
End DoDot:1
+15 QUIT
ID(X) ; 4 Lexicon ICD
+1 NEW LEX,LEXC,LEXCT,LEXD,LEXE,LEXEIEN,LEXLEX,LEXH,LEXI,LEXN,LEXS,LEXSAB,LEXSIEN,LEXSO,LEXT,LEXX
SET LEXSO=$GET(X)
SET (LEXCT,LEXSIEN)=0
+2 FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+3 NEW LEXN,LEXEIEN,LEXSAB,LEXLEX,LEXH,LEXD,LEXE
SET LEXN=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXEIEN=+LEXN
SET LEXSAB=$PIECE(LEXN,U,3)
if "^1^"'[("^"_+LEXSAB_"^")
QUIT
+4 if +$PIECE(LEXN,U,5)'>0
QUIT
SET LEXLEX=$PIECE($GET(^LEX(757.01,+LEXEIEN,0)),U,1)
SET LEXH=0
FOR
SET LEXH=$ORDER(^LEX(757.02,+LEXSIEN,4,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+5 NEW LEXN
SET LEXN=$GET(^LEX(757.02,+LEXSIEN,4,LEXH,0))
if +($PIECE(LEXN,U,2))'>0
QUIT
+6 SET LEXE=$PIECE(LEXN,U,1)
if LEXE'?7N
QUIT
SET LEXD=$$SD^LEXQHLM(LEXE)
SET LEXX(LEXE)=LEXD_U_LEXLEX
End DoDot:2
End DoDot:1
+7 SET LEXCT=0
SET LEXE=""
FOR
SET LEXE=$ORDER(LEXX(LEXE))
if '$LENGTH(LEXE)
QUIT
Begin DoDot:1
+8 NEW LEXN,LEXD,LEXT,LEXS,LEX
SET LEXN=$GET(LEXX(LEXE))
SET LEXD=$PIECE(LEXN,U,1)
SET LEXT=$PIECE(LEXN,U,2)
if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXT)
QUIT
+9 SET LEX(1)=LEXT
DO PR^LEXU(.LEX,63)
if '$LENGTH($GET(LEX(1)))
QUIT
SET LEXCT=LEXCT+1
+10 SET LEXS=$SELECT(+LEXCT=1:"Initial Lexicon Expression",+LEXCT>1:"Updated Lexicon Expression",1:"Lexicon Expression")
+11 if $ORDER(LEXX(LEXE))=""&(LEXCT>1)
SET LEXS=LEXS_" (final change)"
+12 SET ^TMP("LEXQHL",$JOB,LEXE,4,1)=LEXD_U_LEXS
+13 SET LEXI=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+14 NEW LEXC
SET LEXT=$GET(LEX(LEXI))
if '$LENGTH(LEXT)
QUIT
SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXE,4," "),-1)+1
SET ^TMP("LEXQHL",$JOB,LEXE,4,LEXC)=U_LEXT
End DoDot:2
End DoDot:1
+15 QUIT
IX(X,Y) ; 4 Lexicon ICD 10
+1 NEW LEX,LEXC,LEXCT,LEXD,LEXE,LEXEIEN,LEXLEX,LEXH,LEXI,LEXN,LEXS,LEXSR,LEXSAB,LEXSIEN,LEXSO,LEXT,LEXX
SET LEXSO=$GET(X)
SET (LEXCT,LEXSIEN)=0
+2 SET LEXSR=$GET(Y)
if '$LENGTH(LEXSR)
SET LEXSR="30^31"
SET LEXSR="^"_LEXSR_"^"
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+3 NEW LEXN,LEXEIEN,LEXSAB,LEXLEX,LEXH,LEXD,LEXE
SET LEXN=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXEIEN=+LEXN
SET LEXSAB=$PIECE(LEXN,U,3)
+4 if LEXSR'[("^"_+LEXSAB_"^")
QUIT
+5 if +$PIECE(LEXN,U,5)'>0
QUIT
SET LEXLEX=$PIECE($GET(^LEX(757.01,+LEXEIEN,0)),U,1)
SET LEXH=0
FOR
SET LEXH=$ORDER(^LEX(757.02,+LEXSIEN,4,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+6 NEW LEXN
SET LEXN=$GET(^LEX(757.02,+LEXSIEN,4,LEXH,0))
if +($PIECE(LEXN,U,2))'>0
QUIT
+7 SET LEXE=$PIECE(LEXN,U,1)
if LEXE'?7N
QUIT
SET LEXD=$$SD^LEXQHLM(LEXE)
SET LEXX(LEXE)=LEXD_U_LEXLEX
End DoDot:2
End DoDot:1
+8 SET LEXCT=0
SET LEXE=""
FOR
SET LEXE=$ORDER(LEXX(LEXE))
if '$LENGTH(LEXE)
QUIT
Begin DoDot:1
+9 NEW LEXN,LEXD,LEXT,LEXS,LEX
SET LEXN=$GET(LEXX(LEXE))
SET LEXD=$PIECE(LEXN,U,1)
SET LEXT=$PIECE(LEXN,U,2)
if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXT)
QUIT
+10 SET LEX(1)=LEXT
DO PR^LEXU(.LEX,63)
if '$LENGTH($GET(LEX(1)))
QUIT
SET LEXCT=LEXCT+1
+11 SET LEXS=$SELECT(+LEXCT=1:"Initial Lexicon Expression",+LEXCT>1:"Updated Lexicon Expression",1:"Lexicon Expression")
+12 if $ORDER(LEXX(LEXE))=""&(LEXCT>1)
SET LEXS=LEXS_" (final change)"
+13 SET ^TMP("LEXQHL",$JOB,LEXE,4,1)=LEXD_U_LEXS
+14 SET LEXI=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+15 NEW LEXC
SET LEXT=$GET(LEX(LEXI))
if '$LENGTH(LEXT)
QUIT
SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXE,4," "),-1)+1
SET ^TMP("LEXQHL",$JOB,LEXE,4,LEXC)=U_LEXT
End DoDot:2
End DoDot:1
+16 QUIT
