source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI7.m@ 1407

Last change on this file since 1407 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 6.5 KB
Line 
1LEXXFI7 ; ISL/KER - File Info - Prompts and Header ; 02/22/2007
2 ;;2.0;LEXICON UTILITY;**32,49**;Sep 23, 1996;Build 3
3 Q
4 ;
5 ; Global Variables
6 ; ^%ZOSF("UCI") DBIA 10096
7 ; ^%ZOSF("PROD") DBIA 10096
8 ;
9 ; External References
10 ; DBIA 10026 ^DIR
11 ; DBIA 10103 $$FMTE^XLFDT
12 ; DBIA 10103 $$NOW^XLFDT
13 ; DBIA 2056 $$GET1^DIQ (file #200)
14 ; DBIA 10096 ^%ZOSF("UCI")
15 ; DBIA 10096 ^%ZOSF("PROD")
16 ;
17MT(X) ; Method - One or All Files
18 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
19 S DIR(0)="SAO^O:Checksum for ONE file;A:Checksum for ALL files (LEX/ICD/CPT)"
20 S DIR("A",1)=" Compute Checksum for:",DIR("A",2)=" "
21 S DIR("A",3)=" One Lexicon, ICD or CPT file"
22 S DIR("A",4)=" All Lexicon, ICD or CPT files (757*/80*/81*)"
23 S DIR("A",5)=" ",DIR("A")=" Select One or All: (O/A) "
24 S DIR("B")="O",(DIR("?"),DIR("??"))="^D MTH^LEXXFI7"
25 W ! D ^DIR S X=$S(Y="O":"ONE",Y="A":"ALL",1:"")
26 Q X
27MTH ; Method Help
28 W !," Do you wish to compute the checksum for a single Lexicon, ICD"
29 W !," or CPT file or all Lexicon, ICD and CPT files (757*/80*/81*)"
30 W:$G(X)["??" !," Answer either 'O'ne or 'A'll or '^' to exit"
31 Q
32 ;
33CC(X) ; Checksum AND Count
34 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
35 S DIR(0)="YAO",DIR("A")=" Include a Record Count with the Checksum? (Y/N) "
36 S DIR("B")="N",(DIR("?"),DIR("??"))="^D CCH^LEXXFI7"
37 W ! D ^DIR S X=$S(+Y>0:1,1:0)
38 Q X
39CCH ; Checksum AND Count Help
40 W !," Answer 'Yes' to include a count of the total the number of records"
41 W !," in the file/sub-file along with the checksum"
42 Q
43 ;
44FI(X) ; Select Lexicon/ICD File
45 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
46 S DIR(0)="FAO^1:45"
47 S DIR("A")=" Select File: "
48 S (DIR("?"),DIR("??"))="^D FIH^LEXXFI7" D ^DIR S X=$$FOT(Y)
49 Q X
50FIH ; File Help
51 W !," Select either a Lexicon, ICD or CPT file:"
52 W !!," Lexicon ICD CPT"
53 W !," ---------------------------------------- ---- ----"
54 W !," 757 757.03 757.12 757.31 80 81"
55 W !," 757.001 757.03 757.13 757.4 80.1 81.1"
56 W !," 757.01 757.05 757.14 757.41 80.3 81.2"
57 W !," 757.011 757.06 757.2 81.3"
58 W !," 757.014 757.1 757.21"
59 W !," 757.02 757.11 757.3 "
60 Q
61FOT(X) ; File Output Transform
62 N LEX,LEXX
63 S LEXX=$G(X) Q:'$L(X) "^" D ARY(LEXX,.LEX)
64 S:+($G(LEX(0)))=1 LEXX=$$ONE(X,.LEX)
65 S:+($G(LEX(0)))>1 LEXX=$$MULT(X,.LEX)
66 S X=$S(+LEXX>0:+LEXX,1:"^")
67 Q X
68ONE(X,LEX) ; One Entry
69 S X=+($G(LEX(1)))
70 I $L($P($G(LEX(1)),"^",2)),+X>0 D
71 . W " ",$P($G(LEX(1)),"^",2)," (#",+X,")"
72 Q:+X'>0 "^" Q X
73MULT(X,LEX) ; Multiple Entries
74 N LEXE,LEXEX,LEXFI,LEXI,LEXM,LEXMAX,LEXNAM,LEXS
75 S LEXMAX=$G(LEX(0)) Q:+LEXMAX'>1 W ! W !," ",LEXMAX," matches found"
76 S LEXS=0,LEXEX=0 F LEXI=1:1:LEXMAX Q:((LEXS>0)&(LEXS<LEXI+1)) Q:LEXEX D Q:LEXEX
77 . S LEXE=$G(LEX(LEXI)),LEXNAM=$P(LEXE,"^",2),LEXFI=+LEXE Q:'$L(LEXNAM) Q:+LEXFI'>0 S LEXM=LEXI
78 . W:LEXI#5=1 ! W !," ",$J(LEXI,4),". ",LEXNAM," (#",+LEXFI,")"
79 . W:LEXI#5=0 ! S:LEXI#5=0 LEXS=$$SEL(LEXM,.LEX) S:LEXS["^" LEXEX=1
80 I LEXI#5'=0,+LEXS=0 W ! S LEXS=$$SEL(LEXM,.LEX) S:LEXS["^" LEXEX=1
81 S X="^" S:'LEXEX&(+LEXS>0) X=+LEXS S:+X'>0 X="^"
82 Q X
83SEL(X,LEX) ; Select Multiple
84 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXM,Y S LEXM=+($G(X)) Q:LEXM=0 -1
85 S:+($O(LEX(+($G(LEXI)))))>0 DIR("A")=" Select 1-"_LEXM_" or '^' to exit: "
86 S:+($O(LEX(+($G(LEXI)))))'>0 DIR("A")=" Select 1-"_LEXM_": "
87 S (DIR("?"),DIR("??"))="Answer must be from 1 to "_LEXM_", or <Return> to continue "
88 S DIR(0)="NAO^1:"_LEXM_":0" D ^DIR S X="" S:$D(DTOUT)!(X[U) X=U
89 I $L($P($G(LEX(+Y)),"^",2)),+($G(LEX(+Y)))>0 D
90 . W " ",$P($G(LEX(+Y)),"^",2)," (#",+($G(LEX(+Y))),")"
91 . S X=+($G(LEX(+Y)))
92 Q X
93ARY(X,LEX) ; Build Array of Files
94 N LEXF,LEXNM,LEXO,LEXX,Y
95 S LEXX=$TR($G(X),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") N X,Y
96 Q:'$L(LEXX) "" I +LEXX=LEXX D Q
97 . N LEXO,LEXN,LEXC S LEXO=LEXX-.00000001
98 . F S LEXO=$O(@("^DIC("_LEXO_")")) Q:+LEXO=0!($E(LEXO,1,$L(LEXX))'=LEXX) D
99 . . N LEXNM S LEXNM=$$FN^LEXXFI8(LEXO) Q:'$L(LEXNM) S LEX(0)=($O(LEX(" "),-1)+1),LEX(+LEX(0))=+LEXO_"^"_LEXNM
100 S LEXO=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~"
101 F S LEXO=$O(@("^DIC(""B"","_LEXO_")")) Q:LEXO="" Q:$E(LEXO,1,$L(LEXX))'[LEXX D
102 . S LEXF=0 F S LEXF=$O(@("^DIC(""B"","_LEXO_","_LEXF_")")) Q:+LEXF'>0 D
103 . . Q:+($$LEX^LEXXFI8(LEXF))'>0&(+($$IC^LEXXFI8(LEXF))'>0) N LEXNM S LEXNM=$$FN^LEXXFI8(LEXF)
104 . . Q:'$L(LEXNM) S LEX(0)=($O(LEX(" "),-1)+1),LEX(+LEX(0))=+LEXF_"^"_LEXNM
105 Q
106 ;
107 ; Miscellaneous
108U(X) ; UCI where Lexicon is installed
109 N LEXU,LEXP,LEXT,Y X ^%ZOSF("UCI") S LEXU=Y,LEXP="" S:LEXU=^%ZOSF("PROD")!($P(LEXU,",",1)=^%ZOSF("PROD")) LEXP=" (Production)"
110 S:LEXU'=^%ZOSF("PROD")&($P(LEXU,",",1)'=^%ZOSF("PROD")) LEXP=" (Test)" S X="",$P(X,"^",1)=LEXU,$P(X,"^",2)=LEXP
111 Q X
112A(X) ; As of date/time
113 N LEXX S LEXX=$$NOW^XLFDT,LEXX=$$FMTE^XLFDT(LEXX,"1")
114 S:LEXX["@" LEXX=$P(LEXX,"@",1)_" "_$P(LEXX,"@",2,299)
115 S X=LEXX
116 Q X
117P(X) ; Person
118 N LEXDUZ,LEXPH,LEXNM
119 S LEXDUZ=+($G(DUZ)),LEXNM=$$GET1^DIQ(200,+($G(LEXDUZ)),.01) Q:'$L(LEXNM) "UNKNOWN^"
120 S LEXDUZ=+($G(DUZ)) S LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.132)
121 S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.133)
122 S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.134)
123 S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.135)
124 S LEXDUZ=$$PM(LEXNM)
125 S X=LEXDUZ_"^"_LEXPH
126 Q X
127PM(X) ; Person, Mixed Case
128 N LEXF,LEXL,LEXP S LEXP=$G(X),LEXL=$$MX($P(LEXP,",",1)),LEXF=$P(LEXP,",",2)
129 S LEXL(1)=$$MX($P(LEXL,"-",1)),LEXL(2)=$$MX($P(LEXL(1)," ",2,2)),LEXL(1)=$$MX($P(LEXL(1)," ",1))
130 S:$L(LEXL(1))&($L(LEXL(2))) LEXL(1)=LEXL(1)_" "_LEXL(2)
131 S LEXL(3)=$$MX($P(LEXL,"-",2)),LEXL(4)=$$MX($P(LEXL(3)," ",2,2)),LEXL(3)=$$MX($P(LEXL(3)," ",1))
132 S:$L(LEXL(3))&($L(LEXL(4))) LEXL(3)=LEXL(3)_" "_LEXL(4)
133 S LEXL=LEXL(1) S:$L(LEXL(1))&($L(LEXL(3))) LEXL=LEXL(1)_"-"_LEXL(3)
134 S LEXF=$$MX($P(LEXP,",",1)),LEXF=$P(LEXP,",",2)
135 S LEXF(1)=$$MX($P(LEXF,"-",1)),LEXF(2)=$$MX($P(LEXF(1)," ",2,2)),LEXF(1)=$$MX($P(LEXF(1)," ",1))
136 S:$L(LEXF(1))&($L(LEXF(2))) LEXF(1)=LEXF(1)_" "_LEXF(2)
137 S LEXF(3)=$$MX($P(LEXF,"-",2)),LEXF(4)=$$MX($P(LEXF(3)," ",2,2)),LEXF(3)=$$MX($P(LEXF(3)," ",1))
138 S:$L(LEXF(3))&($L(LEXF(4))) LEXF(3)=LEXF(3)_" "_LEXF(4)
139 S LEXF=LEXF(1) S:$L(LEXF(1))&($L(LEXF(3))) LEXF=LEXF(1)_"-"_LEXF(3)
140 S LEXP=LEXL_", "_LEXF,X=LEXP
141 Q X
142MX(X) ; Mix Case
143 Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
Note: See TracBrowser for help on using the repository browser.