DDSPRNT1 ;SFISC/MKO-PRINT A FORM ;9DEC2003
;;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.
;
PAGE ;Print page properties
I $Y+7'<IOSL!(DDSPBRK&'$D(DDSPFRST)) D HEADER^DDSPRNT Q:$D(DIRUT)
I DDSPBRK!$D(DDSPFRST) D
. W !,"Page Page"
. W !,"Number Properties"
. W !,"------ ----------"
K DDSPFRST
;
S DDSCOL1=0,DDSCOL2=8,DDSCOL3=32
F X=0,1 S DDSPG(X)=$G(^DIST(.403,+DDSFORM,40,DDSPG,X))
Q:DDSPG(0)=""
;
D W() Q:$D(DIRUT)
W ?DDSCOL1,$P(DDSPG(0),U),?DDSCOL2,$P(DDSPG(1),U)
;
D W() Q:$D(DIRUT)
D WP^DDSPRNT($NA(^DIST(.403,+DDSFORM,40,DDSPG,15)),DDSCOL2+1)
Q:$D(DIRUT)
;
S X=$P(DDSPG(0),U,2)
I X]"" D Q:$D(DIRUT)
. D WR("HEADER BLOCK:",$P($G(^DIST(.404,X,0)),U)_" (#"_X_")")
. S DDSHBK(X)=""
;
D WR("PAGE COORDINATE:",$P(DDSPG(0),U,3)) Q:$D(DIRUT)
I $P(DDSPG(0),U,6) D WR("IS THIS A POP UP PAGE?:","YES") Q:$D(DIRUT)
D WR("LOWER RIGHT COORDINATE:",$P(DDSPG(0),U,7)) Q:$D(DIRUT)
;
D WR("NEXT PAGE:",$P(DDSPG(0),U,4)) Q:$D(DIRUT)
D WR("PREVIOUS PAGE:",$P(DDSPG(0),U,5)) Q:$D(DIRUT)
D WR("PARENT FIELD:",$P(DDSPG(1),U,2)) Q:$D(DIRUT)
;
D WR("PRE ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,11))) Q:$D(DIRUT)
D WR("POST ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,12))) Q:$D(DIRUT)
K DDSPG(0),DDSPG(1)
;
;Loop through all blocks
I $X D W() Q:$D(DIRUT)
Q:'$O(^DIST(.403,+DDSFORM,40,DDSPG,40,0))
;
I $Y+7'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
W !?DDSCOL2,"Block Block"
W !?DDSCOL2,"Order Properties (Form File)"
W !?DDSCOL2,"----- ----------------------"
;
N DDSBKO
S DDSBKO=""
F S DDSBKO=$O(^DIST(.403,+DDSFORM,40,DDSPG,40,"AC",DDSBKO)) Q:DDSBKO=""!$D(DIRUT) S DDSBK=0 F S DDSBK=$O(^DIST(.403,+DDSFORM,40,DDSPG,40,"AC",DDSBKO,DDSBK)) Q:'DDSBK!$D(DIRUT) D BLOCK
Q
;
BLOCK ;Print Block properties
S DDSCOL1=8,DDSCOL2=15,DDSCOL3=39
F X=0,1,2,"COMP MUL","COMP MUL PTR" S DDSBK(X)=$G(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,X))
Q:DDSBK(0)=""
;
D W($P(DDSBK(0),U,2),DDSCOL1) Q:$D(DIRUT)
W ?DDSCOL2,$P($G(^DIST(.404,DDSBK,0)),U)_" (#"_DDSBK_")"
D W() Q:$D(DIRUT)
;
D WR("TYPE OF BLOCK:",$$EXTERNAL^DILFD(.4032,3,"",$P(DDSBK(0),U,4))) Q:$D(DIRUT)
D WR("BLOCK COORDINATE:",$P(DDSBK(0),U,3)) Q:$D(DIRUT)
D WR("POINTER LINK:",$P(DDSBK(1),U)) Q:$D(DIRUT)
D WR("REPLICATION:",$P(DDSBK(2),U)) Q:$D(DIRUT)
D WR("INDEX:",$P(DDSBK(2),U,2)) Q:$D(DIRUT)
D WR("INITIAL POSITION:",$P(DDSBK(2),U,3)) Q:$D(DIRUT)
D WR("DISALLOW LAYGO",$P(DDSBK(2),U,4)) Q:$D(DIRUT)
D WR("FIELD FOR SELECTION:",$P(DDSBK(2),U,5)) Q:$D(DIRUT)
D WR("COMPUTED MULTIPLE:",DDSBK("COMP MUL")) Q:$D(DIRUT)
D WR("COMPUTED MULTIPLE POINTER:",DDSBK("COMP MUL PTR")) Q:$D(DIRUT)
;
D WR("PRE ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,11))) Q:$D(DIRUT)
D WR("POST ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,12))) Q:$D(DIRUT)
;
K DDSBK(1),DDSBK(2)
S DDSBK(0)=$G(^DIST(.404,DDSBK,0)) Q:DDSBK(0)=""
;
I $Y+6'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
W !!?DDSCOL2,"Block Properties (Block File)"
W !,?DDSCOL2,"-----------------------------"
D BLOCK^DDSPRNT2
Q
;
HBLKS ;Header blocks
Q:'$D(DDSHBK)
I $Y+7'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
W !!,"Header Block Properties"
W !,"------------------------"
S DDSCOL1=8,DDSCOL2=15,DDSCOL3=39
S DDSBK="" F S DDSBK=$O(DDSHBK(DDSBK)) Q:'DDSBK!$D(DIRUT) D
. S DDSBK(0)=$G(^DIST(.404,DDSBK,0)) Q:DDSBK(0)=""
. D W("NAME: "_$P(DDSBK(0),U)_" (#"_DDSBK_")") Q:$D(DIRUT)
. D W() Q:$D(DIRUT)
. D BLOCK^DDSPRNT2
. D W() Q:$D(DIRUT)
Q
;
WR(DDSLAB,DDSVAL,DDSFLG) ;Write label and value
I DDSVAL="",'$G(DDSFLG) Q
;
D W() Q:$D(DIRUT)
W ?DDSCOL2,DDSLAB
;
I $X>DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1
D PCOL(DDSVAL,DDSCOL3)
Q
;
PCOL(DDSVAL,DDSCOL) ;Print DDSVAL starting in column DDSCOL
N DDSWIDTH,DDSIND
S DDSWIDTH=IOM-DDSCOL-1
F DDSIND=1:DDSWIDTH:$L(DDSVAL) D Q:$D(DIRUT)
. I DDSIND>1 D W() Q:$D(DIRUT)
. W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1)
Q
;
W(DDSSTR,DDSCOL) ;Write DDSSTR preceded by !?DDSCOL
I $Y+3'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
W !?+$G(DDSCOL),$G(DDSSTR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSPRNT1 4332 printed Oct 16, 2024@18:44 Page 2
DDSPRNT1 ;SFISC/MKO-PRINT A FORM ;9DEC2003
+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 ;
PAGE ;Print page properties
+1 IF $Y+7'<IOSL!(DDSPBRK&'$DATA(DDSPFRST))
DO HEADER^DDSPRNT
if $DATA(DIRUT)
QUIT
+2 IF DDSPBRK!$DATA(DDSPFRST)
Begin DoDot:1
+3 WRITE !,"Page Page"
+4 WRITE !,"Number Properties"
+5 WRITE !,"------ ----------"
End DoDot:1
+6 KILL DDSPFRST
+7 ;
+8 SET DDSCOL1=0
SET DDSCOL2=8
SET DDSCOL3=32
+9 FOR X=0,1
SET DDSPG(X)=$GET(^DIST(.403,+DDSFORM,40,DDSPG,X))
+10 if DDSPG(0)=""
QUIT
+11 ;
+12 DO W()
if $DATA(DIRUT)
QUIT
+13 WRITE ?DDSCOL1,$PIECE(DDSPG(0),U),?DDSCOL2,$PIECE(DDSPG(1),U)
+14 ;
+15 DO W()
if $DATA(DIRUT)
QUIT
+16 DO WP^DDSPRNT($NAME(^DIST(.403,+DDSFORM,40,DDSPG,15)),DDSCOL2+1)
+17 if $DATA(DIRUT)
QUIT
+18 ;
+19 SET X=$PIECE(DDSPG(0),U,2)
+20 IF X]""
Begin DoDot:1
+21 DO WR("HEADER BLOCK:",$PIECE($GET(^DIST(.404,X,0)),U)_" (#"_X_")")
+22 SET DDSHBK(X)=""
End DoDot:1
if $DATA(DIRUT)
QUIT
+23 ;
+24 DO WR("PAGE COORDINATE:",$PIECE(DDSPG(0),U,3))
if $DATA(DIRUT)
QUIT
+25 IF $PIECE(DDSPG(0),U,6)
DO WR("IS THIS A POP UP PAGE?:","YES")
if $DATA(DIRUT)
QUIT
+26 DO WR("LOWER RIGHT COORDINATE:",$PIECE(DDSPG(0),U,7))
if $DATA(DIRUT)
QUIT
+27 ;
+28 DO WR("NEXT PAGE:",$PIECE(DDSPG(0),U,4))
if $DATA(DIRUT)
QUIT
+29 DO WR("PREVIOUS PAGE:",$PIECE(DDSPG(0),U,5))
if $DATA(DIRUT)
QUIT
+30 DO WR("PARENT FIELD:",$PIECE(DDSPG(1),U,2))
if $DATA(DIRUT)
QUIT
+31 ;
+32 DO WR("PRE ACTION:",$GET(^DIST(.403,+DDSFORM,40,DDSPG,11)))
if $DATA(DIRUT)
QUIT
+33 DO WR("POST ACTION:",$GET(^DIST(.403,+DDSFORM,40,DDSPG,12)))
if $DATA(DIRUT)
QUIT
+34 KILL DDSPG(0),DDSPG(1)
+35 ;
+36 ;Loop through all blocks
+37 IF $X
DO W()
if $DATA(DIRUT)
QUIT
+38 if '$ORDER(^DIST(.403,+DDSFORM,40,DDSPG,40,0))
QUIT
+39 ;
+40 IF $Y+7'<IOSL
DO HEADER^DDSPRNT
if $DATA(DIRUT)
QUIT
+41 WRITE !?DDSCOL2,"Block Block"
+42 WRITE !?DDSCOL2,"Order Properties (Form File)"
+43 WRITE !?DDSCOL2,"----- ----------------------"
+44 ;
+45 NEW DDSBKO
+46 SET DDSBKO=""
+47 FOR
SET DDSBKO=$ORDER(^DIST(.403,+DDSFORM,40,DDSPG,40,"AC",DDSBKO))
if DDSBKO=""!$DATA(DIRUT)
QUIT
SET DDSBK=0
FOR
SET DDSBK=$ORDER(^DIST(.403,+DDSFORM,40,DDSPG,40,"AC",DDSBKO,DDSBK))
if 'DDSBK!$DATA(DIRUT)
QUIT
DO BLOCK
+48 QUIT
+49 ;
BLOCK ;Print Block properties
+1 SET DDSCOL1=8
SET DDSCOL2=15
SET DDSCOL3=39
+2 FOR X=0,1,2,"COMP MUL","COMP MUL PTR"
SET DDSBK(X)=$GET(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,X))
+3 if DDSBK(0)=""
QUIT
+4 ;
+5 DO W($PIECE(DDSBK(0),U,2),DDSCOL1)
if $DATA(DIRUT)
QUIT
+6 WRITE ?DDSCOL2,$PIECE($GET(^DIST(.404,DDSBK,0)),U)_" (#"_DDSBK_")"
+7 DO W()
if $DATA(DIRUT)
QUIT
+8 ;
+9 DO WR("TYPE OF BLOCK:",$$EXTERNAL^DILFD(.4032,3,"",$PIECE(DDSBK(0),U,4)))
if $DATA(DIRUT)
QUIT
+10 DO WR("BLOCK COORDINATE:",$PIECE(DDSBK(0),U,3))
if $DATA(DIRUT)
QUIT
+11 DO WR("POINTER LINK:",$PIECE(DDSBK(1),U))
if $DATA(DIRUT)
QUIT
+12 DO WR("REPLICATION:",$PIECE(DDSBK(2),U))
if $DATA(DIRUT)
QUIT
+13 DO WR("INDEX:",$PIECE(DDSBK(2),U,2))
if $DATA(DIRUT)
QUIT
+14 DO WR("INITIAL POSITION:",$PIECE(DDSBK(2),U,3))
if $DATA(DIRUT)
QUIT
+15 DO WR("DISALLOW LAYGO",$PIECE(DDSBK(2),U,4))
if $DATA(DIRUT)
QUIT
+16 DO WR("FIELD FOR SELECTION:",$PIECE(DDSBK(2),U,5))
if $DATA(DIRUT)
QUIT
+17 DO WR("COMPUTED MULTIPLE:",DDSBK("COMP MUL"))
if $DATA(DIRUT)
QUIT
+18 DO WR("COMPUTED MULTIPLE POINTER:",DDSBK("COMP MUL PTR"))
if $DATA(DIRUT)
QUIT
+19 ;
+20 DO WR("PRE ACTION:",$GET(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,11)))
if $DATA(DIRUT)
QUIT
+21 DO WR("POST ACTION:",$GET(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,12)))
if $DATA(DIRUT)
QUIT
+22 ;
+23 KILL DDSBK(1),DDSBK(2)
+24 SET DDSBK(0)=$GET(^DIST(.404,DDSBK,0))
if DDSBK(0)=""
QUIT
+25 ;
+26 IF $Y+6'<IOSL
DO HEADER^DDSPRNT
if $DATA(DIRUT)
QUIT
+27 WRITE !!?DDSCOL2,"Block Properties (Block File)"
+28 WRITE !,?DDSCOL2,"-----------------------------"
+29 DO BLOCK^DDSPRNT2
+30 QUIT
+31 ;
HBLKS ;Header blocks
+1 if '$DATA(DDSHBK)
QUIT
+2 IF $Y+7'<IOSL
DO HEADER^DDSPRNT
if $DATA(DIRUT)
QUIT
+3 WRITE !!,"Header Block Properties"
+4 WRITE !,"------------------------"
+5 SET DDSCOL1=8
SET DDSCOL2=15
SET DDSCOL3=39
+6 SET DDSBK=""
FOR
SET DDSBK=$ORDER(DDSHBK(DDSBK))
if 'DDSBK!$DATA(DIRUT)
QUIT
Begin DoDot:1
+7 SET DDSBK(0)=$GET(^DIST(.404,DDSBK,0))
if DDSBK(0)=""
QUIT
+8 DO W("NAME: "_$PIECE(DDSBK(0),U)_" (#"_DDSBK_")")
if $DATA(DIRUT)
QUIT
+9 DO W()
if $DATA(DIRUT)
QUIT
+10 DO BLOCK^DDSPRNT2
+11 DO W()
if $DATA(DIRUT)
QUIT
End DoDot:1
+12 QUIT
+13 ;
WR(DDSLAB,DDSVAL,DDSFLG) ;Write label and value
+1 IF DDSVAL=""
IF '$GET(DDSFLG)
QUIT
+2 ;
+3 DO W()
if $DATA(DIRUT)
QUIT
+4 WRITE ?DDSCOL2,DDSLAB
+5 ;
+6 IF $X>DDSCOL3
NEW DDSCOL3
SET DDSCOL3=$X+1
+7 DO PCOL(DDSVAL,DDSCOL3)
+8 QUIT
+9 ;
PCOL(DDSVAL,DDSCOL) ;Print DDSVAL starting in column DDSCOL
+1 NEW DDSWIDTH,DDSIND
+2 SET DDSWIDTH=IOM-DDSCOL-1
+3 FOR DDSIND=1:DDSWIDTH:$LENGTH(DDSVAL)
Begin DoDot:1
+4 IF DDSIND>1
DO W()
if $DATA(DIRUT)
QUIT
+5 WRITE ?DDSCOL,$EXTRACT(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1)
End DoDot:1
if $DATA(DIRUT)
QUIT
+6 QUIT
+7 ;
W(DDSSTR,DDSCOL) ;Write DDSSTR preceded by !?DDSCOL
+1 IF $Y+3'<IOSL
DO HEADER^DDSPRNT
if $DATA(DIRUT)
QUIT
+2 WRITE !?+$GET(DDSCOL),$GET(DDSSTR)
+3 QUIT
