source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DMSQU.m@ 846

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

initial load of WorldVistAEHR

File size: 8.7 KB
Line 
1DMSQU ;SFISC/JHM-SQLI UTILITIES ;5/13/98 12:03
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5SOC(T,B) ;TRANSLATE BASE CODE B TO EXTERNAL FORM FROM TEXT T
6 Q $P($P(T,";"_B_":",2),";")
7NEW() ;Extrinsic function returns comma-list of variables to NEW
8 Q "DI,DIQUIET,DIFM"
9ENV Q:$G(DUZ(0))'["@"
10 K ERR I $G(DIFM),$G(U)="^",$G(DT),$D(DUZ) D CLEAN^DIEFU Q
11 S DIQUIET=1,DIFM=1 D INIZE^DIEFU
12 Q
13EXT(F,FI,FLG,INT,MSG) ;SQLI ENTRY TO EXTERNAL^DILFD
14 D ENV Q $$EXTERNAL^DILFD(F,FI,FLG,INT,$G(MSG))
15GET(F,IEN,FI,FLG,BUF,MSG) ;SQLI ENTRY TO GET1^DIQ
16 D ENV Q $$GET1^DIQ(F,IEN,FI,$G(FLG),$G(BUF),$G(MSG))
17CLF(S) D ENV N X
18 S X=$P($G(^DMSQ(S,0)),"^",1,2)_"^" I X'="^" K ^DMSQ(S) S ^DMSQ(S,0)=X
19 Q
20CLN D CLF("DT"),CLF("DM") Q
21VIEN(TI) ;RETURN VIRTUAL IENS FOR TI
22 N I,S S S=""
23 F I=$L(^DMSQ("T",TI,1),"{K}")-1:-1:1 S S=S_"{K"_I_"},"
24 Q S
25ET(T) ;REPORT ELAPSED TIME SINCE T ($H FORMAT)
26 W ?30,"Time elapsed: ",$$TM($$TD(T,$H))," (HH:MM:SS)"
27 Q
28TD(T,N) ;RETURNS TIME DIFERENCE OF N(OW)-T(HEN) $H FORMATS
29 Q N-T*86400+$P(N,",",2)-$P(T,",",2)
30TM(S) ;RETURN TEXT VALUE OF TIME S SECONDS AS HH:MM:SS
31 Q $E(S\3600+100,2,3)_":"_$E(S\60#60+100,2,3)_":"_$E(S#60+100,2,3)
32PAR(TI,NP,G,P,E) ;GET PARENT, GBL FRAGMENT, AND PIECE OR EXTRACT
33 ;CALLED: S PAR=$$PAR^DMSQU(TABLE_ID,NODE;PIECE,.GBL_FRAG,.PC,.EX)
34 N PEI,PI,SQ,CI,E1,E2 D ENV
35 S PEI=$O(^DMSQ("E","F",TI,"P","")) Q:'PEI ""
36 S SQ=$O(^DMSQ("P","C",PEI,""),-1) Q:'SQ ""
37 S PI=$O(^DMSQ("P","C",PEI,SQ,"")),CI=$P(^DMSQ("P",PI,0),U,2)
38 S G=","_$$SS($P(NP,";"))_")",E=""
39 S P=$P(NP,";",2) I P'["E" S:P]"" P=+P
40 E S E=+$P(P,"E",2)_","_(+$P(NP,",",2)),P=""
41 Q CI
42ERR(F,FI,T) ;ERROR LOGGER
43 N TI,EI,FE S FE=$G(ERR("DIERR",1)) D ENV
44 I T?1NN,$D(^DMSQ("ET",T)) S TI=T
45 E S TI=$O(^DMSQ("ET","B",T,"")) I 'TI D
46 . F TI=$P($G(^DMSQ("ET",0)),U,4)+1:1 Q:'$D(^(TI))
47 . S $P(^DMSQ("ET",0),U,3,4)=TI_U_TI,^(TI,0)=T,^DMSQ("ET","B",T,TI)=""
48 S EI=$P($G(^DMSQ("EX",0)),U,4)+1,$P(^(0),U,3,4)=EI_U_EI
49 S ^DMSQ("EX",EI,0)=F_U_FI_U_TI_U_DT_U_FE,^DMSQ("EX","B",F,EI)=""
50 S ^DMSQ("EX","C",TI,EI)="",^DMSQ("EX","D",DT,EI)=""
51 I FE S ^DMSQ("EX","E",FE,EI)=""
52 Q
53ATTR ;;TYPE;FIELD LENGTH;DECIMAL DEFAULT;INPUT TRANSFORM;GLOBAL SUBSCRIPT LOCATION;POINTER;TITLE;SPECIFIER;DESCRIPTION;MULTIPLE-VALUED;LABEL
54DOM(F,FI,DEF,ERR) ;GET FIELD ATTRIBUTES - DEF AND ERR ARE OPTIONAL
55 ;RETURNS DOMAIN:WIDTH:SCALE ALLWAYS, ARRAYS DEF AND ERR OPTIONALLY
56 N T,W,S,X K DEF D ENV
57 I '$D(^DD(F,FI,0))#10 Q ""
58 D FIELD^DID(F,FI,"",$P($T(ATTR),";;",2),"DEF","ERR")
59 I $D(ERR)!$D(DIERR) D Q T
60 . S T=$$DM(F,FI,.DEF) I T]"" D ENV,ERR(F,FI,"FIELD: CALL TO RETRIEVE ATTRIBUTES FAILED")
61 S T=DEF("TYPE"),W=DEF("FIELD LENGTH"),S=DEF("DECIMAL DEFAULT")
62 S:W W=+W S:S?1N.E S=+S
63 S I=DEF("INPUT TRANSFORM"),W=$S(I["$L(X)>":+$P(I,"$L(X)>",2),1:W)
64 I T["MUMPS" S W=245,T="FM_MUMPS"
65 E I T["SET" S T="SET_OF_CODES"
66 E I T["DATE/TIME" D
67 . S X=$P($P(DEF("INPUT TRANSFORM"),"%DT=""",2),"""")
68 . S T=$S(X["R":"FM_DATE_TIME",X["T":"FM_MOMENT",1:"FM_DATE")
69 E I T["NUMERIC",'S S T="INTEGER",S=""
70 E I T["FREE TEXT" S T="CHARACTER"
71 E I T["COMPUTED" S T=$S(S:"NUMERIC",S=0:"INTEGER",1:"CHARACTER")
72 E I T["BOOLEAN" S T="FM_FLAG"
73 E I T["VARIABLE-POINTER" S T="VARIABLE_POINTER"
74 E I T["POINTER" S T="POINTER"
75 E I T["WORD-PROCESSING" S T="WORD_PROCESSING",W=80
76 S F=$G(DEF("DESCRIPTION",1)) K DEF("DESCRIPTION")
77 S DEF("DESCRIPTION")=$P(F,".")
78 Q T_U_W_U_S
79DM(F,FI,DEF) ;BUILD META-DATA FOR ONE FIELD (USE WHEN FIELD^DID FAILS!!)
80 D ENV N CK,H,IT,SP,P,D,EX,LD,DP,TYP,DM,X
81 K DEF S H=$G(^DD(F,FI,0)) Q:H="" ""
82 S DEF("LABEL")=$P(H,U),(PE,DEF("GLOBAL SUBSCRIPT LOCATION"))=$P(H,U,4)
83 S (IT,DEF("INPUT TRANSFORM"))=$P(H,U,5),(SP,DEF("SPECIFIER"))=$P(H,U,2)
84 S DEF("DESCRIPTION")=$P($G(^DD(F,FI,21,1,0)),".")
85 S (P,DEF("POINTER"))=$P(H,U,3),DEF("MULTIPLE-VALUED")=SP["M"!SP
86 S D=$TR(SP,"aeAIMOn'X*","") ;IGNORE CHILD DESCRIPTORS
87 S EX=$P($P(PE,";",2),"E",2)
88 I EX F I=1:1 I $E(EX,I)?.A S EX=$E(EX,1,I-1) Q
89 S LD=$P(D,"J",2),DP=+$P(LD,",",2) I LD,'DP S LD=+LD
90 I LD="" S CK=$P(IT,"$L(X)>",2) I CK S LD=+CK
91 I LD="",$P(EX,",",2) S LD=$P(EX,",",2)-EX+1
92 S:DP LD=(+LD)_U_DP,DEF("DECIMAL DEFAULT")=DP
93 I LD S DEF("FIELD LENGTH")=+LD,LD=U_LD
94 S TYP=$S(DP:"N",D["N":"I",D["D":"D",D["P":"P",D["V":"V",D["B":"B",D["K":"K",D["S":"S",D["W":"W",1:"F")
95 I TYP="N" S DM="NUMERIC"_LD,DEF("TYPE")="NUMERIC"
96 E I TYP="W" D
97 . S DM="WORD_PROCESSING",LD="^80",DEF("TYPE")="WORD-PROCESSING"
98 E I TYP="P" S DM="POINTER",LD="^10",DEF("TYPE")="POINTER"
99 E I TYP="S" D S DM="SET_OF_CODES"_LD,DEF("TYPE")="SET"
100 . N I,X,W S W=1
101 . F I=1:1:$L(P,":") S X=$L($P($P(";"_P,":",I),";",2)) S:X>W W=X
102 . S LD=U_W
103 E I TYP="I" S DM="INTEGER"_LD,DEF("TYPE")="NUMERIC"
104 E I TYP="V" S DM="VARIABLE_POINTER",DEF("TYPE")="VARIABLE-POINTER"
105 E I TYP="B" S DM="FM_FLAG",DEF("TYPE")="BOOLEAN"
106 E I TYP="D" S X=$P($P($P(H,"^",5),"%DT=",2),"""",2) D
107 . I X'["T",X'["R" S DM="FM_DATE"
108 . E I X["R" S DM="FM_DATE_TIME"
109 . E S DM="FM_MOMENT"
110 . S DEF("TYPE")="DATE"
111 E I TYP="K" S DM="FM_MUMPS^245",DEF("TYPE")="MUMPS"
112 E S DM="CHARACTER"_$S(LD]"":LD,1:"(80)"),DEF("TYPE")="FREE TEXT"
113 Q DM
114KL(TI) ;RETURN IEN LIST OF TABLE
115 N KL,P S KL=TI
116 F S P=$G(^DD(TI,0,"UP")) Q:P="" S KL=P_","_KL,TI=P
117 Q KL
118PUT(I,A,E) ;FILE OR UPDATE
119 ;GIVEN I=IEN AND A=FDA ARRAY RETURN IEN AND ERR
120 K @E D ENV
121 I I?1N.E D
122 . D FILE^DIE("",A,E)
123 E D
124 . N O D UPDATE^DIE("",A,"O",E) S I=$G(O(1))
125 Q $S($D(@E):0,1:+I)
126KWC(N) ;RETURN N AS A NON-KEYWORD
127 I N]"",$D(^DMSQ("K","B",N)) N X,I S X=$$SQLI(N,25),N=X_1 D
128 . F I=2:1 Q:'$D(^DMSQ("K","B",N)) S N=X_I ; AVOID KEYWORDS
129 Q N
130FNB(F,TI) ;BUILD SQL FILE NAME
131 ;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
132 ;INPUT: F=FILEMAN FILE NUMBER, TI=SQLI IEN
133 ;OUTPUT: STANDARD SQLI TABLE LABEL, UNIQUE BY SCHEMA, AND NOT
134 ; A KEY WORD
135 N NM,F1,SP,P,I,X,J
136 S NM="",F1=F,SP="" F D Q:'P
137 . S P=$G(^DD(F1,0,"UP"))
138 . I P S NM=$O(^DD(F1,0,"NM",""))_SP_NM,SP="_",F1=P
139 S NM=$P($G(^DIC(F1,0)),"^")_SP_NM
140 I NM=""!(NM["__")!($E(NM,$L(NM))="_")!(NM?1"_".E) Q ""
141 F I=1:1:$L(NM,"_")-1 D
142 . S X=$P(NM,"_",I)
143 . F J=I+1:1:$L(NM,"_") S:$P(NM,"_",J)=X $P(NM,"_",J)=""
144 S NM=$$SQLI(NM,26)
145 F I=1:1 Q:'$D(^DMSQ("T","B",NM))!($O(^(NM,""))=TI) S NM=NM_I
146 Q $$KWC(NM)
147CN(T,C,N) ;BUILD COLUMN NAME N UNIQUE BY TABLE T, COLUMN ELEMENT C
148 ;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
149 ;INPUT: T=SQLI_TABLE EIN, C=SQLI_COLUMN EIN, N=FIELD NAME
150 ;FIELD NAME ARE GENERATED FOR PRIMARY AND FOREIGN KEY COLUMNS
151 ;OUTPUT: STANDARD SQLI COLUMN LABELS, UNIQUE BY TABLE, NOT KEYWORDS
152 N I,X,% I N]"" D
153 . S N=$$KWC($$SQLI(N,26)),%="",X=N
154 . F I=1:1 S %=$O(^DMSQ("E","G",T,N,"")) Q:%=C!'% S N=X_I
155 Q N
156SQLK(T,L) ;RETURN SQL IDENTIFIER NOT A KEYWORD
157 ;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
158 ;SEE $$SQLI FOR DESCRIPTION OF INPUT/OUTPUT
159 Q $$KWC($$SQLI(T,L))
160SQLI(T,L) ;RETURN VALID SQL IDENTIFIER OF LENGTH L OR LESS BASED ON T
161 ;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
162 ;INPUT: T=FREE TEXT, L=MAXIMUM OUTPUT LENGTH
163 ;OUTPUT: AN SQLI STANDARD SQL IDENTIFIER
164 N I,PL,T1
165 I $TR(T,"_")?.UN,$L(T)'>L G SQLIX ;SKIP PROCESSING FOR SIMPLE CASE
166 ;CONVERT LOWER TO UPPER CASE, MOST PUNCTUATION TO UNDERLINES
167 S T=$TR(T," -abcdefghijklmnopqrstuvwxyz!@#$%^&*()_-+=|\}]{[:;""'?/>.<,~`","__ABCDEFGHIJKLMNOPQRSTUVWXYZ_________________________________")
168 ;REMOVE DOUBLE UNDERLINES
169 F Q:T'["__" S T=$P(T,"__")_"_"_$P(T,"__",2,99)
170 I T?1"_".E S T=$E(T,2,999) ;REMOVE INITIAL UNDERLINE
171 I $E(T,$L(T))="_" S T=$E(T,1,$L(T)-1) ;REMOVE TRAILING UNDERLINE
172 ;COMPRESSION
173 I $L(T)>L D
174 . S PL=$L(T,"_") ;1) REDUCE SIZE OF _ PIECES
175 . F I=PL-1:-1:2,PL,1 S $P(T,"_",I)=$$SQZ($P(T,"_",I)) Q:$L(T)'>L
176 ;2) CONVERT _ PIECES TO INITIAL LETTERS
177 I $L(T)>L F I=PL-1:-1:2,PL,1 S $P(T,"_",I)=$E($P(T,"_",I)) Q:$L(T)'>L
178 ;3) COMPRESS OVERHANG INTO ONE ALPHA-NUMBERIC CHARACTER
179 I $L(T)>L S T=$E(T,1,L-1)_$TR($E(T,L,999),"_")
180SQLIX F Q:$E(T,$L(T))'="_" S $E(T,$L(T))="" ;REMOVE TRAILING _S
181 F Q:$E(T)'="_" S $E(T)="" ;REMOVE LEADING _S
182 I T?1N.E S T="N"_T ;AVOID INITIAL DIGIT
183 I $L(T)>L S T=$E(T,1,$S($E(T,L)="_":L-1,1:L)) ;4) JUST TRUNCATE IT
184 Q T
185SQZ(T) ;RETURN MNEMONIC VALUE OF T
186 I $L(T)>5 S T=$E(T,1,4) S:"AEIOU"[$E(T,4) T=$E(T,1,3)
187 Q T
188ROOT(F) ;GET GLOBAL NAME SYNTAX FOR A SUBFILE (F)
189 N G,P,FI
190 S G="{K})" F D Q:G["^"
191 . S P=$G(^DD(F,0,"UP"))
192 . I P D
193 . . S FI=$O(^DD(P,"SB",F,""))
194 . . I FI S F=P,G="{K},"_$$SS($P($P(^DD(F,FI,0),"^",4),";"))_","_G
195 . . E S G="^"
196 . E I $D(^DIC(F,0,"GL")) S G=^("GL")_G
197 . E S G="^"
198 Q G
199SS(T) ;CONVERT T TO A VALID SUBSCRIPT (QUOTES)
200 I T?1N.N
201 E I T?.N1"."1N.N
202 E S T=$C(34)_T_$C(34)
203 Q T
204FIL(SF) ;EXTRINSIC FUNCTION RETURNS FILE CONTAINING FILE OR SUBFILE SF
205 N F F S F=SF,SF=$G(^DD(SF,0,"UP")) Q:SF=""
206 Q $S($D(^DIC(F,0)):F,1:"")
207TBL(TI) ;EXTRINSIC FUNCTION RETURNS TABLE CONTAINING TABLE OR SUBTABLE TI
208 N F S F=$P($G(^DMSQ("T",TI,0)),U,7)
209 I F S F=$$FIL(F) I F S F=$O(^DMSQ("T","C",F,""))
210 Q F
Note: See TracBrowser for help on using the repository browser.