source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YIHIST.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1YIHIST ;SLC/DKG-INTERVIEW HISTORY DRIVER ;11/15/90 16:23 ;
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 G A
4 ;
5CK ;
6 I $T D WAIT:'P0 Q:YSZZ D HDR
7 Q
8L ;
9 S Y1=$E(YSYTX,1,78-YSIND),Y2=$E(YSYTX,79-YSIND,255)
10 I Y2="" X P1 D CK Q:YSZZ W !?YSIND,Y1 Q
11 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
12 I $E(Y1,YSYI)'?1P X P1 D CK Q:YSZZ W !?YSIND,Y1 S YSYTX=Y2
13 G L
14 ;
15A ;
16 S YSJT=0 I '$D(J) S J=1,YSRP=""
17NX ;
18 G DONE:'$D(^YTT(601,YSTEST,"Q",J)),D1:'$D(^(J,"I",1))
19 W @IOF,!! F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"I",K,0)) W !?3,^(0)
20 W !!!?3,"PRESS THE SPACE BAR TO CONTINUE."
21N2 ;
22 D RD I X'=" " G:X="*" ^YTAR2 W " ? " G N2
23D1 ;
24 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
25T0 ;
26 W @IOF
27 F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"T",K,0)) W !!?3,^(0)
28 W !!?3,"(Y OR N)",!!
29A2 ;
30 S R1="T0" W $C(13)," " D RD G STOR:"YN"[X,BK:X="^",^YTAR2:X="*",WH:X="?" W " ?" G A2
31T3 ;
32 W @IOF
33 F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"T",K,0)) W:+^(0)=1 ! W !?3,^(0)
34 S M=$P(YSTY,",",2)+1 W !!!?3,"ANSWER = "
35A4 ;
36 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
37T2 ;
38 W !?12 F K=1:1 G:'$D(^YTT(601,YSTEST,"Q",J,"T",K,0)) A2 W !?12,^(0)
39T1 ;
40 W @IOF,!!!?3,^YTT(601,YSTEST,"Q",J,"T",1,0)
41 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)
42 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)
43STOR ;
44 S YSRP=YSRP_X D:J#200=0 EN4^YTFILE S J=J+1,YSJT=0 X:B'="" B G:'YSJT NX
45 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_" "
46 I T>198 D EN4^YTFILE I T>199 F L=200:1:T S YSRP=YSRP_" "
47 G NX
48DONE ;
49 D ^YTFILE Q
50RD ;
51 R *X:900 S:'$T X=42 G:X<32 RD S X=$C(X) Q
52BK ;
53 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)
54 S J=J-1,YSRP=$E(YSRP,1,$L(YSRP)-1) G NX
55RP ;
56 S J=1,U1=0,L=-200,YSLCK=200,YSZZ=0 D HDR
57 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)
58R1 ;
59 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
60 S A=^YTT(601,YSTEST,"G",J,1,1,0),J=J+1,B=$P(A,U),I=+B,YSIND=$P(B,",",2)
61 I I=0 X P3 D CK G:YSZZ END W !!?YSIND,$P(A,U,2),! S YSLCK=200 G R1
62 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)
63 S R=$E(YSYX,I-L) G:R=" " R1
64 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
65 I YSSCK X P3 D CK G:YSZZ END
66 W:YSSCK ! W !?YSIND,$P(A,U,3) W:YSSCK=2 ! G R1
67YSRP1 ;
68 I "YN"[R S R=R="N"+1 I YSSTEM'["#" S R=$P(A,U,R+1) G NOST:R'="",R1
69 S R=$P(A,U,R+2) G R1:R="",NOST:YSSTEM=""
70 D:YSIND>YSLCK STM G:YSZZ END
71 I YSSTEM'["#" S YSYTX=YSSTEM_R D L G R1:'YSZZ,END
72 S A=$F(YSSTEM,"#") I A<3 S YSYTX=R_$E(YSSTEM,2,99) D L G R1:'YSZZ,END
73 S YSYTX=$E(YSSTEM,1,A-2)_R_$E(YSSTEM,A,99) D L G R1:'YSZZ,END
74NOST ;
75 D:YSIND>YSLCK STM G:YSZZ END S YSYTX=R D L G R1:'YSZZ,END
76STM ;
77 I YSSCK X P3 D CK Q:YSZZ
78 W:YSSCK ! W !?YSLCK,YSYCK W:YSSCK=2 ! S YSLCK=200 Q
79WH ;
80 W !,$P(^YTT(601,YSTEST,0),U)," QUESTION # ",J,! H 2 G @(R1)
81HDR ;
82 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
83WAIT ;
84 F I0=1:1:IOSL-$Y-2 W !
85 N DTOUT,DUOUT,DIRUT
86 W $C(7) S DIR(0)="E" D ^DIR K DIR S YSZZ=$D(DIRUT) W @IOF
87 Q
88END ;
89 K I,YSIND,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK Q
90HOLD ;
91 W !!,"Please read each question carefully!",$C(7) R X:3 K X G T3
Note: See TracBrowser for help on using the repository browser.