DIWP ;SFISC/GFT-ASSEMBLE WP LINE ;24APR2012
;;22.2;VA FileMan;**10**;Jan 05, 2016;Build 11
;;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.
;
;The DIWF variable contains a string of one-letter codes to control W-P output.
;"|" in DIWF means that "|"-windows are not to be evaluated, but are to be printed as
; they stand.
;"X" means eXactly line-for-line, with "||" printed as "||"
;"W" in DIWF means that formatted text will be written out to
; the current device as it is assembled.
;"N" means NOWRAP-- text is assembled line-for-line
;"R" means text will be assembled Right-justified
;"D" means text will be double-spaced
;"L" means internal line numbers appear at the left margin
;"C" followed by a number will cause formatting of text in a column
; width specified by the number.
;"I" followed by a number will cause text to be indented that number
; of columns.
;"?" means that, if user's terminal is available, "|"-windows that cannot
; be evaluated will be asked from the user's terminal.
;"B" followed by number causes new page when output gets within that
; number of lines from the bottom of the page (as defined by IOSL).
;
;DIWTC is a Boolean -- Are we printing out in LINE MODE?
S:'$L(X) X=" "
S DIWTC=X[($C(124)_"TAB") S:'$D(DN) DN=1
LN S:'$D(DIWF) DIWF="" S:'DIWTC DIWTC=DIWF["N" S DIWX=X,DIW=$C(124),I=$P(DIWF,"C",2) I I S DIWR=DIWL+I-1
I '$D(^UTILITY($J,"W",DIWL)) S ^(DIWL)=1 K DIWFU,DIWFWU,DIWLL D DIWI S:'$D(DIWT) DIWT="5,10,15,20,25" G DIW
S I=^(DIWL),DIWI=^(DIWL,I,0) I DIWI="" D DIWI G Z
D NEW:DIWTC
Z S Z=X?.P!DIWTC I X?1" ".E!Z S DIWTC=1 D NEW:DIWI]"" S DIWTC=Z
DIW ;from RCR+5^DIWW
I DIWF["X" S DIWTC=1,X=DIWX,DIWX="" D C G D ;**DI*22*152** Leave line unaltered
S X=$P(DIWX,DIW,1) D C:X]"" S X=$P(DIWX,DIW,1),DIWX=$P(DIWX,DIW,2,9999) G D:DIWX="" I $D(DIWP),X'?.E1" " D ST
S X=$P(DIWX,DIW,1) I $P(X,"TAB",1)="" D TAB G N
I X="TOP" D PUT S ^("X")="S DIFF=1 X:$D(^UTILITY($J,1)) ^(1)" D NEW G N
I DIWF'[DIW G U:X="_" D PUT,RCR^DIWW G N:$D(X)
S X=DIW_$P(DIWX,DIW,1) S:DIWX[DIW!(DIWF'[DIW) X=X_DIW D C ;DO NOT PUT GRATUITOUS "|" AT END, IF DIWF["|"
N K X S DIWX=$P(DIWX,DIW,2,99) I DIWX]"" D ST:$D(DIWP) G DIW
D K DIWP D PUT,PRE:DIWTC S:DIWTC DIWI="" Q
;
ST S DIWI=$E(DIWI,1,$L(DIWI)-1) K DIWP Q
;
DIWI S DIWI=$J("",+$P(DIWF,"I",2)) I DIWF["L",$D(D)#2 S DIWLL=D
Q
PUT S I=^UTILITY($J,"W",DIWL),^(DIWL,I,0)=DIWI I DIWF["L",$D(DIWLL) S ^("L")=DIWLL
Q
L ;
S DIWTC=1 G LN
;
TAB I X="" S X=DIW G C
S J=$P(DIWT,",",DIWTC),DIWTC=DIWTC+1 S:X?3A1P.P.N.E J=$E(X,5,9) S:J?1"""".E1"""" J=$E(J,2,$L(J)-1)
I J'>0 S %=$P(DIWX,DIW,2) Q:%="" S J=$S(J<0:1-$L(%)-J,J="C":DIWR-DIWL-$L(%)\2,1:0)
S J=J-1-$L(DIWI) Q:J<1 S X=$J("",J)
C K DIWP I DIWTC S DIWI=DIWI_X Q
B S Z=DIWR-DIWL+1-$L(DIWI) G FULL:$F(X," ")-1>Z F %=Z:-1 I " "[$E(X,%) S:$E(X,%+1)=" " %=%+1 Q
S Z=$E(X,1,%-1),X=$E(X,%+1,9999) I Z]"" S DIWI=DIWI_Z G S:X]"" S %=$E(Z,$L(Z)) S:%'=" " DIWI=DIWI_$J("",%="."+1),DIWP=1 Q
FULL I $P(DIWF,"I",2)'<$L(DIWI) S DIWI=DIWI_$P(X," ",1),X=$P(X," ",2,9999)
S D PUT,NEW G B:X]"" Q
;
U S I=^UTILITY($J,"W",DIWL) I $D(DIWFU) S ^(DIWL,I,"U",$L(DIWI)+1)="" K DIWFU G N
S ^(DIWL,I,"U",$L(DIWI)+1)=X,DIWFU=1 G N
;
NEW D DIWI
PRE S I=^UTILITY($J,"W",DIWL),^(DIWL)=I+1,^(DIWL,I+1,0)="" I DIWF["D" S ^(0)=" ",^UTILITY($J,"W",DIWL)=I+2,^(DIWL,I+2,0)=""
I $D(DIWFU) S ^("U",1+$P(DIWF,"I",2))="_"
G P:DIWF'["R"!DIWTC K % Q:'$D(^UTILITY($J,"W",DIWL,I,0))
S Y=^(0),%=$L(Y) F %=%:-1 Q:$A(Y,%)-32
S Y=$E(Y,1,%),J=DIWR-DIWL-%+1,%X=0 G P:J<1
F %=1:1 S %(%)=$P(Y," ",1),Y=$P(Y," ",2,9999) G:Y="" PAD:%-1,P I $E(%(%),$L(%(%)))?.P S:%=1&(%(%)="") %=0,%X=%X+1 S:%&J J=J-1,%(%)=%(%)_" "
PAD I J F Y=%\2+1:1:%-1,%\2:-1 S %(Y)=%(Y)_" ",J=J-1 G PAD:Y=1!'J
S Y=%(%) F %=%-1:-1:1 S Y=%(%)_" "_Y
S ^(0)=$J("",%X)_Y K %
P I DIWF["W" G NX^DIWW
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIWP 4081 printed Dec 13, 2024@02:55 Page 2
DIWP ;SFISC/GFT-ASSEMBLE WP LINE ;24APR2012
+1 ;;22.2;VA FileMan;**10**;Jan 05, 2016;Build 11
+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 ;
+7 ;The DIWF variable contains a string of one-letter codes to control W-P output.
+8 ;"|" in DIWF means that "|"-windows are not to be evaluated, but are to be printed as
+9 ; they stand.
+10 ;"X" means eXactly line-for-line, with "||" printed as "||"
+11 ;"W" in DIWF means that formatted text will be written out to
+12 ; the current device as it is assembled.
+13 ;"N" means NOWRAP-- text is assembled line-for-line
+14 ;"R" means text will be assembled Right-justified
+15 ;"D" means text will be double-spaced
+16 ;"L" means internal line numbers appear at the left margin
+17 ;"C" followed by a number will cause formatting of text in a column
+18 ; width specified by the number.
+19 ;"I" followed by a number will cause text to be indented that number
+20 ; of columns.
+21 ;"?" means that, if user's terminal is available, "|"-windows that cannot
+22 ; be evaluated will be asked from the user's terminal.
+23 ;"B" followed by number causes new page when output gets within that
+24 ; number of lines from the bottom of the page (as defined by IOSL).
+25 ;
+26 ;DIWTC is a Boolean -- Are we printing out in LINE MODE?
+27 if '$LENGTH(X)
SET X=" "
+28 SET DIWTC=X[($CHAR(124)_"TAB")
if '$DATA(DN)
SET DN=1
LN if '$DATA(DIWF)
SET DIWF=""
if 'DIWTC
SET DIWTC=DIWF["N"
SET DIWX=X
SET DIW=$CHAR(124)
SET I=$PIECE(DIWF,"C",2)
IF I
SET DIWR=DIWL+I-1
+1 IF '$DATA(^UTILITY($JOB,"W",DIWL))
SET ^(DIWL)=1
KILL DIWFU,DIWFWU,DIWLL
DO DIWI
if '$DATA(DIWT)
SET DIWT="5,10,15,20,25"
GOTO DIW
+2 SET I=^(DIWL)
SET DIWI=^(DIWL,I,0)
IF DIWI=""
DO DIWI
GOTO Z
+3 if DIWTC
DO NEW
Z SET Z=X?.P!DIWTC
IF X?1" ".E!Z
SET DIWTC=1
if DIWI]""
DO NEW
SET DIWTC=Z
DIW ;from RCR+5^DIWW
+1 ;**DI*22*152** Leave line unaltered
IF DIWF["X"
SET DIWTC=1
SET X=DIWX
SET DIWX=""
DO C
GOTO D
+2 SET X=$PIECE(DIWX,DIW,1)
if X]""
DO C
SET X=$PIECE(DIWX,DIW,1)
SET DIWX=$PIECE(DIWX,DIW,2,9999)
if DIWX=""
GOTO D
IF $DATA(DIWP)
IF X'?.E1" "
DO ST
+3 SET X=$PIECE(DIWX,DIW,1)
IF $PIECE(X,"TAB",1)=""
DO TAB
GOTO N
+4 IF X="TOP"
DO PUT
SET ^("X")="S DIFF=1 X:$D(^UTILITY($J,1)) ^(1)"
DO NEW
GOTO N
+5 IF DIWF'[DIW
if X="_"
GOTO U
DO PUT
DO RCR^DIWW
if $DATA(X)
GOTO N
+6 ;DO NOT PUT GRATUITOUS "|" AT END, IF DIWF["|"
SET X=DIW_$PIECE(DIWX,DIW,1)
if DIWX[DIW!(DIWF'[DIW)
SET X=X_DIW
DO C
N KILL X
SET DIWX=$PIECE(DIWX,DIW,2,99)
IF DIWX]""
if $DATA(DIWP)
DO ST
GOTO DIW
D KILL DIWP
DO PUT
if DIWTC
DO PRE
if DIWTC
SET DIWI=""
QUIT
+1 ;
ST SET DIWI=$EXTRACT(DIWI,1,$LENGTH(DIWI)-1)
KILL DIWP
QUIT
+1 ;
DIWI SET DIWI=$JUSTIFY("",+$PIECE(DIWF,"I",2))
IF DIWF["L"
IF $DATA(D)#2
SET DIWLL=D
+1 QUIT
PUT SET I=^UTILITY($JOB,"W",DIWL)
SET ^(DIWL,I,0)=DIWI
IF DIWF["L"
IF $DATA(DIWLL)
SET ^("L")=DIWLL
+1 QUIT
L ;
+1 SET DIWTC=1
GOTO LN
+2 ;
TAB IF X=""
SET X=DIW
GOTO C
+1 SET J=$PIECE(DIWT,",",DIWTC)
SET DIWTC=DIWTC+1
if X?3A1P.P.N.E
SET J=$EXTRACT(X,5,9)
if J?1"""".E1""""
SET J=$EXTRACT(J,2,$LENGTH(J)-1)
+2 IF J'>0
SET %=$PIECE(DIWX,DIW,2)
if %=""
QUIT
SET J=$SELECT(J<0:1-$LENGTH(%)-J,J="C":DIWR-DIWL-$LENGTH(%)\2,1:0)
+3 SET J=J-1-$LENGTH(DIWI)
if J<1
QUIT
SET X=$JUSTIFY("",J)
C KILL DIWP
IF DIWTC
SET DIWI=DIWI_X
QUIT
B SET Z=DIWR-DIWL+1-$LENGTH(DIWI)
if $FIND(X," ")-1>Z
GOTO FULL
FOR %=Z:-1
IF " "[$EXTRACT(X,%)
if $EXTRACT(X,%+1)=" "
SET %=%+1
QUIT
+1 SET Z=$EXTRACT(X,1,%-1)
SET X=$EXTRACT(X,%+1,9999)
IF Z]""
SET DIWI=DIWI_Z
if X]""
GOTO S
SET %=$EXTRACT(Z,$LENGTH(Z))
if %'=" "
SET DIWI=DIWI_$JUSTIFY("",%="."+1)
SET DIWP=1
QUIT
FULL IF $PIECE(DIWF,"I",2)'<$LENGTH(DIWI)
SET DIWI=DIWI_$PIECE(X," ",1)
SET X=$PIECE(X," ",2,9999)
S DO PUT
DO NEW
if X]""
GOTO B
QUIT
+1 ;
U SET I=^UTILITY($JOB,"W",DIWL)
IF $DATA(DIWFU)
SET ^(DIWL,I,"U",$LENGTH(DIWI)+1)=""
KILL DIWFU
GOTO N
+1 SET ^(DIWL,I,"U",$LENGTH(DIWI)+1)=X
SET DIWFU=1
GOTO N
+2 ;
NEW DO DIWI
PRE SET I=^UTILITY($JOB,"W",DIWL)
SET ^(DIWL)=I+1
SET ^(DIWL,I+1,0)=""
IF DIWF["D"
SET ^(0)=" "
SET ^UTILITY($JOB,"W",DIWL)=I+2
SET ^(DIWL,I+2,0)=""
+1 IF $DATA(DIWFU)
SET ^("U",1+$PIECE(DIWF,"I",2))="_"
+2 if DIWF'["R"!DIWTC
GOTO P
KILL %
if '$DATA(^UTILITY($JOB,"W",DIWL,I,0))
QUIT
+3 SET Y=^(0)
SET %=$LENGTH(Y)
FOR %=%:-1
if $ASCII(Y,%)-32
QUIT
+4 SET Y=$EXTRACT(Y,1,%)
SET J=DIWR-DIWL-%+1
SET %X=0
if J<1
GOTO P
+5 FOR %=1:1
SET %(%)=$PIECE(Y," ",1)
SET Y=$PIECE(Y," ",2,9999)
if Y=""
if %-1
GOTO PAD
GOTO P
IF $EXTRACT(%(%),$LENGTH(%(%)))?.P
if %=1&(%(%)="")
SET %=0
SET %X=%X+1
if %&J
SET J=J-1
SET %(%)=%(%)_" "
PAD IF J
FOR Y=%\2+1:1:%-1,%\2:-1
SET %(Y)=%(Y)_" "
SET J=J-1
if Y=1!'J
GOTO PAD
+1 SET Y=%(%)
FOR %=%-1:-1:1
SET Y=%(%)_" "_Y
+2 SET ^(0)=$JUSTIFY("",%X)_Y
KILL %
P IF DIWF["W"
GOTO NX^DIWW
