DDSPRNT2 ;SFISC/MKO-PRINT A FORM ;29JAN2004
;;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.
;
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",$P(DDSFD(4),U)=0:"NO",1:"")) Q:$D(DIRUT)
. D WR("DISABLE EDITING:",$S($P(DDSFD(4),U,4)=2:"REACHABLE",$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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSPRNT2 4351 printed Dec 13, 2024@02:43:27 Page 2
DDSPRNT2 ;SFISC/MKO-PRINT A FORM ;29JAN2004
+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 ;
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",$PIECE(DDSFD(4),U)=0:"NO",1:""))
if $DATA(DIRUT)
QUIT
+44 DO WR("DISABLE EDITING:",$SELECT($PIECE(DDSFD(4),U,4)=2:"REACHABLE",$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
