- 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 Feb 18, 2025@23:35:02 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
