YTAR ;SLC/DKG,SLC/TGA-ADMINISTER & RESUME TESTS ;5/30/02 14:54
;;5.01;MENTAL HEALTH;**37,54,76**;Dec 30, 1994
;
W:YSNT>0 !!?10,"--- Previous Instruments ---",! S B=$S(YSNT<11:YSNT,1:YSNT+1\2)
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
I $D(YSCLERK) G ^YTCLERK
S:'$D(T1) T1=0 I $D(^YTD(601.4,YSDFN,1,"B")) G ^YTAR1
A10 ;
W !!!?2,"Do you want DEMO program administered" S %=2 D YN^DICN G:%<0 KAR^YTS
I '% W !?4,"The DEMO program teaches the patient to use the terminal." G A10
S YSDEMO=$S(%=1:"Y",1:"N")
A11 ;
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
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
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)
G:T1 A3 ;->
W $C(7),!!,$P(^VA(200,YSORD,0),U)," may order ",$P($T(ORD+YSORDP),";",3)
W ", exempt tests, and vocational tests."
A12 ;
S YSXT="" W !!?2,"Administer the following instruments:",!
A2 ;
R !?5,"Instrument: ",YSTESTN:DTIME S YSTOUT='$T,YSUOUT=YSTESTN["^" G KAR^YTS:YSTOUT!YSUOUT,A3:YSTESTN=""
I YSTESTN="CLERK" W !!,"Not a valid instrument, you may want to use the CLERK entry option!",!! G A2
I YSTESTN["?" D ^YTLIST G A2
I $L(YSTESTN)>5!(YSTESTN'?.UNP) W " ?" G A2
I YSTESTN="BECK" D BECK^YTS
I YSTESTN="MMPI" D MMPI^YTS
S YSTEST=$O(^YTT(601,"B",YSTESTN,0)) I 'YSTEST W " [Not Found]" G A2
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
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
;I $P(X,U,13)="N" W !!,YSORD(0)_" is NOT AUTHORIZED to order",!,"Instrument "_$P(YSNX(0),U)_".",!! G A2
I $P(X,U,13)="N" W !!,"You have selected an instrument that is NOT OPERATIONAL.",! G A2
I $P(X,U,14)="N" D CR G A2
F Z=1:1 S YSNX=$P(YSXT,U,Z) Q:YSNX="" I YSNX=YSTEST W " [Duplicate Ignored]",!! G A2
MCMI2 ;
I $P(^YTT(601,YSTEST,0),U)?1"MCMI"1N X ^YTT(601,YSTEST,"C") ;ASF 5/30/02
I $P(X,U,9)="B",YSORDP>0 S YSTEST=$$SCRN(YSTEST) I YSTEST']"" G A2
S YSXT=YSXT_YSTEST_"^" G:$L(YSXT,U)<11 A2
A3 ;
G:YSXT="" KAR^YTS S YSQ=0 I $D(^XUSEC("YSP",DUZ))!$D(^XUSEC("YSZ",DUZ)) D A31^YTCLERK1 G:YSOK<1 KAR^YTS
I YSQ S ZTIO=ION D HOME^%ZIS
D:"Y"[YSDEMO ^YTDEMO S YSXTP=1
A4 ;
S YSTEST=$P(YSXT,U,YSXTP) I YSTEST="" G DONE
D:'$D(YSRESTRT) KT S YS4D=0,YSTESTN=$P(^YTT(601,YSTEST,0),U)
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
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
DONE ;
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)_"^"
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
I DUZ'=YSORD,$D(YSCLERK) S XMB(6)="CLERK-"_YSCLN
E I DUZ'=YSORD F K=6:1 Q:'$D(XMB(K)) S XMB(K)=$P(^YTT(601,+XMB(K),0),U)
I DUZ'=YSORD D ENBUL^YSUTL
G H^XUS:'$D(YSCL)&('$D(YSM)),KAR^YTS
DAT ;
S YSDT=$$FMTE^XLFDT(YSDT,"5ZD") Q
KT ;
K J I $D(^YTD(601.4,YSDFN,1,YSTEST)) S YSENT=YSTEST D ENKIL^YTFILE
Q
CR ;
W " [VACO currently does not have a license to use this test]" Q
MSG1 ;
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."
W !!?2,"Enter (N) for (NO) to NOT send message and to DISCONTINUE this test/",!,"interview process."
Q
SCRN(X) ; when a battery is ordered then each test is screened to
; see if the person requesting the battery has access to the tests
; contained in the battery
N Y,YSNX,YSXT,Z
I 'X Q ""
S X(0)=$G(^YTT(601,X,0)),(YSXT,Y)="" I '$D(^YTT(601,X,"A")) Q ""
X ^YTT(601,X,"A")
F Z=1:1 S YSNX=$P(YSXT,U,Z) Q:YSNX="" D
.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
.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
.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
.I $P(X,U,14)="N" W !," [VACO currently does not have a license to use this test]" Q
.S Y=Y_YSNX_U
Q Y
;
ORD ;;all instruments
;;interviews and vocational tests
;;interviews
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTAR 5106 printed Dec 13, 2024@02:16:55 Page 2
YTAR ;SLC/DKG,SLC/TGA-ADMINISTER & RESUME TESTS ;5/30/02 14:54
+1 ;;5.01;MENTAL HEALTH;**37,54,76**;Dec 30, 1994
+2 ;
+3 if YSNT>0
WRITE !!?10,"--- Previous Instruments ---",!
SET B=$SELECT(YSNT<11:YSNT,1:YSNT+1\2)
+4 FOR K=1:1:B
SET YSDT=$PIECE(A1(K),U,2)
DO DAT
WRITE !?15,$PIECE(A1(K),U),?22,YSDT
IF B'=YSNT
IF $DATA(A1(B+K))
WRITE ?50,$PIECE(A1(B+K),U)
SET YSDT=$PIECE(A1(B+K),U,2)
DO DAT
WRITE ?57,YSDT
+5 IF $DATA(YSCLERK)
GOTO ^YTCLERK
+6 if '$DATA(T1)
SET T1=0
IF $DATA(^YTD(601.4,YSDFN,1,"B"))
GOTO ^YTAR1
A10 ;
+1 WRITE !!!?2,"Do you want DEMO program administered"
SET %=2
DO YN^DICN
if %<0
GOTO KAR^YTS
+2 IF '%
WRITE !?4,"The DEMO program teaches the patient to use the terminal."
GOTO A10
+3 SET YSDEMO=$SELECT(%=1:"Y",1:"N")
A11 ;
+1 WRITE !!
SET DIC="^VA(200,"
SET DIC(0)="AEQM"
SET DIC("A")="Professional requesting instrument: "
SET DIC("B")=DUZ
DO ^DIC
KILL DIC
IF Y'>0
GOTO KAR^YTS
+2 IF DUZ'=+Y
WRITE !!?2,"A message will be sent to ",$PIECE(^VA(200,+Y,0),U)
READ " OK? Y// ",A:DTIME
SET YSTOUT='$TEST
SET YSUOUT=A["^"
if YSTOUT!YSUOUT!(A["N")!(A["n")
GOTO KAR^YTS
if A=""
SET A="Y"
IF "Yy"'[$EXTRACT(A)
if A'["?"
WRITE " ?",$CHAR(7)
DO MSG1
GOTO A11
+3 SET YSORD=+Y
SET YSORD(0)=$PIECE(Y,U,2)
SET YSORDP=$SELECT($DATA(^XUSEC("YSP",YSORD)):0,1:2)
IF YSORDP>0
SET YSORDD=$SELECT($DATA(^XUSEC("YSP",DUZ)):0,1:2)
+4 ;->
if T1
GOTO A3
+5 WRITE $CHAR(7),!!,$PIECE(^VA(200,YSORD,0),U)," may order ",$PIECE($TEXT(ORD+YSORDP),";",3)
+6 WRITE ", exempt tests, and vocational tests."
A12 ;
+1 SET YSXT=""
WRITE !!?2,"Administer the following instruments:",!
A2 ;
+1 READ !?5,"Instrument: ",YSTESTN:DTIME
SET YSTOUT='$TEST
SET YSUOUT=YSTESTN["^"
if YSTOUT!YSUOUT
GOTO KAR^YTS
if YSTESTN=""
GOTO A3
+2 IF YSTESTN="CLERK"
WRITE !!,"Not a valid instrument, you may want to use the CLERK entry option!",!!
GOTO A2
+3 IF YSTESTN["?"
DO ^YTLIST
GOTO A2
+4 IF $LENGTH(YSTESTN)>5!(YSTESTN'?.UNP)
WRITE " ?"
GOTO A2
+5 IF YSTESTN="BECK"
DO BECK^YTS
+6 IF YSTESTN="MMPI"
DO MMPI^YTS
+7 SET YSTEST=$ORDER(^YTT(601,"B",YSTESTN,0))
IF 'YSTEST
WRITE " [Not Found]"
GOTO A2
+8 SET X=^YTT(601,YSTEST,0)
SET YSNX(0)=X
IF YSORDP>0
IF $PIECE(X,U,8)'="V"
IF $PIECE(X,U,9)="T"
IF $PIECE(X,U,10)'="Y"
IF YSORDD>0
WRITE !!,YSORD(0)_" is NOT AUTHORIZED to order",!,"Instrument "_$PIECE(YSNX(0),U)_".",!!
GOTO A2
+9 IF YSORDP=2
IF $PIECE(X,U,8)="V"
IF $PIECE(X,U,10)'="Y"
IF YSORDD>1
WRITE !!,YSORD(0)_" is NOT AUTHORIZED to order",!,"Instrument "_$PIECE(YSNX(0),U)_".",!!
GOTO A2
+10 ;I $P(X,U,13)="N" W !!,YSORD(0)_" is NOT AUTHORIZED to order",!,"Instrument "_$P(YSNX(0),U)_".",!! G A2
+11 IF $PIECE(X,U,13)="N"
WRITE !!,"You have selected an instrument that is NOT OPERATIONAL.",!
GOTO A2
+12 IF $PIECE(X,U,14)="N"
DO CR
GOTO A2
+13 FOR Z=1:1
SET YSNX=$PIECE(YSXT,U,Z)
if YSNX=""
QUIT
IF YSNX=YSTEST
WRITE " [Duplicate Ignored]",!!
GOTO A2
MCMI2 ;
+1 ;ASF 5/30/02
IF $PIECE(^YTT(601,YSTEST,0),U)?1"MCMI"1N
XECUTE ^YTT(601,YSTEST,"C")
+2 IF $PIECE(X,U,9)="B"
IF YSORDP>0
SET YSTEST=$$SCRN(YSTEST)
IF YSTEST']""
GOTO A2
+3 SET YSXT=YSXT_YSTEST_"^"
if $LENGTH(YSXT,U)<11
GOTO A2
A3 ;
+1 if YSXT=""
GOTO KAR^YTS
SET YSQ=0
IF $DATA(^XUSEC("YSP",DUZ))!$DATA(^XUSEC("YSZ",DUZ))
DO A31^YTCLERK1
if YSOK<1
GOTO KAR^YTS
+2 IF YSQ
SET ZTIO=ION
DO HOME^%ZIS
+3 if "Y"[YSDEMO
DO ^YTDEMO
SET YSXTP=1
A4 ;
+1 SET YSTEST=$PIECE(YSXT,U,YSXTP)
IF YSTEST=""
GOTO DONE
+2 if '$DATA(YSRESTRT)
DO KT
SET YS4D=0
SET YSTESTN=$PIECE(^YTT(601,YSTEST,0),U)
+3 ;ASF 5/30/02
IF $DATA(^YTT(601,YSTEST,"C"))
IF $PIECE(^YTT(601,YSTEST,0),U)'?1"MCMI"1N
XECUTE ^("C")
IF $DATA(J)
IF J<1
GOTO KAR^YTS
+4 XECUTE ^YTT(601,YSTEST,"A")
if $DATA(YSTIN)
GOTO KAR^YTS
DO KT
KILL YSRESTRT
SET XMB(YSXTP+5)=$PIECE(YSXT,U,YSXTP)
SET YSXTP=YSXTP+1
GOTO A4
DONE ;
+1 if '$DATA(YSCL)
WRITE @IOF,!!!?10,"*** Thank you for completing the test! ***",!!!
HANG 5
SET XMB(5)=""
IF YSQ
SET YSXT=""
FOR K=6:1
if '$DATA(XMB(K))
QUIT
SET YSXT=YSXT_YSHD_","_XMB(K)_"^"
+2 IF YSQ
SET YSXTP=1
SET ZTRTN="RP1^YTDP"
SET ZTSAVE("YS*")=""
SET ZTDTH=$HOROLOG
SET ZTDESC="YS MH INST PRINT"
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Your Task Number is "_ZTSK
+3 IF DUZ'=YSORD
IF $DATA(YSCLERK)
SET XMB(6)="CLERK-"_YSCLN
+4 IF '$TEST
IF DUZ'=YSORD
FOR K=6:1
if '$DATA(XMB(K))
QUIT
SET XMB(K)=$PIECE(^YTT(601,+XMB(K),0),U)
+5 IF DUZ'=YSORD
DO ENBUL^YSUTL
+6 if '$DATA(YSCL)&('$DATA(YSM))
GOTO H^XUS
GOTO KAR^YTS
DAT ;
+1 SET YSDT=$$FMTE^XLFDT(YSDT,"5ZD")
QUIT
KT ;
+1 KILL J
IF $DATA(^YTD(601.4,YSDFN,1,YSTEST))
SET YSENT=YSTEST
DO ENKIL^YTFILE
+2 QUIT
CR ;
+1 WRITE " [VACO currently does not have a license to use this test]"
QUIT
MSG1 ;
+1 WRITE !!!?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."
+2 WRITE !!?2,"Enter (N) for (NO) to NOT send message and to DISCONTINUE this test/",!,"interview process."
+3 QUIT
SCRN(X) ; when a battery is ordered then each test is screened to
+1 ; see if the person requesting the battery has access to the tests
+2 ; contained in the battery
+3 NEW Y,YSNX,YSXT,Z
+4 IF 'X
QUIT ""
+5 SET X(0)=$GET(^YTT(601,X,0))
SET (YSXT,Y)=""
IF '$DATA(^YTT(601,X,"A"))
QUIT ""
+6 XECUTE ^YTT(601,X,"A")
+7 FOR Z=1:1
SET YSNX=$PIECE(YSXT,U,Z)
if YSNX=""
QUIT
Begin DoDot:1
+8 SET YSNX(0)=^YTT(601,YSNX,0)
IF YSORDP>0
IF $PIECE(YSNX(0),U,8)'="V"
IF $PIECE(YSNX(0),U,9)="T"
IF $PIECE(YSNX(0),U,10)'="Y"
IF YSORDD>0
WRITE !,YSORD(0)_" is NOT AUTHORIZED to order",!,"the "_$PIECE(YSNX(0),U)_" test from the Battery: '"_$PIECE(X(0),U)_"'.",!
QUIT
+9 IF YSORDP=2
IF $PIECE(YSNX(0),U,8)="V"
IF $PIECE(YSNX(0),U,10)'="Y"
IF YSORDD>1
WRITE !,YSORD(0)_" is NOT AUTHORIZED to order",!,"the "_$PIECE(YSNX(0),U)_" test from the Battery: '"_$PIECE(X(0),U)_"'.",!
QUIT
+10 IF $PIECE(YSNX(0),U,13)="N"
WRITE !,YSORD(0)_" is NOT AUTHORIZED to order",!,"the "_$PIECE(YSNX(0),U)_" test, from the Battery: '"_$PIECE(X(0),U)_"'.",!
QUIT
+11 IF $PIECE(X,U,14)="N"
WRITE !," [VACO currently does not have a license to use this test]"
QUIT
+12 SET Y=Y_YSNX_U
End DoDot:1
+13 QUIT Y
+14 ;
ORD ;;all instruments
+1 ;;interviews and vocational tests
+2 ;;interviews
