YTONLY.m

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 ---YTONLY   4763     printed  Mar 13, 2025@21:22:47                                                                                                                                                                                                      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