source: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN52.m@ 636

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