75 lines
4.0 KiB
Mathematica
75 lines
4.0 KiB
Mathematica
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
|