source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMCMI2.m@ 691

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

initial load of WorldVistAEHR

File size: 2.0 KB
RevLine 
[613]1YTMCMI2 ;SLC/DKG-TEST PKG: TEST DRIVER; ;4/11/91 15:31
2 ;;5.01;MENTAL HEALTH;**10,19**;Dec 30, 1994
3 ;
4 I '$D(J) S J=1,YSRP="",B="",YSBEGIN=DT
5 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
6NX ;
7 I $D(^YTT(601,YSTEST,"Q",J,0))#2=1 S:$P(^(0),U,2)]"" C=$P(^(0),U,2)
8 I $D(^YTT(601,YSTEST,"Q",J,"B")) S K=^("B") S:K'="" B=K
9 I '$D(^YTT(601,YSTEST,"Q",J,"I",1,0)) G D1
10 W @IOF F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"I",K)) W:'$D(^YTT(601,YSTEST,"Q",J,"I",5)) ! W:$D(^YTT(601,YSTEST,"Q",J,"I",K,0)) !?3,^(0)
11 W !!!?3,"PRESS THE SPACE BAR TO CONTINUE."
12I2 ;
13 D RD I X'=" " G:X="*" ^YTAR2 W " ? " G I2
14D1 ;
15 W @IOF F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",J,"T",K)) W:$D(^(K,0)) !!?3,^(0)
16 X:B'="" B
17D3 ;
18 S YZT=$P($H,",",2)
19 D RD
20 G HOLD:YZT+1>$P($H,",",2)
21 G D4:C[X,BK:X="^",^YTAR2:X="*",WHERE:X="?" W " ? " G D3
22D4 ;
23 S YSRP=YSRP_X S J=J+1 I $D(^YTT(601,YSTEST,"Q",J)) G NX
24 S:$D(YSMCMI2P) YSRP=YSRP_YSMCMI2P_YSMCMI2L D ^YTFILE K YSMCMI2P,YSMCMI2L Q
25RD ;
26 R *X:900 S:'$T X=42 G:X<32 RD S X=$C(X) Q
27BK ;
28 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
29WHERE ;
30 W !,YSTESTN," QUESTION # ",J,! X:B]"" B G D3
31CR ;
32 I YSCH="IPAT"!(YSCH="PSYC") S YSTNM=$P($P(^YTT(601,YSTEST,"P"),U),"---",2),YSTNM=$E(YSTNM,1,$L(YSTNM)-1) G IP:YSCH="IPAT",PS:YSCH="PSYC"
33 W @IOF,!!!?3,^YTT(601.3,YSCHN,1,1,0)," ",YSCD," ",^YTT(601.3,YSCHN,1,2,0) S YSTX=2
34 F S YSTX=$O(^YTT(601.3,YSCHN,1,YSTX)) Q:'YSTX W !?3,^(YSTX,0)
35 W !! H 5 K YSCH,YSCHN,YSCD,YSTX Q
36IP ;
37 W @IOF,!!!?3,^YTT(601.3,YSCHN,1,1,0),!?3,^YTT(601.3,YSCHN,1,2,0),YSTNM,",",!?3,^YTT(601.3,YSCHN,1,3,0)," ",YSCD," ",^YTT(601.3,YSCHN,1,4,0),!?3,^YTT(601.3,YSCHN,1,5,0),! H 5 K YSCH,YSCHN,YSCD,YSTX,YSTNM Q
38PS ;
39 W @IOF,!!!?3,^YTT(601.3,YSCHN,1,1,0),YSTNM,!?3,^YTT(601.3,YSCHN,1,2,0)," ",YSCD,!?3,^YTT(601.3,YSCHN,1,3,0)," ",^YTT(601.3,YSCHN,1,4,0) H 5 K YSCH,YSCHN,YSCD,YSTX,YSTNM Q
40 ;
41HOLD ;
42 W @IOF,#,$C(7)
43 R "Please read each question carefully!",X:3 K X G D1
Note: See TracBrowser for help on using the repository browser.