YTBPRS.m

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 ---YTBPRS   1111     printed  Mar 13, 2025@21:21:55                                                                                                                                                                                                      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