Return to DDSLIB.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DDSLIB	;SFISC/MKO-LIBRARY FUNCTIONS ;01:37 PM  6 Sep 1994
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: FIND(E,C,S)	;Find in expression E, starting from pos S, the char pos
    5: 	;after the next occurrence of char C, ignoring those within quoted
    6: 	;strings.
    7: 	N I,J,P
    8: 	S:'$D(S) S=1
    9: 	F  D  Q:$D(P)
   10: 	. S I=$F(E,C,S),J=$F(E,"""",S)
   11: 	. I 'I S P=I Q
   12: 	. I J,J<I S S=$$AFTQ(E,J-1) Q
   13: 	. S P=I
   14: 	Q P
   15: 	;
   16: PIECE(E,C,N1,N2)	;Return the N1th to N2th C-piece of E
   17: 	;ignoring those within quoted strings
   18: 	;Start looking from pos 1
   19: 	N I,J,S,F
   20: 	S:'$D(N1) N1=1 Q:'N1
   21: 	S:'$D(N2) N2=N1 Q:N2<N1
   22: 	S S=1 F I=1:1:N1-1 S S=$$FIND(E,C,S) Q:'S
   23: 	Q:'S $S(N1=1:E,1:"")
   24: 	S F=S F I=1:1:N2-N1+1 S F=$$FIND(E,C,F) Q:'F
   25: 	Q:'F $E(E,S,999)
   26: 	Q $E(E,S,F-2)
   27: 	;
   28: RPAR(E,S)	;Find in expression E, from char pos S (the position
   29: 	;of the left paren) the char pos after the right paren,
   30: 	;ignoring nested parens, or parens within quotes
   31: 	N I,L,P,R
   32: 	S P=1,I=S+1
   33: 	F  D  Q:'P
   34: 	. S R=$$FIND(E,")",I),L=$$FIND(E,"(",I)
   35: 	. I L,L<R S P=P+1,I=L Q
   36: 	. S P=P-1,I=R
   37: 	Q I
   38: 	;
   39: AFTQ(E,I)	;Return character position after quoted string
   40: 	;E = string, I=character position of first quote
   41: 	S:'$G(I) I=1
   42: 	F  S I=$F(E,"""",I+1) Q:$E(E,I)'=""""
   43: 	S:'I I=$L(E)+1
   44: 	Q I
   45: 	;
   46: QT(X)	;Return X quoted
   47: 	Q:$G(X)="" """"""
   48: 	S X(X)="",X=$Q(X(""))
   49: 	Q $E(X,3,$L(X)-1)
   50: 	;
   51: UQT(X)	;Return quoted string X unquoted
   52: 	Q:$G(X)="" ""
   53: 	S @("X("_X_")=""""")
   54: 	Q $O(X(""))
   55: 	;
   56: FIELD(DDP,FLD)	;Get field number
   57: 	N F,P
   58: 	I FLD="" D BLD^DIALOG(202,"field") Q ""
   59: 	S:$E(FLD)="""" FLD=$$UQT($E(FLD,1,$$AFTQ(FLD)-1))
   60: 	S F=FLD,P("FILE")=DDP
   61: 	I FLD'=+$P(FLD,"E") D  Q:$G(DIERR) ""
   62: 	. S F=$O(^DD(DDP,"B",FLD,""))
   63: 	. I F="" S P(1)=FLD D BLD^DIALOG(501,.P)
   64: 	;
   65: 	I $D(^DD(DDP,F,0))[0 S P(1)="#"_F D BLD^DIALOG(501,.P) Q ""
   66: 	Q F
   67: 	;
   68: GETFLD(FD,BK,PG,DDS,DDSPG,DDSBK,DDSFLG)	;Return "DDO,bk#,pg#"
   69: 	;DDSPG=current page, DDSBK=current block
   70: 	; -- when block and page are optional
   71: 	;PG is required only if block order is sent
   72: 	;DDSFLG["F" means field must be form-only
   73: 	N F,B,P,N
   74: 	I FD?.N.1"."1.N1",".N.1"."1.N,BK="",PG="" Q FD
   75: 	S:$E($G(FD))="""" FD=$$UQT(FD)
   76: 	S:$E($G(BK))="""" BK=$$UQT(BK)
   77: 	S:$E($G(PG))="""" PG=$$UQT(PG)
   78: 	S P=+$G(DDSPG),B=+$G(DDSBK)
   79: 	D @$S($G(PG)]"":"PG",$G(BK)]"":"BK",1:"FD") Q:$G(DIERR) ""
   80: 	Q F_","_B_","_P
   81: 	;
   82: PG	;Get internal page number
   83: 	I '$G(DDS) D BLD^DIALOG(3084) Q
   84: 	S N=PG=+$P(PG,"E")
   85: 	I N S P=$O(^DIST(.403,+DDS,40,"B",PG,""))
   86: 	E  I PG?1"`".N.1"."1.N S P=+$P(PG,"`",2),N=2
   87: 	E  S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(PG),""))
   88: 	;
   89: 	I $D(^DIST(.403,+DDS,40,+P,0))[0 D BLD^DIALOG(3023,$S(N=2:"#",N:"number ",1:"named ")_PG) Q
   90: 	;
   91: 	I BK="" D  Q:$G(DIERR)
   92: 	. S BK=$O(^DIST(.403,+DDS,40,P,40,"AC",""))
   93: 	. I BK="" D BLD^DIALOG(3055,$S(N:"number ",1:"named ")_PG)
   94: 	;
   95: BK	;Get internal block number
   96: 	S N=BK=+$P(BK,"E")
   97: 	I N D  Q:$G(DIERR)
   98: 	. I P S B=$O(^DIST(.403,+DDS,40,P,40,"AC",BK,"")) Q
   99: 	. D BLD^DIALOG(3085)
  100: 	E  I BK?1"`".N.1"."1.N S B=+$P(BK,"`",2),N=2
  101: 	E  D  Q:$G(DIERR)
  102: 	. S B=$O(^DIST(.404,"B",BK,""))
  103: 	. I B="" D BLD^DIALOG(3051,BK) Q
  104: 	. S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,""))
  105: 	;
  106: 	I P,$D(^DIST(.403,+DDS,40,P,40,+B,0))[0 D  Q
  107: 	. N P1
  108: 	. S P1(1)=$S(N=2:"#",N:"order ",1:"")_BK
  109: 	. S P1(2)="number "_$P(^DIST(.403,+DDS,40,P,0),U)_$S($G(^(1))]"":" ("_$P(^(1),U)_")",1:"")
  110: 	. D BLD^DIALOG(3053,.P1)
  111: 	;
  112: 	I FD="" D  Q:$G(DIERR)
  113: 	. S FD=$O(^DIST(.404,B,40,"B",""))
  114: 	. D:FD="" BLD^DIALOG(3071,$P(^DIST(.404,B,0),U))
  115: 	;
  116: FD	;Get internal field number
  117: 	I 'B D BLD^DIALOG(3082) Q
  118: 	S N=FD=+$P(FD,"E")
  119: 	I N S F=$O(^DIST(.404,B,40,"B",FD,""))
  120: 	E  I FD?1"`".N.1"."1.N S F=+$P(FD,"`",2),N=2
  121: 	E  D  Q:$G(DIERR)
  122: 	. N X
  123: 	. S FD=$$UPCASE(FD),X=$S($D(^DIST(.404,B,40,"D",FD)):"D",1:"C")
  124: 	. S F=$O(^DIST(.404,B,40,X,FD,""))
  125: 	;
  126: 	I $D(^DIST(.404,B,40,+F,0))[0 D
  127: 	. N P
  128: 	. S P(1)=$S(N=2:"#",N:"order ",1:"with caption or unique name ")_FD
  129: 	. S P(2)=$P(^DIST(.404,B,0),U)
  130: 	. D BLD^DIALOG(3072,.P)
  131: 	;
  132: 	I '$G(DIERR),$G(DDSFLG)["F","^2^4^"'[(U_$P($G(^DIST(.404,B,40,+F,0)),U,3)_U) D BLD^DIALOG(3081)
  133: 	Q
  134: 	;
  135: UPCASE(X)	;
  136: 	;Return X in uppercase
  137: 	Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")