DDSLIB ;SFISC/MKO-LIBRARY FUNCTIONS ;11:55 AM 14 Aug 2002
;;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.
;
FIND(E,C,S) ;Find in expression E, starting from pos S, the char pos
;after the next occurrence of char C, ignoring those within quoted
;strings.
N I,J,P
S:'$D(S) S=1
F D Q:$D(P)
. S I=$F(E,C,S),J=$F(E,"""",S)
. I 'I S P=I Q
. I J,J<I S S=$$AFTQ(E,J-1) Q
. S P=I
Q P
;
PIECE(E,C,N1,N2) ;Return the N1th to N2th C-piece of E
;ignoring those within quoted strings
;Start looking from pos 1
N I,J,S,F
S:'$D(N1) N1=1 Q:'N1
S:'$D(N2) N2=N1 Q:N2<N1
S S=1 F I=1:1:N1-1 S S=$$FIND(E,C,S) Q:'S
Q:'S $S(N1=1:E,1:"")
S F=S F I=1:1:N2-N1+1 S F=$$FIND(E,C,F) Q:'F
Q:'F $E(E,S,999)
Q $E(E,S,F-2)
;
RPAR(E,S) ;Find in expression E, from char pos S (the position
;of the left paren) the char pos after the right paren,
;ignoring nested parens, or parens within quotes
N I,L,P,R
S P=1,I=S+1
F D Q:'P
. S R=$$FIND(E,")",I),L=$$FIND(E,"(",I)
. I L,L<R S P=P+1,I=L Q
. S P=P-1,I=R
Q I
;
AFTQ(E,I) ;Return character position after quoted string
;E = string, I=character position of first quote
S:'$G(I) I=1
F S I=$F(E,"""",I+1) Q:$E(E,I)'=""""
S:'I I=$L(E)+1
Q I
;
QT(X) ;Return X quoted
Q:$G(X)="" """"""
S X(X)="",X=$Q(X(""))
Q $E(X,3,$L(X)-1)
;
UQT(X) ;Return quoted string X unquoted
Q:$G(X)="" ""
S @("X("_X_")=""""")
Q $O(X(""))
;
FIELD(DDP,FLD) ;Get field number
N F,P
I FLD="" D BLD^DIALOG(202,"field") Q ""
S:$E(FLD)="""" FLD=$$UQT($E(FLD,1,$$AFTQ(FLD)-1))
S F=FLD,P("FILE")=DDP
I FLD'=+$P(FLD,"E") D Q:$G(DIERR) ""
. S F=$O(^DD(DDP,"B",FLD,""))
. I F="" S P(1)=FLD D BLD^DIALOG(501,.P)
;
I $D(^DD(DDP,F,0))[0 S P(1)="#"_F D BLD^DIALOG(501,.P) Q ""
Q F
;
GETFLD(FD,BK,PG,DDS,DDSPG,DDSBK,DDSFLG) ;Return "DDO,bk#,pg#"
;DDSPG=current page, DDSBK=current block
; -- when block and page are optional
;PG is required only if block order is sent
;DDSFLG["F" means field must be form-only
N F,B,P,N
I FD?.N.1"."1.N1",".N.1"."1.N,BK="",PG="" Q FD
S:$E($G(FD))="""" FD=$$UQT(FD)
S:$E($G(BK))="""" BK=$$UQT(BK)
S:$E($G(PG))="""" PG=$$UQT(PG)
S P=+$G(DDSPG),B=+$G(DDSBK)
D @$S($G(PG)]"":"PG",$G(BK)]"":"BK",1:"FD") Q:$G(DIERR) ""
Q F_","_B_","_P
;
PG ;Get internal page number
I '$G(DDS) D BLD^DIALOG(3084) Q
S N=PG=+$P(PG,"E")
I N S P=$O(^DIST(.403,+DDS,40,"B",PG,""))
E I PG?1"`".N.1"."1.N S P=+$P(PG,"`",2),N=2
E S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(PG),""))
;
I $D(^DIST(.403,+DDS,40,+P,0))[0 D BLD^DIALOG(3023,$S(N=2:"#",N:"number ",1:"named ")_PG) Q
;
I BK="" D Q:$G(DIERR)
. S BK=$O(^DIST(.403,+DDS,40,P,40,"AC",""))
. I BK="" D BLD^DIALOG(3055,$S(N:"number ",1:"named ")_PG)
;
BK ;Get internal block number
S N=BK=+$P(BK,"E")
I N D Q:$G(DIERR)
. I P S B=$O(^DIST(.403,+DDS,40,P,40,"AC",BK,"")) Q
. D BLD^DIALOG(3085)
E I BK?1"`".N.1"."1.N S B=+$P(BK,"`",2),N=2
E D Q:$G(DIERR)
. S B=$O(^DIST(.404,"B",BK,""))
. I B="" D BLD^DIALOG(3051,BK) Q
. S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,""))
;
I P,$D(^DIST(.403,+DDS,40,P,40,+B,0))[0 D Q
. N P1
. S P1(1)=$S(N=2:"#",N:"order ",1:"")_BK
. S P1(2)="number "_$P(^DIST(.403,+DDS,40,P,0),U)_$S($G(^(1))]"":" ("_$P(^(1),U)_")",1:"")
. D BLD^DIALOG(3053,.P1)
;
I FD="" D Q:$G(DIERR)
. S FD=$O(^DIST(.404,B,40,"B",""))
. D:FD="" BLD^DIALOG(3071,$P(^DIST(.404,B,0),U))
;
FD ;Get internal field number
I 'B D BLD^DIALOG(3082) Q
S N=FD=+$P(FD,"E")
I N S F=$O(^DIST(.404,B,40,"B",FD,""))
E I FD?1"`".N.1"."1.N S F=+$P(FD,"`",2),N=2
E D Q:$G(DIERR)
. N X
. S FD=$$UPCASE(FD),X=$S($D(^DIST(.404,B,40,"D",FD)):"D",1:"C")
. S F=$O(^DIST(.404,B,40,X,FD,""))
;
I $D(^DIST(.404,B,40,+F,0))[0 D
. N P
. S P(1)=$S(N=2:"#",N:"order ",1:"with caption or unique name ")_FD
. S P(2)=$P(^DIST(.404,B,0),U)
. D BLD^DIALOG(3072,.P)
;
I '$G(DIERR),$G(DDSFLG)["F","^2^4^"'[(U_$P($G(^DIST(.404,B,40,+F,0)),U,3)_U) D BLD^DIALOG(3081)
Q
;
UPCASE(X) ;
;Return X in uppercase
Q $$UP^DILIBF(X) ;**
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSLIB 4338 printed Oct 16, 2024@18:43:54 Page 2
DDSLIB ;SFISC/MKO-LIBRARY FUNCTIONS ;11:55 AM 14 Aug 2002
+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 ;
FIND(E,C,S) ;Find in expression E, starting from pos S, the char pos
+1 ;after the next occurrence of char C, ignoring those within quoted
+2 ;strings.
+3 NEW I,J,P
+4 if '$DATA(S)
SET S=1
+5 FOR
Begin DoDot:1
+6 SET I=$FIND(E,C,S)
SET J=$FIND(E,"""",S)
+7 IF 'I
SET P=I
QUIT
+8 IF J
IF J<I
SET S=$$AFTQ(E,J-1)
QUIT
+9 SET P=I
End DoDot:1
if $DATA(P)
QUIT
+10 QUIT P
+11 ;
PIECE(E,C,N1,N2) ;Return the N1th to N2th C-piece of E
+1 ;ignoring those within quoted strings
+2 ;Start looking from pos 1
+3 NEW I,J,S,F
+4 if '$DATA(N1)
SET N1=1
if 'N1
QUIT
+5 if '$DATA(N2)
SET N2=N1
if N2<N1
QUIT
+6 SET S=1
FOR I=1:1:N1-1
SET S=$$FIND(E,C,S)
if 'S
QUIT
+7 if 'S
QUIT $SELECT(N1=1:E,1:"")
+8 SET F=S
FOR I=1:1:N2-N1+1
SET F=$$FIND(E,C,F)
if 'F
QUIT
+9 if 'F
QUIT $EXTRACT(E,S,999)
+10 QUIT $EXTRACT(E,S,F-2)
+11 ;
RPAR(E,S) ;Find in expression E, from char pos S (the position
+1 ;of the left paren) the char pos after the right paren,
+2 ;ignoring nested parens, or parens within quotes
+3 NEW I,L,P,R
+4 SET P=1
SET I=S+1
+5 FOR
Begin DoDot:1
+6 SET R=$$FIND(E,")",I)
SET L=$$FIND(E,"(",I)
+7 IF L
IF L<R
SET P=P+1
SET I=L
QUIT
+8 SET P=P-1
SET I=R
End DoDot:1
if 'P
QUIT
+9 QUIT I
+10 ;
AFTQ(E,I) ;Return character position after quoted string
+1 ;E = string, I=character position of first quote
+2 if '$GET(I)
SET I=1
+3 FOR
SET I=$FIND(E,"""",I+1)
if $EXTRACT(E,I)'=""""
QUIT
+4 if 'I
SET I=$LENGTH(E)+1
+5 QUIT I
+6 ;
QT(X) ;Return X quoted
+1 if $GET(X)=""
QUIT """"""
+2 SET X(X)=""
SET X=$QUERY(X(""))
+3 QUIT $EXTRACT(X,3,$LENGTH(X)-1)
+4 ;
UQT(X) ;Return quoted string X unquoted
+1 if $GET(X)=""
QUIT ""
+2 SET @("X("_X_")=""""")
+3 QUIT $ORDER(X(""))
+4 ;
FIELD(DDP,FLD) ;Get field number
+1 NEW F,P
+2 IF FLD=""
DO BLD^DIALOG(202,"field")
QUIT ""
+3 if $EXTRACT(FLD)=""""
SET FLD=$$UQT($EXTRACT(FLD,1,$$AFTQ(FLD)-1))
+4 SET F=FLD
SET P("FILE")=DDP
+5 IF FLD'=+$PIECE(FLD,"E")
Begin DoDot:1
+6 SET F=$ORDER(^DD(DDP,"B",FLD,""))
+7 IF F=""
SET P(1)=FLD
DO BLD^DIALOG(501,.P)
End DoDot:1
if $GET(DIERR)
QUIT ""
+8 ;
+9 IF $DATA(^DD(DDP,F,0))[0
SET P(1)="#"_F
DO BLD^DIALOG(501,.P)
QUIT ""
+10 QUIT F
+11 ;
GETFLD(FD,BK,PG,DDS,DDSPG,DDSBK,DDSFLG) ;Return "DDO,bk#,pg#"
+1 ;DDSPG=current page, DDSBK=current block
+2 ; -- when block and page are optional
+3 ;PG is required only if block order is sent
+4 ;DDSFLG["F" means field must be form-only
+5 NEW F,B,P,N
+6 IF FD?.N.1"."1.N1",".N.1"."1.N
IF BK=""
IF PG=""
QUIT FD
+7 if $EXTRACT($GET(FD))=""""
SET FD=$$UQT(FD)
+8 if $EXTRACT($GET(BK))=""""
SET BK=$$UQT(BK)
+9 if $EXTRACT($GET(PG))=""""
SET PG=$$UQT(PG)
+10 SET P=+$GET(DDSPG)
SET B=+$GET(DDSBK)
+11 DO @$SELECT($GET(PG)]"":"PG",$GET(BK)]"":"BK",1:"FD")
if $GET(DIERR)
QUIT ""
+12 QUIT F_","_B_","_P
+13 ;
PG ;Get internal page number
+1 IF '$GET(DDS)
DO BLD^DIALOG(3084)
QUIT
+2 SET N=PG=+$PIECE(PG,"E")
+3 IF N
SET P=$ORDER(^DIST(.403,+DDS,40,"B",PG,""))
+4 IF '$TEST
IF PG?1"`".N.1"."1.N
SET P=+$PIECE(PG,"`",2)
SET N=2
+5 IF '$TEST
SET P=$ORDER(^DIST(.403,+DDS,40,"C",$$UPCASE(PG),""))
+6 ;
+7 IF $DATA(^DIST(.403,+DDS,40,+P,0))[0
DO BLD^DIALOG(3023,$SELECT(N=2:"#",N:"number ",1:"named ")_PG)
QUIT
+8 ;
+9 IF BK=""
Begin DoDot:1
+10 SET BK=$ORDER(^DIST(.403,+DDS,40,P,40,"AC",""))
+11 IF BK=""
DO BLD^DIALOG(3055,$SELECT(N:"number ",1:"named ")_PG)
End DoDot:1
if $GET(DIERR)
QUIT
+12 ;
BK ;Get internal block number
+1 SET N=BK=+$PIECE(BK,"E")
+2 IF N
Begin DoDot:1
+3 IF P
SET B=$ORDER(^DIST(.403,+DDS,40,P,40,"AC",BK,""))
QUIT
+4 DO BLD^DIALOG(3085)
End DoDot:1
if $GET(DIERR)
QUIT
+5 IF '$TEST
IF BK?1"`".N.1"."1.N
SET B=+$PIECE(BK,"`",2)
SET N=2
+6 IF '$TEST
Begin DoDot:1
+7 SET B=$ORDER(^DIST(.404,"B",BK,""))
+8 IF B=""
DO BLD^DIALOG(3051,BK)
QUIT
+9 SET B=$ORDER(^DIST(.403,+DDS,40,P,40,"B",B,""))
End DoDot:1
if $GET(DIERR)
QUIT
+10 ;
+11 IF P
IF $DATA(^DIST(.403,+DDS,40,P,40,+B,0))[0
Begin DoDot:1
+12 NEW P1
+13 SET P1(1)=$SELECT(N=2:"#",N:"order ",1:"")_BK
+14 SET P1(2)="number "_$PIECE(^DIST(.403,+DDS,40,P,0),U)_$SELECT($GET(^(1))]"":" ("_$PIECE(^(1),U)_")",1:"")
+15 DO BLD^DIALOG(3053,.P1)
End DoDot:1
QUIT
+16 ;
+17 IF FD=""
Begin DoDot:1
+18 SET FD=$ORDER(^DIST(.404,B,40,"B",""))
+19 if FD=""
DO BLD^DIALOG(3071,$PIECE(^DIST(.404,B,0),U))
End DoDot:1
if $GET(DIERR)
QUIT
+20 ;
FD ;Get internal field number
+1 IF 'B
DO BLD^DIALOG(3082)
QUIT
+2 SET N=FD=+$PIECE(FD,"E")
+3 IF N
SET F=$ORDER(^DIST(.404,B,40,"B",FD,""))
+4 IF '$TEST
IF FD?1"`".N.1"."1.N
SET F=+$PIECE(FD,"`",2)
SET N=2
+5 IF '$TEST
Begin DoDot:1
+6 NEW X
+7 SET FD=$$UPCASE(FD)
SET X=$SELECT($DATA(^DIST(.404,B,40,"D",FD)):"D",1:"C")
+8 SET F=$ORDER(^DIST(.404,B,40,X,FD,""))
End DoDot:1
if $GET(DIERR)
QUIT
+9 ;
+10 IF $DATA(^DIST(.404,B,40,+F,0))[0
Begin DoDot:1
+11 NEW P
+12 SET P(1)=$SELECT(N=2:"#",N:"order ",1:"with caption or unique name ")_FD
+13 SET P(2)=$PIECE(^DIST(.404,B,0),U)
+14 DO BLD^DIALOG(3072,.P)
End DoDot:1
+15 ;
+16 IF '$GET(DIERR)
IF $GET(DDSFLG)["F"
IF "^2^4^"'[(U_$PIECE($GET(^DIST(.404,B,40,+F,0)),U,3)_U)
DO BLD^DIALOG(3081)
+17 QUIT
+18 ;
UPCASE(X) ;
+1 ;Return X in uppercase
+2 ;**
QUIT $$UP^DILIBF(X)
