source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN3.m@ 1800

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1YSCEN3 ;ALB/ASF-MH CENSUS LOOKUPS BY UNIT ;3/30/90 14:29 ;11/18/93 08:44
2 ;;5.01;MENTAL HEALTH;**3**;Dec 30, 1994
3 ;
4ENPROB ; Called from MENU option YSCENPROB
5 ;
6 K YSOPT1,YSOPT2 D A Q:Y<1!(POP) I $D(IO("Q")) S ZTRTN="PROBQ^YSCEN3" D OUT G END
7PROBQ ;
8 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
9 ;
10ENCN ; Called from MENU option YSCENCRISIS
11 ;
12 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
13CNQ ;
14 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
15 ;
16ENPN1 ; Prints Crisis Notes and Messages
17 ; Originally, called PN2^YSCEN33 if not a progress note type,
18 ; and PT1^YSCEN38 if a progress note.
19 ; Now, there is no longer a YSCEN38 routine.
20 ; Note: When calling here, YSN3 = Pt Name, and
21 ; ^UTILITY($J,YSN3,YSDFN)=Mental Health Inpt file's IEN
22 ;
23 QUIT:$G(Q3) ;->
24 N YSN3,YSDFN
25 S YSN3=0
26 F S YSN3=$O(^UTILITY($J,YSN3)) QUIT:YSN3']""!($G(Q3)) D
27 . S YSDFN=0
28 . F S YSDFN=$O(^UTILITY($J,YSN3,YSDFN)) QUIT:YSDFN'>0 D ^YSCEN33
29 QUIT
30 ;
31ENDIAG ; Called from MENU option YSCENDIA
32 ;
33 K YSOPT1,YSOPT2 D A Q:Y<1 I $D(IO("Q")) S ZTRTN="DIAGQ^YSCEN3" D OUT G END
34DIAGQ ;
35 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)
36 S Y1=0,YST=$S(IOST?1"P".E:9,1:0),YSSL=$S(YST:8,1:6),YSLFT=0,YSNOFORM=1
37 D:T6'="A" L2^YSCEN2,L3^YSCEN2 D:T6="A" L1^YSCEN2 G END0
38DIAGQ2 ;
39 ; Modified 11/18/93 to move DSM code to YSDX* area / LJA
40 D DIAGQ2^YSDX0002
41 QUIT
42 ;
43ENDRG ;
44 K YSOPT1,YSOPT2 D A Q:Y<1!(POP) I $D(IO("Q")) S ZTRTN="DRGQ^YSCEN3" D OUT G END
45DRGQ ;
46 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
47ENTLST ;
48 K YSOPT1,YSOPT2 D A G:Y<1!(POP) END I $D(IO("Q")) S ZTRTN="TLSTQ^YSCEN3" D OUT G END
49TLSTQ ;
50 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
51ENALLT ;
52 K YSOPT1,YSOPT2 S YSCENN=1 D A G:Y<1 END I $D(POP) G:POP END
53 I $D(IO("Q")) S ZTRTN="ALLTQ^YSCEN3" D OUT G END
54ALLTQ ;
55 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
56PROB ;
57 S P4="PL",F3=0,YSSL=1 D EN1^YSPROB5,WAIT^YSCEN1 Q
58 ;
59A ; Called by routines YSCEN2, YSCEN23, YSCEN31, YSCEN34, YSCEN35
60 K IOP
61A1 ; Called by routine YSCEN1
62 ;
63 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
64 ;
65AX ; Called by routines YSCEN39, YSCEN4, YSCEN8
66 ;
67 S POP="" K ^UTILITY($J) D UN^YSCEN2 Q:Y<1 S (Q3,P1)=0
68 I '$D(^YSG("INP","AWC",+Y)) W !,"No patients are listed on this ward",!,$C(7) H 3 G A
69 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
70A0 ;
71 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
72 I X?1"^".E S Y=-1,POP=1 Q
73 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
74 I '$D(^YSG("INP","AWC",W1,+Y)) W !,"No patients are listed for this team",!,$C(7) G A0
75 S T6=+Y I '$D(TYPE) S %ZIS="Q" D ^%ZIS Q:POP
76 Q
77END0 ;
78 D KILL^%ZTLOAD
79END ;
80 G ^YSCEN37
81FS ;
82 I $D(W1),W1 S P1=0 D FS0^YSCEN Q
83 Q
84LDT ;
85 S %DT("A")="LISTING FROM WHICH DATE? ",%DT="AEQP" D ^%DT S YSLDTY=+Y,YSLDT=9999999-+Y K %DT Q
86OUT ;
87 K IO("Q") S ZTDESC="LOOKUP "_ZTRTN F ZZ="W1","W2","Q3","T6","YSLDT","YSCR","YSWHO" S ZTSAVE(ZZ)="",ZTDESC="YS IP UNIT LKUP"
88 D ^%ZTLOAD W !,$S($D(ZTQUEUED):"QUEUED",1:"Not queued"),$C(7)
Note: See TracBrowser for help on using the repository browser.