source: FOIAVistA/trunk/r/MEDICINE-MC/MCARBSA.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 1.4 KB
Line 
1MCARBSA ;WISC/TJK,RCH-COMPUTE BODY SURFACE AREA .001*71.84*((WT/2.2)**.425*(HT*2.5)**.725) ;5/2/96 13:53
2 ;;2.3;Medicine;;09/13/1996
3 N BS
4 Q:'$D(^MCAR(691,DA,13)) S BS=^(13),WT=$P(BS,U,1),HT=$P(BS,U,2)
5 Q:(WT="")!(HT="") D COMPUTE S $P(BS,U,3)=X,^MCAR(691,DA,13)=BS
6A I $D(DJDN) S V(7)=X,DJVV=7 D EN^MCARDNJ1 K DJVV
7 Q
8CATH S BS=^MCAR(691.1,DA,0),WT=$P(BS,U,7),HT=$P(BS,U,8)
9 Q:(WT="")!(HT="") D COMPUTE S $P(BS,U,9)=X,^MCAR(691.1,DA,0)=BS K BS
10B I $D(DJDN) S V(8)=X,DJVV=8 D EN^MCARDNJ1 K DJVV
11 Q
12RISK S BS=^MCAR(694.5,DA,0),WT=$P(BS,U,7),HT=$P(BS,U,5)
13 D RISK1:(WT="")!(HT="")
14 Q:(WT="")!(HT="") D COMPUTE S $P(BS,U,9)=X,^MCAR(694.5,DA,0)=BS K BS
15 Q
16RISK1 I '$P(BS,U,5),$P(BS,U,6) S HT=$P(BS,U,6)/2.5,$P(BS,U,5)=HT
17 I '$P(BS,U,7),$P(BS,U,8) S WT=$P(BS,U,8)*2.2,$P(BS,U,7)=WT
18 Q
19COMPUTE ;
20 S MCARX=WT/2.2 D LN S MCARX=MCARR*0.425 D EXP S MCARW=MCARR
21 S MCARX=HT*2.5 D LN S MCARX=MCARR*0.725 D EXP
22 S X=(0.0001)*(71.84)*(MCARW*MCARR),X=$J(X,4,2) K MCARR,MCARW,MCARX,WT,HT
23 Q
24LN ;
25 S F=MCARX,(LN,D)=0 Q:MCARX'>0
26LN2 I F'<1 S F=.5*F,D=D+1 G LN2
27LN3 I F<.5 S F=2*F,D=D-1 G LN3
28 S F=(F-.707107)/(F+.707107),LN=F*F
29 S LN=(((.598979*LN+.961471)*LN+2.88539)*F+D-.5)*.693147
30 S MCARR=LN K LN,D,F Q
31EXP ;
32 S X=MCARX,E=0,B=1.4427*X\1+1 Q:B>90
33 S E=.693147*B-X,A=.00132988-(.000141316*E)
34 S A=((A*E-.00830136)*E+.0416574)*E
35 S E=(((A-.166665)*E+.5)*E-1)*E+1,A=2
36 I B'>0 S A=.5,B=-B
37 F I=1:1:B S E=A*E
38 S MCARR=+E K A,B,I,E,X Q
Note: See TracBrowser for help on using the repository browser.