source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSPROSE.m@ 1474

Last change on this file since 1474 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
RevLine 
[613]1YSPROSE ;SLC/RWF,SLC/DKG,SLC/TGA-PROSE TEXT GENERATOR ; 7/5/89 11:47 ;
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3L1 ;
4 S YSPTF=YSX_YSPGI_",0)",YSPX=@YSPTF G SKC:YSPTRUE,CMD:$A(YSPX)=124 ;"|"
5 D JU
6L2 ;
7 S YSPGI=YSPGI+1 G CL:YSPGI>YSPGL,L1
8 ;
9CMD ;
10 S YSPCMD=YSPX,YSPX=$P(YSPX,"|") G CMDQ:YSPX=""
11 I $E(YSPX)=" " S YSPX=$E(YSPX,2,999) D JU G CMDQ
12 S YSPY=+$E(YSPX,1,2) I YSPY S YSPX=$E(YSPX,$E(YSPX,3)?1P+3,255) G CMD2
13 S YSPY=$F("TAB,BLA,TOP,MAR,FIL, , ,NEW,PAR",$E(YSPX,1,3))\4+9 S:YSPY<10 YSPY=0 S:YSPY YSPX=$P(YSPX," ",2,256)
14CMD2 G CMDQ:YSPY=0,IR:YSPY=1,DIR:YSPY=2,SKIP:YSPY=5,DO:YSPY=7,XQT:YSPY=8,CL:YSPY=19
15 S YSPY=$P("VT,TAB,BL,TOP,MAR,FILL,PAGE,SPACE,OUT,PAR,,PGN",",",YSPY-8)
16 D:YSPY]"" @YSPY G CMDQ
17 D JU
18CMDQ ;
19 Q:'$D(YSPCMD) S YSPX=$P(YSPCMD,"|",2,99) G CMD:YSPX]"" K YSPCMD G L2
20JU ;
21 G JU1:YSPJU=1,JU2:YSPJU>1
22 S YSPOL=YSPOL_YSPX G OUT
23RL ;
24 S YSPI=1
25F ;
26 S J=YSPTRM-YSPLM-$L(YSPOL),L=J I J<$L(YSPX) F J=J:-1:YSPI Q:$E(YSPX,J)=" "
27 I J'>YSPI S J=YSPTRM-YSPLM+YSPI W J ;DEBUG
28 D OUT:$L(YSPOL)+YSPLM+J-YSPI>YSPTRM S YSPOL=YSPOL_$E(YSPX,YSPI,J)_$E(" ",J=L),YSPI=J+1
29 G F:$L(YSPX)>YSPI Q
30JU1 ;
31 S YSPI=1
32J S J=$F(YSPX," ",YSPI),L=$E(YSPX,YSPI,$S(J:J-1,1:$L(YSPX))),YSPI=J I 'J S L=L_" "
33 I $E(YSPX,YSPI)'=" ",".?!"[$E(L,$L(L)-1),$L(L)>4 S L=L_" "
34 I YSPLM+$L(L)+$L(YSPOL)>YSPTRM D OUT
35 S YSPOL=YSPOL_L G J:J K I,J,YSPX Q
36JU2 ;
37 Q:YSPX="" S L=$P(YSPX," "),YSPX=$P(YSPX," ",2,255)
38 G JU2:L?." "
39 I YSPLM+$L(L)+$L(YSPOL)>YSPTRM D OUT S YSPWC=0
40 I $L(L)>3,".?!"[$E(L,$L(L)) S L=L_" "
41 S YSPOL=YSPOL_L_" " G JU2 ;%WC=YSPWC+1 G JU2
42OUT ;
43 I $Y>YSPPL D H
44 I YSPOL]"" W @($E("!!!!",1,YSPSKC)),?YSPLM,YSPOL S YSPOL=""
45 I YSPPS S YSPLM=YSPPS,YSPPS=0
46 Q
47IR ;
48 S @("YSPX="_YSPX) D JU G CMDQ
49 G CMDQ
50DIR ;
51 S YSPY=$P(YSPX,U),YSPZ=$P(YSPX,U,2) S:YSPY="" YSPY="^"_YSPZ,YSPZ=$P(YSPX,U,3) I $D(@YSPY) S YSPX=$P(@YSPY,U,+YSPZ) D JU
52 G CMDQ
53SKIP ;
54 S YSPSV=$P(YSPX,":",2),YSPX=$P(YSPX,":") I @YSPX G SK2
55 G CMDQ
56SK2 ;
57 S YSPTRUE=$T,YSPST=YSPSV?1A.AN G L2
58SKC ;
59 I YSPST,$E(YSPX,1,2)="|0",$E(YSPX,5,99)=YSPSV S YSPTRUE=0 G L2
60 I 'YSPST,$E(YSPX,1,2)="|0" S YSPSV=YSPSV-1 I YSPSV=0 S YSPTRUE=0 G L2
61 G L2
62DO ;
63 D @YSPX G CMDQ
64XQT ;
65 X YSPX G CMDQ
66VT ;
67 D OUT S YSPX=$S(YSPX>YSPPL:YSPPL,1:YSPX) F YSPI=$Y:1:+YSPX W !
68 Q
69BL ;
70 D OUT,H:$Y+YSPX>YSPPL Q:YSLFT F YSPI=1:1:+YSPX W !
71 K YSPI Q
72TOP ;
73 Q:$D(YSNOFORM) D ENHD^YSFORM Q
74MAR ;
75 D OUT S YSPLM=$P(YSPX,U),YSPTRM=$P(YSPX,U,2) Q
76FILL ;
77 D OUT S YSPJU=+YSPX S:YSPJU>3 YSPJU=2 Q
78PAGE ;
79 S YSPPL=+YSPX I (YSPPL<3)!(YSPPL>66) S YSPPL=50
80 Q
81SPACE ;
82 D OUT S YSPSKC=+YSPX Q
83TAB ;
84 S YSPY=+YSPX,YSPZ=$P(YSPX,U,2),YSPX=$L(YSPOL)+YSPLM S:'YSPY YSPY=80-$L(YSPZ)\2 F YSPI=YSPX:1:YSPY-1 S YSPOL=YSPOL_" "
85 S YSPX=YSPZ K YSPI,YSPZ G JU
86PAR ;
87 D OUT S YSPOL=" " D OUT S YSPPS=YSPLM I YSPX?1P,"+-"[YSPX S @("YSPLM=YSPLM"_YSPX_"5") Q
88 Q
89PGN ;
90 S:YSPX YSPPGN=YSPX K:'YSPX YSPPGN Q
91 E S:YSPX?.N YSPLM=+YSPX Q
92CL ;
93 D OUT Q
94H ;
95 I $D(YSNOFORM) D:'YST WAIT W @IOF Q
96 S:YST YSCON=1 D ENFT^YSFORM:YST,WAIT:'YST Q:YSLFT D:YST ENHD^YSFORM Q
97WAIT ;
98 F I0=1:1:IOSL-$Y-2 W !
99 W:$Y+1<IOSL !
100 N DTOUT,DUOUT,DIRUT
101 S DIR(0)="E" D ^DIR K DIR S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT),YSLFT=$D(DIRUT)
102 W @IOF Q:'YSLFT S YSPGI=YSPGL,(YSPCMD,YSPOL,YSPX,L)=""
103 Q
104EN1 ; Called by routine YSPHYR, YSPP7
105 S (YSCON,YSLFT)=0,YSPTF=YSX_"YSPGI)",YSPGI=0,YSPGL=$P(@YSPTF,U,4),YSPGI=1,YSPTRM=78,YSPOL="",YSPJU=1,YSPLM=0,YSPSKC=1,YSPPS=0,YSPWC=0,YSPTRUE=0,YST=$S(IOST?1"P".E:1,1:0),YSPPL=$S(YST:IOSL-8,1:IOSL-3) U IO D L1
106 K YSPCMD,YSPGI,YSPGL,YSPJU,YSPLM,YSPOL,YSPPS,YSPSKC,YSPTF,YSPTRM,YSPTRUE,YSPWC,YSPX Q
Note: See TracBrowser for help on using the repository browser.