YIHIST ;SLC/DKG-INTERVIEW HISTORY DRIVER ;11/15/90 16:23 ;
;;5.01;MENTAL HEALTH;;Dec 30, 1994
G A
;
CK ;
I $T D WAIT:'P0 Q:YSZZ D HDR
Q
L ;
S Y1=$E(YSYTX,1,78-YSIND),Y2=$E(YSYTX,79-YSIND,255)
I Y2="" X P1 D CK Q:YSZZ W !?YSIND,Y1 Q
F YSYI=78-YSIND:-1:1 I $E(Y1,YSYI)?1P X P1 D CK Q:YSZZ W !?YSIND,$E(Y1,1,YSYI) S YSYTX=$E(Y1,YSYI+1,78-YSIND)_Y2 Q
I $E(Y1,YSYI)'?1P X P1 D CK Q:YSZZ W !?YSIND,Y1 S YSYTX=Y2
G L
;
A ;
S YSJT=0 I '$D(J) S J=1,YSRP=""
NX ;
G DONE:'$D(^YTT(601,YSTEST,"Q",J)),D1:'$D(^(J,"I",1))
W @IOF,!! F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"I",K,0)) W !?3,^(0)
W !!!?3,"PRESS THE SPACE BAR TO CONTINUE."
N2 ;
D RD I X'=" " G:X="*" ^YTAR2 W " ? " G N2
D1 ;
S YSTY=^YTT(601,YSTEST,"Q",J,1),T=+YSTY,B=$P(YSTY,U,2,99) G T0:T=0,T1:T=1,T2:T=2,T3
T0 ;
W @IOF
F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"T",K,0)) W !!?3,^(0)
W !!?3,"(Y OR N)",!!
A2 ;
S R1="T0" W $C(13)," " D RD G STOR:"YN"[X,BK:X="^",^YTAR2:X="*",WH:X="?" W " ?" G A2
T3 ;
W @IOF
F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"T",K,0)) W:+^(0)=1 ! W !?3,^(0)
S M=$P(YSTY,",",2)+1 W !!!?3,"ANSWER = "
A4 ;
S R1="T3" S YZT=$P($H,",",2) D RD G HOLD:YZT+1>$P($H,",",2) G STOR:X>0&(X<M),BK:X="^",^YTAR2:X="*",WH:X="?" W " ? " G A4
T2 ;
W !?12 F K=1:1 G:'$D(^YTT(601,YSTEST,"Q",J,"T",K,0)) A2 W !?12,^(0)
T1 ;
W @IOF,!!!?3,^YTT(601,YSTEST,"Q",J,"T",1,0)
F K=2:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"T",K+1,0)) Q:$E(^(0),1,3)=" " W !?3,^YTT(601,YSTEST,"Q",J,"T",K,0)
W !!?3,"(Y OR N)",!!?12,^YTT(601,YSTEST,"Q",J,"T",K,0) F K=K+1:1 G:'$D(^YTT(601,YSTEST,"Q",J,"T",K,0)) A2 W !?12,^YTT(601,YSTEST,"Q",J,"T",K,0)
STOR ;
S YSRP=YSRP_X D:J#200=0 EN4^YTFILE S J=J+1,YSJT=0 X:B'="" B G:'YSJT NX
S M=J-1#200,J=J+YSJT,T=M+YSJT-1,K=T S:K>199 K=199 F L=M:1:K S YSRP=YSRP_" "
I T>198 D EN4^YTFILE I T>199 F L=200:1:T S YSRP=YSRP_" "
G NX
DONE ;
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 F I=1:1 S YSRP=$S($L(YSRP):YSRP,1:^YTD(601.4,YSDFN,1,YSENT,J\200)),X=$E(YSRP,$L(YSRP)) Q:X'=" " S J=J-1,YSRP=$E(YSRP,1,$L(YSRP)-1)
S J=J-1,YSRP=$E(YSRP,1,$L(YSRP)-1) G NX
RP ;
S J=1,U1=0,L=-200,YSLCK=200,YSZZ=0 D HDR
S P1=$S(IOST?1"C-".E:"I IOSL-$Y<3",1:"I IOSL-$Y<7"),P3=$S(P1[3:"I IOSL-$Y<6",1:"I IOSL-$Y<10"),P0=$S(P1[3:0,1:1)
R1 ;
I '$D(^YTT(601,YSTEST,"G",J,1,1,0)) K A,B,I,YSIND,J,L,YSLCK,R,YSSTEM,U1,YSYX,YSYCK,YSSCK Q
S A=^YTT(601,YSTEST,"G",J,1,1,0),J=J+1,B=$P(A,U),I=+B,YSIND=$P(B,",",2)
I I=0 X P3 D CK G:YSZZ END W !!?YSIND,$P(A,U,2),! S YSLCK=200 G R1
I I'>L!(I>U1) S L=(I-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
S R=$E(YSYX,I-L) G:R=" " R1
S YSSTEM=$P(A,U,2) G:YSSTEM'["##" YSRP1 S YSSCK=$S(YSSTEM["2":2,YSSTEM["1":1,1:0) I YSSTEM["L" S YSLCK=YSIND,YSYCK=$P(A,U,3) G R1
I YSSCK X P3 D CK G:YSZZ END
W:YSSCK ! W !?YSIND,$P(A,U,3) W:YSSCK=2 ! G R1
YSRP1 ;
I "YN"[R S R=R="N"+1 I YSSTEM'["#" S R=$P(A,U,R+1) G NOST:R'="",R1
S R=$P(A,U,R+2) G R1:R="",NOST:YSSTEM=""
D:YSIND>YSLCK STM G:YSZZ END
I YSSTEM'["#" S YSYTX=YSSTEM_R D L G R1:'YSZZ,END
S A=$F(YSSTEM,"#") I A<3 S YSYTX=R_$E(YSSTEM,2,99) D L G R1:'YSZZ,END
S YSYTX=$E(YSSTEM,1,A-2)_R_$E(YSSTEM,A,99) D L G R1:'YSZZ,END
NOST ;
D:YSIND>YSLCK STM G:YSZZ END S YSYTX=R D L G R1:'YSZZ,END
STM ;
I YSSCK X P3 D CK Q:YSZZ
W:YSSCK ! W !?YSLCK,YSYCK W:YSSCK=2 ! S YSLCK=200 Q
WH ;
W !,$P(^YTT(601,YSTEST,0),U)," QUESTION # ",J,! H 2 G @(R1)
HDR ;
S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)_" "_YSDT(0)_" "_$E(YSHD,4,5)_"/"_$E(YSHD,6,7)_"/"_$E(YSHD,2,3) W @IOF,YSHDR,!?53,"PRINTED",?62,"ENTERED" Q
WAIT ;
F I0=1:1:IOSL-$Y-2 W !
N DTOUT,DUOUT,DIRUT
W $C(7) S DIR(0)="E" D ^DIR K DIR S YSZZ=$D(DIRUT) W @IOF
Q
END ;
K I,YSIND,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK Q
HOLD ;
W !!,"Please read each question carefully!",$C(7) R X:3 K X G T3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYIHIST 3846 printed Sep 23, 2025@19:47:57 Page 2
YIHIST ;SLC/DKG-INTERVIEW HISTORY DRIVER ;11/15/90 16:23 ;
+1 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
+2 GOTO A
+3 ;
CK ;
+1 IF $TEST
if 'P0
DO WAIT
if YSZZ
QUIT
DO HDR
+2 QUIT
L ;
+1 SET Y1=$EXTRACT(YSYTX,1,78-YSIND)
SET Y2=$EXTRACT(YSYTX,79-YSIND,255)
+2 IF Y2=""
XECUTE P1
DO CK
if YSZZ
QUIT
WRITE !?YSIND,Y1
QUIT
+3 FOR YSYI=78-YSIND:-1:1
IF $EXTRACT(Y1,YSYI)?1P
XECUTE P1
DO CK
if YSZZ
QUIT
WRITE !?YSIND,$EXTRACT(Y1,1,YSYI)
SET YSYTX=$EXTRACT(Y1,YSYI+1,78-YSIND)_Y2
QUIT
+4 IF $EXTRACT(Y1,YSYI)'?1P
XECUTE P1
DO CK
if YSZZ
QUIT
WRITE !?YSIND,Y1
SET YSYTX=Y2
+5 GOTO L
+6 ;
A ;
+1 SET YSJT=0
IF '$DATA(J)
SET J=1
SET YSRP=""
NX ;
+1 if '$DATA(^YTT(601,YSTEST,"Q",J))
GOTO DONE
if '$DATA(^(J,"I",1))
GOTO D1
+2 WRITE @IOF,!!
FOR K=1:1
if '$DATA(^YTT(601,YSTEST,"Q",J,"I",K,0))
QUIT
WRITE !?3,^(0)
+3 WRITE !!!?3,"PRESS THE SPACE BAR TO CONTINUE."
N2 ;
+1 DO RD
IF X'=" "
if X="*"
GOTO ^YTAR2
WRITE " ? "
GOTO N2
D1 ;
+1 SET YSTY=^YTT(601,YSTEST,"Q",J,1)
SET T=+YSTY
SET B=$PIECE(YSTY,U,2,99)
if T=0
GOTO T0
if T=1
GOTO T1
if T=2
GOTO T2
GOTO T3
T0 ;
+1 WRITE @IOF
+2 FOR K=1:1
if '$DATA(^YTT(601,YSTEST,"Q",J,"T",K,0))
QUIT
WRITE !!?3,^(0)
+3 WRITE !!?3,"(Y OR N)",!!
A2 ;
+1 SET R1="T0"
WRITE $CHAR(13)," "
DO RD
if "YN"[X
GOTO STOR
if X="^"
GOTO BK
if X="*"
GOTO ^YTAR2
if X="?"
GOTO WH
WRITE " ?"
GOTO A2
T3 ;
+1 WRITE @IOF
+2 FOR K=1:1
if '$DATA(^YTT(601,YSTEST,"Q",J,"T",K,0))
QUIT
if +^(0)=1
WRITE !
WRITE !?3,^(0)
+3 SET M=$PIECE(YSTY,",",2)+1
WRITE !!!?3,"ANSWER = "
A4 ;
+1 SET R1="T3"
SET YZT=$PIECE($HOROLOG,",",2)
DO RD
if YZT+1>$PIECE($HOROLOG,",",2)
GOTO HOLD
if X>0&(X<M)
GOTO STOR
if X="^"
GOTO BK
if X="*"
GOTO ^YTAR2
if X="?"
GOTO WH
WRITE " ? "
GOTO A4
T2 ;
+1 WRITE !?12
FOR K=1:1
if '$DATA(^YTT(601,YSTEST,"Q",J,"T",K,0))
GOTO A2
WRITE !?12,^(0)
T1 ;
+1 WRITE @IOF,!!!?3,^YTT(601,YSTEST,"Q",J,"T",1,0)
+2 FOR K=2:1
if '$DATA(^YTT(601,YSTEST,"Q",J,"T",K+1,0))
QUIT
if $EXTRACT(^(0),1,3)=" "
QUIT
WRITE !?3,^YTT(601,YSTEST,"Q",J,"T",K,0)
+3 WRITE !!?3,"(Y OR N)",!!?12,^YTT(601,YSTEST,"Q",J,"T",K,0)
FOR K=K+1:1
if '$DATA(^YTT(601,YSTEST,"Q",J,"T",K,0))
GOTO A2
WRITE !?12,^YTT(601,YSTEST,"Q",J,"T",K,0)
STOR ;
+1 SET YSRP=YSRP_X
if J#200=0
DO EN4^YTFILE
SET J=J+1
SET YSJT=0
if B'=""
XECUTE B
if 'YSJT
GOTO NX
+2 SET M=J-1#200
SET J=J+YSJT
SET T=M+YSJT-1
SET K=T
if K>199
SET K=199
FOR L=M:1:K
SET YSRP=YSRP_" "
+3 IF T>198
DO EN4^YTFILE
IF T>199
FOR L=200:1:T
SET YSRP=YSRP_" "
+4 GOTO NX
DONE ;
+1 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
FOR I=1:1
SET YSRP=$SELECT($LENGTH(YSRP):YSRP,1:^YTD(601.4,YSDFN,1,YSENT,J\200))
SET X=$EXTRACT(YSRP,$LENGTH(YSRP))
if X'=" "
QUIT
SET J=J-1
SET YSRP=$EXTRACT(YSRP,1,$LENGTH(YSRP)-1)
+2 SET J=J-1
SET YSRP=$EXTRACT(YSRP,1,$LENGTH(YSRP)-1)
GOTO NX
RP ;
+1 SET J=1
SET U1=0
SET L=-200
SET YSLCK=200
SET YSZZ=0
DO HDR
+2 SET P1=$SELECT(IOST?1"C-".E:"I IOSL-$Y<3",1:"I IOSL-$Y<7")
SET P3=$SELECT(P1[3:"I IOSL-$Y<6",1:"I IOSL-$Y<10")
SET P0=$SELECT(P1[3:0,1:1)
R1 ;
+1 IF '$DATA(^YTT(601,YSTEST,"G",J,1,1,0))
KILL A,B,I,YSIND,J,L,YSLCK,R,YSSTEM,U1,YSYX,YSYCK,YSSCK
QUIT
+2 SET A=^YTT(601,YSTEST,"G",J,1,1,0)
SET J=J+1
SET B=$PIECE(A,U)
SET I=+B
SET YSIND=$PIECE(B,",",2)
+3 IF I=0
XECUTE P3
DO CK
if YSZZ
GOTO END
WRITE !!?YSIND,$PIECE(A,U,2),!
SET YSLCK=200
GOTO R1
+4 IF I'>L!(I>U1)
SET L=(I-1)\200*200
SET U1=L+200
SET YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
+5 SET R=$EXTRACT(YSYX,I-L)
if R=" "
GOTO R1
+6 SET YSSTEM=$PIECE(A,U,2)
if YSSTEM'["##"
GOTO YSRP1
SET YSSCK=$SELECT(YSSTEM["2":2,YSSTEM["1":1,1:0)
IF YSSTEM["L"
SET YSLCK=YSIND
SET YSYCK=$PIECE(A,U,3)
GOTO R1
+7 IF YSSCK
XECUTE P3
DO CK
if YSZZ
GOTO END
+8 if YSSCK
WRITE !
WRITE !?YSIND,$PIECE(A,U,3)
if YSSCK=2
WRITE !
GOTO R1
YSRP1 ;
+1 IF "YN"[R
SET R=R="N"+1
IF YSSTEM'["#"
SET R=$PIECE(A,U,R+1)
if R'=""
GOTO NOST
GOTO R1
+2 SET R=$PIECE(A,U,R+2)
if R=""
GOTO R1
if YSSTEM=""
GOTO NOST
+3 if YSIND>YSLCK
DO STM
if YSZZ
GOTO END
+4 IF YSSTEM'["#"
SET YSYTX=YSSTEM_R
DO L
if 'YSZZ
GOTO R1
GOTO END
+5 SET A=$FIND(YSSTEM,"#")
IF A<3
SET YSYTX=R_$EXTRACT(YSSTEM,2,99)
DO L
if 'YSZZ
GOTO R1
GOTO END
+6 SET YSYTX=$EXTRACT(YSSTEM,1,A-2)_R_$EXTRACT(YSSTEM,A,99)
DO L
if 'YSZZ
GOTO R1
GOTO END
NOST ;
+1 if YSIND>YSLCK
DO STM
if YSZZ
GOTO END
SET YSYTX=R
DO L
if 'YSZZ
GOTO R1
GOTO END
STM ;
+1 IF YSSCK
XECUTE P3
DO CK
if YSZZ
QUIT
+2 if YSSCK
WRITE !
WRITE !?YSLCK,YSYCK
if YSSCK=2
WRITE !
SET YSLCK=200
QUIT
WH ;
+1 WRITE !,$PIECE(^YTT(601,YSTEST,0),U)," QUESTION # ",J,!
HANG 2
GOTO @(R1)
HDR ;
+1 SET YSHDR=$EXTRACT(YSHDR,1,43)_" "_YSSEX_" AGE "_$JUSTIFY(YSAGE,2,0)_" "_YSDT(0)_" "_$EXTRACT(YSHD,4,5)_"/"_$EXTRACT(YSHD,6,7)_"/"_$EXTRACT(YSHD,2,3)
WRITE @IOF,YSHDR,!?53,"PRINTED",?62,"ENTERED"
QUIT
WAIT ;
+1 FOR I0=1:1:IOSL-$Y-2
WRITE !
+2 NEW DTOUT,DUOUT,DIRUT
+3 WRITE $CHAR(7)
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET YSZZ=$DATA(DIRUT)
WRITE @IOF
+4 QUIT
END ;
+1 KILL I,YSIND,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK
QUIT
HOLD ;
+1 WRITE !!,"Please read each question carefully!",$CHAR(7)
READ X:3
KILL X
GOTO T3
