DMSQU ;SFISC/JHM-SQLI UTILITIES ;5/13/98 12:03
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
Q
SOC(T,B) ;TRANSLATE BASE CODE B TO EXTERNAL FORM FROM TEXT T
Q $P($P(T,";"_B_":",2),";")
NEW() ;Extrinsic function returns comma-list of variables to NEW
Q "DI,DIQUIET,DIFM"
ENV Q:$G(DUZ(0))'["@"
K ERR I $G(DIFM),$G(U)="^",$G(DT),$D(DUZ) D CLEAN^DIEFU Q
S DIQUIET=1,DIFM=1 D INIZE^DIEFU
Q
EXT(F,FI,FLG,INT,MSG) ;SQLI ENTRY TO EXTERNAL^DILFD
D ENV Q $$EXTERNAL^DILFD(F,FI,FLG,INT,$G(MSG))
GET(F,IEN,FI,FLG,BUF,MSG) ;SQLI ENTRY TO GET1^DIQ
D ENV Q $$GET1^DIQ(F,IEN,FI,$G(FLG),$G(BUF),$G(MSG))
CLF(S) D ENV N X
S X=$P($G(^DMSQ(S,0)),"^",1,2)_"^" I X'="^" K ^DMSQ(S) S ^DMSQ(S,0)=X
Q
CLN D CLF("DT"),CLF("DM") Q
VIEN(TI) ;RETURN VIRTUAL IENS FOR TI
N I,S S S=""
F I=$L(^DMSQ("T",TI,1),"{K}")-1:-1:1 S S=S_"{K"_I_"},"
Q S
ET(T) ;REPORT ELAPSED TIME SINCE T ($H FORMAT)
W ?30,"Time elapsed: ",$$TM($$TD(T,$H))," (HH:MM:SS)"
Q
TD(T,N) ;RETURNS TIME DIFERENCE OF N(OW)-T(HEN) $H FORMATS
Q N-T*86400+$P(N,",",2)-$P(T,",",2)
TM(S) ;RETURN TEXT VALUE OF TIME S SECONDS AS HH:MM:SS
Q $E(S\3600+100,2,3)_":"_$E(S\60#60+100,2,3)_":"_$E(S#60+100,2,3)
PAR(TI,NP,G,P,E) ;GET PARENT, GBL FRAGMENT, AND PIECE OR EXTRACT
;CALLED: S PAR=$$PAR^DMSQU(TABLE_ID,NODE;PIECE,.GBL_FRAG,.PC,.EX)
N PEI,PI,SQ,CI,E1,E2 D ENV
S PEI=$O(^DMSQ("E","F",TI,"P","")) Q:'PEI ""
S SQ=$O(^DMSQ("P","C",PEI,""),-1) Q:'SQ ""
S PI=$O(^DMSQ("P","C",PEI,SQ,"")),CI=$P(^DMSQ("P",PI,0),U,2)
S G=","_$$SS($P(NP,";"))_")",E=""
S P=$P(NP,";",2) I P'["E" S:P]"" P=+P
E S E=+$P(P,"E",2)_","_(+$P(NP,",",2)),P=""
Q CI
ERR(F,FI,T) ;ERROR LOGGER
N TI,EI,FE S FE=$G(ERR("DIERR",1)) D ENV
I T?1NN,$D(^DMSQ("ET",T)) S TI=T
E S TI=$O(^DMSQ("ET","B",T,"")) I 'TI D
. F TI=$P($G(^DMSQ("ET",0)),U,4)+1:1 Q:'$D(^(TI))
. S $P(^DMSQ("ET",0),U,3,4)=TI_U_TI,^(TI,0)=T,^DMSQ("ET","B",T,TI)=""
S EI=$P($G(^DMSQ("EX",0)),U,4)+1,$P(^(0),U,3,4)=EI_U_EI
S ^DMSQ("EX",EI,0)=F_U_FI_U_TI_U_DT_U_FE,^DMSQ("EX","B",F,EI)=""
S ^DMSQ("EX","C",TI,EI)="",^DMSQ("EX","D",DT,EI)=""
I FE S ^DMSQ("EX","E",FE,EI)=""
Q
ATTR ;;TYPE;FIELD LENGTH;DECIMAL DEFAULT;INPUT TRANSFORM;GLOBAL SUBSCRIPT LOCATION;POINTER;TITLE;SPECIFIER;DESCRIPTION;MULTIPLE-VALUED;LABEL
DOM(F,FI,DEF,ERR) ;GET FIELD ATTRIBUTES - DEF AND ERR ARE OPTIONAL
;RETURNS DOMAIN:WIDTH:SCALE ALLWAYS, ARRAYS DEF AND ERR OPTIONALLY
N T,W,S,X K DEF D ENV
I '$D(^DD(F,FI,0))#10 Q ""
D FIELD^DID(F,FI,"",$P($T(ATTR),";;",2),"DEF","ERR")
I $D(ERR)!$D(DIERR) D Q T
. S T=$$DM(F,FI,.DEF) I T]"" D ENV,ERR(F,FI,"FIELD: CALL TO RETRIEVE ATTRIBUTES FAILED")
S T=DEF("TYPE"),W=DEF("FIELD LENGTH"),S=DEF("DECIMAL DEFAULT")
S:W W=+W S:S?1N.E S=+S
S I=DEF("INPUT TRANSFORM"),W=$S(I["$L(X)>":+$P(I,"$L(X)>",2),1:W)
I T["MUMPS" S W=245,T="FM_MUMPS"
E I T["SET" S T="SET_OF_CODES"
E I T["DATE/TIME" D
. S X=$P($P(DEF("INPUT TRANSFORM"),"%DT=""",2),"""")
. S T=$S(X["R":"FM_DATE_TIME",X["T":"FM_MOMENT",1:"FM_DATE")
E I T["NUMERIC",'S S T="INTEGER",S=""
E I T["FREE TEXT" S T="CHARACTER"
E I T["COMPUTED" S T=$S(S:"NUMERIC",S=0:"INTEGER",1:"CHARACTER")
E I T["BOOLEAN" S T="FM_FLAG"
E I T["VARIABLE-POINTER" S T="VARIABLE_POINTER"
E I T["POINTER" S T="POINTER"
E I T["WORD-PROCESSING" S T="WORD_PROCESSING",W=80
S F=$G(DEF("DESCRIPTION",1)) K DEF("DESCRIPTION")
S DEF("DESCRIPTION")=$P(F,".")
Q T_U_W_U_S
DM(F,FI,DEF) ;BUILD META-DATA FOR ONE FIELD (USE WHEN FIELD^DID FAILS!!)
D ENV N CK,H,IT,SP,P,D,EX,LD,DP,TYP,DM,X
K DEF S H=$G(^DD(F,FI,0)) Q:H="" ""
S DEF("LABEL")=$P(H,U),(PE,DEF("GLOBAL SUBSCRIPT LOCATION"))=$P(H,U,4)
S (IT,DEF("INPUT TRANSFORM"))=$P(H,U,5),(SP,DEF("SPECIFIER"))=$P(H,U,2)
S DEF("DESCRIPTION")=$P($G(^DD(F,FI,21,1,0)),".")
S (P,DEF("POINTER"))=$P(H,U,3),DEF("MULTIPLE-VALUED")=SP["M"!SP
S D=$TR(SP,"aeAIMOn'X*","") ;IGNORE CHILD DESCRIPTORS
S EX=$P($P(PE,";",2),"E",2)
I EX F I=1:1 I $E(EX,I)?.A S EX=$E(EX,1,I-1) Q
S LD=$P(D,"J",2),DP=+$P(LD,",",2) I LD,'DP S LD=+LD
I LD="" S CK=$P(IT,"$L(X)>",2) I CK S LD=+CK
I LD="",$P(EX,",",2) S LD=$P(EX,",",2)-EX+1
S:DP LD=(+LD)_U_DP,DEF("DECIMAL DEFAULT")=DP
I LD S DEF("FIELD LENGTH")=+LD,LD=U_LD
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")
I TYP="N" S DM="NUMERIC"_LD,DEF("TYPE")="NUMERIC"
E I TYP="W" D
. S DM="WORD_PROCESSING",LD="^80",DEF("TYPE")="WORD-PROCESSING"
E I TYP="P" S DM="POINTER",LD="^10",DEF("TYPE")="POINTER"
E I TYP="S" D S DM="SET_OF_CODES"_LD,DEF("TYPE")="SET"
. N I,X,W S W=1
. F I=1:1:$L(P,":") S X=$L($P($P(";"_P,":",I),";",2)) S:X>W W=X
. S LD=U_W
E I TYP="I" S DM="INTEGER"_LD,DEF("TYPE")="NUMERIC"
E I TYP="V" S DM="VARIABLE_POINTER",DEF("TYPE")="VARIABLE-POINTER"
E I TYP="B" S DM="FM_FLAG",DEF("TYPE")="BOOLEAN"
E I TYP="D" S X=$P($P($P(H,"^",5),"%DT=",2),"""",2) D
. I X'["T",X'["R" S DM="FM_DATE"
. E I X["R" S DM="FM_DATE_TIME"
. E S DM="FM_MOMENT"
. S DEF("TYPE")="DATE"
E I TYP="K" S DM="FM_MUMPS^245",DEF("TYPE")="MUMPS"
E S DM="CHARACTER"_$S(LD]"":LD,1:"(80)"),DEF("TYPE")="FREE TEXT"
Q DM
KL(TI) ;RETURN IEN LIST OF TABLE
N KL,P S KL=TI
F S P=$G(^DD(TI,0,"UP")) Q:P="" S KL=P_","_KL,TI=P
Q KL
PUT(I,A,E) ;FILE OR UPDATE
;GIVEN I=IEN AND A=FDA ARRAY RETURN IEN AND ERR
K @E D ENV
I I?1N.E D
. D FILE^DIE("",A,E)
E D
. N O D UPDATE^DIE("",A,"O",E) S I=$G(O(1))
Q $S($D(@E):0,1:+I)
KWC(N) ;RETURN N AS A NON-KEYWORD
I N]"",$D(^DMSQ("K","B",N)) N X,I S X=$$SQLI(N,25),N=X_1 D
. F I=2:1 Q:'$D(^DMSQ("K","B",N)) S N=X_I ; AVOID KEYWORDS
Q N
FNB(F,TI) ;BUILD SQL FILE NAME
;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
;INPUT: F=FILEMAN FILE NUMBER, TI=SQLI IEN
;OUTPUT: STANDARD SQLI TABLE LABEL, UNIQUE BY SCHEMA, AND NOT
; A KEY WORD
N NM,F1,SP,P,I,X,J
S NM="",F1=F,SP="" F D Q:'P
. S P=$G(^DD(F1,0,"UP"))
. I P S NM=$O(^DD(F1,0,"NM",""))_SP_NM,SP="_",F1=P
S NM=$P($G(^DIC(F1,0)),"^")_SP_NM
I NM=""!(NM["__")!($E(NM,$L(NM))="_")!(NM?1"_".E) Q ""
F I=1:1:$L(NM,"_")-1 D
. S X=$P(NM,"_",I)
. F J=I+1:1:$L(NM,"_") S:$P(NM,"_",J)=X $P(NM,"_",J)=""
S NM=$$SQLI(NM,26)
F I=1:1 Q:'$D(^DMSQ("T","B",NM))!($O(^(NM,""))=TI) S NM=NM_I
Q $$KWC(NM)
CN(T,C,N) ;BUILD COLUMN NAME N UNIQUE BY TABLE T, COLUMN ELEMENT C
;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
;INPUT: T=SQLI_TABLE EIN, C=SQLI_COLUMN EIN, N=FIELD NAME
;FIELD NAME ARE GENERATED FOR PRIMARY AND FOREIGN KEY COLUMNS
;OUTPUT: STANDARD SQLI COLUMN LABELS, UNIQUE BY TABLE, NOT KEYWORDS
N I,X,% I N]"" D
. S N=$$KWC($$SQLI(N,26)),%="",X=N
. F I=1:1 S %=$O(^DMSQ("E","G",T,N,"")) Q:%=C!'% S N=X_I
Q N
SQLK(T,L) ;RETURN SQL IDENTIFIER NOT A KEYWORD
;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
;SEE $$SQLI FOR DESCRIPTION OF INPUT/OUTPUT
Q $$KWC($$SQLI(T,L))
SQLI(T,L) ;RETURN VALID SQL IDENTIFIER OF LENGTH L OR LESS BASED ON T
;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
;INPUT: T=FREE TEXT, L=MAXIMUM OUTPUT LENGTH
;OUTPUT: AN SQLI STANDARD SQL IDENTIFIER
N I,PL,T1
I $TR(T,"_")?.UN,$L(T)'>L G SQLIX ;SKIP PROCESSING FOR SIMPLE CASE
;CONVERT LOWER TO UPPER CASE, MOST PUNCTUATION TO UNDERLINES
S T=$TR(T," -abcdefghijklmnopqrstuvwxyz!@#$%^&*()_-+=|\}]{[:;""'?/>.<,~`","__ABCDEFGHIJKLMNOPQRSTUVWXYZ_________________________________")
;REMOVE DOUBLE UNDERLINES
F Q:T'["__" S T=$P(T,"__")_"_"_$P(T,"__",2,99)
I T?1"_".E S T=$E(T,2,999) ;REMOVE INITIAL UNDERLINE
I $E(T,$L(T))="_" S T=$E(T,1,$L(T)-1) ;REMOVE TRAILING UNDERLINE
;COMPRESSION
I $L(T)>L D
. S PL=$L(T,"_") ;1) REDUCE SIZE OF _ PIECES
. F I=PL-1:-1:2,PL,1 S $P(T,"_",I)=$$SQZ($P(T,"_",I)) Q:$L(T)'>L
;2) CONVERT _ PIECES TO INITIAL LETTERS
I $L(T)>L F I=PL-1:-1:2,PL,1 S $P(T,"_",I)=$E($P(T,"_",I)) Q:$L(T)'>L
;3) COMPRESS OVERHANG INTO ONE ALPHA-NUMBERIC CHARACTER
I $L(T)>L S T=$E(T,1,L-1)_$TR($E(T,L,999),"_")
SQLIX F Q:$E(T,$L(T))'="_" S $E(T,$L(T))="" ;REMOVE TRAILING _S
F Q:$E(T)'="_" S $E(T)="" ;REMOVE LEADING _S
I T?1N.E S T="N"_T ;AVOID INITIAL DIGIT
I $L(T)>L S T=$E(T,1,$S($E(T,L)="_":L-1,1:L)) ;4) JUST TRUNCATE IT
Q T
SQZ(T) ;RETURN MNEMONIC VALUE OF T
I $L(T)>5 S T=$E(T,1,4) S:"AEIOU"[$E(T,4) T=$E(T,1,3)
Q T
ROOT(F) ;GET GLOBAL NAME SYNTAX FOR A SUBFILE (F)
N G,P,FI
S G="{K})" F D Q:G["^"
. S P=$G(^DD(F,0,"UP"))
. I P D
. . S FI=$O(^DD(P,"SB",F,""))
. . I FI S F=P,G="{K},"_$$SS($P($P(^DD(F,FI,0),"^",4),";"))_","_G
. . E S G="^"
. E I $D(^DIC(F,0,"GL")) S G=^("GL")_G
. E S G="^"
Q G
SS(T) ;CONVERT T TO A VALID SUBSCRIPT (QUOTES)
I T?1N.N
E I T?.N1"."1N.N
E S T=$C(34)_T_$C(34)
Q T
FIL(SF) ;EXTRINSIC FUNCTION RETURNS FILE CONTAINING FILE OR SUBFILE SF
N F F S F=SF,SF=$G(^DD(SF,0,"UP")) Q:SF=""
Q $S($D(^DIC(F,0)):F,1:"")
TBL(TI) ;EXTRINSIC FUNCTION RETURNS TABLE CONTAINING TABLE OR SUBTABLE TI
N F S F=$P($G(^DMSQ("T",TI,0)),U,7)
I F S F=$$FIL(F) I F S F=$O(^DMSQ("T","C",F,""))
Q F
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDMSQU 9306 printed Jan 18, 2025@03:56:17 Page 2
DMSQU ;SFISC/JHM-SQLI UTILITIES ;5/13/98 12:03
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 QUIT
SOC(T,B) ;TRANSLATE BASE CODE B TO EXTERNAL FORM FROM TEXT T
+1 QUIT $PIECE($PIECE(T,";"_B_":",2),";")
NEW() ;Extrinsic function returns comma-list of variables to NEW
+1 QUIT "DI,DIQUIET,DIFM"
ENV if $GET(DUZ(0))'["@"
QUIT
+1 KILL ERR
IF $GET(DIFM)
IF $GET(U)="^"
IF $GET(DT)
IF $DATA(DUZ)
DO CLEAN^DIEFU
QUIT
+2 SET DIQUIET=1
SET DIFM=1
DO INIZE^DIEFU
+3 QUIT
EXT(F,FI,FLG,INT,MSG) ;SQLI ENTRY TO EXTERNAL^DILFD
+1 DO ENV
QUIT $$EXTERNAL^DILFD(F,FI,FLG,INT,$GET(MSG))
GET(F,IEN,FI,FLG,BUF,MSG) ;SQLI ENTRY TO GET1^DIQ
+1 DO ENV
QUIT $$GET1^DIQ(F,IEN,FI,$GET(FLG),$GET(BUF),$GET(MSG))
CLF(S) DO ENV
NEW X
+1 SET X=$PIECE($GET(^DMSQ(S,0)),"^",1,2)_"^"
IF X'="^"
KILL ^DMSQ(S)
SET ^DMSQ(S,0)=X
+2 QUIT
CLN DO CLF("DT")
DO CLF("DM")
QUIT
VIEN(TI) ;RETURN VIRTUAL IENS FOR TI
+1 NEW I,S
SET S=""
+2 FOR I=$LENGTH(^DMSQ("T",TI,1),"{K}")-1:-1:1
SET S=S_"{K"_I_"},"
+3 QUIT S
ET(T) ;REPORT ELAPSED TIME SINCE T ($H FORMAT)
+1 WRITE ?30,"Time elapsed: ",$$TM($$TD(T,$HOROLOG))," (HH:MM:SS)"
+2 QUIT
TD(T,N) ;RETURNS TIME DIFERENCE OF N(OW)-T(HEN) $H FORMATS
+1 QUIT N-T*86400+$PIECE(N,",",2)-$PIECE(T,",",2)
TM(S) ;RETURN TEXT VALUE OF TIME S SECONDS AS HH:MM:SS
+1 QUIT $EXTRACT(S\3600+100,2,3)_":"_$EXTRACT(S\60#60+100,2,3)_":"_$EXTRACT(S#60+100,2,3)
PAR(TI,NP,G,P,E) ;GET PARENT, GBL FRAGMENT, AND PIECE OR EXTRACT
+1 ;CALLED: S PAR=$$PAR^DMSQU(TABLE_ID,NODE;PIECE,.GBL_FRAG,.PC,.EX)
+2 NEW PEI,PI,SQ,CI,E1,E2
DO ENV
+3 SET PEI=$ORDER(^DMSQ("E","F",TI,"P",""))
if 'PEI
QUIT ""
+4 SET SQ=$ORDER(^DMSQ("P","C",PEI,""),-1)
if 'SQ
QUIT ""
+5 SET PI=$ORDER(^DMSQ("P","C",PEI,SQ,""))
SET CI=$PIECE(^DMSQ("P",PI,0),U,2)
+6 SET G=","_$$SS($PIECE(NP,";"))_")"
SET E=""
+7 SET P=$PIECE(NP,";",2)
IF P'["E"
if P]""
SET P=+P
+8 IF '$TEST
SET E=+$PIECE(P,"E",2)_","_(+$PIECE(NP,",",2))
SET P=""
+9 QUIT CI
ERR(F,FI,T) ;ERROR LOGGER
+1 NEW TI,EI,FE
SET FE=$GET(ERR("DIERR",1))
DO ENV
+2 IF T?1NN
IF $DATA(^DMSQ("ET",T))
SET TI=T
+3 IF '$TEST
SET TI=$ORDER(^DMSQ("ET","B",T,""))
IF 'TI
Begin DoDot:1
+4 FOR TI=$PIECE($GET(^DMSQ("ET",0)),U,4)+1:1
if '$DATA(^(TI))
QUIT
+5 SET $PIECE(^DMSQ("ET",0),U,3,4)=TI_U_TI
SET ^(TI,0)=T
SET ^DMSQ("ET","B",T,TI)=""
End DoDot:1
+6 SET EI=$PIECE($GET(^DMSQ("EX",0)),U,4)+1
SET $PIECE(^(0),U,3,4)=EI_U_EI
+7 SET ^DMSQ("EX",EI,0)=F_U_FI_U_TI_U_DT_U_FE
SET ^DMSQ("EX","B",F,EI)=""
+8 SET ^DMSQ("EX","C",TI,EI)=""
SET ^DMSQ("EX","D",DT,EI)=""
+9 IF FE
SET ^DMSQ("EX","E",FE,EI)=""
+10 QUIT
ATTR ;;TYPE;FIELD LENGTH;DECIMAL DEFAULT;INPUT TRANSFORM;GLOBAL SUBSCRIPT LOCATION;POINTER;TITLE;SPECIFIER;DESCRIPTION;MULTIPLE-VALUED;LABEL
DOM(F,FI,DEF,ERR) ;GET FIELD ATTRIBUTES - DEF AND ERR ARE OPTIONAL
+1 ;RETURNS DOMAIN:WIDTH:SCALE ALLWAYS, ARRAYS DEF AND ERR OPTIONALLY
+2 NEW T,W,S,X
KILL DEF
DO ENV
+3 IF '$DATA(^DD(F,FI,0))#10
QUIT ""
+4 DO FIELD^DID(F,FI,"",$PIECE($TEXT(ATTR),";;",2),"DEF","ERR")
+5 IF $DATA(ERR)!$DATA(DIERR)
Begin DoDot:1
+6 SET T=$$DM(F,FI,.DEF)
IF T]""
DO ENV
DO ERR(F,FI,"FIELD: CALL TO RETRIEVE ATTRIBUTES FAILED")
End DoDot:1
QUIT T
+7 SET T=DEF("TYPE")
SET W=DEF("FIELD LENGTH")
SET S=DEF("DECIMAL DEFAULT")
+8 if W
SET W=+W
if S?1N.E
SET S=+S
+9 SET I=DEF("INPUT TRANSFORM")
SET W=$SELECT(I["$L(X)>":+$PIECE(I,"$L(X)>",2),1:W)
+10 IF T["MUMPS"
SET W=245
SET T="FM_MUMPS"
+11 IF '$TEST
IF T["SET"
SET T="SET_OF_CODES"
+12 IF '$TEST
IF T["DATE/TIME"
Begin DoDot:1
+13 SET X=$PIECE($PIECE(DEF("INPUT TRANSFORM"),"%DT=""",2),"""")
+14 SET T=$SELECT(X["R":"FM_DATE_TIME",X["T":"FM_MOMENT",1:"FM_DATE")
End DoDot:1
+15 IF '$TEST
IF T["NUMERIC"
IF 'S
SET T="INTEGER"
SET S=""
+16 IF '$TEST
IF T["FREE TEXT"
SET T="CHARACTER"
+17 IF '$TEST
IF T["COMPUTED"
SET T=$SELECT(S:"NUMERIC",S=0:"INTEGER",1:"CHARACTER")
+18 IF '$TEST
IF T["BOOLEAN"
SET T="FM_FLAG"
+19 IF '$TEST
IF T["VARIABLE-POINTER"
SET T="VARIABLE_POINTER"
+20 IF '$TEST
IF T["POINTER"
SET T="POINTER"
+21 IF '$TEST
IF T["WORD-PROCESSING"
SET T="WORD_PROCESSING"
SET W=80
+22 SET F=$GET(DEF("DESCRIPTION",1))
KILL DEF("DESCRIPTION")
+23 SET DEF("DESCRIPTION")=$PIECE(F,".")
+24 QUIT T_U_W_U_S
DM(F,FI,DEF) ;BUILD META-DATA FOR ONE FIELD (USE WHEN FIELD^DID FAILS!!)
+1 DO ENV
NEW CK,H,IT,SP,P,D,EX,LD,DP,TYP,DM,X
+2 KILL DEF
SET H=$GET(^DD(F,FI,0))
if H=""
QUIT ""
+3 SET DEF("LABEL")=$PIECE(H,U)
SET (PE,DEF("GLOBAL SUBSCRIPT LOCATION"))=$PIECE(H,U,4)
+4 SET (IT,DEF("INPUT TRANSFORM"))=$PIECE(H,U,5)
SET (SP,DEF("SPECIFIER"))=$PIECE(H,U,2)
+5 SET DEF("DESCRIPTION")=$PIECE($GET(^DD(F,FI,21,1,0)),".")
+6 SET (P,DEF("POINTER"))=$PIECE(H,U,3)
SET DEF("MULTIPLE-VALUED")=SP["M"!SP
+7 ;IGNORE CHILD DESCRIPTORS
SET D=$TRANSLATE(SP,"aeAIMOn'X*","")
+8 SET EX=$PIECE($PIECE(PE,";",2),"E",2)
+9 IF EX
FOR I=1:1
IF $EXTRACT(EX,I)?.A
SET EX=$EXTRACT(EX,1,I-1)
QUIT
+10 SET LD=$PIECE(D,"J",2)
SET DP=+$PIECE(LD,",",2)
IF LD
IF 'DP
SET LD=+LD
+11 IF LD=""
SET CK=$PIECE(IT,"$L(X)>",2)
IF CK
SET LD=+CK
+12 IF LD=""
IF $PIECE(EX,",",2)
SET LD=$PIECE(EX,",",2)-EX+1
+13 if DP
SET LD=(+LD)_U_DP
SET DEF("DECIMAL DEFAULT")=DP
+14 IF LD
SET DEF("FIELD LENGTH")=+LD
SET LD=U_LD
+15 SET TYP=$SELECT(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")
+16 IF TYP="N"
SET DM="NUMERIC"_LD
SET DEF("TYPE")="NUMERIC"
+17 IF '$TEST
IF TYP="W"
Begin DoDot:1
+18 SET DM="WORD_PROCESSING"
SET LD="^80"
SET DEF("TYPE")="WORD-PROCESSING"
End DoDot:1
+19 IF '$TEST
IF TYP="P"
SET DM="POINTER"
SET LD="^10"
SET DEF("TYPE")="POINTER"
+20 IF '$TEST
IF TYP="S"
Begin DoDot:1
+21 NEW I,X,W
SET W=1
+22 FOR I=1:1:$LENGTH(P,":")
SET X=$LENGTH($PIECE($PIECE(";"_P,":",I),";",2))
if X>W
SET W=X
+23 SET LD=U_W
End DoDot:1
SET DM="SET_OF_CODES"_LD
SET DEF("TYPE")="SET"
+24 IF '$TEST
IF TYP="I"
SET DM="INTEGER"_LD
SET DEF("TYPE")="NUMERIC"
+25 IF '$TEST
IF TYP="V"
SET DM="VARIABLE_POINTER"
SET DEF("TYPE")="VARIABLE-POINTER"
+26 IF '$TEST
IF TYP="B"
SET DM="FM_FLAG"
SET DEF("TYPE")="BOOLEAN"
+27 IF '$TEST
IF TYP="D"
SET X=$PIECE($PIECE($PIECE(H,"^",5),"%DT=",2),"""",2)
Begin DoDot:1
+28 IF X'["T"
IF X'["R"
SET DM="FM_DATE"
+29 IF '$TEST
IF X["R"
SET DM="FM_DATE_TIME"
+30 IF '$TEST
SET DM="FM_MOMENT"
+31 SET DEF("TYPE")="DATE"
End DoDot:1
+32 IF '$TEST
IF TYP="K"
SET DM="FM_MUMPS^245"
SET DEF("TYPE")="MUMPS"
+33 IF '$TEST
SET DM="CHARACTER"_$SELECT(LD]"":LD,1:"(80)")
SET DEF("TYPE")="FREE TEXT"
+34 QUIT DM
KL(TI) ;RETURN IEN LIST OF TABLE
+1 NEW KL,P
SET KL=TI
+2 FOR
SET P=$GET(^DD(TI,0,"UP"))
if P=""
QUIT
SET KL=P_","_KL
SET TI=P
+3 QUIT KL
PUT(I,A,E) ;FILE OR UPDATE
+1 ;GIVEN I=IEN AND A=FDA ARRAY RETURN IEN AND ERR
+2 KILL @E
DO ENV
+3 IF I?1N.E
Begin DoDot:1
+4 DO FILE^DIE("",A,E)
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 NEW O
DO UPDATE^DIE("",A,"O",E)
SET I=$GET(O(1))
End DoDot:1
+7 QUIT $SELECT($DATA(@E):0,1:+I)
KWC(N) ;RETURN N AS A NON-KEYWORD
+1 IF N]""
IF $DATA(^DMSQ("K","B",N))
NEW X,I
SET X=$$SQLI(N,25)
SET N=X_1
Begin DoDot:1
+2 ; AVOID KEYWORDS
FOR I=2:1
if '$DATA(^DMSQ("K","B",N))
QUIT
SET N=X_I
End DoDot:1
+3 QUIT N
FNB(F,TI) ;BUILD SQL FILE NAME
+1 ;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
+2 ;INPUT: F=FILEMAN FILE NUMBER, TI=SQLI IEN
+3 ;OUTPUT: STANDARD SQLI TABLE LABEL, UNIQUE BY SCHEMA, AND NOT
+4 ; A KEY WORD
+5 NEW NM,F1,SP,P,I,X,J
+6 SET NM=""
SET F1=F
SET SP=""
FOR
Begin DoDot:1
+7 SET P=$GET(^DD(F1,0,"UP"))
+8 IF P
SET NM=$ORDER(^DD(F1,0,"NM",""))_SP_NM
SET SP="_"
SET F1=P
End DoDot:1
if 'P
QUIT
+9 SET NM=$PIECE($GET(^DIC(F1,0)),"^")_SP_NM
+10 IF NM=""!(NM["__")!($EXTRACT(NM,$LENGTH(NM))="_")!(NM?1"_".E)
QUIT ""
+11 FOR I=1:1:$LENGTH(NM,"_")-1
Begin DoDot:1
+12 SET X=$PIECE(NM,"_",I)
+13 FOR J=I+1:1:$LENGTH(NM,"_")
if $PIECE(NM,"_",J)=X
SET $PIECE(NM,"_",J)=""
End DoDot:1
+14 SET NM=$$SQLI(NM,26)
+15 FOR I=1:1
if '$DATA(^DMSQ("T","B",NM))!($ORDER(^(NM,""))=TI)
QUIT
SET NM=NM_I
+16 QUIT $$KWC(NM)
CN(T,C,N) ;BUILD COLUMN NAME N UNIQUE BY TABLE T, COLUMN ELEMENT C
+1 ;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
+2 ;INPUT: T=SQLI_TABLE EIN, C=SQLI_COLUMN EIN, N=FIELD NAME
+3 ;FIELD NAME ARE GENERATED FOR PRIMARY AND FOREIGN KEY COLUMNS
+4 ;OUTPUT: STANDARD SQLI COLUMN LABELS, UNIQUE BY TABLE, NOT KEYWORDS
+5 NEW I,X,%
IF N]""
Begin DoDot:1
+6 SET N=$$KWC($$SQLI(N,26))
SET %=""
SET X=N
+7 FOR I=1:1
SET %=$ORDER(^DMSQ("E","G",T,N,""))
if %=C!'%
QUIT
SET N=X_I
End DoDot:1
+8 QUIT N
SQLK(T,L) ;RETURN SQL IDENTIFIER NOT A KEYWORD
+1 ;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
+2 ;SEE $$SQLI FOR DESCRIPTION OF INPUT/OUTPUT
+3 QUIT $$KWC($$SQLI(T,L))
SQLI(T,L) ;RETURN VALID SQL IDENTIFIER OF LENGTH L OR LESS BASED ON T
+1 ;EXTRINSIC FUNCTION, ALL PARAMETERS REQUIRED & PASSED BY VALUE
+2 ;INPUT: T=FREE TEXT, L=MAXIMUM OUTPUT LENGTH
+3 ;OUTPUT: AN SQLI STANDARD SQL IDENTIFIER
+4 NEW I,PL,T1
+5 ;SKIP PROCESSING FOR SIMPLE CASE
IF $TRANSLATE(T,"_")?.UN
IF $LENGTH(T)'>L
GOTO SQLIX
+6 ;CONVERT LOWER TO UPPER CASE, MOST PUNCTUATION TO UNDERLINES
+7 SET T=$TRANSLATE(T," -abcdefghijklmnopqrstuvwxyz!@#$%^&*()_-+=|\}]{[:;""'?/>.<,~`","__ABCDEFGHIJKLMNOPQRSTUVWXYZ_________________________________")
+8 ;REMOVE DOUBLE UNDERLINES
+9 FOR
if T'["__"
QUIT
SET T=$PIECE(T,"__")_"_"_$PIECE(T,"__",2,99)
+10 ;REMOVE INITIAL UNDERLINE
IF T?1"_".E
SET T=$EXTRACT(T,2,999)
+11 ;REMOVE TRAILING UNDERLINE
IF $EXTRACT(T,$LENGTH(T))="_"
SET T=$EXTRACT(T,1,$LENGTH(T)-1)
+12 ;COMPRESSION
+13 IF $LENGTH(T)>L
Begin DoDot:1
+14 ;1) REDUCE SIZE OF _ PIECES
SET PL=$LENGTH(T,"_")
+15 FOR I=PL-1:-1:2,PL,1
SET $PIECE(T,"_",I)=$$SQZ($PIECE(T,"_",I))
if $LENGTH(T)'>L
QUIT
End DoDot:1
+16 ;2) CONVERT _ PIECES TO INITIAL LETTERS
+17 IF $LENGTH(T)>L
FOR I=PL-1:-1:2,PL,1
SET $PIECE(T,"_",I)=$EXTRACT($PIECE(T,"_",I))
if $LENGTH(T)'>L
QUIT
+18 ;3) COMPRESS OVERHANG INTO ONE ALPHA-NUMBERIC CHARACTER
+19 IF $LENGTH(T)>L
SET T=$EXTRACT(T,1,L-1)_$TRANSLATE($EXTRACT(T,L,999),"_")
SQLIX ;REMOVE TRAILING _S
FOR
if $EXTRACT(T,$LENGTH(T))'="_"
QUIT
SET $EXTRACT(T,$LENGTH(T))=""
+1 ;REMOVE LEADING _S
FOR
if $EXTRACT(T)'="_"
QUIT
SET $EXTRACT(T)=""
+2 ;AVOID INITIAL DIGIT
IF T?1N.E
SET T="N"_T
+3 ;4) JUST TRUNCATE IT
IF $LENGTH(T)>L
SET T=$EXTRACT(T,1,$SELECT($EXTRACT(T,L)="_":L-1,1:L))
+4 QUIT T
SQZ(T) ;RETURN MNEMONIC VALUE OF T
+1 IF $LENGTH(T)>5
SET T=$EXTRACT(T,1,4)
if "AEIOU"[$EXTRACT(T,4)
SET T=$EXTRACT(T,1,3)
+2 QUIT T
ROOT(F) ;GET GLOBAL NAME SYNTAX FOR A SUBFILE (F)
+1 NEW G,P,FI
+2 SET G="{K})"
FOR
Begin DoDot:1
+3 SET P=$GET(^DD(F,0,"UP"))
+4 IF P
Begin DoDot:2
+5 SET FI=$ORDER(^DD(P,"SB",F,""))
+6 IF FI
SET F=P
SET G="{K},"_$$SS($PIECE($PIECE(^DD(F,FI,0),"^",4),";"))_","_G
+7 IF '$TEST
SET G="^"
End DoDot:2
+8 IF '$TEST
IF $DATA(^DIC(F,0,"GL"))
SET G=^("GL")_G
+9 IF '$TEST
SET G="^"
End DoDot:1
if G["^"
QUIT
+10 QUIT G
SS(T) ;CONVERT T TO A VALID SUBSCRIPT (QUOTES)
+1 IF T?1N.N
+2 IF '$TEST
IF T?.N1"."1N.N
+3 IF '$TEST
SET T=$CHAR(34)_T_$CHAR(34)
+4 QUIT T
FIL(SF) ;EXTRINSIC FUNCTION RETURNS FILE CONTAINING FILE OR SUBFILE SF
+1 NEW F
FOR
SET F=SF
SET SF=$GET(^DD(SF,0,"UP"))
if SF=""
QUIT
+2 QUIT $SELECT($DATA(^DIC(F,0)):F,1:"")
TBL(TI) ;EXTRINSIC FUNCTION RETURNS TABLE CONTAINING TABLE OR SUBTABLE TI
+1 NEW F
SET F=$PIECE($GET(^DMSQ("T",TI,0)),U,7)
+2 IF F
SET F=$$FIL(F)
IF F
SET F=$ORDER(^DMSQ("T","C",F,""))
+3 QUIT F
