- DDSPRNT2 ;SFISC/MKO-PRINT A FORM ;10:52 AM 23 Aug 1995
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- BLOCK ;Print Block properties from Block file
- D WP^DDSPRNT($NA(^DIST(.404,DDSBK,15)),DDSCOL2+1,"AB") Q:$D(DIRUT)
- ;
- D WR("DATA DICTIONARY NUMBER:",$P(DDSBK(0),U,2),1) Q:$D(DIRUT)
- S X=$P(DDSBK(0),U,3)
- I X]"" D WR("DISABLE NAVIGATION:",$$EXTERNAL^DILFD(.404,2,"",$P(DDSBK(0),U,3))) Q:$D(DIRUT)
- ;
- D WR("PRE ACTION:",$G(^DIST(.404,DDSBK,11))) Q:$D(DIRUT)
- D WR("POST ACTION:",$G(^DIST(.404,DDSBK,12))) Q:$D(DIRUT)
- K DDSBK(0)
- ;
- ;Loop through all fields
- I $X D W() Q:$D(DIRUT)
- Q:'$O(^DIST(.404,DDSBK,40,0))
- ;
- D:$Y+7'<IOSL HEADER^DDSPRNT Q:$D(DIRUT)
- W !?DDSCOL2,"Field Field"
- W !?DDSCOL2,"Order Properties"
- W !?DDSCOL2,"----- ----------"
- ;
- N DDSFD,DDSFDO
- S DDSFDO=""
- F S DDSFDO=$O(^DIST(.404,DDSBK,40,"B",DDSFDO)) Q:DDSFDO=""!$D(DIRUT) S DDSFD=0 F S DDSFD=$O(^DIST(.404,DDSBK,40,"B",DDSFDO,DDSFD)) Q:'DDSFD!$D(DIRUT) D FIELD
- ;
- Q
- ;
- FIELD ;Print Block properties
- S DDSCOL1=15,DDSCOL2=22,DDSCOL3=45
- F X=0,2,4,20 S DDSFD(X)=$G(^DIST(.404,DDSBK,40,DDSFD,X))
- Q:DDSFD(0)=""
- ;
- D W(DDSFDO,DDSCOL1) Q:$D(DIRUT)
- W ?DDSCOL2,"FIELD TYPE:"
- W ?DDSCOL3,$$EXTERNAL^DILFD(.4044,2,"",$P(DDSFD(0),U,3))
- ;
- D WR("CAPTION:",$P(DDSFD(0),U,2)) Q:$D(DIRUT)
- D WR("EXECUTABLE CAPTION:",$G(^DIST(.404,DDSBK,40,DDSFD,.1))) Q:$D(DIRUT)
- D WR("DISPLAY GROUP:",$P(DDSFD(0),U,4)) Q:$D(DIRUT)
- ;
- D WR("UNIQUE NAME:",$P(DDSFD(0),U,5)) Q:$D(DIRUT)
- ;
- D WR("FIELD:",$P($G(^DIST(.404,DDSBK,40,DDSFD,1)),U)) Q:$D(DIRUT)
- D WR("COMPUTED EXPRESSION:",$G(^DIST(.404,DDSBK,40,DDSFD,30))) Q:$D(DIRUT)
- ;
- I DDSFD(20)'?."^" D Q:$D(DIRUT)
- . D WR("READ TYPE:",$$EXTERNAL^DILFD(.4044,20.1,"",$P(DDSFD(20),U))) Q:$D(DIRUT)
- . D WR("PARAMETERS:",$P(DDSFD(20),U,2)) Q:$D(DIRUT)
- . D WR("QUALIFIERS:",$P(DDSFD(20),U,3)) Q:$D(DIRUT)
- . ;
- . S DDSWP=$NA(^DIST(.404,DDSBK,40,DDSFD,21))
- . I $P($G(@DDSWP@(0)),U,3) D
- .. D W("HELP:",DDSCOL2) Q:$D(DIRUT)
- .. D WP^DDSPRNT(DDSWP,DDSCOL2+3,"B")
- . K DDSWP Q:$D(DIRUT)
- . ;
- . D WR("INPUT TRANSFORM:",$G(^DIST(.404,DDSBK,40,DDSFD,22))) Q:$D(DIRUT)
- . D WR("SAVE CODE:",$G(^DIST(.404,DDSBK,40,DDSFD,23))) Q:$D(DIRUT)
- . D WR("SCREEN:",$G(^DIST(.404,DDSBK,40,DDSFD,24))) Q:$D(DIRUT)
- . K DDSFD(20)
- ;
- D WR("CAPTION COORDINATE:",$P(DDSFD(2),U,3)) Q:$D(DIRUT)
- D WR("DATA COORDINATE:",$P(DDSFD(2),U)) Q:$D(DIRUT)
- D WR("DATA LENGTH:",$P(DDSFD(2),U,2)) Q:$D(DIRUT)
- D WR("SUPPRESS COLON:",$S($P(DDSFD(2),U,4):"YES",1:"")) Q:$D(DIRUT)
- ;
- D WR("DEFAULT:",$P($G(^DIST(.404,DDSBK,40,DDSFD,3)),U)) Q:$D(DIRUT)
- D WR("EXECUTABLE DEFAULT:",$G(^DIST(.404,DDSBK,40,DDSFD,3.1))) Q:$D(DIRUT)
- ;
- I DDSFD(4)'?."^" D
- . D WR("REQUIRED:",$S($P(DDSFD(4),U):"YES",1:"")) Q:$D(DIRUT)
- . D WR("DISABLE EDITING:",$S($P(DDSFD(4),U,4):"YES",1:"")) Q:$D(DIRUT)
- . D WR("RIGHT JUSTIFY:",$S($P(DDSFD(4),U,3):"YES",1:"")) Q:$D(DIRUT)
- . D WR("DISALLOW LAYGO:",$S($P(DDSFD(4),U,5):"YES",1:"")) Q:$D(DIRUT)
- K DDSFD(4)
- ;
- D WR("SUB PAGE LINK:",$P($G(^DIST(.404,DDSBK,40,DDSFD,7)),U,2)) Q:$D(DIRUT)
- ;
- D WR("BRANCHING LOGIC:",$G(^DIST(.404,DDSBK,40,DDSFD,10))) Q:$D(DIRUT)
- D WR("PRE ACTION:",$G(^DIST(.404,DDSBK,40,DDSFD,11))) Q:$D(DIRUT)
- D WR("POST ACTION:",$G(^DIST(.404,DDSBK,40,DDSFD,12))) Q:$D(DIRUT)
- D WR("POST ACTION ON CHANGE:",$G(^DIST(.404,DDSBK,40,DDSFD,13))) Q:$D(DIRUT)
- D WR("DATA VALIDATION:",$G(^DIST(.404,DDSBK,40,DDSFD,14))) Q:$D(DIRUT)
- ;
- 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
- DDSPRNT2 ;SFISC/MKO-PRINT A FORM ;10:52 AM 23 Aug 1995
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- BLOCK ;Print Block properties from Block file
- +1 DO WP^DDSPRNT($NAME(^DIST(.404,DDSBK,15)),DDSCOL2+1,"AB")
- IF $DATA(DIRUT)
- QUIT
- +2 ;
- +3 DO WR("DATA DICTIONARY NUMBER:",$PIECE(DDSBK(0),U,2),1)
- IF $DATA(DIRUT)
- QUIT
- +4 SET X=$PIECE(DDSBK(0),U,3)
- +5 IF X]""
- DO WR("DISABLE NAVIGATION:",$$EXTERNAL^DILFD(.404,2,"",$PIECE(DDSBK(0),U,3)))
- IF $DATA(DIRUT)
- QUIT
- +6 ;
- +7 DO WR("PRE ACTION:",$GET(^DIST(.404,DDSBK,11)))
- IF $DATA(DIRUT)
- QUIT
- +8 DO WR("POST ACTION:",$GET(^DIST(.404,DDSBK,12)))
- IF $DATA(DIRUT)
- QUIT
- +9 KILL DDSBK(0)
- +10 ;
- +11 ;Loop through all fields
- +12 IF $X
- DO W()
- IF $DATA(DIRUT)
- QUIT
- +13 IF '$ORDER(^DIST(.404,DDSBK,40,0))
- QUIT
- +14 ;
- +15 IF $Y+7'<IOSL
- DO HEADER^DDSPRNT
- IF $DATA(DIRUT)
- QUIT
- +16 WRITE !?DDSCOL2,"Field Field"
- +17 WRITE !?DDSCOL2,"Order Properties"
- +18 WRITE !?DDSCOL2,"----- ----------"
- +19 ;
- +20 NEW DDSFD,DDSFDO
- +21 SET DDSFDO=""
- +22 FOR
- SET DDSFDO=$ORDER(^DIST(.404,DDSBK,40,"B",DDSFDO))
- IF DDSFDO=""!$DATA(DIRUT)
- QUIT
- SET DDSFD=0
- FOR
- SET DDSFD=$ORDER(^DIST(.404,DDSBK,40,"B",DDSFDO,DDSFD))
- IF 'DDSFD!$DATA(DIRUT)
- QUIT
- DO FIELD
- +23 ;
- +24 QUIT
- +25 ;
- FIELD ;Print Block properties
- +1 SET DDSCOL1=15
- SET DDSCOL2=22
- SET DDSCOL3=45
- +2 FOR X=0,2,4,20
- SET DDSFD(X)=$GET(^DIST(.404,DDSBK,40,DDSFD,X))
- +3 IF DDSFD(0)=""
- QUIT
- +4 ;
- +5 DO W(DDSFDO,DDSCOL1)
- IF $DATA(DIRUT)
- QUIT
- +6 WRITE ?DDSCOL2,"FIELD TYPE:"
- +7 WRITE ?DDSCOL3,$$EXTERNAL^DILFD(.4044,2,"",$PIECE(DDSFD(0),U,3))
- +8 ;
- +9 DO WR("CAPTION:",$PIECE(DDSFD(0),U,2))
- IF $DATA(DIRUT)
- QUIT
- +10 DO WR("EXECUTABLE CAPTION:",$GET(^DIST(.404,DDSBK,40,DDSFD,.1)))
- IF $DATA(DIRUT)
- QUIT
- +11 DO WR("DISPLAY GROUP:",$PIECE(DDSFD(0),U,4))
- IF $DATA(DIRUT)
- QUIT
- +12 ;
- +13 DO WR("UNIQUE NAME:",$PIECE(DDSFD(0),U,5))
- IF $DATA(DIRUT)
- QUIT
- +14 ;
- +15 DO WR("FIELD:",$PIECE($GET(^DIST(.404,DDSBK,40,DDSFD,1)),U))
- IF $DATA(DIRUT)
- QUIT
- +16 DO WR("COMPUTED EXPRESSION:",$GET(^DIST(.404,DDSBK,40,DDSFD,30)))
- IF $DATA(DIRUT)
- QUIT
- +17 ;
- +18 IF DDSFD(20)'?."^"
- Begin DoDot:1
- +19 DO WR("READ TYPE:",$$EXTERNAL^DILFD(.4044,20.1,"",$PIECE(DDSFD(20),U)))
- IF $DATA(DIRUT)
- QUIT
- +20 DO WR("PARAMETERS:",$PIECE(DDSFD(20),U,2))
- IF $DATA(DIRUT)
- QUIT
- +21 DO WR("QUALIFIERS:",$PIECE(DDSFD(20),U,3))
- IF $DATA(DIRUT)
- QUIT
- +22 ;
- +23 SET DDSWP=$NAME(^DIST(.404,DDSBK,40,DDSFD,21))
- +24 IF $PIECE($GET(@DDSWP@(0)),U,3)
- Begin DoDot:2
- +25 DO W("HELP:",DDSCOL2)
- IF $DATA(DIRUT)
- QUIT
- +26 DO WP^DDSPRNT(DDSWP,DDSCOL2+3,"B")
- End DoDot:2
- +27 KILL DDSWP
- IF $DATA(DIRUT)
- QUIT
- +28 ;
- +29 DO WR("INPUT TRANSFORM:",$GET(^DIST(.404,DDSBK,40,DDSFD,22)))
- IF $DATA(DIRUT)
- QUIT
- +30 DO WR("SAVE CODE:",$GET(^DIST(.404,DDSBK,40,DDSFD,23)))
- IF $DATA(DIRUT)
- QUIT
- +31 DO WR("SCREEN:",$GET(^DIST(.404,DDSBK,40,DDSFD,24)))
- IF $DATA(DIRUT)
- QUIT
- +32 KILL DDSFD(20)
- End DoDot:1
- IF $DATA(DIRUT)
- QUIT
- +33 ;
- +34 DO WR("CAPTION COORDINATE:",$PIECE(DDSFD(2),U,3))
- IF $DATA(DIRUT)
- QUIT
- +35 DO WR("DATA COORDINATE:",$PIECE(DDSFD(2),U))
- IF $DATA(DIRUT)
- QUIT
- +36 DO WR("DATA LENGTH:",$PIECE(DDSFD(2),U,2))
- IF $DATA(DIRUT)
- QUIT
- +37 DO WR("SUPPRESS COLON:",$SELECT($PIECE(DDSFD(2),U,4):"YES",1:""))
- IF $DATA(DIRUT)
- QUIT
- +38 ;
- +39 DO WR("DEFAULT:",$PIECE($GET(^DIST(.404,DDSBK,40,DDSFD,3)),U))
- IF $DATA(DIRUT)
- QUIT
- +40 DO WR("EXECUTABLE DEFAULT:",$GET(^DIST(.404,DDSBK,40,DDSFD,3.1)))
- IF $DATA(DIRUT)
- QUIT
- +41 ;
- +42 IF DDSFD(4)'?."^"
- Begin DoDot:1
- +43 DO WR("REQUIRED:",$SELECT($PIECE(DDSFD(4),U):"YES",1:""))
- IF $DATA(DIRUT)
- QUIT
- +44 DO WR("DISABLE EDITING:",$SELECT($PIECE(DDSFD(4),U,4):"YES",1:""))
- IF $DATA(DIRUT)
- QUIT
- +45 DO WR("RIGHT JUSTIFY:",$SELECT($PIECE(DDSFD(4),U,3):"YES",1:""))
- IF $DATA(DIRUT)
- QUIT
- +46 DO WR("DISALLOW LAYGO:",$SELECT($PIECE(DDSFD(4),U,5):"YES",1:""))
- IF $DATA(DIRUT)
- QUIT
- End DoDot:1
- +47 KILL DDSFD(4)
- +48 ;
- +49 DO WR("SUB PAGE LINK:",$PIECE($GET(^DIST(.404,DDSBK,40,DDSFD,7)),U,2))
- IF $DATA(DIRUT)
- QUIT
- +50 ;
- +51 DO WR("BRANCHING LOGIC:",$GET(^DIST(.404,DDSBK,40,DDSFD,10)))
- IF $DATA(DIRUT)
- QUIT
- +52 DO WR("PRE ACTION:",$GET(^DIST(.404,DDSBK,40,DDSFD,11)))
- IF $DATA(DIRUT)
- QUIT
- +53 DO WR("POST ACTION:",$GET(^DIST(.404,DDSBK,40,DDSFD,12)))
- IF $DATA(DIRUT)
- QUIT
- +54 DO WR("POST ACTION ON CHANGE:",$GET(^DIST(.404,DDSBK,40,DDSFD,13)))
- IF $DATA(DIRUT)
- QUIT
- +55 DO WR("DATA VALIDATION:",$GET(^DIST(.404,DDSBK,40,DDSFD,14)))
- IF $DATA(DIRUT)
- QUIT
- +56 ;
- +57 DO W()
- IF $DATA(DIRUT)
- QUIT
- +58 QUIT
- +59 ;
- 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
