source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN61.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1YSCEN61 ;ALB/ASF,SLC/BB-MH WARD LOS ;4/16/92 10:40 ;
2 ;;5.01;MENTAL HEALTH;**37**;Dec 30, 1994
3 ;
4 ; Called from the top by MENU option YSCENLOS
5 ;
6ALOS ;
7 K L,H,YSOPT1,YSOPT2 S IOP=0 D ^%ZIS K IOP W @IOF,!?IOM-$L("LENGTH OF WARD STAY FOR CURRENT INPATIENTS")\2,"LENGTH OF WARD STAY FOR CURRENT INPATIENTS"
8R ;
9 R !!,"(A)verage MH ward LOS, (S)ort by MH ward LOS, (B)reak even report? A// ",A7:DTIME S YSTOUT='$T,YSUOUT=A7["^" I YSTOUT!YSUOUT G END
10 S:A7="" A7="A" S A7=$TR($E(A7),"asb","ASB") G ST:A7="A",C1:A7="B",CT:A7="S"
11 W !!,"Enter 'A' for averages by ward/team",!,"Enter 'S' to show patients based on MH ward LOS",!,"Enter 'B' for extensive report of DRG, DDXLS and LOS" G R
12CT ;
13 R !!,"Display Patients with MH WARD LOS greater than how many days? 30// ",H:DTIME S YSTOUT='$T,YSUOUT=H["^" G:YSTOUT END
14 S YSR1="H",YSR2=30,YSR3=999 D ^YSCEN14 G END:H=-1,CT:H="?"
15XXX R !!,"All Wards? Y// ",X:DTIME S YSTOUT='$T,YSUOUT=X["^" G:YSTOUT END
16 S YSR1="X",YSR2="Y",YSR3="YN",YSR4="Enter No to list only one ward." D ^YSCEN14 G END:X=-1,XXX:X="?",ST:X="Y"
17 D UN^YSCEN2 G:Y<1 END K IOP S %ZIS="Q" D ^%ZIS G:POP END
18 I $D(IO("Q")) K IO("Q") S ZTRTN="ENQO^YSCEN61",ZTDESC="YS IP 61",(ZTSAVE("W1"),ZTSAVE("W2"),ZTSAVE("A7"),ZTSAVE("H"))="" D ^%ZTLOAD W !,$S($D(ZTSK):"QUEUED",1:"Not queued"),$C(7) G END
19ENQO ;
20 U IO D HD,IN,CAL,@($S($D(H):"LP",1:"PRT")) G END0
21ST ;
22 K IOP S %ZIS="Q" D ^%ZIS G:POP END
23 I $D(IO("Q")) K IO("Q") S ZTRTN="ENQST^YSCEN61",ZTDESC="YS IP 61",(ZTSAVE("W1"),ZTSAVE("W2"),ZTSAVE("A7"),ZTSAVE("H"))="" D ^%ZTLOAD W !,$S($D(ZTSK):"QUEUED",1:"Not queued"),$C(7) G END
24ENQST ;
25 U IO D HD S YSFS=0 F S YSFS=$O(^YSG("CEN","AFS",YSFS)) Q:'YSFS S W1=$O(^YSG("CEN","AFS",YSFS,0)) D IN,CAL,@($S($D(H):"LP",1:"PRT")) W ! K L I $Y+5>IOSL D WAIT^YSCEN1 G:Q3 END D HD
26 G END0
27CAL ;
28 S (T6,N)=0 F S T6=$O(^YSG("INP","AWC",W1,T6)) Q:'T6 S YSN=0 F S YSN=$O(^YSG("INP","AWC",W1,T6,YSN)) Q:'YSN S G=^YSG("INP",YSN,0) D CAL1
29 Q
30CAL1 ;
31 S YSDFN=$P(G,U,2),X1=DT,X2=$P(G,U,3),YSUN=$P(G,U,4) S:YSUN="" YSUN="UN" D ^%DTC S:'$D(L(W1)) L(W1)=0 S N=N+1 S:X=0 X=1
32 S:'$D(L(W1,YSUN)) L(W1,YSUN)=0,N(W1,YSUN)=0 S N(W1,YSUN)=N(W1,YSUN)+1,L(W1)=(L(W1)+X)_U_N,L(W1,YSUN)=L(W1,YSUN)+X_U_N(W1,YSUN)
33 I $D(H),X>H S ^UTILITY($J,9999999-X,YSDFN)=G
34 Q
35PRT ;
36 W !,$P(^YSG("CEN",W1,0),U,2) I '$D(L(W1)) W ?25,"***** NO PATIENTS ****" Q
37 W ?25,"Total days: ",+L(W1),?45,"Patients: ",$P(L(W1),U,2),?60,"Average: ",$J(+L(W1)/$P(L(W1),U,2),6,2),!
38 S U1="" F S U1=$O(L(W1,U1)) Q:U1="" D PRT2
39 Q
40PRT2 ;
41 S U3=$S(U1="UN":"UNASSIGNED",1:$P(^YSG("SUB",U1,0),U)) W !?3,U3,?25,"Total days: ",+L(W1,U1),?45,"Patients: ",$P(L(W1,U1),U,2),?60,"Average: ",$J(+L(W1,U1)/$P(L(W1,U1),U,2),6,2)
42 Q
43LP ;
44 W !?10,"Ward: ",W2 I '$D(^UTILITY($J)) W !,"*** NO PATIENTS " W:H>0 " WITH AN MH WARD LOS GREATER THAN ",H," DAYS ***" Q
45 W " patients" W:H>0 " with MH WARD LOS>",H W !,"Name",?17,"age entry",?32,"days",?51,"primary dx",?73,"on" S C3=0 F S C3=$O(^UTILITY($J,C3)) Q:'C3 D LP1
46 Q
47LP1 ;
48 S YSDFN=0 F S YSDFN=$O(^UTILITY($J,C3,YSDFN)) Q:'YSDFN S G=^(YSDFN) D ENPT^YSUTL W !,$E(YSNM,1,16),?17,YSAGE D D W ?21,D,?31,$J(9999999-C3,4),?37 S X=$P(G,U,5) D:X?1N.N D3^YSCEN2 W ?49 D DX^YSCEN6
49 Q
50END0 ;
51 D KILL^%ZTLOAD,WAIT^YSCEN1
52END ;
53 K ZTSK,%Y,C1,Q3,T6,YSDTM,D,YSDX,F,YSFS,G,R,T2,U1,U3,YSUN,YSDOB,YSSEX,YSSSN,X1,X2,YSAGE,YSNM,YSPDX,YSTM,H,P1,W2,W1,L,N,^UTILITY($J),YSDFN,YSBID,X,Y,A7,I,J,C3 D KVAR^VADPT W !! D ^%ZISC Q
54HD ;
55 W @IOF,!?10,"LENGTH OF WARD STAY FOR CURRENT INPATIENTS"
56 K Y D ENDTM^YSUTL W ?55,YSDT(1)," ",YSTM,! I $D(H),H=0 W ?10,"*** SORTED BY MH WARD LOS ***",! Q
57 Q
58D ;
59 S D=$P(G,U,3),D=$$FMTE^XLFDT(D,"5ZD") Q
60C1 ;
61 S YSX="C" D EXP0^YSCEN53,EN^YSCEN52
62C11 ; Called by routine YSCEN52
63 K A7,AGE,B,C,DAM,DFN,DIYS,DRG,DRGCAL,DXLS,EXP,J1,L,L1,L5,L6,L7,L8,LOS,MDC,NDR,NO,NOR,NSD,OR,PD,PTF,RG,SD,SD1,SEX,T6,TAC,TRS,X3,YS,YSAF,YSBAR,YSBD,YSBE,YSDRG,YSDRGFL,YSDTM,YSDY,YSFLGP,YSFR,YSN,YSN1
64 K YSR,YSSX,YST1,YSTM,YSWT,YSX,W1,W2,YSTO,ZTSK,I Q
65IN ;
66 S P1=0 K YSOPT1 D FS0^YSCEN,L1^YSCEN2 K ^UTILITY($J)
Note: See TracBrowser for help on using the repository browser.