DDSRP ;GFT/GFT - PRINT FORM 'DDS', PAGE 'DDS3P';2013-01-25 12:19 PM
;;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.
;
EN(DDS,DDS3P,DDSJ) ; Main Entry Point
I '$G(DDSJ) S DDSJ=$J
N X,Y,IOP,POP,BLK,DDSREFS,DDSREFT
S DDSREFT=$NA(^TMP("DDS",DDSJ,DDS))
S DDSREFS=$NA(^DIST(.403,+DDS,"AY"))
K ^UTILITY($J,"DDSRP")
;Set terminal characterstics for scroll mode
W *27,"[?1000l" ; Mouse Off
W $P(DDGLCLR,DDGLDEL,2) ; Clear ALL screen
S DX=0,DY=0 X IOXY ; Take cursor to 0,0
W $P(DDGLVID,DDGLDEL)_"PRINT SCREEN"_$P(DDGLVID,DDGLDEL,10) ; Write to screen in bold
D KILL^DDGLIB0() ; Turn off screen handling
D ^%ZIS ; Select Device
I POP D HLP^DDSUTL("SORRY, PRINTING FAILED") G ENQ ; Quit if can't open
I $E(IOST,1,2)="C-" S IOF="!" ; On a terminal, make Form Feed a Line Feed
U IO ; Use printer device
D CAP,BLKS,PRINT ; This is where the printing really happens.
D ; Block to new DDS so that the reader can't find it for writing to screen
. N DDS,DIR I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR ; Press Enter to continue
D ^%ZISC ; Close device
ENQ ; Goto label in case we fail to open the device.
D INIT^DDGLIB0() ; Turn screen handling back on again.
I $G(DDS)>0 W *27,"[?1000h" ; Mouse On
D FINISH^DDGLIBP() ; Turn on terminators, off echo, and set RM to zero.
Q
BLKS ;FROM ^DDSR
S BLK=$P($G(^DIST(.403,+DDS,40,DDS3P,0)),U,2) ;Hdr blk
D:BLK]"" DB(DDS3P,BLK)
;
;Other blks
N DDS3BO
S DDS3BO="" F S DDS3BO=$O(^DIST(.403,+DDS,40,DDS3P,40,"AC",DDS3BO)) Q:'DDS3BO S BLK=$O(^(DDS3BO,"")) Q:'BLK D DB(DDS3P,BLK)
Q
;
PRINT ;
N DDSI S DDSI=1
F Y=0:1:$O(^UTILITY($J,"DDSRP",""),-1) W !,$G(^UTILITY($J,"DDSRP",Y)) S DDSI=DDSI+1 I $G(IOSL),DDSI'<IOSL S DDSI=1 I $G(IOF)]"" W @IOF
W ! F Y=1:1:80 W "_"
W:$D(IOF) @IOF
Q
;
CAP N DDCAP,A,C,C1,C2,P,PC,V ; FROM ^DDSR1
I $G(DUZ("LANG")) S DY=$NA(@DDSREFS@("CAP")) F S DY=$Q(@DY) Q:$QS(DY,4)'="CAP" D
.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 A=$$LABEL^DIALOGZ(C2,A) I A]"" 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 PUT(DDS3CAP)
;.I $G(DUZ("LANG")) D
;..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)
;..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 DDS3CAP=DDS3CAP_$E(X,P,C1-1)_V_$E(X,C1,C2)
;.. S P=C2+1
;. S DDS3CAP=DDS3CAP_$E(X,P,999)
Q
;
DB(DDS3P,DDS3B) ;DATA BLOCK
K @DDSREFT@("XCAP",DDS3P,DDS3B)
S DDS3=@DDSREFS@(DDS3P,DDS3B)
S DDS3FN="F"_$P(DDS3,U,3),DDS3REP=$P(DDS3,U,7),DDS3PTB=$P(DDS3,U,8)
K DDS3
;
I $G(DDS3REP)'>1 D
. N DIE
. S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B))
. S:DDS3DA]"" DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3DA,"GL"))
. S DDS3DDO=0
. F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) D:DDS3C]"" DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3PTB)
. K DDS3C,DDS3DA,DDS3DDO
E D DMULT(DDS3P,DDS3B,DDS3FN)
;
K DDS3FN,DDS3PTB,DDS3REP
Q
;
DMULT(DDS3P,DDS3B,DDS3FN) ;Paint data, all lines
N X,DIE
S DDS3PDA=$P($G(@DDSREFT@(DDS3P,DDS3B)),U)
GFT I '$D(^(DDS3B,"COMP MUL")),'DDS3PDA D
. S X="",DDS3STL=1
. S DDS3NREP=$P(@DDSREFS@(DDS3P,DDS3B),U,7),DDS3SEL=$P(^(DDS3B),U,10)
E D
. S X=@DDSREFT@(DDS3P,DDS3B,DDS3PDA)
. S DDS3STL=$P(X,U,3),DDS3NREP=$P(X,U,6),DDS3SEL=$P(X,U,9) ;3RD PIECE SAYS WHICH LINE IS NOW TOP LINE
S DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"GL"))
;
F DDS3LN=1:1:$O(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"A"),-1) D ;PAINT LINES ONE BY ONE
. S DDS3SN=DDS3LN ;START WITH LINE 1 ALWAYS
. S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN))
. D DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3SEL)
F DDS3LN=DDS3LN+1:1:DDS3REP S DY=DY+1,DX=2 D PUT(" ") ;BLANK LINES AT END OF MULTIPLES
K DDS3DA,DDS3LN,DDS3NREP,DDS3PDA,DDS3SEL,DDS3SN,DDS3STL
Q
;
DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3SEL) ;Paint 1 line, LINE DDS3LN
N DDSHITE S DDSHITE=$$HITE^DDSR(DDS3B),DDS3DDO=0
F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) I DDS3C]"" D
. S $P(DDS3C,U)=$P(DDS3C,U)+(DDS3LN-1*DDSHITE) ;DJW/GFT
. S:$P(DDS3C,U,5)]"" $P(DDS3C,U,5)=$P(DDS3C,U,5)+(DDS3LN-1*DDSHITE) ;DJW/GFT
. D DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,1,DDS3LN,DDS3SN)
K DDS3C,DDS3DDO
Q
;
DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3FLG,DDS3LN,DDS3SN) ;Paint field
N DDS3FLD,DDS3LEN,DDSX
D:$P(DDS3C,U,5)]"" XCAP
;
S DY=+DDS3C,DX=$P(DDS3C,U,2)
S DDS3LEN=$P(DDS3C,U,3),DDS3FLD=$P(DDS3C,U,4)
;
;Computed flds
I DDS3DA]"",$P(DDS3C,U,9) S DDSX=$$VAL^DDSCOMP(DDS3DDO,DDS3B,DDS3DA)
;
;Form only flds
Q:DDS3FLD=""
I DDS3FLD'=+DDS3FLD N DDS3FN S DDS3FN="F0"
;
;External form
S:DDS3FLD DDSX=$S(DDS3DA="":"",$D(@DDSREFT@(DDS3FN,DDS3DA,DDS3FLD,"X"))#2:^("X"),1:$G(^("D")))
I $G(DDSX)]""!$G(DDS3FLG) D
. S:$D(DDSX)[0 DDSX=""
. I '$P(DDS3C,U,10) S DDSX=$E(DDSX,1,DDS3LEN)_$J("",DDS3LEN-$L(DDSX))
. E S DDSX=$J("",DDS3LEN-$L(DDSX))_$E(DDSX,1,DDS3LEN)
. D PUT(DDSX)
Q
;
XCAP ;Paint exec caps
N Y,DDSLN,DDSSN
I 'DDS3DA N DA,D0 S (DA,D0)=""
;
I DDS3DA N DDSDL S DDSDL=$L(DDS3DA,",")-2
I N DA,@$$D0^DDS(DDSDL)
I D BLDDA^DDS(DDS3DA)
;
S DDS3TP=$P($G(@DDSREFS@(DDS3P,DDS3B)),U,5)
S DDS3L0=$G(^DIST(.404,DDS3B,40,DDS3DDO,0)) G:DDS3L0?."^" XCAPQ
S DDS3L01=$G(^DIST(.404,DDS3B,40,DDS3DDO,.1)) G:DDS3L01?."^" XCAPQ
;
S:$D(DDS3LN) DDSLN=DDS3LN
S:$D(DDS3SN) DDSSN=DDS3SN
;
X DDS3L01 G:$G(Y)="" XCAPQ
S DDS3CAP=Y
;
I DDS3TP="e","^2^3^"[(U_$P(DDS3L0,U,3)_U)!'$P(DDS3L0,U,3) D
. S Y=$$UP^DILIBF(Y) ;**
. S @DDSREFT@("XCAP",DDS3P,Y,DDS3B,DDS3DDO)=""
;
S DY=$P(DDS3C,U,5),DX=$P(DDS3C,U,6)
S DDS3CAP=DDS3CAP_$P(DDS3C,U,7)
D PUT(DDS3CAP)
XCAPQ K DDS3CAP,DDS3L0,DDS3L01,DDS3TP
Q
;
PUT(X) S $E(^UTILITY($J,"DDSRP",DY),DX+1,DX+$L(X))=X Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSRP 6402 printed Apr 09, 2024@21:53:27 Page 2
DDSRP ;GFT/GFT - PRINT FORM 'DDS', PAGE 'DDS3P';2013-01-25 12:19 PM
+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 ;
EN(DDS,DDS3P,DDSJ) ; Main Entry Point
+1 IF '$GET(DDSJ)
SET DDSJ=$JOB
+2 NEW X,Y,IOP,POP,BLK,DDSREFS,DDSREFT
+3 SET DDSREFT=$NAME(^TMP("DDS",DDSJ,DDS))
+4 SET DDSREFS=$NAME(^DIST(.403,+DDS,"AY"))
+5 KILL ^UTILITY($JOB,"DDSRP")
+6 ;Set terminal characterstics for scroll mode
+7 ; Mouse Off
WRITE *27,"[?1000l"
+8 ; Clear ALL screen
WRITE $PIECE(DDGLCLR,DDGLDEL,2)
+9 ; Take cursor to 0,0
SET DX=0
SET DY=0
XECUTE IOXY
+10 ; Write to screen in bold
WRITE $PIECE(DDGLVID,DDGLDEL)_"PRINT SCREEN"_$PIECE(DDGLVID,DDGLDEL,10)
+11 ; Turn off screen handling
DO KILL^DDGLIB0()
+12 ; Select Device
DO ^%ZIS
+13 ; Quit if can't open
IF POP
DO HLP^DDSUTL("SORRY, PRINTING FAILED")
GOTO ENQ
+14 ; On a terminal, make Form Feed a Line Feed
IF $EXTRACT(IOST,1,2)="C-"
SET IOF="!"
+15 ; Use printer device
USE IO
+16 ; This is where the printing really happens.
DO CAP
DO BLKS
DO PRINT
+17 ; Block to new DDS so that the reader can't find it for writing to screen
Begin DoDot:1
+18 ; Press Enter to continue
NEW DDS,DIR
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
End DoDot:1
+19 ; Close device
DO ^%ZISC
ENQ ; Goto label in case we fail to open the device.
+1 ; Turn screen handling back on again.
DO INIT^DDGLIB0()
+2 ; Mouse On
IF $GET(DDS)>0
WRITE *27,"[?1000h"
+3 ; Turn on terminators, off echo, and set RM to zero.
DO FINISH^DDGLIBP()
+4 QUIT
BLKS ;FROM ^DDSR
+1 ;Hdr blk
SET BLK=$PIECE($GET(^DIST(.403,+DDS,40,DDS3P,0)),U,2)
+2 if BLK]""
DO DB(DDS3P,BLK)
+3 ;
+4 ;Other blks
+5 NEW DDS3BO
+6 SET DDS3BO=""
FOR
SET DDS3BO=$ORDER(^DIST(.403,+DDS,40,DDS3P,40,"AC",DDS3BO))
if 'DDS3BO
QUIT
SET BLK=$ORDER(^(DDS3BO,""))
if 'BLK
QUIT
DO DB(DDS3P,BLK)
+7 QUIT
+8 ;
PRINT ;
+1 NEW DDSI
SET DDSI=1
+2 FOR Y=0:1:$ORDER(^UTILITY($JOB,"DDSRP",""),-1)
WRITE !,$GET(^UTILITY($JOB,"DDSRP",Y))
SET DDSI=DDSI+1
IF $GET(IOSL)
IF DDSI'<IOSL
SET DDSI=1
IF $GET(IOF)]""
WRITE @IOF
+3 WRITE !
FOR Y=1:1:80
WRITE "_"
+4 if $DATA(IOF)
WRITE @IOF
+5 QUIT
+6 ;
CAP ; FROM ^DDSR1
NEW DDCAP,A,C,C1,C2,P,PC,V
+1 IF $GET(DUZ("LANG"))
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 A=$$LABEL^DIALOGZ(C2,A)
IF A]""
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)
DO PUT(DDS3CAP)
+4 ;.I $G(DUZ("LANG")) D
+5 ;..S C="",C2=$$UP^DILIBF(DDS3CAP) F S C=$O(DDCAP(C)) Q:C="" D
+6 ;...S C1=$L(C),P=$F(C2,C) I P S $E(DDS3CAP,P-C1,P-1)=$E(DDCAP(C)_$J("",80),1,C1)
+7 ;..Q
+8 ;..S C=DDS3CAP,C1=C?.E1":" I C1 S C=$E(C,1,$L(C)-1)
+9 ;. Q:'$D(@DDSREFS@("X",DDS3P,DY,DX,"A")) S A=^("A")
+10 ;. S X=DDS3CAP,DDS3CAP="",P=1
+11 ;. F PC=1:1:$L(A,U) S C=$P(A,U,PC) D:C]""
+12 ;.. S C1=$P(C,";"),C2=$P(C,";",2)
+13 ;.. S DDS3CAP=DDS3CAP_$E(X,P,C1-1)_V_$E(X,C1,C2)
+14 ;.. S P=C2+1
+15 ;. S DDS3CAP=DDS3CAP_$E(X,P,999)
+16 QUIT
+17 ;
DB(DDS3P,DDS3B) ;DATA BLOCK
+1 KILL @DDSREFT@("XCAP",DDS3P,DDS3B)
+2 SET DDS3=@DDSREFS@(DDS3P,DDS3B)
+3 SET DDS3FN="F"_$PIECE(DDS3,U,3)
SET DDS3REP=$PIECE(DDS3,U,7)
SET DDS3PTB=$PIECE(DDS3,U,8)
+4 KILL DDS3
+5 ;
+6 IF $GET(DDS3REP)'>1
Begin DoDot:1
+7 NEW DIE
+8 SET DDS3DA=$GET(@DDSREFT@(DDS3P,DDS3B))
+9 if DDS3DA]""
SET DIE=$GET(@DDSREFT@(DDS3P,DDS3B,DDS3DA,"GL"))
+10 SET DDS3DDO=0
+11 FOR
SET DDS3DDO=$ORDER(@DDSREFS@(DDS3P,DDS3B,DDS3DDO))
if DDS3DDO'=+DDS3DDO
QUIT
SET DDS3C=$GET(^(DDS3DDO,"D"))
if DDS3C]""
DO DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3PTB)
+12 KILL DDS3C,DDS3DA,DDS3DDO
End DoDot:1
+13 IF '$TEST
DO DMULT(DDS3P,DDS3B,DDS3FN)
+14 ;
+15 KILL DDS3FN,DDS3PTB,DDS3REP
+16 QUIT
+17 ;
DMULT(DDS3P,DDS3B,DDS3FN) ;Paint data, all lines
+1 NEW X,DIE
+2 SET DDS3PDA=$PIECE($GET(@DDSREFT@(DDS3P,DDS3B)),U)
GFT IF '$DATA(^(DDS3B,"COMP MUL"))
IF 'DDS3PDA
Begin DoDot:1
+1 SET X=""
SET DDS3STL=1
+2 SET DDS3NREP=$PIECE(@DDSREFS@(DDS3P,DDS3B),U,7)
SET DDS3SEL=$PIECE(^(DDS3B),U,10)
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 SET X=@DDSREFT@(DDS3P,DDS3B,DDS3PDA)
+5 ;3RD PIECE SAYS WHICH LINE IS NOW TOP LINE
SET DDS3STL=$PIECE(X,U,3)
SET DDS3NREP=$PIECE(X,U,6)
SET DDS3SEL=$PIECE(X,U,9)
End DoDot:1
+6 SET DIE=$GET(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"GL"))
+7 ;
+8 ;PAINT LINES ONE BY ONE
FOR DDS3LN=1:1:$ORDER(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"A"),-1)
Begin DoDot:1
+9 ;START WITH LINE 1 ALWAYS
SET DDS3SN=DDS3LN
+10 SET DDS3DA=$GET(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN))
+11 DO DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3SEL)
End DoDot:1
+12 ;BLANK LINES AT END OF MULTIPLES
FOR DDS3LN=DDS3LN+1:1:DDS3REP
SET DY=DY+1
SET DX=2
DO PUT(" ")
+13 KILL DDS3DA,DDS3LN,DDS3NREP,DDS3PDA,DDS3SEL,DDS3SN,DDS3STL
+14 QUIT
+15 ;
DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3SEL) ;Paint 1 line, LINE DDS3LN
+1 NEW DDSHITE
SET DDSHITE=$$HITE^DDSR(DDS3B)
SET DDS3DDO=0
+2 FOR
SET DDS3DDO=$ORDER(@DDSREFS@(DDS3P,DDS3B,DDS3DDO))
if DDS3DDO'=+DDS3DDO
QUIT
SET DDS3C=$GET(^(DDS3DDO,"D"))
IF DDS3C]""
Begin DoDot:1
+3 ;DJW/GFT
SET $PIECE(DDS3C,U)=$PIECE(DDS3C,U)+(DDS3LN-1*DDSHITE)
+4 ;DJW/GFT
if $PIECE(DDS3C,U,5)]""
SET $PIECE(DDS3C,U,5)=$PIECE(DDS3C,U,5)+(DDS3LN-1*DDSHITE)
+5 DO DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,1,DDS3LN,DDS3SN)
End DoDot:1
+6 KILL DDS3C,DDS3DDO
+7 QUIT
+8 ;
DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3FLG,DDS3LN,DDS3SN) ;Paint field
+1 NEW DDS3FLD,DDS3LEN,DDSX
+2 if $PIECE(DDS3C,U,5)]""
DO XCAP
+3 ;
+4 SET DY=+DDS3C
SET DX=$PIECE(DDS3C,U,2)
+5 SET DDS3LEN=$PIECE(DDS3C,U,3)
SET DDS3FLD=$PIECE(DDS3C,U,4)
+6 ;
+7 ;Computed flds
+8 IF DDS3DA]""
IF $PIECE(DDS3C,U,9)
SET DDSX=$$VAL^DDSCOMP(DDS3DDO,DDS3B,DDS3DA)
+9 ;
+10 ;Form only flds
+11 if DDS3FLD=""
QUIT
+12 IF DDS3FLD'=+DDS3FLD
NEW DDS3FN
SET DDS3FN="F0"
+13 ;
+14 ;External form
+15 if DDS3FLD
SET DDSX=$SELECT(DDS3DA="":"",$DATA(@DDSREFT@(DDS3FN,DDS3DA,DDS3FLD,"X"))#2:^("X"),1:$GET(^("D")))
+16 IF $GET(DDSX)]""!$GET(DDS3FLG)
Begin DoDot:1
+17 if $DATA(DDSX)[0
SET DDSX=""
+18 IF '$PIECE(DDS3C,U,10)
SET DDSX=$EXTRACT(DDSX,1,DDS3LEN)_$JUSTIFY("",DDS3LEN-$LENGTH(DDSX))
+19 IF '$TEST
SET DDSX=$JUSTIFY("",DDS3LEN-$LENGTH(DDSX))_$EXTRACT(DDSX,1,DDS3LEN)
+20 DO PUT(DDSX)
End DoDot:1
+21 QUIT
+22 ;
XCAP ;Paint exec caps
+1 NEW Y,DDSLN,DDSSN
+2 IF 'DDS3DA
NEW DA,D0
SET (DA,D0)=""
+3 ;
+4 IF DDS3DA
NEW DDSDL
SET DDSDL=$LENGTH(DDS3DA,",")-2
+5 IF $TEST
NEW DA,@$$D0^DDS(DDSDL)
+6 IF $TEST
DO BLDDA^DDS(DDS3DA)
+7 ;
+8 SET DDS3TP=$PIECE($GET(@DDSREFS@(DDS3P,DDS3B)),U,5)
+9 SET DDS3L0=$GET(^DIST(.404,DDS3B,40,DDS3DDO,0))
if DDS3L0?."^"
GOTO XCAPQ
+10 SET DDS3L01=$GET(^DIST(.404,DDS3B,40,DDS3DDO,.1))
if DDS3L01?."^"
GOTO XCAPQ
+11 ;
+12 if $DATA(DDS3LN)
SET DDSLN=DDS3LN
+13 if $DATA(DDS3SN)
SET DDSSN=DDS3SN
+14 ;
+15 XECUTE DDS3L01
if $GET(Y)=""
GOTO XCAPQ
+16 SET DDS3CAP=Y
+17 ;
+18 IF DDS3TP="e"
IF "^2^3^"[(U_$PIECE(DDS3L0,U,3)_U)!'$PIECE(DDS3L0,U,3)
Begin DoDot:1
+19 ;**
SET Y=$$UP^DILIBF(Y)
+20 SET @DDSREFT@("XCAP",DDS3P,Y,DDS3B,DDS3DDO)=""
End DoDot:1
+21 ;
+22 SET DY=$PIECE(DDS3C,U,5)
SET DX=$PIECE(DDS3C,U,6)
+23 SET DDS3CAP=DDS3CAP_$PIECE(DDS3C,U,7)
+24 DO PUT(DDS3CAP)
XCAPQ KILL DDS3CAP,DDS3L0,DDS3L01,DDS3TP
+1 QUIT
+2 ;
PUT(X) SET $EXTRACT(^UTILITY($JOB,"DDSRP",DY),DX+1,DX+$LENGTH(X))=X
QUIT
+1 ;
