144 lines
6.5 KiB
Mathematica
144 lines
6.5 KiB
Mathematica
LEXXFI7 ; ISL/KER - File Info - Prompts and Header ; 02/22/2007
|
|
;;2.0;LEXICON UTILITY;**32,49**;Sep 23, 1996;Build 3
|
|
Q
|
|
;
|
|
; Global Variables
|
|
; ^%ZOSF("UCI") DBIA 10096
|
|
; ^%ZOSF("PROD") DBIA 10096
|
|
;
|
|
; External References
|
|
; DBIA 10026 ^DIR
|
|
; DBIA 10103 $$FMTE^XLFDT
|
|
; DBIA 10103 $$NOW^XLFDT
|
|
; DBIA 2056 $$GET1^DIQ (file #200)
|
|
; DBIA 10096 ^%ZOSF("UCI")
|
|
; DBIA 10096 ^%ZOSF("PROD")
|
|
;
|
|
MT(X) ; Method - One or All Files
|
|
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
|
|
S DIR(0)="SAO^O:Checksum for ONE file;A:Checksum for ALL files (LEX/ICD/CPT)"
|
|
S DIR("A",1)=" Compute Checksum for:",DIR("A",2)=" "
|
|
S DIR("A",3)=" One Lexicon, ICD or CPT file"
|
|
S DIR("A",4)=" All Lexicon, ICD or CPT files (757*/80*/81*)"
|
|
S DIR("A",5)=" ",DIR("A")=" Select One or All: (O/A) "
|
|
S DIR("B")="O",(DIR("?"),DIR("??"))="^D MTH^LEXXFI7"
|
|
W ! D ^DIR S X=$S(Y="O":"ONE",Y="A":"ALL",1:"")
|
|
Q X
|
|
MTH ; Method Help
|
|
W !," Do you wish to compute the checksum for a single Lexicon, ICD"
|
|
W !," or CPT file or all Lexicon, ICD and CPT files (757*/80*/81*)"
|
|
W:$G(X)["??" !," Answer either 'O'ne or 'A'll or '^' to exit"
|
|
Q
|
|
;
|
|
CC(X) ; Checksum AND Count
|
|
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
|
|
S DIR(0)="YAO",DIR("A")=" Include a Record Count with the Checksum? (Y/N) "
|
|
S DIR("B")="N",(DIR("?"),DIR("??"))="^D CCH^LEXXFI7"
|
|
W ! D ^DIR S X=$S(+Y>0:1,1:0)
|
|
Q X
|
|
CCH ; Checksum AND Count Help
|
|
W !," Answer 'Yes' to include a count of the total the number of records"
|
|
W !," in the file/sub-file along with the checksum"
|
|
Q
|
|
;
|
|
FI(X) ; Select Lexicon/ICD File
|
|
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
|
|
S DIR(0)="FAO^1:45"
|
|
S DIR("A")=" Select File: "
|
|
S (DIR("?"),DIR("??"))="^D FIH^LEXXFI7" D ^DIR S X=$$FOT(Y)
|
|
Q X
|
|
FIH ; File Help
|
|
W !," Select either a Lexicon, ICD or CPT file:"
|
|
W !!," Lexicon ICD CPT"
|
|
W !," ---------------------------------------- ---- ----"
|
|
W !," 757 757.03 757.12 757.31 80 81"
|
|
W !," 757.001 757.03 757.13 757.4 80.1 81.1"
|
|
W !," 757.01 757.05 757.14 757.41 80.3 81.2"
|
|
W !," 757.011 757.06 757.2 81.3"
|
|
W !," 757.014 757.1 757.21"
|
|
W !," 757.02 757.11 757.3 "
|
|
Q
|
|
FOT(X) ; File Output Transform
|
|
N LEX,LEXX
|
|
S LEXX=$G(X) Q:'$L(X) "^" D ARY(LEXX,.LEX)
|
|
S:+($G(LEX(0)))=1 LEXX=$$ONE(X,.LEX)
|
|
S:+($G(LEX(0)))>1 LEXX=$$MULT(X,.LEX)
|
|
S X=$S(+LEXX>0:+LEXX,1:"^")
|
|
Q X
|
|
ONE(X,LEX) ; One Entry
|
|
S X=+($G(LEX(1)))
|
|
I $L($P($G(LEX(1)),"^",2)),+X>0 D
|
|
. W " ",$P($G(LEX(1)),"^",2)," (#",+X,")"
|
|
Q:+X'>0 "^" Q X
|
|
MULT(X,LEX) ; Multiple Entries
|
|
N LEXE,LEXEX,LEXFI,LEXI,LEXM,LEXMAX,LEXNAM,LEXS
|
|
S LEXMAX=$G(LEX(0)) Q:+LEXMAX'>1 W ! W !," ",LEXMAX," matches found"
|
|
S LEXS=0,LEXEX=0 F LEXI=1:1:LEXMAX Q:((LEXS>0)&(LEXS<LEXI+1)) Q:LEXEX D Q:LEXEX
|
|
. S LEXE=$G(LEX(LEXI)),LEXNAM=$P(LEXE,"^",2),LEXFI=+LEXE Q:'$L(LEXNAM) Q:+LEXFI'>0 S LEXM=LEXI
|
|
. W:LEXI#5=1 ! W !," ",$J(LEXI,4),". ",LEXNAM," (#",+LEXFI,")"
|
|
. W:LEXI#5=0 ! S:LEXI#5=0 LEXS=$$SEL(LEXM,.LEX) S:LEXS["^" LEXEX=1
|
|
I LEXI#5'=0,+LEXS=0 W ! S LEXS=$$SEL(LEXM,.LEX) S:LEXS["^" LEXEX=1
|
|
S X="^" S:'LEXEX&(+LEXS>0) X=+LEXS S:+X'>0 X="^"
|
|
Q X
|
|
SEL(X,LEX) ; Select Multiple
|
|
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXM,Y S LEXM=+($G(X)) Q:LEXM=0 -1
|
|
S:+($O(LEX(+($G(LEXI)))))>0 DIR("A")=" Select 1-"_LEXM_" or '^' to exit: "
|
|
S:+($O(LEX(+($G(LEXI)))))'>0 DIR("A")=" Select 1-"_LEXM_": "
|
|
S (DIR("?"),DIR("??"))="Answer must be from 1 to "_LEXM_", or <Return> to continue "
|
|
S DIR(0)="NAO^1:"_LEXM_":0" D ^DIR S X="" S:$D(DTOUT)!(X[U) X=U
|
|
I $L($P($G(LEX(+Y)),"^",2)),+($G(LEX(+Y)))>0 D
|
|
. W " ",$P($G(LEX(+Y)),"^",2)," (#",+($G(LEX(+Y))),")"
|
|
. S X=+($G(LEX(+Y)))
|
|
Q X
|
|
ARY(X,LEX) ; Build Array of Files
|
|
N LEXF,LEXNM,LEXO,LEXX,Y
|
|
S LEXX=$TR($G(X),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") N X,Y
|
|
Q:'$L(LEXX) "" I +LEXX=LEXX D Q
|
|
. N LEXO,LEXN,LEXC S LEXO=LEXX-.00000001
|
|
. F S LEXO=$O(@("^DIC("_LEXO_")")) Q:+LEXO=0!($E(LEXO,1,$L(LEXX))'=LEXX) D
|
|
. . N LEXNM S LEXNM=$$FN^LEXXFI8(LEXO) Q:'$L(LEXNM) S LEX(0)=($O(LEX(" "),-1)+1),LEX(+LEX(0))=+LEXO_"^"_LEXNM
|
|
S LEXO=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~"
|
|
F S LEXO=$O(@("^DIC(""B"","_LEXO_")")) Q:LEXO="" Q:$E(LEXO,1,$L(LEXX))'[LEXX D
|
|
. S LEXF=0 F S LEXF=$O(@("^DIC(""B"","_LEXO_","_LEXF_")")) Q:+LEXF'>0 D
|
|
. . Q:+($$LEX^LEXXFI8(LEXF))'>0&(+($$IC^LEXXFI8(LEXF))'>0) N LEXNM S LEXNM=$$FN^LEXXFI8(LEXF)
|
|
. . Q:'$L(LEXNM) S LEX(0)=($O(LEX(" "),-1)+1),LEX(+LEX(0))=+LEXF_"^"_LEXNM
|
|
Q
|
|
;
|
|
; Miscellaneous
|
|
U(X) ; UCI where Lexicon is installed
|
|
N LEXU,LEXP,LEXT,Y X ^%ZOSF("UCI") S LEXU=Y,LEXP="" S:LEXU=^%ZOSF("PROD")!($P(LEXU,",",1)=^%ZOSF("PROD")) LEXP=" (Production)"
|
|
S:LEXU'=^%ZOSF("PROD")&($P(LEXU,",",1)'=^%ZOSF("PROD")) LEXP=" (Test)" S X="",$P(X,"^",1)=LEXU,$P(X,"^",2)=LEXP
|
|
Q X
|
|
A(X) ; As of date/time
|
|
N LEXX S LEXX=$$NOW^XLFDT,LEXX=$$FMTE^XLFDT(LEXX,"1")
|
|
S:LEXX["@" LEXX=$P(LEXX,"@",1)_" "_$P(LEXX,"@",2,299)
|
|
S X=LEXX
|
|
Q X
|
|
P(X) ; Person
|
|
N LEXDUZ,LEXPH,LEXNM
|
|
S LEXDUZ=+($G(DUZ)),LEXNM=$$GET1^DIQ(200,+($G(LEXDUZ)),.01) Q:'$L(LEXNM) "UNKNOWN^"
|
|
S LEXDUZ=+($G(DUZ)) S LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.132)
|
|
S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.133)
|
|
S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.134)
|
|
S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.135)
|
|
S LEXDUZ=$$PM(LEXNM)
|
|
S X=LEXDUZ_"^"_LEXPH
|
|
Q X
|
|
PM(X) ; Person, Mixed Case
|
|
N LEXF,LEXL,LEXP S LEXP=$G(X),LEXL=$$MX($P(LEXP,",",1)),LEXF=$P(LEXP,",",2)
|
|
S LEXL(1)=$$MX($P(LEXL,"-",1)),LEXL(2)=$$MX($P(LEXL(1)," ",2,2)),LEXL(1)=$$MX($P(LEXL(1)," ",1))
|
|
S:$L(LEXL(1))&($L(LEXL(2))) LEXL(1)=LEXL(1)_" "_LEXL(2)
|
|
S LEXL(3)=$$MX($P(LEXL,"-",2)),LEXL(4)=$$MX($P(LEXL(3)," ",2,2)),LEXL(3)=$$MX($P(LEXL(3)," ",1))
|
|
S:$L(LEXL(3))&($L(LEXL(4))) LEXL(3)=LEXL(3)_" "_LEXL(4)
|
|
S LEXL=LEXL(1) S:$L(LEXL(1))&($L(LEXL(3))) LEXL=LEXL(1)_"-"_LEXL(3)
|
|
S LEXF=$$MX($P(LEXP,",",1)),LEXF=$P(LEXP,",",2)
|
|
S LEXF(1)=$$MX($P(LEXF,"-",1)),LEXF(2)=$$MX($P(LEXF(1)," ",2,2)),LEXF(1)=$$MX($P(LEXF(1)," ",1))
|
|
S:$L(LEXF(1))&($L(LEXF(2))) LEXF(1)=LEXF(1)_" "_LEXF(2)
|
|
S LEXF(3)=$$MX($P(LEXF,"-",2)),LEXF(4)=$$MX($P(LEXF(3)," ",2,2)),LEXF(3)=$$MX($P(LEXF(3)," ",1))
|
|
S:$L(LEXF(3))&($L(LEXF(4))) LEXF(3)=LEXF(3)_" "_LEXF(4)
|
|
S LEXF=LEXF(1) S:$L(LEXF(1))&($L(LEXF(3))) LEXF=LEXF(1)_"-"_LEXF(3)
|
|
S LEXP=LEXL_", "_LEXF,X=LEXP
|
|
Q X
|
|
MX(X) ; Mix Case
|
|
Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
|