source: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN3.m@ 636

YSCEN3 ;ALB/ASF-MH CENSUS LOOKUPS BY UNIT ;3/30/90  14:29 ;11/18/93 08:44
 ;;5.01;MENTAL HEALTH;**3**;Dec 30, 1994
 ;
ENPROB ; Called from MENU option YSCENPROB
 ;
 K YSOPT1,YSOPT2 D A Q:Y<1!(POP)  I $D(IO("Q")) S ZTRTN="PROBQ^YSCEN3" D OUT G END
PROBQ ;
 D FS U IO W @IOF S P1=1,YSOPT1="PROB^YSCEN3",YSOPT1L="Short Problem Lists",YSLFT=0 K ^UTILITY($J) D:T6'="A" L2^YSCEN2,L3^YSCEN2 D:T6="A" L1^YSCEN2 G END
 ;
ENCN ; Called from MENU option YSCENCRISIS
 ;
 K YSOPT1,YSOPT2 D LDT G:Y<1 END D A G:Y<1!(POP) END I $D(IO("Q")) S ZTRTN="CNQ^YSCEN3" D OUT G END
CNQ ;
 U IO D FS S (P,P1,Q3)=0,YSOP="+",YSTY="CN",YSTLL="Crisis Notes and Messages",YSOPT2="ENPN1^YSCEN3",YSP0=$S(IOST?1"P".E:1,1:0) D:T6'="A" L2^YSCEN2 D:T6="A" L1^YSCEN2 G END0
 ;
ENPN1 ;  Prints Crisis Notes and Messages
 ;  Originally, called PN2^YSCEN33 if not a progress note type,
 ;    and PT1^YSCEN38 if a progress note.
 ;  Now, there is no longer a YSCEN38 routine.
 ;  Note:  When calling here, YSN3 = Pt Name, and
 ;         ^UTILITY($J,YSN3,YSDFN)=Mental Health Inpt file's IEN
 ;
 QUIT:$G(Q3)  ;->
 N YSN3,YSDFN
 S YSN3=0
 F  S YSN3=$O(^UTILITY($J,YSN3)) QUIT:YSN3']""!($G(Q3))  D
 .  S YSDFN=0
 .  F  S YSDFN=$O(^UTILITY($J,YSN3,YSDFN)) QUIT:YSDFN'>0  D ^YSCEN33
 QUIT
 ;
ENDIAG ; Called from MENU option YSCENDIA
 ;
 K YSOPT1,YSOPT2 D A Q:Y<1  I $D(IO("Q")) S ZTRTN="DIAGQ^YSCEN3" D OUT G END
DIAGQ ;
 D FS S YSP0=$S(IOST?1"P".E:6,1:4) U IO W @IOF S YSOPT1="DXLS^YSDX3RUA,DX^YSDX3RU,AX4^YSDX3RUA:YSLFT'=1,AX5^YSDX3RUA:YSLFT'=1,DIAGQ2^YSCEN3",(P,P1)=1,YSOPT1L="ACTIVE DSM/ICD9 DIAGNOSIS",YSTY="ACT",YSLFT=0,YSCENN=1 K ^UTILITY($J)
 S Y1=0,YST=$S(IOST?1"P".E:9,1:0),YSSL=$S(YST:8,1:6),YSLFT=0,YSNOFORM=1
 D:T6'="A" L2^YSCEN2,L3^YSCEN2 D:T6="A" L1^YSCEN2 G END0
DIAGQ2 ;
 ;  Modified 11/18/93 to move DSM code to YSDX* area / LJA
 D DIAGQ2^YSDX0002
 QUIT
 ;
ENDRG ;
 K YSOPT1,YSOPT2 D A Q:Y<1!(POP)  I $D(IO("Q")) S ZTRTN="DRGQ^YSCEN3" D OUT G END
DRGQ ;
 D FS U IO W @IOF S YSDRGFL=0,YSN1="X",YSOPT1="^YSCEN32",(P,P1)=1,YSOPT1L="Diagnostic Related Groups" K ^UTILITY($J) D:T6'="A" L2^YSCEN2,L3^YSCEN2 D:T6="A" L1^YSCEN2 G END0
