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