- DDSR1 ;SFISC/MKO-PAINT ;11AUG2004
- ;;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.
- ;
- CAP ;Write captions in "X" nodes
- N DDGLVAN S DDGLVAN=1 ;** DEFEAT OLD LOGIC ABOUT LO-INTENSITY
- W:$D(DDGLVAN) $P(DDGLVID,DDGLDEL,2)
- ;
- EGP N DDCAP,A,C,C1,C2,P,PC,V,X ;**CCO/NI
- I $G(DUZ("LANG"))>1 S DY=$NA(@DDSREFS@("CAP")) F S DY=$Q(@DY) Q:$QS(DY,4)'="CAP" D ;IF WE HAVE A FIELD WITH A FOREIGN LABEL ENTERED, USE IT
- .I $QS(DY,7)=DDS3P S C1=+$QS(DY,8),C2=$P($G(@DDSREFS@(DDS3P,C1)),U,3) I C2 S X=$G(^(C1,+$QS(DY,9),"D")),A=$P(X,U,4) I A S P=$P($G(^DD(C2,A,0)),U),A=$$LABEL^DIALOGZ(C2,A) I A]"",A'=P S DDCAP($$UP^DILIBF($QS(DY,5)))=A
- S DY="" F S DY=$O(@DDSREFS@("X",DDS3P,DY)) Q:DY="" S DX=$O(^(DY,"")),DDS3CAP=^(DX) D X IOXY W DDS3CAP
- .I $G(DUZ("LANG"))>1 D
- ..;I $D(@DDSREFS@("X",DDS3P,DY,DX,"LANG",DUZ("LANG"))) S DDS3CAP=^(DUZ("LANG")) Q
- ..S C="",C2=$$UP^DILIBF(DDS3CAP) F S C=$O(DDCAP(C)) Q:C="" D
- ...S C1=$L(C),P=$F(C2,C) I P S $E(DDS3CAP,P-C1,P-1)=$E(DDCAP(C)_$J("",80),1,C1) ;COULD FIND "NAME" IN "FATHER'S NAME" AND REPLACE IT WITH "NOBRE"!
- ..Q
- ..S C=DDS3CAP,C1=C?.E1":" I C1 S C=$E(C,1,$L(C)-1)
- . Q:'$D(@DDSREFS@("X",DDS3P,DY,DX,"A")) S A=^("A")
- . S X=DDS3CAP,DDS3CAP="",P=1
- . F PC=1:1:$L(A,U) S C=$P(A,U,PC) D:C]""
- .. S C1=$P(C,";"),C2=$P(C,";",2)
- .. S V=$S($P(C,";",3)="U":$P(DDGLVID,DDGLDEL,4),1:"")
- .. S DDS3CAP=DDS3CAP_$E(X,P,C1-1)_V_$E(X,C1,C2)_$P(DDGLVID,DDGLDEL,10)_$S($D(DDGLVAN):$P(DDGLVID,DDGLDEL,2),1:"")
- .. S P=C2+1
- . S DDS3CAP=DDS3CAP_$E(X,P,999)
- ;
- W:$D(DDGLVAN) $P(DDGLVID,DDGLDEL,10)
- K DDS3CAP
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSR1 1821 printed Feb 19, 2025@00:09:45 Page 2
- DDSR1 ;SFISC/MKO-PAINT ;11AUG2004
- +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 ;
- CAP ;Write captions in "X" nodes
- +1 ;** DEFEAT OLD LOGIC ABOUT LO-INTENSITY
- NEW DDGLVAN
- SET DDGLVAN=1
- +2 if $DATA(DDGLVAN)
- WRITE $PIECE(DDGLVID,DDGLDEL,2)
- +3 ;
- EGP ;**CCO/NI
- NEW DDCAP,A,C,C1,C2,P,PC,V,X
- +1 ;IF WE HAVE A FIELD WITH A FOREIGN LABEL ENTERED, USE IT
- IF $GET(DUZ("LANG"))>1
- SET DY=$NAME(@DDSREFS@("CAP"))
- FOR
- SET DY=$QUERY(@DY)
- if $QSUBSCRIPT(DY,4)'="CAP"
- QUIT
- Begin DoDot:1
- +2 IF $QSUBSCRIPT(DY,7)=DDS3P
- SET C1=+$QSUBSCRIPT(DY,8)
- SET C2=$PIECE($GET(@DDSREFS@(DDS3P,C1)),U,3)
- IF C2
- SET X=$GET(^(C1,+$QSUBSCRIPT(DY,9),"D"))
- SET A=$PIECE(X,U,4)
- IF A
- SET P=$PIECE($GET(^DD(C2,A,0)),U)
- SET A=$$LABEL^DIALOGZ(C2,A)
- IF A]""
- IF A'=P
- SET DDCAP($$UP^DILIBF($QSUBSCRIPT(DY,5)))=A
- End DoDot:1
- +3 SET DY=""
- FOR
- SET DY=$ORDER(@DDSREFS@("X",DDS3P,DY))
- if DY=""
- QUIT
- SET DX=$ORDER(^(DY,""))
- SET DDS3CAP=^(DX)
- Begin DoDot:1
- +4 IF $GET(DUZ("LANG"))>1
- Begin DoDot:2
- +5 ;I $D(@DDSREFS@("X",DDS3P,DY,DX,"LANG",DUZ("LANG"))) S DDS3CAP=^(DUZ("LANG")) Q
- +6 SET C=""
- SET C2=$$UP^DILIBF(DDS3CAP)
- FOR
- SET C=$ORDER(DDCAP(C))
- if C=""
- QUIT
- Begin DoDot:3
- +7 ;COULD FIND "NAME" IN "FATHER'S NAME" AND REPLACE IT WITH "NOBRE"!
- SET C1=$LENGTH(C)
- SET P=$FIND(C2,C)
- IF P
- SET $EXTRACT(DDS3CAP,P-C1,P-1)=$EXTRACT(DDCAP(C)_$JUSTIFY("",80),1,C1)
- End DoDot:3
- +8 QUIT
- +9 SET C=DDS3CAP
- SET C1=C?.E1":"
- IF C1
- SET C=$EXTRACT(C,1,$LENGTH(C)-1)
- End DoDot:2
- +10 if '$DATA(@DDSREFS@("X",DDS3P,DY,DX,"A"))
- QUIT
- SET A=^("A")
- +11 SET X=DDS3CAP
- SET DDS3CAP=""
- SET P=1
- +12 FOR PC=1:1:$LENGTH(A,U)
- SET C=$PIECE(A,U,PC)
- if C]""
- Begin DoDot:2
- +13 SET C1=$PIECE(C,";")
- SET C2=$PIECE(C,";",2)
- +14 SET V=$SELECT($PIECE(C,";",3)="U":$PIECE(DDGLVID,DDGLDEL,4),1:"")
- +15 SET DDS3CAP=DDS3CAP_$EXTRACT(X,P,C1-1)_V_$EXTRACT(X,C1,C2)_$PIECE(DDGLVID,DDGLDEL,10)_$SELECT($DATA(DDGLVAN):$PIECE(DDGLVID,DDGLDEL,2),1:"")
- +16 SET P=C2+1
- End DoDot:2
- +17 SET DDS3CAP=DDS3CAP_$EXTRACT(X,P,999)
- End DoDot:1
- XECUTE IOXY
- WRITE DDS3CAP
- +18 ;
- +19 if $DATA(DDGLVAN)
- WRITE $PIECE(DDGLVID,DDGLDEL,10)
- +20 KILL DDS3CAP
- +21 QUIT
