source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN.m@ 810

YSCEN ;ALB/ASF-MENTAL HEALTH CENSUS FACE SHEET ;12/3/91  16:38 ;
 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
 ;
1 ;
 S P1=1 W @IOF,?10,"M E N T A L   H E A L T H   C E N S U S"
 K Y D ENDTM^YSUTL W ?55,YSDT(1)," ",YSTM D PRH
FS ; Called from routine YSCEN6
 ;
 S (YSTOP,YSSCT,Q3,T,S1,YSSC1,YSOP1)=0 S:'$D(P1) P1=0
 S J=0 F  S J=$O(^YSG("CEN","AFS",J)) Q:'J  S W2=$O(^YSG("CEN","AFS",J,0)),W1=W2 D:$Y+5>IOSL WW:P1 Q:Q3  D FS0
 Q:Q3  I P1 W !!?13,"Total:",?23,$J(YSTOP,4),?33,$J(T,4),?45,$J(YSTOP-T,4),?54,$J(YSSCT,4) I YSTOP W ?67,$J(T/YSTOP*100,4,1),"%"
 I P1,IOST?1"C-".E D WAIT^YSCEN1
 Q
FS0 ; Called from routines YSCEN1, YSCEN13, YSCEN2, YSCEN21, YSCEN22
 ; YSCEN23, YSCEN24, YSCEN3, YSCEN4, YSCEN51, YSCEN55, YSCEN61, YSCEN8
 ;
 S W2=$P(^DIC(42,+^YSG("CEN",W1,0),0),U) D FS1 I P1,$$ACTIVE(+W1) D PR,PRS:$P(^YSG("CEN",W1,0),U,4) S:$P(^(0),U,5) (YSOP1,YSSC1,S1)=0 W:$P(^(0),U,7) !
 Q
FS1 ;
 N J S YSDFN=0,R=0 F  S YSDFN=$O(^DPT("CN",W2,YSDFN)) Q:YSDFN'>0  S YSDA=$O(^YSG("INP","CP",+YSDFN,0)) I +$G(^YSG("INP",+YSDA,7))=W1 S:P1 R=R+1,S1=S1+1,T=T+1
 Q:'P1  S YSSC=0 I $D(^DGS(41.1,"ARSV",W1)) S X=0 F  S X=$O(^DGS(41.1,"ARSV",W1,X)) Q:'X  I $D(^DGS(41.1,X,0)),$P(^(0),U,2)'<DT S YSSC=YSSC+1
 K YSBED S DIC="^DIC(42,",DA=W1,DR=".23",DIQ(0)="E",DIQ="YSBED(" D EN^DIQ1 K DIC,DR,DIQ,DA
 S YSOP=YSBED(42,W1,.23,"E"),YSTOP=YSTOP+YSOP,YSSCT=YSSCT+YSSC,YSSC1=YSSC1+YSSC,YSOP1=YSOP1+YSOP
 Q
PR ;
 W !,$P(^YSG("CEN",W1,0),U,2),?24,$J(YSOP,3),?34,$J(R,3),?46,$J(YSOP-R,3),?55,$J(+YSSC,3),?67 W:YSOP'=0&(YSOP]"") $J(R/YSOP*100,4,1),"%" W:YSOP=0!(YSOP="") "***" Q
PRS ;
 S X=$S($P(^YSG("CEN",W1,0),U,6)?1A.E:$P(^(0),U,6),1:"sub-total:") W !?9,X,?24,$J(YSOP1,3),?34,$J(S1,3),?46,$J(YSOP1-S1,3),?55,$J(YSSC1,3)
 W ?67,$S(YSOP:$J(S1/YSOP1*100,4,1)_"%",1:"***") Q
PRH ;
 W !,"Ward",?22,"operating",?34,"current",?46,"empty",?55,"sched",?65,"occupancy",!?24,"beds",?34,"patients",?46,"beds",?55,"admis",?67,"rate",! F ZZ=1:1:11 W "-------"
 Q
WW ;
 D WAIT^YSCEN1 Q:Q3  W @IOF D PRH Q
 Q
 ;
ACTIVE(X) ;Is ward active?  0=No, 1=Yes
 S X=$G(^YSG("CEN",+$G(X),0))
 QUIT '(+$P(X,U,13))
 ;
EN ; Called from MENU option YSCENFS
 ;
 K IOP S %ZIS="Q" D ^%ZIS G:POP END
 I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^YSCEN",ZTIO=IO,ZTDESC="Mental Health Inpatient",ZTSAVE("P")="" D ^%ZTLOAD G END
