FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08
;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1
W @IOF,!!?20,"N U T R I T I O N A S S E S S M E N T",!! S X="T",%DT="X" D ^%DT S DT=+Y
F1 ; Select Patient
S FHALL=1 D ^FHOMDPA G KILL^XUSCLEAN:'FHDFN
S:DFN'>0 DFN=""
I $G(DFN),$P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KILL^XUSCLEAN
S (ADM,ASN,FHASK,KNEE,EXT,DTP,FHCAS,FHCASD,FHASS,FHFFC,FHFEC,FHFPC,FHCFRBO,FHCM,FHEF,FHKCAL,FHLOC)="",(FHHWF,FHQUIT)=0
S (ADT,SEX,AGE,HGT,HGP,WGT,WGP,DWGT,UWGT,IBW,FRM,AMP,KCAL,PRO,FLD,RC,XD,BMI,BMIP,FHCLI,FHPLXSV)=""
S (NOW,NB,TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,FHAPP,FHEDU,DEWGT,WARD,FHSPC)=""
S (FHDIPL,FHDIPLD,FHAST,FHDINF,FHDINFD,FHFUD,FHDIST,FHDIDI,FHDITF,FHDIDI,FHDITF,FHDITFDT,FHDITFCM,FHDITFML,FHDITFKC,FHVHGT,FHDVHGT)=""
S (TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,BMI,BMIP,X1,X2,FHFUDS,EKKG,FHFDC,FHFDCSV)=""
S (WCCM,CIBW,CERBO,CENB,PCTB,SEF,CFRB,CFRBO,CPRBO,NWGT,DNWGT,FHYN,FHDINA,FHVWGT,FHDVWGT,FHPL)=""
S FHCLI=DUZ
K ^TMP("FH",$J) S FHQTALL=0
;get current diet and tf
S Y=""
I DFN D
.F I=0:0 S I=$O(^FHPT("AW",I)) Q:I'>0 I $D(^FHPT("AW",I,FHDFN)) S FHLOC=I Q
.I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHCLI=$P($G(^FH(119.6,FHLOC,0)),U,2)
.S WARD=$G(^DPT(DFN,.1)) I WARD'="" S ADM=$G(^DPT("CN",WARD,DFN))
.I ADM D CUR^FHORD7 S X1=""
.S FHDIDI=$S(Y'="":Y,1:"No Order")
.W !,"Current Diet: ",FHDIDI
.Q:'ADM
.S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4)
.Q:'TF
.S FHDITFDT=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,1)
.S FHDITFCM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,5)
.S FHDITFML=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,6)
.S FHDITFKC=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,7)
.F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 D
..S Y=^(TF2,0),TUN=$P(Y,"^",1)
..I TUN,$D(^FH(118.2,TUN,0)) S FHDITFPR(TUN)=Y
.W ?30,"Tubefeeding: " I $D(FHDITFPR) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 W $P($G(^FH(118.2,FHTUN,0)),"^",1) I $O(FHDITFPR(FHTUN))'="" W ", "
K Y
STA ;if pt has Work in Progress assessment, ask user to Edit or Create or Delete Assessment.
D PATNAME^FHOMUTL
S AGE=FHAGE
I $D(^FHPT(FHDFN,"N",0)) D
.S FHCAS=$P(^FHPT(FHDFN,"N",0),U,3)
.Q:'FHCAS
.S FHCASD=$P(^FHPT(FHDFN,"N",FHCAS,0),U,1)
.I $D(^FHPT(FHDFN,"N",FHCAS,"DI")) S FHASS=$P($G(^FHPT(FHDFN,"N",FHCAS,"DI")),U,6)
.S FHAST=0
.F FHA=0:0 S FHA=$O(^FHPT(FHDFN,"N",FHA)) Q:'FHA D
..S FHASSD=$P($G(^FHPT(FHDFN,"N",FHA,"DI")),U,6)
..I (FHASSD="W")!(FHASS="") S FHAST=1
..I $D(^FHPT(FHDFN,"N",FHA,0)),'$D(^FHPT(FHDFN,"N",FHA,"DI")) S FHAST=1
I 'FHCAS!(FHAST=0) G CRE
D ASK^FHASM2 G:FHQUIT KILL^XUSCLEAN
I FHASK="D" S DIK="^FHPT("_FHDFN_",""N"",",DA(1)=FHDFN,DA=FHCAS D ^DIK W ?65,"Deleted..." G F1
I FHASK="E" S ADT=FHCAS D SVAR G:SEX=""!(AGE="") P1 G F3A
CRE ;create new assessment
;D:FHCAS PRTA^FHASM2
S FHASK="C"
W !!,"Creating new Assessment...",!
I (FHSEX="")!(FHAGE="") G P1
E S NAM=FHPTNM,SEX=FHSEX,AGE=FHAGE
S X="NOW",%DT="XT" D ^%DT S ADT=Y
I SEX=""!(AGE="") G P1
F2 S X="NOW",%DT="XT" D ^%DT S ADT=Y
F3 I DFN,$D(^FHPT(FHDFN,"N",9999999-ADT)) S ADT=$$FMADD^XLFDT(ADT,,,1) G F3
F3A ;start here if edit
S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1),NAM=FHPTNM
G:'FHDFN F4 S XX=$O(^FHPT(FHDFN,"N",0)) G:XX="" F4 S XX=$G(^(XX,0)),HGT=$P(XX,"^",4),HGP=$P(XX,"^",5)
I HGP'="S" S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_"CM",X1=$S(FHU'="M":X1,1:X2)
F4 ; If Multidivisional site Select Communications Office
S FHCOMM="" I $P($G(^FH(119.9,1,0)),U,20)'="N" D I FHCOMM="" Q
.K DIC S DIC="^FH(119.73," S DIC(0)="AEMQ" D ^DIC
.I Y=-1 Q
.S FHCOMM=+Y
;get ht and wt from vitals.
I DFN S GMRVSTR="WT" D EN6^GMRVUTL S FHDVWGT=$P(X,"^",1),FHVWGT=$P(X,"^",8),GMRVSTR="HT" D EN6^GMRVUTL S FHVHGT=$P(X,"^",8)
I X1="" S (X1,HGT)=FHVHGT
F4A W !!,"Height: " W:X1'="" X1,"// " R X:DTIME G:'$T!(X["^") KIL I X="",X1'="" S Y0=$J(HGT,0,0),H1=Y0 G F5
D TR,HGT I Y<1 D HGP G F4A
S:X1'=Y FHHWF=1
S HGT=Y,H1=Y0,HGP=Y1
F5 I FHVWGT'="" S WGT=FHVWGT
W !!,"Weight: " W:WGT'="" WGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="",WGT S X=WGT_"#"
S:X="a" X="A"
I X="A",AGE>39 D A^FHASM2D G:Y<1 F5 S:WGT'=Y FHHWF=1 S WGT=Y,WGP="A" G F6
D WGT I Y<1 D WGP W:AGE>39 !,"You may enter an A to calculate weight anthropometrically." G F5
S:WGT'=Y FHHWF=1
S WGT=Y,WGP=Y1 I FHDVWGT'="" S DWGT=$P(FHDVWGT,".",1)
F6 G:'FHHWF F7
S %DT="AEP",%DT("A")="Date Weight Taken: "
I 'DWGT,FHDVWGT S DTP=$E(FHDVWGT,4,5)_"/"_$E(FHDVWGT,6,7)_"/"_$E(FHDVWGT,2,3)
I DWGT S DTP=$E(DWGT,4,5)_"/"_$E(DWGT,6,7)_"/"_$E(DWGT,2,3)
S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY"
S %DT(0)="-T" W ! D ^%DT K %DT G KIL:X["^"!$D(DTOUT),F6:Y<1
S DWGT=Y
;
F7 S:UWGT X=UWGT W !!,"Usual Weight: " W:UWGT'="" UWGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="" G F8
D WGT I Y<1 D WGP G F7
S UWGT=Y
F8 K %DT,A1,K,X,Y G ^FHASM2
HGT ; Convert Height to inches
S A1=+X I 'A1 S Y=-1 Q
S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SMK"[$E(X,1) S Y=A1 S:FHU="M" Y=Y/2.54 G H1
I """I"[$E(X,1) S Y=A1 G H1
I $E(X,1)="C" S Y=A1/2.54 G H1
I "'F"'[$E(X,1) S Y=-1 G H2
S Y=A1*12 F K=1:1 Q:$E(X,K)?.N
I $E(X,K,99)="" G H1
S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99)
I """I"'[$E(X,1) S Y=-1 G H2
S Y=Y+A1
H1 I X["K" D K^FHASM2D
H2 I Y<12!(Y>96) S Y=-1
S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1=$S(X["K":"K",X["S":"S",1:"") Q
HGP ; Height Help
W !!,"Enter height as: 6' 2"" or 74"" or 74IN or 6FT 2 IN or 30CM"
W !,"Add an S if height is stated rather than measured."
W !,"Add a K if value is a Knee Height measurement."
W !,"Height should be between 12"" and 96"" (8')." Q
WGT ; Convert Weight to lbs.
D TR S A1=+X I 'A1 S Y=-1 Q
S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SM"[$E(X,1) S Y=A1 S:FHU="M" Y=Y*2.2 G W1
I $E(X,1)="O" S Y=A1/16 G W1
I $E(X,1)="G" S Y=A1/1000*2.2 G W1
I $E(X,1)="K" S Y=A1*2.2 G W1
I "L#"'[$E(X,1) S Y=-1 G W1
S Y=A1 F K=1:1 Q:$E(X,K)?.N
I $E(X,K,99)="" G W1
S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99)
I $E(X,1)'="O" S Y=-1 G W1
S Y=A1/16+Y
W1 I Y<0!(Y>750) S Y=-1
S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1="" S:X["S" Y1="S" Q
WGP ; Weight help
W !!,"Enter Weight as 150# or 150# 6OZ or 800G or 70KG"
W !,"Add an S if weight is stated rather than measured."
W !,"Enter an A to determine weight anthropometrically."
W !,"Weight should be between 0 Lbs and 750 Lbs." Q
TR ; Translate Lower to Upper Case
D TR^FH
Q
KIL ; Final variable kill
;if X not equal ^, update or create nutrition assessment
G:$G(FHQUIT) ASKUS
I $D(X),X=U G ASKUS
D SDAT^FHASM7
;
G KILL^XUSCLEAN
PAT S (FHDFN,DFN,SEX,AGE,PID)="" R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!(NAM["^") KILL^XUSCLEAN
I NAM["?"!(NAM'?.ANP)!(NAM="") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT
P1 I SEX="" R !,"Sex: ",SEX:DTIME S:SEX="" SEX="?" G:'$T!(SEX["^") KILL^XUSCLEAN S X=SEX D TR S SEX=X I $P("FEMALE",SEX,1)'="",$P("MALE",SEX,1)'="" W *7," Enter M or F" S SEX="" G P1
S SEX=$E(SEX,1)
P2 I AGE="" R !,"Age: ",AGE:DTIME S:AGE="" AGE="?" G:'$T!(AGE["^") KILL^XUSCLEAN S X=AGE D TR S AGE=X
S:AGE["M" AGE=+$J($P(AGE,"M",1)/12,0,2) I AGE'>0!(AGE>124) W !?5,"Enter Age Less Than 124 in Years or Months (followed by M) but Not Both" S AGE="" G P2
G F2
SVAR ;set variables of incomplete assessment.
Q:'$D(^FHPT(FHDFN,"N",0))
S FHA0=$G(^FHPT(FHDFN,"N",FHCAS,0))
S ADT=$P(FHA0,U,1),SEX=$P(FHA0,U,2),AGE=$P(FHA0,U,3),HGT=$P(FHA0,U,4)
S HGP=$P(FHA0,U,5),WGT=$P(FHA0,U,6),WGP=$P(FHA0,U,7),DWGT=$P(FHA0,U,8)
S UWGT=$P(FHA0,U,9),IBW=$P(FHA0,U,10),FRM=$P(FHA0,U,11),AMP=$P(FHA0,U,12)
S KCAL=$P(FHA0,U,16),PRO=$P(FHA0,U,17),FLD=$P(FHA0,U,18),RC=$P(FHA0,U,19)
S XD=$P(FHA0,U,20),BMI=$P(FHA0,U,21),BMIP=$P(FHA0,U,22)
S NOW=$P(FHA0,U,24),NB=$P(FHA0,U,25)
S FHA1=$G(^FHPT(FHDFN,"N",FHCAS,1))
S TSF=$P(FHA1,U,1),TSFP=$P(FHA1,U,2),SCA=$P(FHA1,U,3),SCAP=$P(FHA1,U,4),ACIR=$P(FHA1,U,5)
S ACIRP=$P(FHA1,U,6),CCIR=$P(FHA1,U,7),CCIRP=$P(FHA1,U,8),BFAMA=$P(FHA1,U,9),BFAMAP=$P(FHA1,U,10)
S WCCM=$P(FHA1,U,11),CIBW=$P(FHA1,U,12),CERBO=$P(FHA1,U,13),CENB=$P(FHA1,U,14),PCTB=$P(FHA1,U,15)
S SEF=$P(FHA1,U,16),CFRB=$P(FHA1,U,17),CFRBO=$P(FHA1,U,18),CPRBO=$P(FHA1,U,19),EKKG=$P(FHA1,U,20)
S FHAPP=$G(^FHPT(FHDFN,"N",FHCAS,2))
S FHA3=$G(^FHPT(FHDFN,"N",FHCAS,3))
S FHYN=$P(FHA3,U,1),FHFEC=$P(FHA3,U,2),FHFPC=$P(FHA3,U,3),FHDINA=$P(FHA3,U,4),FHEDU=$P(FHA3,U,5)
S FHFDCSV=$P(FHA3,U,6),FHPL=$P(FHA3,U,7),FHSPC=$P(FHA3,U,8)
S FHADI=$G(^FHPT(FHDFN,"N",FHCAS,"DI"))
S FHDIPL=$P(FHADI,U,1),FHDIPLD=$P(FHADI,U,2),FHDINF=$P(FHADI,U,3),FHDINFD=$P(FHADI,U,4)
S (FHFUD,FHFUDS)=$P(FHADI,U,5),FHDIST=$P(FHADI,U,6),FHDIDI=$P(FHADI,U,7),FHDITF=$P(FHADI,U,8)
Q
ASKUS R !!,"Do you wish to SAVE this Assessment Y// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN
S:X="" X="Y" D TR I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G ASKUS
I X'?1"Y".E G KILL^XUSCLEAN
D SDAT^FHASM7 G KILL^XUSCLEAN
FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08
+1 ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1
+2 WRITE @IOF,!!?20,"N U T R I T I O N A S S E S S M E N T",!!
SET X="T"
SET %DT="X"
DO ^%DT
SET DT=+Y
F1 ; Select Patient
+1 SET FHALL=1
DO ^FHOMDPA
IF 'FHDFN
GOTO KILL^XUSCLEAN
+2 IF DFN'>0
SET DFN=""
+3 IF $GET(DFN)
IF $PIECE($GET(^DPT(DFN,.35)),"^",1)
WRITE *7,!!?5," [ Patient has expired. ]"
GOTO KILL^XUSCLEAN
+4 SET (ADM,ASN,FHASK,KNEE,EXT,DTP,FHCAS,FHCASD,FHASS,FHFFC,FHFEC,FHFPC,FHCFRBO,FHCM,FHEF,FHKCAL,FHLOC)=""
SET (FHHWF,FHQUIT)=0
+5 SET (ADT,SEX,AGE,HGT,HGP,WGT,WGP,DWGT,UWGT,IBW,FRM,AMP,KCAL,PRO,FLD,RC,XD,BMI,BMIP,FHCLI,FHPLXSV)=""
+6 SET (NOW,NB,TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,FHAPP,FHEDU,DEWGT,WARD,FHSPC)=""
+7 SET (FHDIPL,FHDIPLD,FHAST,FHDINF,FHDINFD,FHFUD,FHDIST,FHDIDI,FHDITF,FHDIDI,FHDITF,FHDITFDT,FHDITFCM,FHDITFML,FHDITFKC,FHVHGT,FHDVHGT)=""
+8 SET (TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,BMI,BMIP,X1,X2,FHFUDS,EKKG,FHFDC,FHFDCSV)=""
+9 SET (WCCM,CIBW,CERBO,CENB,PCTB,SEF,CFRB,CFRBO,CPRBO,NWGT,DNWGT,FHYN,FHDINA,FHVWGT,FHDVWGT,FHPL)=""
+10 SET FHCLI=DUZ
+11 KILL ^TMP("FH",$JOB)
SET FHQTALL=0
+12 ;get current diet and tf
+13 SET Y=""
+14 IF DFN
Begin DoDot:1
+15 FOR I=0:0
SET I=$ORDER(^FHPT("AW",I))
IF I'>0
QUIT
IF $DATA(^FHPT("AW",I,FHDFN))
SET FHLOC=I
QUIT
+16 IF $GET(FHLOC)
IF $DATA(^FH(119.6,FHLOC,0))
SET FHCLI=$PIECE($GET(^FH(119.6,FHLOC,0)),U,2)
+17 SET WARD=$GET(^DPT(DFN,.1))
IF WARD'=""
SET ADM=$GET(^DPT("CN",WARD,DFN))
+18 IF ADM
DO CUR^FHORD7
SET X1=""
+19 SET FHDIDI=$SELECT(Y'="":Y,1:"No Order")
+20 WRITE !,"Current Diet: ",FHDIDI
+21 IF 'ADM
QUIT
+22 SET TF=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",4)
+23 IF 'TF
QUIT
+24 SET FHDITFDT=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,1)
+25 SET FHDITFCM=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,5)
+26 SET FHDITFML=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,6)
+27 SET FHDITFKC=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,7)
+28 FOR TF2=0:0
SET TF2=$ORDER(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2))
IF TF2<1
QUIT
Begin DoDot:2
+29 SET Y=^(TF2,0)
SET TUN=$PIECE(Y,"^",1)
+30 IF TUN
IF $DATA(^FH(118.2,TUN,0))
SET FHDITFPR(TUN)=Y
End DoDot:2
+31 WRITE ?30,"Tubefeeding: "
IF $DATA(FHDITFPR)
FOR FHTUN=0:0
SET FHTUN=$ORDER(FHDITFPR(FHTUN))
IF FHTUN'>0
QUIT
WRITE $PIECE($GET(^FH(118.2,FHTUN,0)),"^",1)
IF $ORDER(FHDITFPR(FHTUN))'=""
WRITE ", "
End DoDot:1
+32 KILL Y
STA ;if pt has Work in Progress assessment, ask user to Edit or Create or Delete Assessment.
+1 DO PATNAME^FHOMUTL
+2 SET AGE=FHAGE
+3 IF $DATA(^FHPT(FHDFN,"N",0))
Begin DoDot:1
+4 SET FHCAS=$PIECE(^FHPT(FHDFN,"N",0),U,3)
+5 IF 'FHCAS
QUIT
+6 SET FHCASD=$PIECE(^FHPT(FHDFN,"N",FHCAS,0),U,1)
+7 IF $DATA(^FHPT(FHDFN,"N",FHCAS,"DI"))
SET FHASS=$PIECE($GET(^FHPT(FHDFN,"N",FHCAS,"DI")),U,6)
+8 SET FHAST=0
+9 FOR FHA=0:0
SET FHA=$ORDER(^FHPT(FHDFN,"N",FHA))
IF 'FHA
QUIT
Begin DoDot:2
+10 SET FHASSD=$PIECE($GET(^FHPT(FHDFN,"N",FHA,"DI")),U,6)
+11 IF (FHASSD="W")!(FHASS="")
SET FHAST=1
+12 IF $DATA(^FHPT(FHDFN,"N",FHA,0))
IF '$DATA(^FHPT(FHDFN,"N",FHA,"DI"))
SET FHAST=1
End DoDot:2
End DoDot:1
+13 IF 'FHCAS!(FHAST=0)
GOTO CRE
+14 DO ASK^FHASM2
IF FHQUIT
GOTO KILL^XUSCLEAN
+15 IF FHASK="D"
SET DIK="^FHPT("_FHDFN_",""N"","
SET DA(1)=FHDFN
SET DA=FHCAS
DO ^DIK
WRITE ?65,"Deleted..."
GOTO F1
+16 IF FHASK="E"
SET ADT=FHCAS
DO SVAR
IF SEX=""!(AGE="")
GOTO P1
GOTO F3A
CRE ;create new assessment
+1 ;D:FHCAS PRTA^FHASM2
+2 SET FHASK="C"
+3 WRITE !!,"Creating new Assessment...",!
+4 IF (FHSEX="")!(FHAGE="")
GOTO P1
+5 IF '$TEST
SET NAM=FHPTNM
SET SEX=FHSEX
SET AGE=FHAGE
+6 SET X="NOW"
SET %DT="XT"
DO ^%DT
SET ADT=Y
+7 IF SEX=""!(AGE="")
GOTO P1
F2 SET X="NOW"
SET %DT="XT"
DO ^%DT
SET ADT=Y
F3 IF DFN
IF $DATA(^FHPT(FHDFN,"N",9999999-ADT))
SET ADT=$$FMADD^XLFDT(ADT,,,1)
GOTO F3
F3A ;start here if edit
+1 SET FHAP=$GET(^FH(119.9,1,3))
SET FHU=$PIECE(FHAP,"^",1)
SET NAM=FHPTNM
+2 IF 'FHDFN
GOTO F4
SET XX=$ORDER(^FHPT(FHDFN,"N",0))
IF XX=""
GOTO F4
SET XX=$GET(^(XX,0))
SET HGT=$PIECE(XX,"^",4)
SET HGP=$PIECE(XX,"^",5)
+3 IF HGP'="S"
SET X1=$SELECT(HGT\12:HGT\12_"'",1:"")_$SELECT(HGT#12:" "_(HGT#12)_"""",1:"")
SET X2=+$JUSTIFY(HGT*2.54,0,0)_"CM"
SET X1=$SELECT(FHU'="M":X1,1:X2)
F4 ; If Multidivisional site Select Communications Office
+1 SET FHCOMM=""
IF $PIECE($GET(^FH(119.9,1,0)),U,20)'="N"
Begin DoDot:1
+2 KILL DIC
SET DIC="^FH(119.73,"
SET DIC(0)="AEMQ"
DO ^DIC
+3 IF Y=-1
QUIT
+4 SET FHCOMM=+Y
End DoDot:1
IF FHCOMM=""
QUIT
+5 ;get ht and wt from vitals.
+6 IF DFN
SET GMRVSTR="WT"
DO EN6^GMRVUTL
SET FHDVWGT=$PIECE(X,"^",1)
SET FHVWGT=$PIECE(X,"^",8)
SET GMRVSTR="HT"
DO EN6^GMRVUTL
SET FHVHGT=$PIECE(X,"^",8)
+7 IF X1=""
SET (X1,HGT)=FHVHGT
F4A WRITE !!,"Height: "
IF X1'=""
WRITE X1,"// "
READ X:DTIME
IF '$TEST!(X["^")
GOTO KIL
IF X=""
IF X1'=""
SET Y0=$JUSTIFY(HGT,0,0)
SET H1=Y0
GOTO F5
+1 DO TR
DO HGT
IF Y<1
DO HGP
GOTO F4A
+2 IF X1'=Y
SET FHHWF=1
+3 SET HGT=Y
SET H1=Y0
SET HGP=Y1
F5 IF FHVWGT'=""
SET WGT=FHVWGT
+1 WRITE !!,"Weight: "
IF WGT'=""
WRITE WGT_" lbs","// "
READ X:DTIME
IF '$TEST!(X["^")
GOTO KIL
IF X=""
IF WGT
SET X=WGT_"#"
+2 IF X="a"
SET X="A"
+3 IF X="A"
IF AGE>39
DO A^FHASM2D
IF Y<1
GOTO F5
IF WGT'=Y
SET FHHWF=1
SET WGT=Y
SET WGP="A"
GOTO F6
+4 DO WGT
IF Y<1
DO WGP
IF AGE>39
WRITE !,"You may enter an A to calculate weight anthropometrically."
GOTO F5
+5 IF WGT'=Y
SET FHHWF=1
+6 SET WGT=Y
SET WGP=Y1
IF FHDVWGT'=""
SET DWGT=$PIECE(FHDVWGT,".",1)
F6 IF 'FHHWF
GOTO F7
+1 SET %DT="AEP"
SET %DT("A")="Date Weight Taken: "
+2 IF 'DWGT
IF FHDVWGT
SET DTP=$EXTRACT(FHDVWGT,4,5)_"/"_$EXTRACT(FHDVWGT,6,7)_"/"_$EXTRACT(FHDVWGT,2,3)
+3 IF DWGT
SET DTP=$EXTRACT(DWGT,4,5)_"/"_$EXTRACT(DWGT,6,7)_"/"_$EXTRACT(DWGT,2,3)
+4 IF DTP'=""
SET %DT("B")=DTP
IF DTP=""
SET %DT("B")="TODAY"
+5 SET %DT(0)="-T"
WRITE !
DO ^%DT
KILL %DT
IF X["^"!$DATA(DTOUT)
GOTO KIL
IF Y<1
GOTO F6
+6 SET DWGT=Y
+7 ;
F7 IF UWGT
SET X=UWGT
WRITE !!,"Usual Weight: "
IF UWGT'=""
WRITE UWGT_" lbs","// "
READ X:DTIME
IF '$TEST!(X["^")
GOTO KIL
IF X=""
GOTO F8
+1 DO WGT
IF Y<1
DO WGP
GOTO F7
+2 SET UWGT=Y
F8 KILL %DT,A1,K,X,Y
GOTO ^FHASM2
HGT ; Convert Height to inches
+1 SET A1=+X
IF 'A1
SET Y=-1
QUIT
+2 SET X=$PIECE(X,A1,2,99)
IF $EXTRACT(X,1)=" "
SET X=$EXTRACT(X,2,99)
IF "SMK"[$EXTRACT(X,1)
SET Y=A1
IF FHU="M"
SET Y=Y/2.54
GOTO H1
+3 IF """I"[$EXTRACT(X,1)
SET Y=A1
GOTO H1
+4 IF $EXTRACT(X,1)="C"
SET Y=A1/2.54
GOTO H1
+5 IF "'F"'[$EXTRACT(X,1)
SET Y=-1
GOTO H2
+6 SET Y=A1*12
FOR K=1:1
IF $EXTRACT(X,K)?.N
QUIT
+7 IF $EXTRACT(X,K,99)=""
GOTO H1
+8 SET A1=+$EXTRACT(X,K,99)
SET X=$PIECE(X,A1,2,99)
IF $EXTRACT(X,1)=" "
SET X=$EXTRACT(X,2,99)
+9 IF """I"'[$EXTRACT(X,1)
SET Y=-1
GOTO H2
+10 SET Y=Y+A1
H1 IF X["K"
DO K^FHASM2D
H2 IF Y<12!(Y>96)
SET Y=-1
+1 IF Y>0
SET Y0=+$JUSTIFY(Y,0,0)
SET Y=+$JUSTIFY(Y,0,1)
SET Y1=$SELECT(X["K":"K",X["S":"S",1:"")
QUIT
HGP ; Height Help
+1 WRITE !!,"Enter height as: 6' 2"" or 74"" or 74IN or 6FT 2 IN or 30CM"
+2 WRITE !,"Add an S if height is stated rather than measured."
+3 WRITE !,"Add a K if value is a Knee Height measurement."
+4 WRITE !,"Height should be between 12"" and 96"" (8')."
QUIT
WGT ; Convert Weight to lbs.
+1 DO TR
SET A1=+X
IF 'A1
SET Y=-1
QUIT
+2 SET X=$PIECE(X,A1,2,99)
IF $EXTRACT(X,1)=" "
SET X=$EXTRACT(X,2,99)
IF "SM"[$EXTRACT(X,1)
SET Y=A1
IF FHU="M"
SET Y=Y*2.2
GOTO W1
+3 IF $EXTRACT(X,1)="O"
SET Y=A1/16
GOTO W1
+4 IF $EXTRACT(X,1)="G"
SET Y=A1/1000*2.2
GOTO W1
+5 IF $EXTRACT(X,1)="K"
SET Y=A1*2.2
GOTO W1
+6 IF "L#"'[$EXTRACT(X,1)
SET Y=-1
GOTO W1
+7 SET Y=A1
FOR K=1:1
IF $EXTRACT(X,K)?.N
QUIT
+8 IF $EXTRACT(X,K,99)=""
GOTO W1
+9 SET A1=+$EXTRACT(X,K,99)
SET X=$PIECE(X,A1,2,99)
IF $EXTRACT(X,1)=" "
SET X=$EXTRACT(X,2,99)
+10 IF $EXTRACT(X,1)'="O"
SET Y=-1
GOTO W1
+11 SET Y=A1/16+Y
W1 IF Y<0!(Y>750)
SET Y=-1
+1 IF Y>0
SET Y0=+$JUSTIFY(Y,0,0)
SET Y=+$JUSTIFY(Y,0,1)
SET Y1=""
IF X["S"
SET Y1="S"
QUIT
WGP ; Weight help
+1 WRITE !!,"Enter Weight as 150# or 150# 6OZ or 800G or 70KG"
+2 WRITE !,"Add an S if weight is stated rather than measured."
+3 WRITE !,"Enter an A to determine weight anthropometrically."
+4 WRITE !,"Weight should be between 0 Lbs and 750 Lbs."
QUIT
TR ; Translate Lower to Upper Case
+1 DO TR^FH
+2 QUIT
KIL ; Final variable kill
+1 ;if X not equal ^, update or create nutrition assessment
+2 IF $GET(FHQUIT)
GOTO ASKUS
+3 IF $DATA(X)
IF X=U
GOTO ASKUS
+4 DO SDAT^FHASM7
+5 ;
+6 GOTO KILL^XUSCLEAN
PAT SET (FHDFN,DFN,SEX,AGE,PID)=""
READ !!,"Enter Patient's Name: ",NAM:DTIME
IF '$TEST!(NAM["^")
GOTO KILL^XUSCLEAN
+1 IF NAM["?"!(NAM'?.ANP)!(NAM="")
WRITE *7,!?5,"Enter Patient's Name to be printed on the report."
GOTO PAT
P1 IF SEX=""
READ !,"Sex: ",SEX:DTIME
IF SEX=""
SET SEX="?"
IF '$TEST!(SEX["^")
GOTO KILL^XUSCLEAN
SET X=SEX
DO TR
SET SEX=X
IF $PIECE("FEMALE",SEX,1)'=""
IF $PIECE("MALE",SEX,1)'=""
WRITE *7," Enter M or F"
SET SEX=""
GOTO P1
+1 SET SEX=$EXTRACT(SEX,1)
P2 IF AGE=""
READ !,"Age: ",AGE:DTIME
IF AGE=""
SET AGE="?"
IF '$TEST!(AGE["^")
GOTO KILL^XUSCLEAN
SET X=AGE
DO TR
SET AGE=X
+1 IF AGE["M"
SET AGE=+$JUSTIFY($PIECE(AGE,"M",1)/12,0,2)
IF AGE'>0!(AGE>124)
WRITE !?5,"Enter Age Less Than 124 in Years or Months (followed by M) but Not Both"
SET AGE=""
GOTO P2
+2 GOTO F2
SVAR ;set variables of incomplete assessment.
+1 IF '$DATA(^FHPT(FHDFN,"N",0))
QUIT
+2 SET FHA0=$GET(^FHPT(FHDFN,"N",FHCAS,0))
+3 SET ADT=$PIECE(FHA0,U,1)
SET SEX=$PIECE(FHA0,U,2)
SET AGE=$PIECE(FHA0,U,3)
SET HGT=$PIECE(FHA0,U,4)
+4 SET HGP=$PIECE(FHA0,U,5)
SET WGT=$PIECE(FHA0,U,6)
SET WGP=$PIECE(FHA0,U,7)
SET DWGT=$PIECE(FHA0,U,8)
+5 SET UWGT=$PIECE(FHA0,U,9)
SET IBW=$PIECE(FHA0,U,10)
SET FRM=$PIECE(FHA0,U,11)
SET AMP=$PIECE(FHA0,U,12)
+6 SET KCAL=$PIECE(FHA0,U,16)
SET PRO=$PIECE(FHA0,U,17)
SET FLD=$PIECE(FHA0,U,18)
SET RC=$PIECE(FHA0,U,19)
+7 SET XD=$PIECE(FHA0,U,20)
SET BMI=$PIECE(FHA0,U,21)
SET BMIP=$PIECE(FHA0,U,22)
+8 SET NOW=$PIECE(FHA0,U,24)
SET NB=$PIECE(FHA0,U,25)
+9 SET FHA1=$GET(^FHPT(FHDFN,"N",FHCAS,1))
+10 SET TSF=$PIECE(FHA1,U,1)
SET TSFP=$PIECE(FHA1,U,2)
SET SCA=$PIECE(FHA1,U,3)
SET SCAP=$PIECE(FHA1,U,4)
SET ACIR=$PIECE(FHA1,U,5)
+11 SET ACIRP=$PIECE(FHA1,U,6)
SET CCIR=$PIECE(FHA1,U,7)
SET CCIRP=$PIECE(FHA1,U,8)
SET BFAMA=$PIECE(FHA1,U,9)
SET BFAMAP=$PIECE(FHA1,U,10)
+12 SET WCCM=$PIECE(FHA1,U,11)
SET CIBW=$PIECE(FHA1,U,12)
SET CERBO=$PIECE(FHA1,U,13)
SET CENB=$PIECE(FHA1,U,14)
SET PCTB=$PIECE(FHA1,U,15)
+13 SET SEF=$PIECE(FHA1,U,16)
SET CFRB=$PIECE(FHA1,U,17)
SET CFRBO=$PIECE(FHA1,U,18)
SET CPRBO=$PIECE(FHA1,U,19)
SET EKKG=$PIECE(FHA1,U,20)
+14 SET FHAPP=$GET(^FHPT(FHDFN,"N",FHCAS,2))
+15 SET FHA3=$GET(^FHPT(FHDFN,"N",FHCAS,3))
+16 SET FHYN=$PIECE(FHA3,U,1)
SET FHFEC=$PIECE(FHA3,U,2)
SET FHFPC=$PIECE(FHA3,U,3)
SET FHDINA=$PIECE(FHA3,U,4)
SET FHEDU=$PIECE(FHA3,U,5)
+17 SET FHFDCSV=$PIECE(FHA3,U,6)
SET FHPL=$PIECE(FHA3,U,7)
SET FHSPC=$PIECE(FHA3,U,8)
+18 SET FHADI=$GET(^FHPT(FHDFN,"N",FHCAS,"DI"))
+19 SET FHDIPL=$PIECE(FHADI,U,1)
SET FHDIPLD=$PIECE(FHADI,U,2)
SET FHDINF=$PIECE(FHADI,U,3)
SET FHDINFD=$PIECE(FHADI,U,4)
+20 SET (FHFUD,FHFUDS)=$PIECE(FHADI,U,5)
SET FHDIST=$PIECE(FHADI,U,6)
SET FHDIDI=$PIECE(FHADI,U,7)
SET FHDITF=$PIECE(FHADI,U,8)
+21 QUIT
ASKUS READ !!,"Do you wish to SAVE this Assessment Y// ",X:DTIME
IF '$TEST!(X["^")
GOTO KILL^XUSCLEAN
+1 IF X=""
SET X="Y"
DO TR
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7,!," Answer YES or NO"
GOTO ASKUS
+2 IF X'?1"Y".E
GOTO KILL^XUSCLEAN
+3 DO SDAT^FHASM7
GOTO KILL^XUSCLEAN
