- FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08
- ;;5.5;DIETETICS;**8,14,22**;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 KILL^XUSCLEAN
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASM1 9080 printed Jan 18, 2025@02:48:01 Page 2
- FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08
- +1 ;;5.5;DIETETICS;**8,14,22**;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 KILL^XUSCLEAN
- +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