ENQ ;
 U IO D 1 G:Q3 END0 D ENALL^YSCEN21
END0 ;
 D KILL^%ZTLOAD
END ;
 K ZTDESC,ZTSK,ZTIO,B,A1,C1,D1,D2,P1,YSW1,YSDFN,W1,I7,J,R,T,YSLST,YSSCT,W2,T6,YSSC,YSSC1,YSOP,YSOP1,YSTOP,I,X,Y,DIC,DIK,DIE,G2,J3,K2,X1,S1,Q3,J1,L,L7,LOS,PTF,W1,YSAGE,YSBD,YSBE,SEX,DXLS,ZZ
 K YSDRG,YSDRGFL,YSDY,YSFLGP,YSFR,YSN,YSN1,YSNM,YSPDX,YSPDX,YSR,YSSEX,YSSSN,YST1,YSWT,YSX,ZTRTN,ZTSAVE,YSOR,YSBID,VA,PTI D KVAR^VADPT W !! D ^%ZISC Q
 ;
KILLALL ;This sub-routine is an exit action called by YSCEN* options
 K DZ,G7,VAIN,VAINDT,VAIP,X5,XQH
 K YS,YSA8,YSAC,YSADR,YSAF,YSAGE,YALL,YSAOR,YSB,YSBAR,YSBD,YSBE,YSBED
 K YSBID,YSBLN,YSC,YSC1,YSCD,YSCEN3F,YSCENDA,YSCENDNO,YSCENDO
 K YSCENDTA,YSCENI,YSCENLP,YSCENN,YSCENOK,YSCENPB,YSCENRNO,YSCENRT
 K YSCENWNO,YSCENX,YSCF,YSCHAR,YSCNT,YSCON,YSCOP,YSCOPY,YSCR,YSCRX
 K YSCTN,YSD,YSDA,YSDA2,YSDAT,YSDATE,YSDAY,YSDFN,YSDFN1,YSDFN9,YSDIN
 K YSDISP,YSDOB,YSDOT,YSDPT,YSDR,YSDRG,YSDRGFL,YSDRT,YSDRUG,YSDRUG2
 K YSDT,YSDTM,YSDUZ,YSDX,YSDY,YSEN,YSEND,YSENT,YSET,YSF,YSF4,YSFA
 K YSFDAT,YSFFS,YSFHDR,YSFIN,YSFIRST,YSFL5,YSFL6,YSFL7,YSFLG,YSFLGP
 K YSFR,YSFRM,YSFRM1,YSFRT,YSFS,YSG,YSGL1,YSGP,YSH1,YSHDR,YSHM,YSHR
 K YSHTM,YSI,YSIDT,YSIG,YSIGI,YSINDT,YSJ,YSKK,YSLDRUG,YSLDT,YSLDT1
 K YSLDTY,YSLFT,YSLIG,YSLL,YSLST,YSM,YSMN,YSMOR,YSN,YSN1,YSND,YSND1
 K YSNM,YSNN,YSNOFORM,YSNOW,YSNT,YSNX,YSO,YSOP,YSOP1,YSOPT1,YSOPT1L
 K YSOPT2,YSOPT9L,YSOR,YSPO,YSPCK,YSPDX,YSPE,YSPF,YSPHY,YSPNH,YSPOIN
 K YSPPL,YSPRG,YSPRG3,YSPST,YSPSV,YSPY,YSPYSTO,YSPZ,YSQT,YSQTY
 K YSR,YSR1,YSR11,YSR2,YSR3,YSR4,YSR5,YSR99,YSRD,YSREM,YSRX1,YSRXGL
 K YSRXGL2,YSRXNO,YSSC,YSSC1,YSSCT,YSSEX,YSSL,YSSSN,YSSX,YST,YST0,YST1
 K YSTB,YSTBO,YSTLE,YSTLL,YSTLST,YSTLT,YSTM,YSTM7,YSTM8,YSTMX,YSTO,YSTO1
 K YSTOP,YSTOT,YSTOUT,YSTP,YSTP1,YSTS,YSTS1,YSTST,YSTY,YSU,YSUN,YSUOUT
 K YSUS,YSUSER,YSUSN,YSV,YSW1,YSWDAT,YSWHO,YSWT,YSX,YSYD,YSYDT,YY
 K Z,Z1,Z4,ZZ