DDSCAP ;SFISC/MKO-INPUT TRANSFORM FOR CAPTIONS ;01:24 PM 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.
;
FUNC(X) ;
Q:$E(X)'="!"
N E,F,Y
S F=$E(X,2,999)
S:$P(F,"(")?.A1.L.A F=$$UPCASE($P(F,"("))_$S(F["(":"("_$P(F,"(",2,999),1:"")
Q:$P(F,"(")'?1U.7UN X
Q:$T(@$P(F,"("))="" X
;
D Q:$G(E) X
. N X S X="S Y=$$"_F
. N F D ^DIM
. S:'$D(X) E=1
;
S @("Y=$$"_F)
Q Y
;
L() ;;Get label of field
N F1,F2
S X=""
S F1=$$GET^DDSVAL(DIE,.DA,4) Q:'F1 X
S F2=$$GET^DDSVAL(.404,DA(1),1) Q:'F2 X
S X=$P($G(^DD(F2,F1,0)),U)
Q X
;
T() ;;Get title of field
N F1,F2
S X=""
S F1=$$GET^DDSVAL(DIE,.DA,4) Q:'F1 X
S F2=$$GET^DDSVAL(.404,DA(1),1) Q:'F2 X
S X=$G(^DD(F2,F1,.1))
Q X
;
U() ;;Get unique name of field
Q $$GET^DDSVAL(DIE,.DA,3.1)
;
DUP(X1,X) ;;The DUP function
Q:$G(X1)="" ""
N %
S %=X,X="",$P(X,X1,%\$L(X1)+1)=X1,X=$E(X,1,%)
Q X
;
UPCASE(X) ;Convert X to uppercase
Q $$UP^DILIBF(X) ;**
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSCAP 1227 printed Dec 13, 2024@02:43:11 Page 2
DDSCAP ;SFISC/MKO-INPUT TRANSFORM FOR CAPTIONS ;01:24 PM 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 ;
FUNC(X) ;
+1 if $EXTRACT(X)'="!"
QUIT
+2 NEW E,F,Y
+3 SET F=$EXTRACT(X,2,999)
+4 if $PIECE(F,"(")?.A1.L.A
SET F=$$UPCASE($PIECE(F,"("))_$SELECT(F["(":"("_$PIECE(F,"(",2,999),1:"")
+5 if $PIECE(F,"(")'?1U.7UN
QUIT X
+6 if $TEXT(@$PIECE(F,"("))=""
QUIT X
+7 ;
+8 Begin DoDot:1
+9 NEW X
SET X="S Y=$$"_F
+10 NEW F
DO ^DIM
+11 if '$DATA(X)
SET E=1
End DoDot:1
if $GET(E)
QUIT X
+12 ;
+13 SET @("Y=$$"_F)
+14 QUIT Y
+15 ;
L() ;;Get label of field
+1 NEW F1,F2
+2 SET X=""
+3 SET F1=$$GET^DDSVAL(DIE,.DA,4)
if 'F1
QUIT X
+4 SET F2=$$GET^DDSVAL(.404,DA(1),1)
if 'F2
QUIT X
+5 SET X=$PIECE($GET(^DD(F2,F1,0)),U)
+6 QUIT X
+7 ;
T() ;;Get title of field
+1 NEW F1,F2
+2 SET X=""
+3 SET F1=$$GET^DDSVAL(DIE,.DA,4)
if 'F1
QUIT X
+4 SET F2=$$GET^DDSVAL(.404,DA(1),1)
if 'F2
QUIT X
+5 SET X=$GET(^DD(F2,F1,.1))
+6 QUIT X
+7 ;
U() ;;Get unique name of field
+1 QUIT $$GET^DDSVAL(DIE,.DA,3.1)
+2 ;
DUP(X1,X) ;;The DUP function
+1 if $GET(X1)=""
QUIT ""
+2 NEW %
+3 SET %=X
SET X=""
SET $PIECE(X,X1,%\$LENGTH(X1)+1)=X1
SET X=$EXTRACT(X,1,%)
+4 QUIT X
+5 ;
UPCASE(X) ;Convert X to uppercase
+1 ;**
QUIT $$UP^DILIBF(X)
