- DDSPRNT1 ;SFISC/MKO-PRINT A FORM ;11:49 AM 17 Nov 1994
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- 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 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("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
- DDSPRNT1 ;SFISC/MKO-PRINT A FORM ;11:49 AM 17 Nov 1994
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- 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
- 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 ;
- +18 DO WR("PRE ACTION:",$GET(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,11)))
- IF $DATA(DIRUT)
- QUIT
- +19 DO WR("POST ACTION:",$GET(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,12)))
- IF $DATA(DIRUT)
- QUIT
- +20 ;
- +21 KILL DDSBK(1),DDSBK(2)
- +22 SET DDSBK(0)=$GET(^DIST(.404,DDSBK,0))
- IF DDSBK(0)=""
- QUIT
- +23 ;
- +24 IF $Y+6'<IOSL
- DO HEADER^DDSPRNT
- IF $DATA(DIRUT)
- QUIT
- +25 WRITE !!?DDSCOL2,"Block Properties (Block File)"
- +26 WRITE !,?DDSCOL2,"-----------------------------"
- +27 DO BLOCK^DDSPRNT2
- +28 QUIT
- +29 ;
- 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
