YTBPRS ;SLC/DKG-TEST PKG: BPRS REPORT ; 10/19/88  17:18 ;
 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
 ;
 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
 S R="" F J=1:1:18 S R=R_$E(X,J)_"^"
 S R1=0 F J=4,12,15 S R1=R1+$E(X,J)
 S R=R_R1_"^",R1=0 F J=2,5,9 S R1=R1+$E(X,J)
 S R=R_R1_"^",R1=0 F J=10,11,14 S R1=R1+$E(X,J)
 S R=R_R1_"^",R1=0 F J=3,13,16 S R1=R1+$E(X,J)
 S R=R_R1_"^",R1=0 F J=1:1:16 S R1=R1+$E(X,J)
 S R=R_R1
 S Y=^YTT(601,YSTEST,"P"),X=$P(Y,U),A=$P(Y,U,2),B=$P(Y,U,3),L1=58-A\2,L2=L1+A+1 S:A<9 A=9
 D DTA^YTREPT W !!?(72-$L(X)\2),X,!!!?(A-9\2+L1),"S C A L E",?(L2+1),"RAW",!
 S YSLFT=0 F J=1:1 D:IOST?1"C-".E WAIT:$Y>(IOSL-4) Q:YSLFT  S R1=$P(R,U,J) Q:R1=""  W:J=19!(J=23) ! W !?L1,$P(^YTT(601,YSTEST,"S",J,0),U,2),?L2,$J(R1,4,0)
 W ! K A,B,J,L1,L2,R1,X,Y Q
WAIT ;
 ;  Added 5/6/94 LJA
 N A,B,B1,C,D,E,E1,F,F1,G,G1,H,I,J,J1,J2,J3,J4,K,L,L1,L2,M,N
 N N1,N2,N3,N4,P,P0,P1,P3,R,R1,S,S1,T,T1,T2,TT,V,V1,V2,V3
 N V4,V5,V6,W,X,X0,X1,X2,X3,X4,X7,X8,X9,Y,Y1,Y2,Z,Z1,Z3
 ;
 Q:IOST'?1"C-".E
 N DTOUT,DUOUT,DIRUT
 S DIR(0)="E" D ^DIR K DIR S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT),YSLFT=$D(DIRUT)
 W @IOF