source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN4.m@ 1608

Last change on this file since 1608 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1YSCEN4 ;ALB/ASF-TEST SEARCH/BY TEAM ;4/3/90 10:30 ;
2 ;;5.01;MENTAL HEALTH;**37**;Dec 30, 1994
3 ;
4 ; Called from the top by MENU option YSCENTESTING
5 ;
6CH ; Called by routine YSCEN41
7 ;
8 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"
9 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
10RD1 ;
11 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
12 D:YSTS1?.E1L.E RDL I '$D(^YTT(601,"B",YSTS1)) W $C(7),!,"NO SUCH TEST/INTERVIEW" G RD1
13 S YSTS=YSTS_YSTS1_"^" G RD1
14RDQ ;
15 S Z=59,YSNX="",I="" W !!?21,"--- LIST OF TESTS ---",!
16L1 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:"")
17 S YSNX=$P(X,U)_$S(X2="*":"*",1:"") S Z=Z+8#64 W:Z=3 ! W ?Z,YSNX G L1
18INT ;
19 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 ---",!
20L2 ;
21 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
22INE ;
23 W ! K I,X,X2,YSNX,Z Q
24RDL ;
25 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)
26 Q
27LP ;
28 R !,"Display (A)ll or (L)ast date: L// ",YSALL:DTIME S YSTOUT='$T,YSUOUT=YSALL["^" G:YSTOUT END
29 S YSR1="YSALL",YSR2="L",YSR3="AL" D ^YSCEN14 G END:YSALL=-1,LP:YSALL="?"
30 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
31LPQ ;
32 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
33 D KILL^%ZTLOAD
34END ;
35 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
36LP1 ;
37 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
38 W @IOF D LABEL S C=0,N8="",Q3=0 F S N8=$O(^UTILITY($J,N8)) Q:N8=""!Q3 D S0
39 D:IOST?1"C-".E WAIT^YSCEN1 Q
40S0 ;
41 S YSDFN=0 F S YSDFN=$O(^UTILITY($J,N8,YSDFN)) Q:'YSDFN D S1
42 Q
43 ;
44S1 ;
45 S C=C+1 W !,$J(C,3)," ",$P(^DPT(YSDFN,0),U),?29," " D LK
46 Q
47 ;
48LK ;
49 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
50 Q
51SEARCH ;
52 I '$D(^YTD(601.2,YSDFN,1,YSET)) W:$X>70 !?30 W " ",$J(YSTST,4)," XXXXXXXX" W:YSALL'?1"A".E "X " Q
53 G SALL:YSALL?1"A".E
54SL ;
55 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
56SALL ;
57 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
58LABEL ;
59 S T5=$S(T6?1N.N:$P(^YSG("SUB",T6,0),U),1:"UNNASSIGNED")
60 W !!!,$$FMTE^XLFDT(DT,"5ZD")," Ward: ",W2," team: ",T5 Q:T6="UN"
61 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
62STAN ;
63 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
64 Q
Note: See TracBrowser for help on using the repository browser.