source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN52.m@ 1489

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1YSCEN52 ;ALB/ASF-TEAM ADMISSION REPORT ;4/4/90 08:32 ;
2 ;;5.01;MENTAL HEALTH;**5,37**;Dec 30, 1994
3 ;
4 ; Called from top by MENU option YSCENTMHX
5 ;
6 D EXP^YSCEN53
7W ;
8 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)
9 I "AaDd"'[YSX W !!,"ENTER 'A' FOR ADMIT SORT",!,"'D' FOR SORTING BY DISCHARGES",!,$C(7) G W
10 ;
11EN ; Called from routine YSCEN61
12 K YSTO I "Cc"[YSX S YSTO=1,YSFR=9999999 G WD
13 D:'$D(YSTO) FR G:'YSTO END
14A ;
15 S Y=-1 R !,"Sort by (W)ard/team or (S)taff? W// ",X:DTIME S YSTOUT='$T,YSUOUT=X["^" Q:YSTOUT!YSUOUT
16 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
17WD ;
18 S YSGP=0 D UN^YSCEN2 G END:+Y'>0,DEV
19WHO ;
20 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
21 S YSGP=5,YSOPT9L="PRIMARY THERAPIST" S:"Pp"[X2 YSGP=6,YSOPT9L="PHYSICIAN" S:"Rr"[X2 YSGP=7,YSOPT9L="RESIDENT"
22 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"
23DEV ;
24 S %ZIS="Q" K IOP D ^%ZIS G:POP END
25 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)=""
26 I D ^%ZTLOAD W !,$S($D(ZTSK):"QUEUED",1:"Not queued"),$C(7) G END
27EN11 ;
28 S Q3=0 U IO D L1,P1 G:Q3 END D ^YSCEN53,KILL^%ZTLOAD
29END ;
30 D END^YSCEN5,C11^YSCEN61 K %,%W,%Y,YSFRT,YSTOT,YSGP,YSOPT9L,YSWHO Q
31FR ;
32 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
33TO ;
34 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
35L1 ;
36 K ^UTILITY($J) I "Cc"[YSX D C1 Q
37 S YSX=$S("Dd"[YSX:"AOUT",1:"AIN"),YSR=YSTO-.01 F S YSR=$O(^YSG("INP",YSX,YSR)) Q:YSR>YSFR!('YSR) D
38 .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
39 Q
403 ;
41 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
42 Q
434 ;
44 S X=^YSG("INP",YSN,0),^UTILITY($J,$P(X,U,4),9999999-$P(X,U,3),YSN)=YSWHO_U_"S" Q
45C1 ;
46 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"
47 Q
48P1 ;
49 S YSFLGP=1,(Q3,P1,YST1)=0 K ^UTILITY($J,"YS")
50 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
51 Q
52P2 ;
53 Q:Q3 S YSDY=0 F S YSDY=$O(^UTILITY($J,YST1,YSDY)) Q:'YSDY D
54 .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
55 Q
56P4 ; Called by routine YSCEN33
57 S L=^YSG("INP",YSN,0),DFN=$P(L,U,2),X2=$P(L,U,3)
58 S X1=$P(^YSG("INP",YSN,7),U,2) S:X1?7N.E X3=$$FMTE^XLFDT(X2,"5ZD") Q:DFN<1
59 I 'X1 S X1=DT,X3="current"
60 S YSDFN=DFN D ENPT^YSUTL I $Y+5>IOSL D WAIT^YSCEN1 Q:Q3 D HD^YSCEN56
61 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)
62 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
63 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
64 Q
65P5 ;
66 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
67PTF ;
68 S PTF=0,J1=$P(^YSG("INP",YSN,7),U,3) Q
Note: See TracBrowser for help on using the repository browser.