- 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
