- 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 Feb 19, 2025@00:21:33 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