BEHOVMC2 ;MSC/IND/MGH - CUMMULATIVE VITALS/MEASUREMENTS CONT ;09-Apr-2010 07:55;PLS
;;1.1;BEH COMPONENTS;**001004,001005**;Mar 20, 2007
;=================================================================
SETLN ; Store the data in the one line
N BEH,ALTU,DEFU,DEFAULT,BEHVER,QUALS,VAL
S BEHVER=^TMP("BEHV",$J,BEHDATE,BEHVTY,BEHVDA) N BEHVPO
D:IOSL<($Y+9) HDR Q:BEHOUT W ! W:BEHVER ?3,"(E)"
I GPRT(BEHVTY)=0 D
. W ?4,BEHVTY_": "
S GPRT(BEHVTY)=1
S BEHDAT=$G(^AUPNVMSR(BEHVDA,0))
S BEHVX=BEHVTY,BEHVX(0)=$P(BEHDAT,"^",4) D
.I "UNAVAILABLEPASSREFUSED"[$$UP^XLFSTR(BEHVX(0)) W ?9,BEHVX(0) Q
.;Get the result
.S TYP=$P(^AUPNVMSR(BEHVDA,0),U),VAL=$P(BEHDAT,U,4),MR=""
. I BEHVTY="PA" D Q
. . I VAL=0 W ?9,VAL_" - No pain" Q
. . I VAL=99 W ?9,VAL_" - Unable to respond" Q
. . I VAL=10 W ?9,VAL_" - Worst imaginable pain" Q
. . S QUALS=$$QUAL(BEHVDA)
. . W ?9,VAL_" "_QUALS
.S:'$G(DAT) DAT=DT
.S AGE=$$PTAGE^BGOUTL(DFN,$S(X:X,1:DAT))
.S BEH="" S BEH=$O(^BEHOVM(90460.01,"B",BEHVTY,BEH))
.I BEHVTY="" D
..W ?9,$$RND(VAL)
.E D
..S DATA=$G(^BEHOVM(90460.01,BEH,0))
..S DEFAULT=$P(DATA,U,2)
..I DEFAULT=1 D
...S DEFU=$P(DATA,U,4),ALTU=$P(DATA,U,3)
...I ALTU=""!(DEFU=ALTU) D
....S QUALS=$$QUAL(BEHVDA)
....W ?9,$$RND(VAL)_" "_DEFU_" "_QUALS
...E S X=VAL I $D(^BEHOVM(90460.01,BEH,2)) X $G(^BEHOVM(90460.01,BEH,2)) D
....S QUALS=$$QUAL(BEHVDA)
....W ?9,$$RND(VAL)_" "_DEFU_" ("_$$RND(X)_" "_ALTU_") "_QUALS
..I DEFAULT=0 D
...S DEFU=$P(DATA,U,3),ALTU=$P(DATA,U,4)
...I ALTU=""!(DEFU=ALTU) D
....S QUALS=$$QUAL(BEHVDA)
....W ?9,$$RND(VAL)_" "_DEFU
...E S X=VAL I $D(^BEHOVM(90460.01,BEH,1)) X $G(^BEHOVM(90460.01,BEH,1)) D
....S QUALS=$$QUAL(BEHVDA)
....W ?9,$$RND(VAL)_" "_DEFU_" ("_$$RND(X)_" "_ALTU_") "_QUALS
..I DEFAULT="" D
...S QUALS=$$QUAL(BEHVDA)
...W ?9,$$RND(VAL)_" "_QUALS
Q:$G(AGE)'>2!'$D(WT)!'$D(HT)
S VAL=$$RND((WT*704.5)/(HT*HT))
S MR=$S(AGE<20:"",VAL<18.5:"Underweight",VAL<25:"Normal Weight",VAL<30:"Overweight",VAL<35:"Obesity - Class 1",VAL<40:"Obesity - Class 2",1:"Extreme Obesity")
W ?9,"BMI: "_VAL_" "_MR
Q
RND(X) Q $S(X=+X:+$J(X,0,2),1:X)
HDR ;
I 'BEH1ST D FOOTER^BEHVSC0
I $E(IOST)'="P",'BEH1ST W "Press return to continue ""^"" to escape " R X:DTIME I X="^"!'$T S BEHOUT=1 Q
W:'($E(IOST)'="C"&'$D(GFLAG)) @IOF S BEHPG=BEHPG+1,GFLAG=1
W !,BEHPDT,?25,"Cumulative Vitals/Measurements Report",?70,"Page ",BEHPG,!!,$E(BEHDSH,1,78)
I 'BEH1ST,$P(BEHDATE,".")=BEHDATE(0) W !,$E(BEHDATE(0),4,5)_"/"_$E(BEHDATE(0),6,7)_"/"_$E(BEHDATE,2,3)_" (continued)",!
S BEH1ST=0
Q
BLNK ;
F I=1:1:$L(Z) Q:$E(Z,I)'=" "
S Z=$E(Z,I,$L(Z))
Q
QUAL(BEHIEN) ;Add on qualifiers
N QUALSTR,MOD,QUAL
S QUALSTR=""
S MOD=0 F S MOD=$O(^AUPNVMSR(BEHIEN,5,MOD)) Q:'+MOD D
.S QUAL=$G(^AUPNVMSR(BEHIEN,5,MOD,0))
.S QUAL=$P($G(^GMRD(120.52,QUAL,0)),U,1)
.S QUALSTR=QUALSTR_$S(QUALSTR'="":", ",1:"")_QUAL
Q QUALSTR
BEHOVMC2 ;MSC/IND/MGH - CUMMULATIVE VITALS/MEASUREMENTS CONT ;09-Apr-2010 07:55;PLS
+1 ;;1.1;BEH COMPONENTS;**001004,001005**;Mar 20, 2007
+2 ;=================================================================
SETLN ; Store the data in the one line
+1 NEW BEH,ALTU,DEFU,DEFAULT,BEHVER,QUALS,VAL
+2 SET BEHVER=^TMP("BEHV",$JOB,BEHDATE,BEHVTY,BEHVDA)
NEW BEHVPO
+3 IF IOSL<($Y+9)
DO HDR
IF BEHOUT
QUIT
WRITE !
IF BEHVER
WRITE ?3,"(E)"
+4 IF GPRT(BEHVTY)=0
Begin DoDot:1
+5 WRITE ?4,BEHVTY_": "
End DoDot:1
+6 SET GPRT(BEHVTY)=1
+7 SET BEHDAT=$GET(^AUPNVMSR(BEHVDA,0))
+8 SET BEHVX=BEHVTY
SET BEHVX(0)=$PIECE(BEHDAT,"^",4)
Begin DoDot:1
+9 IF "UNAVAILABLEPASSREFUSED"[$$UP^XLFSTR(BEHVX(0))
WRITE ?9,BEHVX(0)
QUIT
+10 ;Get the result
+11 SET TYP=$PIECE(^AUPNVMSR(BEHVDA,0),U)
SET VAL=$PIECE(BEHDAT,U,4)
SET MR=""
+12 IF BEHVTY="PA"
Begin DoDot:2
+13 IF VAL=0
WRITE ?9,VAL_" - No pain"
QUIT
+14 IF VAL=99
WRITE ?9,VAL_" - Unable to respond"
QUIT
+15 IF VAL=10
WRITE ?9,VAL_" - Worst imaginable pain"
QUIT
+16 SET QUALS=$$QUAL(BEHVDA)
+17 WRITE ?9,VAL_" "_QUALS
End DoDot:2
QUIT
+18 IF '$GET(DAT)
SET DAT=DT
+19 SET AGE=$$PTAGE^BGOUTL(DFN,$SELECT(X:X,1:DAT))
+20 SET BEH=""
SET BEH=$ORDER(^BEHOVM(90460.01,"B",BEHVTY,BEH))
+21 IF BEHVTY=""
Begin DoDot:2
+22 WRITE ?9,$$RND(VAL)
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET DATA=$GET(^BEHOVM(90460.01,BEH,0))
+25 SET DEFAULT=$PIECE(DATA,U,2)
+26 IF DEFAULT=1
Begin DoDot:3
+27 SET DEFU=$PIECE(DATA,U,4)
SET ALTU=$PIECE(DATA,U,3)
+28 IF ALTU=""!(DEFU=ALTU)
Begin DoDot:4
+29 SET QUALS=$$QUAL(BEHVDA)
+30 WRITE ?9,$$RND(VAL)_" "_DEFU_" "_QUALS
End DoDot:4
+31 IF '$TEST
SET X=VAL
IF $DATA(^BEHOVM(90460.01,BEH,2))
XECUTE $GET(^BEHOVM(90460.01,BEH,2))
Begin DoDot:4
+32 SET QUALS=$$QUAL(BEHVDA)
+33 WRITE ?9,$$RND(VAL)_" "_DEFU_" ("_$$RND(X)_" "_ALTU_") "_QUALS
End DoDot:4
End DoDot:3
+34 IF DEFAULT=0
Begin DoDot:3
+35 SET DEFU=$PIECE(DATA,U,3)
SET ALTU=$PIECE(DATA,U,4)
+36 IF ALTU=""!(DEFU=ALTU)
Begin DoDot:4
+37 SET QUALS=$$QUAL(BEHVDA)
+38 WRITE ?9,$$RND(VAL)_" "_DEFU
End DoDot:4
+39 IF '$TEST
SET X=VAL
IF $DATA(^BEHOVM(90460.01,BEH,1))
XECUTE $GET(^BEHOVM(90460.01,BEH,1))
Begin DoDot:4
+40 SET QUALS=$$QUAL(BEHVDA)
+41 WRITE ?9,$$RND(VAL)_" "_DEFU_" ("_$$RND(X)_" "_ALTU_") "_QUALS
End DoDot:4
End DoDot:3
+42 IF DEFAULT=""
Begin DoDot:3
+43 SET QUALS=$$QUAL(BEHVDA)
+44 WRITE ?9,$$RND(VAL)_" "_QUALS
End DoDot:3
End DoDot:2
End DoDot:1
+45 IF $GET(AGE)'>2!'$DATA(WT)!'$DATA(HT)
QUIT
+46 SET VAL=$$RND((WT*704.5)/(HT*HT))
+47 SET MR=$SELECT(AGE<20:"",VAL<18.5:"Underweight",VAL<25:"Normal Weight",VAL<30:"Overweight",VAL<35:"Obesity - Class 1",VAL<40:"Obesity - Class 2",1:"Extreme Obesity")
+48 WRITE ?9,"BMI: "_VAL_" "_MR
+49 QUIT
RND(X) QUIT $SELECT(X=+X:+$JUSTIFY(X,0,2),1:X)
HDR ;
+1 IF 'BEH1ST
DO FOOTER^BEHVSC0
+2 IF $EXTRACT(IOST)'="P"
IF 'BEH1ST
WRITE "Press return to continue ""^"" to escape "
READ X:DTIME
IF X="^"!'$TEST
SET BEHOUT=1
QUIT
+3 IF '($EXTRACT(IOST)'="C"&'$DATA(GFLAG))
WRITE @IOF
SET BEHPG=BEHPG+1
SET GFLAG=1
+4 WRITE !,BEHPDT,?25,"Cumulative Vitals/Measurements Report",?70,"Page ",BEHPG,!!,$EXTRACT(BEHDSH,1,78)
+5 IF 'BEH1ST
IF $PIECE(BEHDATE,".")=BEHDATE(0)
WRITE !,$EXTRACT(BEHDATE(0),4,5)_"/"_$EXTRACT(BEHDATE(0),6,7)_"/"_$EXTRACT(BEHDATE,2,3)_" (continued)",!
+6 SET BEH1ST=0
+7 QUIT
BLNK ;
+1 FOR I=1:1:$LENGTH(Z)
IF $EXTRACT(Z,I)'=" "
QUIT
+2 SET Z=$EXTRACT(Z,I,$LENGTH(Z))
+3 QUIT
QUAL(BEHIEN) ;Add on qualifiers
+1 NEW QUALSTR,MOD,QUAL
+2 SET QUALSTR=""
+3 SET MOD=0
FOR
SET MOD=$ORDER(^AUPNVMSR(BEHIEN,5,MOD))
IF '+MOD
QUIT
Begin DoDot:1
+4 SET QUAL=$GET(^AUPNVMSR(BEHIEN,5,MOD,0))
+5 SET QUAL=$PIECE($GET(^GMRD(120.52,QUAL,0)),U,1)
+6 SET QUALSTR=QUALSTR_$SELECT(QUALSTR'="":", ",1:"")_QUAL
End DoDot:1
+7 QUIT QUALSTR
