Changeset 623 for WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM1.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM1.m
r613 r623 1 FHASM1 2 ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1 3 4 F1 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 .I ADM D CUR^FHORD7 S X1="" 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 STA 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 CRE 55 56 57 58 59 60 61 62 F2 63 F3 64 F3A 65 66 67 68 F4 69 70 71 72 73 74 75 76 F4A 77 78 79 80 F5 81 82 83 84 85 86 S WGT=Y,WGP=Y1 I FHDVWGT'="" SDWGT=$P(FHDVWGT,".",1)87 F6 88 89 90 91 92 93 94 95 F7 96 97 98 F8 99 HGT 100 101 102 103 104 105 106 107 108 109 110 H1 111 H2 112 113 HGP 114 115 116 117 118 WGT 119 120 121 122 123 124 125 126 127 128 129 130 W1 131 132 WGP 133 134 135 136 137 TR 138 139 140 KIL 141 142 143 144 145 146 147 PAT 148 149 P1 150 151 P2 152 153 154 SVAR 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 ASKUS 177 178 179 1 FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08 2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 3 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 4 F1 ; Select Patient 5 S FHALL=1 D ^FHOMDPA G KILL^XUSCLEAN:'FHDFN 6 S:DFN'>0 DFN="" 7 I $G(DFN),$P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KILL^XUSCLEAN 8 S (ADM,ASN,FHASK,KNEE,EXT,DTP,FHCAS,FHCASD,FHASS,FHFFC,FHFEC,FHFPC,FHCFRBO,FHCM,FHEF,FHKCAL,FHLOC)="",(FHHWF,FHQUIT)=0 9 S (ADT,SEX,AGE,HGT,HGP,WGT,WGP,DWGT,UWGT,IBW,FRM,AMP,KCAL,PRO,FLD,RC,XD,BMI,BMIP,FHCLI,FHPLXSV)="" 10 S (NOW,NB,TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,FHAPP,FHEDU,DEWGT,WARD,FHSPC)="" 11 S (FHDIPL,FHDIPLD,FHAST,FHDINF,FHDINFD,FHFUD,FHDIST,FHDIDI,FHDITF,FHDIDI,FHDITF,FHDITFDT,FHDITFCM,FHDITFML,FHDITFKC,FHVHGT,FHDVHGT)="" 12 S (TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,BMI,BMIP,X1,X2,FHFUDS,EKKG,FHFDC,FHFDCSV)="" 13 S (WCCM,CIBW,CERBO,CENB,PCTB,SEF,CFRB,CFRBO,CPRBO,NWGT,DNWGT,FHYN,FHDINA,FHVWGT,FHDVWGT,FHPL)="" 14 S FHCLI=DUZ 15 K ^TMP("FH",$J) S FHQTALL=0 16 ;get current diet and tf 17 S Y="" 18 I DFN D 19 .F I=0:0 S I=$O(^FHPT("AW",I)) Q:I'>0 I $D(^FHPT("AW",I,FHDFN)) S FHLOC=I Q 20 .I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHCLI=$P($G(^FH(119.6,FHLOC,0)),U,2) 21 .S WARD=$G(^DPT(DFN,.1)) I WARD'="" S ADM=$G(^DPT("CN",WARD,DFN)) 22 .D:ADM CUR^FHORD7 23 .S FHDIDI=$S(Y'="":Y,1:"No Order") 24 .W !,"Current Diet: ",FHDIDI 25 .Q:'ADM 26 .S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4) 27 .Q:'TF 28 .S FHDITFDT=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,1) 29 .S FHDITFCM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,5) 30 .S FHDITFML=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,6) 31 .S FHDITFKC=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,7) 32 .F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 D 33 ..S Y=^(TF2,0),TUN=$P(Y,"^",1) 34 ..I TUN,$D(^FH(118.2,TUN,0)) S FHDITFPR(TUN)=Y 35 .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 ", " 36 K Y 37 STA ;if pt has Work in Progress assessment, ask user to Edit or Create or Delete Assessment. 38 D PATNAME^FHOMUTL 39 S AGE=FHAGE 40 I $D(^FHPT(FHDFN,"N",0)) D 41 .S FHCAS=$P(^FHPT(FHDFN,"N",0),U,3) 42 .Q:'FHCAS 43 .S FHCASD=$P(^FHPT(FHDFN,"N",FHCAS,0),U,1) 44 .I $D(^FHPT(FHDFN,"N",FHCAS,"DI")) S FHASS=$P($G(^FHPT(FHDFN,"N",FHCAS,"DI")),U,6) 45 .S FHAST=0 46 .F FHA=0:0 S FHA=$O(^FHPT(FHDFN,"N",FHA)) Q:'FHA D 47 ..S FHASSD=$P($G(^FHPT(FHDFN,"N",FHA,"DI")),U,6) 48 ..I (FHASSD="W")!(FHASS="") S FHAST=1 49 ..I $D(^FHPT(FHDFN,"N",FHA,0)),'$D(^FHPT(FHDFN,"N",FHA,"DI")) S FHAST=1 50 I 'FHCAS!(FHAST=0) G CRE 51 D ASK^FHASM2 G:FHQUIT KILL^XUSCLEAN 52 I FHASK="D" S DIK="^FHPT("_FHDFN_",""N"",",DA(1)=FHDFN,DA=FHCAS D ^DIK W ?65,"Deleted..." G F1 53 I FHASK="E" S ADT=FHCAS D SVAR G:SEX=""!(AGE="") P1 G F3A 54 CRE ;create new assessment 55 ;D:FHCAS PRTA^FHASM2 56 S FHASK="C" 57 W !!,"Creating new Assessment...",! 58 I (FHSEX="")!(FHAGE="") G P1 59 E S NAM=FHPTNM,SEX=FHSEX,AGE=FHAGE 60 S X="NOW",%DT="XT" D ^%DT S ADT=Y 61 I SEX=""!(AGE="") G P1 62 F2 S X="NOW",%DT="XT" D ^%DT S ADT=Y 63 F3 I DFN,$D(^FHPT(FHDFN,"N",9999999-ADT)) S ADT=$$FMADD^XLFDT(ADT,,,1) G F3 64 F3A ;start here if edit 65 S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1),NAM=FHPTNM 66 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) 67 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) 68 F4 ; If Multidivisional site Select Communications Office 69 S FHCOMM="" I $P($G(^FH(119.9,1,0)),U,20)'="N" D I FHCOMM="" Q 70 .K DIC S DIC="^FH(119.73," S DIC(0)="AEMQ" D ^DIC 71 .I Y=-1 Q 72 .S FHCOMM=+Y 73 ;get ht and wt from vitals. 74 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) 75 I X1="" S (X1,HGT)=FHVHGT 76 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 77 D TR,HGT I Y<1 D HGP G F4A 78 S:X1'=Y FHHWF=1 79 S HGT=Y,H1=Y0,HGP=Y1 80 F5 I FHVWGT'="" S WGT=FHVWGT 81 W !!,"Weight: " W:WGT'="" WGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="",WGT S X=WGT_"#" 82 S:X="a" X="A" 83 I X="A",AGE>39 D A^FHASM2D G:Y<1 F5 S:WGT'=Y FHHWF=1 S WGT=Y,WGP="A" G F6 84 D WGT I Y<1 D WGP W:AGE>39 !,"You may enter an A to calculate weight anthropometrically." G F5 85 S:WGT'=Y FHHWF=1 86 S WGT=Y,WGP=Y1,DWGT=$P(FHDVWGT,".",1) 87 F6 G:'FHHWF F7 88 S %DT="AEP",%DT("A")="Date Weight Taken: " 89 I 'DWGT,FHDVWGT S DTP=$E(FHDVWGT,4,5)_"/"_$E(FHDVWGT,6,7)_"/"_$E(FHDVWGT,2,3) 90 I DWGT S DTP=$E(DWGT,4,5)_"/"_$E(DWGT,6,7)_"/"_$E(DWGT,2,3) 91 S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" 92 S %DT(0)="-T" W ! D ^%DT K %DT G KIL:X["^"!$D(DTOUT),F6:Y<1 93 S DWGT=Y 94 ; 95 F7 S:UWGT X=UWGT W !!,"Usual Weight: " W:UWGT'="" UWGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="" G F8 96 D WGT I Y<1 D WGP G F7 97 S UWGT=Y 98 F8 K %DT,A1,K,X,Y G ^FHASM2 99 HGT ; Convert Height to inches 100 S A1=+X I 'A1 S Y=-1 Q 101 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 102 I """I"[$E(X,1) S Y=A1 G H1 103 I $E(X,1)="C" S Y=A1/2.54 G H1 104 I "'F"'[$E(X,1) S Y=-1 G H2 105 S Y=A1*12 F K=1:1 Q:$E(X,K)?.N 106 I $E(X,K,99)="" G H1 107 S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) 108 I """I"'[$E(X,1) S Y=-1 G H2 109 S Y=Y+A1 110 H1 I X["K" D K^FHASM2D 111 H2 I Y<12!(Y>96) S Y=-1 112 S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1=$S(X["K":"K",X["S":"S",1:"") Q 113 HGP ; Height Help 114 W !!,"Enter height as: 6' 2"" or 74"" or 74IN or 6FT 2 IN or 30CM" 115 W !,"Add an S if height is stated rather than measured." 116 W !,"Add a K if value is a Knee Height measurement." 117 W !,"Height should be between 12"" and 96"" (8')." Q 118 WGT ; Convert Weight to lbs. 119 D TR S A1=+X I 'A1 S Y=-1 Q 120 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 121 I $E(X,1)="O" S Y=A1/16 G W1 122 I $E(X,1)="G" S Y=A1/1000*2.2 G W1 123 I $E(X,1)="K" S Y=A1*2.2 G W1 124 I "L#"'[$E(X,1) S Y=-1 G W1 125 S Y=A1 F K=1:1 Q:$E(X,K)?.N 126 I $E(X,K,99)="" G W1 127 S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) 128 I $E(X,1)'="O" S Y=-1 G W1 129 S Y=A1/16+Y 130 W1 I Y<0!(Y>750) S Y=-1 131 S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1="" S:X["S" Y1="S" Q 132 WGP ; Weight help 133 W !!,"Enter Weight as 150# or 150# 6OZ or 800G or 70KG" 134 W !,"Add an S if weight is stated rather than measured." 135 W !,"Enter an A to determine weight anthropometrically." 136 W !,"Weight should be between 0 Lbs and 750 Lbs." Q 137 TR ; Translate Lower to Upper Case 138 D TR^FH 139 Q 140 KIL ; Final variable kill 141 ;if X not equal ^, update or create nutrition assessment 142 G:$G(FHQUIT) ASKUS 143 I $D(X),X=U G ASKUS 144 D SDAT^FHASM7 145 ; 146 G KILL^XUSCLEAN 147 PAT S (FHDFN,DFN,SEX,AGE,PID)="" R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!(NAM["^") KILL^XUSCLEAN 148 I NAM["?"!(NAM'?.ANP)!(NAM="") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT 149 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 150 S SEX=$E(SEX,1) 151 P2 I AGE="" R !,"Age: ",AGE:DTIME S:AGE="" AGE="?" G:'$T!(AGE["^") KILL^XUSCLEAN S X=AGE D TR S AGE=X 152 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 153 G F2 154 SVAR ;set variables of incomplete assessment. 155 Q:'$D(^FHPT(FHDFN,"N",0)) 156 S FHA0=$G(^FHPT(FHDFN,"N",FHCAS,0)) 157 S ADT=$P(FHA0,U,1),SEX=$P(FHA0,U,2),AGE=$P(FHA0,U,3),HGT=$P(FHA0,U,4) 158 S HGP=$P(FHA0,U,5),WGT=$P(FHA0,U,6),WGP=$P(FHA0,U,7),DWGT=$P(FHA0,U,8) 159 S UWGT=$P(FHA0,U,9),IBW=$P(FHA0,U,10),FRM=$P(FHA0,U,11),AMP=$P(FHA0,U,12) 160 S KCAL=$P(FHA0,U,16),PRO=$P(FHA0,U,17),FLD=$P(FHA0,U,18),RC=$P(FHA0,U,19) 161 S XD=$P(FHA0,U,20),BMI=$P(FHA0,U,21),BMIP=$P(FHA0,U,22) 162 S NOW=$P(FHA0,U,24),NB=$P(FHA0,U,25) 163 S FHA1=$G(^FHPT(FHDFN,"N",FHCAS,1)) 164 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) 165 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) 166 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) 167 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) 168 S FHAPP=$G(^FHPT(FHDFN,"N",FHCAS,2)) 169 S FHA3=$G(^FHPT(FHDFN,"N",FHCAS,3)) 170 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) 171 S FHFDCSV=$P(FHA3,U,6),FHPL=$P(FHA3,U,7),FHSPC=$P(FHA3,U,8) 172 S FHADI=$G(^FHPT(FHDFN,"N",FHCAS,"DI")) 173 S FHDIPL=$P(FHADI,U,1),FHDIPLD=$P(FHADI,U,2),FHDINF=$P(FHADI,U,3),FHDINFD=$P(FHADI,U,4) 174 S (FHFUD,FHFUDS)=$P(FHADI,U,5),FHDIST=$P(FHADI,U,6),FHDIDI=$P(FHADI,U,7),FHDITF=$P(FHADI,U,8) 175 Q 176 ASKUS R !!,"Do you wish to SAVE this Assessment Y// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN 177 S:X="" X="Y" D TR I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G ASKUS 178 I X'?1"Y".E G KILL^XUSCLEAN 179 D SDAT^FHASM7 G KILL^XUSCLEAN
Note:
See TracChangeset
for help on using the changeset viewer.
