source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCEN53.m@ 1166

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

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1YSCEN53 ;ALB/ASF-TEAM HX REPORT ;4/3/90 10:49 ;
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 ;
4 ; Called from routine YSCEN52
5A ;
6 S (YSFLGP,YST1)=0 F S YST1=$O(^UTILITY($J,"YS",YST1)) Q:'YST1!Q3 F YS="DRG","DXLS","LOS" I $D(^UTILITY($J,"YS",YST1,YS)) D:YS?1"D".E HD^YSCEN56,HD1,L1,L5:YS="DRG" D:YS="LOS" L4 D:YS'="DXLS" WAIT^YSCEN1
7 Q
8L1 ;
9 S (YSBE,YSI)=0 F S YSI=$O(^UTILITY($J,"YS",YST1,YS,YSI)) Q:'YSI D L2
10 Q
11L2 ;
12 S G=^UTILITY($J,"YS",YST1,YS,YSI)
13 I YS="DRG" W ! I $D(^ICD(YSI,1,1,0)) W YSI,?5,$E(^ICD(YSI,1,1,0),1,25)
14 I YS="DXLS" W !,$P(^ICD9(YSI,0),U),?8,$E($P(^ICD9(YSI,0),U,3),1,20)
15L3 ;
16 S N=+$P(G,U,2),YSBAR=+G/N,YSSX=+$P(G,U,3)
17 W ?32,$J(N,3),?38,$J(YSBAR,6,1)
18 S X=(YSSX/N)-(YSBAR*YSBAR) D SQR W ?49,$J(Y,6,2)
19 W ?57,$J($P(G,U,5),4),"/",$P(G,U,4)
20 I +$P(G,U,6) S YSBE=YSBE+$P(G,U,6)
21 I $P(G,U,6) W ?67,$J($P(G,U,6),8,2)
22 Q
23HD1 ;
24 W !?32,"# of",?40,"mean",?47,"standard" W:YS="DRG" ?67,"days to" W !,$S(YS="DRG":"DRG",1:"DXLS"),?32,"pts",?40,"LOS",?47,"deviation",?59,"range" W:YS="DRG" ?67,"break even" W ! F ZZ=1:1:11 W "-------"
25 Q
26SP ;
27 S G1=$E(^ICD9(YSI,1),I1,$L(^(1))) F I1=I1+45:1 S X=$E(G1,I1) Q:X=" "!(X="")
28 W $S($L(G1):$E(G1,1,I1),1:$P(^ICD9(YSI,0),U,3)) I $L(G1)>I1 W !?14 G SP
29 Q
30L4 ;
31 D:'$D(^UTILITY($J,"YS",YST1,"DXLS")) HD^YSCEN56 D HD1 W !,"Team total: " S G=^UTILITY($J,"YS",YST1,YS) D L3
32 I $D(^UTILITY($J,"YS",YST1,"DXLS",0)) S G=^UTILITY($J,"YS",YST1,"DXLS",0) W !,"not coded:" D L3
33 W !! Q
34L5 ;
35 W:YSBE !?67,"--------",!?67,$J(YSBE,8,2) Q
36SQR ;
37 S Y=0 Q:X'>0 S Y=1+X/2
38L ;
39 S T=Y,Y=X/T+T/2 G L:Y<T
40 K T Q
41EXP ; Called from routine YSCEN52
42 W @IOF,!?IOM-$L("INPATIENT PSYCHIATRIC HISTORY")\2,"INPATIENT PSYCHIATRIC HISTORY",! F ZZ=0:1 S X=$P($T(EXP1+ZZ),";;",2) Q:X="END" W !,X
43 Q
44EXP0 ; Called from routine YSCEN61
45 W @IOF,!?IOM-$L("Current Inpatient Break even Report")\2,"Current Inpatient Break even Report",! F ZZ=0:1 S X=$P($T(EXP11+ZZ),";;",2) Q:X="END" W !,X
46 Q
47EXP1 ;;This option will provide a full list of admits or discharges from
48 ;;the selected ward sorted by team. Patients may appear more than
49 ;;once if they change teams within this ward. Only the last team
50 ;;gets credit in the summary LOS, DRG and DXLS tables.
51 ;;
52EXP11 ;;Please use this summary data carefully as in order to do concurrent
53 ;;program planning, the computer uses DSM and ICD9 primary diagnosis
54 ;;if full PTF data is not available. As surgery, procedures and other
55 ;;data points are not available this creates a best guess DRG. The data
56 ;;should be evaluated accordingly. The letter following the DRG number
57 ;;denotes the source of the DXLS: p= PTF DXLS, m= First PTF dx,
58 ;;i= Primary ICD9 code, d= Primary DSM code.
59 ;;END
60EX ; Called from routine YSCEN52
61 Q:$D(^UTILITY($J,"YS","DFN",DFN)) S ^UTILITY($J,"YS","DFN",DFN)=""
62 S G=$S($D(^UTILITY($J,"YS",YST1,"LOS")):^("LOS"),1:"^^^0^99999")
63 S $P(G,U)=$P(G,U)+LOS,$P(G,U,2)=$P(G,U,2)+1,$P(G,U,3)=$P(G,U,3)+(LOS*LOS) S:LOS>$P(G,U,4) $P(G,U,4)=LOS S:LOS<$P(G,U,5) $P(G,U,5)=LOS S ^UTILITY($J,"YS",YST1,"LOS")=G
64 S G=$S($D(^UTILITY($J,"YS",YST1,"DRG",YSDRG)):^(YSDRG),1:"^^^0^99999")
65 S $P(G,U)=$P(G,U)+LOS,$P(G,U,2)=$P(G,U,2)+1,$P(G,U,3)=$P(G,U,3)+(LOS*LOS) S:LOS>$P(G,U,4) $P(G,U,4)=LOS S:LOS<$P(G,U,5) $P(G,U,5)=LOS
66 Q:'YSDRG S:YSBE $P(G,U,6)=$P(G,U,6)+(YSBD-LOS) S ^UTILITY($J,"YS",YST1,"DRG",YSDRG)=G
67 S G=$S($D(^UTILITY($J,"YS",YST1,"DXLS",DXLS)):^(DXLS),1:"^^^0^9999")
68 S $P(G,U)=$P(G,U)+LOS,$P(G,U,2)=$P(G,U,2)+1,$P(G,U,3)=$P(G,U,3)+(LOS*LOS) S:LOS>$P(G,U,4) $P(G,U,4)=LOS S:LOS<$P(G,U,5) $P(G,U,5)=LOS
69 S ^UTILITY($J,"YS",YST1,"DXLS",DXLS)=G
Note: See TracBrowser for help on using the repository browser.