- 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 Feb 18, 2025@23:43:12 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