VistA-WorldVistAEHR/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTTB.m

87 lines
4.3 KiB
Mathematica

YTTB ;SLC/DKG-CREATE/DELETE TEST BATTERIES ; 7/10/89 11:34 ;
;;5.01;MENTAL HEALTH;;Dec 30, 1994
; Called from the top by MENU option YSTESTBAT
;
W @IOF,?IOM-$L("Test/Interview Battery Utility")\2,"Test/Interview Battery Utility",!!
W !?3,"A test battery (e.g., 'BATA') allows administration of a set",!?3,"of tests/interviews by entering just the battery code.",!
OP ;
R !!?3,"(C)reate battery, (D)elete battery, (P)rint list or (Q)uit: Q// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G END:YSTOUT!YSUOUT S A=$TR($E(A_"Q"),"cdpq","CDPQ") G:"Q"=$E(A) END I "CDP"'[A W:A'["?" $C(7)," ?" G OP
G C:"C"[A,D:"D"[A,P:"P"[A
C ;
S YSTANO=$$STANO($G(DUZ(2))) I YSTANO'>0 D QUIT ;->
. W !!!!!,"Batteries cannot be entered because your DUZ(2) is not properly defined!!"
. W !,"Please contact your IRM Service for assistance...",!!
. N DIR
. S DIR(0)="EA",DIR("A")="Hit RETURN to continue... "
. D ^DIR
;
S YSLK=$D(^XUSEC("YSP",DUZ))
R !!?3,"Create battery NAME: ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G END:YSTOUT!YSUOUT,OP:A=""
I $L(A)<3!($L(A)>5)!(A'?.UN) W $C(7),!!?3,"Enter 3 to 5 characters - upper case letters and numbers only",!?3,"(e.g., BATA or BAT1)" G C
I $D(^YTT(601,"B",A)) W $C(7),!!?3,"There is already a test or test battery named ",A," in the package! " G C
S YSK=0,L1="" K N
NB ;
S YSK=YSK+1 W !!?3,"TEST ",YSK,"> " R L:DTIME S YSTOUT='$T,YSUOUT=L["^" G END:YSTOUT!YSUOUT,FB:L=""
I L["?" S YSXT="" D ENTB^YTLIST S YSK=YSK-1 G NB
S L=$E(L,1,5) S N=$O(^YTT(601,"B",L,0)) I 'N W $C(7),!!?3,"No instrument ",L," in the package" S YSK=YSK-1 G NB
S N(0)=$G(^YTT(601,N,0)) I $P(N(0),U,14)="N" W $C(7),!!?3,"Copy righted, non-licensed tests can not be in a test battery! " S YSK=YSK-1 G NB
I $P(N(0),U,9)="B" W $C(7),!!?3,"Batteries may not be included in batteries!" S YSK=YSK-1 G NB
I 'YSLK&($P(N(0),U,8)'["V") W $C(7),!!?3,"You do NOT have the proper security to put this test on a battery!" S YSK=YSK-1 G NB
I $D(N(N)) W !!?3,"Duplicate ignored!",$C(7) S YSK=YSK-1 G NB
NB1 ;
I YSK>4 D G END:YSTOUT!YSUOUT S A1=$TR($E(A1),"yn","YN") G OP:"N"[A1 I "Y"'[A1 W:A1'["?" $C(7)," ?" G NB1
.W $C(7),!!?3,"There are now ",YSK," tests in the battery",!!,"Are you sure you want ",YSK R " tests in one battery? N// ",A1:DTIME S YSTOUT='$T,YSUOUT=A1["^"
S L1=L1_N_U,N(N)="" G NB:YSK<10 W !!,"10 instruments is max!"
FB ;
I $L(L1,U)<3 W !!?3,"No battery created",$C(7) G LB
FB1 ;
; Get next 601 IEN in Station's number range...
F YSDINUM=YSTANO_"000":1:YSTANO_999 Q:'$D(^YTT(601,+YSDINUM))
I YSDINUM>(YSTANO_999) D G YTTB ;->
. W !!,"No MH Instrument (#601) file internal entry numbers available!!"
. W !,"Please contact IRM Service for assistance...",!!
. N DIR
. S DIR(0)="EA",DIR("A")="Hit return to continue... "
. D ^DIR
;
; All OK. Enter test battery...
S DINUM=+YSDINUM
S X=A,DIC="^YTT(601,",DIC(0)="LX",DLAYGO=601,DIC("DR")="20///^S X=""B"";"
D ^DIC
S ^YTT(601,+Y,"A")="S YSXT=YSXT_"_""""_L1_""""
W !!,"BATTERY ",A," created with ",YSK-1," instruments."
H 3
LB ;
K A,A1,DINUM,L,L1,N,X,YSDINUM,YSK,YSLK,YSTANO
G YTTB
;
D ;
R !!?3,"Delete battery: ",A:DTIME
S YSTOUT='$T,YSUOUT=A["^" G END:YSTOUT!YSUOUT,OP:A=""
I A["?" D ENP G D
S X=$O(^YTT(601,"B",A,0))
I 'X W $C(7),!!?3,"No battery with name ",A," on file. " G D
I $P(^YTT(601,X,0),U,9)="B" S DIK="^YTT(601,",DA=X D ^DIK W !!?3,"Battery ",A," deleted! " G D
W !!?3,$C(7),"There is an instrument by that name but it is not a battery!!"
G D
;
STANO(SIEN) ; Pass in station's IEN. Station number returned...
; SIEN = DUZ(2)
N DA,DIC,DIQ,DR,YSDATA,YSTANO
QUIT:$G(SIEN)'>0 "" ;->
S DA=+SIEN,DIC=4,DR=99,DIQ="YSDATA",DIQ(0)="I"
D EN^DIQ1
S YSTANO=+$G(YSDATA(4,+SIEN,99,"I"))
QUIT:YSTANO'>0 "" ;->
QUIT YSTANO
;
P W ! K IOP S %ZIS="Q" D ^%ZIS K %ZIS G:POP END I $D(IO("Q")) K IO("Q") S ZTRTN="ENP^YTTB",ZTDESC="YS PSYCH INST BAT" D ^%ZTLOAD G END
ENP ;
S:'$D(A) A=0 U IO W !! W:A'["?" @IOF W ?28,"CURRENT BATTERIES",!!,"NAME",?6,"INSTRUMENTS ON BATTERY"
S I=0 F N=0:1 S I=$O(^YTT(601,"AI","B",I)) G:'I EP W !,$P(^YTT(601,I,0),U) S X=$P(^YTT(601,I,"A"),"""",2) F J=1:1 S Y=$P(X,U,J) Q:Y="" W ?(J*6),$P(^YTT(601,Y,0),U)
EP ;
I N=0 U IO(0) W $C(7),!!!?3,"No batteries on file!"
Q:A["?" D:IOST?1"C-".E WAIT^YSUTL K A,I,J,N,X,Y D KILL^%ZTLOAD W ! D ^%ZISC G OP:'$G(ZTSK)
END ;
K A,A1,DA,DIK,I,J,K,L,L1,N,T,T1,X,Y,YSK,YSORD,YSLK,Z,ZTSK Q