source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAR.m@ 724

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

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1YTAR ;SLC/DKG,SLC/TGA-ADMINISTER & RESUME TESTS ;5/30/02 14:54
2 ;;5.01;MENTAL HEALTH;**37,54,76**;Dec 30, 1994
3 ;
4 W:YSNT>0 !!?10,"--- Previous Instruments ---",! S B=$S(YSNT<11:YSNT,1:YSNT+1\2)
5 F K=1:1:B S YSDT=$P(A1(K),U,2) D DAT W !?15,$P(A1(K),U),?22,YSDT I B'=YSNT,$D(A1(B+K)) W ?50,$P(A1(B+K),U) S YSDT=$P(A1(B+K),U,2) D DAT W ?57,YSDT
6 I $D(YSCLERK) G ^YTCLERK
7 S:'$D(T1) T1=0 I $D(^YTD(601.4,YSDFN,1,"B")) G ^YTAR1
8A10 ;
9 W !!!?2,"Do you want DEMO program administered" S %=2 D YN^DICN G:%<0 KAR^YTS
10 I '% W !?4,"The DEMO program teaches the patient to use the terminal." G A10
11 S YSDEMO=$S(%=1:"Y",1:"N")
12A11 ;
13 W !! S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Professional requesting instrument: ",DIC("B")=DUZ D ^DIC K DIC I Y'>0 G KAR^YTS
14 I DUZ'=+Y W !!?2,"A message will be sent to ",$P(^VA(200,+Y,0),U) R " OK? Y// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G:YSTOUT!YSUOUT!(A["N")!(A["n") KAR^YTS S:A="" A="Y" I "Yy"'[$E(A) W:A'["?" " ?",$C(7) D MSG1 G A11
15 S YSORD=+Y,YSORD(0)=$P(Y,U,2),YSORDP=$S($D(^XUSEC("YSP",YSORD)):0,1:2) I YSORDP>0 S YSORDD=$S($D(^XUSEC("YSP",DUZ)):0,1:2)
16 G:T1 A3 ;->
17 W $C(7),!!,$P(^VA(200,YSORD,0),U)," may order ",$P($T(ORD+YSORDP),";",3)
18 W ", exempt tests, and vocational tests."
19A12 ;
20 S YSXT="" W !!?2,"Administer the following instruments:",!
21A2 ;
22 R !?5,"Instrument: ",YSTESTN:DTIME S YSTOUT='$T,YSUOUT=YSTESTN["^" G KAR^YTS:YSTOUT!YSUOUT,A3:YSTESTN=""
23 I YSTESTN="CLERK" W !!,"Not a valid instrument, you may want to use the CLERK entry option!",!! G A2
24 I YSTESTN["?" D ^YTLIST G A2
25 I $L(YSTESTN)>5!(YSTESTN'?.UNP) W " ?" G A2
26 I YSTESTN="BECK" D BECK^YTS
27 I YSTESTN="MMPI" D MMPI^YTS
28 S YSTEST=$O(^YTT(601,"B",YSTESTN,0)) I 'YSTEST W " [Not Found]" G A2
29 S X=^YTT(601,YSTEST,0),YSNX(0)=X I YSORDP>0,$P(X,U,8)'="V",$P(X,U,9)="T",$P(X,U,10)'="Y",YSORDD>0 W !!,YSORD(0)_" is NOT AUTHORIZED to order",!,"Instrument "_$P(YSNX(0),U)_".",!! G A2
30 I YSORDP=2,$P(X,U,8)="V",$P(X,U,10)'="Y",YSORDD>1 W !!,YSORD(0)_" is NOT AUTHORIZED to order",!,"Instrument "_$P(YSNX(0),U)_".",!! G A2
31 ;I $P(X,U,13)="N" W !!,YSORD(0)_" is NOT AUTHORIZED to order",!,"Instrument "_$P(YSNX(0),U)_".",!! G A2
32 I $P(X,U,13)="N" W !!,"You have selected an instrument that is NOT OPERATIONAL.",! G A2
33 I $P(X,U,14)="N" D CR G A2
34 F Z=1:1 S YSNX=$P(YSXT,U,Z) Q:YSNX="" I YSNX=YSTEST W " [Duplicate Ignored]",!! G A2
35MCMI2 ;
36 I $P(^YTT(601,YSTEST,0),U)?1"MCMI"1N X ^YTT(601,YSTEST,"C") ;ASF 5/30/02
37 I $P(X,U,9)="B",YSORDP>0 S YSTEST=$$SCRN(YSTEST) I YSTEST']"" G A2
38 S YSXT=YSXT_YSTEST_"^" G:$L(YSXT,U)<11 A2
39A3 ;
40 G:YSXT="" KAR^YTS S YSQ=0 I $D(^XUSEC("YSP",DUZ))!$D(^XUSEC("YSZ",DUZ)) D A31^YTCLERK1 G:YSOK<1 KAR^YTS
41 I YSQ S ZTIO=ION D HOME^%ZIS
42 D:"Y"[YSDEMO ^YTDEMO S YSXTP=1
43A4 ;
44 S YSTEST=$P(YSXT,U,YSXTP) I YSTEST="" G DONE
45 D:'$D(YSRESTRT) KT S YS4D=0,YSTESTN=$P(^YTT(601,YSTEST,0),U)
46 I $D(^YTT(601,YSTEST,"C")),$P(^YTT(601,YSTEST,0),U)'?1"MCMI"1N X ^("C") I $D(J),J<1 G KAR^YTS ;ASF 5/30/02
47 X ^YTT(601,YSTEST,"A") G:$D(YSTIN) KAR^YTS D KT K YSRESTRT S XMB(YSXTP+5)=$P(YSXT,U,YSXTP),YSXTP=YSXTP+1 G A4
48DONE ;
49 W:'$D(YSCL) @IOF,!!!?10,"*** Thank you for completing the test! ***",!!! H 5 S XMB(5)="" I YSQ S YSXT="" F K=6:1 Q:'$D(XMB(K)) S YSXT=YSXT_YSHD_","_XMB(K)_"^"
50 I YSQ S YSXTP=1,ZTRTN="RP1^YTDP",ZTSAVE("YS*")="",ZTDTH=$H,ZTDESC="YS MH INST PRINT" D ^%ZTLOAD W:$D(ZTSK) !!,"Your Task Number is "_ZTSK
51 I DUZ'=YSORD,$D(YSCLERK) S XMB(6)="CLERK-"_YSCLN
52 E I DUZ'=YSORD F K=6:1 Q:'$D(XMB(K)) S XMB(K)=$P(^YTT(601,+XMB(K),0),U)
53 I DUZ'=YSORD D ENBUL^YSUTL
54 G H^XUS:'$D(YSCL)&('$D(YSM)),KAR^YTS
55DAT ;
56 S YSDT=$$FMTE^XLFDT(YSDT,"5ZD") Q
57KT ;
58 K J I $D(^YTD(601.4,YSDFN,1,YSTEST)) S YSENT=YSTEST D ENKIL^YTFILE
59 Q
60CR ;
61 W " [VACO currently does not have a license to use this test]" Q
62MSG1 ;
63 W !!!?2,"Enter (Y) or <cr> for (YES) to send a message to the person requesting",!,"this test/interview and to CONTINUE this test/interview process."
64 W !!?2,"Enter (N) for (NO) to NOT send message and to DISCONTINUE this test/",!,"interview process."
65 Q
66SCRN(X) ; when a battery is ordered then each test is screened to
67 ; see if the person requesting the battery has access to the tests
68 ; contained in the battery
69 N Y,YSNX,YSXT,Z
70 I 'X Q ""
71 S X(0)=$G(^YTT(601,X,0)),(YSXT,Y)="" I '$D(^YTT(601,X,"A")) Q ""
72 X ^YTT(601,X,"A")
73 F Z=1:1 S YSNX=$P(YSXT,U,Z) Q:YSNX="" D
74 .S YSNX(0)=^YTT(601,YSNX,0) I YSORDP>0,$P(YSNX(0),U,8)'="V",$P(YSNX(0),U,9)="T",$P(YSNX(0),U,10)'="Y",YSORDD>0 W !,YSORD(0)_" is NOT AUTHORIZED to order",!,"the "_$P(YSNX(0),U)_" test from the Battery: '"_$P(X(0),U)_"'.",! Q
75 .I YSORDP=2,$P(YSNX(0),U,8)="V",$P(YSNX(0),U,10)'="Y",YSORDD>1 W !,YSORD(0)_" is NOT AUTHORIZED to order",!,"the "_$P(YSNX(0),U)_" test from the Battery: '"_$P(X(0),U)_"'.",! Q
76 .I $P(YSNX(0),U,13)="N" W !,YSORD(0)_" is NOT AUTHORIZED to order",!,"the "_$P(YSNX(0),U)_" test, from the Battery: '"_$P(X(0),U)_"'.",! Q
77 .I $P(X,U,14)="N" W !," [VACO currently does not have a license to use this test]" Q
78 .S Y=Y_YSNX_U
79 Q Y
80 ;
81ORD ;;all instruments
82 ;;interviews and vocational tests
83 ;;interviews
Note: See TracBrowser for help on using the repository browser.