Routine: YTCLERK

YTCLERK ;SLC/DKG,SLC/BB-FAST CLERICAL ENTRY; ;5/30/02  15:04

 ;;5.01;MENTAL HEALTH;**19,76**;Dec 30, 1994

 S YSCL=1 I $D(^YTD(601.4,YSDFN,1,"AC")) S YSTEST=$O(^("AC",0)),YSENT=$O(^(YSTEST,0)) W !!,"Discontinued CLERK test found:" G RESTART^YTCLERK1

1 ;

 D A11 I YSOK<1 G KAR^YTS

2 ;

 R !!?3,"Clerk Test: ",YSTESTN:DTIME S YSTOUT='$T,YSUOUT=YSTESTN["^" I YSTOUT!YSUOUT G KAR^YTS

 S:YSTESTN["?" YSXT="CLERK^" S:YSTESTN'="?" YSXT=YSTESTN G KAR^YTS:"^"[YSTESTN

 I YSTESTN["?" D ^YTLIST W !!,"Enter one of the above listed instruments.",!,"Questions will NOT be asked.  Responses only are required.",! K YSXT,YSTESTN G 2

 I YSTESTN?.PC D ^YTLIST K YSXT,YSTESTN G 2

RE ;

 I '$D(^YTT(601,"B",YSTESTN)) W "  [Not Found]" G 2

 S YSTEST=$O(^YTT(601,"B",YSTESTN,0)) S YSCLERK=14

 S X=^YTT(601,YSTEST,0) I $P(X,U,9)="I" W $C(7),"  [INTERVIEWS may not be CLERK entered!]" G 2

 I $P(X,U,2)="I"!'(+$P(X,U,11)) W "  [Not a CLERK Test]",$C(7) G 2

 I $P(X,U,13)="N" W $C(7),"  [Not Available]" G 2

 I YSTESTN?1"MCMI"1N S YSNQ=$P(^YTT(601,YSTEST,"Q",0),U,3) ;ASF 5/30/02

 E  S YSNQ=$P(X,U,11)

 S (J,YSXTP)=1,(B,C,YSRP)=""

 I YSTESTN="MMPR" D REMMPR^YTCLERK1 I $D(YSTIN) G KAR^YTS

REY ;

 S YSQ=0 D:$D(^XUSEC("YSZ",DUZ))!$D(^XUSEC("YSP",DUZ)) A31^YTCLERK1 G KAR^YTS:YSOK<1

REY1 ;

 W ! S %DT("A")="   Date test was administered to patient: ",%DT="AEXQ",%DT(0)="-NOW" D ^%DT G:Y<1 KAR^YTS

 S YSDTA=Y K %DT

 I $D(^YTD(601.4,YSDFN,1,"B",YSCLERK)) W !,"There is a clerk test underway on this patient now",!,"Try again later." G KAR^YTS

 D EN40^YTFILE S ^YTD(601.4,YSDFN,1,YSENT,0)=YSENT,^YTD(601.4,YSDFN,1,"B",YSENT,YSENT)="" L  S YSCL=YSTEST,YSCLN=YSTESTN

ENX ;

 I $D(^YTT(601,YSTEST,"C")) X ^("C") G:J<1 ^YTAR2

 W ! D Q1

NX ;

 I $D(^YTT(601,YSTEST,"Q",J,0)) S X1=^(0) S:$P(X1,U,2)]"" C=$P(X1,U,2) S:$P(X1,U,3)]"" C=$P(X1,U,3)

 I $D(^YTT(601,YSTEST,"Q",J,"B")) S B=^("B") S B1=$S(B?1"W ".PN1"ANSWER".E:0,1:1)

D1 ;

 W:$X>68 ! W $J(J,5),": "

