YTONLY ;ASF/ALB,HIOFO/FT - Restricted Psych Testing Option ;8/7/12 3:41pm
;;5.01;MENTAL HEALTH;**19,37,60,187**;Dec 30, 1994;Build 73
;
;Reference to VADPT APIs supported by DBIA #10061
;Reference to ^%ZIS supported by IA #10086
;Reference to ^XLFDT APIs supported by DBIA #10103
;Reference to ^VA(200 supported by IA #10060
;Reference to ^XLFSTR supported by DBIA #10104
;
MAIN ; main loop
S (YSXT,YSENTRY)=$O(^YTT(601,"B",YSCODE,0))
S YSXTP=1,T1=1,T1(0)=$P(^YTT(601,YSXT,"P"),U,4)
S YSPREV=0
I YSENTRY=""!($P(^YTT(601,YSENTRY,0),U,13)="N") W !,"Instrument "_YSCODE_" not available" H 3 Q
S YSTITLE=$P($G(^YTT(601,YSENTRY,"P")),U)
W @IOF,!,$$CJ^XLFSTR(YSTITLE,79," "),!
D PT G END:$G(YSDFN)<1
D NX,PREV
D OPT1 Q:$D(DIRUT)
D ADMIN:YSOPT="A",PRINT:YSOPT="P",CLERK:YSOPT="C"
;
G MAIN
ADMIN ;
K J
I $D(^YTD(601.4,YSDFN,1,YSENTRY)) G RESTART
S YSOK=1 W !! S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Professional requesting instrument: ",DIC("B")=DUZ D ^DIC K DIC I Y<1 S YSOK=-1 Q
S YSORD=+Y
S YSQ=0 D A31^YTCLERK1 I YSOK<1 D KAR^YTS Q
I YSQ S ZTIO=ION D HOME^%ZIS
S YSTEST=YSENTRY,YSXT=YSENTRY,YSXTP=1
D A4^YTAR
Q
RESTART ;
K DIR S DIR(0)="S^R:Restart "_YSCODE_";D:Delete previous incomplete and administer;Q:Quit"
D ^DIR K DIR
Q:$D(DIRUT)!(Y="Q")
I Y="D" S YSTEST=YSENTRY D KT,ADMIN Q
S YSTEST=YSENTRY
S YTLM=3
I $P($G(^YTT(601,YSTEST,0)),U,16) S YTLM=$P(^(0),U,16)
S X2=$S($P(^YTD(601.4,YSDFN,1,YSTEST,0),U,8):$P(^(0),U,8),1:$P(^(0),U,2))
S X=$$FMDIFF^XLFDT(DT,X2,1)
I X>YTLM W !,"Administration discontinued more than "_YTLM_" days ago -- not restartable" H 2 Q
S YSTEST=YSENTRY
S (B,C)="",J=+$P(^YTD(601.4,YSDFN,1,YSENTRY,0),U,4),C=$P(^(0),U,5),YSORD=$P(^(0),U,7) S:$P(^(0),U,8) YSBEGIN=$P(^(0),U,8)
I $D(^YTD(601.4,YSDFN,1,YSENTRY,"B"))#2 S B=^("B")
S YSRP=$S(J#200=1:"",1:^YTD(601.4,YSDFN,1,YSENTRY,J+198\200)) S:'J J=1
S YSXT=YSTEST_"^" S:$D(^YTD(601.4,YSDFN,1,YSENTRY,"R")) YSXT=YSXT_^("R") S YSXTP=1,YSDEMO="N",YSRESTRT=1
S YSQ=0 D A31^YTCLERK1 I YSOK<1 D KAR^YTS Q
I YSQ S ZTIO=ION D HOME^%ZIS
D A4^YTAR
Q
PRINT ;
S YSXT=""
W !
D DU^YTDP
Q
CLERK ;
S YSCL=1,(YTESTN,YSTESTN)=YSCODE,YSCLERK=14,YSENT=14,YSTEST=YSENTRY,YSNQ=$P(^YTT(601,YSENTRY,0),U,11)
I $D(^YTD(601.4,YSDFN,1,"AC",YSENTRY)) W !!,"Discontinued CLERK test found:" G RESTART^YTCLERK1
I $D(^YTD(601.4,YSDFN)) S DIK="^YTD(601.4,",DA=YSDFN D ^DIK K DIK
S YSOK=1 W !! S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Professional requesting instrument: ",DIC("B")=DUZ D ^DIC K DIC I Y<1 S YSOK=-1 Q
S YSORD=+Y
S YSQ=0 D A31^YTCLERK1 I YSOK<1 D KAR^YTS Q
S (J,YSXTP)=1,(B,C,YSRP)=""
D REY1^YTCLERK
Q
PT ;
D ^YSLRP G:YSDFN<1 END D ENPT^YSUTL
I YSSEX="" W !,"Gender not properly specified. Call IRM" H 3 G MAIN
Q
OPT1 ;admin, clerk, print
W !
K DIR
S DIR(0)="S^A:Administer on-line;C:Clerk entry"
S:YSPREV DIR(0)=DIR(0)_";P:Print"
S DIR("A")=$S(YSPREV:"Administer on-line, Clerk entry or Print",1:"Administer on-line or Clerk entry")
D ^DIR
S YSOPT=Y
K DIR
G MAIN:$D(DIRUT)
Q
NX ;
K A,A1
S %=$H>21549+$H-.1,%Y=%\365.25+141,%=%#365.25\1,YSPTD=%+306#(%Y#4=0+365)#153#61#31+1,YSPTM=%-YSPTD\29+1,Y=%Y_"00"+YSPTM_"00"+YSPTD,YSDT(0)=$$FMTE^XLFDT(Y,"5ZD")
S YSSX=YSSEX,YSBL=" ",YSHDR=$$MASKSSN(YSSSN)_" "_YSNM_YSBL_YSBL_YSBL,YSHDR=$E(YSHDR,1,44)_YSSX_" AGE "_YSAGE,YSHD=DT
S YSHDT=""
I '$D(^YTD(601.2,YSDFN,1,YSENTRY)) K A,A1 Q
S YSNT=0,N2=0 F S N2=$O(^YTD(601.2,YSDFN,1,YSENTRY,1,N2)) Q:'N2 S A(YSCODE,N2)=YSENTRY,YSNT=YSNT+1,A1(YSNT)=YSCODE_U_N2_U_YSENTRY
Q
MASKSSN(YSSSN) ; return only last 4 of SSN
Q "xxx-xx-"_$E(YSSSN,$L(YSSSN)-3,$L(YSSSN))
;
PREV ;
W @IOF,YSHDR
I '$D(A1(1)),'$D(^YTD(601.4,YSDFN,1,YSENTRY,0)),'$D(^YTD(601.4,YSDFN,1,"AC",YSENTRY)) W !!,?10,"No Previous Administrations on File" S YSPREV=0 Q
I $D(^YTD(601.4,YSDFN,1,YSENTRY,0)) W !!,"Incomplete "_YSCODE_" on-line administration found on " S Y=$P(^(0),U,2) X ^DD("DD") W Y Q
I $D(^YTD(601.4,YSDFN,1,"AC",YSENTRY)) W !!,"Incomplete "_YSCODE_" clerk entry found on " S Y=$P(^YTD(601.4,YSDFN,1,14,0),U,2) X ^DD("DD") W Y Q
;
W !!,"Previous Administrations of the",$S(YSTITLE["*":$TR(YSTITLE,"*",""),YSTITLE["-":$TR(YSTITLE,"-",""),1:" "_YSTITLE),!!
F I=1:1 Q:'$D(A1(I)) D
. S YSPREV=I
. S Y=$P(A1(I),U,2)
. X ^DD("DD")
. W:$X>60 !
. W $J(I,3)_" "_Y_" "
Q
KT ;
K J I $D(^YTD(601.4,YSDFN,1,YSTEST)) S YSENTRY=YSTEST D ENKIL^YTFILE
Q
END ;
D KVAR^VADPT
K %,%Y,A,A1,B,C,I,J,N2,T1,X,X2,Y,YSAGE,YSBEGIN,YSBL,YSCL,YSCLERK
K YSCODE,YSDEMO,YSDFN,YSDT,YSENT,YSENTRY,YSHD,YSHDR,YSHDT,YSNM,YSNQ
K YSNT,YSOK,YSOPT,YSORD,YSPREV,YSPTD,YSPTM,YSQ,YSRESTRT,YSRP,YSSEX
K YSSSN,YSSX,YSTEST,YSTESTN,YSTITLE,YSXT,YSXTP,YTESTN,YTLM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTONLY 4763 printed Sep 23, 2025@19:54:02 Page 2
YTONLY ;ASF/ALB,HIOFO/FT - Restricted Psych Testing Option ;8/7/12 3:41pm
+1 ;;5.01;MENTAL HEALTH;**19,37,60,187**;Dec 30, 1994;Build 73
+2 ;
+3 ;Reference to VADPT APIs supported by DBIA #10061
+4 ;Reference to ^%ZIS supported by IA #10086
+5 ;Reference to ^XLFDT APIs supported by DBIA #10103
+6 ;Reference to ^VA(200 supported by IA #10060
+7 ;Reference to ^XLFSTR supported by DBIA #10104
+8 ;
MAIN ; main loop
+1 SET (YSXT,YSENTRY)=$ORDER(^YTT(601,"B",YSCODE,0))
+2 SET YSXTP=1
SET T1=1
SET T1(0)=$PIECE(^YTT(601,YSXT,"P"),U,4)
+3 SET YSPREV=0
+4 IF YSENTRY=""!($PIECE(^YTT(601,YSENTRY,0),U,13)="N")
WRITE !,"Instrument "_YSCODE_" not available"
HANG 3
QUIT
+5 SET YSTITLE=$PIECE($GET(^YTT(601,YSENTRY,"P")),U)
+6 WRITE @IOF,!,$$CJ^XLFSTR(YSTITLE,79," "),!
+7 DO PT
if $GET(YSDFN)<1
GOTO END
+8 DO NX
DO PREV
+9 DO OPT1
if $DATA(DIRUT)
QUIT
+10 if YSOPT="A"
DO ADMIN
if YSOPT="P"
DO PRINT
if YSOPT="C"
DO CLERK
+11 ;
+12 GOTO MAIN
ADMIN ;
+1 KILL J
+2 IF $DATA(^YTD(601.4,YSDFN,1,YSENTRY))
GOTO RESTART
+3 SET YSOK=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<1
SET YSOK=-1
QUIT
+4 SET YSORD=+Y
+5 SET YSQ=0
DO A31^YTCLERK1
IF YSOK<1
DO KAR^YTS
QUIT
+6 IF YSQ
SET ZTIO=ION
DO HOME^%ZIS
+7 SET YSTEST=YSENTRY
SET YSXT=YSENTRY
SET YSXTP=1
+8 DO A4^YTAR
+9 QUIT
RESTART ;
+1 KILL DIR
SET DIR(0)="S^R:Restart "_YSCODE_";D:Delete previous incomplete and administer;Q:Quit"
+2 DO ^DIR
KILL DIR
+3 if $DATA(DIRUT)!(Y="Q")
QUIT
+4 IF Y="D"
SET YSTEST=YSENTRY
DO KT
DO ADMIN
QUIT
+5 SET YSTEST=YSENTRY
+6 SET YTLM=3
+7 IF $PIECE($GET(^YTT(601,YSTEST,0)),U,16)
SET YTLM=$PIECE(^(0),U,16)
+8 SET X2=$SELECT($PIECE(^YTD(601.4,YSDFN,1,YSTEST,0),U,8):$PIECE(^(0),U,8),1:$PIECE(^(0),U,2))
+9 SET X=$$FMDIFF^XLFDT(DT,X2,1)
+10 IF X>YTLM
WRITE !,"Administration discontinued more than "_YTLM_" days ago -- not restartable"
HANG 2
QUIT
+11 SET YSTEST=YSENTRY
+12 SET (B,C)=""
SET J=+$PIECE(^YTD(601.4,YSDFN,1,YSENTRY,0),U,4)
SET C=$PIECE(^(0),U,5)
SET YSORD=$PIECE(^(0),U,7)
if $PIECE(^(0),U,8)
SET YSBEGIN=$PIECE(^(0),U,8)
+13 IF $DATA(^YTD(601.4,YSDFN,1,YSENTRY,"B"))#2
SET B=^("B")
+14 SET YSRP=$SELECT(J#200=1:"",1:^YTD(601.4,YSDFN,1,YSENTRY,J+198\200))
if 'J
SET J=1
+15 SET YSXT=YSTEST_"^"
if $DATA(^YTD(601.4,YSDFN,1,YSENTRY,"R"))
SET YSXT=YSXT_^("R")
SET YSXTP=1
SET YSDEMO="N"
SET YSRESTRT=1
+16 SET YSQ=0
DO A31^YTCLERK1
IF YSOK<1
DO KAR^YTS
QUIT
+17 IF YSQ
SET ZTIO=ION
DO HOME^%ZIS
+18 DO A4^YTAR
+19 QUIT
PRINT ;
+1 SET YSXT=""
+2 WRITE !
+3 DO DU^YTDP
+4 QUIT
CLERK ;
+1 SET YSCL=1
SET (YTESTN,YSTESTN)=YSCODE
SET YSCLERK=14
SET YSENT=14
SET YSTEST=YSENTRY
SET YSNQ=$PIECE(^YTT(601,YSENTRY,0),U,11)
+2 IF $DATA(^YTD(601.4,YSDFN,1,"AC",YSENTRY))
WRITE !!,"Discontinued CLERK test found:"
GOTO RESTART^YTCLERK1
+3 IF $DATA(^YTD(601.4,YSDFN))
SET DIK="^YTD(601.4,"
SET DA=YSDFN
DO ^DIK
KILL DIK
+4 SET YSOK=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<1
SET YSOK=-1
QUIT
+5 SET YSORD=+Y
+6 SET YSQ=0
DO A31^YTCLERK1
IF YSOK<1
DO KAR^YTS
QUIT
+7 SET (J,YSXTP)=1
SET (B,C,YSRP)=""
+8 DO REY1^YTCLERK
+9 QUIT
PT ;
+1 DO ^YSLRP
if YSDFN<1
GOTO END
DO ENPT^YSUTL
+2 IF YSSEX=""
WRITE !,"Gender not properly specified. Call IRM"
HANG 3
GOTO MAIN
+3 QUIT
OPT1 ;admin, clerk, print
+1 WRITE !
+2 KILL DIR
+3 SET DIR(0)="S^A:Administer on-line;C:Clerk entry"
+4 if YSPREV
SET DIR(0)=DIR(0)_";P:Print"
+5 SET DIR("A")=$SELECT(YSPREV:"Administer on-line, Clerk entry or Print",1:"Administer on-line or Clerk entry")
+6 DO ^DIR
+7 SET YSOPT=Y
+8 KILL DIR
+9 if $DATA(DIRUT)
GOTO MAIN
+10 QUIT
NX ;
+1 KILL A,A1
+2 SET %=$HOROLOG>21549+$HOROLOG-.1
SET %Y=%\365.25+141
SET %=%#365.25\1
SET YSPTD=%+306#(%Y#4=0+365)#153#61#31+1
SET YSPTM=%-YSPTD\29+1
SET Y=%Y_"00"+YSPTM_"00"+YSPTD
SET YSDT(0)=$$FMTE^XLFDT(Y,"5ZD")
+3 SET YSSX=YSSEX
SET YSBL=" "
SET YSHDR=$$MASKSSN(YSSSN)_" "_YSNM_YSBL_YSBL_YSBL
SET YSHDR=$EXTRACT(YSHDR,1,44)_YSSX_" AGE "_YSAGE
SET YSHD=DT
+4 SET YSHDT=""
+5 IF '$DATA(^YTD(601.2,YSDFN,1,YSENTRY))
KILL A,A1
QUIT
+6 SET YSNT=0
SET N2=0
FOR
SET N2=$ORDER(^YTD(601.2,YSDFN,1,YSENTRY,1,N2))
if 'N2
QUIT
SET A(YSCODE,N2)=YSENTRY
SET YSNT=YSNT+1
SET A1(YSNT)=YSCODE_U_N2_U_YSENTRY
+7 QUIT
MASKSSN(YSSSN) ; return only last 4 of SSN
+1 QUIT "xxx-xx-"_$EXTRACT(YSSSN,$LENGTH(YSSSN)-3,$LENGTH(YSSSN))
+2 ;
PREV ;
+1 WRITE @IOF,YSHDR
+2 IF '$DATA(A1(1))
IF '$DATA(^YTD(601.4,YSDFN,1,YSENTRY,0))
IF '$DATA(^YTD(601.4,YSDFN,1,"AC",YSENTRY))
WRITE !!,?10,"No Previous Administrations on File"
SET YSPREV=0
QUIT
+3 IF $DATA(^YTD(601.4,YSDFN,1,YSENTRY,0))
WRITE !!,"Incomplete "_YSCODE_" on-line administration found on "
SET Y=$PIECE(^(0),U,2)
XECUTE ^DD("DD")
WRITE Y
QUIT
+4 IF $DATA(^YTD(601.4,YSDFN,1,"AC",YSENTRY))
WRITE !!,"Incomplete "_YSCODE_" clerk entry found on "
SET Y=$PIECE(^YTD(601.4,YSDFN,1,14,0),U,2)
XECUTE ^DD("DD")
WRITE Y
QUIT
+5 ;
+6 WRITE !!,"Previous Administrations of the",$SELECT(YSTITLE["*":$TRANSLATE(YSTITLE,"*",""),YSTITLE["-":$TRANSLATE(YSTITLE,"-",""),1:" "_YSTITLE),!!
+7 FOR I=1:1
if '$DATA(A1(I))
QUIT
Begin DoDot:1
+8 SET YSPREV=I
+9 SET Y=$PIECE(A1(I),U,2)
+10 XECUTE ^DD("DD")
+11 if $X>60
WRITE !
+12 WRITE $JUSTIFY(I,3)_" "_Y_" "
End DoDot:1
+13 QUIT
KT ;
+1 KILL J
IF $DATA(^YTD(601.4,YSDFN,1,YSTEST))
SET YSENTRY=YSTEST
DO ENKIL^YTFILE
+2 QUIT
END ;
+1 DO KVAR^VADPT
+2 KILL %,%Y,A,A1,B,C,I,J,N2,T1,X,X2,Y,YSAGE,YSBEGIN,YSBL,YSCL,YSCLERK
+3 KILL YSCODE,YSDEMO,YSDFN,YSDT,YSENT,YSENTRY,YSHD,YSHDR,YSHDT,YSNM,YSNQ
+4 KILL YSNT,YSOK,YSOPT,YSORD,YSPREV,YSPTD,YSPTM,YSQ,YSRESTRT,YSRP,YSSEX
+5 KILL YSSSN,YSSX,YSTEST,YSTESTN,YSTITLE,YSXT,YSXTP,YTESTN,YTLM
+6 QUIT
