MCARBSA.m

MCARBSA ;WISC/TJK,RCH-COMPUTE BODY SURFACE AREA .001*71.84*((WT/2.2)**.425*(HT*2.5)**.725) ;5/2/96  13:53

 ;;2.3;Medicine;;09/13/1996

 N BS

 Q:'$D(^MCAR(691,DA,13))  S BS=^(13),WT=$P(BS,U,1),HT=$P(BS,U,2)

 Q:(WT="")!(HT="")  D COMPUTE S $P(BS,U,3)=X,^MCAR(691,DA,13)=BS

A I $D(DJDN) S V(7)=X,DJVV=7 D EN^MCARDNJ1 K DJVV

 Q

CATH S BS=^MCAR(691.1,DA,0),WT=$P(BS,U,7),HT=$P(BS,U,8)

 Q:(WT="")!(HT="")  D COMPUTE S $P(BS,U,9)=X,^MCAR(691.1,DA,0)=BS K BS

B I $D(DJDN) S V(8)=X,DJVV=8 D EN^MCARDNJ1 K DJVV

 Q

RISK S BS=^MCAR(694.5,DA,0),WT=$P(BS,U,7),HT=$P(BS,U,5)

 D RISK1:(WT="")!(HT="")

 Q:(WT="")!(HT="")  D COMPUTE S $P(BS,U,9)=X,^MCAR(694.5,DA,0)=BS K BS

 Q

RISK1 I '$P(BS,U,5),$P(BS,U,6) S HT=$P(BS,U,6)/2.5,$P(BS,U,5)=HT

 I '$P(BS,U,7),$P(BS,U,8) S WT=$P(BS,U,8)*2.2,$P(BS,U,7)=WT

 Q

COMPUTE ;

 S MCARX=WT/2.2 D LN S MCARX=MCARR*0.425 D EXP S MCARW=MCARR

 S MCARX=HT*2.5 D LN S MCARX=MCARR*0.725 D EXP

 S X=(0.0001)*(71.84)*(MCARW*MCARR),X=$J(X,4,2) K MCARR,MCARW,MCARX,WT,HT

 Q

LN ;

 S F=MCARX,(LN,D)=0 Q:MCARX'>0

LN2 I F'<1 S F=.5*F,D=D+1 G LN2

LN3 I F<.5 S F=2*F,D=D-1 G LN3

 S F=(F-.707107)/(F+.707107),LN=F*F

 S LN=(((.598979*LN+.961471)*LN+2.88539)*F+D-.5)*.693147

 S MCARR=LN K LN,D,F Q

EXP ;

 S X=MCARX,E=0,B=1.4427*X\1+1 Q:B>90

 S E=.693147*B-X,A=.00132988-(.000141316*E)

 S A=((A*E-.00830136)*E+.0416574)*E

 S E=(((A-.166665)*E+.5)*E-1)*E+1,A=2

 I B'>0 S A=.5,B=-B

 F I=1:1:B S E=A*E

 S MCARR=+E K A,B,I,E,X Q

MCARBSA   ;WISC/TJK,RCH-COMPUTE BODY SURFACE AREA .001*71.84*((WT/2.2)**.425*(HT*2.5)**.725) ;5/2/96  13:53

 +1       ;;2.3;Medicine;;09/13/1996

 +2        NEW BS

 +3        IF '$DATA(^MCAR(691,DA,13))

               QUIT 

           SET BS=^(13)

           SET WT=$PIECE(BS,U,1)

           SET HT=$PIECE(BS,U,2)

 +4        IF (WT="")!(HT="")

               QUIT 

           DO COMPUTE

           SET $PIECE(BS,U,3)=X

           SET ^MCAR(691,DA,13)=BS

A          IF $DATA(DJDN)

               SET V(7)=X

               SET DJVV=7

               DO EN^MCARDNJ1

               KILL DJVV

 +1        QUIT 

CATH       SET BS=^MCAR(691.1,DA,0)

           SET WT=$PIECE(BS,U,7)

           SET HT=$PIECE(BS,U,8)

 +1        IF (WT="")!(HT="")

               QUIT 

           DO COMPUTE

           SET $PIECE(BS,U,9)=X

           SET ^MCAR(691.1,DA,0)=BS

           KILL BS

B          IF $DATA(DJDN)

               SET V(8)=X

               SET DJVV=8

               DO EN^MCARDNJ1

               KILL DJVV

 +1        QUIT 

RISK       SET BS=^MCAR(694.5,DA,0)

           SET WT=$PIECE(BS,U,7)

           SET HT=$PIECE(BS,U,5)

 +1        IF (WT="")!(HT="")

               DO RISK1

 +2        IF (WT="")!(HT="")

               QUIT 

           DO COMPUTE

           SET $PIECE(BS,U,9)=X

           SET ^MCAR(694.5,DA,0)=BS

           KILL BS

 +3        QUIT 

RISK1      IF '$PIECE(BS,U,5)

               IF $PIECE(BS,U,6)

                   SET HT=$PIECE(BS,U,6)/2.5

                   SET $PIECE(BS,U,5)=HT

 +1        IF '$PIECE(BS,U,7)

               IF $PIECE(BS,U,8)

                   SET WT=$PIECE(BS,U,8)*2.2

                   SET $PIECE(BS,U,7)=WT

 +2        QUIT 

COMPUTE   ;

 +1        SET MCARX=WT/2.2

           DO LN

           SET MCARX=MCARR*0.425

           DO EXP

           SET MCARW=MCARR

 +2        SET MCARX=HT*2.5

           DO LN

           SET MCARX=MCARR*0.725

           DO EXP

 +3        SET X=(0.0001)*(71.84)*(MCARW*MCARR)

           SET X=$JUSTIFY(X,4,2)

           KILL MCARR,MCARW,MCARX,WT,HT

 +4        QUIT 

LN        ;

 +1        SET F=MCARX

           SET (LN,D)=0

           IF MCARX'>0

               QUIT 

LN2        IF F'<1

               SET F=.5*F

               SET D=D+1

               GOTO LN2

LN3        IF F<.5

               SET F=2*F

               SET D=D-1

               GOTO LN3

 +1        SET F=(F-.707107)/(F+.707107)

           SET LN=F*F

 +2        SET LN=(((.598979*LN+.961471)*LN+2.88539)*F+D-.5)*.693147

 +3        SET MCARR=LN

           KILL LN,D,F

           QUIT 

EXP       ;

 +1        SET X=MCARX

           SET E=0

           SET B=1.4427*X\1+1

           IF B>90

               QUIT 

 +2        SET E=.693147*B-X

           SET A=.00132988-(.000141316*E)

 +3        SET A=((A*E-.00830136)*E+.0416574)*E

 +4        SET E=(((A-.166665)*E+.5)*E-1)*E+1

           SET A=2

 +5        IF B'>0

               SET A=.5

               SET B=-B

 +6        FOR I=1:1:B

               SET E=A*E

 +7        SET MCARR=+E

           KILL A,B,I,E,X

           QUIT