D14 ;

 D RD G D14X:C[X,BK:X="^",CONT:X="*" W:X'="?" " ? " D:$D(X1) Q G D1

D14X ;

 S YSRP=YSRP_X D:J#200=0 WD S J=J+1 I J'>YSNQ G NX

 S J=J+199 I $P(^YTT(601,YSTEST,0),U)?1"MCMI"1N,$D(YSMCMI2P),$D(YSMCMI2L) S YSRP=YSRP_YSMCMI2P_YSMCMI2L ;ASF 5/30/02

 D WD,^YTFILE S XMB(6)=YSTEST,YSXT=YSTEST G DONE^YTAR

RD ;

 R *X:120 S X=$S('$T:"*",X>31&(X<97):$C(X),1:" ") Q

WD ;

 L +^YTD(601.4,YSDFN) S ^YTD(601.4,YSDFN,1,YSENT,J\200)=YSRP I $P(^YTT(601,YSTEST,0),U)="MMPI",$D(YSTF) S X(J\200)=YSRP I J\200=3 D WD1,^YTMMP7 F H=2,3 S ^YTD(601.4,YSDFN,1,YSENT,H)=X(H)

 L -^YTD(601.4,YSDFN) S YSRP="" Q

WD1 ;

 ; 3/10/94 LJA Commented...  F H=1:1:3 S ^YTD(601.4,YSDFN,1,YSENT,H+3)=X(H)

 S ^YTD(601.4,YSDFN,1,YSENT,99)="MMPIR" Q

BK ;

 G D1:J=1,BK1:$L(YSRP)>1,BK2:$L(YSRP)=1,BK3

BK1 ;

 S YSRP=$E(YSRP,1,$L(YSRP)-1),J=J-1 G NX

BK2 ;

 S YSRP="",J=J-1 G NX

BK3 ;

 S J=J-1,YSRP=$E(^YTD(601.4,YSDFN,1,YSCLERK,J\200),1,199) G NX

CONT ;

 S YSTEST=YSCLERK G ^YTAR2

A11 ;

 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

 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["^" I YSTOUT!YSUOUT S YSOK=-1 Q

 I DUZ'=+Y,"Yy"'[$E(A) W !!?2,"The requesting professional must be informed!" G A11

 S YSORD=+Y,YSORDP=$S($D(^XUSEC("YSP",YSORD)):0,1:2) W !!?2,$P(^VA(200,YSORD,0),U)," may order ",$P($T(ORD+YSORDP),";",3) S:YSORDP=2 YSOK=0

ORD ;;all instruments

 ;;interviews and vocational tests

 ;;only interviews

Q I $P(X1,U,3)]""!('B1) W !!,"Valid responses are: " F I=1:1:$L(C)-1 W $E(C,I),", "

 I  W "and X (missing response)" G Q1

 E  D Q1 X B W !! Q

Q1 ;

 W !!,"Press * to stop, press ^ to back up.",!!

TFYN(YSC) ;

 I YSC["T"!(YSC["Y") S C="12X"

 QUIT ""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTCLERK   3777     printed  Apr 23, 2025@18:31:32                                                                                                                                                                                                     Page 2

YTCLERK   ;SLC/DKG,SLC/BB-FAST CLERICAL ENTRY; ;5/30/02  15:04

 +1       ;;5.01;MENTAL HEALTH;**19,76**;Dec 30, 1994

 +2       ;

 +3        SET YSCL=1

           IF $DATA(^YTD(601.4,YSDFN,1,"AC"))

               SET YSTEST=$ORDER(^("AC",0))

               SET YSENT=$ORDER(^(YSTEST,0))

               WRITE !!,"Discontinued CLERK test found:"

               GOTO RESTART^YTCLERK1

1         ;

 +1        DO A11

           IF YSOK<1

               GOTO KAR^YTS

2         ;

 +1        READ !!?3,"Clerk Test: ",YSTESTN:DTIME

           SET YSTOUT='$TEST

           SET YSUOUT=YSTESTN["^"

           IF YSTOUT!YSUOUT

               GOTO KAR^YTS

 +2        if YSTESTN["?"

               SET YSXT="CLERK^"

           if YSTESTN'="?"

               SET YSXT=YSTESTN

           if "^"[YSTESTN

               GOTO KAR^YTS

 +3        IF YSTESTN["?"

               DO ^YTLIST

               WRITE !!,"Enter one of the above listed instruments.",!,"Questions will NOT be asked.  Responses only are required.",!

               KILL YSXT,YSTESTN

               GOTO 2

 +4        IF YSTESTN?.PC

               DO ^YTLIST

               KILL YSXT,YSTESTN

               GOTO 2

RE        ;

 +1        IF '$DATA(^YTT(601,"B",YSTESTN))

               WRITE "  [Not Found]"

               GOTO 2

 +2        SET YSTEST=$ORDER(^YTT(601,"B",YSTESTN,0))

           SET YSCLERK=14

 +3        SET X=^YTT(601,YSTEST,0)

           IF $PIECE(X,U,9)="I"

               WRITE $CHAR(7),"  [INTERVIEWS may not be CLERK entered!]"

               GOTO 2

 +4        IF $PIECE(X,U,2)="I"!'(+$PIECE(X,U,11))

               WRITE "  [Not a CLERK Test]",$CHAR(7)

               GOTO 2

 +5        IF $PIECE(X,U,13)="N"

               WRITE $CHAR(7),"  [Not Available]"

               GOTO 2

 +6       ;ASF 5/30/02

           IF YSTESTN?1"MCMI"1N

               SET YSNQ=$PIECE(^YTT(601,YSTEST,"Q",0),U,3)

 +7       IF '$TEST

               SET YSNQ=$PIECE(X,U,11)

 +8        SET (J,YSXTP)=1

           SET (B,C,YSRP)=""

 +9        IF YSTESTN="MMPR"

               DO REMMPR^YTCLERK1

               IF $DATA(YSTIN)

                   GOTO KAR^YTS

REY       ;

 +1        SET YSQ=0

           if $DATA(^XUSEC("YSZ",DUZ))!$DATA(^XUSEC("YSP",DUZ))

               DO A31^YTCLERK1

           if YSOK<1

               GOTO KAR^YTS

REY1      ;

 +1        WRITE !

           SET %DT("A")="   Date test was administered to patient: "

           SET %DT="AEXQ"

           SET %DT(0)="-NOW"

           DO ^%DT

           if Y<1

               GOTO KAR^YTS

 +2        SET YSDTA=Y

           KILL %DT

 +3        IF $DATA(^YTD(601.4,YSDFN,1,"B",YSCLERK))

               WRITE !,"There is a clerk test underway on this patient now",!,"Try again later."

               GOTO KAR^YTS

 +4        DO EN40^YTFILE

           SET ^YTD(601.4,YSDFN,1,YSENT,0)=YSENT

           SET ^YTD(601.4,YSDFN,1,"B",YSENT,YSENT)=""

           LOCK

           SET YSCL=YSTEST

           SET YSCLN=YSTESTN

ENX       ;

 +1        IF $DATA(^YTT(601,YSTEST,"C"))

               XECUTE ^("C")

               if J<1

                   GOTO ^YTAR2

 +2        WRITE !

           DO Q1

NX        ;

 +1        IF $DATA(^YTT(601,YSTEST,"Q",J,0))

               SET X1=^(0)

               if $PIECE(X1,U,2)]""

                   SET C=$PIECE(X1,U,2)

               if $PIECE(X1,U,3)]""

                   SET C=$PIECE(X1,U,3)

 +2        IF $DATA(^YTT(601,YSTEST,"Q",J,"B"))

               SET B=^("B")

               SET B1=$SELECT(B?1"W ".PN1"ANSWER".E:0,1:1)

D1        ;

 +1        if $X>68

               WRITE !

           WRITE $JUSTIFY(J,5),": "

D14       ;

 +1        DO RD

           if C[X

               GOTO D14X

           if X="^"

               GOTO BK

           if X="*"

               GOTO CONT

           if X'="?"

               WRITE " ? "

           if $DATA(X1)

               DO Q

           GOTO D1

D14X      ;

 +1        SET YSRP=YSRP_X

           if J#200=0

               DO WD

           SET J=J+1

           IF J'>YSNQ

               GOTO NX

 +2       ;ASF 5/30/02

           SET J=J+199

           IF $PIECE(^YTT(601,YSTEST,0),U)?1"MCMI"1N

               IF $DATA(YSMCMI2P)

                   IF $DATA(YSMCMI2L)

                       SET YSRP=YSRP_YSMCMI2P_YSMCMI2L

 +3        DO WD

           DO ^YTFILE

           SET XMB(6)=YSTEST

           SET YSXT=YSTEST

           GOTO DONE^YTAR

RD        ;

 +1        READ *X:120

           SET X=$SELECT('$TEST:"*",X>31&(X<97):$CHAR(X),1:" ")

           QUIT

WD        ;

 +1        LOCK +^YTD(601.4,YSDFN)

           SET ^YTD(601.4,YSDFN,1,YSENT,J\200)=YSRP

           IF $PIECE(^YTT(601,YSTEST,0),U)="MMPI"

               IF $DATA(YSTF)

                   SET X(J\200)=YSRP

                   IF J\200=3

                       DO WD1

                       DO ^YTMMP7

                       FOR H=2,3

                           SET ^YTD(601.4,YSDFN,1,YSENT,H)=X(H)

 +2        LOCK -^YTD(601.4,YSDFN)

           SET YSRP=""

           QUIT

WD1       ;

 +1       ; 3/10/94 LJA Commented...  F H=1:1:3 S ^YTD(601.4,YSDFN,1,YSENT,H+3)=X(H)

 +2        SET ^YTD(601.4,YSDFN,1,YSENT,99)="MMPIR"

           QUIT

BK        ;

 +1        if J=1

               GOTO D1

           if $LENGTH(YSRP)>1

               GOTO BK1

           if $LENGTH(YSRP)=1

               GOTO BK2

           GOTO BK3

BK1       ;

 +1        SET YSRP=$EXTRACT(YSRP,1,$LENGTH(YSRP)-1)

           SET J=J-1

           GOTO NX

BK2       ;

 +1        SET YSRP=""

           SET J=J-1

           GOTO NX

BK3       ;

 +1        SET J=J-1

           SET YSRP=$EXTRACT(^YTD(601.4,YSDFN,1,YSCLERK,J\200),1,199)

           GOTO NX

CONT      ;

 +1        SET YSTEST=YSCLERK

           GOTO ^YTAR2

A11       ;

 +1        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

 +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

                   SET YSOK=-1

                   QUIT

 +3        IF DUZ'=+Y

               IF "Yy"'[$EXTRACT(A)

                   WRITE !!?2,"The requesting professional must be informed!"

                   GOTO A11

 +4        SET YSORD=+Y

           SET YSORDP=$SELECT($DATA(^XUSEC("YSP",YSORD)):0,1:2)

           WRITE !!?2,$PIECE(^VA(200,YSORD,0),U)," may order ",$PIECE($TEXT(ORD+YSORDP),";",3)

           if YSORDP=2

               SET YSOK=0

 +5        QUIT

ORD       ;;all instruments

 +1       ;;interviews and vocational tests

 +2       ;;only interviews

Q          IF $PIECE(X1,U,3)]""!('B1)

               WRITE !!,"Valid responses are: "

               FOR I=1:1:$LENGTH(C)-1

                   WRITE $EXTRACT(C,I),", "

 +1       IF $TEST

               WRITE "and X (missing response)"

               GOTO Q1

 +2       IF '$TEST

               DO Q1

               XECUTE B

               WRITE !!

               QUIT

Q1        ;

 +1        WRITE !!,"Press * to stop, press ^ to back up.",!!

 +2        QUIT

 +3       ;

TFYN(YSC) ;

 +1        IF YSC["T"!(YSC["Y")

               SET C="12X"

 +2        QUIT ""

YTCLERK.m