- 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 Feb 18, 2025@23:34:48 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