- DIWW ;SFISC/GFT-OUTPUT WP LINE ;5NOV2007
- ;;22.0;VA FileMan;**64,144,152**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
- F I=0:1 G:$D(DN) QQ:'DN Q:$D(^UTILITY($J,"W"))<9 D T G:$D(DN) QQ:'DN D 0
- T W:$X !
- B Q:$S($D(DN):'DN,1:0) I '$D(DIWF) S DIWF=""
- I '$D(DIOT(2)),$D(IOSL),$Y+$S($P(DIWF,"B",2):$P(DIWF,"B",2),1:2)'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1) I $D(DN),'DN S D0="zzzzzz",W=9999999 Q
- F I=$Y+2:1:+$P(DIWF,"T",2) W !
- Q
- ;
- A ;
- D 0 G DIWW
- ;
- NX ;
- W:$X+1>DIWL ! D B G:$D(DN) Q:'DN
- 0 ;
- S I=999999,%="" F S %=$O(^UTILITY($J,"W",%)) Q:%="" S:$O(^(%,""))<I I=$O(^(""))
- 1 S %="" F S %=$O(^UTILITY($J,"W",%)) Q:%="" I $D(^(%,I)) D W I $D(^UTILITY($J,"W",%))<9 K ^(%) I $O(^(""))="" K DIWI,DIWX,DIWTC
- S:%="" %=-1 G Q
- ;
- W G X:^(I,0)="",O:'$D(DIWF) I DIWF[" " S DIWF=$P(DIWF," ",1)_$P(DIWF," ",2) G X:^(0)?." "
- W:$X+(%>0)>% ! I DIWF["L",$D(^("L")) W $E(^("L")_" ",1,4)
- O W ?%-1,^(0)
- X D U:$D(^("U")) I $D(^("X")) S Y=^("X") D K X Y Q
- K K ^UTILITY($J,"W",%,I) Q
- ;
- U Q:'$D(IOST) Q:IOST'?1"P".E W $C(13) F DE=1:1:$S($D(^("L")):%+3,1:%-1) W " "
- S DE=1
- UU S %Y=$O(^UTILITY($J,"W",%,I,"U","")) I %Y="" S %Y=$L(^UTILITY($J,"W",%,I,0))+1 S:'$D(DIWFWU) DIWFWU=" " D UUU K DIWFWU Q
- S Y=^(%Y) K ^(%Y) I Y="" D UUU K DIWFWU G UU
- S DIWFWU=Y F DE=DE:1 G UU:DE'<%Y W " "
- UUU I $D(DIWFWU) F DE=DE:1 Q:DE'<%Y W DIWFWU
- Q Q
- QQ K DIWI,DIWX,DIWTC Q
- ;
- RCR ;
- N DA,M,DQI,DA
- F M="DIWX","DICMX","DIC","D","D0","D1","D2","D3","D4","D5","D6","D7","Y","I","J" M %=@M N @M M @M=%
- S DQI="Y(",DA="X(",DICMX="X DICMX",DICOMP="ST" S:$D(DIA("P"))#2 J(0)=DIA("P") D EN1^DICOMP
- I '$D(X) Q:DIWF'["?"!(IO(0)=IO)!$D(IO("C")) U IO(0) W $C(7),!,$P(@(I(0)_"D0,0)"),U),"---",!?4,$P(DIWX,DIW)_": " R X:DTIME,! U IO G BACK
- I Y["m" S DICMX=$S(Y["w":"D ^DIWP",1:"S DIWX=X,DIWTC=1 D DIW^DIWP S DIWI=$J("""","_$L(DIWI)_")") X X S X="" G BACK
- I Y["X" S X=DIW_X_DIW G BACK
- I $P(DIWX,"SETPAGE(",1)="" S ^(DIWL,^UTILITY($J,"W",DIWL),"X")=X,X="" G BACK
- S DICMX=Y["D" X X I DICMX S Y=X X ^DD("DD") S X=Y
- I $P(DIWX,"INDENT(")="" S X=$J(X,$P(DIWF,"I",2)-$L(DIWI)-1)
- BACK D C^DIWP:X]"" S X=""
- Q
- ;
- DIQ ;
- S DIWF=$E("N",C["L")_"W"_$E("|X",C["X"!(C["x")+1),DIWL=2,DIWR=IOM,X=O_": " K ^UTILITY($J,"W")
- S W=0 F D S W=$O(@(D(DL-1)_"W)")) Q:W'>0!(S=0) S X=^(W,0)
- .D ^DIWP
- .N W D LF^DIQ
- G DIWW
- ;
- H G H^DIO2
- DT G DT^DIO2
- ;
- N W ! G B
- DIWW ;SFISC/GFT-OUTPUT WP LINE ;5NOV2007
- +1 ;;22.0;VA FileMan;**64,144,152**;Mar 30, 1999;Build 10
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 FOR I=0:1
- IF $DATA(DN)
- IF 'DN
- GOTO QQ
- IF $DATA(^UTILITY($JOB,"W"))<9
- QUIT
- DO T
- IF $DATA(DN)
- IF 'DN
- GOTO QQ
- DO 0
- T IF $X
- WRITE !
- B IF $SELECT($DATA(DN)
- QUIT
- IF '$DATA(DIWF)
- SET DIWF=""
- +1 IF '$DATA(DIOT(2))
- IF $DATA(IOSL)
- IF $Y+$SELECT($PIECE(DIWF,"B",2):$PIECE(DIWF,"B",2),1:2)'<IOSL
- IF $DATA(^UTILITY($JOB,1))#2
- IF ^(1)?1U1P1E.E
- XECUTE ^(1)
- IF $DATA(DN)
- IF 'DN
- SET D0="zzzzzz"
- SET W=9999999
- QUIT
- +2 FOR I=$Y+2:1:+$PIECE(DIWF,"T",2)
- WRITE !
- +3 QUIT
- +4 ;
- A ;
- +1 DO 0
- GOTO DIWW
- +2 ;
- NX ;
- +1 IF $X+1>DIWL
- WRITE !
- DO B
- IF $DATA(DN)
- IF 'DN
- GOTO Q
- 0 ;
- +1 SET I=999999
- SET %=""
- FOR
- SET %=$ORDER(^UTILITY($JOB,"W",%))
- IF %=""
- QUIT
- IF $ORDER(^(%,""))<I
- SET I=$ORDER(^(""))
- 1 SET %=""
- FOR
- SET %=$ORDER(^UTILITY($JOB,"W",%))
- IF %=""
- QUIT
- IF $DATA(^(%,I))
- DO W
- IF $DATA(^UTILITY($JOB,"W",%))<9
- KILL ^(%)
- IF $ORDER(^(""))=""
- KILL DIWI,DIWX,DIWTC
- +1 IF %=""
- SET %=-1
- GOTO Q
- +2 ;
- W IF ^(I,0)=""
- GOTO X
- IF '$DATA(DIWF)
- GOTO O
- IF DIWF[" "
- SET DIWF=$PIECE(DIWF," ",1)_$PIECE(DIWF," ",2)
- IF ^(0)?." "
- GOTO X
- +1 IF $X+(%>0)>%
- WRITE !
- IF DIWF["L"
- IF $DATA(^("L"))
- WRITE $EXTRACT(^("L")_" ",1,4)
- O WRITE ?%-1,^(0)
- X IF $DATA(^("U"))
- DO U
- IF $DATA(^("X"))
- SET Y=^("X")
- DO K
- XECUTE Y
- QUIT
- K KILL ^UTILITY($JOB,"W",%,I)
- QUIT
- +1 ;
- U IF '$DATA(IOST)
- QUIT
- IF IOST'?1"P".E
- QUIT
- WRITE $CHAR(13)
- FOR DE=1:1:$SELECT($DATA(^("L")):%+3,1:%-1)
- WRITE " "
- +1 SET DE=1
- UU SET %Y=$ORDER(^UTILITY($JOB,"W",%,I,"U",""))
- IF %Y=""
- SET %Y=$LENGTH(^UTILITY($JOB,"W",%,I,0))+1
- IF '$DATA(DIWFWU)
- SET DIWFWU=" "
- DO UUU
- KILL DIWFWU
- QUIT
- +1 SET Y=^(%Y)
- KILL ^(%Y)
- IF Y=""
- DO UUU
- KILL DIWFWU
- GOTO UU
- +2 SET DIWFWU=Y
- FOR DE=DE:1
- IF DE'<%Y
- GOTO UU
- WRITE " "
- UUU IF $DATA(DIWFWU)
- FOR DE=DE:1
- IF DE'<%Y
- QUIT
- WRITE DIWFWU
- Q QUIT
- QQ KILL DIWI,DIWX,DIWTC
- QUIT
- +1 ;
- RCR ;
- +1 NEW DA,M,DQI,DA
- +2 FOR M="DIWX","DICMX","DIC","D","D0","D1","D2","D3","D4","D5","D6","D7","Y","I","J"
- MERGE %=@M
- NEW @M
- MERGE @M=%
- +3 SET DQI="Y("
- SET DA="X("
- SET DICMX="X DICMX"
- SET DICOMP="ST"
- IF $DATA(DIA("P"))#2
- SET J(0)=DIA("P")
- DO EN1^DICOMP
- +4 IF '$DATA(X)
- IF DIWF'["?"!(IO(0)=IO)!$DATA(IO("C"))
- QUIT
- USE IO(0)
- WRITE $CHAR(7),!,$PIECE(@(I(0)_"D0,0)"),U),"---",!?4,$PIECE(DIWX,DIW)_": "
- READ X:DTIME,!
- USE IO
- GOTO BACK
- +5 IF Y["m"
- SET DICMX=$SELECT(Y["w":"D ^DIWP",1:"S DIWX=X,DIWTC=1 D DIW^DIWP S DIWI=$J("""","_$LENGTH(DIWI)_")")
- XECUTE X
- SET X=""
- GOTO BACK
- +6 IF Y["X"
- SET X=DIW_X_DIW
- GOTO BACK
- +7 IF $PIECE(DIWX,"SETPAGE(",1)=""
- SET ^(DIWL,^UTILITY($JOB,"W",DIWL),"X")=X
- SET X=""
- GOTO BACK
- +8 SET DICMX=Y["D"
- XECUTE X
- IF DICMX
- SET Y=X
- XECUTE ^DD("DD")
- SET X=Y
- +9 IF $PIECE(DIWX,"INDENT(")=""
- SET X=$JUSTIFY(X,$PIECE(DIWF,"I",2)-$LENGTH(DIWI)-1)
- BACK IF X]""
- DO C^DIWP
- SET X=""
- +1 QUIT
- +2 ;
- DIQ ;
- +1 SET DIWF=$EXTRACT("N",C["L")_"W"_$EXTRACT("|X",C["X"!(C["x")+1)
- SET DIWL=2
- SET DIWR=IOM
- SET X=O_": "
- KILL ^UTILITY($JOB,"W")
- +2 SET W=0
- FOR
- Begin DoDot:1
- +3 DO ^DIWP
- +4 NEW W
- DO LF^DIQ
- End DoDot:1
- SET W=$ORDER(@(D(DL-1)_"W)"))
- IF W'>0!(S=0)
- QUIT
- SET X=^(W,0)
- +5 GOTO DIWW
- +6 ;
- H GOTO H^DIO2
- DT GOTO DT^DIO2
- +1 ;
- N WRITE !
- GOTO B
