Annotation of freem_fileman/DDSLIB.m, revision 1.1
1.1 ! snw 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")
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DDSLIB.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman