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
Q
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.",!!
Q
;
TFYN(YSC) ;
I YSC["T"!(YSC["Y") S C="12X"
QUIT ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTCLERK 3777 printed Dec 13, 2024@02:17:08 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 ""
