YTBI ;ALB/ASF-BECK INVENTORY DRIVERS ; 2/20/08 10:38am
;;5.01;MENTAL HEALTH;**76,96**;Dec 30, 1994;Build 46
;No external references
S J=1,(YSRP,B)="",YSBEGIN=DT
I $P(^YTT(601,YSTEST,0),U,6)]"" S YSCH=$P(^(0),U,6),Y=$P(^(0),U,7) D DD^%DT S YSCD=Y I $D(^YTT(601.3,YSCH,0)) S YSCHN=YSCH,YSCH=$P(^(0),U) D CR^YTDRIV
NX ;
I $D(^YTT(601,YSTEST,"Q",J,0))#2=1 S:$P(^(0),U,2)]"" C=$P(^(0),U,2)
I $D(^YTT(601,YSTEST,"Q",J,"B")) S K=^("B") S:K'="" B=K
I '$D(^YTT(601,YSTEST,"Q",J,"I",1,0)) G D1
W @IOF F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"I",K)) S X=^YTT(601,YSTEST,"Q",J,"I",K,0) W !!?3,X
W !!!?3,"PRESS THE SPACE BAR TO CONTINUE."
I2 ;
D RD I X'=" " G:X="*" ^YTAR2 W " ? " G I2
D1 ;
W @IOF F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"T",K)) I $D(^(K,0)) W:^(0) ! W !?3,^(0)
X:B'="" B
D3 ;
S YZT=$P($H,",",2) D RD G HOLD:YZT+1>$P($H,",",2) G D4:C[X,BK:X="^",^YTAR2:X="*",WHERE:X="?" W " ? " G D3
D4 ;
S YSRP=YSRP_X
; SKIP LOGIC ****
I (J=5)&($E(YSRP,4,5)="00") S YSRP=YSRP_" ",J=19
I (J=20)&(X=0) S YSRP=YSRP_" ",J=21
S J=J+1 I $D(^YTT(601,YSTEST,"Q",J)) G NX
D ^YTFILE Q
RD ;
R *X:900 S:'$T X=42 G:X<32 RD S X=$C(X) Q
BK ;
G:J=1 D1 S J=J-1,X=$L(YSRP),YSRP=$S(X>1:$E(YSRP,1,X-1),X=1:"",1:$E(^YTD(601.4,YSDFN,1,YSENT,J\200),1,199)) G NX
WHERE ;
W !,YSTESTN," QUESTION # ",J,! X:B]"" B G D3
HOLD ;
W @IOF,#,"Please read each question carefully!",$C(7) R X:3 K X G D1
BAI ;
W ?$X+3,$S(R<10:"normal",R<19:"mild to moderate",R<30:"moderate to severe",R<64:"severe",1:""),!!,^YTT(601,YSTEST,"G",1,1,1,0),! S X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1) G B2:X'?.E1"3".E
W !!?7,"Items marked Severe",! F I=1:1:21 I $E(X,I)=3 S Y=^YTT(601,YSTEST,"Q",I,"T",1,0) W:$X+$L(Y)>79 ! W $E(Y,1,$L(Y)-1),", "
B2 ;
Q:X'?.E1"2".E
W !!?7,"Items marked Moderate",! F I=1:1:21 I $E(X,I)=2 S Y=^YTT(601,YSTEST,"Q",I,"T",1,0) W:$X+$L(Y)>79 ! W $E(Y,1,$L(Y)-1),", "
Q
BSIRPT ;
W !!,"Responses",! S X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1),YSLFT=0
F I=1:1:21 S Y=$E(X,I) I Y?1N S K=0 F S K=$O(^YTT(601,YSTEST,"Q",I,"T",K)) Q:K'>0 S Z=^(K,0) I $E(Z)=Y D:$Y+4>IOSL WAIT W !,$J(I,2),".(",Y,") ",$P(^(0)," ",2,9) D BSI2 Q
Q:X'?.E1"X".E W !!,"The following questions were skipped: " F I=1:1:20 W:$E(X,I)="X" I,", " ;ASF 9/15/04 from refused
Q
BSI2 ;
F S K=$O(^YTT(601,YSTEST,"Q",I,"T",K)) Q:K'>0 S Z=^(K,0) Q:'Z W !?3,Z
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
;
I IOST'?1"C".E D DTA^YTREPT Q
F I0=1:1:IOSL-$Y-2 W !
W $C(7) S DIR(0)="E" D ^DIR K DIR S YSTOUT=$D(DTOUT),YSUOUT=$D(YSUOUT),YSLFT=$D(DIRUT) W @IOF Q
BDI ;
S YSTY="*",R=0,Z(1)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1) F I=1:1:18,21,22 S R=R+$E(Z(1),I)
S:$E(Z(1),20)="N" R=R+$E(Z(1),19) D REPT^YTREPT S YSLFT=0 W ?$X+3,$S(R<10:"asymptomatic",R<19:"mild-moderate",R<30:"moderate-severe",R>29:"extremely severe",1:""),!!,^YTT(601,YSTEST,"M",24,1,1,0),!,^YTT(601,YSTEST,"M",24,1,2,0)
F Z=3,2,1 Q:YSLFT I Z(1)[Z W !!?3,$S(Z=3:"Severe",Z=2:"Moderate",1:"Mild")," Symptoms:" F I=1:1:22 S Z(2)=$S(Z=3:1,Z=2:2,1:3) W:$E(Z(1),I)=Z !,$P(^YTT(601,YSTEST,"M",I,1,1,0),U,Z(2)) D:$Y+4>IOSL WAIT Q:YSLFT
Q
BDI2 ;
S R=0,(G,Z)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
S Z1=$E(Z,16)
S Z1=$S(Z1=0:0,Z1=1:1,Z1=2:1,Z1=3:2,Z1=4:2,Z1=5:3,Z1=6:3,1:"X")
S Z2=$E(Z,18)
S Z2=$S(Z2=0:0,Z2=1:1,Z2=2:1,Z2=3:2,Z2=4:2,Z2=5:3,Z2=6:3,1:"X")
S Z=$E(Z,1,15)_Z1_$E(Z,17)_Z2_$E(Z,19,21)
F I=1:1:21 S R=R+$E(Z,I)
S S=$S(R>28:"severe",R>19:"moderate",R>13:"mild",R<12:"minimal",1:"")
Q:YSTY'["*"
S (YSTOUT,YSUOUT)=0
S X=$P(^YTT(601,YSTEST,"P"),U),A=$P(^("P"),U,2),B=$P(^("P"),U,3),L1=58-A\2,L2=L1+A+4 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 ",B,!
W !?L1,$P(^YTT(601,YSTEST,"S",1,0),U,2),?L2,$J(R,4,0)
W " ",S
F J=3,2,1 W:Z[J !!,$S(J=3:"Severe",J=2:"Moderate",J=1:"Mild",1:"")," symptoms",! D D:IOST?1"C-".E&($Y>21) SCR^YTREPT Q:YSTOUT!YSUOUT
. F K=1:1:21 I $E(Z,K)=J W:$X>60 ! W:$X>3 "," W $P(^YTT(601,YSTEST,"G",1,1,K,0),".",2,9) D D:IOST?1"C-".E&($Y>21) SCR^YTREPT Q:YSTOUT!YSUOUT
.. I K=16 S G1=$E(G,16) W $S(G1=1:" (more)",G1=3:" (more)",G1=5:" (more)",G1=2:" (less)",G1=4:" (less)",G1=6:" (less)",1:"")
.. I K=18 S G1=$E(G,18) W $S(G1=1:" (less)",G1=2:" (more)",G1=3:" (less)",G1=4:" (more)",G1=5:" (less)",G1=6:" (more)",1:"")
Q:YSTOUT!YSUOUT D:IOST?1"C-".E SCR^YTREPT
Q:YSTOUT!YSUOUT D IR^YTREPT
Q:YSTOUT!YSUOUT D:IOST?1"C-".E SCR^YTREPT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTBI 4583 printed Sep 23, 2025@19:53:08 Page 2
YTBI ;ALB/ASF-BECK INVENTORY DRIVERS ; 2/20/08 10:38am
+1 ;;5.01;MENTAL HEALTH;**76,96**;Dec 30, 1994;Build 46
+2 ;No external references
+3 SET J=1
SET (YSRP,B)=""
SET YSBEGIN=DT
+4 IF $PIECE(^YTT(601,YSTEST,0),U,6)]""
SET YSCH=$PIECE(^(0),U,6)
SET Y=$PIECE(^(0),U,7)
DO DD^%DT
SET YSCD=Y
IF $DATA(^YTT(601.3,YSCH,0))
SET YSCHN=YSCH
SET YSCH=$PIECE(^(0),U)
DO CR^YTDRIV
NX ;
+1 IF $DATA(^YTT(601,YSTEST,"Q",J,0))#2=1
if $PIECE(^(0),U,2)]""
SET C=$PIECE(^(0),U,2)
+2 IF $DATA(^YTT(601,YSTEST,"Q",J,"B"))
SET K=^("B")
if K'=""
SET B=K
+3 IF '$DATA(^YTT(601,YSTEST,"Q",J,"I",1,0))
GOTO D1
+4 WRITE @IOF
FOR K=1:1
if '$DATA(^YTT(601,YSTEST,"Q",J,"I",K))
QUIT
SET X=^YTT(601,YSTEST,"Q",J,"I",K,0)
WRITE !!?3,X
+5 WRITE !!!?3,"PRESS THE SPACE BAR TO CONTINUE."
I2 ;
+1 DO RD
IF X'=" "
if X="*"
GOTO ^YTAR2
WRITE " ? "
GOTO I2
D1 ;
+1 WRITE @IOF
FOR K=1:1
if '$DATA(^YTT(601,YSTEST,"Q",J,"T",K))
QUIT
IF $DATA(^(K,0))
if ^(0)
WRITE !
WRITE !?3,^(0)
+2 if B'=""
XECUTE B
D3 ;
+1 SET YZT=$PIECE($HOROLOG,",",2)
DO RD
if YZT+1>$PIECE($HOROLOG,",",2)
GOTO HOLD
if C[X
GOTO D4
if X="^"
GOTO BK
if X="*"
GOTO ^YTAR2
if X="?"
GOTO WHERE
WRITE " ? "
GOTO D3
D4 ;
+1 SET YSRP=YSRP_X
+2 ; SKIP LOGIC ****
+3 IF (J=5)&($EXTRACT(YSRP,4,5)="00")
SET YSRP=YSRP_" "
SET J=19
+4 IF (J=20)&(X=0)
SET YSRP=YSRP_" "
SET J=21
+5 SET J=J+1
IF $DATA(^YTT(601,YSTEST,"Q",J))
GOTO NX
+6 DO ^YTFILE
QUIT
RD ;
+1 READ *X:900
if '$TEST
SET X=42
if X<32
GOTO RD
SET X=$CHAR(X)
QUIT
BK ;
+1 if J=1
GOTO D1
SET J=J-1
SET X=$LENGTH(YSRP)
SET YSRP=$SELECT(X>1:$EXTRACT(YSRP,1,X-1),X=1:"",1:$EXTRACT(^YTD(601.4,YSDFN,1,YSENT,J\200),1,199))
GOTO NX
WHERE ;
+1 WRITE !,YSTESTN," QUESTION # ",J,!
if B]""
XECUTE B
GOTO D3
HOLD ;
+1 WRITE @IOF,#,"Please read each question carefully!",$CHAR(7)
READ X:3
KILL X
GOTO D1
BAI ;
+1 WRITE ?$X+3,$SELECT(R<10:"normal",R<19:"mild to moderate",R<30:"moderate to severe",R<64:"severe",1:""),!!,^YTT(601,YSTEST,"G",1,1,1,0),!
SET X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
if X'?.E1"3".E
GOTO B2
+2 WRITE !!?7,"Items marked Severe",!
FOR I=1:1:21
IF $EXTRACT(X,I)=3
SET Y=^YTT(601,YSTEST,"Q",I,"T",1,0)
if $X+$LENGTH(Y)>79
WRITE !
WRITE $EXTRACT(Y,1,$LENGTH(Y)-1),", "
B2 ;
+1 if X'?.E1"2".E
QUIT
+2 WRITE !!?7,"Items marked Moderate",!
FOR I=1:1:21
IF $EXTRACT(X,I)=2
SET Y=^YTT(601,YSTEST,"Q",I,"T",1,0)
if $X+$LENGTH(Y)>79
WRITE !
WRITE $EXTRACT(Y,1,$LENGTH(Y)-1),", "
+3 QUIT
BSIRPT ;
+1 WRITE !!,"Responses",!
SET X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
SET YSLFT=0
+2 FOR I=1:1:21
SET Y=$EXTRACT(X,I)
IF Y?1N
SET K=0
FOR
SET K=$ORDER(^YTT(601,YSTEST,"Q",I,"T",K))
if K'>0
QUIT
SET Z=^(K,0)
IF $EXTRACT(Z)=Y
if $Y+4>IOSL
DO WAIT
WRITE !,$JUSTIFY(I,2),".(",Y,") ",$PIECE(^(0)," ",2,9)
DO BSI2
QUIT
+3 ;ASF 9/15/04 from refused
if X'?.E1"X".E
QUIT
WRITE !!,"The following questions were skipped: "
FOR I=1:1:20
if $EXTRACT(X,I)="X"
WRITE I,", "
+4 QUIT
BSI2 ;
+1 FOR
SET K=$ORDER(^YTT(601,YSTEST,"Q",I,"T",K))
if K'>0
QUIT
SET Z=^(K,0)
if 'Z
QUIT
WRITE !?3,Z
+2 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
DO DTA^YTREPT
QUIT
+7 FOR I0=1:1:IOSL-$Y-2
WRITE !
+8 WRITE $CHAR(7)
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET YSTOUT=$DATA(DTOUT)
SET YSUOUT=$DATA(YSUOUT)
SET YSLFT=$DATA(DIRUT)
WRITE @IOF
QUIT
BDI ;
+1 SET YSTY="*"
SET R=0
SET Z(1)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
FOR I=1:1:18,21,22
SET R=R+$EXTRACT(Z(1),I)
+2 if $EXTRACT(Z(1),20)="N"
SET R=R+$EXTRACT(Z(1),19)
DO REPT^YTREPT
SET YSLFT=0
WRITE ?$X+3,$SELECT(R<10:"asymptomatic",R<19:"mild-moderate",R<30:"moderate-severe",R>29:"extremely severe",1:""),!!,^YTT(601,YSTEST,"M",24,1,1,0),!,^YTT(601,YSTEST,"M",24,1,2,0)
+3 FOR Z=3,2,1
if YSLFT
QUIT
IF Z(1)[Z
WRITE !!?3,$SELECT(Z=3:"Severe",Z=2:"Moderate",1:"Mild")," Symptoms:"
FOR I=1:1:22
SET Z(2)=$SELECT(Z=3:1,Z=2:2,1:3)
if $EXTRACT(Z(1),I)=Z
WRITE !,$PIECE(^YTT(601,YSTEST,"M",I,1,1,0),U,Z(2))
if $Y+4>IOSL
DO WAIT
if YSLFT
QUIT
+4 QUIT
BDI2 ;
+1 SET R=0
SET (G,Z)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
+2 SET Z1=$EXTRACT(Z,16)
+3 SET Z1=$SELECT(Z1=0:0,Z1=1:1,Z1=2:1,Z1=3:2,Z1=4:2,Z1=5:3,Z1=6:3,1:"X")
+4 SET Z2=$EXTRACT(Z,18)
+5 SET Z2=$SELECT(Z2=0:0,Z2=1:1,Z2=2:1,Z2=3:2,Z2=4:2,Z2=5:3,Z2=6:3,1:"X")
+6 SET Z=$EXTRACT(Z,1,15)_Z1_$EXTRACT(Z,17)_Z2_$EXTRACT(Z,19,21)
+7 FOR I=1:1:21
SET R=R+$EXTRACT(Z,I)
+8 SET S=$SELECT(R>28:"severe",R>19:"moderate",R>13:"mild",R<12:"minimal",1:"")
+9 if YSTY'["*"
QUIT
+10 SET (YSTOUT,YSUOUT)=0
+11 SET X=$PIECE(^YTT(601,YSTEST,"P"),U)
SET A=$PIECE(^("P"),U,2)
SET B=$PIECE(^("P"),U,3)
SET L1=58-A\2
SET L2=L1+A+4
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 ",B,!
+13 WRITE !?L1,$PIECE(^YTT(601,YSTEST,"S",1,0),U,2),?L2,$JUSTIFY(R,4,0)
+14 WRITE " ",S
+15 FOR J=3,2,1
if Z[J
WRITE !!,$SELECT(J=3:"Severe",J=2:"Moderate",J=1:"Mild",1:"")," symptoms",!
Begin DoDot:1
+16 FOR K=1:1:21
IF $EXTRACT(Z,K)=J
if $X>60
WRITE !
if $X>3
WRITE ","
WRITE $PIECE(^YTT(601,YSTEST,"G",1,1,K,0),".",2,9)
Begin DoDot:2
+17 IF K=16
SET G1=$EXTRACT(G,16)
WRITE $SELECT(G1=1:" (more)",G1=3:" (more)",G1=5:" (more)",G1=2:" (less)",G1=4:" (less)",G1=6:" (less)",1:"")
+18 IF K=18
SET G1=$EXTRACT(G,18)
WRITE $SELECT(G1=1:" (less)",G1=2:" (more)",G1=3:" (less)",G1=4:" (more)",G1=5:" (less)",G1=6:" (more)",1:"")
End DoDot:2
if IOST?1"C-".E&($Y>21)
DO SCR^YTREPT
if YSTOUT!YSUOUT
QUIT
End DoDot:1
if IOST?1"C-".E&($Y>21)
DO SCR^YTREPT
if YSTOUT!YSUOUT
QUIT
+19 if YSTOUT!YSUOUT
QUIT
if IOST?1"C-".E
DO SCR^YTREPT
+20 if YSTOUT!YSUOUT
QUIT
DO IR^YTREPT
+21 if YSTOUT!YSUOUT
QUIT
if IOST?1"C-".E
DO SCR^YTREPT
