Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHASM1

FHASM1.m

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