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 Oct 16, 2024@18:44:04 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
