69 lines
3.8 KiB
Mathematica
69 lines
3.8 KiB
Mathematica
|
YSCEN52 ;ALB/ASF-TEAM ADMISSION REPORT ;4/4/90 08:32 ;
|
||
|
|
;;5.01;MENTAL HEALTH;**5,37**;Dec 30, 1994
|
||
|
|
;
|
||
|
|
; Called from top by MENU option YSCENTMHX
|
||
|
|
;
|
||
|
|
D EXP^YSCEN53
|
||
|
|
W ;
|
||
|
|
R !!!,"Sort by (A)dmit dates or (D)ischarge dates ? ",YSX:DTIME S YSTOUT='$T,YSUOUT=YSX["^" G:YSTOUT!YSUOUT END S YSX=YSX_1,YSX=$E(YSX)
|
||
|
|
I "AaDd"'[YSX W !!,"ENTER 'A' FOR ADMIT SORT",!,"'D' FOR SORTING BY DISCHARGES",!,$C(7) G W
|
||
|
|
;
|
||
|
|
EN ; Called from routine YSCEN61
|
||
|
|
K YSTO I "Cc"[YSX S YSTO=1,YSFR=9999999 G WD
|
||
|
|
D:'$D(YSTO) FR G:'YSTO END
|
||
|
|
A ;
|
||
|
|
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=X_"W" G:X?1"S".E!(X?1"s".E) WHO I X'?1"W".E&(X'?1"w".E) W !,"Please select either <<W>>ard or <<S>>taff",$C(7) G A
|
||
|
|
WD ;
|
||
|
|
S YSGP=0 D UN^YSCEN2 G END:+Y'>0,DEV
|
||
|
|
WHO ;
|
||
|
|
R !,"Sort by (T)herapist, (P)hysician or (R)esident: ",X2:DTIME S YSTOUT='$T,YSUOUT=X2["^" Q:YSTOUT!YSUOUT S X2=$E(X2_1) I "TPRtpr"'[X2 W !,"Select above for listing by either Physician, Resident or primary Therapist",! G WHO
|
||
|
|
S YSGP=5,YSOPT9L="PRIMARY THERAPIST" S:"Pp"[X2 YSGP=6,YSOPT9L="PHYSICIAN" S:"Rr"[X2 YSGP=7,YSOPT9L="RESIDENT"
|
||
|
|
S DIC="^VA(200,",DIC("A")="Select "_YSOPT9L_": ",DIC(0)="AEQ" D ^DIC K DIC Q:Y<1 S YSWHO=+Y,(Q3,P1,W1)=0,T6="S"
|
||
|
|
DEV ;
|
||
|
|
S %ZIS="Q" K IOP D ^%ZIS G:POP END
|
||
|
|
I $D(IO("Q")) K IO("Q") S ZTRTN="EN11^YSCEN52",ZTDESC="MH IP 99" F ZZ="YSTO","YSTOT","YSFR","YSFRT","W1","W2","T6","YSX","YSGP","YSOPT9L","YSWHO" S ZTSAVE(ZZ)=""
|
||
|
|
I D ^%ZTLOAD W !,$S($D(ZTSK):"QUEUED",1:"Not queued"),$C(7) G END
|
||
|
|
EN11 ;
|
||
|
|
S Q3=0 U IO D L1,P1 G:Q3 END D ^YSCEN53,KILL^%ZTLOAD
|
||
|
|
END ;
|
||
|
|
D END^YSCEN5,C11^YSCEN61 K %,%W,%Y,YSFRT,YSTOT,YSGP,YSOPT9L,YSWHO Q
|
||
|
|
FR ;
|
||
|
|
S (YSFR,YSTO)=0,%DT("A")="From what date: ",%DT="AEQ" D ^%DT Q:Y<1 S YSFR=9999999-+Y D DD^%DT S YSFRT=Y
|
||
|
|
TO ;
|
||
|
|
S %DT("A")="To what date: ",%DT="AEQT" D ^%DT Q:Y<1 S YSTO=9999999-+Y D DD^%DT S YSTOT=Y Q:YSTO<YSFR S Y=YSFR,YSFR=YSTO,YSTO=Y,Y=YSTOT,YSTOT=YSFRT,YSFRT=Y Q
|
||
|
|
L1 ;
|
||
|
|
K ^UTILITY($J) I "Cc"[YSX D C1 Q
|
||
|
|
S YSX=$S("Dd"[YSX:"AOUT",1:"AIN"),YSR=YSTO-.01 F S YSR=$O(^YSG("INP",YSX,YSR)) Q:YSR>YSFR!('YSR) D
|
||
|
|
.S YSN=0 F S YSN=$O(^YSG("INP",YSX,YSR,YSN)) Q:'YSN D:+^YSG("INP",YSN,7)=W1 3:'YSGP D:YSGP 4:$P(^YSG("INP",YSN,0),U,YSGP)=YSWHO
|
||
|
|
Q
|
||
|
|
3 ;
|
||
|
|
Q:'$D(^YSG("INP",YSN,6)) S YSN1=0 F S YSN1=$O(^YSG("INP",YSN,6,YSN1)) Q:'YSN1 S X=^(YSN1,0),X1=+X,X2=9999999-$P(X,U,2) S ^UTILITY($J,X1,X2,YSN)=YSN1
|
||
|
|
Q
|
||
|
|
4 ;
|
||
|
|
S X=^YSG("INP",YSN,0),^UTILITY($J,$P(X,U,4),9999999-$P(X,U,3),YSN)=YSWHO_U_"S" Q
|
||
|
|
C1 ;
|
||
|
|
S T6=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 YSR=9999999-$P(^YSG("INP",YSN,0),U,3) I YSR'>YSFR&(YSR'<YSTO) S ^UTILITY($J,T6,YSR,YSN)="C"
|
||
|
|
Q
|
||
|
|
P1 ;
|
||
|
|
S YSFLGP=1,(Q3,P1,YST1)=0 K ^UTILITY($J,"YS")
|
||
|
|
F S YST1=$O(^UTILITY($J,YST1)) Q:'YST1 S YSBE=+$P($G(^YSG("CEN",W1,0)),U,10) D HD^YSCEN56,P2,P5,WAIT^YSCEN1 Q:Q3
|
||
|
|
Q
|
||
|
|
P2 ;
|
||
|
|
Q:Q3 S YSDY=0 F S YSDY=$O(^UTILITY($J,YST1,YSDY)) Q:'YSDY D
|
||
|
|
.S YSN=0 F S YSN=$O(^UTILITY($J,YST1,YSDY,YSN)) Q:'YSN S YSN1=^UTILITY($J,YST1,YSDY,YSN) K DRGCAL D P4
|
||
|
|
Q
|
||
|
|
P4 ; Called by routine YSCEN33
|
||
|
|
S L=^YSG("INP",YSN,0),DFN=$P(L,U,2),X2=$P(L,U,3)
|
||
|
|
S X1=$P(^YSG("INP",YSN,7),U,2) S:X1?7N.E X3=$$FMTE^XLFDT(X2,"5ZD") Q:DFN<1
|
||
|
|
I 'X1 S X1=DT,X3="current"
|
||
|
|
S YSDFN=DFN D ENPT^YSUTL I $Y+5>IOSL D WAIT^YSCEN1 Q:Q3 D HD^YSCEN56
|
||
|
|
W !,$E(YSNM,1,25),?27,YSBID,?33,$$FMTE^XLFDT(X2,"5ZD"),?44,X3 D ^%DTC S LOS=$S(X>0:X,X=0:1,1:"") W ?55,$J(LOS,4)
|
||
|
|
D PTF S YSDRGFL=1,YSDRG=0,DXLS=0 D ^YSCEN32 G:'YSDRG EX^YSCEN53 S YSWT=$P(^ICD(YSDRG,0),U,2),DXLS=L W ?61,$P(^ICD9(L,0),U),?68,YSDRG,L7 G:'YSBE EX^YSCEN53
|
||
|
|
S YSBD=YSWT*$P(^YSA(602,1,0),U,5)/YSBE W ?76,$J(YSBD-LOS,3,0) S X=0 S:YSWT X=LOS/YSBD*100 W " ",$S(X>149.99:"#",X>99.99:"*",X>74.99:"@",1:"") G EX^YSCEN53
|
||
|
|
Q
|
||
|
|
P5 ;
|
||
|
|
W !!,"p= PTF DXLS, m= First PTF dx, i= Primary ICD9 DXLS, d= Primary DSM DXLS",!,"# >150% of Break even, *>100% break even, @ >75% break even Cost/day=$",YSBE Q
|
||
|
|
PTF ;
|
||
|
|
S PTF=0,J1=$P(^YSG("INP",YSN,7),U,3) Q
|