LEXQL4 ;ISL/KER - Query - Lookup Code (CPT/MOD) ;05/23/2017
;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^DIC(81.3) ICR 4492
; ^ICPT( ICR 4489
; ^ICPT("BA") ICR 4489
; ^TMP("LEXQL") SACC 2.3.2.5.1
;
; External References
; $$CPTD^ICPTCOD ICR 1995
; $$CPT^ICPTCOD ICR 1995
; $$MOD^ICPTMOD ICR 1996
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXVDT Version Date - default TODAY
; LEXTT Text String
; LEXTO $Order Text Variable
; LEXCT Code String
; LEXCO $Order Text Variable
; LEXTD TODAY's Date
; LEXTKNS Local Array of Tolkens
; LEXTTK Total # Tolkens
;
Q
CP ; $$CPT^ICPTCOD(CODE,DATE)
;
; 1 IEN of code in ^ICPT 1-6
; 2 CPT Code (.01) 5
; 3 Versioned Short Name (#61) 1-28
; 6 Effective Date (#60) 10 (external)
; 7 Status (#60) 6-8 (external)
; 8 Inactivation Date (#60) 10 (external)
; 9 Activation Date (#60) 10 (external)
;
Q:'$L($G(LEXTT)) Q:'$L($G(LEXTO)) Q:'$L($G(LEXCT)) Q:'$L($G(LEXCO))
S LEXCT=$$VI(LEXCT)
S LEXCO=$E(LEXCT,1,($L(LEXCT)-1))_$C(($A($E(LEXCT,$L(LEXCT)))-1))_"~"
N LEXNUM D PUR N LEXIX F LEXIX="BA","C" D
. N LEXO,LEXOC Q:LEXIX="C"&(LEXTT?1N.NP)
. S LEXO=$S(LEXIX="BA":($G(LEXCO)_" "),1:$G(LEXTO)) Q:'$L(LEXO)
. S LEXOC=$S(LEXIX="BA":$G(LEXCT),1:$G(LEXTT)) Q:'$L(LEXOC)
. F S LEXO=$O(^ICPT(LEXIX,LEXO)) Q:'$L(LEXO) Q:$E(LEXO,1,$L(LEXOC))'=LEXOC D
. . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^ICPT(LEXIX,LEXO,LEXIEN)) Q:+LEXIEN'>0 D
. . . N LEXOK S LEXOK=1 S:$O(LEXTKNS(0))>0&($G(LEXIX)="C") LEXOK=0
. . . I $G(LEXIX)="C"&($O(LEXTKNS(0))>0) D
. . . . N LEXN,LEXT,LEXC S (LEXC,LEXN)=0 F S LEXN=$O(LEXTKNS(LEXN)) Q:+LEXN'>0 D
. . . . . S LEXT="" F S LEXT=$O(LEXTKNS(LEXN,LEXT)) Q:'$L(LEXT) D
. . . . . . N LEXOT,LEXKT,LEXF S LEXF=0,LEXOT=$E(LEXT,1,($L(LEXT)-1))_$C(($A($E(LEXT,$L(LEXT)))-1))_"~"
. . . . . . F S LEXOT=$O(^ICPT(LEXIX,LEXOT)) Q:'$L(LEXOT) Q:$E(LEXOT,1,$L(LEXT))'=LEXT D
. . . . . . . S:$D(^ICPT(LEXIX,LEXOT,LEXIEN)) LEXF=1
. . . . . . S:LEXF LEXC=LEXC+1
. . . . S:+LEXC>0&(+LEXC=+($G(LEXTTK))) LEXOK=1
. . . I $G(LEXIX)="C"&($O(LEXNUM(0))>0) D
. . . . N LEXD,LEXC,LEXF,LEXN,LEXO S LEXO=$$CPTD^ICPTCOD(+LEXIEN,"LEXD") S (LEXC,LEXF,LEXN)=0
. . . . F S LEXN=$O(LEXNUM(LEXN)) Q:+LEXN'>0 D
. . . . . S LEXC=LEXC+1
. . . . . N LEXI S LEXI=0 F S LEXI=$O(LEXD(LEXI)) Q:+LEXI'>0 D
. . . . . . N LEXT S LEXT=$G(LEXD(LEXI)) S:LEXT[LEXN LEXF=LEXF+1
. . . . I LEXC>0&(LEXC'=LEXF) S LEXOK=0
. . . Q:'LEXOK N LEXT,LEXD,LEXC,LEXD,LEXN,LEXS,LEXE,LEXDS,LEXTN,LEXTS,LEXSS,LEXDT
. . . S LEXC=$P($G(^ICPT(+LEXIEN,0)),U,1) Q:'$L(LEXC) S LEXD=$G(LEXVDT) S:LEXD'?7N LEXD=$G(LEXTD) S LEXT=$$CPT^ICPTCOD(LEXC,LEXD)
. . . S LEXC=$P(LEXT,U,2),LEXN=$$UP^XLFSTR($P(LEXT,U,3)),LEXS=$P(LEXT,U,7)
. . . Q:'$L(LEXC) Q:'$L(LEXN) Q:'$L(LEXS)
. . . S LEXE=$P(LEXT,U,6) I LEXE'?7N S:+LEXS'>0 LEXE=$P(LEXT,U,8) S:+LEXS>0 LEXE=$P(LEXT,U,9)
. . . S LEXTS=$$STY^LEXQL2(LEXC)
. . . S LEXTN=+LEXTS,LEXTS=$P(LEXTS,U,2) Q:'$L(LEXTS)
. . . S LEXSS="" S:+LEXS'>0&($L($G(LEXE))) LEXSS="Inactive" S LEXDS=LEXN S:$L(LEXSS) LEXDS=LEXDS_" "_LEXSS
. . . S LEXDT=LEXC,LEXDT=LEXDT_$J(" ",(8-$L(LEXDT)))_LEXDS S:$L(LEXTS) LEXDT=LEXDT_" ("_LEXTS_")"
. . . S ^TMP("LEXQL",$J,"ADDLIST",(LEXTN_" "_LEXC_" "))=LEXIEN_U_$$FT^LEXQL2(LEXC,LEXN,LEXSS)
. . . S ^TMP("LEXQL",$J,"ADDLIST",(LEXTN_" "_LEXC_" "),2)=LEXIEN_U_$$FC^LEXQL2(LEXC,LEXN,LEXSS)
Q
CM ; $$MOD(CODE,FORMAT,DATE)
;
; 1 IEN of code in ^DIC(81.3, 1-3
; 2 Modifier (.01) 2
; 3 Versioned Name (61) 1-60
; 6 Effective Date (60) 10 (external)
; 7 Status (60) 6-8 (external)
; 8 Inactivation Date (60) 10 (external)
; 9 Activation Date (60) 10 (external)
;
Q:'$L($G(LEXTT)) Q:'$L($G(LEXTO)) Q:'$L($G(LEXCT)) Q:'$L($G(LEXCO))
N LEXIX F LEXIX="BA" D
. N LEXO,LEXOC Q:LEXIX="C"&(LEXTT?1N.NP)
. S LEXO=$S(LEXIX="BA":($G(LEXCO)_" "),1:$G(LEXTO)) Q:'$L(LEXO)
. S LEXOC=$S(LEXIX="BA":$G(LEXCT),1:$G(LEXTT)) Q:'$L(LEXOC)
. F S LEXO=$O(^DIC(81.3,LEXIX,LEXO)) Q:'$L(LEXO) Q:$E(LEXO,1,$L(LEXOC))'=LEXOC D
. . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^DIC(81.3,LEXIX,LEXO,LEXIEN)) Q:+LEXIEN'>0 D
. . . Q:$O(^DIC(81.3,LEXIEN,60,0))'>0 N LEXOK S LEXOK=1 S:$O(LEXTKNS(0))>0&($G(LEXIX)="C") LEXOK=0
. . . Q:'LEXOK N LEXT,LEXD,LEXC,LEXD,LEXN,LEXS,LEXE,LEXDS,LEXTN,LEXTS,LEXSS,LEXDT
. . . S LEXC=$P($G(^DIC(81.3,+LEXIEN,0)),U,1) Q:'$L(LEXC) S LEXD=$G(LEXVDT) S:LEXD'?7N LEXD=$G(LEXTD) S LEXT=$$MOD^ICPTMOD(LEXIEN,"I",LEXD)
. . . S LEXC=$P(LEXT,U,2),LEXN=$$UP^XLFSTR($P(LEXT,U,3)),LEXS=$P(LEXT,U,7) Q:'$L(LEXC) Q:'$L(LEXN) Q:'$L(LEXS)
. . . S LEXE=$P(LEXT,U,6) I LEXE'?7N S:+LEXS'>0 LEXE=$P(LEXT,U,8) S:+LEXS>0 LEXE=$P(LEXT,U,9)
. . . S LEXTS=$$STY^LEXQL2(LEXC),LEXTN=+LEXTS,LEXTS=$P(LEXTS,U,2) Q:'$L(LEXTS) S LEXSS="" S:+LEXS'>0&($L($G(LEXE))) LEXSS="(Inactive)"
. . . S LEXDS=LEXN S:$L(LEXSS) LEXDS=LEXDS_" "_LEXSS S LEXDT=LEXC,LEXDT=LEXDT_$J(" ",(8-$L(LEXDT)))_LEXDS S:$L(LEXTS) LEXDT=LEXDT_" ("_LEXTS_")"
. . . S LEXCT=LEXCT+1 S ^TMP("LEXQL",$J,"ADDLIST",(LEXTN_" "_LEXC_LEXCT_" "))=LEXIEN_U_$$FT^LEXQL2(LEXC,LEXN,$TR(LEXSS,"()",""))
. . . S ^TMP("LEXQL",$J,"ADDLIST",(LEXTN_" "_LEXC_LEXCT_" "),2)=LEXIEN_U_$$FC^LEXQL2(LEXC,LEXN,$TR(LEXSS,"()",""))
Q
VI(X) ; Verify Input
N LEX,LEXIO,LEXIC,LEXUC,LEXUO S LEX=$G(X) Q:'$L(LEX) "" Q:$L(LEX)'>1 $$UP^XLFSTR(LEX)
S LEXIC=$G(LEX),LEXIO=$E(LEX,1,($L(LEX)-1))_$C(($A($E(LEX,$L(LEX)))-1))_"~ "
S LEXUC=$$UP^XLFSTR(LEXIC),LEXUO=$$UP^XLFSTR(LEXIO)
; 81 CPT
I $E($O(^ICPT("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
I $E($O(^ICPT("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
; 81.3 CPT Modifier
I $E($O(^DIC(81.3,"BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
I $E($O(^DIC(81.3,"BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
Q LEX
PUR ; Purge for CPT
N LEXL,LEXN,LEXC S (LEXC,LEXL)=0 F S LEXL=$O(LEXTKNS(LEXL)) Q:+LEXL'>0 D
. S LEXN="" F S LEXN=$O(LEXTKNS(LEXL,LEXN)) Q:'$L(LEXN) D
. . S LEXOK=$$NOT(LEXN) S:LEXN?1N.N LEXNUM(LEXN)="" S:LEXOK>0 LEXC=LEXC+1
. . K:'LEXOK LEXTKNS(LEXL,LEXN)
S LEXTTK=LEXC
Q
NOT(X) ; Word not to use
N LEXF,LEXN S LEXF=0 S:$E(X,1)?1N LEXF=1
S LEXN="^AND^THE^THEN^FOR^FROM^OTHER^" S:LEXN[("^"_X_"^") LEXF=1
S LEXN="^THAN^WITH^THEIR^SOME^THIS^INCLUDING^ALL^" S:LEXN[("^"_X_"^") LEXF=1
S LEXN="^OTHERWISE^SPECIFIED^ANY^NOT^ONLY^EACH^MORE^" S:LEXN[("^"_X_"^") LEXF=1
S LEXN="^ONE^TWO^LESS^PROCEDURES^WITH^OUT^TYPE^AREA^" S:LEXN[("^"_X_"^") LEXF=1
S LEXN="^EXCEPT^INVOLVING^SAME^PER^DAYS^BUT^ALA^III^" S:LEXN[("^"_X_"^") LEXF=1
S LEXN="^EXCEPT^NUMBERS^UNLESS^" S:LEXN[("^"_X_"^") LEXF=1
S:$E(X,1)?1N LEXF=1
Q:LEXF>0 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQL4 7121 printed Apr 09, 2024@21:14:16 Page 2
LEXQL4 ;ISL/KER - Query - Lookup Code (CPT/MOD) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^DIC(81.3) ICR 4492
+5 ; ^ICPT( ICR 4489
+6 ; ^ICPT("BA") ICR 4489
+7 ; ^TMP("LEXQL") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$CPTD^ICPTCOD ICR 1995
+11 ; $$CPT^ICPTCOD ICR 1995
+12 ; $$MOD^ICPTMOD ICR 1996
+13 ; $$UP^XLFSTR ICR 10104
+14 ;
+15 ; Local Variables NEWed or KILLed Elsewhere
+16 ; LEXVDT Version Date - default TODAY
+17 ; LEXTT Text String
+18 ; LEXTO $Order Text Variable
+19 ; LEXCT Code String
+20 ; LEXCO $Order Text Variable
+21 ; LEXTD TODAY's Date
+22 ; LEXTKNS Local Array of Tolkens
+23 ; LEXTTK Total # Tolkens
+24 ;
+25 QUIT
CP ; $$CPT^ICPTCOD(CODE,DATE)
+1 ;
+2 ; 1 IEN of code in ^ICPT 1-6
+3 ; 2 CPT Code (.01) 5
+4 ; 3 Versioned Short Name (#61) 1-28
+5 ; 6 Effective Date (#60) 10 (external)
+6 ; 7 Status (#60) 6-8 (external)
+7 ; 8 Inactivation Date (#60) 10 (external)
+8 ; 9 Activation Date (#60) 10 (external)
+9 ;
+10 if '$LENGTH($GET(LEXTT))
QUIT
if '$LENGTH($GET(LEXTO))
QUIT
if '$LENGTH($GET(LEXCT))
QUIT
if '$LENGTH($GET(LEXCO))
QUIT
+11 SET LEXCT=$$VI(LEXCT)
+12 SET LEXCO=$EXTRACT(LEXCT,1,($LENGTH(LEXCT)-1))_$CHAR(($ASCII($EXTRACT(LEXCT,$LENGTH(LEXCT)))-1))_"~"
+13 NEW LEXNUM
DO PUR
NEW LEXIX
FOR LEXIX="BA","C"
Begin DoDot:1
+14 NEW LEXO,LEXOC
if LEXIX="C"&(LEXTT?1N.NP)
QUIT
+15 SET LEXO=$SELECT(LEXIX="BA":($GET(LEXCO)_" "),1:$GET(LEXTO))
if '$LENGTH(LEXO)
QUIT
+16 SET LEXOC=$SELECT(LEXIX="BA":$GET(LEXCT),1:$GET(LEXTT))
if '$LENGTH(LEXOC)
QUIT
+17 FOR
SET LEXO=$ORDER(^ICPT(LEXIX,LEXO))
if '$LENGTH(LEXO)
QUIT
if $EXTRACT(LEXO,1,$LENGTH(LEXOC))'=LEXOC
QUIT
Begin DoDot:2
+18 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^ICPT(LEXIX,LEXO,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:3
+19 NEW LEXOK
SET LEXOK=1
if $ORDER(LEXTKNS(0))>0&($GET(LEXIX)="C")
SET LEXOK=0
+20 IF $GET(LEXIX)="C"&($ORDER(LEXTKNS(0))>0)
Begin DoDot:4
+21 NEW LEXN,LEXT,LEXC
SET (LEXC,LEXN)=0
FOR
SET LEXN=$ORDER(LEXTKNS(LEXN))
if +LEXN'>0
QUIT
Begin DoDot:5
+22 SET LEXT=""
FOR
SET LEXT=$ORDER(LEXTKNS(LEXN,LEXT))
if '$LENGTH(LEXT)
QUIT
Begin DoDot:6
+23 NEW LEXOT,LEXKT,LEXF
SET LEXF=0
SET LEXOT=$EXTRACT(LEXT,1,($LENGTH(LEXT)-1))_$CHAR(($ASCII($EXTRACT(LEXT,$LENGTH(LEXT)))-1))_"~"
+24 FOR
SET LEXOT=$ORDER(^ICPT(LEXIX,LEXOT))
if '$LENGTH(LEXOT)
QUIT
if $EXTRACT(LEXOT,1,$LENGTH(LEXT))'=LEXT
QUIT
Begin DoDot:7
+25 if $DATA(^ICPT(LEXIX,LEXOT,LEXIEN))
SET LEXF=1
End DoDot:7
+26 if LEXF
SET LEXC=LEXC+1
End DoDot:6
End DoDot:5
+27 if +LEXC>0&(+LEXC=+($GET(LEXTTK)))
SET LEXOK=1
End DoDot:4
+28 IF $GET(LEXIX)="C"&($ORDER(LEXNUM(0))>0)
Begin DoDot:4
+29 NEW LEXD,LEXC,LEXF,LEXN,LEXO
SET LEXO=$$CPTD^ICPTCOD(+LEXIEN,"LEXD")
SET (LEXC,LEXF,LEXN)=0
+30 FOR
SET LEXN=$ORDER(LEXNUM(LEXN))
if +LEXN'>0
QUIT
Begin DoDot:5
+31 SET LEXC=LEXC+1
+32 NEW LEXI
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXD(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:6
+33 NEW LEXT
SET LEXT=$GET(LEXD(LEXI))
if LEXT[LEXN
SET LEXF=LEXF+1
End DoDot:6
End DoDot:5
+34 IF LEXC>0&(LEXC'=LEXF)
SET LEXOK=0
End DoDot:4
+35 if 'LEXOK
QUIT
NEW LEXT,LEXD,LEXC,LEXD,LEXN,LEXS,LEXE,LEXDS,LEXTN,LEXTS,LEXSS,LEXDT
+36 SET LEXC=$PIECE($GET(^ICPT(+LEXIEN,0)),U,1)
if '$LENGTH(LEXC)
QUIT
SET LEXD=$GET(LEXVDT)
if LEXD'?7N
SET LEXD=$GET(LEXTD)
SET LEXT=$$CPT^ICPTCOD(LEXC,LEXD)
+37 SET LEXC=$PIECE(LEXT,U,2)
SET LEXN=$$UP^XLFSTR($PIECE(LEXT,U,3))
SET LEXS=$PIECE(LEXT,U,7)
+38 if '$LENGTH(LEXC)
QUIT
if '$LENGTH(LEXN)
QUIT
if '$LENGTH(LEXS)
QUIT
+39 SET LEXE=$PIECE(LEXT,U,6)
IF LEXE'?7N
if +LEXS'>0
SET LEXE=$PIECE(LEXT,U,8)
if +LEXS>0
SET LEXE=$PIECE(LEXT,U,9)
+40 SET LEXTS=$$STY^LEXQL2(LEXC)
+41 SET LEXTN=+LEXTS
SET LEXTS=$PIECE(LEXTS,U,2)
if '$LENGTH(LEXTS)
QUIT
+42 SET LEXSS=""
if +LEXS'>0&($LENGTH($GET(LEXE)))
SET LEXSS="Inactive"
SET LEXDS=LEXN
if $LENGTH(LEXSS)
SET LEXDS=LEXDS_" "_LEXSS
+43 SET LEXDT=LEXC
SET LEXDT=LEXDT_$JUSTIFY(" ",(8-$LENGTH(LEXDT)))_LEXDS
if $LENGTH(LEXTS)
SET LEXDT=LEXDT_" ("_LEXTS_")"
+44 SET ^TMP("LEXQL",$JOB,"ADDLIST",(LEXTN_" "_LEXC_" "))=LEXIEN_U_$$FT^LEXQL2(LEXC,LEXN,LEXSS)
+45 SET ^TMP("LEXQL",$JOB,"ADDLIST",(LEXTN_" "_LEXC_" "),2)=LEXIEN_U_$$FC^LEXQL2(LEXC,LEXN,LEXSS)
End DoDot:3
End DoDot:2
End DoDot:1
+46 QUIT
CM ; $$MOD(CODE,FORMAT,DATE)
+1 ;
+2 ; 1 IEN of code in ^DIC(81.3, 1-3
+3 ; 2 Modifier (.01) 2
+4 ; 3 Versioned Name (61) 1-60
+5 ; 6 Effective Date (60) 10 (external)
+6 ; 7 Status (60) 6-8 (external)
+7 ; 8 Inactivation Date (60) 10 (external)
+8 ; 9 Activation Date (60) 10 (external)
+9 ;
+10 if '$LENGTH($GET(LEXTT))
QUIT
if '$LENGTH($GET(LEXTO))
QUIT
if '$LENGTH($GET(LEXCT))
QUIT
if '$LENGTH($GET(LEXCO))
QUIT
+11 NEW LEXIX
FOR LEXIX="BA"
Begin DoDot:1
+12 NEW LEXO,LEXOC
if LEXIX="C"&(LEXTT?1N.NP)
QUIT
+13 SET LEXO=$SELECT(LEXIX="BA":($GET(LEXCO)_" "),1:$GET(LEXTO))
if '$LENGTH(LEXO)
QUIT
+14 SET LEXOC=$SELECT(LEXIX="BA":$GET(LEXCT),1:$GET(LEXTT))
if '$LENGTH(LEXOC)
QUIT
+15 FOR
SET LEXO=$ORDER(^DIC(81.3,LEXIX,LEXO))
if '$LENGTH(LEXO)
QUIT
if $EXTRACT(LEXO,1,$LENGTH(LEXOC))'=LEXOC
QUIT
Begin DoDot:2
+16 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^DIC(81.3,LEXIX,LEXO,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:3
+17 if $ORDER(^DIC(81.3,LEXIEN,60,0))'>0
QUIT
NEW LEXOK
SET LEXOK=1
if $ORDER(LEXTKNS(0))>0&($GET(LEXIX)="C")
SET LEXOK=0
+18 if 'LEXOK
QUIT
NEW LEXT,LEXD,LEXC,LEXD,LEXN,LEXS,LEXE,LEXDS,LEXTN,LEXTS,LEXSS,LEXDT
+19 SET LEXC=$PIECE($GET(^DIC(81.3,+LEXIEN,0)),U,1)
if '$LENGTH(LEXC)
QUIT
SET LEXD=$GET(LEXVDT)
if LEXD'?7N
SET LEXD=$GET(LEXTD)
SET LEXT=$$MOD^ICPTMOD(LEXIEN,"I",LEXD)
+20 SET LEXC=$PIECE(LEXT,U,2)
SET LEXN=$$UP^XLFSTR($PIECE(LEXT,U,3))
SET LEXS=$PIECE(LEXT,U,7)
if '$LENGTH(LEXC)
QUIT
if '$LENGTH(LEXN)
QUIT
if '$LENGTH(LEXS)
QUIT
+21 SET LEXE=$PIECE(LEXT,U,6)
IF LEXE'?7N
if +LEXS'>0
SET LEXE=$PIECE(LEXT,U,8)
if +LEXS>0
SET LEXE=$PIECE(LEXT,U,9)
+22 SET LEXTS=$$STY^LEXQL2(LEXC)
SET LEXTN=+LEXTS
SET LEXTS=$PIECE(LEXTS,U,2)
if '$LENGTH(LEXTS)
QUIT
SET LEXSS=""
if +LEXS'>0&($LENGTH($GET(LEXE)))
SET LEXSS="(Inactive)"
+23 SET LEXDS=LEXN
if $LENGTH(LEXSS)
SET LEXDS=LEXDS_" "_LEXSS
SET LEXDT=LEXC
SET LEXDT=LEXDT_$JUSTIFY(" ",(8-$LENGTH(LEXDT)))_LEXDS
if $LENGTH(LEXTS)
SET LEXDT=LEXDT_" ("_LEXTS_")"
+24 SET LEXCT=LEXCT+1
SET ^TMP("LEXQL",$JOB,"ADDLIST",(LEXTN_" "_LEXC_LEXCT_" "))=LEXIEN_U_$$FT^LEXQL2(LEXC,LEXN,$TRANSLATE(LEXSS,"()",""))
+25 SET ^TMP("LEXQL",$JOB,"ADDLIST",(LEXTN_" "_LEXC_LEXCT_" "),2)=LEXIEN_U_$$FC^LEXQL2(LEXC,LEXN,$TRANSLATE(LEXSS,"()",""))
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
VI(X) ; Verify Input
+1 NEW LEX,LEXIO,LEXIC,LEXUC,LEXUO
SET LEX=$GET(X)
if '$LENGTH(LEX)
QUIT ""
if $LENGTH(LEX)'>1
QUIT $$UP^XLFSTR(LEX)
+2 SET LEXIC=$GET(LEX)
SET LEXIO=$EXTRACT(LEX,1,($LENGTH(LEX)-1))_$CHAR(($ASCII($EXTRACT(LEX,$LENGTH(LEX)))-1))_"~ "
+3 SET LEXUC=$$UP^XLFSTR(LEXIC)
SET LEXUO=$$UP^XLFSTR(LEXIO)
+4 ; 81 CPT
+5 IF $EXTRACT($ORDER(^ICPT("BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
QUIT LEXIC
+6 IF $EXTRACT($ORDER(^ICPT("BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
QUIT LEXUC
+7 ; 81.3 CPT Modifier
+8 IF $EXTRACT($ORDER(^DIC(81.3,"BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
QUIT LEXIC
+9 IF $EXTRACT($ORDER(^DIC(81.3,"BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
QUIT LEXUC
+10 QUIT LEX
PUR ; Purge for CPT
+1 NEW LEXL,LEXN,LEXC
SET (LEXC,LEXL)=0
FOR
SET LEXL=$ORDER(LEXTKNS(LEXL))
if +LEXL'>0
QUIT
Begin DoDot:1
+2 SET LEXN=""
FOR
SET LEXN=$ORDER(LEXTKNS(LEXL,LEXN))
if '$LENGTH(LEXN)
QUIT
Begin DoDot:2
+3 SET LEXOK=$$NOT(LEXN)
if LEXN?1N.N
SET LEXNUM(LEXN)=""
if LEXOK>0
SET LEXC=LEXC+1
+4 if 'LEXOK
KILL LEXTKNS(LEXL,LEXN)
End DoDot:2
End DoDot:1
+5 SET LEXTTK=LEXC
+6 QUIT
NOT(X) ; Word not to use
+1 NEW LEXF,LEXN
SET LEXF=0
if $EXTRACT(X,1)?1N
SET LEXF=1
+2 SET LEXN="^AND^THE^THEN^FOR^FROM^OTHER^"
if LEXN[("^"_X_"^")
SET LEXF=1
+3 SET LEXN="^THAN^WITH^THEIR^SOME^THIS^INCLUDING^ALL^"
if LEXN[("^"_X_"^")
SET LEXF=1
+4 SET LEXN="^OTHERWISE^SPECIFIED^ANY^NOT^ONLY^EACH^MORE^"
if LEXN[("^"_X_"^")
SET LEXF=1
+5 SET LEXN="^ONE^TWO^LESS^PROCEDURES^WITH^OUT^TYPE^AREA^"
if LEXN[("^"_X_"^")
SET LEXF=1
+6 SET LEXN="^EXCEPT^INVOLVING^SAME^PER^DAYS^BUT^ALA^III^"
if LEXN[("^"_X_"^")
SET LEXF=1
+7 SET LEXN="^EXCEPT^NUMBERS^UNLESS^"
if LEXN[("^"_X_"^")
SET LEXF=1
+8 if $EXTRACT(X,1)?1N
SET LEXF=1
+9 if LEXF>0
QUIT 0
+10 QUIT 1
