source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN4.m@ 1800

YSCEN4 ;ALB/ASF-TEST SEARCH/BY TEAM ;4/3/90  10:30 ;
 ;;5.01;MENTAL HEALTH;**37**;Dec 30, 1994
 ;
 ; Called from the top by MENU option YSCENTESTING
 ;
CH ;  Called by routine YSCEN41
 ;
 S YSTS="" R !,"(A)ll tests,(R)ecent tests",!,"(C)ustom battery,(S)tandard battery or (H)elp? S// ",L:DTIME S YSTOUT='$T,YSUOUT=L["^" G:YSTOUT!YSUOUT END S:L?1"?".E L="H"
 S L=$E(L),L=$TR(L,"arcsh","ARCSH") G CH:"ARCSH"'[L S L=$S(L="A":"ENALLT^YSCEN3",L="C":"RD1",L="R":"ENTLST^YSCEN3",L="H":"INS^YSCEN41",1:"LP") G @L
RD1 ;
 R !," Test/interview for search : ",YSTS1:DTIME S YSTOUT='$T,YSUOUT=YSTS1["^" G:YSTOUT!YSUOUT END G LP:YSTS1="" I YSTS1["?" D RDQ G RD1
 D:YSTS1?.E1L.E RDL I '$D(^YTT(601,"B",YSTS1)) W $C(7),!,"NO SUCH TEST/INTERVIEW" G RD1
 S YSTS=YSTS_YSTS1_"^" G RD1
RDQ ;
 S Z=59,YSNX="",I="" W !!?21,"--- LIST OF TESTS ---",!
L1 S I=$O(^YTT(601,"AI","T",I)) G:'I INT S X=^YTT(601,I,0) G:$P(X,U,13)="N" L1 S X2=$P(X,U,14),X2=$S(X2="N":"*",1:"")
 S YSNX=$P(X,U)_$S(X2="*":"*",1:"") S Z=Z+8#64 W:Z=3 ! W ?Z,YSNX G L1
INT ;
 S I=0,Z=59,YSLFT=0,IOP=0 D ^%ZIS K IOP D:IOST?1"C-".E WAIT^YSUTL G:YSLFT INE W !!?19,"--- LIST OF INTERVIEWS ---",!
L2 ;
 S I=$O(^YTT(601,"AI","I",I)) I I S X=^YTT(601,I,0) G:$P(X,U,13)="N" L2 S Z=Z+8#64 W:Z=3 ! W ?Z,$P(^(0),U) G L2
INE ;
 W ! K I,X,X2,YSNX,Z Q
RDL ;
 F ZZ=1:1:$L(YSTS1) I $E(YSTS1,ZZ)?1L S D=$E(YSTS1,ZZ),D=$A(D)-32,YSTS1=$E(YSTS1,0,ZZ-1)_$C(D)_$E(YSTS1,ZZ+1,30)
 Q
LP ;
 R !,"Display (A)ll or (L)ast date: L// ",YSALL:DTIME S YSTOUT='$T,YSUOUT=YSALL["^" G:YSTOUT END
 S YSR1="YSALL",YSR2="L",YSR3="AL" D ^YSCEN14 G END:YSALL=-1,LP:YSALL="?"
 W ! D AX^YSCEN3 G:Y<1!(POP) END I $D(IO("Q")) K IO("Q") S ZTRTN="LPQ^YSCEN4",ZTDESC="YS IP TT",(ZTSAVE("T6"),ZTSAVE("W1"),ZTSAVE("W2"),ZTSAVE("YSALL"),ZTSAVE("YSTS"))="" D ^%ZTLOAD W !,$S($D(ZTSK):"QUEUED",1:"Not queued"),$C(7) G END
LPQ ;
 U IO S P1=0,YSOPT2="LP1^YSCEN4",YSOPT1L="PSYCHOLOGICAL TESTS & INTERVIEWS" D FS0^YSCEN D:T6'="A" L2^YSCEN2 D:T6="A" L1^YSCEN2
 D KILL^%ZTLOAD
END ;
 K ZTSK,^UTILITY($J),YSOPT2,YSOPT1,Z,S,T6,T5,W1,W2,C1,DIC,DIK,YSALL,C,YSDATE,YSDAY,YSDFN,I,L,N,N8,P1,S,YSTS,YSTS1,YSTST,Z4,DIYS,Q3,R,W4,X,X1,Y,YSET,YSTM,YSTY,YSLFT D ^%ZISC Q
LP1 ;
 D:YSTS="" STAN I YSTS="" W:T6?1N.N !!,$C(7),"NO STANDARD BATTERY DEFINED FOR ",$P(^YSG("SUB",T6,0),U) H 1 Q
 W @IOF D LABEL S C=0,N8="",Q3=0 F  S N8=$O(^UTILITY($J,N8)) Q:N8=""!Q3  D S0
 D:IOST?1"C-".E WAIT^YSCEN1 Q
S0 ;
 S YSDFN=0 F  S YSDFN=$O(^UTILITY($J,N8,YSDFN)) Q:'YSDFN  D S1
 Q
 ;
S1 ;
 S C=C+1 W !,$J(C,3)," ",$P(^DPT(YSDFN,0),U),?29," " D LK
 Q
 ;
LK ;
 F ZZ=1:1 Q:$P(YSTS,U,ZZ)=""  S YSDAY=0,N=0,YSTST=$P(YSTS,U,ZZ),YSET=$O(^YTT(601,"B",YSTST,0)) D SEARCH
 Q
SEARCH ;
 I '$D(^YTD(601.2,YSDFN,1,YSET)) W:$X>70 !?30 W " ",$J(YSTST,4)," XXXXXXXX" W:YSALL'?1"A".E "X " Q
 G SALL:YSALL?1"A".E
SL ;
 S YSDAY=$O(^YTD(601.2,YSDFN,1,YSET,1,YSDAY)) S:YSDAY YSDATE=YSDAY,N=N+1 W:$X>70 !?30 W:YSDAY<1 " ",$J(YSTST,4)," ",$$FMTE^XLFDT(YSDATE,"5ZD"),$C(N+96)," " G SL:YSDAY>1 Q
SALL ;
 S YSDAY=$O(^YTD(601.2,YSDFN,1,YSET,1,YSDAY)) Q:'YSDAY  S YSDATE=YSDAY W:$X>70 !?30 W " ",$J(YSTST,4)," ",$$FMTE^XLFDT(YSDATE,"5ZD") G SALL
LABEL ;
 S T5=$S(T6?1N.N:$P(^YSG("SUB",T6,0),U),1:"UNNASSIGNED")
 W !!!,$$FMTE^XLFDT(DT,"5ZD")," Ward: ",W2,"  team: ",T5 Q:T6="UN"
 S Z4=^YSG("SUB",T6,0) W:$P(Z4,U,2)]"" !,"PHYSICIAN: ",$P(^VA(200,$P(Z4,U,2),0),U) W:$P(Z4,U,3)]"" ?45,"PSYCHOLOGIST: ",$P(^VA(200,$P(Z4,U,3),0),U) Q
STAN ;
 S YSTS="",YSTY="",Z=0 F  S Z=$O(^YSG("SUB",T6,"TEST",Z)) Q:'Z  S YSTS1=$P(^(Z,0),U),YSTS=YSTS_YSTS1_U
 Q