Changeset 623 for WorldVistAEHR/trunk/r/DIETETICS-FH
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- Location:
- WorldVistAEHR/trunk/r/DIETETICS-FH
- Files:
-
- 14 edited
-
FHASM1.m (modified) (1 diff)
-
FHASM3.m (modified) (1 diff)
-
FHASM7.m (modified) (1 diff)
-
FHASMR2.m (modified) (1 diff)
-
FHASP1.m (modified) (1 diff)
-
FHDSSAPI.m (modified) (1 diff)
-
FHNO2.m (modified) (1 diff)
-
FHOMPP.m (modified) (1 diff)
-
FHORC5.m (modified) (1 diff)
-
FHPRO.m (modified) (1 diff)
-
FHPRW.m (modified) (1 diff)
-
FHREP1.m (modified) (1 diff)
-
FHSELA1.m (modified) (1 diff)
-
FHSELA2.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 -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM3.m
r613 r623 1 FHASM3 ; HISC/REL - Antropometrics and TIU Notes ;5/14/93 09:17 2 ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1 3 I EXT="Y" G NEXT 4 EXT R !!,"Do you wish Anthropometric Assessment? NO// ",EXT:DTIME S:EXT=U FHQUIT=1 G:'$T!(EXT["^") KIL^FHASM1 5 S:EXT="" EXT="N" 6 S X=EXT D TR^FHASM1 S EXT=X 7 I $P("YES",EXT,1)'="",$P("NO",EXT,1)'="" W *7,!," Enter YES if you have Anthropometric measurements; Otherwise NO" G EXT 8 S EXT=$E(EXT,1) I EXT="Y" D ANT G:EXT="" KIL^FHASM1 9 NEXT ; Calculate BMI 10 S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) 11 ;update nutrition assessment data in #115. 12 ; 13 ; 14 D ^FHASM3A G ^FHASM4 15 ANT ; Anthropometric measurements 16 W !!,"Triceps Skin Fold (mm): " W:$D(TSF) TSF_"// " R X:DTIME G QT:'$T!(X["^") 17 S:X'="" TSF=X 18 S:TSF="" TSF=X 19 G A1:TSF="" 20 I TSF'?.N.1".".N!(TSF<1)!(TSF>100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G ANT 21 A1 W !,"Subscapular Skinfold (mm): " W:$D(SCA) SCA_"// " R X:DTIME G QT:'$T!(X["^") 22 S:X'="" SCA=X 23 S:SCA="" SCA=X 24 G A2:SCA="" 25 I SCA'?.N.1".".N!(SCA<1)!(SCA>100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G A1 26 A2 W !,"Arm Circumference (cm): " W:$G(ACIR) ACIR_"// " R X:DTIME G QT:'$T!(X["^") 27 S:X'="" ACIR=X 28 S:SCA="" ACIR=X 29 G A3:ACIR="" 30 I ACIR'?.N.1".".N!(ACIR<5)!(ACIR>100) W !?5,"Enter number between 5 and 100; outside values should be assessed manually" G A2 31 A3 W !,"Calf Circumference (cm): " W:$G(CCIR) CCIR_"// " R X:DTIME G QT:'$T!(X["^") 32 S:X'="" CCIR=X 33 S:CCIR="" CCIR=X 34 G A4:CCIR="" 35 I CCIR'?.N.1".".N!(CCIR<10)!(CCIR>250) W !?5,"Enter value between 10 and 250; outside values should be assessed manually" G A3 36 A4 I ACIR,TSF S X1=ACIR-(TSF/10*3.1416),BFAMA=X1*X1/12.5664-$S(AGE<18:0,SEX="M":10,1:6.5),BFAMA=$J(BFAMA,0,1) 37 Q 38 QT S EXT="" Q 39 ; 40 REC ;recalculate calorie, protien and fluid requirements. 41 I '$G(IBW)!'$G(WGT)!'$G(HGT)!'$G(AGE) Q 42 I $D(CFRBO) S CB=CFRBO,W2=$S(CB=2:IBW,CB=3:WGT-IBW*.25+IBW,1:WGT)/2.2 43 Q:'$G(W2) 44 ;calorie 45 I $D(CENB),CENB=3 D 46 .I SEX="M" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)+5 47 .I SEX="F" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)-161 48 .S KCAL=$J(KCAL,0,0) 49 I $D(CENB),CENB=1 D 50 .I SEX="F" S KCAL=(655.10+(9.56*W2)+(1.85*HGT*2.54)-(4.68*AGE)) 51 .I SEX="M" S KCAL=(66.47+(13.75*W2)+(5.0*HGT*2.54)-(6.67*AGE)) 52 .I $D(SEF),$G(AF) S KCAL=+$J(KCAL*AF*SEF,0,0) 53 .S KCAL=$J(KCAL,0,0) 54 I $D(CENB),(CENB=2),$G(EKKG) S KCAL=+$J(EKKG*W2,0,0) 55 ;fluid 56 I $G(CFRB),CFRB=1 D 57 .S:AGE>17 FLD=35 58 .S:AGE>64 FLD=30 59 .S FLD=W2*FLD 60 I $D(CFRB),CFRB=2 S W1=W2,FLD=$S(W1<10:W1*100,W1<20:W1-10*50+1000,1:W1-20*25+1500) 61 I $D(CFRB),CFRB=3 S FLD=KCAL 62 I $D(CFRB),CFRB=4 S FLD=.5*KCAL 63 I $D(CFRB),CFRB=5 S X=W2,X1=.425 D PWR^FHASM6 S FLD=Y,X=HGT*2.54,X1=.725 D PWR^FHASM6 S FLD=FLD*Y*.007184*1500 64 S FLD=+$J(FLD,0,0) 65 I FLD'?1N.N!(FLD<0)!(FLD>10000) W *7,!,"Fluid level must be between 0-10000 ml/day" S FHQTALL=1 Q 66 S FLD=+$J(FLD,0,0) 67 ;protien 68 S P1=$S(AGE>18:.8,AGE>14:.84,AGE>10:1,AGE>6:1.2,AGE>3:1.5,AGE>1:1.8,AGE>.5:2,1:2.2) 69 I P1=FHPL S PRO=+$J(P1*W2,0,0) 70 I P1'=FHPL S PRO=+$J(FHPL*W2,0,0) 71 I PRO'="",(PRO'>0!(PRO>400)) W *7," Protien level is greater than 0 but not more than 400." S FHQTALL=1 72 ;FOLLOW-UP DATE. 73 S (FHDD,DTP)="" 74 I $G(RC),FHFUD<DT D 75 .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH 76 .I X["NORMAL" D 77 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20) 78 ..S:FHDD DTP="T+"_FHDD 79 ..S:'FHDD DTP="T+11" 80 .I X["MILD" D 81 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21) 82 ..S:FHDD DTP="T+"_FHDD 83 ..S:'FHDD DTP="T+9" 84 .I X["MODERATE" D 85 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22) 86 ..S:FHDD DTP="T+"_FHDD 87 ..S:'FHDD DTP="T+7" 88 .I X["SEVERE" D 89 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23) 90 ..S:FHDD DTP="T+"_FHDD 91 ..S:'FHDD DTP="T+5" 92 .S X=DTP,%DT="X",%DT(0)=DT D ^%DT S FHFUD=Y 93 .W ! K %DT 94 .S FHFUD=Y 95 I 'RC,FHFUD<DT S X="NOW",%DT="X" D ^%DT S FHFUD=Y 96 ; 97 Q 1 FHASM3 ; HISC/REL - Antropometrics and TIU Notes ;5/14/93 09:17 2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 3 I EXT="Y" G NEXT 4 EXT R !!,"Do you wish Anthropometric Assessment? NO// ",EXT:DTIME S:EXT=U FHQUIT=1 G:'$T!(EXT["^") KIL^FHASM1 5 S:EXT="" EXT="N" 6 S X=EXT D TR^FHASM1 S EXT=X 7 I $P("YES",EXT,1)'="",$P("NO",EXT,1)'="" W *7,!," Enter YES if you have Anthropometric measurements; Otherwise NO" G EXT 8 S EXT=$E(EXT,1) I EXT="Y" D ANT G:EXT="" KIL^FHASM1 9 NEXT ; Calculate BMI 10 S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) 11 ;update nutrition assessment data in #115. 12 ; 13 ; 14 D ^FHASM3A G ^FHASM4 15 ANT ; Anthropometric measurements 16 W !!,"Triceps Skin Fold (mm): " W:$D(TSF) TSF_"// " R X:DTIME G QT:'$T!(X["^") 17 S:X'="" TSF=X 18 S:TSF="" TSF=X 19 G A1:TSF="" 20 I TSF'?.N.1".".N!(TSF<1)!(TSF>100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G ANT 21 A1 W !,"Subscapular Skinfold (mm): " W:$D(SCA) SCA_"// " R X:DTIME G QT:'$T!(X["^") 22 S:X'="" SCA=X 23 S:SCA="" SCA=X 24 G A2:SCA="" 25 I SCA'?.N.1".".N!(SCA<1)!(SCA>100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G A1 26 A2 W !,"Arm Circumference (cm): " W:$G(ACIR) ACIR_"// " R X:DTIME G QT:'$T!(X["^") 27 S:X'="" ACIR=X 28 S:SCA="" ACIR=X 29 G A3:ACIR="" 30 I ACIR'?.N.1".".N!(ACIR<5)!(ACIR>100) W !?5,"Enter number between 5 and 100; outside values should be assessed manually" G A2 31 A3 W !,"Calf Circumference (cm): " W:$G(CCIR) CCIR_"// " R X:DTIME G QT:'$T!(X["^") 32 S:X'="" CCIR=X 33 S:CCIR="" CCIR=X 34 G A4:CCIR="" 35 I CCIR'?.N.1".".N!(CCIR<10)!(CCIR>250) W !?5,"Enter value between 10 and 250; outside values should be assessed manually" G A3 36 A4 I ACIR,TSF S X1=ACIR-(TSF/10*3.1416),BFAMA=X1*X1/12.5664-$S(AGE<18:0,SEX="M":10,1:6.5),BFAMA=$J(BFAMA,0,1) 37 Q 38 QT S EXT="" Q 39 ; 40 REC ;recalculate calorie, protien and fluid requirements. 41 I '$G(IBW)!'$G(WGT)!'$G(HGT)!'$G(AGE) Q 42 I $D(CFRBO) S CB=CFRBO,W2=$S(CB=2:IBW,CB=3:WGT-IBW*.25+IBW,1:WGT)/2.2 43 Q:'$G(W2) 44 ;calorie 45 I $D(CENB),CENB=3 D 46 .I SEX="M" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)+5 47 .I SEX="F" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)-161 48 .S KCAL=$J(KCAL,0,0) 49 I $D(CENB),CENB=1 D 50 .I SEX="F" S KCAL=(655.10+(9.56*W2)+(1.85*HGT*2.54)-(4.68*AGE)) 51 .I SEX="M" S KCAL=(66.47+(13.75*W2)+(5.0*HGT*2.54)-(6.67*AGE)) 52 .I $D(SEF),$G(AF) S KCAL=+$J(KCAL*AF*SEF,0,0) 53 .S KCAL=$J(KCAL,0,0) 54 I $D(CENB),(CENB=2),$G(EKKG) S KCAL=+$J(EKKG*W2,0,0) 55 ;fluid 56 I $G(CFRB),CFRB=1 D 57 .S:AGE>17 FLD=35 58 .S:AGE>64 FLD=30 59 .S FLD=W2*FLD 60 I $D(CFRB),CFRB=2 S W1=W2,FLD=$S(W1<10:W1*100,W1<20:W1-10*50+1000,1:W1-20*25+1500) 61 I $D(CFRB),CFRB=3 S FLD=KCAL 62 I $D(CFRB),CFRB=4 S FLD=.5*KCAL 63 I $D(CFRB),CFRB=5 S X=W2,X1=.425 D PWR^FHASM6 S FLD=Y,X=HGT*2.54,X1=.725 D PWR^FHASM6 S FLD=FLD*Y*.007184*1500 64 S FLD=+$J(FLD,0,0) 65 I FLD'?1N.N!(FLD<0)!(FLD>10000) W *7,!,"Fluid level must be between 0-10000 ml/day" S FHQTALL=1 Q 66 S FLD=+$J(FLD,0,0) 67 ;protien 68 S P1=$S(AGE>18:.8,AGE>14:.84,AGE>10:1,AGE>6:1.2,AGE>3:1.5,AGE>1:1.8,AGE>.5:2,1:2.2) 69 S PRO=+$J(P1*W2,0,0) 70 I PRO'="",(PRO'>0!(PRO>400)) W *7," Protien level is greater than 0 but not more than 400." S FHQTALL=1 71 ;FOLLOW-UP DATE. 72 S (FHDD,DTP)="" 73 I $G(RC),FHFUD<DT D 74 .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH 75 .I X["NORMAL" D 76 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20) 77 ..S:FHDD DTP="T+"_FHDD 78 ..S:'FHDD DTP="T+11" 79 .I X["MILD" D 80 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21) 81 ..S:FHDD DTP="T+"_FHDD 82 ..S:'FHDD DTP="T+9" 83 .I X["MODERATE" D 84 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22) 85 ..S:FHDD DTP="T+"_FHDD 86 ..S:'FHDD DTP="T+7" 87 .I X["SEVERE" D 88 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23) 89 ..S:FHDD DTP="T+"_FHDD 90 ..S:'FHDD DTP="T+5" 91 .S X=DTP,%DT="X",%DT(0)=DT D ^%DT S FHFUD=Y 92 .W ! K %DT 93 .S FHFUD=Y 94 I 'RC,FHFUD<DT S X="NOW",%DT="X" D ^%DT S FHFUD=Y 95 ; 96 Q -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM7.m
r613 r623 1 FHASM7 2 ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1 3 4 E31 5 6 7 E32 8 9 E33 10 11 E34 12 13 14 E35 15 EDU 16 17 18 19 20 21 22 23 EDC 24 25 26 27 28 29 30 31 DPL 32 33 34 35 DP1 36 37 38 39 40 41 42 43 44 45 46 47 ANF 48 49 50 51 52 53 54 55 DNF 56 57 58 59 60 61 62 63 E4 64 65 66 67 68 69 70 EC1 71 E5 72 73 74 75 FDT 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 SDAT 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 E7 136 137 138 E8 139 140 141 142 143 E9 144 E6 145 146 147 148 149 150 .;send assessment to TIU if pt has entry in #2 and is inpatient.151 .I $G(DFN) S WARD=$G(^DPT(DFN,.1)) I WARD'=""D ^FHASMR2 K ^TMP($J) I $G(FHOUT) D Q152 153 154 155 .W !!,"Assessment is completed" I $G(DFN),WARD'="" W" and forwarded to TIU" W "...",!156 KIL 1 FHASM7 ; HISC/REL - KCAL Distribution ;8/18/93 11:05 2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 3 S PRT=0,(ASN,NB)="" 4 E31 S FH7FLG=1 D ^FHASMR1 K FH7FLG 5 R !!,"Do you want to do a NITROGEN BALANCE? NO// ",X:DTIME G:'$T!(X["^") KIL^FHASM1 S:X="" X="N" D TR^FHASM1 I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G E31 6 I $E(X,1)="N" G KIL:'FHDFN,EDU 7 E32 R !!,"Enter Protein Intake (gm/24hr): ",X1:DTIME S:X1=U FHQUIT=1 G KIL^FHASM1:'$T!(X1["^"),E35:X1="" 8 I X1'?.N.1".".N!(X1<0)!(X1>200) W !?5,"Enter 0-200 grams of protein intake" G E32 9 E33 R !,"Enter Urinary Nitrogen Output (gm/24hr): ",X2:DTIME S:X2=U FHQUIT=1 G KIL^FHASM1:'$T!(X2["^"),E35:X2="" 10 I X2'?.N.1".".N!(X2<0)!(X2>30) W !?5,"Enter 0-30 gms of Urinary Nitrogen output (24 hr UUN)" G E33 11 E34 R !,"Enter Insensible Nitrogen Output (gm/24hr): 4// ",X3:DTIME S:X3="" X3=4 S:X3=U FHQUIT=1 G:'$T!(X3["^") KIL^FHASM1 12 I X3'?.N.1".".N!(X3<0)!(X3>10) W !?5,"Insensible Nitrogen output should be between 0-10 grams" G E34 13 S NB=X1/6.25-(X2+X3),NB=$J(NB,0,0) W !,"Nitrogen Balance: ",NB 14 E35 G:'FHDFN KIL 15 EDU ; 16 W !!,"Did you educate patient on Food/Drug Interactions (Y/N): " W:FHEDU'="" FHEDU_"//" W:FHEDU="" "N//" R X:DTIME 17 G KIL^FHASM1:'$T!(X["^") 18 I X="",FHEDU="" S X="N" 19 I X="",FHEDU'="" S X=FHEDU 20 D TR^FH 21 I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!,"Enter 'Y' for yes or 'N' for no." G EDU 22 S FHEDU=$E(X,1) 23 EDC ;food/drug comment. 24 S FHFDC=FHFDCSV 25 W !!,"Food/Drug Comment: ",FHFDCSV,"// " R FHFDC:DTIME I '$T!(FHFDC["^") S FHQUIT=1 G KIL^FHASM1 26 I FHFDC="@" S FHFDCSV="" W " deleted..." G DPL 27 I (FHFDC=""),(FHFDCSV'="") S FHFDC=FHFDCSV 28 I FHFDC["?"!($L(FHFDC)>30) W *7,!,"Enter Food/Drug Comment or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G EDC 29 S FHFDCSV=FHFDC 30 ;adding diagnosis, follow-up date 31 DPL ;get diagnosis from Problem List package. 32 D:DFN LIST^GMPLUTL2(.FHPLIST,DFN,"A","") 33 S FHDIACT=0 34 I $D(FHPLIST(0)) S FHDIACT=FHPLIST(0) 35 DP1 I FHDIACT D 36 .S FHDCH="" 37 .W !!,"Patient's Diagnosis from Problem List:",! 38 .F FHDLI=0:0 S FHDLI=$O(FHPLIST(FHDLI)) Q:'FHDLI D 39 ..S DTP=$P(FHPLIST(FHDLI),U,6) D DTP^FH 40 ..W !,?6,FHDLI_" ",$P(FHPLIST(FHDLI),U,3)," - Date entered: ",DTP 41 G:'FHDIACT ANF 42 W !!,"Diagnosis: " W:FHDIPL'="" FHDIPL W "// " R FHDCH:DTIME S:FHDCH=U FHQUIT=1 G:'$T!(FHDCH["^") KIL^FHASM1 43 G:FHDCH="" ANF 44 I FHDCH="@" S (FHDIPL,FHDIPLD)="" G ANF 45 I '$D(FHPLIST(FHDCH)) W !!,*7,"Choose a number from the list or Hit Return to accept default!!",! G DP1 46 S FHDIPL=$P(FHPLIST(FHDCH),U,3),FHDIPLD=$P(FHPLIST(FHDCH),U,6) 47 ANF ;problem through NFS. 48 S AFDIA=FHDINA 49 W !!,"Problem: ",FHDINA,"// " R AFDIA:DTIME I '$T!(AFDIA["^") S FHQUIT=1 G KIL^FHASM1 50 I AFDIA="@" S FHDINA="" W " deleted..." G DNF 51 I (AFDIA=""),(FHDINA'="") S AFDIA=FHDINA 52 I AFDIA["?"!($L(AFDIA)>30) W *7,!,"Enter patient's Problem or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G ANF 53 S FHDINA=AFDIA 54 ; 55 DNF ;aditional problem through NFS. 56 S NFDIA=FHDINF 57 W !!,"Additional Problem: ",FHDINF,"// " R NFDIA:DTIME I '$T!(NFDIA["^") S FHQUIT=1 G KIL^FHASM1 58 I NFDIA="@" S FHDINF="" W " deleted..." G E4 59 I (NFDIA=""),(FHDINF'="") S NFDIA=FHDINF 60 I NFDIA["?"!($L(NFDIA)>30) W *7,!,"Enter Additional Problem of a patient or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G DNF 61 S FHDINF=NFDIA 62 ; 63 E4 ; 64 S APP=FHAPP 65 W !!,"Appearance: ",FHAPP,"// " R APP:DTIME I '$T!(APP["^") S FHQUIT=1 G KIL^FHASM1 66 I APP="@" S FHAPP="" W " deleted..." G EC1 67 I (APP=""),(FHAPP'="") S APP=FHAPP 68 I APP["?"!(APP'?.ANP)!($L(APP)>60) W *7,!,"Enter Physical Appearance of patient or Hit Return to Accept or @ to Delete and cannot exceed 60 characters." G E4 69 S FHAPP=APP 70 EC1 W ! S DIC="^FH(115.3,",DIC(0)="AEQMZ",DIC("B")=XD D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S XD=$S(Y>0:+Y,1:"") 71 E5 W ! S DIC="^FH(115.4,",DIC(0)="AEQMZ",DIC("B")=RC,DIC("S")="I $P(^(0),U,2)'=""""" D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S RC=$S(Y>0:+Y,1:"") 72 W !!,"Comments:" K ^TMP("FH",$J) S DIC="^TMP(""FH"",$J,",DWPK=1 73 I FHASK="E",$D(^FHPT(FHDFN,"N",FHCAS,"X")) M ^TMP("FH",$J)=^FHPT(FHDFN,"N",FHCAS,"X") D EN^DIWE G FDT 74 D EN^DIWE 75 FDT ;enter follow-up date. 76 S (FHDD,DTP)="" 77 I $G(RC) D 78 .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH 79 .I X["NORMAL" D 80 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20) 81 ..S:FHDD DTP="T+"_FHDD 82 ..S:'FHDD DTP="T+11" 83 .I X["MILD" D 84 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21) 85 ..S:FHDD DTP="T+"_FHDD 86 ..S:'FHDD DTP="T+9" 87 .I X["MODERATE" D 88 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22) 89 ..S:FHDD DTP="T+"_FHDD 90 ..S:'FHDD DTP="T+7" 91 .I X["SEVERE" D 92 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23) 93 ..S:FHDD DTP="T+"_FHDD 94 ..S:'FHDD DTP="T+5" 95 K %DT S %DT="AEF",%DT("A")="Enter Follow-up Assessment Date: " 96 I FHFUD'="",FHFUD>DT S DTP=$E(FHFUD,4,5)_"/"_$E(FHFUD,6,7)_"/"_$E(FHFUD,2,3) 97 S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" 98 S %DT(0)=DT 99 W ! D ^%DT K %DT G KIL^FHASM1:X["^"!$D(DTOUT),FDT:Y<1 100 S FHFUD=Y 101 SDAT ;create or update nutrition assessment and file to Progress Notes. 102 G:'$D(FHASK) KILL^XUSCLEAN 103 I '$D(^FHPT(FHDFN,0)) S ^(0)=FHDFN 104 I '$D(^FHPT(FHDFN,"N",0)) S ^FHPT(FHDFN,"N",0)="^115.011D^^" 105 K DIC,DD,DO S DIC="^FHPT(FHDFN,""N"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN 106 I FHASK="E" S ASN=FHCAS D REC^FHASM3 ;re-calculate calorie, protien and fluid requirement. 107 I FHASK="C" S X=ADT,DINUM=9999999-ADT D FILE^DICN S ASN=+Y ;if not an update, create. 108 D NOW^%DTC S NOW=% 109 S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) 110 S Y=ADT_"^"_SEX_"^"_AGE_"^"_HGT_"^"_HGP_"^"_WGT_"^"_WGP_"^"_DWGT_"^"_UWGT_"^"_IBW_"^"_FRM_"^"_AMP_"^^^^"_KCAL_"^"_PRO_"^"_FLD_"^"_RC_"^"_XD_"^"_BMI_"^"_BMIP_"^"_DUZ_"^"_NOW_"^"_NB 111 S ^FHPT(FHDFN,"N",ASN,0)=Y 112 S:'FHFUD FHFUD=DT 113 S FHASN1=TSF_U_TSFP_U_SCA_U_SCAP_U_ACIR_U_ACIRP_U_CCIR_U_CCIRP_U_BFAMA_U_BFAMAP_U_WCCM_U_CIBW_U_CERBO_U_CENB_U_PCTB_U_SEF_U_CFRB_U_CFRBO_U_CPRBO_U_EKKG 114 S ^FHPT(FHDFN,"N",ASN,1)=FHASN1 115 S ^FHPT(FHDFN,"N",ASN,2)=FHAPP 116 S ^FHPT(FHDFN,"N",ASN,3)=FHYN_U_FHFEC_U_FHFPC_U_FHDINA_U_FHEDU_U_FHFDCSV_U_FHPL_U_FHSPC 117 S ^FHPT(FHDFN,"N",ASN,"DI")=FHDIPL_U_FHDIPLD_U_FHDINF_U_FHDINFD_U_FHFUD_U_FHDIST_U_FHDIDI_U_FHDITFDT 118 S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,10)=FHDITFML 119 S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,11)=FHDITFKC 120 S $P(^FHPT(FHDFN,"N",ASN,4),U,1)=FHDITFCM 121 I $D(FHDITFPR),'$D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 D 122 .S Y=FHTUN K DIC,DO S DA(2)=FHDFN,DA(1)=ASN 123 .S DIC="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," 124 .S DIC(0)="L",DIC("P")=$P(^DD(115.011,67.1,0),U,2),X=+Y 125 .D FILE^DICN I Y=-1 Q 126 .K DIE S DA(2)=FHDFN,DA(1)=ASN,DA=+Y 127 .S FH1=$P(FHDITFPR(FHTUN),U,2),FH2=$P(FHDITFPR(FHTUN),U,3) 128 .S DIE="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," 129 .S DR="1////^S X=FH1;2////^S X=FH2" D ^DIE 130 I FHFUDS,(FHFUDS'=FHFUD) K ^FHPT("E",FHFUDS,FHDFN,ASN) 131 I FHFUD S DA(1)=FHDFN,DA=ASN,DIK="^FHPT(DA(1)"_",""N"",",DIK(1)="64^E" D IX^DIK 132 G:'$D(LRTST) E7 133 S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" S ^FHPT(FHDFN,"N",ASN,"L",K,0)=LRTST(K),N1=N1+1 134 I N1,'$D(^FHPT(FHDFN,"N",ASN,"L",0)) S ^(0)="^115.021^^" 135 E7 G:'$D(^TMP("FH",$J)) E8 136 S ^FHPT(FHDFN,"N",ASN,"X",0)=^TMP("FH",$J,0) 137 S N1=0 F K=0:0 S K=$O(^TMP("FH",$J,K)) Q:K'>0 S N1=N1+1,^FHPT(FHDFN,"N",ASN,"X",N1,0)=^TMP("FH",$J,K,0) 138 E8 S DTE=ADT,S1=1,S2="I",S3=$S('RC:"",1:"Nutrition Status: "_$P(^FH(115.4,RC,0),"^",2)) 139 I $G(DFN) D FIL^FHASE3 I 'RC G E9 140 I '$D(^FHPT(FHDFN,"S",0)) S ^(0)="^115.012D^^" 141 K DIC,DD,DO S DIC="^FHPT(FHDFN,""S"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN,X=ADT,DINUM=9999999-ADT D FILE^DICN S ASE=+Y 142 I $G(DFN) D DID^FHDPA S $P(^FHPT(FHDFN,"S",ASE,0),"^",2,3)=RC_"^"_DUZ S:FHWRD $P(^(0),"^",6)=FHWRD 143 E9 ;D P0^FHASMR 144 E6 R !!,"Save as Work in Progress or Complete or Delete this assessment: W// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN 145 S:X="" X="W" D TR^FHASM1 146 I ($E(X)'="W"),($E(X)'="C"),($E(X)'="D") W *7,!," Answer 'W' to file as Work in progress or 'C' to Complete and send to TIU or 'D' to Delete" G E6 147 I $E(X)="D" S DA(1)=FHDFN,DIK="^FHPT(FHDFN,""N"",",DA=ASN D ^DIK W !!,"Deleted...",! G KILL^XUSCLEAN 148 I $E(X)="W" S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" W !!,"This Assessment has been saved as Work in Progress...",! 149 I $E(X)="C" D 150 .;send assessment to TIU if pt has entry in #2. 151 .I $G(DFN) D ^FHASMR2 K ^TMP($J) I $G(FHOUT) D Q 152 ..W !!,"TIU Progress Note was NOT created!!" 153 ..S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" 154 .S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="C" 155 .W !!,"Assessment is completed" W:$G(DFN) " and forwarded to TIU" W "...",! 156 KIL G KILL^XUSCLEAN -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHASMR2.m
r613 r623 1 FHASMR2 2 ;;5.5;DIETETICS;**8,14**;Apr 27, 2007;Build 1 3 4 5 6 EN 7 8 9 10 11 12 13 14 15 16 EN1 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 EN2 72 73 74 75 76 77 78 79 80 DRU 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 DIA 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 DCOM 136 137 138 139 140 141 142 143 144 145 D NOW^%DTC S FHRDT=%,FHIFN="",FHESBY=FHCLI K %,%H,%I,X 146 147 148 149 150 151 152 153 154 155 156 157 158 Q6 159 LAB 160 161 162 163 164 165 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=$E(FHLABTE,1,20)_" "_$E(FHLABRE,1,11)_" "_$E(FHLABUN,1,13)_" "_$E(FHLABRR,1,20)_" "_DTP166 167 HEAD 168 169 170 171 172 FOOT 173 174 175 176 177 178 179 180 181 1 FHASMR2 ;HISC/RVD - Progress Notes To TIU ;04/27/07 06:59 2 ;;5.5;DIETETICS;**8**;Apr 27, 2007;Build 28 3 ;input var: fhdfn,na ien (var ASN),dfn 4 ;only process inpatient assessment. 5 ;uses DBIA #1911 6 EN ; save note to a temp global 7 K ^TMP("TIUP",$J) 8 D NOW^%DTC S NOW=% K % S FHN=1 9 S ($P(LN5," ",5),$P(LN10," ",10),$P(LN20," ",20),$P(LN25," ",25),$P(LN30," ",30))="" 10 S ($P(LN35," ",35),$P(LN40," ",40),$P(LN45," ",45),$P(LN50," ",45),$P(LN55," ",55),$P(LN60," ",60))="" 11 S ($P(LN65," ",65))="" 12 S ^TMP("TIUP",$J,FHN,0)=NAM_LN10_$S(SEX="M":"Male",1:"Female")_LN10_"Age: "_AGE 13 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 14 S DTP=ADT D DTP^FH S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Date of Assessment: "_$E(DTP,1,9) 15 S (FHRDIPLD,FHRDIST,FHRDIPL,FHRDINFD,FHRDINA,FHRDINFD,FHRDINF,FHREDU,FHRDIDI,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,FHRNWGT,FHRDNWGT,FHRFUD,FHRFEC,FHRFPC,FHRFDC)="" D DIA 16 EN1 S DTP="" I FHRDIPLD S DTP=FHRDIPLD D DTP^FH 17 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Diagnosis: "_$E(FHRDIPL,1,30) 18 S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH 19 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Problem: "_$E(FHRDINA,1,30) 20 S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH 21 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Additional Problem: "_$E(FHRDINF,1,30) 22 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 23 S FHN=FHN+1 24 S ^TMP("TIUP",$J,FHN,0)="Current Diet: "_$E(FHRDIDI,1,53) 25 I FHRDITF'="" D 26 .S DTP=FHRDITF D DTP^FH 27 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Ordered: "_DTP 28 .I ASN I $D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(^FHPT(FHDFN,"N",ASN,"TF",FHTUN)) Q:FHTUN'>0 D 29 ..S FHASTFZN=$G(^FHPT(FHDFN,"N",ASN,"TF",FHTUN,0)) 30 ..S TNM=$P(FHASTFZN,U,1),STR=$P(FHASTFZN,U,2),QUA=$P(FHASTFZN,U,3) 31 ..S FHTFPROD=$P($G(^FH(118.2,TNM,0)),"^",1)_", "_$S(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")_" Str., "_QUA 32 ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=" "_FHTFPROD 33 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Total Quantity: "_FHRDITFM_"ml"_LN5_"Total KCAL: "_FHRDITFK 34 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Comment: "_FHRDITFC 35 K FHRDIPL,FHRDIPLD,FHRDINF,FHRDINFD,FHRDIDI,FHTFPROD,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,DTP 36 S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_" cm" 37 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1 38 S ^TMP("TIUP",$J,FHN,0)="Height: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_")" I HGP'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" "_$S(HGP="K":"knee hgt",HGP="S":"stated",1:"") 39 S X1=WGT_" lbs",X2=+$J(WGT/2.2,0,1)_" kg" 40 S FHN=FHN+1 41 S ^TMP("TIUP",$J,FHN,0)="Weight: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_")" I WGP'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" "_$S(WGP="A":"anthro",WGP="S":"stated",1:"") 42 S DTP=DWGT D DTP^FH 43 S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_" Weight Taken: "_DTP 44 S X1=FHRNWGT_" lbs",X2=+$J(FHRNWGT/2.2,0,1)_" kg" 45 K FHRNWGT,FHRDNWGT 46 I UWGT S X1=UWGT_" lbs",X2=+$J(UWGT/2.2,0,1)_" kg" 47 S FHN=FHN+1 48 S ^TMP("TIUP",$J,FHN,0)="Usual Weight: " 49 I UWGT S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_")" 50 S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_"% Usual Wt: " 51 I UWGT S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/UWGT*100,3,0)_"%" 52 S X1=IBW_" lbs",X2=+$J(IBW/2.2,0,1)_" kg" 53 S FHN=FHN+1 54 S ^TMP("TIUP",$J,FHN,0)="Target Weight: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_") % Target Wt: " 55 I IBW S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/IBW*100,3,0)_"%" 56 I AMP S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Target weight adjusted for amputation" 57 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Frame Size: "_$S(FRM="S":"Small",FRM="M":"Medium",FRM="L":"Large",1:"") 58 S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN10_" Body Mass Index: "_BMI 59 S EXT="" I $G(TSF)!$G(SCA)!$G(ACIR)!$G(CCIR) S EXT="Y" 60 G:EXT'="Y" EN2 ;there is no antthropometric measurement. 61 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 62 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Anthropometric Measurements" 63 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN35_"%ile %ile" 64 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Triceps Skinfold (mm) "_$J(+TSF,3,0)_" "_$J(TSFP,3)_LN5_"Arm Circumference (cm) " 65 S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+ACIR,3,0)_" "_$J(ACIRP,3) 66 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Subscapular Skinfold (mm) " 67 S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+SCA,3,0)_" "_$J(SCAP,3)_" Bone-free AMA (cm2) " 68 S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+BFAMA,3,0)_" "_$J(BFAMAP,3) 69 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Calf Circumference (cm) " 70 S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+CCIR,3,0)_" "_$J(CCIRP,3) 71 EN2 ;skip here if there is no anthropometric measurement. 72 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 73 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_"Laboratory Data" 74 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Test"_LN20_"Result units"_LN10_"Ref. range"_LN10_"Date" 75 S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" D LAB 76 I 'N1 D 77 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 78 .S FHN=FHN+1,^TMP("TIYP",$J,FHN,0)=LN5_"No laboratory data available last "_$S($D(^FH(119.9,1,3)):$P(^(3),"^",2),1:90)_" days" 79 S N=PRO/6.25 80 DRU ;pharmacy data. 81 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 82 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 83 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Medications" 84 S PX=1 D DRUG^FHASM4 85 I $D(PSCA) D 86 .F FHI=0:0 S FHI=$O(PSCA(FHI)) Q:FHI'>0 S FHJ="" F S FHJ=$O(PSCA(FHI,FHJ)) Q:FHJ="" D 87 ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 88 ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_FHJ 89 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 90 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Educated on Food/Drug Interactions: "_$S(FHREDU="Y":"Yes",1:"No") K FHREDU 91 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="FOOD/DRUG COMMENT: "_FHRFDC 92 K FHI,FHJ,PSD,PSCA 93 ; 94 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 95 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Energy Requirements: "_KCAL_" Kcal/day" 96 I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" Kcal:N "_$J(KCAL/N,0,0)_":1" 97 I NB'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" N-Bal: "_NB 98 I FHRFEC'="" D 99 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Energy calculation is based on: "_FHRFEC 100 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Protein Requirements: "_PRO_" gm/day" 101 I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" NPC:N "_$J(KCAL-(PRO*4)/N,0,0)_":1" 102 I FHRFPC'="" D 103 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Protein calculation is based on: "_FHRFPC 104 K FHRFEC,FHRFPC 105 I FLD'="" D 106 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Fluid Requirements: "_FLD_" ml/day" 107 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 108 I FHAPP'="" D 109 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Appearance: "_FHAPP 110 I XD D 111 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Class: "_$P($G(^FH(115.3,XD,0)),"^",1) 112 I RC D 113 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Status: "_$P($G(^FH(115.4,RC,0)),"^",2) 114 D DCOM 115 Q 116 DIA ;get data from DI node. 117 I ASN S FHDIA=$G(^FHPT(FHDFN,"N",ASN,"DI")) Q:FHDIA="" D 118 .S FHRDIPL=$P(FHDIA,U,1) 119 .S FHRDIPLD=$P(FHDIA,U,2) 120 .S FHRDINF=$P(FHDIA,U,3) 121 .S FHRDINFD=$P(FHDIA,U,4) 122 .S FHRFUD=$P(FHDIA,U,5) 123 .S FHRDIST=$P(FHDIA,U,6) 124 .S FHRDIDI=$P(FHDIA,U,7) 125 .S FHRDITF=$P(FHDIA,U,8) 126 .S FHRDITFM=$P(FHDIA,U,10) 127 .S FHRDITFK=$P(FHDIA,U,11) 128 .S FHRDITFC=$P($G(^FHPT(FHDFN,"N",ASN,4)),U,1) 129 .S FHRFEC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,2) 130 .S FHRFPC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,3) 131 .S FHRDINA=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,4) 132 .S FHREDU=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,5) 133 .S FHRFDC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,6) 134 Q 135 DCOM ;print follow up date and status and comments 136 S DTP="" I FHRFUD S DTP=FHRFUD D DTP^FH 137 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 138 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Follow-up Date: "_DTP 139 K FHRFUD,FHRDIST 140 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 141 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Comments:" 142 I ASN F K=0:0 S K=$O(^FHPT(FHDFN,"N",ASN,"X",K)) Q:K<1 D 143 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=^FHPT(FHDFN,"N",ASN,"X",K,0) 144 S SIGN=$P(^FHPT(FHDFN,"N",ASN,0),U,23) 145 S FHRDT=DT,FHIFN="",FHESBY=FHCLI 146 ;Use data from user selection from file 8925.1 147 K DIC,DA W !!,"Enter a Progress Note Title for this Assessment!!",! 148 S DIC=8925.1,DIC(0)="AEQMZ",DIC("S")="I ($P($G(^TIU(8925.1,+Y,0)),U,7)'=13),($P(^(0),U,1)[""NUTRITION""),($P(^(0),U,4)=""DOC"")" D ^DIC 149 K DIC I X["^"!$D(DTOUT)!(Y<1) S FHOUT=1 Q 150 S FHIEN1=+Y 151 ;call TIU to create a progress notes; DBIA #1911 152 ;D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","",FHESBY,"","") 153 D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","","","","") 154 I $P(FHIFN,U,1)'>0 S FHOUT=1 155 K FHIFN,FHRDT,FHTITLE,FHESBY,FHTIUST,FH251,FHIEN1 156 ;done 157 Q 158 Q6 D FOOT Q 159 LAB S X1=$P(LRTST(K),"^",7) Q:X1="" S DTP=X1\1 D DTP^FH 160 I 'N1 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" S N1=N1+1 161 S FHLABTE=$P(LRTST(K),U,1)_" " 162 S FHLABRE=$P(LRTST(K),U,6)_" " 163 S FHLABUN=$P(LRTST(K),U,4)_" " 164 S FHLABRR=$P(LRTST(K),U,5)_" " 165 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=$E(FHLABTE,1,20)_" "_$E(FHLABRE,1,9)_" "_$E(FHLABUN,1,14)_" "_$E(FHLABRR,1,21)_" "_DTP 166 Q 167 HEAD ; Page Header 168 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN 169 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=DTP_LN30_"NUTRITION ASSESSMENT" 170 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN 171 Q 172 FOOT ; Page Footer 173 D SITE^FH 174 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 175 I $G(DFN) S W1=$G(^DPT(DFN,.1)) S:$D(^DPT(DFN,.101)) W1=W1_"/"_^DPT(DFN,.101) I W1'="" D 176 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 177 .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_W1_LN5_"(Vice SF 509)" 178 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 179 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN 180 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" 181 Q -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHASP1.m
r613 r623 1 FHASP1 2 ;;5.5;DIETETICS;**8,9**;Jan 28, 2005;Build 7 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 F1 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 NOAPP 36 37 LST 38 39 40 41 42 43 CLIN 44 45 46 47 48 49 50 DISP 51 52 53 54 55 56 57 58 59 P0 60 61 62 P1 63 64 65 SP Q:'$P(X,U) S M1=$P(X,"^",2) S:M1="A"!(M1="")M1="BNE" S Z=$G(^FH(115.2,+X,0)) Q:$P(Z,U)=""!($P(Z,U,2)="") S L1=$P(Z,"^",1),KK=$P(Z,"^",2),M="",DAS=$P(X,"^",4)66 67 68 69 70 SP1 71 72 73 MO 74 75 76 77 78 PRERR 79 80 81 82 1 FHASP1 ; HISC/REL/JH - Nutrition Profile (cont) ;5/2/01 10:14 2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 3 ; 4 I '$G(FHET) S X="T-365",%DT="XT" D ^%DT S FHET=Y K %DT 5 S DTP=FHET D DTP^FH S FHENDATE=DTP 6 S N1=0 7 W !!?22,"Dietetic Encounters since ",FHENDATE 8 F FHET=FHET:0 S FHET=$O(^FHEN("AP",DFN,FHET)) Q:FHET<1!(ANS="^") F ASN=0:0 S ASN=$O(^FHEN("AP",DFN,FHET,ASN)) Q:ASN<1 D:$Y'<S1 HF^FHASP Q:ANS="^" D LST 9 Q:ANS="^" 10 I 'N1 W !!?5,"No Encounters recorded since ",FHENDATE 11 S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q 12 S FADM=$O(^FHPT(FHDFN,"A",""),-1) S FADM=$S($G(ADM):$G(ADM),FADM:FADM,1:"") G:FADM="" F1 13 D:$Y'<(S1-6) HF^FHASP Q:ANS="^" W !!?28,$S($G(ADM):"Current",1:"Last")," Admission Monitors" S N1=0 14 ; F NDT=0:0 S NDT=$O(^FHPT(FHDFN,"A",FADM,"MO","AC",NDT)) Q:NDT<1 F K=0:0 S K=$O(^FHPT(FHDFN,"A",FADM,"MO","AC",NDT,K)) Q:K<1 D MO 15 S FHTTLM="",FHTTLM=$P($G(^FHPT(FHDFN,"A",FADM,"MO",0)),U,3) 16 I FHTTLM="" W !,"No Monitors on file." G F1 17 S FHMONS=$S(FHTTLM-FHNUM<0:0,1:FHTTLM-FHNUM) 18 F NDT=FHMONS:0 S NDT=$O(^FHPT(FHDFN,"A",FADM,"MO",NDT)) Q:NDT<1!(ANS="^") S K=NDT D MO 19 Q:ANS="^" I 'N1 W !,"No Monitors on file." 20 F1 D:$Y'<(S1-6) HF^FHASP Q:ANS="^" W !!?32,"Food Preferences" D DISP 21 W !!?27,"Future Clinic Appointments" S N1=0 22 ; 23 ;patch #41 24 ;F NDT=NOW:0 S NDT=$O(^DPT(DFN,"S",NDT)) Q:NDT'>0 S Z=^(NDT,0) I "I"[$P(Z,"^",2) D CLIN Q:ANS="^" 25 K ^TMP($J) 26 S FHCNT="" 27 D GETAPPT^SDAMA201(DFN,"1;2;12","R",DT,,.FHCNT,"") 28 G:'$D(^TMP($J,"SDAMA201","GETAPPT")) NOAPP 29 I $D(^TMP($J,"SDAMA201","GETAPPT")) S FHTMP=$NA(^TMP($J,"SDAMA201","GETAPPT")) 30 I $D(@FHTMP@("ERROR")) D PRERR 31 I $G(FHCNT) F FHI=0:0 S FHI=$O(@FHTMP@(FHI)) Q:FHI'>0 D CLIN I ANS="^" K ^TMP($J) Q 32 K ^TMP($J) 33 ;end changes in patch #41 34 Q:ANS="^" 35 NOAPP I 'N1 W !!?5,"No scheduled appointments." 36 D FOOT^FHASP Q 37 LST S X0=$G(^FHEN(ASN,0)) Q:$P(X0,"^",4)<3 38 S X1=$G(^FHEN(ASN,"P",DFN,0)) 39 W:'N1 ! S N1=N1+1,DTP=$P(X0,"^",2) D DTP^FH W !?5,$E(DTP,1,9)," " S Y=$P(X0,"^",4),Y=$P($G(^FH(115.6,+Y,0)),"^",1) W Y I $P(X0,"^",7)="F" W " (FU)" 40 S Y=$P(X0,"^",9) W ", ",$S(Y="G":"Group",1:"Individual") 41 S Y=$P(X0,"^",11) W:Y'="" !?10,Y S Y=$P(X1,"^",4) W:Y'="" !?10,Y Q 42 ;patch #41 43 CLIN ;S SC=+$P(Z,"^",1),Y=$P($G(^SC(SC,0)),"^",1) Q:Y="" 44 S NDT=@FHTMP@(FHI,1) 45 S SC=$P(@FHTMP@(FHI,2),U,1) 46 S Y=$P(@FHTMP@(FHI,2),U,2) Q:Y="" 47 D:$Y'<S1 HF^FHASP Q:ANS="^" W:'N1 ! S N1=N1+1,DTP=NDT D DTP^FH W !?5,DTP,?25,Y Q 48 ;D:$Y'<S1 HF^FHASP Q:ANS="^" W:'N1 ! S N1=N1+1,DTP=NDT D DTP^FH W !?5,DTP,?25,Y W:$P(Z,"^",11) " (Collateral)" Q 49 ;end changes in patch #41 50 DISP ; Display Food Preferences 51 W !?26,"Likes",?58,"DisLikes",! 52 K P S P1=1 F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0) D SP 53 W ! S (M,MM)="" F S M=$O(P(M)) Q:M="" I $D(P(M)) W $P(M,"~",2) D S MM=M 54 . S (P1,P2)=0 F S:P1'="" P1=$O(P(M,"L",P1)) S X1=$S(P1>0:P(M,"L",P1),1:"") S:P2'="" P2=$O(P(M,"D",P2)) S X2=$S(P2>0:P(M,"D",P2),1:"") Q:P1=""&(P2="") D P0 Q:ANS="^" W:MM'=M ! 55 . Q 56 Q:ANS="^" 57 I $O(P(""))="" W !,"No Food Preferences on file",! 58 Q 59 P0 I X1'="" W ?12 S X=X1 D P1 S X1=X 60 I X2'="" W ?46 S X=X2 D P1 S X2=X 61 Q:X1=""&(X2="") D:$Y'<S1 HF^FHASP Q:ANS="^" W ! G P0 62 P1 I $L(X)<34 W X S X="" Q 63 F KK=35:-1:1 Q:$E(X,KK-1,KK)=", " 64 W $E(X,1,KK-2) S X=$E(X,KK+1,999) Q 65 SP Q:'$P(X,U) S M1=$P(X,"^",2) S:M1="A" M1="BNE" S Z=$G(^FH(115.2,+X,0)) Q:$P(Z,U)=""!($P(Z,U,2)="") S L1=$P(Z,"^",1),KK=$P(Z,"^",2),M="",DAS=$P(X,"^",4) 66 I KK="L" S Q=$P(X,"^",3),L1=$S(Q:Q,1:1)_" "_L1 67 I M1="BNE" S M="1~All Meals" G SP1 68 S Z1=$E(M1,1) I Z1'="" S M=$S(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even") 69 S Z1=$E(M1,2) I Z1'="" S M=M_","_$S(Z1="B":"Break",Z1="N":"Noon",1:"Even") 70 SP1 S:'$D(P(M,KK,P1)) P(M,KK,P1)="" I $L(P(M,KK,P1))+$L(L1)<255 S P(M,KK,P1)=P(M,KK,P1)_$S(P(M,KK,P1)="":"",1:", ")_L1_$S(DAS="Y":" (D)",1:"") 71 E S:'$D(P(M,KK,K)) P(M,KK,K)="" S P(M,KK,K)=L1_$S(DAS="Y":" (D)",1:"") S P1=K 72 Q 73 MO ; Display Monitors 74 S Y=$G(^FHPT(FHDFN,"A",FADM,"MO",K,0)) Q:Y="" S N1=N1+1 75 D:$Y'<S1 HF^FHASP Q:ANS="^" 76 W !,$P(Y,"^",1) S DTP=$P(Y,"^",2) D DTP^FH W ", ",DTP 77 S COM=$P(Y,"^",3) W:COM'="" !?5,"Action: ",COM Q 78 PRERR ;if Scheduling API returns an error, print error in the report. 79 S FHER=$O(@FHTMP@("ERROR",0)) 80 W !!,"*** ERROR in Scheduling API ***" 81 W !,"***",@FHTMP@("ERROR",FHER)," !!!",! 82 Q -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHDSSAPI.m
r613 r623 1 FHDSSAPI ;Hines OIFO/RTK,JRC-DSS REQUESTED API's ;11/23/07 12:40pm 2 ;;5.5;DIETETICS;**7,11,10**;Jan 28, 2005;Build 5 3 ;11/22/2006 KAM/BAY Remedy Call 168346 Add Variable Cleanup from *7 4 ; 5 DATA(FHSDT,FHEDT) ;API for DSS extract of NFS data 6 ; INPUT: START DATE, END DATE 7 ; OUTPUT: ^TMP($J,"FH" 8 ; Get inpatient meals 9 I FHSDT>FHEDT W !!,"END DATE BEFORE START DATE!",! H 1 Q 10 K ^TMP($J,"FH") S FHEDT=FHEDT_.99 11 F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:FHADM'>0 D 12 .I '$D(^FHPT(FHDFN,0)) Q 13 .; Quit if patient is deceased - DSS developer added lines DATA+9,10,13 14 .S FHDCEASE=$$GET1^DIQ(2,$P(^FHPT(FHDFN,0),U,3),".351","I") 15 .Q:FHDCEASE&(FHDCEASE<FHSDT) 16 .S FHZN=$G(^FHPT(FHDFN,"A",FHADM,0)),FHLAST="" 17 .S FHADTM=$P(FHZN,U,1) I FHADTM>FHEDT Q 18 .I '$P(FHZN,U,14),FHDCEASE S $P(FHZN,U,14)=FHDCEASE 19 .S FHDDTM=$P(FHZN,U,14) I FHDDTM'="",FHDDTM<FHSDT Q 20 .F FHDATE=0:0 S FHDATE=$O(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE)) Q:FHDATE'>0!(FHDATE>FHEDT) D 21 ..S FHDSEQ=$P($G(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE,0)),U,2) 22 ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDSEQ,0)) 23 ..I FHDATE<FHSDT I FHLAST'="" K ^TMP($J,"FH",FHADM,FHDFN,FHLAST,"INP") 24 ..S FHLAST=FHDATE 25 ..S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"INP")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 26 .; Get additional feedings for inpatient 27 .F FHDATE=0:0 S FHDATE=$O(^FHPT(FHDFN,"A",FHADM,"EL",FHDATE)) Q:FHDATE'>0!(FHDATE>FHEDT) D 28 ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"EL",FHDATE,0)) 29 ..I FHDATE<FHSDT Q I FHLAST'="" K ^TMP($J,"FH",FHADM,FHDFN,FHLAST,"EL") 30 ..S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"EL")=FHNODE 31 .S FHLAST="" F FHSF=0:0 S FHSF=$O(^FHPT(FHDFN,"A",FHADM,"SF",FHSF)) Q:FHSF'>0 D 32 ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SF",FHSF,0)) 33 ..S FHDATE=$P(FHNODE,U,2) I FHDATE>FHEDT Q 34 ..S FHCDATE=$P(FHNODE,U,32) I FHCDATE'="" I FHCDATE<FHSDT Q 35 ..I FHDATE<FHSDT I FHLAST'="" K ^TMP($J,"FH",FHADM,FHDFN,FHLAST,"SF") 36 ..S FHLAST=FHDATE 37 ..S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"SF")=FHNODE 38 .S FHNUM=0 F FHSO=0:0 S FHSO=$O(^FHPT(FHDFN,"A",FHADM,"SP",FHSO)) Q:FHSO'>0 D 39 ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SP",FHSO,0)) 40 ..S FHDATE=$P(FHNODE,U,4) I FHDATE>FHEDT Q 41 ..S FHCDATE=$P(FHNODE,U,6) I FHCDATE'="" I FHCDATE<FHSDT Q 42 ..S FHNUM=FHNUM+1,^TMP($J,"FH",FHADM,FHDFN,FHDATE,"SO",FHNUM)=FHNODE 43 .S FHLAST="" F FHTF=0:0 S FHTF=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF)) Q:FHTF'>0 D 44 ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,0)) 45 ..S FHDATE=$P(FHNODE,U,1) I FHDATE>FHEDT Q 46 ..S FHCDATE=$P(FHNODE,U,11) I FHCDATE'="" I FHCDATE<FHSDT Q 47 ..I FHDATE<FHSDT I FHLAST'="" K ^TMP($J,"FH",FHADM,FHDFN,FHLAST,"TF") 48 ..S FHLAST=FHDATE 49 ..S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"TF")=FHNODE 50 ..F FHTFPR=0:0 S FHTFPR=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR)) Q:FHTFPR'>0 D 51 ...S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR,0)) 52 ...S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"TF",FHTFPR,"P")=FHNODE 53 ...Q 54 ..Q 55 .Q 56 ; Get outpatient meals 57 S X1=FHSDT,X2=-1 D C^%DTC S FHSDTX1=X_.99 58 ; Get recurring meals 59 F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("RM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHEDT) D 60 .F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHOMDT,FHDFN)) Q:FHDFN="" D 61 ..I '$D(^FHPT(FHDFN,0)) Q 62 ..F FHRNUM=0:0 S FHRNUM=$O(^FHPT("RM",FHOMDT,FHDFN,FHRNUM)) Q:FHRNUM="" D 63 ...S FHNODE=$G(^FHPT(FHDFN,"OP",FHRNUM,0)) I $P(FHNODE,U,15)="C" Q 64 ...I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 65 ...S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RM")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 66 ...; 67 ...; IF NON-VA LOC DIET(S) ARE IN FIELDS DIET1-DIET5 68 ...; 69 ...I $D(^FHPT(FHDFN,"OP",FHRNUM,2)) D 70 ....S FHNODE2=$G(^FHPT(FHDFN,"OP",FHRNUM,2)) I $P(FHNODE2,U,6)="C" Q 71 ....I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 72 ....S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RMEL")=FHNODE2 I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 73 ...I $D(^FHPT(FHDFN,"OP",FHRNUM,3)) D 74 ....S FHNODE3=$G(^FHPT(FHDFN,"OP",FHRNUM,3)) I $P(FHNODE3,U,5)="C" Q 75 ....I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 76 ....S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RMTF")=FHNODE3 I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 77 ....F FHZ=0:0 S FHZ=$O(^FHPT(FHDFN,"OP",FHRNUM,"TF",FHZ)) Q:FHZ'>0 D 78 .....S FHTUZN=$G(^FHPT(FHDFN,"OP",FHRNUM,"TF",FHZ,0)) 79 .....S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RMTF",FHZ)=FHTUZN I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 80 ; Get special meals 81 F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("SM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHEDT) D 82 .F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHOMDT,FHDFN)) Q:FHDFN="" D 83 ..I '$D(^FHPT(FHDFN,0)) Q 84 ..S FHNODE=$G(^FHPT(FHDFN,"SM",FHOMDT,0)) I $P(FHNODE,U,2)'="A" Q 85 ..I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 86 ..S ^TMP($J,"FH",FHOMDT,FHDFN,"SM")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 87 ; Get guest meals 88 F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("GM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHEDT) D 89 .F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHOMDT,FHDFN)) Q:FHDFN="" D 90 ..I '$D(^FHPT(FHDFN,0)) Q 91 ..S FHNODE=$G(^FHPT(FHDFN,"GM",FHOMDT,0)) I $P(FHNODE,U,9)="C" Q 92 ..I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 93 ..S ^TMP($J,"FH",FHOMDT,FHDFN,"GM")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 94 K FHADM,FHDATE,FHDFN,FHDSEQ,FHEL,FHNODE,FHNODE2,FHNODE3,FHOMDT,FHRNUM 95 K FHSDTX1,FHSF,FHSFDT,FHSO,FHSODT,FHTF,FHTFDT,FHTFPR,FHTUZN,FHZ,FHZN 96 K FHCDATE,FHNUM,FHEFF,FHADTM,FHDDTM,FHLAST,X,X1,X2,FHDCEASE 97 Q 1 FHDSSAPI ;Hines OIFO/RTK-DSS REQUESTED API's ;3/08/06 10:15 2 ;;5.5;DIETETICS;**7,11**;Jan 28, 2005;Build 4 3 ;11/22/2006 KAM/BAY Remedy Call 168346 Add Variable Cleanup from *7 4 ; 5 DATA(FHSDT,FHEDT) ;API for DSS extract of NFS data 6 ; INPUT: START DATE, END DATE 7 ; OUTPUT: ^TMP($J,"FH" 8 ; Get inpatient meals 9 I FHSDT>FHEDT W !!,"END DATE BEFORE START DATE!",! H 1 Q 10 K ^TMP($J,"FH") S FHEDT=FHEDT_.99 11 F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:FHADM'>0 F FHDATE=FHSDT:0 S FHDATE=$O(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE)) Q:FHDATE'>0!(FHDATE>FHEDT) D 12 .S FHDSEQ=$P($G(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE,0)),U,2) 13 .S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDSEQ,0)) 14 .S ^TMP($J,"FH",FHDATE,FHDFN,FHADM,"INP")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 15 ; Get additional feedings for inpatient 16 F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:'FHADM D 17 .F FHEL=FHSDT:0 S FHEL=$O(^FHPT(FHDFN,"A",FHADM,"EL",FHEL)) Q:FHEL'>0!(FHEL>FHEDT) D 18 ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"EL",FHEL,0)) 19 ..S ^TMP($J,"FH",FHEL,FHDFN,FHADM,"EL")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 20 .F FHSF=0:0 S FHSF=$O(^FHPT(FHDFN,"A",FHADM,"SF",FHSF)) Q:FHSF'>0 D 21 ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SF",FHSF,0)),FHSFDT=$P(FHNODE,U,2) 22 ..I FHSFDT<FHSDT!(FHSFDT>FHEDT) Q 23 ..S ^TMP($J,"FH",FHSFDT,FHDFN,FHADM,"SF")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 24 .F FHSO=0:0 S FHSO=$O(^FHPT(FHDFN,"A",FHADM,"SP",FHSO)) Q:FHSO'>0 D 25 ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SP",FHSO,0)),FHSODT=$P(FHNODE,U,4) 26 ..I FHSODT<FHSDT!(FHSODT>FHEDT) Q 27 ..S ^TMP($J,"FH",FHSODT,FHDFN,FHADM,"SO")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 28 .F FHTF=0:0 S FHTF=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF)) Q:FHTF'>0 D 29 ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,0)),FHTFDT=$P(FHNODE,U,1) 30 ..I FHTFDT<FHSDT!(FHTFDT>FHEDT) Q 31 ..S ^TMP($J,"FH",FHTFDT,FHDFN,FHADM,"TF")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 32 ..F FHTFPR=0:0 S FHTFPR=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR)) Q:FHTFPR'>0 D 33 ...S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR,0)) 34 ...S ^TMP($J,"FH",FHTFDT,FHDFN,FHADM,"TF",FHTFPR,"P")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 35 ..Q 36 .Q 37 ; Get outpatient meals 38 S X1=FHSDT,X2=-1 D C^%DTC S FHSDTX1=X_.99 39 ; Get recurring meals 40 F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("RM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHEDT) D 41 .F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHOMDT,FHDFN)) Q:FHDFN="" D 42 ..F FHRNUM=0:0 S FHRNUM=$O(^FHPT("RM",FHOMDT,FHDFN,FHRNUM)) Q:FHRNUM="" D 43 ...S FHNODE=$G(^FHPT(FHDFN,"OP",FHRNUM,0)) I $P(FHNODE,U,15)="C" Q 44 ...I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 45 ...S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RM")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 46 ...; 47 ...; SHOULD LET DSS KNOW DIETS COULD BE IN FIELDS DIET1-5 IF NONVA LOC 48 ...; 49 ...I $D(^FHPT(FHDFN,"OP",FHRNUM,2)) D 50 ....S FHNODE2=$G(^FHPT(FHDFN,"OP",FHRNUM,2)) I $P(FHNODE2,U,6)="C" Q 51 ....I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 52 ....S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RMEL")=FHNODE2 I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 53 ...I $D(^FHPT(FHDFN,"OP",FHRNUM,3)) D 54 ....S FHNODE3=$G(^FHPT(FHDFN,"OP",FHRNUM,3)) I $P(FHNODE3,U,5)="C" Q 55 ....I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 56 ....S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RMTF")=FHNODE3 I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 57 ....F FHZ=0:0 S FHZ=$O(^FHPT(FHDFN,"OP",FHRNUM,"TF",FHZ)) Q:FHZ'>0 D 58 .....S FHTUZN=$G(^FHPT(FHDFN,"OP",FHRNUM,"TF",FHZ,0)) 59 .....S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RMTF",FHZ)=FHTUZN I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 60 ; Get special meals 61 F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("SM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHEDT) D 62 .F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHOMDT,FHDFN)) Q:FHDFN="" D 63 ..S FHNODE=$G(^FHPT(FHDFN,"SM",FHOMDT,0)) I $P(FHNODE,U,2)'="A" Q 64 ..I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 65 ..S ^TMP($J,"FH",FHOMDT,FHDFN,"SM")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 66 ; Get guest meals 67 F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("GM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHEDT) D 68 .F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHOMDT,FHDFN)) Q:FHDFN="" D 69 ..S FHNODE=$G(^FHPT(FHDFN,"GM",FHOMDT,0)) I $P(FHNODE,U,9)="C" Q 70 ..I $P($G(^FHPT(FHDFN,0)),U,3)="" Q 71 ..S ^TMP($J,"FH",FHOMDT,FHDFN,"GM")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) 72 K FHADM,FHDATE,FHDFN,FHDSEQ,FHEL,FHNODE,FHNODE2,FHNODE3,FHOMDT,FHRNUM 73 K FHSDTX1,FHSF,FHSFDT,FHSO,FHSODT,FHTF,FHTFDT,FHTFPR,FHTUZN,FHZ,X,X1,X2 74 Q -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHNO2.m
r613 r623 1 FHNO2 ; HISC/REL/NCA - Supplemental Feeding Labels ;8/26/94 12:01 2 ;;5.5;DIETETICS;**5,13**;Jan 28, 2005;Build 1 3 ;patch #5 - add outpatient SFs. 4 D0 R !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME G:'$T!("^"[XX) KIL I "sw"[XX S X=XX D TR^FH S XX=X 5 I XX'?1U!("SW"'[XX) W *7," Enter S or W" G D0 6 I XX="S" S D1=$O(^FH(119.74,0)) I D1'<1,$O(^FH(119.74,D1))<1 G D3 7 I XX="W" S WRD=$O(^FH(119.6,0)) I WRD'<1,$O(^FH(119.6,WRD))<1 G D3 8 I XX="S" G D2 9 D1 R !!,"Select WARD: ",X:DTIME G:'$T!("^"[X) KIL 10 K DIC S DIC="^FH(119.6,",DIC(0)="EMQ" D ^DIC G:Y<1 D1 S W1=+Y 11 S D1=$P($G(^FH(119.6,W1,0)),"^",9) G D3 12 D2 R !!,"Select SUPPLEMENTAL FEEDING SITE: ",X:DTIME G:'$T!("^"[X) KIL 13 K DIC S DIC="^FH(119.74,",DIC(0)="EMQ" D ^DIC G:Y<1 D2 S D1=+Y,W1=0 14 D3 R !!,"Select Supplemental Feeding Time (10,2,8,ALL): ",TIM:DTIME G KIL:'$T!(U[TIM) I TIM="all" S X=TIM D TR^FH S TIM=X 15 I TIM'=2,TIM'=8,TIM'=10,TIM'="ALL" W *7," Enter a time, 10,2,8, or ALL" G D3 16 W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If using laser label sheets, what row do you want to begin printing at? ",DIR("B")=1 D ^DIR 17 Q:$D(DIRUT) S LABSTART=Y 18 D4 R !!,"Do you want Ingredient list only? N// ",D3:DTIME G:'$T!(D3="^") KIL S:D3="" D3="N" S X=D3 D TR^FH S D3=X I $P("YES",D3,1)'="",$P("NO",D3,1)'="" W *7," Answer YES or NO" G D4 19 S D3=$E(D3,1),D3=D3="Y" G:'D3 D6 20 D5 R !!,"Consolidated List only? Y// ",X:DTIME G:'$T!(X="^") KIL S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G D5 21 S X=$E(X,1) S:X="Y" D3=D3+1 22 D6 I 'D3,'D1,XX="L" W !!,"No Supplemental Feeding Site associated with this location." G KIL 23 W:'D3 !!,"Place Labels in Printer" 24 PR K IOP S %ZIS="MQ",%ZIS("A")="Select "_$S('D3:"LABEL",1:"LIST")_" Printer: " W ! D ^%ZIS K %ZIS,IOP G:POP KIL 25 I $D(IO("Q")) S FHPGM="Q1^FHNO2",FHLST="XX^TIM^W1^D1^D3^LABSTART" D EN2^FH G KIL 26 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL 27 Q1 ; Process Printing Supplemental Feeding Labels 28 S TIMSAV=TIM 29 D NOW^%DTC S NOW=%,DT=%\1 G:D3=2 SUM 30 I 'D3 Q:'D1 S FHPAR=$G(^FH(119.74,D1,0)),LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1 31 S COUNT=0,LINE=1 I TIM="ALL" S TIM=10 D Q2 S TIM=2 D Q2 S TIM=8 32 D Q2 33 I $G(LAB)>2 D DPLL^FHLABEL,KIL Q 34 I 'D3 F L=1:1:18 W ! 35 KIL K ^TMP($J) G KILL^XUSCLEAN 36 Q2 K ^TMP($J,"L"),^TMP($J,"I"),^TMP($J,"SF"),C S P1=$S(TIM=10:5,TIM=2:13,1:21),T0=$P(DT,".",1)_"."_$S(TIM=10:1,TIM=2:14,1:2),P3=7,N1=0 37 I XX="W" S P0=$P($G(^FH(119.6,W1,0)),"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 38 I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 S P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 39 D SF0 40 G ^FHNO21:'D3,PRT 41 F0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 42 F1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN'>0 S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 F1 43 G:'$D(^FHPT(FHDFN,"A",ADM,0)) F1 S X1=^(0),NO=$P(X1,"^",7) G:'NO F1 44 I 'D3 S IS=$P(X1,"^",10) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" 45 D CHK G:'NO F1 46 S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)) 47 S Y=$P(Y,"^",P1,P1+7) G:Y?."^" F1 D:D3 CALC 48 I 'D3 D 49 .D PATNAME^FHOMUTL I DFN="" Q 50 .S $P(Y,"^",9)=IS 51 .S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) 52 .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") 53 .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") 54 .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) 55 .S RM=$G(^DPT(DFN,.101)),PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM 56 .S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD Q 57 G F1 58 Q 59 ; 60 CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1 61 I X1>1,X1'>T0 G C2 62 C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2 63 S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO="" 64 C1 K FHORD,A1,K,X1 Q 65 C2 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>T0) S A1=K 66 G:'A1 C1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G:FHORD'<1 C0 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G C2 67 SUM K C,^TMP($J,"SF") S P0=$S(TIM=2:13,TIM=8:21,1:5),P3=$S(TIM="ALL":23,1:7),N1=0 68 I XX="W" S X=$G(^FH(119.6,W1,0)) D S0 69 I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 D S0 70 D SF0 71 G PRT 72 S0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 73 S1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 S1 74 G:'$D(^FHPT(FHDFN,"A",ADM,0)) S1 S X1=^(0),NO=$P(X1,"^",7) G:'NO S1 75 S Y=$P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3) G:Y?."^" S1 D CALC 76 G S1 77 PRT S DTP=DT D DTP^FH S DTE=DTP_" "_$S(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM") 78 S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:WRDN) 79 W @IOF W:D3=2 !?5,"**** CONSOLIDATED ****" W !?3,"**** INGREDIENTS LIST ****",! W:D3=1 ! W ?(33-$L(Y)\2),Y,!?9,DTE,!! 80 F L=0:0 S L=$O(^FH(118,L)) Q:L<1 S:$D(C(L)) ^TMP($J,"SF",$P($G(^FH(118,L,0)),"^",1),L)="" 81 S A1="" F S A1=$O(^TMP($J,"SF",A1)) Q:A1="" F L=0:0 S L=$O(^TMP($J,"SF",A1,L)) Q:L<1 W !,$E(A1,1,26),?28,$J(C(L),5,0) 82 W !!?4,"**** PATIENTS = ",N1," ****",! Q 83 CALC S N1=N1+1 84 F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q 85 Q 86 ; 87 SF0 ;outpatient SFs 88 F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",DT,FHDFN)) Q:FHDFN'>0 F ADM=0:0 S ADM=$O(^FHPT("RM",DT,FHDFN,ADM)) Q:ADM'>0 D 89 .S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO) 90 .S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3) 91 .S X1=$G(^FH(119.6,FHOWARD,0)) 92 .Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0)) 93 .I XX="W",W1 Q:W1'=FHOWARD 94 .S WRDN=$P(X1,U,1) 95 .I XX="S" S D2=$P(X1,"^",9) Q:D1'=D2 I D1=D2 S P0=$P(X1,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) 96 .S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5) 97 .I (FHMEAL="B"),(TIM'=10) Q 98 .I (FHMEAL="N"),(TIM'=2) Q 99 .I (FHMEAL="E"),(TIM'=8) Q 100 .I 'D3 S IS=$P($G(^FHPT(FHDFN,0)),"^",5) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" 101 .S Y=$G(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0)) 102 .S Y=$P(Y,"^",P1,P1+7) Q:Y?."^" I D3 D CLC1 103 .S N1=N1+1 104 .S RM="",RMIEN=$P(FHODAT,U,18) I $G(RMIEN),$D(^DG(405.4,RMIEN,0)) S RM=$E($P(^DG(405.4,RMIEN,0),U,1),1,10) 105 .I 'D3 D 106 ..D PATNAME^FHOMUTL 107 ..S $P(Y,"^",9)=IS 108 ..S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) 109 ..S RI="***" S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") 110 ..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") 111 ..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) 112 ..S PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM 113 ..S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD 114 Q 115 CLC1 ; 116 F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q 117 Q 1 FHNO2 ; HISC/REL/NCA - Supplemental Feeding Labels ;8/26/94 12:01 2 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53 3 ;patch #5 - add outpatient SFs. 4 D0 R !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME G:'$T!("^"[XX) KIL I "sw"[XX S X=XX D TR^FH S XX=X 5 I XX'?1U!("SW"'[XX) W *7," Enter S or W" G D0 6 I XX="S" S D1=$O(^FH(119.74,0)) I D1'<1,$O(^FH(119.74,D1))<1 G D3 7 I XX="W" S WRD=$O(^FH(119.6,0)) I WRD'<1,$O(^FH(119.6,WRD))<1 G D3 8 I XX="S" G D2 9 D1 R !!,"Select WARD: ",X:DTIME G:'$T!("^"[X) KIL 10 K DIC S DIC="^FH(119.6,",DIC(0)="EMQ" D ^DIC G:Y<1 D1 S W1=+Y 11 S D1=$P($G(^FH(119.6,W1,0)),"^",9) G D3 12 D2 R !!,"Select SUPPLEMENTAL FEEDING SITE: ",X:DTIME G:'$T!("^"[X) KIL 13 K DIC S DIC="^FH(119.74,",DIC(0)="EMQ" D ^DIC G:Y<1 D2 S D1=+Y,W1=0 14 D3 R !!,"Select Supplemental Feeding Time (10,2,8,ALL): ",TIM:DTIME G KIL:'$T!(U[TIM) I TIM="all" S X=TIM D TR^FH S TIM=X 15 I TIM'=2,TIM'=8,TIM'=10,TIM'="ALL" W *7," Enter a time, 10,2,8, or ALL" G D3 16 W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If using laser label sheets, what row do you want to begin printing at? ",DIR("B")=1 D ^DIR 17 Q:$D(DIRUT) S LABSTART=Y 18 D4 R !!,"Do you want Ingredient list only? N// ",D3:DTIME G:'$T!(D3="^") KIL S:D3="" D3="N" S X=D3 D TR^FH S D3=X I $P("YES",D3,1)'="",$P("NO",D3,1)'="" W *7," Answer YES or NO" G D4 19 S D3=$E(D3,1),D3=D3="Y" G:'D3 D6 20 D5 R !!,"Consolidated List only? Y// ",X:DTIME G:'$T!(X="^") KIL S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G D5 21 S X=$E(X,1) S:X="Y" D3=D3+1 22 D6 I 'D3,'D1,XX="L" W !!,"No Supplemental Feeding Site associated with this location." G KIL 23 W:'D3 !!,"Place Labels in Printer" 24 PR K IOP S %ZIS="MQ",%ZIS("A")="Select "_$S('D3:"LABEL",1:"LIST")_" Printer: " W ! D ^%ZIS K %ZIS,IOP G:POP KIL 25 I $D(IO("Q")) S FHPGM="Q1^FHNO2",FHLST="XX^TIM^W1^D1^D3^LABSTART" D EN2^FH G KIL 26 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL 27 Q1 ; Process Printing Supplemental Feeding Labels 28 S TIMSAV=TIM 29 D NOW^%DTC S NOW=%,DT=%\1 G:D3=2 SUM 30 I 'D3 Q:'D1 S FHPAR=$G(^FH(119.74,D1,0)),LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1 31 S COUNT=0,LINE=1 I TIM="ALL" S TIM=10 D Q2 S TIM=2 D Q2 S TIM=8 32 D Q2 33 I $G(LAB)>2 D DPLL^FHLABEL,KIL Q 34 I 'D3 F L=1:1:18 W ! 35 KIL K ^TMP($J) G KILL^XUSCLEAN 36 Q2 K ^TMP($J,"L"),^TMP($J,"I"),^TMP($J,"SF"),C S P1=$S(TIM=10:5,TIM=2:13,1:21),T0=$P(DT,".",1)_"."_$S(TIM=10:1,TIM=2:14,1:2),P3=7,N1=0 37 I XX="W" S P0=$P($G(^FH(119.6,W1,0)),"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 38 I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 S P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 39 D SF0 40 G ^FHNO21:'D3,PRT 41 F0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 42 F1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN'>0 S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 F1 43 G:'$D(^FHPT(FHDFN,"A",ADM,0)) F1 S X1=^(0),NO=$P(X1,"^",7) G:'NO F1 44 I 'D3 S IS=$P(X1,"^",10) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" 45 D CHK G:'NO F1 46 S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)) 47 S Y=$P(Y,"^",P1,P1+7) G:Y?."^" F1 D:D3 CALC 48 I 'D3 D 49 .D PATNAME^FHOMUTL I DFN="" Q 50 .S $P(Y,"^",9)=IS 51 .S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) 52 .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") 53 .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") 54 .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) 55 .S RM=$G(^DPT(DFN,.101)),PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM 56 .S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD Q 57 G F1 58 Q 59 ; 60 CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1 61 I X1>1,X1'>T0 G C2 62 C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2 63 S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO="" 64 C1 K FHORD,A1,K,X1 Q 65 C2 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>T0) S A1=K 66 G:'A1 C1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G:FHORD'<1 C0 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G C2 67 SUM K C,^TMP($J,"SF") S P0=$S(TIM=2:13,TIM=8:21,1:5),P3=$S(TIM="ALL":23,1:7),N1=0 68 I XX="W" S X=$G(^FH(119.6,W1,0)) D S0 69 I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 D S0 70 D SF0 71 G PRT 72 S0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 73 S1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 S1 74 G:'$D(^FHPT(FHDFN,"A",ADM,0)) S1 S X1=^(0),NO=$P(X1,"^",7) G:'NO S1 75 S Y=$P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3) G:Y?."^" S1 D CALC 76 G S1 77 PRT S DTP=DT D DTP^FH S DTE=DTP_" "_$S(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM") 78 S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:WRDN) 79 W @IOF W:D3=2 !?5,"**** CONSOLIDATED ****" W !?3,"**** INGREDIENTS LIST ****",! W:D3=1 ! W ?(33-$L(Y)\2),Y,!?9,DTE,!! 80 F L=0:0 S L=$O(^FH(118,L)) Q:L<1 S:$D(C(L)) ^TMP($J,"SF",$P($G(^FH(118,L,0)),"^",1),L)="" 81 S A1="" F S A1=$O(^TMP($J,"SF",A1)) Q:A1="" F L=0:0 S L=$O(^TMP($J,"SF",A1,L)) Q:L<1 W !,$E(A1,1,26),?28,$J(C(L),5,0) 82 W !!?4,"**** PATIENTS = ",N1," ****",! Q 83 CALC S N1=N1+1 84 F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q 85 Q 86 ; 87 SF0 ;outpatient SFs 88 F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",DT,FHDFN)) Q:FHDFN'>0 F ADM=0:0 S ADM=$O(^FHPT("RM",DT,FHDFN,ADM)) Q:ADM'>0 D 89 .S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO) 90 .S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3) 91 .S X1=$G(^FH(119.6,FHOWARD,0)),WRDN=$P(X1,U,1) 92 .Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0)) 93 .I XX="W",W1 Q:W1'=FHOWARD 94 .I XX="S" S D2=$P(X1,"^",9) Q:D1'=D2 I D1=D2 S P0=$P(X1,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) 95 .S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5) 96 .I (FHMEAL="B"),(TIM'=10) Q 97 .I (FHMEAL="N"),(TIM'=2) Q 98 .I (FHMEAL="E"),(TIM'=8) Q 99 .I 'D3 S IS=$P($G(^FHPT(FHDFN,0)),"^",5) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" 100 .S Y=$G(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0)) 101 .S Y=$P(Y,"^",P1,P1+7) Q:Y?."^" I D3 D CLC1 102 .S N1=N1+1 103 .S RM="",RMIEN=$P(FHODAT,U,18) I $G(RMIEN),$D(^DG(405.4,RMIEN,0)) S RM=$E($P(^DG(405.4,RMIEN,0),U,1),1,10) 104 .I 'D3 D 105 ..D PATNAME^FHOMUTL 106 ..S $P(Y,"^",9)=IS 107 ..S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) 108 ..S RI="***" S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") 109 ..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") 110 ..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) 111 ..S PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM 112 ..S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD 113 Q 114 CLC1 ; 115 F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q 116 Q -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHOMPP.m
r613 r623 1 FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;7/2/20072 ;;5.5;DIETETICS;**9**;Jan 28, 2005;Build 7 3 4 DEV 5 6 7 8 9 10 11 12 DISP 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 PG 39 40 41 HDR 42 43 44 45 END 46 47 48 CPRS 49 50 51 K ^TMP($J,"FHPROF"),^TMP($J,"L"),^TMP($J,"D") S (FHX,N)=0 D PATNAME^FHOMUTL52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"L",FHM,FHP) 70 71 72 .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"D",FHM,FHP) 73 74 75 76 77 NEWL 78 79 80 1 FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;6/23/03 1:04 2 ;;5.5;DIETETICS;;Jan 28, 2005 3 D DEV Q 4 DEV ;get device and set up queue 5 W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP 6 I '$D(IO("Q")) U IO D DISP,^%ZISC,END Q 7 S ZTRTN="DISP^FHOMPP" 8 S ZTSAVE("FHDFN")="" 9 S ZTDESC="Outpatient Meals Recurring Meals Display" D ^%ZTLOAD 10 D ^%ZISC K %ZIS,IOP 11 D END Q 12 DISP ; 13 S EX="" D HDR 14 D ALG^FHCLN I ALG'="" W !!,"Allergies: ",ALG 15 K ^TMP($J) F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D 16 .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) 17 .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) 18 .Q:FHFPIEN="" 19 .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) 20 .S FHMEAL=FHNORD_FHMEAL 21 .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" 22 .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" 23 .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM 24 .Q 25 W !!,"Food Preferences Currently on file: " 26 I $D(^TMP($J,"L")) W !!?20,"Likes" 27 S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM=""!(EX=U) D 28 .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0 W !!,^TMP($J,"L",FHM,FHP) I $Y>(IOSL-4) D PG I EX=U Q 29 I $D(^TMP($J,"D")) W !!?20,"Dislikes" 30 S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM=""!(EX=U) D 31 .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0 W !!,^TMP($J,"D",FHM,FHP) I $Y>(IOSL-4) D PG I EX=U Q 32 ; 33 S FHIPX=$P($G(^FHPT(FHDFN,0)),U,5) I FHIPX'="" W !!,"Isolation/Precaution type is ",$P($G(^FH(119.4,FHIPX,0)),"^",1) I $Y>(IOSL-4) D PG I EX=U Q 34 W !!,"Recurring Meals on File: " I $Y>(IOSL-4) D PG I EX=U Q 35 W ! S STDT=DT S FHPP=1 D DISP^FHOMRR1 K FHPP 36 I EX'=U,IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR 37 Q 38 PG ; 39 I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q 40 D HDR Q 41 HDR ; 42 W:$Y @IOF 43 W !!,"OUTPATIENT NAME: " D PATNAME^FHOMUTL W FHPTNM," ",FHSSN 44 W ?65,FHSEX," Age ",FHAGE Q 45 END ; 46 K FHM,FHP,FHT Q 47 ; 48 CPRS ; Call from FHWOR71 to get outpatient profile for CPRS 49 ; Data is returned in ^TMP($J,"FHPROF",DFN,FHX) 50 S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q "-1^Invalid outpatient" 51 K ^TMP($J,"FHPROF",DFN) S (FHX,N)=0 D PATNAME^FHOMUTL 52 S FHB="" F I=1:1:80 S FHB=FHB_" " 53 S ^TMP($J,"FHPROF",DFN,FHX)="OUTPATIENT NAME: "_FHPTNM_" "_FHSSN 54 S FHJ=66 D PAD^FHOMPP1 S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"FHPROF",DFN,FHX)_PAD_FHSEX_" Age "_FHAGE 55 D ALG^FHCLN I ALG'="" S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Allergies: "_ALG 56 F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D 57 .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) 58 .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) 59 .Q:FHFPIEN="" 60 .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) 61 .S FHMEAL=FHNORD_FHMEAL 62 .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" 63 .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" 64 .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM 65 .Q 66 S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Food Preferences Currently on file: " 67 I $D(^TMP($J,"L")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Likes" 68 S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM="" D 69 .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"L",FHM,FHP) Q 70 I $D(^TMP($J,"D")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Dislikes" 71 S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM="" D 72 .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"D",FHM,FHP) Q 73 ; 74 S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Recurring Meals on File: " 75 S STDT=DT D ^FHOMPP1 76 Q 77 NEWL ;New line before next line of text in ^TMP global 78 I N=1 S FHX=FHX+1,^TMP($J,"FHPROF",DFN,FHX)=" " 79 S FHX=FHX+1 80 Q -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHORC5.m
r613 r623 1 FHORC5 ; HISC/REL - Consult Management ;4/12/06 13:26 2 ;;5.5;DIETETICS;**4,12**;Jan 28, 2005;Build 3 3 ; 10/17/2007 BP/KAM FH*5.5*12 Rem Call 210883 Remove Old Clinician Field (#1) 4 EN9 ; Enter/Edit Ward Assignments 5 K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQM" 6 W ! D ^DIC G KIL:U[X!$D(DTOUT),EN9:Y<1 S OLD=$S($P(Y,"^",3):"",1:$P(^FH(119.6,+Y,0),"^",2)) 7 ; 10/17/2007 BP/KAM *12 Rem Call 210883 Removed field #1 in next line 8 S DA=+Y,DR="112" D ^DIE S NEW=$P(^FH(119.6,DA,0),"^",2) I 'NEW!('OLD) K OLD,NEW,X,Y G EN9 9 D:OLD'=NEW EN2^FHORC4 K OLD,NEW,X,Y G EN9 10 EN10 ; List Ward Assignments 11 W ! S L=0,DIC="^FH(119.6,",FLDS="[FHORWRD]",BY=".01" 12 S (FR,TO)="",DHD="NUTRITION LOCATION ASSIGNMENTS" D EN1^DIP,RSET Q 13 EN11 ; Enter/Edit Consult Types 14 S (DIC,DIE)="^FH(119.5,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=119.5 15 W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN11:Y<1 16 S DA=+Y,DR=".01:2;S FHA1=X;3;S Y=$S(FHA1=""Y"":4,1:5);4;5:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.5 D ^DIE K DA,DIE,DIDEL,DR,FHA1 G EN11 17 EN12 ; List Consult Types 18 W !!,"The list requires a 132 column printer.",! 19 W ! S L=0,DIC="^FH(119.5,",FLDS="[FHORCON]",BY=".01" 20 S (FR,TO)="",DHD="CONSULTATION TYPES" D EN1^DIP,RSET Q 21 RSET K %ZIS S IOP="" D ^%ZIS 22 KIL K %,%ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,NEW,OLD,TO,X,Y Q 1 FHORC5 ; HISC/REL - Consult Management ;4/12/06 13:26 2 ;;5.5;DIETETICS;**4**;Jan 28, 2005;Build 32 3 EN9 ; Enter/Edit Ward Assignments 4 K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQM" 5 W ! D ^DIC G KIL:U[X!$D(DTOUT),EN9:Y<1 S OLD=$S($P(Y,"^",3):"",1:$P(^FH(119.6,+Y,0),"^",2)) 6 S DA=+Y,DR="1;112" D ^DIE S NEW=$P(^FH(119.6,DA,0),"^",2) I 'NEW!('OLD) K OLD,NEW,X,Y G EN9 7 D:OLD'=NEW EN2^FHORC4 K OLD,NEW,X,Y G EN9 8 EN10 ; List Ward Assignments 9 W ! S L=0,DIC="^FH(119.6,",FLDS="[FHORWRD]",BY=".01" 10 S (FR,TO)="",DHD="NUTRITION LOCATION ASSIGNMENTS" D EN1^DIP,RSET Q 11 EN11 ; Enter/Edit Consult Types 12 S (DIC,DIE)="^FH(119.5,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=119.5 13 W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN11:Y<1 14 S DA=+Y,DR=".01:2;S FHA1=X;3;S Y=$S(FHA1=""Y"":4,1:5);4;5:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.5 D ^DIE K DA,DIE,DIDEL,DR,FHA1 G EN11 15 EN12 ; List Consult Types 16 W !!,"The list requires a 132 column printer.",! 17 W ! S L=0,DIC="^FH(119.5,",FLDS="[FHORCON]",BY=".01" 18 S (FR,TO)="",DHD="CONSULTATION TYPES" D EN1^DIP,RSET Q 19 RSET K %ZIS S IOP="" D ^%ZIS 20 KIL K %,%ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,NEW,OLD,TO,X,Y Q -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHPRO.m
r613 r623 1 FHPRO ; HISC/REL/RTK - Food Production Manager ;4/12/06 15:53 2 ;;5.5;DIETETICS;**4,5,12**;Jan 28, 2005;Build 3 3 ; 4 ; 10/16/2007 BY/KAM FH*5.5*12 Rem Call 210883 Remove access to old 5 ; Clinician field 6 EN2 ; Enter/Edit Nutrition Locations (Inpatient Wards/Outpatient Clinics) 7 W ! K DIR,DIC S DIR("A")="Select WARD or OUTPATIENT Location: " 8 S DIR(0)="SAO^W:Ward Location;O:Outpatient Location" D ^DIR I $D(DIRUT) G KIL 9 I Y'=-1 S FHANS=Y 10 I FHANS="W" D EN2WRD Q 11 I FHANS="O" D EN2OL Q 12 Q 13 EN2WRD ;Ward locations 14 K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 15 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 16 ; S DR=".01;2:2.5;... POTENTIAL CHG FOR 210883 WAS S DR=".01:2.5;3" 17 ; 10/16/2007 BP/KAM FH*5.5*12 changed next line to remove access to field # 1 Clinician (Old Clinician field) 18 S DA=+Y,DR=".01;2:2.5;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6:29;99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2 19 EN2OL ;Outpatient locations 20 K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 21 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 22 S DA=+Y,DR=".01;2;2.6;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6;7;103:106;11;20:99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2 23 EN3 ; Enter/Edit Production Diets 24 K DIC S (DIC,DIE)="^FH(116.2,",DIC(0)="AEQLM",DLAYGO=116.2 25 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN3:Y<1 26 S DA=+Y,DR=$S(DA=1:"1:8",1:".01:7.5;10;S:X'=""Y"" Y=8;11;8;12:99") S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=116.2 D ^DIE I '$D(DA) D KIL G EN3 27 S:$O(^FH(116.2,DA,"R",0))<1 $P(^FH(116.2,DA,0),"^",4)="N" D KIL G EN3 28 EN4 ; List Production Diets 29 W !!,"The list requires a 132 column printer.",! 30 W ! S L=0,DIC="^FH(116.2,",FLDS="[FHPROD]",BY="8,.01" 31 S FR="@",TO="",DHD="PRODUCTION DIETS" D EN1^DIP,RSET Q 32 EN5 ; Enter/Edit Production Facilities 33 K DIC S (DIC,DIE)="^FH(119.71,",DIC(0)="AEQLM",DLAYGO=119.71 34 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN5:Y<1 35 S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.71 D ^DIE,KIL G EN5 36 EN6 ; Enter/Edit Service Points 37 K DIC S (DIC,DIE)="^FH(119.72,",DIC(0)="AEQLM",DLAYGO=119.72 38 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN6:Y<1 39 S DA=+Y S DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.72 D ^DIE I '$D(DA) D KIL G EN6 40 S DA(1)=DA S DIK="^FH(119.72,DA(1),""A""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"A",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,8)?."^" D ^DIK 41 S DIK="^FH(119.72,DA(1),""B""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"B",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,22)?."^" D ^DIK 42 D KIL G EN6 43 EN7 ; Enter/Edit Communication Offices 44 K DIC S (DIC,DIE)="^FH(119.73,",DIC(0)="AEQLM",DLAYGO=119.73 45 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN7:Y<1 46 S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.73 D ^DIE,KIL G EN7 47 EN8 ; Enter/Edit Supplemental Feeding Sites 48 K DIC S (DIC,DIE)="^FH(119.74,",DIC(0)="AEQLM",DLAYGO=119.74 49 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN8:Y<1 50 S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.74 D ^DIE,KIL G EN8 51 RSET K %ZIS S IOP="" D ^%ZIS 52 KIL G KILL^XUSCLEAN 1 FHPRO ; HISC/REL/RTK - Food Production Manager ;4/12/06 15:53 2 ;;5.5;DIETETICS;**4,5**;Jan 28, 2005;Build 53 3 EN2 ; Enter/Edit Nutrition Locations (Inpatient Wards/Outpatient Clinics) 4 W ! K DIR,DIC S DIR("A")="Select WARD or OUTPATIENT Location: " 5 S DIR(0)="SAO^W:Ward Location;O:Outpatient Location" D ^DIR Q:$D(DIRUT) 6 I Y'=-1 S FHANS=Y 7 I FHANS="W" D EN2WRD Q 8 I FHANS="O" D EN2OL Q 9 Q 10 EN2WRD ;Ward locations 11 K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 12 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 13 S DA=+Y,DR=".01:2.5;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6:29;99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2 14 EN2OL ;Outpatient locations 15 K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 16 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 17 S DA=+Y,DR=".01;2;2.6;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6;7;103:106;11;20:99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2 18 EN3 ; Enter/Edit Production Diets 19 K DIC S (DIC,DIE)="^FH(116.2,",DIC(0)="AEQLM",DLAYGO=116.2 20 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN3:Y<1 21 S DA=+Y,DR=$S(DA=1:"1:8",1:".01:7.5;10;S:X'=""Y"" Y=8;11;8;12:99") S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=116.2 D ^DIE I '$D(DA) D KIL G EN3 22 S:$O(^FH(116.2,DA,"R",0))<1 $P(^FH(116.2,DA,0),"^",4)="N" D KIL G EN3 23 EN4 ; List Production Diets 24 W !!,"The list requires a 132 column printer.",! 25 W ! S L=0,DIC="^FH(116.2,",FLDS="[FHPROD]",BY="8,.01" 26 S FR="@",TO="",DHD="PRODUCTION DIETS" D EN1^DIP,RSET Q 27 EN5 ; Enter/Edit Production Facilities 28 K DIC S (DIC,DIE)="^FH(119.71,",DIC(0)="AEQLM",DLAYGO=119.71 29 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN5:Y<1 30 S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.71 D ^DIE,KIL G EN5 31 EN6 ; Enter/Edit Service Points 32 K DIC S (DIC,DIE)="^FH(119.72,",DIC(0)="AEQLM",DLAYGO=119.72 33 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN6:Y<1 34 S DA=+Y S DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.72 D ^DIE I '$D(DA) D KIL G EN6 35 S DA(1)=DA S DIK="^FH(119.72,DA(1),""A""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"A",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,8)?."^" D ^DIK 36 S DIK="^FH(119.72,DA(1),""B""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"B",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,22)?."^" D ^DIK 37 D KIL G EN6 38 EN7 ; Enter/Edit Communication Offices 39 K DIC S (DIC,DIE)="^FH(119.73,",DIC(0)="AEQLM",DLAYGO=119.73 40 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN7:Y<1 41 S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.73 D ^DIE,KIL G EN7 42 EN8 ; Enter/Edit Supplemental Feeding Sites 43 K DIC S (DIC,DIE)="^FH(119.74,",DIC(0)="AEQLM",DLAYGO=119.74 44 S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN8:Y<1 45 S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.74 D ^DIE,KIL G EN8 46 RSET K %ZIS S IOP="" D ^%ZIS 47 KIL G KILL^XUSCLEAN -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHPRW.m
r613 r623 1 FHPRW ;Hines OIFO/REL,RTK - List Dietetic Locations ;5/13/94 14:57 2 ;;5.5;DIETETICS;**12**;Jan 28, 2005;Build 3 3 ; 10/24/07 BAY/KAM FH*5.5*12 CALL 214407 Display new Clinician Field 4 F1 R !!,"Select LOCATION (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S WRD=0 5 E K DIC S DIC="^FH(119.6,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 F1 S WRD=+Y 6 I 'WRD W !!,"Verifying completeness of room-bed & ward assignments ..." D VER 7 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL 8 I $D(IO("Q")) S FHPGM="Q1^FHPRW",FHLST="WRD" D EN2^FH G KIL 9 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL 10 Q1 ; Print Dietetic Ward Profile 11 K ^TMP($J) D NOW^%DTC S NOW=%,PG=0 I WRD S K1=WRD D Q2 W ! Q 12 F NX=0:0 S NX=$O(^FH(119.6,NX)) Q:NX<1 S X=$G(^(NX,0)),P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0),WRDN=$P(X,"^",1),^TMP($J,"FHW",P0_"~"_WRDN)=NX 13 S NX="" F S NX=$O(^TMP($J,"FHW",NX)) Q:NX="" S K1=+$G(^(NX)) I K1 D Q2 14 W ! Q 15 Q2 S X=^FH(119.6,K1,0),NODE1=$G(^FH(119.6,K1,1)) D BLD,HDR 16 W !!,"Print Order:",?22,$P(X,"^",4) 17 W !,"Type of Location:",?22,$S($P(X,U,3)="O":"OUTPATIENT",1:"INPATIENT") 18 ; 19 ;10/24/07 BAY/KAM *12 214407 Print new Clinician Multiple field 20 N C1 S C1="" 21 F S C1=$O(^FH(119.6,K1,2,C1)) Q:C1="" D 22 . S Z=$G(^FH(119.6,K1,2,C1,0)) I Z W !,"Assigned Clinician(s):",?22,$P($G(^VA(200,Z,0)),"^",1) 23 ; 24 W !,"Tray Assembly:",?22 S Z=$P(X,"^",5) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",17) S:Z="" Z=100 W " (",Z,"%)" 25 W !,"Cafeteria:",?22 S Z=$P(X,"^",6) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",18) S:Z="" Z=100 W " (",Z,"%)" 26 W !,"Dining Room:",?22 S Z=$P(X,"^",7) I Z W "Yes" S Z=$P(X,"^",19) S:Z="" Z=100 W " (",Z,"%)" 27 W !,"Supplemental Fdgs.:",?22 S Z=$P(X,"^",9) I Z W $P($G(^FH(119.74,Z,0)),"^",1) 28 W !,"Diet Communication:",?22 S Z=$P(X,"^",8) I Z W $P($G(^FH(119.73,Z,0)),"^",1) 29 W !!,"Admission Diet:",?22 S Z=$P(X,"^",15) I Z W $P($G(^FH(111,Z,0)),"^",1) 30 E I $P(X,"^",16)="Y" W "NO ORDER" 31 W !!,"Review Frequencies:" 32 W !!?5,"NPO's:" S Z=$P(X,"^",11) W:Z ?19,$J(Z,3,0)," days" 33 W ?45,"Admit Status:" S Z=$P(X,"^",14) W:Z ?59,$J(Z,3,0)," days" 34 W !?5,"Tubefeedings:" S Z=$P(X,"^",12) W:Z ?19,$J(Z,3,0)," days" 35 W ?45,"Supp. Fdgs.:" S Z=$P(X,"^",13) W:Z ?59,$J(Z,3,0)," days" 36 W !!?5,"Status I:" S Z=$P(X,"^",20) W:Z ?19,$J(Z,3,0)," days" 37 W ?45,"Status III:" S Z=$P(X,"^",22) W:Z ?59,$J(Z,3,0)," days" 38 W !?5,"Status II:" S Z=$P(X,"^",21) W:Z ?19,$J(Z,3,0)," days" 39 W ?45,"Status IV:" S Z=$P(X,"^",23) W:Z ?59,$J(Z,3,0)," days" 40 S FHY=$P(X,"^",24) W !!,"Bulk Nourishment Orders:",! 41 K P S N=0,NM="" F S NM=$O(^TMP($J,"B",NM)) Q:NM="" S N=N+1,P(N)=$J(^(NM),3,0)_" "_$P(NM,"~",1) 42 I N S (Z,K)=N+1\2 F LL=1:1:Z W !?5,P(LL) S K=K+1 I $D(P(K)) W ?45,P(K) 43 W !!,"Room-Beds Assigned:",! 44 K P S N=0,NM="" F S NM=$O(^TMP($J,"R",NM)) Q:NM="" S N=N+1,P(N)=$P(NM,"~",1) 45 I N S Z=N+3\4 S K(22)=Z,K(39)=2*Z,K(54)=3*Z F LL=1:1:Z W !?5,P(LL) F MM=22,39,54 S K(MM)=K(MM)+1 I $D(P(K(MM))) W ?MM,P(K(MM)) 46 W !!,"Default MAS Wards:",! 47 K P S N=0,NM="" F S NM=$O(^TMP($J,"W",NM)) Q:NM="" S N=N+1,P(N)=$P(NM,"~",1) 48 I N S (Z,K)=N+1\2 F LL=1:1:Z W !?5,P(LL) S K=K+1 I $D(P(K)) W ?45,P(K) 49 W !!,"Print Cafeteria on Tray Tickets: ",$S(FHY="Y":"YES",1:"NO") 50 S FHOL=$P(NODE1,U,1),FHOLFIL=$S(FHOL["SC(":44,FHOL["DIC(42":42,1:0) 51 S FHOLNM="" I FHOLFIL D 52 .S FHOLIEN=$P(FHOL,";",1) 53 .I FHOLFIL=42 S FHOLNM=$P($G(^DIC(42,FHOLIEN,0)),U,1) 54 .I FHOLFIL=44 S FHOLNM=$P($G(^SC(FHOLIEN,0)),U,1) 55 .W !!,"Outpatient Location: ",FHOLNM,! 56 W !,"Maximum # of Days to Schedule Recurring Meal: ",$P(NODE1,U,2) 57 W !,"Number of Days for Review of Recurring Meal: ",$P(NODE1,U,3) 58 W !!,"Non-VA Facility? ",$S($P(NODE1,U,4)="Y":"YES",1:"NO") 59 W ! Q 60 BLD ; Build temp files 61 K ^TMP($J,"B"),^TMP($J,"R"),^TMP($J,"W") 62 F LL=0:0 S LL=$O(^FH(119.6,K1,"BN",LL)) Q:LL<1 S Y=^(LL,0) D B1 63 F LL=0:0 S LL=$O(^FH(119.6,K1,"W",LL)) Q:LL<1 S Y=^(LL,0) D B2 64 F LL=0:0 S LL=$O(^FH(119.6,K1,"R",LL)) Q:LL<1 S Y=^(LL,0) D B3 65 Q 66 B1 S N=+Y,Q=$P(Y,"^",2) Q:'N!('Q) S N=$P($G(^FH(118,N,0)),"^",1) Q:N="" S ^TMP($J,"B",N_"~"_(+Y))=Q Q 67 B2 S N=$P($G(^DIC(42,+Y,0)),"^",1) Q:N="" S ^TMP($J,"W",N_"~"_(+Y))="" Q 68 B3 S N=$P($G(^DG(405.4,+Y,0)),"^",1) Q:N="" S ^TMP($J,"R",N_"~"_(+Y))="" Q 69 HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=NOW D DTP^FH W !,$E(DTP,1,9),?19,"D I E T E T I C L O C A T I O N P R O F I L E",?73,"Page ",PG 70 S Y=$P(X,"^",1) W !!?(78-$L(Y)\2),Y 71 W !,"-------------------------------------------------------------------------------",! Q 72 VER ; Verify completeness of data base 73 F LL=0:0 S LL=$O(^DG(405.4,LL)) Q:LL'>0 I '$D(^FH(119.6,"AR",LL)) W !,"Room ",$P(^DG(405.4,LL,0),"^",1)," not assigned to any Dietetic Ward" 74 F LL=0:0 S LL=$O(^DIC(42,LL)) Q:LL'>0 I $G(^DIC(42,LL,"ORDER")),'$D(^FH(119.6,"AW",LL)) W !,"MAS Ward ",$P(^DIC(42,LL,0),"^",1)," not assigned to any Dietetics Ward" 75 Q 76 KIL K ^TMP($J) G KILL^XUSCLEAN 1 FHPRW ;Hines OIFO/REL,RTK - List Dietetic Locations ;5/13/94 14:57 2 ;;5.5;DIETETICS;;Jan 28, 2005 3 F1 R !!,"Select LOCATION (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S WRD=0 4 E K DIC S DIC="^FH(119.6,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 F1 S WRD=+Y 5 I 'WRD W !!,"Verifying completeness of room-bed & ward assignments ..." D VER 6 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL 7 I $D(IO("Q")) S FHPGM="Q1^FHPRW",FHLST="WRD" D EN2^FH G KIL 8 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL 9 Q1 ; Print Dietetic Ward Profile 10 K ^TMP($J) D NOW^%DTC S NOW=%,PG=0 I WRD S K1=WRD D Q2 W ! Q 11 F NX=0:0 S NX=$O(^FH(119.6,NX)) Q:NX<1 S X=$G(^(NX,0)),P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0),WRDN=$P(X,"^",1),^TMP($J,"FHW",P0_"~"_WRDN)=NX 12 S NX="" F S NX=$O(^TMP($J,"FHW",NX)) Q:NX="" S K1=+$G(^(NX)) I K1 D Q2 13 W ! Q 14 Q2 S X=^FH(119.6,K1,0),NODE1=$G(^FH(119.6,K1,1)) D BLD,HDR 15 W !!,"Print Order:",?22,$P(X,"^",4) 16 W !,"Type of Location:",?22,$S($P(X,U,3)="O":"OUTPATIENT",1:"INPATIENT") 17 W !,"Assigned Clinician:",?22 S Z=$P(X,"^",2) I Z W $P($G(^VA(200,Z,0)),"^",1) 18 W !,"Tray Assembly:",?22 S Z=$P(X,"^",5) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",17) S:Z="" Z=100 W " (",Z,"%)" 19 W !,"Cafeteria:",?22 S Z=$P(X,"^",6) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",18) S:Z="" Z=100 W " (",Z,"%)" 20 W !,"Dining Room:",?22 S Z=$P(X,"^",7) I Z W "Yes" S Z=$P(X,"^",19) S:Z="" Z=100 W " (",Z,"%)" 21 W !,"Supplemental Fdgs.:",?22 S Z=$P(X,"^",9) I Z W $P($G(^FH(119.74,Z,0)),"^",1) 22 W !,"Diet Communication:",?22 S Z=$P(X,"^",8) I Z W $P($G(^FH(119.73,Z,0)),"^",1) 23 W !!,"Admission Diet:",?22 S Z=$P(X,"^",15) I Z W $P($G(^FH(111,Z,0)),"^",1) 24 E I $P(X,"^",16)="Y" W "NO ORDER" 25 W !!,"Review Frequencies:" 26 W !!?5,"NPO's:" S Z=$P(X,"^",11) W:Z ?19,$J(Z,3,0)," days" 27 W ?45,"Admit Status:" S Z=$P(X,"^",14) W:Z ?59,$J(Z,3,0)," days" 28 W !?5,"Tubefeedings:" S Z=$P(X,"^",12) W:Z ?19,$J(Z,3,0)," days" 29 W ?45,"Supp. Fdgs.:" S Z=$P(X,"^",13) W:Z ?59,$J(Z,3,0)," days" 30 W !!?5,"Status I:" S Z=$P(X,"^",20) W:Z ?19,$J(Z,3,0)," days" 31 W ?45,"Status III:" S Z=$P(X,"^",22) W:Z ?59,$J(Z,3,0)," days" 32 W !?5,"Status II:" S Z=$P(X,"^",21) W:Z ?19,$J(Z,3,0)," days" 33 W ?45,"Status IV:" S Z=$P(X,"^",23) W:Z ?59,$J(Z,3,0)," days" 34 S FHY=$P(X,"^",24) W !!,"Bulk Nourishment Orders:",! 35 K P S N=0,NM="" F S NM=$O(^TMP($J,"B",NM)) Q:NM="" S N=N+1,P(N)=$J(^(NM),3,0)_" "_$P(NM,"~",1) 36 I N S (Z,K)=N+1\2 F LL=1:1:Z W !?5,P(LL) S K=K+1 I $D(P(K)) W ?45,P(K) 37 W !!,"Room-Beds Assigned:",! 38 K P S N=0,NM="" F S NM=$O(^TMP($J,"R",NM)) Q:NM="" S N=N+1,P(N)=$P(NM,"~",1) 39 I N S Z=N+3\4 S K(22)=Z,K(39)=2*Z,K(54)=3*Z F LL=1:1:Z W !?5,P(LL) F MM=22,39,54 S K(MM)=K(MM)+1 I $D(P(K(MM))) W ?MM,P(K(MM)) 40 W !!,"Default MAS Wards:",! 41 K P S N=0,NM="" F S NM=$O(^TMP($J,"W",NM)) Q:NM="" S N=N+1,P(N)=$P(NM,"~",1) 42 I N S (Z,K)=N+1\2 F LL=1:1:Z W !?5,P(LL) S K=K+1 I $D(P(K)) W ?45,P(K) 43 W !!,"Print Cafeteria on Tray Tickets: ",$S(FHY="Y":"YES",1:"NO") 44 S FHOL=$P(NODE1,U,1),FHOLFIL=$S(FHOL["SC(":44,FHOL["DIC(42":42,1:0) 45 S FHOLNM="" I FHOLFIL D 46 .S FHOLIEN=$P(FHOL,";",1) 47 .I FHOLFIL=42 S FHOLNM=$P($G(^DIC(42,FHOLIEN,0)),U,1) 48 .I FHOLFIL=44 S FHOLNM=$P($G(^SC(FHOLIEN,0)),U,1) 49 .W !!,"Outpatient Location: ",FHOLNM,! 50 W !,"Maximum # of Days to Schedule Recurring Meal: ",$P(NODE1,U,2) 51 W !,"Number of Days for Review of Recurring Meal: ",$P(NODE1,U,3) 52 W !!,"Non-VA Facility? ",$S($P(NODE1,U,4)="Y":"YES",1:"NO") 53 W ! Q 54 BLD ; Build temp files 55 K ^TMP($J,"B"),^TMP($J,"R"),^TMP($J,"W") 56 F LL=0:0 S LL=$O(^FH(119.6,K1,"BN",LL)) Q:LL<1 S Y=^(LL,0) D B1 57 F LL=0:0 S LL=$O(^FH(119.6,K1,"W",LL)) Q:LL<1 S Y=^(LL,0) D B2 58 F LL=0:0 S LL=$O(^FH(119.6,K1,"R",LL)) Q:LL<1 S Y=^(LL,0) D B3 59 Q 60 B1 S N=+Y,Q=$P(Y,"^",2) Q:'N!('Q) S N=$P($G(^FH(118,N,0)),"^",1) Q:N="" S ^TMP($J,"B",N_"~"_(+Y))=Q Q 61 B2 S N=$P($G(^DIC(42,+Y,0)),"^",1) Q:N="" S ^TMP($J,"W",N_"~"_(+Y))="" Q 62 B3 S N=$P($G(^DG(405.4,+Y,0)),"^",1) Q:N="" S ^TMP($J,"R",N_"~"_(+Y))="" Q 63 HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=NOW D DTP^FH W !,$E(DTP,1,9),?19,"D I E T E T I C L O C A T I O N P R O F I L E",?73,"Page ",PG 64 S Y=$P(X,"^",1) W !!?(78-$L(Y)\2),Y 65 W !,"-------------------------------------------------------------------------------",! Q 66 VER ; Verify completeness of data base 67 F LL=0:0 S LL=$O(^DG(405.4,LL)) Q:LL'>0 I '$D(^FH(119.6,"AR",LL)) W !,"Room ",$P(^DG(405.4,LL,0),"^",1)," not assigned to any Dietetic Ward" 68 F LL=0:0 S LL=$O(^DIC(42,LL)) Q:LL'>0 I $G(^DIC(42,LL,"ORDER")),'$D(^FH(119.6,"AW",LL)) W !,"MAS Ward ",$P(^DIC(42,LL,0),"^",1)," not assigned to any Dietetics Ward" 69 Q 70 KIL K ^TMP($J) G KILL^XUSCLEAN -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHREP1.m
r613 r623 1 FHREP1 2 ;;5.5;DIETETICS;**13**;Jan 28, 2005;Build 1 3 EN2 4 5 6 7 8 E0 9 10 11 12 S %DT="M" D ^%DT K%DT I Y<1!($E(Y,1,5)>$E(NOW,1,5)) W *7," Answer Month and Yr as Mth/Yr or Mth Yr.",!?25," CANNOT be greater than now." G E013 14 15 16 E1 17 18 19 Q0 20 21 Q1 22 23 24 25 26 27 28 29 LP 30 31 32 33 34 35 P1 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 CHK 60 61 62 63 64 65 66 67 68 69 70 SUB 71 72 73 74 HD 75 76 77 HDR 78 79 80 81 82 83 84 85 86 1 FHREP1 ; HISC/NCA - Inventory Worksheet and Report ;3/9/95 08:28 2 ;;5.5;DIETETICS;;Jan 28, 2005 3 EN2 ; Print the Inventory Worksheet & Report 4 S FHXX="F" 5 R !!,"Select W=Worksheet or R=Report: ",FHR:DTIME G:'$T!("^"[FHR) KIL^FHREP 6 I "wr"[FHR S X=FHR D TR^FH S FHR=X 7 I FHR'?1U!("WR"'[FHR) W *7," Enter W or R" G EN2 8 E0 ; Read in Month and Year 9 D NOW^%DTC S NOW=%\1 10 K %DT W !!,"Enter Mth/Yr: "_+$E(NOW,4,5)_"/"_$E(NOW,2,3)_"// " R X:DTIME G:'$T!(X["^") KIL^FHREP 11 I X="" S X=$E(NOW,1,5)_"00" 12 D ^%DT I Y<1!($E(Y,1,5)>$E(NOW,1,5)) W *7," Answer Month and Yr as Mth/Yr or Mth Yr.",!?25," CANNOT be greater than now." G E0 13 S MTH=+$E(Y,4,5),MTH=$P("January February March April May June July August September October November December"," ",MTH),YR=$E(Y,2,3),MTH=MTH_" "_YR 14 I FHR="W" D F1^FHREP G:FHXX["^"!("^"[X) KIL^FHREP 15 I FHR="R" D D1^FHREP G:"^"[X KIL^FHREP 16 E1 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL^FHREP 17 I $D(IO("Q")) S FHPGM="Q0^FHREP1",FHLST="FHR^FHXX^MTH^SRT" D EN2^FH G KIL^FHREP 18 U IO D Q0 D ^%ZISC K %ZIS,IOP G KIL^FHREP 19 Q0 ; Process Printing worksheet or report 20 D Q1 G KIL^FHREP 21 Q1 ; Loop through Ingredients 22 K ^TMP($J) S ANS="",(K,GRDTOT,OLD,SUBTOT,TOTAL,PG)=0 D NOW^%DTC S DTP=% D DTP^FH S HD=DTP S CK=1 23 F K=0:0 S K=$O(^FHING(K)) Q:K<1 S X=$P($G(^(K,0)),"^",19) I X="Y" S X=$G(^(0)) D LP S:OK ^TMP($J,P0_$S(FHXX="S":$E(L0,1,15),1:"FG"_P0),ING)=K_"^"_UP_"^"_COST_"^"_QOH_"^"_UDC_"^"_UDQ_"^"_$E(MIN,1,5) 24 S REC=0 25 S P0="" F L1=0:0 S P0=$O(^TMP($J,P0)) Q:P0=""!(ANS="^") S ING="" F L2=0:0 S ING=$O(^TMP($J,P0,ING)) Q:ING="" S XX=^(ING) D P1 Q:ANS="^" 26 I FHR="R",ANS="",SRT W !!,?55,"TOTAL: ",$J(SUBTOT,8,2) 27 I FHR="R",ANS="",'SRT D SUB W !!?49,"GRAND TOTAL: ",$J(GRDTOT,8,2) 28 Q 29 LP ; Get Food Group or Storage 30 S ING=$P(X,"^",1),UP=$P(X,"^",5),COST=$P(X,"^",9),QOH=$P(X,"^",11),UDC=$P(X,"^",23),UDQ=$P(X,"^",24),MIN=$P(X,"^",25),OK=1,L0="" 31 S DTP=UDC D:DTP'="" DTP^FH S UDC=DTP,DTP=UDQ D:DTP'="" DTP^FH S UDQ=DTP 32 I FHXX="F" S P0=$P(X,"^",13) S:P0<1!(P0>6) P0=7 S:SRT&(P0'=SRT) OK=0 Q 33 S LOC=$P(X,"^",12),L0=$P($G(^FH(113.1,+LOC,0)),"^",1) S:L0="" L0="UNCLASSIFIED" S P0=$P($G(^FH(113.1,+LOC,0)),"^",3),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) S:SRT&(LOC'=SRT) OK=0 34 Q 35 P1 ; Loop to print or if FHR="E" edit QOH 36 S K=$P(XX,"^",1),UP=$P(XX,"^",2),COST=$P(XX,"^",3),QOH=$P(XX,"^",4),UDC=$P(XX,"^",5),UDQ=$P(XX,"^",6),MIN=$P(XX,"^",7),REC=REC+1 37 I FHR="E" D Q 38 .W !!,"Ingredient: ",$P(^FHING(K,0),"^",1) 39 .W:UDQ'="" !?12,"QOH LAST UPDATED ON ",UDQ,! 40 .K DIE S DIE="^FHING(",DA=K 41 .S:OKAY DR="8;S:X=COST Y=""@1"";29////"_DT_";@1;10;S:X=QOH Y="""";30////"_DT 42 .S:'OKAY DR="10;S:X=QOH Y="""";30////"_DT D ^DIE S:$D(DTOUT) CK=0 S:$D(Y)!$D(DTOUT) ANS="^" K DA,DIE,DR,DTOUT,Y 43 .Q 44 D CHK Q:ANS="^" 45 D:$Y'<(IOSL-5) HD W ! Q:ANS="^" 46 I $L(ING)'>30 D 47 .W !,$J(MIN,5),?6,ING,?39,UP,?43,$J(COST,8,3) 48 .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q 49 .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) 50 .Q 51 E D 52 .S L=$L($E(ING,1,30),",") 53 .S:L=1 L=L+1 W !,$J(MIN,5),?6,$P(ING,",",1,L-1),"," 54 .W !?6,$P(ING,",",L,99),?39,UP,?43,$J(COST,8,3) 55 .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q 56 .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) 57 .Q 58 Q 59 CHK ; Check the Food Group or Storage to do Subtotal & Grandtotal 60 S P1=$S(FHXX="F":+P0,1:$E(P0,3,17)) 61 I REC=1 S OLD=P1 D HDR 62 I OLD'=P1 D:FHR="R" SUB D HD 63 S OLD=P1 64 ; Calculate subtotal grand total 65 Q:FHR'="R" 66 S TOTAL=COST*QOH 67 S SUBTOT=SUBTOT+TOTAL 68 S GRDTOT=GRDTOT+TOTAL 69 Q 70 SUB ; Write subtotal 71 W !!,?52,"SUBTOTAL: ",$J(SUBTOT,8,2) 72 S SUBTOT=0 73 Q 74 HD ; Check for end of page 75 G:REC=1 HDR 76 I IOST?1"C".E W:$X>1 ! W *7 K DIR S DIR(0)="E" D ^DIR I 'Y S ANS="^" Q 77 HDR ; Heading for the Inventory 78 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 79 W !,HD,?70,"Page ",PG,!!?22,"I N V E N T O R Y " W $S(FHR="W":"W O R K S H E E T",1:"R E P O R T"),!! 80 W ?(80-$L(MTH)/2),MTH,!! 81 I FHXX="F" S P2="FOOD GROUP: "_$P("MEAT PRODUCTS^MILK PRODUCTS^FRUITS & VEGETABLES^BREADS^COMMERCIAL NUTRITION SUPPLEMENTS^MISCELLANEOUS^UNCLASSIFIED","^",+P1) 82 E S P2=P1 83 W ?(80-$L(P2)/2),P2,!! 84 I FHR="W" W !?56,"DATE",!?47,"ITEM",?56,"LAST",?66,"QOH",?74,"QOH",!,"ITEM#",?20,"NAME",?38,"U/P",?47,"COST",?55,"UPDATE",?63,"LAST MTH",?72,"CURRENT",! Q 85 W !?47,"ITEM",?58,"QOH",?67,"TOTAL",!,"ITEM#",?20,"NAME",?38,"U/P",?47,"COST",?56,"CURRENT",?68,"COST",! 86 Q -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHSELA1.m
r613 r623 1 FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 2 ;;5.5;DIETETICS;**8,12**;Jan 28, 2005;Build 3 3 ; 4 ;10/16/2007 BAY/KAM FH*5.5*12 Remedy Call 210385 Do not allow 5 ; user to change Food Preference name or 6 ; LIKE/DISLIKE field 7 ; 8 CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 9 ; and allow user to create the FP on the fly 10 D ^FHSELA2 S NUM=0,FHQUIT=0 11 W !!!,"The following Allergy Food Preference titles are not on file." 12 W !,"You may use this option to create these Food Preference entries:" 13 D CRLIST I NUM=0 W !,"No Food Preferences need to be mapped." D EXIT Q 14 I FHQUIT=1 D EXIT Q 15 I FHRESP=""!(FHRESP="M") D EXIT Q 16 S FHAFPNM=$P(FHLIST(FHRESP),"^",1) 17 W !,FHAFPNM," " 18 K DIR S DIR("A")="Add to Food Preference file",DIR(0)="Y" D ^DIR 19 I $D(DIRUT) D EXIT Q 20 I Y'=1 D CREATE Q 21 D ADD 22 W !!," ...done. ",FHAFPNM," Food Preference has been added!" H 1 23 D CREATE Q 24 D EXIT Q 25 CRLIST ; 26 W !!?5,"MISSING FOOD PREFERENCE LIST" 27 W !?5,"============================" 28 S FHSEL=0,FHK="" 29 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK=""!(FHQUIT=1)!(FHSEL=1) D 30 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) 31 .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) 32 .I $D(^FH(115.2,"B",FHZ1)) Q 33 .S NUM=NUM+1,PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM 34 .W ?8,FHZ1 35 .S FHLIST(NUM)=FHZ1_"^"_FHFPS 36 .I NUM#5=0!($O(^TMP($J,"FHALG",FHK))="") D PG Q 37 .Q 38 I FHQUIT=0,FHSEL=0,NUM#5'=0 D PG Q 39 Q 40 ADD ; 41 S FHALGMZ=1 42 S X=FHAFPNM K DIC,DO 43 S (DIC,DIE)="^FH(115.2,",DIC(0)="L" D FILE^DICN 44 ; 10/16/2007 BP/KAM FH*5.5*12 Default DISLIKE and prevent Food Preference name change in the next line 45 S (FHDA,DA)=+Y,DR="26;1////D" 46 D ^DIE K DA,DIE,DR 47 D TRAN^FHSEL1 48 Q 49 PG ; 50 S FHRESP="" W ! K DIR 51 S DIR("A")="Select Food Preference or 'M' to see more ('^' to EXIT)" 52 S DIR(0)="F",DIR("B")="M" D ^DIR I $D(DIRUT) S FHQUIT=1 Q 53 S FHRESP=Y 54 I FHRESP?1"M" Q 55 I FHRESP?1.3N,FHRESP>0,FHRESP<(NUM+1) S FHSEL=1 Q 56 W !!,"Select from 1 to ",NUM D PG Q 57 Q 58 MAP ; Map allergies by setting pointers in 115.2 to correct entries in 120.82 59 D ^FHSELA2 60 S FHK="" 61 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 62 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) 63 .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) 64 .I '$D(^FH(115.2,"B",FHZ1)) Q ;not set-up in 115.2, can't map 65 .S FHFPIEN=$O(^FH(115.2,"B",FHZ1,"")) 66 .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q ;no allergies to map 67 .S FHZ=0 F S FHZ=FHZ+1 S FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D 68 ..D LOOKUP 69 Q 70 LOOKUP ; Look-up the Allergy in 120.82 and set the pointer 71 S FHX=FHANAM 72 F FHVAL=0:0 S FHVAL=$O(^GMRD(120.82,"B",FHX,FHVAL)) Q:FHVAL'>0 D 73 .I $D(^FH(115.2,FHFPIEN,"ALG","B",FHVAL)) Q ;pointer already exists 74 .S Y=FHVAL K DIC,DO S DA(1)=FHFPIEN,DIC="^FH(115.2,"_DA(1)_",""ALG""," 75 .S DIC(0)="L",DIC("P")=$P(^DD(115.2,25,0),U,2),X=+Y 76 .D FILE^DICN 77 Q 78 DISPMAP ; 79 W !!,"This option can be used to display the Standard GMR Allergy" 80 W !,"entries and the Food Preferences they map to.",!! K DIR 81 S DIR("A")="Display Map by Allergies or by Food Preferences (A/F): " 82 S DIR(0)="SA^A:Allergies;F:Food Preferences" D ^DIR 83 I $D(DIRUT) D EXIT Q 84 S FHSEL=Y 85 D DEV 86 Q 87 DEV ;get device and set up queue 88 W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP 89 I '$D(IO("Q")) U IO D LISTMAP,^%ZISC,EXIT Q 90 S ZTRTN="LISTMAP^FHSELA1",ZTSAVE("FHSEL")="" 91 S ZTDESC="GMR Allergy/Food Preference Map Display" D ^%ZTLOAD 92 D ^%ZISC K %ZIS,IOP 93 D EXIT 94 Q 95 LISTMAP ; List Map by Allergies or by Food Preferences 96 I FHSEL="A" D LISTAL Q 97 I FHSEL="F" D LISTFP Q 98 Q 99 LISTFP ; List all the Allergy-type Food Pref's and corresponding GMR Allergies 100 D ^FHSELA2 101 S FHK="" W !!,"ALLERGY TYPE FOOD PREFERENCE MAP" 102 W !!,"NFS Food Preference Title",?40,"GMR Standard Allergy(s)" 103 W !,"===================================" 104 W ?40,"===================================" 105 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 106 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) 107 .W !,"ALLERGY - ",FHZ1 108 .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" W ?40,"** NONE **" Q 109 .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D 110 ..W ?40,$S(FHZ>1:",",1:"") S N=N+$L(FHANAM)+1 W:N>40 !?40 S:N>40 N=0 W FHANAM I N=0 S N=N+$L(FHANAM)+1 111 D EXIT Q 112 LISTAL ; List all the GMR Allergies and the Food Pref to map to 113 D ^FHSELA2 114 S FHK="" W !!,"GMR STANDARD FOOD ALLERGY MAP" 115 W !!,"GMR Allergy Name",?25,"Corresponding NFS Food Preference" 116 W !,"=======================",?25,"====================================" 117 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 118 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) 119 .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q 120 .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D 121 ..S ^TMP($J,"FHAL",FHANAM)="ALLERGY - "_FHZ1 122 S FHANAMZ="" 123 F S FHANAMZ=$O(^TMP($J,"FHAL",FHANAMZ)) Q:FHANAMZ="" D 124 .W !,FHANAMZ,?25,"...maps to: ",^TMP($J,"FHAL",FHANAMZ) 125 D EXIT Q 126 MISSING ; List all Food Pref's with no pointers to 120.82 127 D ^FHSELA2 128 S FHK="" 129 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 130 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) 131 .I $P(FHFPS,";",2)'="" Q 132 .W !?5,"ALLERGY - ",FHZ1," does not have corresponding 120.82 entries" 133 D EXIT Q 134 CHECK ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 135 D ^FHSELA2 136 S FHK="",FLG=0 137 W !,"The following Food Preferences titles were not found in file #115.2:" 138 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 139 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) 140 .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) 141 .I '$D(^FH(115.2,"B",FHZ1)) W !,FHZ1 S FLG=1 142 I FLG=0 W !,"ALL FOOD PREFERENCES HAVE BEEN RENAMED!" 143 D EXIT Q 144 ; 145 UPDATE ;Update Food Preferences for all Patient's based on Allergies 146 D ^FHSELA2 S FHCOUNT=0,FHQT=0 147 W !!,"...Updating Patient Food Preferences based on Food-Type Allergies" 148 W "..." K FHMISS F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 D 149 .S FHCOUNT=FHCOUNT+1 I FHCOUNT#100=0 W "." 150 .D GETZN^FHOMUTL I FILE'="P" Q 151 .S DFN=IEN D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q 152 .F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP1^FHWGMR 153 I $G(FHPST8)=1 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT Q 154 D LIST 155 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT,FHQT 156 Q 157 LIST ; 158 I '$D(^TMP($J,"FHMISS")) Q 159 W !!,"The following entries need to be mapped in order to automatically" 160 W !,"update the Patient Food Preferences:",! S FHCOUNT=0,FHQT=0 161 S FHMSFP="" F S FHMSFP=$O(^TMP($J,"FHMISS",FHMSFP)) Q:FHMSFP=""!(FHQT=1) D 162 .W !,"'ALLERGY - ",FHMSFP,"'" S FHCOUNT=FHCOUNT+1 163 .S FHMSPT="" F S FHMSPT=$O(^TMP($J,"FHMISS",FHMSFP,FHMSPT)) Q:FHMSPT="" D 164 ..S FHMSAL=$P($G(^TMP($J,"FHMISS",FHMSFP,FHMSPT)),U,1) 165 ..W !?3,"Patient: ",$E(FHMSPT,1,30),?43,"Allergy: ",FHMSAL 166 ..S FHCOUNT=FHCOUNT+1 167 ..I FHCOUNT>14 S FHCOUNT=0 W ! K DIR S DIR(0)="E" D ^DIR W ! I X="^" S FHQT=1 168 Q 169 EXIT ; 170 D MAP 171 K ^TMP($J,"FHALG"),^TMP($J,"FHAL") 172 K FHFPIEN,FHK,FHX,FHZ,FHFPS,FHZ1,FHVAL,N,FHANAM,FHANAMZ 173 K FHQUIT,NUM,FHRESP,FHAFPNM,FHSEL,PAD,FHLIST,FHALGMZ,FHALMP 1 FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 3 ; 4 CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 5 ; and allow user to create the FP on the fly 6 D ^FHSELA2 S NUM=0,FHQUIT=0 7 W !!!,"The following Allergy Food Preference titles are not on file." 8 W !,"You may use this option to create these Food Preference entries:" 9 D CRLIST I NUM=0 W !,"No Food Preferences need to be mapped." D EXIT Q 10 I FHQUIT=1 D EXIT Q 11 I FHRESP=""!(FHRESP="M") D EXIT Q 12 S FHAFPNM=$P(FHLIST(FHRESP),"^",1) 13 W !,FHAFPNM," " 14 K DIR S DIR("A")="Add to Food Preference file",DIR(0)="Y" D ^DIR 15 I $D(DIRUT) D EXIT Q 16 I Y'=1 D CREATE Q 17 D ADD 18 W !!," ...done. ",FHAFPNM," Food Preference has been added!" H 1 19 D CREATE Q 20 D EXIT Q 21 CRLIST ; 22 W !!?5,"MISSING FOOD PREFERENCE LIST" 23 W !?5,"============================" 24 S FHSEL=0,FHK="" 25 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK=""!(FHQUIT=1)!(FHSEL=1) D 26 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) 27 .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) 28 .I $D(^FH(115.2,"B",FHZ1)) Q 29 .S NUM=NUM+1,PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM 30 .W ?8,FHZ1 31 .S FHLIST(NUM)=FHZ1_"^"_FHFPS 32 .I NUM#5=0!($O(^TMP($J,"FHALG",FHK))="") D PG Q 33 .Q 34 I FHQUIT=0,FHSEL=0,NUM#5'=0 D PG Q 35 Q 36 ADD ; 37 S FHALGMZ=1 38 S X=FHAFPNM K DIC,DO 39 S (DIC,DIE)="^FH(115.2,",DIC(0)="L" D FILE^DICN 40 S (FHDA,DA)=+Y,DR=".01;26;1//DISLIKE;S:X=""D"" Y=0;3;20;S:'X Y=99;21;99" 41 D ^DIE K DA,DIE,DR 42 D TRAN^FHSEL1 43 Q 44 PG ; 45 S FHRESP="" W ! K DIR 46 S DIR("A")="Select Food Preference or 'M' to see more ('^' to EXIT)" 47 S DIR(0)="F",DIR("B")="M" D ^DIR I $D(DIRUT) S FHQUIT=1 Q 48 S FHRESP=Y 49 I FHRESP?1"M" Q 50 I FHRESP?1.3N,FHRESP>0,FHRESP<(NUM+1) S FHSEL=1 Q 51 W !!,"Select from 1 to ",NUM D PG Q 52 Q 53 MAP ; Map allergies by setting pointers in 115.2 to correct entries in 120.82 54 D ^FHSELA2 55 S FHK="" 56 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 57 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) 58 .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) 59 .I '$D(^FH(115.2,"B",FHZ1)) Q ;not set-up in 115.2, can't map 60 .S FHFPIEN=$O(^FH(115.2,"B",FHZ1,"")) 61 .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q ;no allergies to map 62 .S FHZ=0 F S FHZ=FHZ+1 S FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D 63 ..D LOOKUP 64 Q 65 LOOKUP ; Look-up the Allergy in 120.82 and set the pointer 66 S FHX=FHANAM 67 F FHVAL=0:0 S FHVAL=$O(^GMRD(120.82,"B",FHX,FHVAL)) Q:FHVAL'>0 D 68 .I $D(^FH(115.2,FHFPIEN,"ALG","B",FHVAL)) Q ;pointer already exists 69 .S Y=FHVAL K DIC,DO S DA(1)=FHFPIEN,DIC="^FH(115.2,"_DA(1)_",""ALG""," 70 .S DIC(0)="L",DIC("P")=$P(^DD(115.2,25,0),U,2),X=+Y 71 .D FILE^DICN 72 Q 73 DISPMAP ; 74 W !!,"This option can be used to display the Standard GMR Allergy" 75 W !,"entries and the Food Preferences they map to.",!! K DIR 76 S DIR("A")="Display Map by Allergies or by Food Preferences (A/F): " 77 S DIR(0)="SA^A:Allergies;F:Food Preferences" D ^DIR 78 I $D(DIRUT) D EXIT Q 79 S FHSEL=Y 80 D DEV 81 Q 82 DEV ;get device and set up queue 83 W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP 84 I '$D(IO("Q")) U IO D LISTMAP,^%ZISC,EXIT Q 85 S ZTRTN="LISTMAP^FHSELA1",ZTSAVE("FHSEL")="" 86 S ZTDESC="GMR Allergy/Food Preference Map Display" D ^%ZTLOAD 87 D ^%ZISC K %ZIS,IOP 88 D EXIT 89 Q 90 LISTMAP ; List Map by Allergies or by Food Preferences 91 I FHSEL="A" D LISTAL Q 92 I FHSEL="F" D LISTFP Q 93 Q 94 LISTFP ; List all the Allergy-type Food Pref's and corresponding GMR Allergies 95 D ^FHSELA2 96 S FHK="" W !!,"ALLERGY TYPE FOOD PREFERENCE MAP" 97 W !!,"NFS Food Preference Title",?40,"GMR Standard Allergy(s)" 98 W !,"===================================" 99 W ?40,"===================================" 100 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 101 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) 102 .W !,"ALLERGY - ",FHZ1 103 .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" W ?40,"** NONE **" Q 104 .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D 105 ..W ?40,$S(FHZ>1:",",1:"") S N=N+$L(FHANAM)+1 W:N>40 !?40 S:N>40 N=0 W FHANAM I N=0 S N=N+$L(FHANAM)+1 106 D EXIT Q 107 LISTAL ; List all the GMR Allergies and the Food Pref to map to 108 D ^FHSELA2 109 S FHK="" W !!,"GMR STANDARD FOOD ALLERGY MAP" 110 W !!,"GMR Allergy Name",?25,"Corresponding NFS Food Preference" 111 W !,"=======================",?25,"====================================" 112 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 113 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) 114 .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q 115 .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D 116 ..S ^TMP($J,"FHAL",FHANAM)="ALLERGY - "_FHZ1 117 S FHANAMZ="" 118 F S FHANAMZ=$O(^TMP($J,"FHAL",FHANAMZ)) Q:FHANAMZ="" D 119 .W !,FHANAMZ,?25,"...maps to: ",^TMP($J,"FHAL",FHANAMZ) 120 D EXIT Q 121 MISSING ; List all Food Pref's with no pointers to 120.82 122 D ^FHSELA2 123 S FHK="" 124 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 125 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) 126 .I $P(FHFPS,";",2)'="" Q 127 .W !?5,"ALLERGY - ",FHZ1," does not have corresponding 120.82 entries" 128 D EXIT Q 129 CHECK ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 130 D ^FHSELA2 131 S FHK="",FLG=0 132 W !,"The following Food Preferences titles were not found in file #115.2:" 133 F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D 134 .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) 135 .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) 136 .I '$D(^FH(115.2,"B",FHZ1)) W !,FHZ1 S FLG=1 137 I FLG=0 W !,"ALL FOOD PREFERENCES HAVE BEEN RENAMED!" 138 D EXIT Q 139 ; 140 UPDATE ;Update Food Preferences for all Patient's based on Allergies 141 D ^FHSELA2 S FHCOUNT=0,FHQT=0 142 W !!,"...Updating Patient Food Preferences based on Food-Type Allergies" 143 W "..." K FHMISS F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 D 144 .S FHCOUNT=FHCOUNT+1 I FHCOUNT#100=0 W "." 145 .D GETZN^FHOMUTL I FILE'="P" Q 146 .S DFN=IEN D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q 147 .F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP1^FHWGMR 148 I $G(FHPST8)=1 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT Q 149 D LIST 150 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT,FHQT 151 Q 152 LIST ; 153 I '$D(^TMP($J,"FHMISS")) Q 154 W !!,"The following entries need to be mapped in order to automatically" 155 W !,"update the Patient Food Preferences:",! S FHCOUNT=0,FHQT=0 156 S FHMSFP="" F S FHMSFP=$O(^TMP($J,"FHMISS",FHMSFP)) Q:FHMSFP=""!(FHQT=1) D 157 .W !,"'ALLERGY - ",FHMSFP,"'" S FHCOUNT=FHCOUNT+1 158 .S FHMSPT="" F S FHMSPT=$O(^TMP($J,"FHMISS",FHMSFP,FHMSPT)) Q:FHMSPT="" D 159 ..S FHMSAL=$P($G(^TMP($J,"FHMISS",FHMSFP,FHMSPT)),U,1) 160 ..W !?3,"Patient: ",$E(FHMSPT,1,30),?43,"Allergy: ",FHMSAL 161 ..S FHCOUNT=FHCOUNT+1 162 ..I FHCOUNT>14 S FHCOUNT=0 W ! K DIR S DIR(0)="E" D ^DIR W ! I X="^" S FHQT=1 163 Q 164 EXIT ; 165 D MAP 166 K ^TMP($J,"FHALG"),^TMP($J,"FHAL") 167 K FHFPIEN,FHK,FHX,FHZ,FHFPS,FHZ1,FHVAL,N,FHANAM,FHANAMZ 168 K FHQUIT,NUM,FHRESP,FHAFPNM,FHSEL,PAD,FHLIST,FHALGMZ,FHALMP -
WorldVistAEHR/trunk/r/DIETETICS-FH/FHSELA2.m
r613 r623 1 FHSELA2 2 ;;5.5;DIETETICS;**8,13**;Jan 28, 2005;Build 1 3 4 TMPGL 5 6 7 8 EXIT 9 10 FPS 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 ;;GREEN LEAFY VEG;GREEN LEAFY VEGETABLES149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 1 FHSELA2 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 3 ; 4 TMPGL ; Create ^TMP Global 5 K ^TMP($J,"FHALG") S FHK=0 6 F S FHK=FHK+1,FHFPS=$T(FPS+FHK),FHZ1=$P(FHFPS,";",3) Q:FHZ1="" D 7 .S ^TMP($J,"FHALG",FHZ1)=$P(FHFPS,";",3,99) 8 EXIT K FHK,FHFPS,FHZ1 9 Q 10 FPS ;; 11 ;;ALCOHOL;ALCOHOL 12 ;;ALCOHOL, BEER;HOPS 13 ;;ALCOHOL, GIN;GIN 14 ;;ALCOHOL, RUM;RUM 15 ;;ALCOHOL, SCOTCH;SCOTCH 16 ;;ALCOHOL, TEQUILA;TEQUILA 17 ;;ALCOHOL, VODKA;VODKA 18 ;;ALCOHOL, WINE;WINE 19 ;;ALCOHOL, WINE, WHITE;WHITE WINE 20 ;;ALFALFA SPROUTS;ALFALFA SPROUTS 21 ;;ALMONDS;ALMONDS 22 ;;ANISE OIL;ANISE OIL 23 ;;APPLES;APPLE JUICE;APPLES 24 ;;APRICOTS;APRICOTS 25 ;;ARTICHOKES;ARTICHOKES 26 ;;ARTIFICIAL COLORS;ARTIFICIAL COLORS;BLACK DYES;BLUE DYES;FD&C BLUE DYE #2;FD&C GREEN DYE #6;GREEN DYES;PINK DYES;PURPLE DYES 27 ;;ASPARAGUS;ASPARAGUS 28 ;;AVOCADOS;AVOCADOS 29 ;;BACON;BACON 30 ;;BANANAS;BANANAS 31 ;;BARBEQUE SAUCE;BARBEQUE SAUCE 32 ;;BARLEY;BARLEY;MALT BARLEY 33 ;;BASIL;BASIL 34 ;;BEANS;BEANS;LEGUMES 35 ;;BEANS, BAKED;BAKED BEANS 36 ;;BEANS, FAVA;FAVA BEANS (BROAD BEANS) 37 ;;BEANS, GREEN;GREEN BEANS 38 ;;BEANS, LENTILS;LENTILS 39 ;;BEANS, LIMA;LIMA BEANS 40 ;;BEANS, PINTO;PINTO BEANS 41 ;;BEANS, SOY;SOYBEANS 42 ;;BEANS, STRING;STRING BEANS 43 ;;BEANS, WHITE;WHITE BEANS 44 ;;BEEF;BEEF;BEEF PRODUCTS 45 ;;BEEF, CORNED;CORNED BEEF 46 ;;BEETS;BEETS 47 ;;BEETS, PICKLES;PICKLED BEETS 48 ;;BERRIES;BERRIES 49 ;;BLACKBERRIES;BLACKBERRIES 50 ;;BLUEBERRIES;BLUEBERRIES 51 ;;BROCCOLI;BROCCOLI 52 ;;BRUSSELS SPROUTS;BRUSSELS SPROUTS 53 ;;BUCKWHEAT;BUCKWHEAT 54 ;;BUTTER;BUTTER 55 ;;CABBAGE;CABBAGE 56 ;;CAFFEINE;CAFFEINE;COFFEE;COFFEE BEANS 57 ;;CAFFEINE, COLAS;COLA DRINKS 58 ;;CANTALOUPE;CANTALOUPE 59 ;;CARBONATED BEVERAGES;CARBONATED BEVERAGES;SOFT DRINKS 60 ;;CARROTS;CARROTS 61 ;;CATSUP;CATSUP 62 ;;CAULIFLOWER;CAULIFLOWER 63 ;;CAVIAR;CAVIAR 64 ;;CELERY;CELERY 65 ;;CEREAL;CEREALS 66 ;;CEREAL, CORNFLAKES;CORNFLAKES 67 ;;CEREAL, CRM OF WHEAT;CREAM OF WHEAT 68 ;;CEREAL, GRITS;GRITS 69 ;;CEREAL, OATMEAL;OATMEAL 70 ;;CHEESE;CHEESE 71 ;;CHEESE, BLUE;BLUE CHEESE 72 ;;CHEESE, CHEDDAR;CHEDDAR CHEESE 73 ;;CHEESE, COTTAGE;COTTAGE CHEESE 74 ;;CHEESE, FETA;FETA CHEESE 75 ;;CHEESE, GOAT;GOAT CHEESE 76 ;;CHEESE, PARMESAN;PARMESAN CHEESE 77 ;;CHEESE, RICOTTA;RICOTTA CHEESE 78 ;;CHEESE, SWISS;SWISS CHEESE 79 ;;CHERRIES;CHERRIES;CHERRY JUICE 80 ;;CHICKEN;CHICKEN 81 ;;CHICKPEAS;CHICKPEAS 82 ;;CHICORY;CHICORY 83 ;;CHILI;CHILI 84 ;;CHIVES;CHIVES 85 ;;CHOCOLATE;CHOCOLATE;COCOA 86 ;;CILANTRO;CILANTRO;CUMIN 87 ;;CINNAMON;CINNAMON;CINNAMON OIL 88 ;;CITRUS;CITRUS;CITRUS FRUIT;CITRUS JUICE 89 ;;CLOVES;CLOVES 90 ;;COCONUT;COCONUTS 91 ;;COLA;COLA DRINKS 92 ;;CORN;CORN 93 ;;CRACKERS;CRACKERS 94 ;;CRACKERS, GRAHAM;GRAHAM CRACKERS 95 ;;CRANBERRIES;CRANBERRIES 96 ;;CREAM, SOUR;SOUR CREAM 97 ;;CREAMER, NON-DAIRY;NON-DAIRY CREAMER 98 ;;CREAMER, POWDER;POWDERED CREAMER 99 ;;CUCUMBERS;CUCUMBERS 100 ;;DAIRY PRODUCTS;DAIRY PRODUCTS 101 ;;DATES;DATES 102 ;;DILL;DILL 103 ;;DUCK;DUCK;WATERFOWL 104 ;;DYES, VEGETABLES;VEGETABLE DYES 105 ;;EGGNOG;EGGNOG 106 ;;EGGPLANT;EGGPLANT 107 ;;EGGS;EGGS;EGG PRODUCTS;EGG WHITES;EGG YOLKS 108 ;;EGGS, SUBSTITUTES;EGG, SUBSTITUTES 109 ;;FAT EMULSIONS;FAT EMULSIONS 110 ;;FIGS;FIGS 111 ;;FISH;FISH 112 ;;FISH, ABALONE;ABALONE 113 ;;FISH, ANCHOVIES;ANCHOVIES 114 ;;FISH, CATFISH;CATFISH 115 ;;FISH, COD;CODFISH 116 ;;FISH, FLOUNDER;FLOUNDER 117 ;;FISH, HERRING;HERRING 118 ;;FISH, MACKEREL;MACKEREL 119 ;;FISH, PERCH;PERCH 120 ;;FISH, RED SNAPPER;RED SNAPPER 121 ;;FISH, SALMON;SALMON 122 ;;FISH, SARDINES;SARDINES 123 ;;FISH, SHARK;SHARK 124 ;;FISH, SWORDFISH;SWORDFISH 125 ;;FISH, TROUT;TROUT 126 ;;FISH, TUNA;TUNA 127 ;;FISH, WHITE;WHITE FISH 128 ;;FLAVORING, HICKORY;HICKORY 129 ;;FLAVORING, LICORICE;LICORICE 130 ;;FLAVORING, VANILLA;VANILLA 131 ;;FOOD PRESERVATIVES;FOOD PRESERVATIVES 132 ;;FRUIT, FRESH;FRESH FRUIT 133 ;;FROG;FROG LEGS;FROGS 134 ;;FRUIT;FRUIT 135 ;;FRUIT JUICE;FRUIT JUICE 136 ;;FRUITCAKES;FRUITCAKES 137 ;;GARLIC;GARLIC 138 ;;GELATIN;GELATIN 139 ;;GINGER;GINGER 140 ;;GLUTEN;GLUTENS 141 ;;GRAINS;GRAINS 142 ;;GRAPEFRUIT;GRAPEFRUIT 143 ;;GRAPES;GRAPES 144 ;;GRAVY;GRAVY 145 ;;GREENS, COLLARD;COLLARD GREENS 146 ;;GREENS, MUSTARD;MUSTARD GREENS 147 ;;GREENS, TURNIP;TURNIP GREENS 148 ;;GREEN LEAFY VEGETABLES;GREEN LEAFY VEGETABLES 149 ;;GUAVA;GUAVA 150 ;;HOMINY;HOMINY 151 ;;HONEY;HONEY 152 ;;HONEYDEW;HONEYDEW 153 ;;HORSERADISH;HORSERADISH 154 ;;IODINE;IODIZED SALT 155 ;;JUICE;JUICE 156 ;;KIWI;KIWI FRUIT 157 ;;LACTOSE;LACTOSE 158 ;;LEEKS;LEEKS 159 ;;LEMON;LEMON JUICE;LEMONS 160 ;;LETTUCE;LETTUCE 161 ;;LIMES;LIMES 162 ;;LYCHEE NUTS;LYCHEES 163 ;;MALTOSE;MALTOSE 164 ;;MANGOS;MANGOS 165 ;;MARSHMALLOWS;MARSHMALLOWS 166 ;;MAYONNAISE;MAYONNAISE 167 ;;MEAT;MEAT 168 ;;MEAT, LAMB;LAMB 169 ;;MEAT, LIVER;LIVER 170 ;;MEAT, PROCESSED;PROCESSED MEATS 171 ;;MEAT, RED;RED MEAT 172 ;;MEAT, VENISON;VENISON 173 ;;MELONS;MELONS 174 ;;MELONS, MUSK;MUSK MELONS 175 ;;MELONS, WATER;WATERMELONS 176 ;;MILK;MILK;DAIRY PRODUCTS 177 ;;MILK, BUTTER;BUTTERMILK 178 ;;MILK, GOAT;GOAT MILK 179 ;;MILK, YOGURT;YOGURT 180 ;;MINT;MINT 181 ;;MODIFIED FOOD STARCH;MODIFIED FOOD STARCH;FOOD STARCH, MODIFIED 182 ;;MSG;MONOSODIUM GLUTAMATE 183 ;;MUSHROOMS;MUSHROOMS 184 ;;MUSTARD;MUSTARD 185 ;;MUTTON/LAMB;MUTTON 186 ;;NECTARINES;NECTARINES 187 ;;NITRITES;NITRITES 188 ;;NON-FOOD RELATED;EGGSHELLS 189 ;;NUTMEG;NUTMEG 190 ;;NUTS;BRAZIL NUTS;CASHEWS;CHESTNUTS;HAZELNUTS;MACADAMIA NUTS;NUTS;PECANS 191 ;;NUTS, PEANUT;PEANUT BUTTER;PEANUT OIL;PEANUTS 192 ;;NUTS, PINE;PINE NUTS 193 ;;NUTS, PISTACHIOS;PISTACHIOS 194 ;;NUTS, TREE;PECANS;TREE NUTS 195 ;;NUTS, WALNUT;WALNUTS 196 ;;OATS;OATS 197 ;;OIL, COCONUT;COCONUT OIL 198 ;;OIL, COTTONSEED;COTTONSEED OIL 199 ;;OIL, PALM;PALM OIL 200 ;;OIL, SAFFLOWER;SAFFLOWER OIL 201 ;;OIL, SOY;SOYBEAN OIL 202 ;;OIL, SUNFLOWER;SUNFLOWER OIL 203 ;;OKRA;OKRA 204 ;;OLIVES;BLACK OLIVES;OLIVES 205 ;;ONIONS;ONIONS 206 ;;ONIONS, RED;RED ONIONS 207 ;;ORANGE;ORANGE;ORANGES;ORANGE JUICE;ORANGE OIL 208 ;;OREGANO;OREGANO 209 ;;OYSTERS;OYSTERS 210 ;;PAPAYAS;PAPAYAS 211 ;;PAPRIKA;PAPRIKA 212 ;;PARSLEY;PARSLEY 213 ;;PARSNIP;PARSNIP 214 ;;PASSION FRUIT;PASSION FRUIT 215 ;;PEACHES;PEACHES 216 ;;PEARS;PEARS 217 ;;PEAS;PEAS 218 ;;PEAS, BLACK-EYED;BLACK-EYED PEAS 219 ;;PEAS, ENGLISH;ENGLISH PEAS 220 ;;PEAS, SNOW;SNOW PEAS 221 ;;PEPPER;PEPPER;WHITE PEPPER 222 ;;PEPPER, BLACK;BLACK PEPPER;PEPPER 223 ;;PEPPERMINT;PEPPERMINT 224 ;;PEPPERONI;PEPPERONI 225 ;;PEPPERS;BELL PEPPERS;PEPPERS 226 ;;PEPPERS, CHILI;CHILI PEPPER;CHILI PEPPERS 227 ;;PEPPERS, GREEN;GREEN BELL PEPPERS;PEPPERS 228 ;;PEPPERS, HOT;CAPSAICIN;CAYENNE PEPPER;HOT PEPPER;HOT PEPPERS;JALAPENO PEPPERS 229 ;;PEPPERS, RED;RED BELL PEPPERS 230 ;;PERSIMMONS;PERSIMMONS 231 ;;PHEASANT;PHEASANT 232 ;;PICKLES;PICKLES 233 ;;PIMENTOS;PIMENTOS 234 ;;PINEAPPLE;PINEAPPLES 235 ;;PIZZA;PIZZA 236 ;;PLUMS;PLUMS 237 ;;POPCORN;POPCORN 238 ;;POPPY SEEDS;POPPY SEEDS 239 ;;PORK;PORK;PORK PRODUCTS;HAM 240 ;;PORK, HAM;HAM 241 ;;POTATOES;POTATOES 242 ;;POTATOES, SALAD;POTATO SALAD 243 ;;POTATOES, SWEET/YAMS;SWEET POTATOES;YAMS 244 ;;POULTRY;FOWL;POULTRY 245 ;;PRUNES;PRUNES 246 ;;PUDDING, TAPIOCA;TAPIOCA PUDDING 247 ;;PUMPKIN;PUMPKINS 248 ;;RABBIT;RABBIT 249 ;;RADISH;RADISHES 250 ;;RAISINS;RAISINS 251 ;;RASPBERRIES;RASPBERRIES 252 ;;RED DYES;FD&C RED DYE #1;FD&C RED DYE #2;FD&C RED DYE #3;FD&C RED DYE #40;FD&C RED DYE #40 LAKE;FD&C RED DYE #5;RED DYES 253 ;;RHUBARB;RHUBARB 254 ;;RICE;RICE;WHITE RICE 255 ;;ROSEMARY;ROSEMARY 256 ;;RUTABAGAS;RUTABAGAS 257 ;;RYE;RYE 258 ;;SALAD DRESSING, ITAL;ITALIAN DRESSING 259 ;;SALT;NON-IODIZED SALT;SALT 260 ;;SALT, SUBSTITUTES;SALT SUBSTITUTES 261 ;;SAUERKRAUT;SAUERKRAUT 262 ;;SAUSAGES;SAUSAGES 263 ;;SEAFOOD;SEAFOOD 264 ;;SEEDS;SEEDS 265 ;;SEEDS, SUNFLOWER;SUNFLOWER SEEDS 266 ;;SESAME;SESAME;SESAME OIL;SESAME SEEDS 267 ;;SHELLFISH;CLAMS;CRAB;CRAWFISH;CRUSTACEANS;LOBSTER;MUSSELS;SCALLOPS;SHELL FISH;SHELLFISH 268 ;;SHERBET;SHERBET 269 ;;SHRIMP;SHRIMP 270 ;;SNAILS;SNAILS 271 ;;SOUR CREAM;SOUR CREAM 272 ;;SOY;SOY;SOY MILK;SOY PRODUCTS;SOY SAUCE;SOYBEANS;TOFU 273 ;;SOY SAUCE;SOY SAUCE 274 ;;SPAGHETTI;SPAGHETTI 275 ;;SPAM;SPAM 276 ;;SPICES;CONDIMENTS;SPICES 277 ;;SPINACH;SPINACH 278 ;;SQUASH;SQUASH 279 ;;SQUID;SQUID 280 ;;STARCHY FOODS;STARCHES 281 ;;STRAWBERRIES;STRAWBERRIES;STRAWBERRIES PLUS 282 ;;SUCRALOSE;SUCRALOSE 283 ;;SUGAR;SUGAR;SUGAR BEETS;WHITE SUGAR 284 ;;SUGAR SUB;ARTIFICIAL SWEETENERS 285 ;;SUGAR SUB, ASPARTAME;ASPARTAME 286 ;;SUGAR SUB, SACCHARIN;SACCHARIN;SWEET'N LOW 287 ;;SUGAR, BROWN;BROWN SUGAR 288 ;;SULFITES;SULFITES 289 ;;SYRUP, MAPLE;MAPLE SYRUP 290 ;;TANGERINES;TANGERINES 291 ;;TARRAGON;TARRAGON 292 ;;TEA;TEA 293 ;;TOFFEE;TOFFEE 294 ;;TOMATO;TOMATO;TOMATO JUICE;TOMATO PRODUCTS;TOMATO SAUCE;TOMATOES 295 ;;TOMATOES, FRESH;FRESH TOMATOES 296 ;;TUMERIC;TUMERIC 297 ;;TURKEY;TURKEY 298 ;;TURNIPS;TURNIPS 299 ;;VEAL;VEAL 300 ;;VEGETABLES;VEGETABLES 301 ;;VEGETABLES, GREEN;GREEN VEGETABLES 302 ;;VINEGAR;VINEGAR 303 ;;WATERFOWL;WATERFOWL 304 ;;WHEAT;FLOUR;WHEAT 305 ;;WHEY;WHEY 306 ;;WINE, RED;RED WINE 307 ;;YEAST;YEAST 308 ;;YELLOW DYES;FD&C YELLOW DYE #10;FD&C YELLOW DYE #2;FD&C YELLOW DYE #5;FD&C YELLOW DYE #6;FD&C YELLOW DYE #6 LAKE;TARTRAZINE;YELLOW DYES 309 ;;ZUCCHINI;ZUCCHINI
Note:
See TracChangeset
for help on using the changeset viewer.
