Return to DDSPRNT1.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DDSPRNT1	;SFISC/MKO-PRINT A FORM ;11:49 AM  17 Nov 1994
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	;
    5: PAGE	;Print page properties
    6: 	I $Y+7'<IOSL!(DDSPBRK&'$D(DDSPFRST)) D HEADER^DDSPRNT Q:$D(DIRUT)
    7: 	I DDSPBRK!$D(DDSPFRST) D
    8: 	. W !,"Page    Page"
    9: 	. W !,"Number  Properties"
   10: 	. W !,"------  ----------"
   11: 	K DDSPFRST
   12: 	;
   13: 	S DDSCOL1=0,DDSCOL2=8,DDSCOL3=32
   14: 	F X=0,1 S DDSPG(X)=$G(^DIST(.403,+DDSFORM,40,DDSPG,X))
   15: 	Q:DDSPG(0)=""
   16: 	;
   17: 	D W() Q:$D(DIRUT)
   18: 	W ?DDSCOL1,$P(DDSPG(0),U),?DDSCOL2,$P(DDSPG(1),U)
   19: 	;
   20: 	D W() Q:$D(DIRUT)
   21: 	D WP^DDSPRNT($NA(^DIST(.403,+DDSFORM,40,DDSPG,15)),DDSCOL2+1)
   22: 	Q:$D(DIRUT)
   23: 	;
   24: 	S X=$P(DDSPG(0),U,2)
   25: 	I X]"" D  Q:$D(DIRUT)
   26: 	. D WR("HEADER BLOCK:",$P($G(^DIST(.404,X,0)),U)_" (#"_X_")")
   27: 	. S DDSHBK(X)=""
   28: 	;
   29: 	D WR("PAGE COORDINATE:",$P(DDSPG(0),U,3)) Q:$D(DIRUT)
   30: 	I $P(DDSPG(0),U,6) D WR("IS THIS A POP UP PAGE?:","YES") Q:$D(DIRUT)
   31: 	D WR("LOWER RIGHT COORDINATE:",$P(DDSPG(0),U,7)) Q:$D(DIRUT)
   32: 	;
   33: 	D WR("NEXT PAGE:",$P(DDSPG(0),U,4)) Q:$D(DIRUT)
   34: 	D WR("PREVIOUS PAGE:",$P(DDSPG(0),U,5)) Q:$D(DIRUT)
   35: 	D WR("PARENT FIELD:",$P(DDSPG(1),U,2)) Q:$D(DIRUT)
   36: 	;
   37: 	D WR("PRE ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,11))) Q:$D(DIRUT)
   38: 	D WR("POST ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,12))) Q:$D(DIRUT)
   39: 	K DDSPG(0),DDSPG(1)
   40: 	;
   41: 	;Loop through all blocks
   42: 	I $X D W() Q:$D(DIRUT)
   43: 	Q:'$O(^DIST(.403,+DDSFORM,40,DDSPG,40,0))
   44: 	;
   45: 	I $Y+7'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
   46: 	W !?DDSCOL2,"Block  Block"
   47: 	W !?DDSCOL2,"Order  Properties (Form File)"
   48: 	W !?DDSCOL2,"-----  ----------------------"
   49: 	;
   50: 	N DDSBKO
   51: 	S DDSBKO=""
   52: 	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
   53: 	Q
   54: 	;
   55: BLOCK	;Print Block properties
   56: 	S DDSCOL1=8,DDSCOL2=15,DDSCOL3=39
   57: 	F X=0,1,2 S DDSBK(X)=$G(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,X))
   58: 	Q:DDSBK(0)=""
   59: 	;
   60: 	D W($P(DDSBK(0),U,2),DDSCOL1) Q:$D(DIRUT)
   61: 	W ?DDSCOL2,$P($G(^DIST(.404,DDSBK,0)),U)_" (#"_DDSBK_")"
   62: 	D W() Q:$D(DIRUT)
   63: 	;
   64: 	D WR("TYPE OF BLOCK:",$$EXTERNAL^DILFD(.4032,3,"",$P(DDSBK(0),U,4))) Q:$D(DIRUT)
   65: 	D WR("BLOCK COORDINATE:",$P(DDSBK(0),U,3)) Q:$D(DIRUT)
   66: 	D WR("POINTER LINK:",$P(DDSBK(1),U)) Q:$D(DIRUT)
   67: 	D WR("REPLICATION:",$P(DDSBK(2),U)) Q:$D(DIRUT)
   68: 	D WR("INDEX:",$P(DDSBK(2),U,2)) Q:$D(DIRUT)
   69: 	D WR("INITIAL POSITION:",$P(DDSBK(2),U,3)) Q:$D(DIRUT)
   70: 	D WR("DISALLOW LAYGO",$P(DDSBK(2),U,4)) Q:$D(DIRUT)
   71: 	D WR("FIELD FOR SELECTION:",$P(DDSBK(2),U,5)) Q:$D(DIRUT)
   72: 	;
   73: 	D WR("PRE ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,11))) Q:$D(DIRUT)
   74: 	D WR("POST ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,12))) Q:$D(DIRUT)
   75: 	;
   76: 	K DDSBK(1),DDSBK(2)
   77: 	S DDSBK(0)=$G(^DIST(.404,DDSBK,0)) Q:DDSBK(0)=""
   78: 	;
   79: 	I $Y+6'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
   80: 	W !!?DDSCOL2,"Block Properties (Block File)"
   81: 	W !,?DDSCOL2,"-----------------------------"
   82: 	D BLOCK^DDSPRNT2
   83: 	Q
   84: 	;
   85: HBLKS	;Header blocks
   86: 	Q:'$D(DDSHBK)
   87: 	I $Y+7'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
   88: 	W !!,"Header Block Properties"
   89: 	W !,"------------------------"
   90: 	S DDSCOL1=8,DDSCOL2=15,DDSCOL3=39
   91: 	S DDSBK="" F  S DDSBK=$O(DDSHBK(DDSBK)) Q:'DDSBK!$D(DIRUT)  D
   92: 	. S DDSBK(0)=$G(^DIST(.404,DDSBK,0)) Q:DDSBK(0)=""
   93: 	. D W("NAME: "_$P(DDSBK(0),U)_" (#"_DDSBK_")") Q:$D(DIRUT)
   94: 	. D W() Q:$D(DIRUT)
   95: 	. D BLOCK^DDSPRNT2
   96: 	. D W() Q:$D(DIRUT)
   97: 	Q
   98: 	;
   99: WR(DDSLAB,DDSVAL,DDSFLG)	;Write label and value
  100: 	I DDSVAL="",'$G(DDSFLG) Q
  101: 	;
  102: 	D W() Q:$D(DIRUT)
  103: 	W ?DDSCOL2,DDSLAB
  104: 	;
  105: 	I $X>DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1
  106: 	D PCOL(DDSVAL,DDSCOL3)
  107: 	Q
  108: 	;
  109: PCOL(DDSVAL,DDSCOL)	;Print DDSVAL starting in column DDSCOL
  110: 	N DDSWIDTH,DDSIND
  111: 	S DDSWIDTH=IOM-DDSCOL-1
  112: 	F DDSIND=1:DDSWIDTH:$L(DDSVAL) D  Q:$D(DIRUT)
  113: 	. I DDSIND>1 D W() Q:$D(DIRUT)
  114: 	. W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1)
  115: 	Q
  116: 	;
  117: W(DDSSTR,DDSCOL)	;Write DDSSTR preceded by !?DDSCOL
  118: 	I $Y+3'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
  119: 	W !?+$G(DDSCOL),$G(DDSSTR)
  120: 	Q