- LEXQL2 ;ISL/KER - Query - Lookup Code (Build List) ;04/21/2014
- ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
- ;
- ; Global Variables
- ; ^DIC(81.3, ICR 4492
- ; ^ICD0("BA" ICR 4486
- ; ^ICD9("BA" ICR 4485
- ; ^ICPT( ICR 4489
- ; ^ICPT("BA" ICR 4489
- ; ^TMP("LEXQL") SACC 2.3.2.5.1
- ; ^UTILITY($J ICR 10011
- ;
- ; External References
- ; ^DIWP ICR 10011
- ; $$CODEABA^ICDEX ICR 5747
- ; $$ROOT^ICDEX ICR 5747
- ; $$DT^XLFDT ICR 10103
- ; $$FMTE^XLFDT ICR 10103
- ; $$UP^XLFSTR ICR 10104
- ;
- ADD(X) ; Add to List
- N LEXIN,LEXINU,LEXO,LEXCO,LEXCT,LEXCS,LEXTO,LEXTT,LEXOC,LEXCT,LEXTY,LEXTD,LEXTMP
- N LEXKEY,LEXLEN,LEXRT,LEXSO,LEXTKNS S LEXTD=$$DT^XLFDT,U="^"
- S LEXIN=$G(X),LEXINU=$$UP^XLFSTR($$TM($G(LEXIN))) K LEXTKNS S LEXTTK=$$TOKN(LEXINU)
- S LEXLEN=$O(LEXTKNS(" "),-1)
- F LEXTMP="~","!","@","#","$","%","&","*","(",")","_","+","`","-","="," " S LEXSO=$P(LEXIN,LEXTMP,1)
- F LEXTMP="[","]","{","}",";","'","\",":","|",",","/","?","<",">" S LEXSO=$P(LEXSO,LEXTMP,1)
- S:+LEXLEN'>0 LEXLEN=$L(LEXSO)
- S LEXKEY=$O(LEXTKNS(LEXLEN,""),-1) S:'$L(LEXKEY) LEXKEY=LEXSO S LEXKEY=$TR(LEXKEY,"#","") Q:'$L(LEXKEY)
- K LEXTKNS(+LEXLEN,LEXKEY) S:+LEXTTK>0 LEXTTK=LEXTTK-1
- S LEXTT=LEXKEY
- S LEXTO=$E(LEXKEY,1,($L(LEXKEY)-1))_$C(($A($E(LEXKEY,$L(LEXKEY)))-1))_"~"
- S LEXCT=$TR(LEXSO,"#","")
- S LEXCO=$E(LEXSO,1,($L(LEXSO)-1))_$C(($A($E(LEXSO,$L(LEXSO)))-1))_"~"
- ; ICD-10 DX
- S LEXRT=$$ROOT^ICDEX(80),LEXCS=30
- I ($L(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($L(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS))) D
- . S LEXTY=1 D ICD^LEXQL3($G(LEXINU),LEXCS)
- ; ICD-10 PR
- S LEXRT=$$ROOT^ICDEX(80.1),LEXCS=31
- I ($L(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($L(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS))) D
- . S LEXTY=2 D ICD^LEXQL3($G(LEXINU),LEXCS)
- ; ICD-9 DX
- S LEXRT=$$ROOT^ICDEX(80),LEXCS=1
- I ($L(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($L(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS))) D
- . S LEXTY=3 D ICD^LEXQL3($G(LEXINU),LEXCS)
- ; ICD-9 PR
- S LEXRT=$$ROOT^ICDEX(80.1),LEXCS=2
- I ($L(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($L(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS))) D
- . S LEXTY=4 D ICD^LEXQL3($G(LEXINU),LEXCS)
- ; CPT/HCPCS
- I ($L(LEXTT)>2&$$OK(LEXTT,"^ICPT(","C"))!($L(LEXCT)>2&($$OK(LEXCT,"^ICPT(","BA"))) D
- . S LEXTY=5 D CP^LEXQL4
- ; CPT MOD
- I ($L(LEXCT)>0&($$OK(LEXCT,"^DIC(81.3,","BA"))) D
- . S LEXTY=6 D CM^LEXQL4
- ; Re-Order List
- N LEXCT,LEXO,LEXT1,LEXT2,LEX S LEXO="" F S LEXO=$O(^TMP("LEXQL",$J,"ADDLIST",LEXO)) Q:'$L(LEXO) D
- . K LEX N LEXT1,LEXT2 S LEXT1=$$TM($G(^TMP("LEXQL",$J,"ADDLIST",LEXO)))
- . S LEXT2=$$TM($G(^TMP("LEXQL",$J,"ADDLIST",LEXO,2))) Q:'$L(LEXT2)
- . I $L(LEXT2) K LEX S LEX(1)=LEXT2 D PR(.LEX,70) Q:'$L($G(LEX(1)))
- . S LEXCT=+($G(LEXCT))+1 K ^TMP("LEXQL",$J,+LEXCT)
- . S ^TMP("LEXQL",$J,+LEXCT)=$G(LEX(1)),^TMP("LEXQL",$J,0)=+LEXCT
- . S:$L($G(LEX(2))) ^TMP("LEXQL",$J,+LEXCT,2)=$G(LEX(2))
- K ^TMP("LEXQL",$J,"ADDLIST")
- Q
- ;
- ; Miscellaneous
- VSO(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)
- ; 80 ICD-9/10
- I $E($O(^ICD9("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
- I $E($O(^ICD9("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
- ; 80.1 ICD-9.10
- I $E($O(^ICD0("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
- I $E($O(^ICD0("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
- ; 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
- SD(X) ; Short Date
- Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
- FT(X,Y,LEX) ; Format Text First
- N LEXT,LEXC,LEXD,LEXS S LEXC=$G(X),LEXD=$G(Y),LEXS=$G(LEX) S LEXC=$G(LEXC) Q:'$L(LEXC) ""
- S LEXT=$P($$STY(LEXC),U,2) Q:'$L(LEXT) S LEXD=$G(LEXD) Q:'$L(LEXD) ""
- S LEXS=$G(LEXS),LEXT=$G(LEXT) S:$L(LEXD)&($L(LEXS)) LEXD=LEXD_" ("_LEXS_")" N LEXO
- S LEXO=LEXC S LEXO=LEXO_$J(" ",(9-$L(LEXO)))_$E(LEXD,1,54)
- S LEXO=LEXO_$J(" ",(63-$L(LEXO)))_LEXT S X=LEXO
- Q X
- FC(X,Y,LEX) ; Format Code First
- N LEXO,LEXT,LEXC,LEXD,LEXS S LEXC=$G(X),LEXD=$G(Y),LEXS=$G(LEX) Q:'$L(LEXC) ""
- S LEXT=$P($$STY(LEXC),"^",2) Q:'$L(LEXT) "" Q:'$L(LEXD) ""
- S LEXS=$G(LEX),LEXO=LEXT_" "_LEXC_" ",LEXO=LEXO_$J(" ",(19-$L(LEXO))),LEXO=LEXO_" "_LEXD
- S:$L(LEXS)&(LEXO'[LEXS) LEXO=$E(LEXO,1,56)_" ("_LEXS_")" S X=LEXO
- Q X
- STY(X) ; Short Type
- N LEXSO S LEXSO=$G(X) Q:$L(LEXSO)'>1 ""
- Q:$$CODEABA^ICDEX(LEXSO,80,30)>0 "1^ICD-10 Dx"
- Q:$$CODEABA^ICDEX(LEXSO,80.1,31)>0 "2^ICD-10 Op"
- Q:$$CODEABA^ICDEX(LEXSO,80,1)>0 "3^ICD-9 Dx"
- Q:$$CODEABA^ICDEX(LEXSO,80.1,2)>0 "4^ICD-9 Op"
- Q:$D(^ICPT("BA",(LEXSO_" "))) "5^CPT-4/HCPCS"
- Q:$D(^DIC(81.3,"BA",(LEXSO_" "))) "6^CPT Mod"
- Q ""
- LTY(X) ; Long Type
- N LEXSO,LEX S LEXSO=$G(X) Q:$L(LEXSO)'>1 ""
- Q:$$CODEABA^ICDEX(LEXSO,80,30)>0 "1^ICD-10 Diagnosis Code"
- Q:$$CODEABA^ICDEX(LEXSO,80.1,31)>0 "2^ICD-10 Procedure Code"
- Q:$$CODEABA^ICDEX(LEXSO,80,1)>0 "3^ICD-9 Diagnosis Code"
- Q:$$CODEABA^ICDEX(LEXSO,80.1,2)>0 "4^ICD-9 Procedure Code"
- S LEX=$O(^ICPT("BA",(LEXSO_" "),0)) I LEX>0 D Q:LEX["^" LEX
- . N LEXS S LEXS=$P($G(^ICPT(+LEX,0)),"^",6)
- . I LEXS="C" S LEX="5^CPT Procedure Code" Q
- . I LEXS="H" S LEX="6^HCPCS Procedure Code" Q
- . I LEXSO?5N S LEX="5^CPT Procedure Code" Q
- . S LEX="6^HCPCS Procedure Code"
- Q:$D(^DIC(81.3,"BA",(LEXSO_" "))) "7^CPT Modifier Code"
- Q ""
- DS(X) ; Trim Dubble Space Character
- S X=$G(X) Q:X'[" " X F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,299)
- Q X
- PR(LEX,X) ; Parse Array
- N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXI,LEXLEN,LEXC K ^UTILITY($J,"W") Q:'$D(LEX)
- S LEXLEN=+($G(X)) S:+LEXLEN'>0 LEXLEN=79 S LEXC=+($G(LEX)) S:+($G(LEXC))'>0 LEXC=$O(LEX(" "),-1) Q:+LEXC'>0
- S DIWL=1,DIWF="C"_+LEXLEN 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
- 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
- OK(X,Y,LEX,LEXS) ; User Input is Ok
- N LEXIX,LEXX,LEXO,LEXCT,LEXNX,LEXROOT
- S (LEXCT,LEXX)=$TR($G(X),"#","") Q:$L(LEXX)'>0 0 S LEXROOT=$G(Y),LEXIX=$G(LEX),LEXS=+($G(LEXS))
- Q:'$L(LEXROOT) 0 Q:"^D^AD^BA^ABA^C^"'[("^"_LEXIX_"^") 0
- S LEXO=$E(LEXX,1,($L(LEXX)-1))_$C(($A($E(LEXX,$L(LEXX)))-1))_"~"
- S:+LEXS'>0 LEXNX=$O(@(LEXROOT_""""_LEXIX_""","""_LEXO_""")"))
- S:+LEXS>0 LEXNX=$O(@(LEXROOT_""""_LEXIX_""","_+LEXS_","""_LEXO_""")"))
- Q:$E(LEXNX,1,$L(LEXCT))=LEXCT 1
- Q 0
- TOKN(X) ; Parse Tolkens
- N LEXX,LEXBEG,LEXEND,LEXCHR,LEXTTK,LEXTKN,LEXNOT K LEXTKNS S LEXX=$G(X),LEXBEG=1,LEXTTK=0
- S LEXNOT="^AND^THE^THEN^FOR^FROM^OTHER^THAN^WITH^THEIR^SOME^THIS^" F LEXEND=1:1:$L(LEXX)+1 D
- . S LEXCHR=$E(LEXX,LEXEND) I "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXCHR D
- . . S LEXTKN=$E(LEXX,LEXBEG,LEXEND-1),LEXBEG=LEXEND+1 I $L(LEXTKN)>2,$L(LEXTKN)<31,LEXNOT'[LEXTKN D
- . . . S:'$D(LEXTKNS($L(LEXTKN),LEXTKN)) LEXTTK=+($G(LEXTTK))+1
- . . . S LEXTKNS($L(LEXTKN),LEXTKN)=""
- S X=+($G(LEXTTK))
- Q X
- SHO ; Show TMP
- N LEXNN,LEXNC S LEXNN="^TMP(""LEXQL"","_$J_")",LEXNC="^TMP(""LEXQL"","_$J_","
- W ! F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) W !,LEXNN,"=",@LEXNN
- W !
- Q
- LEXQL2 ;ISL/KER - Query - Lookup Code (Build List) ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
- +2 ;
- +3 ; Global Variables
- +4 ; ^DIC(81.3, ICR 4492
- +5 ; ^ICD0("BA" ICR 4486
- +6 ; ^ICD9("BA" ICR 4485
- +7 ; ^ICPT( ICR 4489
- +8 ; ^ICPT("BA" ICR 4489
- +9 ; ^TMP("LEXQL") SACC 2.3.2.5.1
- +10 ; ^UTILITY($J ICR 10011
- +11 ;
- +12 ; External References
- +13 ; ^DIWP ICR 10011
- +14 ; $$CODEABA^ICDEX ICR 5747
- +15 ; $$ROOT^ICDEX ICR 5747
- +16 ; $$DT^XLFDT ICR 10103
- +17 ; $$FMTE^XLFDT ICR 10103
- +18 ; $$UP^XLFSTR ICR 10104
- +19 ;
- ADD(X) ; Add to List
- +1 NEW LEXIN,LEXINU,LEXO,LEXCO,LEXCT,LEXCS,LEXTO,LEXTT,LEXOC,LEXCT,LEXTY,LEXTD,LEXTMP
- +2 NEW LEXKEY,LEXLEN,LEXRT,LEXSO,LEXTKNS
- SET LEXTD=$$DT^XLFDT
- SET U="^"
- +3 SET LEXIN=$GET(X)
- SET LEXINU=$$UP^XLFSTR($$TM($GET(LEXIN)))
- KILL LEXTKNS
- SET LEXTTK=$$TOKN(LEXINU)
- +4 SET LEXLEN=$ORDER(LEXTKNS(" "),-1)
- +5 FOR LEXTMP="~","!","@","#","$","%","&","*","(",")","_","+","`","-","="," "
- SET LEXSO=$PIECE(LEXIN,LEXTMP,1)
- +6 FOR LEXTMP="[","]","{","}",";","'","\",":","|",",","/","?","<",">"
- SET LEXSO=$PIECE(LEXSO,LEXTMP,1)
- +7 IF +LEXLEN'>0
- SET LEXLEN=$LENGTH(LEXSO)
- +8 SET LEXKEY=$ORDER(LEXTKNS(LEXLEN,""),-1)
- IF '$LENGTH(LEXKEY)
- SET LEXKEY=LEXSO
- SET LEXKEY=$TRANSLATE(LEXKEY,"#","")
- IF '$LENGTH(LEXKEY)
- QUIT
- +9 KILL LEXTKNS(+LEXLEN,LEXKEY)
- IF +LEXTTK>0
- SET LEXTTK=LEXTTK-1
- +10 SET LEXTT=LEXKEY
- +11 SET LEXTO=$EXTRACT(LEXKEY,1,($LENGTH(LEXKEY)-1))_$CHAR(($ASCII($EXTRACT(LEXKEY,$LENGTH(LEXKEY)))-1))_"~"
- +12 SET LEXCT=$TRANSLATE(LEXSO,"#","")
- +13 SET LEXCO=$EXTRACT(LEXSO,1,($LENGTH(LEXSO)-1))_$CHAR(($ASCII($EXTRACT(LEXSO,$LENGTH(LEXSO)))-1))_"~"
- +14 ; ICD-10 DX
- +15 SET LEXRT=$$ROOT^ICDEX(80)
- SET LEXCS=30
- +16 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($LENGTH(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS)))
- Begin DoDot:1
- +17 SET LEXTY=1
- DO ICD^LEXQL3($GET(LEXINU),LEXCS)
- End DoDot:1
- +18 ; ICD-10 PR
- +19 SET LEXRT=$$ROOT^ICDEX(80.1)
- SET LEXCS=31
- +20 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($LENGTH(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS)))
- Begin DoDot:1
- +21 SET LEXTY=2
- DO ICD^LEXQL3($GET(LEXINU),LEXCS)
- End DoDot:1
- +22 ; ICD-9 DX
- +23 SET LEXRT=$$ROOT^ICDEX(80)
- SET LEXCS=1
- +24 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($LENGTH(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS)))
- Begin DoDot:1
- +25 SET LEXTY=3
- DO ICD^LEXQL3($GET(LEXINU),LEXCS)
- End DoDot:1
- +26 ; ICD-9 PR
- +27 SET LEXRT=$$ROOT^ICDEX(80.1)
- SET LEXCS=2
- +28 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($LENGTH(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS)))
- Begin DoDot:1
- +29 SET LEXTY=4
- DO ICD^LEXQL3($GET(LEXINU),LEXCS)
- End DoDot:1
- +30 ; CPT/HCPCS
- +31 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,"^ICPT(","C"))!($LENGTH(LEXCT)>2&($$OK(LEXCT,"^ICPT(","BA")))
- Begin DoDot:1
- +32 SET LEXTY=5
- DO CP^LEXQL4
- End DoDot:1
- +33 ; CPT MOD
- +34 IF ($LENGTH(LEXCT)>0&($$OK(LEXCT,"^DIC(81.3,","BA")))
- Begin DoDot:1
- +35 SET LEXTY=6
- DO CM^LEXQL4
- End DoDot:1
- +36 ; Re-Order List
- +37 NEW LEXCT,LEXO,LEXT1,LEXT2,LEX
- SET LEXO=""
- FOR
- SET LEXO=$ORDER(^TMP("LEXQL",$JOB,"ADDLIST",LEXO))
- IF '$LENGTH(LEXO)
- QUIT
- Begin DoDot:1
- +38 KILL LEX
- NEW LEXT1,LEXT2
- SET LEXT1=$$TM($GET(^TMP("LEXQL",$JOB,"ADDLIST",LEXO)))
- +39 SET LEXT2=$$TM($GET(^TMP("LEXQL",$JOB,"ADDLIST",LEXO,2)))
- IF '$LENGTH(LEXT2)
- QUIT
- +40 IF $LENGTH(LEXT2)
- KILL LEX
- SET LEX(1)=LEXT2
- DO PR(.LEX,70)
- IF '$LENGTH($GET(LEX(1)))
- QUIT
- +41 SET LEXCT=+($GET(LEXCT))+1
- KILL ^TMP("LEXQL",$JOB,+LEXCT)
- +42 SET ^TMP("LEXQL",$JOB,+LEXCT)=$GET(LEX(1))
- SET ^TMP("LEXQL",$JOB,0)=+LEXCT
- +43 IF $LENGTH($GET(LEX(2)))
- SET ^TMP("LEXQL",$JOB,+LEXCT,2)=$GET(LEX(2))
- End DoDot:1
- +44 KILL ^TMP("LEXQL",$JOB,"ADDLIST")
- +45 QUIT
- +46 ;
- +47 ; Miscellaneous
- VSO(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 ; 80 ICD-9/10
- +5 IF $EXTRACT($ORDER(^ICD9("BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
- QUIT LEXIC
- +6 IF $EXTRACT($ORDER(^ICD9("BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
- QUIT LEXUC
- +7 ; 80.1 ICD-9.10
- +8 IF $EXTRACT($ORDER(^ICD0("BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
- QUIT LEXIC
- +9 IF $EXTRACT($ORDER(^ICD0("BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
- QUIT LEXUC
- +10 ; 81 CPT
- +11 IF $EXTRACT($ORDER(^ICPT("BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
- QUIT LEXIC
- +12 IF $EXTRACT($ORDER(^ICPT("BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
- QUIT LEXUC
- +13 ; 81.3 CPT Modifier
- +14 IF $EXTRACT($ORDER(^DIC(81.3,"BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
- QUIT LEXIC
- +15 IF $EXTRACT($ORDER(^DIC(81.3,"BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
- QUIT LEXUC
- +16 QUIT LEX
- SD(X) ; Short Date
- +1 QUIT $TRANSLATE($$FMTE^XLFDT(+($GET(X)),"5DZ"),"@"," ")
- FT(X,Y,LEX) ; Format Text First
- +1 NEW LEXT,LEXC,LEXD,LEXS
- SET LEXC=$GET(X)
- SET LEXD=$GET(Y)
- SET LEXS=$GET(LEX)
- SET LEXC=$GET(LEXC)
- IF '$LENGTH(LEXC)
- QUIT ""
- +2 SET LEXT=$PIECE($$STY(LEXC),U,2)
- IF '$LENGTH(LEXT)
- QUIT
- SET LEXD=$GET(LEXD)
- IF '$LENGTH(LEXD)
- QUIT ""
- +3 SET LEXS=$GET(LEXS)
- SET LEXT=$GET(LEXT)
- IF $LENGTH(LEXD)&($LENGTH(LEXS))
- SET LEXD=LEXD_" ("_LEXS_")"
- NEW LEXO
- +4 SET LEXO=LEXC
- SET LEXO=LEXO_$JUSTIFY(" ",(9-$LENGTH(LEXO)))_$EXTRACT(LEXD,1,54)
- +5 SET LEXO=LEXO_$JUSTIFY(" ",(63-$LENGTH(LEXO)))_LEXT
- SET X=LEXO
- +6 QUIT X
- FC(X,Y,LEX) ; Format Code First
- +1 NEW LEXO,LEXT,LEXC,LEXD,LEXS
- SET LEXC=$GET(X)
- SET LEXD=$GET(Y)
- SET LEXS=$GET(LEX)
- IF '$LENGTH(LEXC)
- QUIT ""
- +2 SET LEXT=$PIECE($$STY(LEXC),"^",2)
- IF '$LENGTH(LEXT)
- QUIT ""
- IF '$LENGTH(LEXD)
- QUIT ""
- +3 SET LEXS=$GET(LEX)
- SET LEXO=LEXT_" "_LEXC_" "
- SET LEXO=LEXO_$JUSTIFY(" ",(19-$LENGTH(LEXO)))
- SET LEXO=LEXO_" "_LEXD
- +4 IF $LENGTH(LEXS)&(LEXO'[LEXS)
- SET LEXO=$EXTRACT(LEXO,1,56)_" ("_LEXS_")"
- SET X=LEXO
- +5 QUIT X
- STY(X) ; Short Type
- +1 NEW LEXSO
- SET LEXSO=$GET(X)
- IF $LENGTH(LEXSO)'>1
- QUIT ""
- +2 IF $$CODEABA^ICDEX(LEXSO,80,30)>0
- QUIT "1^ICD-10 Dx"
- +3 IF $$CODEABA^ICDEX(LEXSO,80.1,31)>0
- QUIT "2^ICD-10 Op"
- +4 IF $$CODEABA^ICDEX(LEXSO,80,1)>0
- QUIT "3^ICD-9 Dx"
- +5 IF $$CODEABA^ICDEX(LEXSO,80.1,2)>0
- QUIT "4^ICD-9 Op"
- +6 IF $DATA(^ICPT("BA",(LEXSO_" ")))
- QUIT "5^CPT-4/HCPCS"
- +7 IF $DATA(^DIC(81.3,"BA",(LEXSO_" ")))
- QUIT "6^CPT Mod"
- +8 QUIT ""
- LTY(X) ; Long Type
- +1 NEW LEXSO,LEX
- SET LEXSO=$GET(X)
- IF $LENGTH(LEXSO)'>1
- QUIT ""
- +2 IF $$CODEABA^ICDEX(LEXSO,80,30)>0
- QUIT "1^ICD-10 Diagnosis Code"
- +3 IF $$CODEABA^ICDEX(LEXSO,80.1,31)>0
- QUIT "2^ICD-10 Procedure Code"
- +4 IF $$CODEABA^ICDEX(LEXSO,80,1)>0
- QUIT "3^ICD-9 Diagnosis Code"
- +5 IF $$CODEABA^ICDEX(LEXSO,80.1,2)>0
- QUIT "4^ICD-9 Procedure Code"
- +6 SET LEX=$ORDER(^ICPT("BA",(LEXSO_" "),0))
- IF LEX>0
- Begin DoDot:1
- +7 NEW LEXS
- SET LEXS=$PIECE($GET(^ICPT(+LEX,0)),"^",6)
- +8 IF LEXS="C"
- SET LEX="5^CPT Procedure Code"
- QUIT
- +9 IF LEXS="H"
- SET LEX="6^HCPCS Procedure Code"
- QUIT
- +10 IF LEXSO?5N
- SET LEX="5^CPT Procedure Code"
- QUIT
- +11 SET LEX="6^HCPCS Procedure Code"
- End DoDot:1
- IF LEX["^"
- QUIT LEX
- +12 IF $DATA(^DIC(81.3,"BA",(LEXSO_" ")))
- QUIT "7^CPT Modifier Code"
- +13 QUIT ""
- DS(X) ; Trim Dubble Space Character
- +1 SET X=$GET(X)
- IF X'[" "
- QUIT X
- FOR
- IF X'[" "
- QUIT
- SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,299)
- +2 QUIT X
- PR(LEX,X) ; Parse Array
- +1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXI,LEXLEN,LEXC
- KILL ^UTILITY($JOB,"W")
- IF '$DATA(LEX)
- QUIT
- +2 SET LEXLEN=+($GET(X))
- IF +LEXLEN'>0
- SET LEXLEN=79
- SET LEXC=+($GET(LEX))
- IF +($GET(LEXC))'>0
- SET LEXC=$ORDER(LEX(" "),-1)
- IF +LEXC'>0
- QUIT
- +3 SET DIWL=1
- SET DIWF="C"_+LEXLEN
- SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEX(LEXI))
- IF +LEXI=0
- QUIT
- SET X=$GET(LEX(LEXI))
- DO ^DIWP
- +4 KILL LEX
- SET (LEXC,LEXI)=0
- FOR
- SET LEXI=$ORDER(^UTILITY($JOB,"W",1,LEXI))
- IF +LEXI=0
- QUIT
- Begin DoDot:1
- +5 SET LEX(LEXI)=$$TM($GET(^UTILITY($JOB,"W",1,LEXI,0))," ")
- SET LEXC=LEXC+1
- End DoDot:1
- +6 IF $LENGTH(LEXC)
- SET LEX=LEXC
- KILL ^UTILITY($JOB,"W")
- +7 QUIT
- 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
- OK(X,Y,LEX,LEXS) ; User Input is Ok
- +1 NEW LEXIX,LEXX,LEXO,LEXCT,LEXNX,LEXROOT
- +2 SET (LEXCT,LEXX)=$TRANSLATE($GET(X),"#","")
- IF $LENGTH(LEXX)'>0
- QUIT 0
- SET LEXROOT=$GET(Y)
- SET LEXIX=$GET(LEX)
- SET LEXS=+($GET(LEXS))
- +3 IF '$LENGTH(LEXROOT)
- QUIT 0
- IF "^D^AD^BA^ABA^C^"'[("^"_LEXIX_"^")
- QUIT 0
- +4 SET LEXO=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))_$CHAR(($ASCII($EXTRACT(LEXX,$LENGTH(LEXX)))-1))_"~"
- +5 IF +LEXS'>0
- SET LEXNX=$ORDER(@(LEXROOT_""""_LEXIX_""","""_LEXO_""")"))
- +6 IF +LEXS>0
- SET LEXNX=$ORDER(@(LEXROOT_""""_LEXIX_""","_+LEXS_","""_LEXO_""")"))
- +7 IF $EXTRACT(LEXNX,1,$LENGTH(LEXCT))=LEXCT
- QUIT 1
- +8 QUIT 0
- TOKN(X) ; Parse Tolkens
- +1 NEW LEXX,LEXBEG,LEXEND,LEXCHR,LEXTTK,LEXTKN,LEXNOT
- KILL LEXTKNS
- SET LEXX=$GET(X)
- SET LEXBEG=1
- SET LEXTTK=0
- +2 SET LEXNOT="^AND^THE^THEN^FOR^FROM^OTHER^THAN^WITH^THEIR^SOME^THIS^"
- FOR LEXEND=1:1:$LENGTH(LEXX)+1
- Begin DoDot:1
- +3 SET LEXCHR=$EXTRACT(LEXX,LEXEND)
- IF "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXCHR
- Begin DoDot:2
- +4 SET LEXTKN=$EXTRACT(LEXX,LEXBEG,LEXEND-1)
- SET LEXBEG=LEXEND+1
- IF $LENGTH(LEXTKN)>2
- IF $LENGTH(LEXTKN)<31
- IF LEXNOT'[LEXTKN
- Begin DoDot:3
- +5 IF '$DATA(LEXTKNS($LENGTH(LEXTKN),LEXTKN))
- SET LEXTTK=+($GET(LEXTTK))+1
- +6 SET LEXTKNS($LENGTH(LEXTKN),LEXTKN)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +7 SET X=+($GET(LEXTTK))
- +8 QUIT X
- SHO ; Show TMP
- +1 NEW LEXNN,LEXNC
- SET LEXNN="^TMP(""LEXQL"","_$JOB_")"
- SET LEXNC="^TMP(""LEXQL"","_$JOB_","
- +2 WRITE !
- FOR
- SET LEXNN=$QUERY(@LEXNN)
- IF '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
- QUIT
- WRITE !,LEXNN,"=",@LEXNN
- +3 WRITE !
- +4 QUIT
