DDSPRNT ;SFISC/MKO-PRINT A FORM ;02:51 PM 18 Nov 1994
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
;
N DDSFORM,DDSPBRK
D SELFORM(.DDSFORM) Q:DDSFORM=-1
D PAGEBRK(.DDSPBRK) Q:$D(DDSPBRK)[0
;
;Device
S %ZIS=$S($D(^%ZTSK):"Q",1:"")
W ! D ^%ZIS K %ZIS I $G(POP) K POP Q
K POP
;
;Queue report
I $D(IO("Q")),$D(^%ZTSK) D G END
. S ZTRTN="PRINT^DDSPRNT"
. S ZTDESC="Report of Form "_$P(DDSFORM,U,2)
. N I F I="DDSFORM","DDSFORM(0)","DDSPBRK" S ZTSAVE(I)=""
. D ^%ZTLOAD
. I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
. E W !,"Report canceled!",!
. K ZTSK
. S IOP="HOME" D ^%ZIS
;
U IO
;
PRINT ;Entry point for queued reports
N DDSBK,DDSCOL1,DDSCOL2,DDSCOL3,DDSCRT,DDSFILE
N DDSHLIN,DDSHBK,DDSPAGE,DDSQUE
N DX,DY,X,Y
;
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
D INIT
D @("HDR"_(2-DDSCRT))
D FORM,END
Q
;
FORM ;Form data
W !
;
;Description
D WP($NA(^DIST(.403,+DDSFORM,15))) Q:$D(DIRUT)
;
;Other properties
D W("PRIMARY FILE: "_$P(DDSFORM(0),U,8),9) Q:$D(DIRUT)
W ?49,"READ ACCESS: "_$P(DDSFORM(0),U,2)
D W("DATE CREATED: "_$$EXTERNAL^DILFD(.403,4,"",$P(DDSFORM(0),U,5)),9) Q:$D(DIRUT)
W ?48,"WRITE ACCESS: "_$P(DDSFORM(0),U,3)
D W("DATE LAST USED: "_$$EXTERNAL^DILFD(.403,5,"",$P(DDSFORM(0),U,6)),7) Q:$D(DIRUT)
W ?53,"CREATOR: "_$P(DDSFORM(0),U,4)
D W() Q:$D(DIRUT)
;
I $P(DDSFORM(0),U,7)]"" D W("TITLE: "_$P(DDSFORM(0),U,7),16) Q:$D(DIRUT)
I $P($G(^DIST(.403,+DDSFORM,21)),U)]"" D W("RECORD SELECTION PAGE: "_$P(^(21),U)) Q:$D(DIRUT)
;
I $X D W() Q:$D(DIRUT)
S X=$G(^DIST(.403,+DDSFORM,11))
I X]"" D W("PRE ACTION:",11) Q:$D(DIRUT) D PCOL(X,23)
S X=$G(^DIST(.403,+DDSFORM,12))
I X]"" D W("POST ACTION:",10) Q:$D(DIRUT) D PCOL(X,23)
S X=$G(^DIST(.403,+DDSFORM,14))
I X]"" D W("POST SAVE:",12) Q:$D(DIRUT) D PCOL(X,23)
S X=$G(^DIST(.403,+DDSFORM,20))
I X]"" D W("DATA VALIDATION:",6) Q:$D(DIRUT) D PCOL(X,23)
K DDSFORM(0)
;
;Loop through all pages
I $X D W() Q:$D(DIRUT)
Q:'$O(^DIST(.403,+DDSFORM,40,0))
;
N DDSPG,DDSPGN
S DDSPGN="",DDSPFRST=1
F S DDSPGN=$O(^DIST(.403,+DDSFORM,40,"B",DDSPGN)) Q:DDSPGN=""!$D(DIRUT) S DDSPG=0 F S DDSPG=$O(^DIST(.403,+DDSFORM,40,"B",DDSPGN,DDSPG)) Q:'DDSPG!$D(DIRUT) D PAGE^DDSPRNT1
K DDSPFRST Q:$D(DIRUT)
;
D:$D(DDSHBK) HBLKS^DDSPRNT1
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
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
;
WP(DDSWP,DIWL,DDSLF) ;Print text in array @DDSWP
;DDSLF [ A : LF after (def)
; B : LF feed before
;
Q:'$P($G(@DDSWP@(0)),U,3)
N DIW,DIWF,DIWI,DIWR,DIWT,DIWTC,DIWX,DN
N DDSI,DDSCNT,I,X,Z
;
K ^UTILITY($J,"W")
S:'$G(DIWL) DIWL=1
S DIWR=IOM-1
S:'$D(DDSLF) DDSLF="A"
;
S DDSCNT=$P($G(@DDSWP@(0)),U,3)
I DDSCNT D
. F DDSI=1:1:DDSCNT I $D(@DDSWP@(DDSI,0))#2 S X=^(0) D ^DIWP
. ;
. I DDSLF'["B" D
.. W ?DIWL-1,$G(^UTILITY($J,"W",DIWL,1,0))
.. S DDSCNT=1
. E S DDSCNT=0
. F S DDSCNT=$O(^UTILITY($J,"W",DIWL,DDSCNT)) Q:'DDSCNT!$D(DIRUT) D
.. D W($G(^UTILITY($J,"W",DIWL,DDSCNT,0)),DIWL-1)
;
K ^UTILITY($J,"W")
D:DDSLF["A" W()
Q
;
W(DDSSTR,DDSCOL) ;Write DDSSTR
I $Y+3'<IOSL D HEADER Q:$D(DIRUT)
W !?+$G(DDSCOL),$G(DDSSTR)
Q
;
I DDSCRT D Q:$D(DIRUT)
. N DIR,X,Y
. S DIR(0)="E" W ! D ^DIR
I DDSQUE,$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1 Q
;
HDR1 ;First header for CRTs
W @IOF
;
HDR2 ;First header for non-CRTs
;
S DDSPAGE=$G(DDSPAGE)+1
W "FORM LISTING - "_$P(DDSFORM,U,2)_" (#"_+DDSFORM_")"
W !,"FILE: "_DDSFILE
W ?(IOM-$L(DDSHLIN)-$L(DDSPAGE)-1),DDSHLIN_DDSPAGE
W !,$TR($J("",IOM-1)," ","-")
Q
;
SELFORM(DDSFORM) ;Select form
N %,%W,%Y,C,I,Q,DDH,DIC,X,Y
S DIC="^DIST(.403,",DIC(0)="QEAMZ"
D ^DIC K DIC
S DDSFORM=Y,DDSFORM(0)=$G(Y(0))
Q
;
PAGEBRK(DDSPBRK) ;Prompt
N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
S DIR(0)="YO"
S DIR("A")="Start each page of the form on a new page"
S DIR("B")="Yes"
W ! D ^DIR Q:$D(DIRUT)
S DDSPBRK=Y
Q
;
INIT ;Setup
N %,%H,X,Y
S %H=$H D YX^%DTC
S DDSHLIN=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)_" PAGE "
S DDSFILE=$P(DDSFORM(0),U,8)
I DDSFILE,$D(^DIC(DDSFILE,0))#2 S DDSFILE=$P(^(0),U)_" (#"_DDSFILE_")"
E S DDSFILE=""
S DDSCRT=$E(IOST,1,2)="C-"
S DDSQUE=$D(ZTQUEUED)
Q
;
END ;Finish up
I $D(ZTQUEUED) S ZTREQ="@"
E X $G(^%ZIS("C"))
K DIRUT,DUOUT,DTOUT
Q
DDSPRNT ;SFISC/MKO-PRINT A FORM ;02:51 PM 18 Nov 1994
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+5 ;
+6 NEW DDSFORM,DDSPBRK
+7 DO SELFORM(.DDSFORM)
IF DDSFORM=-1
QUIT
+8 DO PAGEBRK(.DDSPBRK)
IF $DATA(DDSPBRK)[0
QUIT
+9 ;
+10 ;Device
+11 SET %ZIS=$SELECT($DATA(^%ZTSK):"Q",1:"")
+12 WRITE !
DO ^%ZIS
KILL %ZIS
IF $GET(POP)
KILL POP
QUIT
+13 KILL POP
+14 ;
+15 ;Queue report
+16 IF $DATA(IO("Q"))
IF $DATA(^%ZTSK)
Begin DoDot:1
+17 SET ZTRTN="PRINT^DDSPRNT"
+18 SET ZTDESC="Report of Form "_$PIECE(DDSFORM,U,2)
+19 NEW I
FOR I="DDSFORM","DDSFORM(0)","DDSPBRK"
SET ZTSAVE(I)=""
+20 DO ^%ZTLOAD
+21 IF $DATA(ZTSK)#2
WRITE !,"Report queued!",!,"Task number: "_$GET(ZTSK),!
+22 IF '$TEST
WRITE !,"Report canceled!",!
+23 KILL ZTSK
+24 SET IOP="HOME"
DO ^%ZIS
End DoDot:1
GOTO END
+25 ;
+26 USE IO
+27 ;
PRINT ;Entry point for queued reports
+1 NEW DDSBK,DDSCOL1,DDSCOL2,DDSCOL3,DDSCRT,DDSFILE
+2 NEW DDSHLIN,DDSHBK,DDSPAGE,DDSQUE
+3 NEW DX,DY,X,Y
+4 ;
+5 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+6 DO INIT
+7 DO @("HDR"_(2-DDSCRT))
+8 DO FORM
DO END
+9 QUIT
+10 ;
FORM ;Form data
+1 WRITE !
+2 ;
+3 ;Description
+4 DO WP($NAME(^DIST(.403,+DDSFORM,15)))
IF $DATA(DIRUT)
QUIT
+5 ;
+6 ;Other properties
+7 DO W("PRIMARY FILE: "_$PIECE(DDSFORM(0),U,8),9)
IF $DATA(DIRUT)
QUIT
+8 WRITE ?49,"READ ACCESS: "_$PIECE(DDSFORM(0),U,2)
+9 DO W("DATE CREATED: "_$$EXTERNAL^DILFD(.403,4,"",$PIECE(DDSFORM(0),U,5)),9)
IF $DATA(DIRUT)
QUIT
+10 WRITE ?48,"WRITE ACCESS: "_$PIECE(DDSFORM(0),U,3)
+11 DO W("DATE LAST USED: "_$$EXTERNAL^DILFD(.403,5,"",$PIECE(DDSFORM(0),U,6)),7)
IF $DATA(DIRUT)
QUIT
+12 WRITE ?53,"CREATOR: "_$PIECE(DDSFORM(0),U,4)
+13 DO W()
IF $DATA(DIRUT)
QUIT
+14 ;
+15 IF $PIECE(DDSFORM(0),U,7)]""
DO W("TITLE: "_$PIECE(DDSFORM(0),U,7),16)
IF $DATA(DIRUT)
QUIT
+16 IF $PIECE($GET(^DIST(.403,+DDSFORM,21)),U)]""
DO W("RECORD SELECTION PAGE: "_$PIECE(^(21),U))
IF $DATA(DIRUT)
QUIT
+17 ;
+18 IF $X
DO W()
IF $DATA(DIRUT)
QUIT
+19 SET X=$GET(^DIST(.403,+DDSFORM,11))
+20 IF X]""
DO W("PRE ACTION:",11)
IF $DATA(DIRUT)
QUIT
DO PCOL(X,23)
+21 SET X=$GET(^DIST(.403,+DDSFORM,12))
+22 IF X]""
DO W("POST ACTION:",10)
IF $DATA(DIRUT)
QUIT
DO PCOL(X,23)
+23 SET X=$GET(^DIST(.403,+DDSFORM,14))
+24 IF X]""
DO W("POST SAVE:",12)
IF $DATA(DIRUT)
QUIT
DO PCOL(X,23)
+25 SET X=$GET(^DIST(.403,+DDSFORM,20))
+26 IF X]""
DO W("DATA VALIDATION:",6)
IF $DATA(DIRUT)
QUIT
DO PCOL(X,23)
+27 KILL DDSFORM(0)
+28 ;
+29 ;Loop through all pages
+30 IF $X
DO W()
IF $DATA(DIRUT)
QUIT
+31 IF '$ORDER(^DIST(.403,+DDSFORM,40,0))
QUIT
+32 ;
+33 NEW DDSPG,DDSPGN
+34 SET DDSPGN=""
SET DDSPFRST=1
+35 FOR
SET DDSPGN=$ORDER(^DIST(.403,+DDSFORM,40,"B",DDSPGN))
IF DDSPGN=""!$DATA(DIRUT)
QUIT
SET DDSPG=0
FOR
SET DDSPG=$ORDER(^DIST(.403,+DDSFORM,40,"B",DDSPGN,DDSPG))
IF 'DDSPG!$DATA(DIRUT)
QUIT
DO PAGE^DDSPRNT1
+36 KILL DDSPFRST
IF $DATA(DIRUT)
QUIT
+37 ;
+38 IF $DATA(DDSHBK)
DO HBLKS^DDSPRNT1
+39 QUIT
+40 ;
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
+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 ;
WP(DDSWP,DIWL,DDSLF) ;Print text in array @DDSWP
+1 ;DDSLF [ A : LF after (def)
+2 ; B : LF feed before
+3 ;
+4 IF '$PIECE($GET(@DDSWP@(0)),U,3)
QUIT
+5 NEW DIW,DIWF,DIWI,DIWR,DIWT,DIWTC,DIWX,DN
+6 NEW DDSI,DDSCNT,I,X,Z
+7 ;
+8 KILL ^UTILITY($JOB,"W")
+9 IF '$GET(DIWL)
SET DIWL=1
+10 SET DIWR=IOM-1
+11 IF '$DATA(DDSLF)
SET DDSLF="A"
+12 ;
+13 SET DDSCNT=$PIECE($GET(@DDSWP@(0)),U,3)
+14 IF DDSCNT
Begin DoDot:1
+15 FOR DDSI=1:1:DDSCNT
IF $DATA(@DDSWP@(DDSI,0))#2
SET X=^(0)
DO ^DIWP
+16 ;
+17 IF DDSLF'["B"
Begin DoDot:2
+18 WRITE ?DIWL-1,$GET(^UTILITY($JOB,"W",DIWL,1,0))
+19 SET DDSCNT=1
End DoDot:2
+20 IF '$TEST
SET DDSCNT=0
+21 FOR
SET DDSCNT=$ORDER(^UTILITY($JOB,"W",DIWL,DDSCNT))
IF 'DDSCNT!$DATA(DIRUT)
QUIT
Begin DoDot:2
+22 DO W($GET(^UTILITY($JOB,"W",DIWL,DDSCNT,0)),DIWL-1)
End DoDot:2
End DoDot:1
+23 ;
+24 KILL ^UTILITY($JOB,"W")
+25 IF DDSLF["A"
DO W()
+26 QUIT
+27 ;
W(DDSSTR,DDSCOL) ;Write DDSSTR
+1 IF $Y+3'<IOSL
DO HEADER
IF $DATA(DIRUT)
QUIT
+2 WRITE !?+$GET(DDSCOL),$GET(DDSSTR)
+3 QUIT
+4 ;
+1 IF DDSCRT
Begin DoDot:1
+2 NEW DIR,X,Y
+3 SET DIR(0)="E"
WRITE !
DO ^DIR
End DoDot:1
IF $DATA(DIRUT)
QUIT
+4 IF DDSQUE
IF $$S^%ZTLOAD
SET (ZTSTOP,DIRUT)=1
QUIT
+5 ;
HDR1 ;First header for CRTs
+1 WRITE @IOF
+2 ;
HDR2 ;First header for non-CRTs
+1 ;
+2 SET DDSPAGE=$GET(DDSPAGE)+1
+3 WRITE "FORM LISTING - "_$PIECE(DDSFORM,U,2)_" (#"_+DDSFORM_")"
+4 WRITE !,"FILE: "_DDSFILE
+5 WRITE ?(IOM-$LENGTH(DDSHLIN)-$LENGTH(DDSPAGE)-1),DDSHLIN_DDSPAGE
+6 WRITE !,$TRANSLATE($JUSTIFY("",IOM-1)," ","-")
+7 QUIT
+8 ;
SELFORM(DDSFORM) ;Select form
+1 NEW %,%W,%Y,C,I,Q,DDH,DIC,X,Y
+2 SET DIC="^DIST(.403,"
SET DIC(0)="QEAMZ"
+3 DO ^DIC
KILL DIC
+4 SET DDSFORM=Y
SET DDSFORM(0)=$GET(Y(0))
+5 QUIT
+6 ;
PAGEBRK(DDSPBRK) ;Prompt
+1 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+2 SET DIR(0)="YO"
+3 SET DIR("A")="Start each page of the form on a new page"
+4 SET DIR("B")="Yes"
+5 WRITE !
DO ^DIR
IF $DATA(DIRUT)
QUIT
+6 SET DDSPBRK=Y
+7 QUIT
+8 ;
INIT ;Setup
+1 NEW %,%H,X,Y
+2 SET %H=$HOROLOG
DO YX^%DTC
+3 SET DDSHLIN=$PIECE(Y,"@")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)_" PAGE "
+4 SET DDSFILE=$PIECE(DDSFORM(0),U,8)
+5 IF DDSFILE
IF $DATA(^DIC(DDSFILE,0))#2
SET DDSFILE=$PIECE(^(0),U)_" (#"_DDSFILE_")"
+6 IF '$TEST
SET DDSFILE=""
+7 SET DDSCRT=$EXTRACT(IOST,1,2)="C-"
+8 SET DDSQUE=$DATA(ZTQUEUED)
+9 QUIT
+10 ;
END ;Finish up
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$TEST
XECUTE $GET(^%ZIS("C"))
+3 KILL DIRUT,DUOUT,DTOUT
+4 QUIT
