- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARBSA 1460 printed Feb 18, 2025@23:38:50 Page 2
- 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