ENTLST ;
 K YSOPT1,YSOPT2 D A G:Y<1!(POP) END I $D(IO("Q")) S ZTRTN="TLSTQ^YSCEN3" D OUT G END
TLSTQ ;
 D FS U IO W @IOF S P1=1,YSOPT1="REC^YSCEN41",YSOPT1L="RECENT PSYCHOLOGICAL TESTS & INTERVIEWS" D:T6'="A" L2^YSCEN2,L3^YSCEN2 D:T6="A" L1^YSCEN2 G END0
ENALLT ;
 K YSOPT1,YSOPT2 S YSCENN=1 D A G:Y<1 END I $D(POP) G:POP END
 I $D(IO("Q")) S ZTRTN="ALLTQ^YSCEN3" D OUT G END
ALLTQ ;
 D FS U IO W @IOF S P1=1,YSOPT1="EN^YSCEN41",YSOPT1L="ALL TESTS AND INTERVIEWS" D:T6'="A" L2^YSCEN2,L3^YSCEN2 D:T6="A" L1^YSCEN2 G END0
PROB ;
 S P4="PL",F3=0,YSSL=1 D EN1^YSPROB5,WAIT^YSCEN1 Q
 ;
A ;  Called by routines YSCEN2, YSCEN23, YSCEN31, YSCEN34, YSCEN35
 K IOP
A1 ;  Called by routine YSCEN1
 ;
 S Y=-1 R !,"Sort by (W)ard/team or (S)taff? W// ",X:DTIME S YSTOUT='$T,YSUOUT=X["^" Q:YSTOUT!YSUOUT  S X=$TR(X_"W","ws","WS") G:X?1"S".E WHO^YSCEN26 I X'?1"W".E W !,"Please select either <<W>>ard or <<S>>taff",$C(7) G A1
 ;
AX ; Called by routines YSCEN39, YSCEN4, YSCEN8
 ;
 S POP="" K ^UTILITY($J) D UN^YSCEN2 Q:Y<1  S (Q3,P1)=0
 I '$D(^YSG("INP","AWC",+Y)) W !,"No patients are listed on this ward",!,$C(7) H 3 G A
 S W4=$P(^YSG("CEN",W1,0),U,9) I $P(^YSG("CEN",W1,0),U,8) S Y=1,T6=W4,%ZIS="Q" D ^%ZIS Q
A0 ;
 S Y=0 W !,"Select ",W2," Team: " R X:DTIME S YSTOUT='$T,YSUOUT=X["^" Q:YSTOUT!YSUOUT  I X="ALL"!(X="all")!(X="All") S T6="A",Y=1,%ZIS="Q" D ^%ZIS Q
 I X?1"^".E S Y=-1,POP=1 Q
 S DIC("S")="I $P(^(1),U)=W1,$P(^(1),U,5)'=1",DIC(0)="EQM",DIC="^YSG(""SUB""," D ^DIC K DIC W:X="?" !,"Enter 'ALL' for all teams",! G:Y<1 A0
 I '$D(^YSG("INP","AWC",W1,+Y)) W !,"No patients are listed for this team",!,$C(7) G A0
 S T6=+Y I '$D(TYPE) S %ZIS="Q" D ^%ZIS Q:POP
 Q
END0 ;
 D KILL^%ZTLOAD
END ;
 G ^YSCEN37
FS ;
 I $D(W1),W1 S P1=0 D FS0^YSCEN Q
 Q
LDT ;
 S %DT("A")="LISTING FROM WHICH DATE? ",%DT="AEQP" D ^%DT S YSLDTY=+Y,YSLDT=9999999-+Y K %DT Q
OUT ;
 K IO("Q") S ZTDESC="LOOKUP "_ZTRTN F ZZ="W1","W2","Q3","T6","YSLDT","YSCR","YSWHO" S ZTSAVE(ZZ)="",ZTDESC="YS IP UNIT LKUP"
 D ^%ZTLOAD W !,$S($D(ZTQUEUED):"QUEUED",1:"Not queued"),$C(7)