Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM1.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM1.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM1.m (revision 623) @@ -1,179 +1,179 @@ -FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08 - ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1 - W @IOF,!!?20,"N U T R I T I O N A S S E S S M E N T",!! S X="T",%DT="X" D ^%DT S DT=+Y -F1 ; Select Patient - S FHALL=1 D ^FHOMDPA G KILL^XUSCLEAN:'FHDFN - S:DFN'>0 DFN="" - I $G(DFN),$P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KILL^XUSCLEAN - S (ADM,ASN,FHASK,KNEE,EXT,DTP,FHCAS,FHCASD,FHASS,FHFFC,FHFEC,FHFPC,FHCFRBO,FHCM,FHEF,FHKCAL,FHLOC)="",(FHHWF,FHQUIT)=0 - S (ADT,SEX,AGE,HGT,HGP,WGT,WGP,DWGT,UWGT,IBW,FRM,AMP,KCAL,PRO,FLD,RC,XD,BMI,BMIP,FHCLI,FHPLXSV)="" - S (NOW,NB,TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,FHAPP,FHEDU,DEWGT,WARD,FHSPC)="" - S (FHDIPL,FHDIPLD,FHAST,FHDINF,FHDINFD,FHFUD,FHDIST,FHDIDI,FHDITF,FHDIDI,FHDITF,FHDITFDT,FHDITFCM,FHDITFML,FHDITFKC,FHVHGT,FHDVHGT)="" - S (TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,BMI,BMIP,X1,X2,FHFUDS,EKKG,FHFDC,FHFDCSV)="" - S (WCCM,CIBW,CERBO,CENB,PCTB,SEF,CFRB,CFRBO,CPRBO,NWGT,DNWGT,FHYN,FHDINA,FHVWGT,FHDVWGT,FHPL)="" - S FHCLI=DUZ - K ^TMP("FH",$J) S FHQTALL=0 - ;get current diet and tf - S Y="" - I DFN D - .F I=0:0 S I=$O(^FHPT("AW",I)) Q:I'>0 I $D(^FHPT("AW",I,FHDFN)) S FHLOC=I Q - .I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHCLI=$P($G(^FH(119.6,FHLOC,0)),U,2) - .S WARD=$G(^DPT(DFN,.1)) I WARD'="" S ADM=$G(^DPT("CN",WARD,DFN)) - .I ADM D CUR^FHORD7 S X1="" - .S FHDIDI=$S(Y'="":Y,1:"No Order") - .W !,"Current Diet: ",FHDIDI - .Q:'ADM - .S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4) - .Q:'TF - .S FHDITFDT=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,1) - .S FHDITFCM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,5) - .S FHDITFML=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,6) - .S FHDITFKC=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,7) - .F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 D - ..S Y=^(TF2,0),TUN=$P(Y,"^",1) - ..I TUN,$D(^FH(118.2,TUN,0)) S FHDITFPR(TUN)=Y - .W ?30,"Tubefeeding: " I $D(FHDITFPR) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 W $P($G(^FH(118.2,FHTUN,0)),"^",1) I $O(FHDITFPR(FHTUN))'="" W ", " - K Y -STA ;if pt has Work in Progress assessment, ask user to Edit or Create or Delete Assessment. - D PATNAME^FHOMUTL - S AGE=FHAGE - I $D(^FHPT(FHDFN,"N",0)) D - .S FHCAS=$P(^FHPT(FHDFN,"N",0),U,3) - .Q:'FHCAS - .S FHCASD=$P(^FHPT(FHDFN,"N",FHCAS,0),U,1) - .I $D(^FHPT(FHDFN,"N",FHCAS,"DI")) S FHASS=$P($G(^FHPT(FHDFN,"N",FHCAS,"DI")),U,6) - .S FHAST=0 - .F FHA=0:0 S FHA=$O(^FHPT(FHDFN,"N",FHA)) Q:'FHA D - ..S FHASSD=$P($G(^FHPT(FHDFN,"N",FHA,"DI")),U,6) - ..I (FHASSD="W")!(FHASS="") S FHAST=1 - ..I $D(^FHPT(FHDFN,"N",FHA,0)),'$D(^FHPT(FHDFN,"N",FHA,"DI")) S FHAST=1 - I 'FHCAS!(FHAST=0) G CRE - D ASK^FHASM2 G:FHQUIT KILL^XUSCLEAN - I FHASK="D" S DIK="^FHPT("_FHDFN_",""N"",",DA(1)=FHDFN,DA=FHCAS D ^DIK W ?65,"Deleted..." G F1 - I FHASK="E" S ADT=FHCAS D SVAR G:SEX=""!(AGE="") P1 G F3A -CRE ;create new assessment - ;D:FHCAS PRTA^FHASM2 - S FHASK="C" - W !!,"Creating new Assessment...",! - I (FHSEX="")!(FHAGE="") G P1 - E S NAM=FHPTNM,SEX=FHSEX,AGE=FHAGE - S X="NOW",%DT="XT" D ^%DT S ADT=Y - I SEX=""!(AGE="") G P1 -F2 S X="NOW",%DT="XT" D ^%DT S ADT=Y -F3 I DFN,$D(^FHPT(FHDFN,"N",9999999-ADT)) S ADT=$$FMADD^XLFDT(ADT,,,1) G F3 -F3A ;start here if edit - S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1),NAM=FHPTNM - G:'FHDFN F4 S XX=$O(^FHPT(FHDFN,"N",0)) G:XX="" F4 S XX=$G(^(XX,0)),HGT=$P(XX,"^",4),HGP=$P(XX,"^",5) - I HGP'="S" S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_"CM",X1=$S(FHU'="M":X1,1:X2) -F4 ; If Multidivisional site Select Communications Office - S FHCOMM="" I $P($G(^FH(119.9,1,0)),U,20)'="N" D I FHCOMM="" Q - .K DIC S DIC="^FH(119.73," S DIC(0)="AEMQ" D ^DIC - .I Y=-1 Q - .S FHCOMM=+Y - ;get ht and wt from vitals. - I DFN S GMRVSTR="WT" D EN6^GMRVUTL S FHDVWGT=$P(X,"^",1),FHVWGT=$P(X,"^",8),GMRVSTR="HT" D EN6^GMRVUTL S FHVHGT=$P(X,"^",8) - I X1="" S (X1,HGT)=FHVHGT -F4A W !!,"Height: " W:X1'="" X1,"// " R X:DTIME G:'$T!(X["^") KIL I X="",X1'="" S Y0=$J(HGT,0,0),H1=Y0 G F5 - D TR,HGT I Y<1 D HGP G F4A - S:X1'=Y FHHWF=1 - S HGT=Y,H1=Y0,HGP=Y1 -F5 I FHVWGT'="" S WGT=FHVWGT - W !!,"Weight: " W:WGT'="" WGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="",WGT S X=WGT_"#" - S:X="a" X="A" - I X="A",AGE>39 D A^FHASM2D G:Y<1 F5 S:WGT'=Y FHHWF=1 S WGT=Y,WGP="A" G F6 - D WGT I Y<1 D WGP W:AGE>39 !,"You may enter an A to calculate weight anthropometrically." G F5 - S:WGT'=Y FHHWF=1 - S WGT=Y,WGP=Y1 I FHDVWGT'="" S DWGT=$P(FHDVWGT,".",1) -F6 G:'FHHWF F7 - S %DT="AEP",%DT("A")="Date Weight Taken: " - I 'DWGT,FHDVWGT S DTP=$E(FHDVWGT,4,5)_"/"_$E(FHDVWGT,6,7)_"/"_$E(FHDVWGT,2,3) - I DWGT S DTP=$E(DWGT,4,5)_"/"_$E(DWGT,6,7)_"/"_$E(DWGT,2,3) - S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" - S %DT(0)="-T" W ! D ^%DT K %DT G KIL:X["^"!$D(DTOUT),F6:Y<1 - S DWGT=Y - ; -F7 S:UWGT X=UWGT W !!,"Usual Weight: " W:UWGT'="" UWGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="" G F8 - D WGT I Y<1 D WGP G F7 - S UWGT=Y -F8 K %DT,A1,K,X,Y G ^FHASM2 -HGT ; Convert Height to inches - S A1=+X I 'A1 S Y=-1 Q - S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SMK"[$E(X,1) S Y=A1 S:FHU="M" Y=Y/2.54 G H1 - I """I"[$E(X,1) S Y=A1 G H1 - I $E(X,1)="C" S Y=A1/2.54 G H1 - I "'F"'[$E(X,1) S Y=-1 G H2 - S Y=A1*12 F K=1:1 Q:$E(X,K)?.N - I $E(X,K,99)="" G H1 - S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) - I """I"'[$E(X,1) S Y=-1 G H2 - S Y=Y+A1 -H1 I X["K" D K^FHASM2D -H2 I Y<12!(Y>96) S Y=-1 - S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1=$S(X["K":"K",X["S":"S",1:"") Q -HGP ; Height Help - W !!,"Enter height as: 6' 2"" or 74"" or 74IN or 6FT 2 IN or 30CM" - W !,"Add an S if height is stated rather than measured." - W !,"Add a K if value is a Knee Height measurement." - W !,"Height should be between 12"" and 96"" (8')." Q -WGT ; Convert Weight to lbs. - D TR S A1=+X I 'A1 S Y=-1 Q - S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SM"[$E(X,1) S Y=A1 S:FHU="M" Y=Y*2.2 G W1 - I $E(X,1)="O" S Y=A1/16 G W1 - I $E(X,1)="G" S Y=A1/1000*2.2 G W1 - I $E(X,1)="K" S Y=A1*2.2 G W1 - I "L#"'[$E(X,1) S Y=-1 G W1 - S Y=A1 F K=1:1 Q:$E(X,K)?.N - I $E(X,K,99)="" G W1 - S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) - I $E(X,1)'="O" S Y=-1 G W1 - S Y=A1/16+Y -W1 I Y<0!(Y>750) S Y=-1 - S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1="" S:X["S" Y1="S" Q -WGP ; Weight help - W !!,"Enter Weight as 150# or 150# 6OZ or 800G or 70KG" - W !,"Add an S if weight is stated rather than measured." - W !,"Enter an A to determine weight anthropometrically." - W !,"Weight should be between 0 Lbs and 750 Lbs." Q -TR ; Translate Lower to Upper Case - D TR^FH - Q -KIL ; Final variable kill - ;if X not equal ^, update or create nutrition assessment - G:$G(FHQUIT) ASKUS - I $D(X),X=U G ASKUS - D SDAT^FHASM7 - ; - G KILL^XUSCLEAN -PAT S (FHDFN,DFN,SEX,AGE,PID)="" R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!(NAM["^") KILL^XUSCLEAN - I NAM["?"!(NAM'?.ANP)!(NAM="") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT -P1 I SEX="" R !,"Sex: ",SEX:DTIME S:SEX="" SEX="?" G:'$T!(SEX["^") KILL^XUSCLEAN S X=SEX D TR S SEX=X I $P("FEMALE",SEX,1)'="",$P("MALE",SEX,1)'="" W *7," Enter M or F" S SEX="" G P1 - S SEX=$E(SEX,1) -P2 I AGE="" R !,"Age: ",AGE:DTIME S:AGE="" AGE="?" G:'$T!(AGE["^") KILL^XUSCLEAN S X=AGE D TR S AGE=X - S:AGE["M" AGE=+$J($P(AGE,"M",1)/12,0,2) I AGE'>0!(AGE>124) W !?5,"Enter Age Less Than 124 in Years or Months (followed by M) but Not Both" S AGE="" G P2 - G F2 -SVAR ;set variables of incomplete assessment. - Q:'$D(^FHPT(FHDFN,"N",0)) - S FHA0=$G(^FHPT(FHDFN,"N",FHCAS,0)) - S ADT=$P(FHA0,U,1),SEX=$P(FHA0,U,2),AGE=$P(FHA0,U,3),HGT=$P(FHA0,U,4) - S HGP=$P(FHA0,U,5),WGT=$P(FHA0,U,6),WGP=$P(FHA0,U,7),DWGT=$P(FHA0,U,8) - S UWGT=$P(FHA0,U,9),IBW=$P(FHA0,U,10),FRM=$P(FHA0,U,11),AMP=$P(FHA0,U,12) - S KCAL=$P(FHA0,U,16),PRO=$P(FHA0,U,17),FLD=$P(FHA0,U,18),RC=$P(FHA0,U,19) - S XD=$P(FHA0,U,20),BMI=$P(FHA0,U,21),BMIP=$P(FHA0,U,22) - S NOW=$P(FHA0,U,24),NB=$P(FHA0,U,25) - S FHA1=$G(^FHPT(FHDFN,"N",FHCAS,1)) - S TSF=$P(FHA1,U,1),TSFP=$P(FHA1,U,2),SCA=$P(FHA1,U,3),SCAP=$P(FHA1,U,4),ACIR=$P(FHA1,U,5) - S ACIRP=$P(FHA1,U,6),CCIR=$P(FHA1,U,7),CCIRP=$P(FHA1,U,8),BFAMA=$P(FHA1,U,9),BFAMAP=$P(FHA1,U,10) - S WCCM=$P(FHA1,U,11),CIBW=$P(FHA1,U,12),CERBO=$P(FHA1,U,13),CENB=$P(FHA1,U,14),PCTB=$P(FHA1,U,15) - S SEF=$P(FHA1,U,16),CFRB=$P(FHA1,U,17),CFRBO=$P(FHA1,U,18),CPRBO=$P(FHA1,U,19),EKKG=$P(FHA1,U,20) - S FHAPP=$G(^FHPT(FHDFN,"N",FHCAS,2)) - S FHA3=$G(^FHPT(FHDFN,"N",FHCAS,3)) - S FHYN=$P(FHA3,U,1),FHFEC=$P(FHA3,U,2),FHFPC=$P(FHA3,U,3),FHDINA=$P(FHA3,U,4),FHEDU=$P(FHA3,U,5) - S FHFDCSV=$P(FHA3,U,6),FHPL=$P(FHA3,U,7),FHSPC=$P(FHA3,U,8) - S FHADI=$G(^FHPT(FHDFN,"N",FHCAS,"DI")) - S FHDIPL=$P(FHADI,U,1),FHDIPLD=$P(FHADI,U,2),FHDINF=$P(FHADI,U,3),FHDINFD=$P(FHADI,U,4) - S (FHFUD,FHFUDS)=$P(FHADI,U,5),FHDIST=$P(FHADI,U,6),FHDIDI=$P(FHADI,U,7),FHDITF=$P(FHADI,U,8) - Q -ASKUS R !!,"Do you wish to SAVE this Assessment Y// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN - S:X="" X="Y" D TR I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G ASKUS - I X'?1"Y".E G KILL^XUSCLEAN - D SDAT^FHASM7 G KILL^XUSCLEAN +FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08 + ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 + W @IOF,!!?20,"N U T R I T I O N A S S E S S M E N T",!! S X="T",%DT="X" D ^%DT S DT=+Y +F1 ; Select Patient + S FHALL=1 D ^FHOMDPA G KILL^XUSCLEAN:'FHDFN + S:DFN'>0 DFN="" + I $G(DFN),$P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KILL^XUSCLEAN + S (ADM,ASN,FHASK,KNEE,EXT,DTP,FHCAS,FHCASD,FHASS,FHFFC,FHFEC,FHFPC,FHCFRBO,FHCM,FHEF,FHKCAL,FHLOC)="",(FHHWF,FHQUIT)=0 + S (ADT,SEX,AGE,HGT,HGP,WGT,WGP,DWGT,UWGT,IBW,FRM,AMP,KCAL,PRO,FLD,RC,XD,BMI,BMIP,FHCLI,FHPLXSV)="" + S (NOW,NB,TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,FHAPP,FHEDU,DEWGT,WARD,FHSPC)="" + S (FHDIPL,FHDIPLD,FHAST,FHDINF,FHDINFD,FHFUD,FHDIST,FHDIDI,FHDITF,FHDIDI,FHDITF,FHDITFDT,FHDITFCM,FHDITFML,FHDITFKC,FHVHGT,FHDVHGT)="" + S (TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,BMI,BMIP,X1,X2,FHFUDS,EKKG,FHFDC,FHFDCSV)="" + S (WCCM,CIBW,CERBO,CENB,PCTB,SEF,CFRB,CFRBO,CPRBO,NWGT,DNWGT,FHYN,FHDINA,FHVWGT,FHDVWGT,FHPL)="" + S FHCLI=DUZ + K ^TMP("FH",$J) S FHQTALL=0 + ;get current diet and tf + S Y="" + I DFN D + .F I=0:0 S I=$O(^FHPT("AW",I)) Q:I'>0 I $D(^FHPT("AW",I,FHDFN)) S FHLOC=I Q + .I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHCLI=$P($G(^FH(119.6,FHLOC,0)),U,2) + .S WARD=$G(^DPT(DFN,.1)) I WARD'="" S ADM=$G(^DPT("CN",WARD,DFN)) + .D:ADM CUR^FHORD7 + .S FHDIDI=$S(Y'="":Y,1:"No Order") + .W !,"Current Diet: ",FHDIDI + .Q:'ADM + .S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4) + .Q:'TF + .S FHDITFDT=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,1) + .S FHDITFCM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,5) + .S FHDITFML=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,6) + .S FHDITFKC=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,7) + .F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 D + ..S Y=^(TF2,0),TUN=$P(Y,"^",1) + ..I TUN,$D(^FH(118.2,TUN,0)) S FHDITFPR(TUN)=Y + .W ?30,"Tubefeeding: " I $D(FHDITFPR) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 W $P($G(^FH(118.2,FHTUN,0)),"^",1) I $O(FHDITFPR(FHTUN))'="" W ", " + K Y +STA ;if pt has Work in Progress assessment, ask user to Edit or Create or Delete Assessment. + D PATNAME^FHOMUTL + S AGE=FHAGE + I $D(^FHPT(FHDFN,"N",0)) D + .S FHCAS=$P(^FHPT(FHDFN,"N",0),U,3) + .Q:'FHCAS + .S FHCASD=$P(^FHPT(FHDFN,"N",FHCAS,0),U,1) + .I $D(^FHPT(FHDFN,"N",FHCAS,"DI")) S FHASS=$P($G(^FHPT(FHDFN,"N",FHCAS,"DI")),U,6) + .S FHAST=0 + .F FHA=0:0 S FHA=$O(^FHPT(FHDFN,"N",FHA)) Q:'FHA D + ..S FHASSD=$P($G(^FHPT(FHDFN,"N",FHA,"DI")),U,6) + ..I (FHASSD="W")!(FHASS="") S FHAST=1 + ..I $D(^FHPT(FHDFN,"N",FHA,0)),'$D(^FHPT(FHDFN,"N",FHA,"DI")) S FHAST=1 + I 'FHCAS!(FHAST=0) G CRE + D ASK^FHASM2 G:FHQUIT KILL^XUSCLEAN + I FHASK="D" S DIK="^FHPT("_FHDFN_",""N"",",DA(1)=FHDFN,DA=FHCAS D ^DIK W ?65,"Deleted..." G F1 + I FHASK="E" S ADT=FHCAS D SVAR G:SEX=""!(AGE="") P1 G F3A +CRE ;create new assessment + ;D:FHCAS PRTA^FHASM2 + S FHASK="C" + W !!,"Creating new Assessment...",! + I (FHSEX="")!(FHAGE="") G P1 + E S NAM=FHPTNM,SEX=FHSEX,AGE=FHAGE + S X="NOW",%DT="XT" D ^%DT S ADT=Y + I SEX=""!(AGE="") G P1 +F2 S X="NOW",%DT="XT" D ^%DT S ADT=Y +F3 I DFN,$D(^FHPT(FHDFN,"N",9999999-ADT)) S ADT=$$FMADD^XLFDT(ADT,,,1) G F3 +F3A ;start here if edit + S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1),NAM=FHPTNM + G:'FHDFN F4 S XX=$O(^FHPT(FHDFN,"N",0)) G:XX="" F4 S XX=$G(^(XX,0)),HGT=$P(XX,"^",4),HGP=$P(XX,"^",5) + I HGP'="S" S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_"CM",X1=$S(FHU'="M":X1,1:X2) +F4 ; If Multidivisional site Select Communications Office + S FHCOMM="" I $P($G(^FH(119.9,1,0)),U,20)'="N" D I FHCOMM="" Q + .K DIC S DIC="^FH(119.73," S DIC(0)="AEMQ" D ^DIC + .I Y=-1 Q + .S FHCOMM=+Y + ;get ht and wt from vitals. + I DFN S GMRVSTR="WT" D EN6^GMRVUTL S FHDVWGT=$P(X,"^",1),FHVWGT=$P(X,"^",8),GMRVSTR="HT" D EN6^GMRVUTL S FHVHGT=$P(X,"^",8) + I X1="" S (X1,HGT)=FHVHGT +F4A W !!,"Height: " W:X1'="" X1,"// " R X:DTIME G:'$T!(X["^") KIL I X="",X1'="" S Y0=$J(HGT,0,0),H1=Y0 G F5 + D TR,HGT I Y<1 D HGP G F4A + S:X1'=Y FHHWF=1 + S HGT=Y,H1=Y0,HGP=Y1 +F5 I FHVWGT'="" S WGT=FHVWGT + W !!,"Weight: " W:WGT'="" WGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="",WGT S X=WGT_"#" + S:X="a" X="A" + I X="A",AGE>39 D A^FHASM2D G:Y<1 F5 S:WGT'=Y FHHWF=1 S WGT=Y,WGP="A" G F6 + D WGT I Y<1 D WGP W:AGE>39 !,"You may enter an A to calculate weight anthropometrically." G F5 + S:WGT'=Y FHHWF=1 + S WGT=Y,WGP=Y1,DWGT=$P(FHDVWGT,".",1) +F6 G:'FHHWF F7 + S %DT="AEP",%DT("A")="Date Weight Taken: " + I 'DWGT,FHDVWGT S DTP=$E(FHDVWGT,4,5)_"/"_$E(FHDVWGT,6,7)_"/"_$E(FHDVWGT,2,3) + I DWGT S DTP=$E(DWGT,4,5)_"/"_$E(DWGT,6,7)_"/"_$E(DWGT,2,3) + S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" + S %DT(0)="-T" W ! D ^%DT K %DT G KIL:X["^"!$D(DTOUT),F6:Y<1 + S DWGT=Y + ; +F7 S:UWGT X=UWGT W !!,"Usual Weight: " W:UWGT'="" UWGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="" G F8 + D WGT I Y<1 D WGP G F7 + S UWGT=Y +F8 K %DT,A1,K,X,Y G ^FHASM2 +HGT ; Convert Height to inches + S A1=+X I 'A1 S Y=-1 Q + S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SMK"[$E(X,1) S Y=A1 S:FHU="M" Y=Y/2.54 G H1 + I """I"[$E(X,1) S Y=A1 G H1 + I $E(X,1)="C" S Y=A1/2.54 G H1 + I "'F"'[$E(X,1) S Y=-1 G H2 + S Y=A1*12 F K=1:1 Q:$E(X,K)?.N + I $E(X,K,99)="" G H1 + S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) + I """I"'[$E(X,1) S Y=-1 G H2 + S Y=Y+A1 +H1 I X["K" D K^FHASM2D +H2 I Y<12!(Y>96) S Y=-1 + S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1=$S(X["K":"K",X["S":"S",1:"") Q +HGP ; Height Help + W !!,"Enter height as: 6' 2"" or 74"" or 74IN or 6FT 2 IN or 30CM" + W !,"Add an S if height is stated rather than measured." + W !,"Add a K if value is a Knee Height measurement." + W !,"Height should be between 12"" and 96"" (8')." Q +WGT ; Convert Weight to lbs. + D TR S A1=+X I 'A1 S Y=-1 Q + S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SM"[$E(X,1) S Y=A1 S:FHU="M" Y=Y*2.2 G W1 + I $E(X,1)="O" S Y=A1/16 G W1 + I $E(X,1)="G" S Y=A1/1000*2.2 G W1 + I $E(X,1)="K" S Y=A1*2.2 G W1 + I "L#"'[$E(X,1) S Y=-1 G W1 + S Y=A1 F K=1:1 Q:$E(X,K)?.N + I $E(X,K,99)="" G W1 + S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) + I $E(X,1)'="O" S Y=-1 G W1 + S Y=A1/16+Y +W1 I Y<0!(Y>750) S Y=-1 + S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1="" S:X["S" Y1="S" Q +WGP ; Weight help + W !!,"Enter Weight as 150# or 150# 6OZ or 800G or 70KG" + W !,"Add an S if weight is stated rather than measured." + W !,"Enter an A to determine weight anthropometrically." + W !,"Weight should be between 0 Lbs and 750 Lbs." Q +TR ; Translate Lower to Upper Case + D TR^FH + Q +KIL ; Final variable kill + ;if X not equal ^, update or create nutrition assessment + G:$G(FHQUIT) ASKUS + I $D(X),X=U G ASKUS + D SDAT^FHASM7 + ; + G KILL^XUSCLEAN +PAT S (FHDFN,DFN,SEX,AGE,PID)="" R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!(NAM["^") KILL^XUSCLEAN + I NAM["?"!(NAM'?.ANP)!(NAM="") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT +P1 I SEX="" R !,"Sex: ",SEX:DTIME S:SEX="" SEX="?" G:'$T!(SEX["^") KILL^XUSCLEAN S X=SEX D TR S SEX=X I $P("FEMALE",SEX,1)'="",$P("MALE",SEX,1)'="" W *7," Enter M or F" S SEX="" G P1 + S SEX=$E(SEX,1) +P2 I AGE="" R !,"Age: ",AGE:DTIME S:AGE="" AGE="?" G:'$T!(AGE["^") KILL^XUSCLEAN S X=AGE D TR S AGE=X + S:AGE["M" AGE=+$J($P(AGE,"M",1)/12,0,2) I AGE'>0!(AGE>124) W !?5,"Enter Age Less Than 124 in Years or Months (followed by M) but Not Both" S AGE="" G P2 + G F2 +SVAR ;set variables of incomplete assessment. + Q:'$D(^FHPT(FHDFN,"N",0)) + S FHA0=$G(^FHPT(FHDFN,"N",FHCAS,0)) + S ADT=$P(FHA0,U,1),SEX=$P(FHA0,U,2),AGE=$P(FHA0,U,3),HGT=$P(FHA0,U,4) + S HGP=$P(FHA0,U,5),WGT=$P(FHA0,U,6),WGP=$P(FHA0,U,7),DWGT=$P(FHA0,U,8) + S UWGT=$P(FHA0,U,9),IBW=$P(FHA0,U,10),FRM=$P(FHA0,U,11),AMP=$P(FHA0,U,12) + S KCAL=$P(FHA0,U,16),PRO=$P(FHA0,U,17),FLD=$P(FHA0,U,18),RC=$P(FHA0,U,19) + S XD=$P(FHA0,U,20),BMI=$P(FHA0,U,21),BMIP=$P(FHA0,U,22) + S NOW=$P(FHA0,U,24),NB=$P(FHA0,U,25) + S FHA1=$G(^FHPT(FHDFN,"N",FHCAS,1)) + S TSF=$P(FHA1,U,1),TSFP=$P(FHA1,U,2),SCA=$P(FHA1,U,3),SCAP=$P(FHA1,U,4),ACIR=$P(FHA1,U,5) + S ACIRP=$P(FHA1,U,6),CCIR=$P(FHA1,U,7),CCIRP=$P(FHA1,U,8),BFAMA=$P(FHA1,U,9),BFAMAP=$P(FHA1,U,10) + S WCCM=$P(FHA1,U,11),CIBW=$P(FHA1,U,12),CERBO=$P(FHA1,U,13),CENB=$P(FHA1,U,14),PCTB=$P(FHA1,U,15) + S SEF=$P(FHA1,U,16),CFRB=$P(FHA1,U,17),CFRBO=$P(FHA1,U,18),CPRBO=$P(FHA1,U,19),EKKG=$P(FHA1,U,20) + S FHAPP=$G(^FHPT(FHDFN,"N",FHCAS,2)) + S FHA3=$G(^FHPT(FHDFN,"N",FHCAS,3)) + S FHYN=$P(FHA3,U,1),FHFEC=$P(FHA3,U,2),FHFPC=$P(FHA3,U,3),FHDINA=$P(FHA3,U,4),FHEDU=$P(FHA3,U,5) + S FHFDCSV=$P(FHA3,U,6),FHPL=$P(FHA3,U,7),FHSPC=$P(FHA3,U,8) + S FHADI=$G(^FHPT(FHDFN,"N",FHCAS,"DI")) + S FHDIPL=$P(FHADI,U,1),FHDIPLD=$P(FHADI,U,2),FHDINF=$P(FHADI,U,3),FHDINFD=$P(FHADI,U,4) + S (FHFUD,FHFUDS)=$P(FHADI,U,5),FHDIST=$P(FHADI,U,6),FHDIDI=$P(FHADI,U,7),FHDITF=$P(FHADI,U,8) + Q +ASKUS R !!,"Do you wish to SAVE this Assessment Y// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN + S:X="" X="Y" D TR I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G ASKUS + I X'?1"Y".E G KILL^XUSCLEAN + D SDAT^FHASM7 G KILL^XUSCLEAN Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM3.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM3.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM3.m (revision 623) @@ -1,97 +1,96 @@ -FHASM3 ; HISC/REL - Antropometrics and TIU Notes ;5/14/93 09:17 - ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1 - I EXT="Y" G NEXT -EXT R !!,"Do you wish Anthropometric Assessment? NO// ",EXT:DTIME S:EXT=U FHQUIT=1 G:'$T!(EXT["^") KIL^FHASM1 - S:EXT="" EXT="N" - S X=EXT D TR^FHASM1 S EXT=X - I $P("YES",EXT,1)'="",$P("NO",EXT,1)'="" W *7,!," Enter YES if you have Anthropometric measurements; Otherwise NO" G EXT - S EXT=$E(EXT,1) I EXT="Y" D ANT G:EXT="" KIL^FHASM1 -NEXT ; Calculate BMI - S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) - ;update nutrition assessment data in #115. - ; - ; - D ^FHASM3A G ^FHASM4 -ANT ; Anthropometric measurements - W !!,"Triceps Skin Fold (mm): " W:$D(TSF) TSF_"// " R X:DTIME G QT:'$T!(X["^") - S:X'="" TSF=X - S:TSF="" TSF=X - G A1:TSF="" - 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 -A1 W !,"Subscapular Skinfold (mm): " W:$D(SCA) SCA_"// " R X:DTIME G QT:'$T!(X["^") - S:X'="" SCA=X - S:SCA="" SCA=X - G A2:SCA="" - 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 -A2 W !,"Arm Circumference (cm): " W:$G(ACIR) ACIR_"// " R X:DTIME G QT:'$T!(X["^") - S:X'="" ACIR=X - S:SCA="" ACIR=X - G A3:ACIR="" - 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 -A3 W !,"Calf Circumference (cm): " W:$G(CCIR) CCIR_"// " R X:DTIME G QT:'$T!(X["^") - S:X'="" CCIR=X - S:CCIR="" CCIR=X - G A4:CCIR="" - 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 -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) - Q -QT S EXT="" Q - ; -REC ;recalculate calorie, protien and fluid requirements. - I '$G(IBW)!'$G(WGT)!'$G(HGT)!'$G(AGE) Q - I $D(CFRBO) S CB=CFRBO,W2=$S(CB=2:IBW,CB=3:WGT-IBW*.25+IBW,1:WGT)/2.2 - Q:'$G(W2) - ;calorie - I $D(CENB),CENB=3 D - .I SEX="M" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)+5 - .I SEX="F" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)-161 - .S KCAL=$J(KCAL,0,0) - I $D(CENB),CENB=1 D - .I SEX="F" S KCAL=(655.10+(9.56*W2)+(1.85*HGT*2.54)-(4.68*AGE)) - .I SEX="M" S KCAL=(66.47+(13.75*W2)+(5.0*HGT*2.54)-(6.67*AGE)) - .I $D(SEF),$G(AF) S KCAL=+$J(KCAL*AF*SEF,0,0) - .S KCAL=$J(KCAL,0,0) - I $D(CENB),(CENB=2),$G(EKKG) S KCAL=+$J(EKKG*W2,0,0) - ;fluid - I $G(CFRB),CFRB=1 D - .S:AGE>17 FLD=35 - .S:AGE>64 FLD=30 - .S FLD=W2*FLD - 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) - I $D(CFRB),CFRB=3 S FLD=KCAL - I $D(CFRB),CFRB=4 S FLD=.5*KCAL - 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 - S FLD=+$J(FLD,0,0) - I FLD'?1N.N!(FLD<0)!(FLD>10000) W *7,!,"Fluid level must be between 0-10000 ml/day" S FHQTALL=1 Q - S FLD=+$J(FLD,0,0) - ;protien - 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) - I P1=FHPL S PRO=+$J(P1*W2,0,0) - I P1'=FHPL S PRO=+$J(FHPL*W2,0,0) - I PRO'="",(PRO'>0!(PRO>400)) W *7," Protien level is greater than 0 but not more than 400." S FHQTALL=1 - ;FOLLOW-UP DATE. - S (FHDD,DTP)="" - I $G(RC),FHFUD
100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G ANT +A1 W !,"Subscapular Skinfold (mm): " W:$D(SCA) SCA_"// " R X:DTIME G QT:'$T!(X["^") + S:X'="" SCA=X + S:SCA="" SCA=X + G A2:SCA="" + 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 +A2 W !,"Arm Circumference (cm): " W:$G(ACIR) ACIR_"// " R X:DTIME G QT:'$T!(X["^") + S:X'="" ACIR=X + S:SCA="" ACIR=X + G A3:ACIR="" + 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 +A3 W !,"Calf Circumference (cm): " W:$G(CCIR) CCIR_"// " R X:DTIME G QT:'$T!(X["^") + S:X'="" CCIR=X + S:CCIR="" CCIR=X + G A4:CCIR="" + 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 +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) + Q +QT S EXT="" Q + ; +REC ;recalculate calorie, protien and fluid requirements. + I '$G(IBW)!'$G(WGT)!'$G(HGT)!'$G(AGE) Q + I $D(CFRBO) S CB=CFRBO,W2=$S(CB=2:IBW,CB=3:WGT-IBW*.25+IBW,1:WGT)/2.2 + Q:'$G(W2) + ;calorie + I $D(CENB),CENB=3 D + .I SEX="M" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)+5 + .I SEX="F" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)-161 + .S KCAL=$J(KCAL,0,0) + I $D(CENB),CENB=1 D + .I SEX="F" S KCAL=(655.10+(9.56*W2)+(1.85*HGT*2.54)-(4.68*AGE)) + .I SEX="M" S KCAL=(66.47+(13.75*W2)+(5.0*HGT*2.54)-(6.67*AGE)) + .I $D(SEF),$G(AF) S KCAL=+$J(KCAL*AF*SEF,0,0) + .S KCAL=$J(KCAL,0,0) + I $D(CENB),(CENB=2),$G(EKKG) S KCAL=+$J(EKKG*W2,0,0) + ;fluid + I $G(CFRB),CFRB=1 D + .S:AGE>17 FLD=35 + .S:AGE>64 FLD=30 + .S FLD=W2*FLD + 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) + I $D(CFRB),CFRB=3 S FLD=KCAL + I $D(CFRB),CFRB=4 S FLD=.5*KCAL + 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 + S FLD=+$J(FLD,0,0) + I FLD'?1N.N!(FLD<0)!(FLD>10000) W *7,!,"Fluid level must be between 0-10000 ml/day" S FHQTALL=1 Q + S FLD=+$J(FLD,0,0) + ;protien + 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) + S PRO=+$J(P1*W2,0,0) + I PRO'="",(PRO'>0!(PRO>400)) W *7," Protien level is greater than 0 but not more than 400." S FHQTALL=1 + ;FOLLOW-UP DATE. + S (FHDD,DTP)="" + I $G(RC),FHFUD
200) W !?5,"Enter 0-200 grams of protein intake" G E32 -E33 R !,"Enter Urinary Nitrogen Output (gm/24hr): ",X2:DTIME S:X2=U FHQUIT=1 G KIL^FHASM1:'$T!(X2["^"),E35:X2="" - I X2'?.N.1".".N!(X2<0)!(X2>30) W !?5,"Enter 0-30 gms of Urinary Nitrogen output (24 hr UUN)" G E33 -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 - I X3'?.N.1".".N!(X3<0)!(X3>10) W !?5,"Insensible Nitrogen output should be between 0-10 grams" G E34 - S NB=X1/6.25-(X2+X3),NB=$J(NB,0,0) W !,"Nitrogen Balance: ",NB -E35 G:'FHDFN KIL -EDU ; - W !!,"Did you educate patient on Food/Drug Interactions (Y/N): " W:FHEDU'="" FHEDU_"//" W:FHEDU="" "N//" R X:DTIME - G KIL^FHASM1:'$T!(X["^") - I X="",FHEDU="" S X="N" - I X="",FHEDU'="" S X=FHEDU - D TR^FH - I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!,"Enter 'Y' for yes or 'N' for no." G EDU - S FHEDU=$E(X,1) -EDC ;food/drug comment. - S FHFDC=FHFDCSV - W !!,"Food/Drug Comment: ",FHFDCSV,"// " R FHFDC:DTIME I '$T!(FHFDC["^") S FHQUIT=1 G KIL^FHASM1 - I FHFDC="@" S FHFDCSV="" W " deleted..." G DPL - I (FHFDC=""),(FHFDCSV'="") S FHFDC=FHFDCSV - 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 - S FHFDCSV=FHFDC - ;adding diagnosis, follow-up date -DPL ;get diagnosis from Problem List package. - D:DFN LIST^GMPLUTL2(.FHPLIST,DFN,"A","") - S FHDIACT=0 - I $D(FHPLIST(0)) S FHDIACT=FHPLIST(0) -DP1 I FHDIACT D - .S FHDCH="" - .W !!,"Patient's Diagnosis from Problem List:",! - .F FHDLI=0:0 S FHDLI=$O(FHPLIST(FHDLI)) Q:'FHDLI D - ..S DTP=$P(FHPLIST(FHDLI),U,6) D DTP^FH - ..W !,?6,FHDLI_" ",$P(FHPLIST(FHDLI),U,3)," - Date entered: ",DTP - G:'FHDIACT ANF - W !!,"Diagnosis: " W:FHDIPL'="" FHDIPL W "// " R FHDCH:DTIME S:FHDCH=U FHQUIT=1 G:'$T!(FHDCH["^") KIL^FHASM1 - G:FHDCH="" ANF - I FHDCH="@" S (FHDIPL,FHDIPLD)="" G ANF - I '$D(FHPLIST(FHDCH)) W !!,*7,"Choose a number from the list or Hit Return to accept default!!",! G DP1 - S FHDIPL=$P(FHPLIST(FHDCH),U,3),FHDIPLD=$P(FHPLIST(FHDCH),U,6) -ANF ;problem through NFS. - S AFDIA=FHDINA - W !!,"Problem: ",FHDINA,"// " R AFDIA:DTIME I '$T!(AFDIA["^") S FHQUIT=1 G KIL^FHASM1 - I AFDIA="@" S FHDINA="" W " deleted..." G DNF - I (AFDIA=""),(FHDINA'="") S AFDIA=FHDINA - 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 - S FHDINA=AFDIA - ; -DNF ;aditional problem through NFS. - S NFDIA=FHDINF - W !!,"Additional Problem: ",FHDINF,"// " R NFDIA:DTIME I '$T!(NFDIA["^") S FHQUIT=1 G KIL^FHASM1 - I NFDIA="@" S FHDINF="" W " deleted..." G E4 - I (NFDIA=""),(FHDINF'="") S NFDIA=FHDINF - 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 - S FHDINF=NFDIA - ; -E4 ; - S APP=FHAPP - W !!,"Appearance: ",FHAPP,"// " R APP:DTIME I '$T!(APP["^") S FHQUIT=1 G KIL^FHASM1 - I APP="@" S FHAPP="" W " deleted..." G EC1 - I (APP=""),(FHAPP'="") S APP=FHAPP - 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 - S FHAPP=APP -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:"") -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:"") - W !!,"Comments:" K ^TMP("FH",$J) S DIC="^TMP(""FH"",$J,",DWPK=1 - I FHASK="E",$D(^FHPT(FHDFN,"N",FHCAS,"X")) M ^TMP("FH",$J)=^FHPT(FHDFN,"N",FHCAS,"X") D EN^DIWE G FDT - D EN^DIWE -FDT ;enter follow-up date. - S (FHDD,DTP)="" - I $G(RC) D - .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH - .I X["NORMAL" D - ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20) - ..S:FHDD DTP="T+"_FHDD - ..S:'FHDD DTP="T+11" - .I X["MILD" D - ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21) - ..S:FHDD DTP="T+"_FHDD - ..S:'FHDD DTP="T+9" - .I X["MODERATE" D - ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22) - ..S:FHDD DTP="T+"_FHDD - ..S:'FHDD DTP="T+7" - .I X["SEVERE" D - ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23) - ..S:FHDD DTP="T+"_FHDD - ..S:'FHDD DTP="T+5" - K %DT S %DT="AEF",%DT("A")="Enter Follow-up Assessment Date: " - I FHFUD'="",FHFUD>DT S DTP=$E(FHFUD,4,5)_"/"_$E(FHFUD,6,7)_"/"_$E(FHFUD,2,3) - S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" - S %DT(0)=DT - W ! D ^%DT K %DT G KIL^FHASM1:X["^"!$D(DTOUT),FDT:Y<1 - S FHFUD=Y -SDAT ;create or update nutrition assessment and file to Progress Notes. - G:'$D(FHASK) KILL^XUSCLEAN - I '$D(^FHPT(FHDFN,0)) S ^(0)=FHDFN - I '$D(^FHPT(FHDFN,"N",0)) S ^FHPT(FHDFN,"N",0)="^115.011D^^" - K DIC,DD,DO S DIC="^FHPT(FHDFN,""N"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN - I FHASK="E" S ASN=FHCAS D REC^FHASM3 ;re-calculate calorie, protien and fluid requirement. - I FHASK="C" S X=ADT,DINUM=9999999-ADT D FILE^DICN S ASN=+Y ;if not an update, create. - D NOW^%DTC S NOW=% - S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) - S Y=ADT_"^"_SEX_"^"_AGE_"^"_HGT_"^"_HGP_"^"_WGT_"^"_WGP_"^"_DWGT_"^"_UWGT_"^"_IBW_"^"_FRM_"^"_AMP_"^^^^"_KCAL_"^"_PRO_"^"_FLD_"^"_RC_"^"_XD_"^"_BMI_"^"_BMIP_"^"_DUZ_"^"_NOW_"^"_NB - S ^FHPT(FHDFN,"N",ASN,0)=Y - S:'FHFUD FHFUD=DT - 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 - S ^FHPT(FHDFN,"N",ASN,1)=FHASN1 - S ^FHPT(FHDFN,"N",ASN,2)=FHAPP - S ^FHPT(FHDFN,"N",ASN,3)=FHYN_U_FHFEC_U_FHFPC_U_FHDINA_U_FHEDU_U_FHFDCSV_U_FHPL_U_FHSPC - S ^FHPT(FHDFN,"N",ASN,"DI")=FHDIPL_U_FHDIPLD_U_FHDINF_U_FHDINFD_U_FHFUD_U_FHDIST_U_FHDIDI_U_FHDITFDT - S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,10)=FHDITFML - S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,11)=FHDITFKC - S $P(^FHPT(FHDFN,"N",ASN,4),U,1)=FHDITFCM - I $D(FHDITFPR),'$D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 D - .S Y=FHTUN K DIC,DO S DA(2)=FHDFN,DA(1)=ASN - .S DIC="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," - .S DIC(0)="L",DIC("P")=$P(^DD(115.011,67.1,0),U,2),X=+Y - .D FILE^DICN I Y=-1 Q - .K DIE S DA(2)=FHDFN,DA(1)=ASN,DA=+Y - .S FH1=$P(FHDITFPR(FHTUN),U,2),FH2=$P(FHDITFPR(FHTUN),U,3) - .S DIE="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," - .S DR="1////^S X=FH1;2////^S X=FH2" D ^DIE - I FHFUDS,(FHFUDS'=FHFUD) K ^FHPT("E",FHFUDS,FHDFN,ASN) - I FHFUD S DA(1)=FHDFN,DA=ASN,DIK="^FHPT(DA(1)"_",""N"",",DIK(1)="64^E" D IX^DIK - G:'$D(LRTST) E7 - 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 - I N1,'$D(^FHPT(FHDFN,"N",ASN,"L",0)) S ^(0)="^115.021^^" -E7 G:'$D(^TMP("FH",$J)) E8 - S ^FHPT(FHDFN,"N",ASN,"X",0)=^TMP("FH",$J,0) - 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) -E8 S DTE=ADT,S1=1,S2="I",S3=$S('RC:"",1:"Nutrition Status: "_$P(^FH(115.4,RC,0),"^",2)) - I $G(DFN) D FIL^FHASE3 I 'RC G E9 - I '$D(^FHPT(FHDFN,"S",0)) S ^(0)="^115.012D^^" - 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 - I $G(DFN) D DID^FHDPA S $P(^FHPT(FHDFN,"S",ASE,0),"^",2,3)=RC_"^"_DUZ S:FHWRD $P(^(0),"^",6)=FHWRD -E9 ;D P0^FHASMR -E6 R !!,"Save as Work in Progress or Complete or Delete this assessment: W// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN - S:X="" X="W" D TR^FHASM1 - 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 - I $E(X)="D" S DA(1)=FHDFN,DIK="^FHPT(FHDFN,""N"",",DA=ASN D ^DIK W !!,"Deleted...",! G KILL^XUSCLEAN - I $E(X)="W" S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" W !!,"This Assessment has been saved as Work in Progress...",! - I $E(X)="C" D - .;send assessment to TIU if pt has entry in #2 and is inpatient. - .I $G(DFN) S WARD=$G(^DPT(DFN,.1)) I WARD'="" D ^FHASMR2 K ^TMP($J) I $G(FHOUT) D Q - ..W !!,"TIU Progress Note was NOT created!!" - ..S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" - .S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="C" - .W !!,"Assessment is completed" I $G(DFN),WARD'="" W " and forwarded to TIU" W "...",! -KIL G KILL^XUSCLEAN +FHASM7 ; HISC/REL - KCAL Distribution ;8/18/93 11:05 + ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 + S PRT=0,(ASN,NB)="" +E31 S FH7FLG=1 D ^FHASMR1 K FH7FLG + 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 + I $E(X,1)="N" G KIL:'FHDFN,EDU +E32 R !!,"Enter Protein Intake (gm/24hr): ",X1:DTIME S:X1=U FHQUIT=1 G KIL^FHASM1:'$T!(X1["^"),E35:X1="" + I X1'?.N.1".".N!(X1<0)!(X1>200) W !?5,"Enter 0-200 grams of protein intake" G E32 +E33 R !,"Enter Urinary Nitrogen Output (gm/24hr): ",X2:DTIME S:X2=U FHQUIT=1 G KIL^FHASM1:'$T!(X2["^"),E35:X2="" + I X2'?.N.1".".N!(X2<0)!(X2>30) W !?5,"Enter 0-30 gms of Urinary Nitrogen output (24 hr UUN)" G E33 +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 + I X3'?.N.1".".N!(X3<0)!(X3>10) W !?5,"Insensible Nitrogen output should be between 0-10 grams" G E34 + S NB=X1/6.25-(X2+X3),NB=$J(NB,0,0) W !,"Nitrogen Balance: ",NB +E35 G:'FHDFN KIL +EDU ; + W !!,"Did you educate patient on Food/Drug Interactions (Y/N): " W:FHEDU'="" FHEDU_"//" W:FHEDU="" "N//" R X:DTIME + G KIL^FHASM1:'$T!(X["^") + I X="",FHEDU="" S X="N" + I X="",FHEDU'="" S X=FHEDU + D TR^FH + I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!,"Enter 'Y' for yes or 'N' for no." G EDU + S FHEDU=$E(X,1) +EDC ;food/drug comment. + S FHFDC=FHFDCSV + W !!,"Food/Drug Comment: ",FHFDCSV,"// " R FHFDC:DTIME I '$T!(FHFDC["^") S FHQUIT=1 G KIL^FHASM1 + I FHFDC="@" S FHFDCSV="" W " deleted..." G DPL + I (FHFDC=""),(FHFDCSV'="") S FHFDC=FHFDCSV + 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 + S FHFDCSV=FHFDC + ;adding diagnosis, follow-up date +DPL ;get diagnosis from Problem List package. + D:DFN LIST^GMPLUTL2(.FHPLIST,DFN,"A","") + S FHDIACT=0 + I $D(FHPLIST(0)) S FHDIACT=FHPLIST(0) +DP1 I FHDIACT D + .S FHDCH="" + .W !!,"Patient's Diagnosis from Problem List:",! + .F FHDLI=0:0 S FHDLI=$O(FHPLIST(FHDLI)) Q:'FHDLI D + ..S DTP=$P(FHPLIST(FHDLI),U,6) D DTP^FH + ..W !,?6,FHDLI_" ",$P(FHPLIST(FHDLI),U,3)," - Date entered: ",DTP + G:'FHDIACT ANF + W !!,"Diagnosis: " W:FHDIPL'="" FHDIPL W "// " R FHDCH:DTIME S:FHDCH=U FHQUIT=1 G:'$T!(FHDCH["^") KIL^FHASM1 + G:FHDCH="" ANF + I FHDCH="@" S (FHDIPL,FHDIPLD)="" G ANF + I '$D(FHPLIST(FHDCH)) W !!,*7,"Choose a number from the list or Hit Return to accept default!!",! G DP1 + S FHDIPL=$P(FHPLIST(FHDCH),U,3),FHDIPLD=$P(FHPLIST(FHDCH),U,6) +ANF ;problem through NFS. + S AFDIA=FHDINA + W !!,"Problem: ",FHDINA,"// " R AFDIA:DTIME I '$T!(AFDIA["^") S FHQUIT=1 G KIL^FHASM1 + I AFDIA="@" S FHDINA="" W " deleted..." G DNF + I (AFDIA=""),(FHDINA'="") S AFDIA=FHDINA + 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 + S FHDINA=AFDIA + ; +DNF ;aditional problem through NFS. + S NFDIA=FHDINF + W !!,"Additional Problem: ",FHDINF,"// " R NFDIA:DTIME I '$T!(NFDIA["^") S FHQUIT=1 G KIL^FHASM1 + I NFDIA="@" S FHDINF="" W " deleted..." G E4 + I (NFDIA=""),(FHDINF'="") S NFDIA=FHDINF + 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 + S FHDINF=NFDIA + ; +E4 ; + S APP=FHAPP + W !!,"Appearance: ",FHAPP,"// " R APP:DTIME I '$T!(APP["^") S FHQUIT=1 G KIL^FHASM1 + I APP="@" S FHAPP="" W " deleted..." G EC1 + I (APP=""),(FHAPP'="") S APP=FHAPP + 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 + S FHAPP=APP +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:"") +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:"") + W !!,"Comments:" K ^TMP("FH",$J) S DIC="^TMP(""FH"",$J,",DWPK=1 + I FHASK="E",$D(^FHPT(FHDFN,"N",FHCAS,"X")) M ^TMP("FH",$J)=^FHPT(FHDFN,"N",FHCAS,"X") D EN^DIWE G FDT + D EN^DIWE +FDT ;enter follow-up date. + S (FHDD,DTP)="" + I $G(RC) D + .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH + .I X["NORMAL" D + ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20) + ..S:FHDD DTP="T+"_FHDD + ..S:'FHDD DTP="T+11" + .I X["MILD" D + ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21) + ..S:FHDD DTP="T+"_FHDD + ..S:'FHDD DTP="T+9" + .I X["MODERATE" D + ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22) + ..S:FHDD DTP="T+"_FHDD + ..S:'FHDD DTP="T+7" + .I X["SEVERE" D + ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23) + ..S:FHDD DTP="T+"_FHDD + ..S:'FHDD DTP="T+5" + K %DT S %DT="AEF",%DT("A")="Enter Follow-up Assessment Date: " + I FHFUD'="",FHFUD>DT S DTP=$E(FHFUD,4,5)_"/"_$E(FHFUD,6,7)_"/"_$E(FHFUD,2,3) + S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" + S %DT(0)=DT + W ! D ^%DT K %DT G KIL^FHASM1:X["^"!$D(DTOUT),FDT:Y<1 + S FHFUD=Y +SDAT ;create or update nutrition assessment and file to Progress Notes. + G:'$D(FHASK) KILL^XUSCLEAN + I '$D(^FHPT(FHDFN,0)) S ^(0)=FHDFN + I '$D(^FHPT(FHDFN,"N",0)) S ^FHPT(FHDFN,"N",0)="^115.011D^^" + K DIC,DD,DO S DIC="^FHPT(FHDFN,""N"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN + I FHASK="E" S ASN=FHCAS D REC^FHASM3 ;re-calculate calorie, protien and fluid requirement. + I FHASK="C" S X=ADT,DINUM=9999999-ADT D FILE^DICN S ASN=+Y ;if not an update, create. + D NOW^%DTC S NOW=% + S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) + S Y=ADT_"^"_SEX_"^"_AGE_"^"_HGT_"^"_HGP_"^"_WGT_"^"_WGP_"^"_DWGT_"^"_UWGT_"^"_IBW_"^"_FRM_"^"_AMP_"^^^^"_KCAL_"^"_PRO_"^"_FLD_"^"_RC_"^"_XD_"^"_BMI_"^"_BMIP_"^"_DUZ_"^"_NOW_"^"_NB + S ^FHPT(FHDFN,"N",ASN,0)=Y + S:'FHFUD FHFUD=DT + 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 + S ^FHPT(FHDFN,"N",ASN,1)=FHASN1 + S ^FHPT(FHDFN,"N",ASN,2)=FHAPP + S ^FHPT(FHDFN,"N",ASN,3)=FHYN_U_FHFEC_U_FHFPC_U_FHDINA_U_FHEDU_U_FHFDCSV_U_FHPL_U_FHSPC + S ^FHPT(FHDFN,"N",ASN,"DI")=FHDIPL_U_FHDIPLD_U_FHDINF_U_FHDINFD_U_FHFUD_U_FHDIST_U_FHDIDI_U_FHDITFDT + S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,10)=FHDITFML + S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,11)=FHDITFKC + S $P(^FHPT(FHDFN,"N",ASN,4),U,1)=FHDITFCM + I $D(FHDITFPR),'$D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 D + .S Y=FHTUN K DIC,DO S DA(2)=FHDFN,DA(1)=ASN + .S DIC="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," + .S DIC(0)="L",DIC("P")=$P(^DD(115.011,67.1,0),U,2),X=+Y + .D FILE^DICN I Y=-1 Q + .K DIE S DA(2)=FHDFN,DA(1)=ASN,DA=+Y + .S FH1=$P(FHDITFPR(FHTUN),U,2),FH2=$P(FHDITFPR(FHTUN),U,3) + .S DIE="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," + .S DR="1////^S X=FH1;2////^S X=FH2" D ^DIE + I FHFUDS,(FHFUDS'=FHFUD) K ^FHPT("E",FHFUDS,FHDFN,ASN) + I FHFUD S DA(1)=FHDFN,DA=ASN,DIK="^FHPT(DA(1)"_",""N"",",DIK(1)="64^E" D IX^DIK + G:'$D(LRTST) E7 + 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 + I N1,'$D(^FHPT(FHDFN,"N",ASN,"L",0)) S ^(0)="^115.021^^" +E7 G:'$D(^TMP("FH",$J)) E8 + S ^FHPT(FHDFN,"N",ASN,"X",0)=^TMP("FH",$J,0) + 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) +E8 S DTE=ADT,S1=1,S2="I",S3=$S('RC:"",1:"Nutrition Status: "_$P(^FH(115.4,RC,0),"^",2)) + I $G(DFN) D FIL^FHASE3 I 'RC G E9 + I '$D(^FHPT(FHDFN,"S",0)) S ^(0)="^115.012D^^" + 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 + I $G(DFN) D DID^FHDPA S $P(^FHPT(FHDFN,"S",ASE,0),"^",2,3)=RC_"^"_DUZ S:FHWRD $P(^(0),"^",6)=FHWRD +E9 ;D P0^FHASMR +E6 R !!,"Save as Work in Progress or Complete or Delete this assessment: W// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN + S:X="" X="W" D TR^FHASM1 + 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 + I $E(X)="D" S DA(1)=FHDFN,DIK="^FHPT(FHDFN,""N"",",DA=ASN D ^DIK W !!,"Deleted...",! G KILL^XUSCLEAN + I $E(X)="W" S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" W !!,"This Assessment has been saved as Work in Progress...",! + I $E(X)="C" D + .;send assessment to TIU if pt has entry in #2. + .I $G(DFN) D ^FHASMR2 K ^TMP($J) I $G(FHOUT) D Q + ..W !!,"TIU Progress Note was NOT created!!" + ..S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" + .S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="C" + .W !!,"Assessment is completed" W:$G(DFN) " and forwarded to TIU" W "...",! +KIL G KILL^XUSCLEAN Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHASMR2.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHASMR2.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHASMR2.m (revision 623) @@ -1,181 +1,181 @@ -FHASMR2 ;HISC/RVD - Progress Notes To TIU ;04/27/07 06:59 - ;;5.5;DIETETICS;**8,14**;Apr 27, 2007;Build 1 - ;input var: fhdfn,na ien (var ASN),dfn - ;only process inpatient assessment. - ;uses DBIA #1911 -EN ; save note to a temp global - K ^TMP("TIUP",$J) - D NOW^%DTC S NOW=% K % S FHN=1 - S ($P(LN5," ",5),$P(LN10," ",10),$P(LN20," ",20),$P(LN25," ",25),$P(LN30," ",30))="" - S ($P(LN35," ",35),$P(LN40," ",40),$P(LN45," ",45),$P(LN50," ",45),$P(LN55," ",55),$P(LN60," ",60))="" - S ($P(LN65," ",65))="" - S ^TMP("TIUP",$J,FHN,0)=NAM_LN10_$S(SEX="M":"Male",1:"Female")_LN10_"Age: "_AGE - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S DTP=ADT D DTP^FH S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Date of Assessment: "_$E(DTP,1,9) - S (FHRDIPLD,FHRDIST,FHRDIPL,FHRDINFD,FHRDINA,FHRDINFD,FHRDINF,FHREDU,FHRDIDI,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,FHRNWGT,FHRDNWGT,FHRFUD,FHRFEC,FHRFPC,FHRFDC)="" D DIA -EN1 S DTP="" I FHRDIPLD S DTP=FHRDIPLD D DTP^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Diagnosis: "_$E(FHRDIPL,1,30) - S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Problem: "_$E(FHRDINA,1,30) - S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Additional Problem: "_$E(FHRDINF,1,30) - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1 - S ^TMP("TIUP",$J,FHN,0)="Current Diet: "_$E(FHRDIDI,1,53) - I FHRDITF'="" D - .S DTP=FHRDITF D DTP^FH - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Ordered: "_DTP - .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 - ..S FHASTFZN=$G(^FHPT(FHDFN,"N",ASN,"TF",FHTUN,0)) - ..S TNM=$P(FHASTFZN,U,1),STR=$P(FHASTFZN,U,2),QUA=$P(FHASTFZN,U,3) - ..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 - ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=" "_FHTFPROD - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Total Quantity: "_FHRDITFM_"ml"_LN5_"Total KCAL: "_FHRDITFK - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Comment: "_FHRDITFC - K FHRDIPL,FHRDIPLD,FHRDINF,FHRDINFD,FHRDIDI,FHTFPROD,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,DTP - S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_" cm" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1 - 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:"") - S X1=WGT_" lbs",X2=+$J(WGT/2.2,0,1)_" kg" - S FHN=FHN+1 - 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:"") - S DTP=DWGT D DTP^FH - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_" Weight Taken: "_DTP - S X1=FHRNWGT_" lbs",X2=+$J(FHRNWGT/2.2,0,1)_" kg" - K FHRNWGT,FHRDNWGT - I UWGT S X1=UWGT_" lbs",X2=+$J(UWGT/2.2,0,1)_" kg" - S FHN=FHN+1 - S ^TMP("TIUP",$J,FHN,0)="Usual Weight: " - 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)_")" - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_"% Usual Wt: " - I UWGT S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/UWGT*100,3,0)_"%" - S X1=IBW_" lbs",X2=+$J(IBW/2.2,0,1)_" kg" - S FHN=FHN+1 - S ^TMP("TIUP",$J,FHN,0)="Target Weight: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_") % Target Wt: " - I IBW S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/IBW*100,3,0)_"%" - I AMP S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Target weight adjusted for amputation" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Frame Size: "_$S(FRM="S":"Small",FRM="M":"Medium",FRM="L":"Large",1:"") - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN10_" Body Mass Index: "_BMI - S EXT="" I $G(TSF)!$G(SCA)!$G(ACIR)!$G(CCIR) S EXT="Y" - G:EXT'="Y" EN2 ;there is no antthropometric measurement. - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Anthropometric Measurements" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN35_"%ile %ile" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Triceps Skinfold (mm) "_$J(+TSF,3,0)_" "_$J(TSFP,3)_LN5_"Arm Circumference (cm) " - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+ACIR,3,0)_" "_$J(ACIRP,3) - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Subscapular Skinfold (mm) " - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+SCA,3,0)_" "_$J(SCAP,3)_" Bone-free AMA (cm2) " - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+BFAMA,3,0)_" "_$J(BFAMAP,3) - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Calf Circumference (cm) " - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+CCIR,3,0)_" "_$J(CCIRP,3) -EN2 ;skip here if there is no anthropometric measurement. - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_"Laboratory Data" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Test"_LN20_"Result units"_LN10_"Ref. range"_LN10_"Date" - S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" D LAB - I 'N1 D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - .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" - S N=PRO/6.25 -DRU ;pharmacy data. - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Medications" - S PX=1 D DRUG^FHASM4 - I $D(PSCA) D - .F FHI=0:0 S FHI=$O(PSCA(FHI)) Q:FHI'>0 S FHJ="" F S FHJ=$O(PSCA(FHI,FHJ)) Q:FHJ="" D - ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_FHJ - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Educated on Food/Drug Interactions: "_$S(FHREDU="Y":"Yes",1:"No") K FHREDU - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="FOOD/DRUG COMMENT: "_FHRFDC - K FHI,FHJ,PSD,PSCA - ; - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Energy Requirements: "_KCAL_" Kcal/day" - I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" Kcal:N "_$J(KCAL/N,0,0)_":1" - I NB'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" N-Bal: "_NB - I FHRFEC'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Energy calculation is based on: "_FHRFEC - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Protein Requirements: "_PRO_" gm/day" - I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" NPC:N "_$J(KCAL-(PRO*4)/N,0,0)_":1" - I FHRFPC'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Protein calculation is based on: "_FHRFPC - K FHRFEC,FHRFPC - I FLD'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Fluid Requirements: "_FLD_" ml/day" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - I FHAPP'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Appearance: "_FHAPP - I XD D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Class: "_$P($G(^FH(115.3,XD,0)),"^",1) - I RC D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Status: "_$P($G(^FH(115.4,RC,0)),"^",2) - D DCOM - Q -DIA ;get data from DI node. - I ASN S FHDIA=$G(^FHPT(FHDFN,"N",ASN,"DI")) Q:FHDIA="" D - .S FHRDIPL=$P(FHDIA,U,1) - .S FHRDIPLD=$P(FHDIA,U,2) - .S FHRDINF=$P(FHDIA,U,3) - .S FHRDINFD=$P(FHDIA,U,4) - .S FHRFUD=$P(FHDIA,U,5) - .S FHRDIST=$P(FHDIA,U,6) - .S FHRDIDI=$P(FHDIA,U,7) - .S FHRDITF=$P(FHDIA,U,8) - .S FHRDITFM=$P(FHDIA,U,10) - .S FHRDITFK=$P(FHDIA,U,11) - .S FHRDITFC=$P($G(^FHPT(FHDFN,"N",ASN,4)),U,1) - .S FHRFEC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,2) - .S FHRFPC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,3) - .S FHRDINA=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,4) - .S FHREDU=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,5) - .S FHRFDC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,6) - Q -DCOM ;print follow up date and status and comments - S DTP="" I FHRFUD S DTP=FHRFUD D DTP^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Follow-up Date: "_DTP - K FHRFUD,FHRDIST - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Comments:" - I ASN F K=0:0 S K=$O(^FHPT(FHDFN,"N",ASN,"X",K)) Q:K<1 D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=^FHPT(FHDFN,"N",ASN,"X",K,0) - S SIGN=$P(^FHPT(FHDFN,"N",ASN,0),U,23) - D NOW^%DTC S FHRDT=%,FHIFN="",FHESBY=FHCLI K %,%H,%I,X - ;Use data from user selection from file 8925.1 - K DIC,DA W !!,"Enter a Progress Note Title for this Assessment!!",! - 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 - K DIC I X["^"!$D(DTOUT)!(Y<1) S FHOUT=1 Q - S FHIEN1=+Y - ;call TIU to create a progress notes; DBIA #1911 - ;D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","",FHESBY,"","") - D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","","","","") - I $P(FHIFN,U,1)'>0 S FHOUT=1 - K FHIFN,FHRDT,FHTITLE,FHESBY,FHTIUST,FH251,FHIEN1 - ;done - Q -Q6 D FOOT Q -LAB S X1=$P(LRTST(K),"^",7) Q:X1="" S DTP=X1\1 D DTP^FH - I 'N1 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" S N1=N1+1 - S FHLABTE=$P(LRTST(K),U,1)_" " - S FHLABRE=$P(LRTST(K),U,6)_" " - S FHLABUN=$P(LRTST(K),U,4)_" " - S FHLABRR=$P(LRTST(K),U,5)_" " - 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)_" "_DTP - Q -HEAD ; Page Header - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=DTP_LN30_"NUTRITION ASSESSMENT" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN - Q -FOOT ; Page Footer - D SITE^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - I $G(DFN) S W1=$G(^DPT(DFN,.1)) S:$D(^DPT(DFN,.101)) W1=W1_"/"_^DPT(DFN,.101) I W1'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_W1_LN5_"(Vice SF 509)" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - Q +FHASMR2 ;HISC/RVD - Progress Notes To TIU ;04/27/07 06:59 + ;;5.5;DIETETICS;**8**;Apr 27, 2007;Build 28 + ;input var: fhdfn,na ien (var ASN),dfn + ;only process inpatient assessment. + ;uses DBIA #1911 +EN ; save note to a temp global + K ^TMP("TIUP",$J) + D NOW^%DTC S NOW=% K % S FHN=1 + S ($P(LN5," ",5),$P(LN10," ",10),$P(LN20," ",20),$P(LN25," ",25),$P(LN30," ",30))="" + S ($P(LN35," ",35),$P(LN40," ",40),$P(LN45," ",45),$P(LN50," ",45),$P(LN55," ",55),$P(LN60," ",60))="" + S ($P(LN65," ",65))="" + S ^TMP("TIUP",$J,FHN,0)=NAM_LN10_$S(SEX="M":"Male",1:"Female")_LN10_"Age: "_AGE + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S DTP=ADT D DTP^FH S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Date of Assessment: "_$E(DTP,1,9) + S (FHRDIPLD,FHRDIST,FHRDIPL,FHRDINFD,FHRDINA,FHRDINFD,FHRDINF,FHREDU,FHRDIDI,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,FHRNWGT,FHRDNWGT,FHRFUD,FHRFEC,FHRFPC,FHRFDC)="" D DIA +EN1 S DTP="" I FHRDIPLD S DTP=FHRDIPLD D DTP^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Diagnosis: "_$E(FHRDIPL,1,30) + S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Problem: "_$E(FHRDINA,1,30) + S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Additional Problem: "_$E(FHRDINF,1,30) + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1 + S ^TMP("TIUP",$J,FHN,0)="Current Diet: "_$E(FHRDIDI,1,53) + I FHRDITF'="" D + .S DTP=FHRDITF D DTP^FH + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Ordered: "_DTP + .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 + ..S FHASTFZN=$G(^FHPT(FHDFN,"N",ASN,"TF",FHTUN,0)) + ..S TNM=$P(FHASTFZN,U,1),STR=$P(FHASTFZN,U,2),QUA=$P(FHASTFZN,U,3) + ..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 + ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=" "_FHTFPROD + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Total Quantity: "_FHRDITFM_"ml"_LN5_"Total KCAL: "_FHRDITFK + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Comment: "_FHRDITFC + K FHRDIPL,FHRDIPLD,FHRDINF,FHRDINFD,FHRDIDI,FHTFPROD,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,DTP + S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_" cm" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1 + 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:"") + S X1=WGT_" lbs",X2=+$J(WGT/2.2,0,1)_" kg" + S FHN=FHN+1 + 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:"") + S DTP=DWGT D DTP^FH + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_" Weight Taken: "_DTP + S X1=FHRNWGT_" lbs",X2=+$J(FHRNWGT/2.2,0,1)_" kg" + K FHRNWGT,FHRDNWGT + I UWGT S X1=UWGT_" lbs",X2=+$J(UWGT/2.2,0,1)_" kg" + S FHN=FHN+1 + S ^TMP("TIUP",$J,FHN,0)="Usual Weight: " + 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)_")" + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_"% Usual Wt: " + I UWGT S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/UWGT*100,3,0)_"%" + S X1=IBW_" lbs",X2=+$J(IBW/2.2,0,1)_" kg" + S FHN=FHN+1 + S ^TMP("TIUP",$J,FHN,0)="Target Weight: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_") % Target Wt: " + I IBW S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/IBW*100,3,0)_"%" + I AMP S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Target weight adjusted for amputation" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Frame Size: "_$S(FRM="S":"Small",FRM="M":"Medium",FRM="L":"Large",1:"") + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN10_" Body Mass Index: "_BMI + S EXT="" I $G(TSF)!$G(SCA)!$G(ACIR)!$G(CCIR) S EXT="Y" + G:EXT'="Y" EN2 ;there is no antthropometric measurement. + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Anthropometric Measurements" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN35_"%ile %ile" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Triceps Skinfold (mm) "_$J(+TSF,3,0)_" "_$J(TSFP,3)_LN5_"Arm Circumference (cm) " + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+ACIR,3,0)_" "_$J(ACIRP,3) + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Subscapular Skinfold (mm) " + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+SCA,3,0)_" "_$J(SCAP,3)_" Bone-free AMA (cm2) " + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+BFAMA,3,0)_" "_$J(BFAMAP,3) + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Calf Circumference (cm) " + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+CCIR,3,0)_" "_$J(CCIRP,3) +EN2 ;skip here if there is no anthropometric measurement. + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_"Laboratory Data" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Test"_LN20_"Result units"_LN10_"Ref. range"_LN10_"Date" + S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" D LAB + I 'N1 D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + .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" + S N=PRO/6.25 +DRU ;pharmacy data. + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Medications" + S PX=1 D DRUG^FHASM4 + I $D(PSCA) D + .F FHI=0:0 S FHI=$O(PSCA(FHI)) Q:FHI'>0 S FHJ="" F S FHJ=$O(PSCA(FHI,FHJ)) Q:FHJ="" D + ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_FHJ + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Educated on Food/Drug Interactions: "_$S(FHREDU="Y":"Yes",1:"No") K FHREDU + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="FOOD/DRUG COMMENT: "_FHRFDC + K FHI,FHJ,PSD,PSCA + ; + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Energy Requirements: "_KCAL_" Kcal/day" + I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" Kcal:N "_$J(KCAL/N,0,0)_":1" + I NB'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" N-Bal: "_NB + I FHRFEC'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Energy calculation is based on: "_FHRFEC + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Protein Requirements: "_PRO_" gm/day" + I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" NPC:N "_$J(KCAL-(PRO*4)/N,0,0)_":1" + I FHRFPC'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Protein calculation is based on: "_FHRFPC + K FHRFEC,FHRFPC + I FLD'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Fluid Requirements: "_FLD_" ml/day" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + I FHAPP'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Appearance: "_FHAPP + I XD D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Class: "_$P($G(^FH(115.3,XD,0)),"^",1) + I RC D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Status: "_$P($G(^FH(115.4,RC,0)),"^",2) + D DCOM + Q +DIA ;get data from DI node. + I ASN S FHDIA=$G(^FHPT(FHDFN,"N",ASN,"DI")) Q:FHDIA="" D + .S FHRDIPL=$P(FHDIA,U,1) + .S FHRDIPLD=$P(FHDIA,U,2) + .S FHRDINF=$P(FHDIA,U,3) + .S FHRDINFD=$P(FHDIA,U,4) + .S FHRFUD=$P(FHDIA,U,5) + .S FHRDIST=$P(FHDIA,U,6) + .S FHRDIDI=$P(FHDIA,U,7) + .S FHRDITF=$P(FHDIA,U,8) + .S FHRDITFM=$P(FHDIA,U,10) + .S FHRDITFK=$P(FHDIA,U,11) + .S FHRDITFC=$P($G(^FHPT(FHDFN,"N",ASN,4)),U,1) + .S FHRFEC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,2) + .S FHRFPC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,3) + .S FHRDINA=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,4) + .S FHREDU=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,5) + .S FHRFDC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,6) + Q +DCOM ;print follow up date and status and comments + S DTP="" I FHRFUD S DTP=FHRFUD D DTP^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Follow-up Date: "_DTP + K FHRFUD,FHRDIST + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Comments:" + I ASN F K=0:0 S K=$O(^FHPT(FHDFN,"N",ASN,"X",K)) Q:K<1 D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=^FHPT(FHDFN,"N",ASN,"X",K,0) + S SIGN=$P(^FHPT(FHDFN,"N",ASN,0),U,23) + S FHRDT=DT,FHIFN="",FHESBY=FHCLI + ;Use data from user selection from file 8925.1 + K DIC,DA W !!,"Enter a Progress Note Title for this Assessment!!",! + 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 + K DIC I X["^"!$D(DTOUT)!(Y<1) S FHOUT=1 Q + S FHIEN1=+Y + ;call TIU to create a progress notes; DBIA #1911 + ;D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","",FHESBY,"","") + D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","","","","") + I $P(FHIFN,U,1)'>0 S FHOUT=1 + K FHIFN,FHRDT,FHTITLE,FHESBY,FHTIUST,FH251,FHIEN1 + ;done + Q +Q6 D FOOT Q +LAB S X1=$P(LRTST(K),"^",7) Q:X1="" S DTP=X1\1 D DTP^FH + I 'N1 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" S N1=N1+1 + S FHLABTE=$P(LRTST(K),U,1)_" " + S FHLABRE=$P(LRTST(K),U,6)_" " + S FHLABUN=$P(LRTST(K),U,4)_" " + S FHLABRR=$P(LRTST(K),U,5)_" " + 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 + Q +HEAD ; Page Header + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=DTP_LN30_"NUTRITION ASSESSMENT" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN + Q +FOOT ; Page Footer + D SITE^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + I $G(DFN) S W1=$G(^DPT(DFN,.1)) S:$D(^DPT(DFN,.101)) W1=W1_"/"_^DPT(DFN,.101) I W1'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_W1_LN5_"(Vice SF 509)" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + Q Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHASP1.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHASP1.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHASP1.m (revision 623) @@ -1,82 +1,82 @@ -FHASP1 ; HISC/REL/JH - Nutrition Profile (cont) ;5/2/01 10:14 - ;;5.5;DIETETICS;**8,9**;Jan 28, 2005;Build 7 - ; - I '$G(FHET) S X="T-365",%DT="XT" D ^%DT S FHET=Y K %DT - S DTP=FHET D DTP^FH S FHENDATE=DTP - S N1=0 - W !!?22,"Dietetic Encounters since ",FHENDATE - 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'0 S Z=^(NDT,0) I "I"[$P(Z,"^",2) D CLIN Q:ANS="^" - K ^TMP($J) - S FHCNT="" - D GETAPPT^SDAMA201(DFN,"1;2;12","R",DT,,.FHCNT,"") - G:'$D(^TMP($J,"SDAMA201","GETAPPT")) NOAPP - I $D(^TMP($J,"SDAMA201","GETAPPT")) S FHTMP=$NA(^TMP($J,"SDAMA201","GETAPPT")) - I $D(@FHTMP@("ERROR")) D PRERR - I $G(FHCNT) F FHI=0:0 S FHI=$O(@FHTMP@(FHI)) Q:FHI'>0 D CLIN I ANS="^" K ^TMP($J) Q - K ^TMP($J) - ;end changes in patch #41 - Q:ANS="^" -NOAPP I 'N1 W !!?5,"No scheduled appointments." - D FOOT^FHASP Q -LST S X0=$G(^FHEN(ASN,0)) Q:$P(X0,"^",4)<3 - S X1=$G(^FHEN(ASN,"P",DFN,0)) - 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)" - S Y=$P(X0,"^",9) W ", ",$S(Y="G":"Group",1:"Individual") - S Y=$P(X0,"^",11) W:Y'="" !?10,Y S Y=$P(X1,"^",4) W:Y'="" !?10,Y Q - ;patch #41 -CLIN ;S SC=+$P(Z,"^",1),Y=$P($G(^SC(SC,0)),"^",1) Q:Y="" - S NDT=@FHTMP@(FHI,1) - S SC=$P(@FHTMP@(FHI,2),U,1) - S Y=$P(@FHTMP@(FHI,2),U,2) Q:Y="" - D:$Y'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 ! - . Q - Q:ANS="^" - I $O(P(""))="" W !,"No Food Preferences on file",! - Q -P0 I X1'="" W ?12 S X=X1 D P1 S X1=X - I X2'="" W ?46 S X=X2 D P1 S X2=X - Q:X1=""&(X2="") D:$Y'0 S Z=^(NDT,0) I "I"[$P(Z,"^",2) D CLIN Q:ANS="^" + K ^TMP($J) + S FHCNT="" + D GETAPPT^SDAMA201(DFN,"1;2;12","R",DT,,.FHCNT,"") + G:'$D(^TMP($J,"SDAMA201","GETAPPT")) NOAPP + I $D(^TMP($J,"SDAMA201","GETAPPT")) S FHTMP=$NA(^TMP($J,"SDAMA201","GETAPPT")) + I $D(@FHTMP@("ERROR")) D PRERR + I $G(FHCNT) F FHI=0:0 S FHI=$O(@FHTMP@(FHI)) Q:FHI'>0 D CLIN I ANS="^" K ^TMP($J) Q + K ^TMP($J) + ;end changes in patch #41 + Q:ANS="^" +NOAPP I 'N1 W !!?5,"No scheduled appointments." + D FOOT^FHASP Q +LST S X0=$G(^FHEN(ASN,0)) Q:$P(X0,"^",4)<3 + S X1=$G(^FHEN(ASN,"P",DFN,0)) + 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)" + S Y=$P(X0,"^",9) W ", ",$S(Y="G":"Group",1:"Individual") + S Y=$P(X0,"^",11) W:Y'="" !?10,Y S Y=$P(X1,"^",4) W:Y'="" !?10,Y Q + ;patch #41 +CLIN ;S SC=+$P(Z,"^",1),Y=$P($G(^SC(SC,0)),"^",1) Q:Y="" + S NDT=@FHTMP@(FHI,1) + S SC=$P(@FHTMP@(FHI,2),U,1) + S Y=$P(@FHTMP@(FHI,2),U,2) Q:Y="" + D:$Y'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 ! + . Q + Q:ANS="^" + I $O(P(""))="" W !,"No Food Preferences on file",! + Q +P0 I X1'="" W ?12 S X=X1 D P1 S X1=X + I X2'="" W ?46 S X=X2 D P1 S X2=X + Q:X1=""&(X2="") D:$Y'FHEDT W !!,"END DATE BEFORE START DATE!",! H 1 Q - K ^TMP($J,"FH") S FHEDT=FHEDT_.99 - 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 - .I '$D(^FHPT(FHDFN,0)) Q - .; Quit if patient is deceased - DSS developer added lines DATA+9,10,13 - .S FHDCEASE=$$GET1^DIQ(2,$P(^FHPT(FHDFN,0),U,3),".351","I") - .Q:FHDCEASE&(FHDCEASEFHEDT Q - .I '$P(FHZN,U,14),FHDCEASE S $P(FHZN,U,14)=FHDCEASE - .S FHDDTM=$P(FHZN,U,14) I FHDDTM'="",FHDDTM0!(FHDATE>FHEDT) D - ..S FHDSEQ=$P($G(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE,0)),U,2) - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDSEQ,0)) - ..I FHDATE0!(FHDATE>FHEDT) D - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"EL",FHDATE,0)) - ..I FHDATE0 D - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SF",FHSF,0)) - ..S FHDATE=$P(FHNODE,U,2) I FHDATE>FHEDT Q - ..S FHCDATE=$P(FHNODE,U,32) I FHCDATE'="" I FHCDATE0 D - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SP",FHSO,0)) - ..S FHDATE=$P(FHNODE,U,4) I FHDATE>FHEDT Q - ..S FHCDATE=$P(FHNODE,U,6) I FHCDATE'="" I FHCDATE0 D - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,0)) - ..S FHDATE=$P(FHNODE,U,1) I FHDATE>FHEDT Q - ..S FHCDATE=$P(FHNODE,U,11) I FHCDATE'="" I FHCDATE0 D - ...S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR,0)) - ...S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"TF",FHTFPR,"P")=FHNODE - ...Q - ..Q - .Q - ; Get outpatient meals - S X1=FHSDT,X2=-1 D C^%DTC S FHSDTX1=X_.99 - ; Get recurring meals - F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("RM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'0 D - .....S FHTUZN=$G(^FHPT(FHDFN,"OP",FHRNUM,"TF",FHZ,0)) - .....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) - ; Get special meals - F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("SM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'FHEDT W !!,"END DATE BEFORE START DATE!",! H 1 Q + K ^TMP($J,"FH") S FHEDT=FHEDT_.99 + 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 + .S FHDSEQ=$P($G(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE,0)),U,2) + .S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDSEQ,0)) + .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) + ; Get additional feedings for inpatient + 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 + .F FHEL=FHSDT:0 S FHEL=$O(^FHPT(FHDFN,"A",FHADM,"EL",FHEL)) Q:FHEL'>0!(FHEL>FHEDT) D + ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"EL",FHEL,0)) + ..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) + .F FHSF=0:0 S FHSF=$O(^FHPT(FHDFN,"A",FHADM,"SF",FHSF)) Q:FHSF'>0 D + ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SF",FHSF,0)),FHSFDT=$P(FHNODE,U,2) + ..I FHSFDTFHEDT) Q + ..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) + .F FHSO=0:0 S FHSO=$O(^FHPT(FHDFN,"A",FHADM,"SP",FHSO)) Q:FHSO'>0 D + ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SP",FHSO,0)),FHSODT=$P(FHNODE,U,4) + ..I FHSODTFHEDT) Q + ..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) + .F FHTF=0:0 S FHTF=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF)) Q:FHTF'>0 D + ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,0)),FHTFDT=$P(FHNODE,U,1) + ..I FHTFDTFHEDT) Q + ..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) + ..F FHTFPR=0:0 S FHTFPR=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR)) Q:FHTFPR'>0 D + ...S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR,0)) + ...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) + ..Q + .Q + ; Get outpatient meals + S X1=FHSDT,X2=-1 D C^%DTC S FHSDTX1=X_.99 + ; Get recurring meals + F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("RM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'0 D + .....S FHTUZN=$G(^FHPT(FHDFN,"OP",FHRNUM,"TF",FHZ,0)) + .....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) + ; Get special meals + F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("SM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'2 D DPLL^FHLABEL,KIL Q - I 'D3 F L=1:1:18 W ! -KIL K ^TMP($J) G KILL^XUSCLEAN -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 - 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 - 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 - D SF0 - G ^FHNO21:'D3,PRT -F0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 -F1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN'>0 S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 F1 - G:'$D(^FHPT(FHDFN,"A",ADM,0)) F1 S X1=^(0),NO=$P(X1,"^",7) G:'NO F1 - I 'D3 S IS=$P(X1,"^",10) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" - D CHK G:'NO F1 - S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)) - S Y=$P(Y,"^",P1,P1+7) G:Y?."^" F1 D:D3 CALC - I 'D3 D - .D PATNAME^FHOMUTL I DFN="" Q - .S $P(Y,"^",9)=IS - .S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) - .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") - .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") - .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) - .S RM=$G(^DPT(DFN,.101)),PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM - .S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD Q - G F1 - Q - ; -CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1 - I X1>1,X1'>T0 G C2 -C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2 - S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO="" -C1 K FHORD,A1,K,X1 Q -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 - 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 -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 - I XX="W" S X=$G(^FH(119.6,W1,0)) D S0 - 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 - D SF0 - G PRT -S0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 -S1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 S1 - G:'$D(^FHPT(FHDFN,"A",ADM,0)) S1 S X1=^(0),NO=$P(X1,"^",7) G:'NO S1 - S Y=$P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3) G:Y?."^" S1 D CALC - G S1 -PRT S DTP=DT D DTP^FH S DTE=DTP_" "_$S(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM") - S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:WRDN) - W @IOF W:D3=2 !?5,"**** CONSOLIDATED ****" W !?3,"**** INGREDIENTS LIST ****",! W:D3=1 ! W ?(33-$L(Y)\2),Y,!?9,DTE,!! - 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)="" - 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) - W !!?4,"**** PATIENTS = ",N1," ****",! Q -CALC S N1=N1+1 - 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 - Q - ; -SF0 ;outpatient SFs - 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 - .S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO) - .S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3) - .S X1=$G(^FH(119.6,FHOWARD,0)) - .Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0)) - .I XX="W",W1 Q:W1'=FHOWARD - .S WRDN=$P(X1,U,1) - .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) - .S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5) - .I (FHMEAL="B"),(TIM'=10) Q - .I (FHMEAL="N"),(TIM'=2) Q - .I (FHMEAL="E"),(TIM'=8) Q - .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="" - .S Y=$G(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0)) - .S Y=$P(Y,"^",P1,P1+7) Q:Y?."^" I D3 D CLC1 - .S N1=N1+1 - .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) - .I 'D3 D - ..D PATNAME^FHOMUTL - ..S $P(Y,"^",9)=IS - ..S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) - ..S RI="***" S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") - ..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") - ..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) - ..S PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM - ..S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD - Q -CLC1 ; - 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 - Q +FHNO2 ; HISC/REL/NCA - Supplemental Feeding Labels ;8/26/94 12:01 + ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53 + ;patch #5 - add outpatient SFs. +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 + I XX'?1U!("SW"'[XX) W *7," Enter S or W" G D0 + I XX="S" S D1=$O(^FH(119.74,0)) I D1'<1,$O(^FH(119.74,D1))<1 G D3 + I XX="W" S WRD=$O(^FH(119.6,0)) I WRD'<1,$O(^FH(119.6,WRD))<1 G D3 + I XX="S" G D2 +D1 R !!,"Select WARD: ",X:DTIME G:'$T!("^"[X) KIL + K DIC S DIC="^FH(119.6,",DIC(0)="EMQ" D ^DIC G:Y<1 D1 S W1=+Y + S D1=$P($G(^FH(119.6,W1,0)),"^",9) G D3 +D2 R !!,"Select SUPPLEMENTAL FEEDING SITE: ",X:DTIME G:'$T!("^"[X) KIL + K DIC S DIC="^FH(119.74,",DIC(0)="EMQ" D ^DIC G:Y<1 D2 S D1=+Y,W1=0 +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 + I TIM'=2,TIM'=8,TIM'=10,TIM'="ALL" W *7," Enter a time, 10,2,8, or ALL" G D3 + 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 + Q:$D(DIRUT) S LABSTART=Y +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 + S D3=$E(D3,1),D3=D3="Y" G:'D3 D6 +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 + S X=$E(X,1) S:X="Y" D3=D3+1 +D6 I 'D3,'D1,XX="L" W !!,"No Supplemental Feeding Site associated with this location." G KIL + W:'D3 !!,"Place Labels in Printer" +PR K IOP S %ZIS="MQ",%ZIS("A")="Select "_$S('D3:"LABEL",1:"LIST")_" Printer: " W ! D ^%ZIS K %ZIS,IOP G:POP KIL + I $D(IO("Q")) S FHPGM="Q1^FHNO2",FHLST="XX^TIM^W1^D1^D3^LABSTART" D EN2^FH G KIL + U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL +Q1 ; Process Printing Supplemental Feeding Labels + S TIMSAV=TIM + D NOW^%DTC S NOW=%,DT=%\1 G:D3=2 SUM + 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 + S COUNT=0,LINE=1 I TIM="ALL" S TIM=10 D Q2 S TIM=2 D Q2 S TIM=8 + D Q2 + I $G(LAB)>2 D DPLL^FHLABEL,KIL Q + I 'D3 F L=1:1:18 W ! +KIL K ^TMP($J) G KILL^XUSCLEAN +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 + 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 + 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 + D SF0 + G ^FHNO21:'D3,PRT +F0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 +F1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN'>0 S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 F1 + G:'$D(^FHPT(FHDFN,"A",ADM,0)) F1 S X1=^(0),NO=$P(X1,"^",7) G:'NO F1 + I 'D3 S IS=$P(X1,"^",10) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" + D CHK G:'NO F1 + S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)) + S Y=$P(Y,"^",P1,P1+7) G:Y?."^" F1 D:D3 CALC + I 'D3 D + .D PATNAME^FHOMUTL I DFN="" Q + .S $P(Y,"^",9)=IS + .S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) + .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") + .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") + .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) + .S RM=$G(^DPT(DFN,.101)),PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM + .S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD Q + G F1 + Q + ; +CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1 + I X1>1,X1'>T0 G C2 +C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2 + S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO="" +C1 K FHORD,A1,K,X1 Q +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 + 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 +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 + I XX="W" S X=$G(^FH(119.6,W1,0)) D S0 + 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 + D SF0 + G PRT +S0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 +S1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 S1 + G:'$D(^FHPT(FHDFN,"A",ADM,0)) S1 S X1=^(0),NO=$P(X1,"^",7) G:'NO S1 + S Y=$P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3) G:Y?."^" S1 D CALC + G S1 +PRT S DTP=DT D DTP^FH S DTE=DTP_" "_$S(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM") + S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:WRDN) + W @IOF W:D3=2 !?5,"**** CONSOLIDATED ****" W !?3,"**** INGREDIENTS LIST ****",! W:D3=1 ! W ?(33-$L(Y)\2),Y,!?9,DTE,!! + 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)="" + 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) + W !!?4,"**** PATIENTS = ",N1," ****",! Q +CALC S N1=N1+1 + 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 + Q + ; +SF0 ;outpatient SFs + 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 + .S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO) + .S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3) + .S X1=$G(^FH(119.6,FHOWARD,0)),WRDN=$P(X1,U,1) + .Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0)) + .I XX="W",W1 Q:W1'=FHOWARD + .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) + .S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5) + .I (FHMEAL="B"),(TIM'=10) Q + .I (FHMEAL="N"),(TIM'=2) Q + .I (FHMEAL="E"),(TIM'=8) Q + .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="" + .S Y=$G(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0)) + .S Y=$P(Y,"^",P1,P1+7) Q:Y?."^" I D3 D CLC1 + .S N1=N1+1 + .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) + .I 'D3 D + ..D PATNAME^FHOMUTL + ..S $P(Y,"^",9)=IS + ..S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) + ..S RI="***" S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") + ..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") + ..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) + ..S PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM + ..S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD + Q +CLC1 ; + 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 + Q Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHOMPP.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHOMPP.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHOMPP.m (revision 623) @@ -1,80 +1,80 @@ -FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;7/2/2007 - ;;5.5;DIETETICS;**9**;Jan 28, 2005;Build 7 - D DEV Q -DEV ;get device and set up queue - W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP - I '$D(IO("Q")) U IO D DISP,^%ZISC,END Q - S ZTRTN="DISP^FHOMPP" - S ZTSAVE("FHDFN")="" - S ZTDESC="Outpatient Meals Recurring Meals Display" D ^%ZTLOAD - D ^%ZISC K %ZIS,IOP - D END Q -DISP ; - S EX="" D HDR - D ALG^FHCLN I ALG'="" W !!,"Allergies: ",ALG - K ^TMP($J) F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D - .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) - .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) - .Q:FHFPIEN="" - .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) - .S FHMEAL=FHNORD_FHMEAL - .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" - .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" - .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM - .Q - W !!,"Food Preferences Currently on file: " - I $D(^TMP($J,"L")) W !!?20,"Likes" - S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM=""!(EX=U) D - .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 - I $D(^TMP($J,"D")) W !!?20,"Dislikes" - S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM=""!(EX=U) D - .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 - ; - 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 - W !!,"Recurring Meals on File: " I $Y>(IOSL-4) D PG I EX=U Q - W ! S STDT=DT S FHPP=1 D DISP^FHOMRR1 K FHPP - I EX'=U,IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR - Q -PG ; - I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q - D HDR Q -HDR ; - W:$Y @IOF - W !!,"OUTPATIENT NAME: " D PATNAME^FHOMUTL W FHPTNM," ",FHSSN - W ?65,FHSEX," Age ",FHAGE Q -END ; - K FHM,FHP,FHT Q - ; -CPRS ; Call from FHWOR71 to get outpatient profile for CPRS - ; Data is returned in ^TMP($J,"FHPROF",DFN,FHX) - S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q "-1^Invalid outpatient" - K ^TMP($J,"FHPROF"),^TMP($J,"L"),^TMP($J,"D") S (FHX,N)=0 D PATNAME^FHOMUTL - S FHB="" F I=1:1:80 S FHB=FHB_" " - S ^TMP($J,"FHPROF",DFN,FHX)="OUTPATIENT NAME: "_FHPTNM_" "_FHSSN - S FHJ=66 D PAD^FHOMPP1 S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"FHPROF",DFN,FHX)_PAD_FHSEX_" Age "_FHAGE - D ALG^FHCLN I ALG'="" S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Allergies: "_ALG - F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D - .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) - .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) - .Q:FHFPIEN="" - .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) - .S FHMEAL=FHNORD_FHMEAL - .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" - .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" - .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM - .Q - S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Food Preferences Currently on file: " - I $D(^TMP($J,"L")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Likes" - S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM="" D - .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) - I $D(^TMP($J,"D")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Dislikes" - S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM="" D - .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) - ; - S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Recurring Meals on File: " - S STDT=DT D ^FHOMPP1 - Q -NEWL ;New line before next line of text in ^TMP global - I N=1 S FHX=FHX+1,^TMP($J,"FHPROF",DFN,FHX)=" " - S FHX=FHX+1 - Q +FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;6/23/03 1:04 + ;;5.5;DIETETICS;;Jan 28, 2005 + D DEV Q +DEV ;get device and set up queue + W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP + I '$D(IO("Q")) U IO D DISP,^%ZISC,END Q + S ZTRTN="DISP^FHOMPP" + S ZTSAVE("FHDFN")="" + S ZTDESC="Outpatient Meals Recurring Meals Display" D ^%ZTLOAD + D ^%ZISC K %ZIS,IOP + D END Q +DISP ; + S EX="" D HDR + D ALG^FHCLN I ALG'="" W !!,"Allergies: ",ALG + K ^TMP($J) F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D + .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) + .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) + .Q:FHFPIEN="" + .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) + .S FHMEAL=FHNORD_FHMEAL + .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" + .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" + .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM + .Q + W !!,"Food Preferences Currently on file: " + I $D(^TMP($J,"L")) W !!?20,"Likes" + S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM=""!(EX=U) D + .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 + I $D(^TMP($J,"D")) W !!?20,"Dislikes" + S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM=""!(EX=U) D + .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 + ; + 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 + W !!,"Recurring Meals on File: " I $Y>(IOSL-4) D PG I EX=U Q + W ! S STDT=DT S FHPP=1 D DISP^FHOMRR1 K FHPP + I EX'=U,IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR + Q +PG ; + I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q + D HDR Q +HDR ; + W:$Y @IOF + W !!,"OUTPATIENT NAME: " D PATNAME^FHOMUTL W FHPTNM," ",FHSSN + W ?65,FHSEX," Age ",FHAGE Q +END ; + K FHM,FHP,FHT Q + ; +CPRS ; Call from FHWOR71 to get outpatient profile for CPRS + ; Data is returned in ^TMP($J,"FHPROF",DFN,FHX) + S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q "-1^Invalid outpatient" + K ^TMP($J,"FHPROF",DFN) S (FHX,N)=0 D PATNAME^FHOMUTL + S FHB="" F I=1:1:80 S FHB=FHB_" " + S ^TMP($J,"FHPROF",DFN,FHX)="OUTPATIENT NAME: "_FHPTNM_" "_FHSSN + S FHJ=66 D PAD^FHOMPP1 S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"FHPROF",DFN,FHX)_PAD_FHSEX_" Age "_FHAGE + D ALG^FHCLN I ALG'="" S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Allergies: "_ALG + F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D + .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) + .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) + .Q:FHFPIEN="" + .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) + .S FHMEAL=FHNORD_FHMEAL + .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" + .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" + .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM + .Q + S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Food Preferences Currently on file: " + I $D(^TMP($J,"L")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Likes" + S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM="" D + .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 + I $D(^TMP($J,"D")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Dislikes" + S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM="" D + .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 + ; + S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Recurring Meals on File: " + S STDT=DT D ^FHOMPP1 + Q +NEWL ;New line before next line of text in ^TMP global + I N=1 S FHX=FHX+1,^TMP($J,"FHPROF",DFN,FHX)=" " + S FHX=FHX+1 + Q Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHORC5.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHORC5.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHORC5.m (revision 623) @@ -1,22 +1,20 @@ -FHORC5 ; HISC/REL - Consult Management ;4/12/06 13:26 - ;;5.5;DIETETICS;**4,12**;Jan 28, 2005;Build 3 - ; 10/17/2007 BP/KAM FH*5.5*12 Rem Call 210883 Remove Old Clinician Field (#1) -EN9 ; Enter/Edit Ward Assignments - K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQM" - 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)) - ; 10/17/2007 BP/KAM *12 Rem Call 210883 Removed field #1 in next line - 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 - D:OLD'=NEW EN2^FHORC4 K OLD,NEW,X,Y G EN9 -EN10 ; List Ward Assignments - W ! S L=0,DIC="^FH(119.6,",FLDS="[FHORWRD]",BY=".01" - S (FR,TO)="",DHD="NUTRITION LOCATION ASSIGNMENTS" D EN1^DIP,RSET Q -EN11 ; Enter/Edit Consult Types - S (DIC,DIE)="^FH(119.5,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=119.5 - W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN11:Y<1 - 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 -EN12 ; List Consult Types - W !!,"The list requires a 132 column printer.",! - W ! S L=0,DIC="^FH(119.5,",FLDS="[FHORCON]",BY=".01" - S (FR,TO)="",DHD="CONSULTATION TYPES" D EN1^DIP,RSET Q -RSET K %ZIS S IOP="" D ^%ZIS -KIL K %,%ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,NEW,OLD,TO,X,Y Q +FHORC5 ; HISC/REL - Consult Management ;4/12/06 13:26 + ;;5.5;DIETETICS;**4**;Jan 28, 2005;Build 32 +EN9 ; Enter/Edit Ward Assignments + K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQM" + 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)) + 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 + D:OLD'=NEW EN2^FHORC4 K OLD,NEW,X,Y G EN9 +EN10 ; List Ward Assignments + W ! S L=0,DIC="^FH(119.6,",FLDS="[FHORWRD]",BY=".01" + S (FR,TO)="",DHD="NUTRITION LOCATION ASSIGNMENTS" D EN1^DIP,RSET Q +EN11 ; Enter/Edit Consult Types + S (DIC,DIE)="^FH(119.5,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=119.5 + W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN11:Y<1 + 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 +EN12 ; List Consult Types + W !!,"The list requires a 132 column printer.",! + W ! S L=0,DIC="^FH(119.5,",FLDS="[FHORCON]",BY=".01" + S (FR,TO)="",DHD="CONSULTATION TYPES" D EN1^DIP,RSET Q +RSET K %ZIS S IOP="" D ^%ZIS +KIL K %,%ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,NEW,OLD,TO,X,Y Q Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHPRO.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHPRO.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHPRO.m (revision 623) @@ -1,52 +1,47 @@ -FHPRO ; HISC/REL/RTK - Food Production Manager ;4/12/06 15:53 - ;;5.5;DIETETICS;**4,5,12**;Jan 28, 2005;Build 3 - ; - ; 10/16/2007 BY/KAM FH*5.5*12 Rem Call 210883 Remove access to old - ; Clinician field -EN2 ; Enter/Edit Nutrition Locations (Inpatient Wards/Outpatient Clinics) - W ! K DIR,DIC S DIR("A")="Select WARD or OUTPATIENT Location: " - S DIR(0)="SAO^W:Ward Location;O:Outpatient Location" D ^DIR I $D(DIRUT) G KIL - I Y'=-1 S FHANS=Y - I FHANS="W" D EN2WRD Q - I FHANS="O" D EN2OL Q - Q -EN2WRD ;Ward locations - K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 - ; S DR=".01;2:2.5;... POTENTIAL CHG FOR 210883 WAS S DR=".01:2.5;3" - ; 10/16/2007 BP/KAM FH*5.5*12 changed next line to remove access to field # 1 Clinician (Old Clinician field) - 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 -EN2OL ;Outpatient locations - K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 - 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 -EN3 ; Enter/Edit Production Diets - K DIC S (DIC,DIE)="^FH(116.2,",DIC(0)="AEQLM",DLAYGO=116.2 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN3:Y<1 - 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 - S:$O(^FH(116.2,DA,"R",0))<1 $P(^FH(116.2,DA,0),"^",4)="N" D KIL G EN3 -EN4 ; List Production Diets - W !!,"The list requires a 132 column printer.",! - W ! S L=0,DIC="^FH(116.2,",FLDS="[FHPROD]",BY="8,.01" - S FR="@",TO="",DHD="PRODUCTION DIETS" D EN1^DIP,RSET Q -EN5 ; Enter/Edit Production Facilities - K DIC S (DIC,DIE)="^FH(119.71,",DIC(0)="AEQLM",DLAYGO=119.71 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN5:Y<1 - S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.71 D ^DIE,KIL G EN5 -EN6 ; Enter/Edit Service Points - K DIC S (DIC,DIE)="^FH(119.72,",DIC(0)="AEQLM",DLAYGO=119.72 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN6:Y<1 - S DA=+Y S DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.72 D ^DIE I '$D(DA) D KIL G EN6 - 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 - 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 - D KIL G EN6 -EN7 ; Enter/Edit Communication Offices - K DIC S (DIC,DIE)="^FH(119.73,",DIC(0)="AEQLM",DLAYGO=119.73 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN7:Y<1 - S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.73 D ^DIE,KIL G EN7 -EN8 ; Enter/Edit Supplemental Feeding Sites - K DIC S (DIC,DIE)="^FH(119.74,",DIC(0)="AEQLM",DLAYGO=119.74 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN8:Y<1 - S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.74 D ^DIE,KIL G EN8 -RSET K %ZIS S IOP="" D ^%ZIS -KIL G KILL^XUSCLEAN +FHPRO ; HISC/REL/RTK - Food Production Manager ;4/12/06 15:53 + ;;5.5;DIETETICS;**4,5**;Jan 28, 2005;Build 53 +EN2 ; Enter/Edit Nutrition Locations (Inpatient Wards/Outpatient Clinics) + W ! K DIR,DIC S DIR("A")="Select WARD or OUTPATIENT Location: " + S DIR(0)="SAO^W:Ward Location;O:Outpatient Location" D ^DIR Q:$D(DIRUT) + I Y'=-1 S FHANS=Y + I FHANS="W" D EN2WRD Q + I FHANS="O" D EN2OL Q + Q +EN2WRD ;Ward locations + K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 + 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 +EN2OL ;Outpatient locations + K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 + 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 +EN3 ; Enter/Edit Production Diets + K DIC S (DIC,DIE)="^FH(116.2,",DIC(0)="AEQLM",DLAYGO=116.2 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN3:Y<1 + 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 + S:$O(^FH(116.2,DA,"R",0))<1 $P(^FH(116.2,DA,0),"^",4)="N" D KIL G EN3 +EN4 ; List Production Diets + W !!,"The list requires a 132 column printer.",! + W ! S L=0,DIC="^FH(116.2,",FLDS="[FHPROD]",BY="8,.01" + S FR="@",TO="",DHD="PRODUCTION DIETS" D EN1^DIP,RSET Q +EN5 ; Enter/Edit Production Facilities + K DIC S (DIC,DIE)="^FH(119.71,",DIC(0)="AEQLM",DLAYGO=119.71 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN5:Y<1 + S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.71 D ^DIE,KIL G EN5 +EN6 ; Enter/Edit Service Points + K DIC S (DIC,DIE)="^FH(119.72,",DIC(0)="AEQLM",DLAYGO=119.72 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN6:Y<1 + S DA=+Y S DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.72 D ^DIE I '$D(DA) D KIL G EN6 + 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 + 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 + D KIL G EN6 +EN7 ; Enter/Edit Communication Offices + K DIC S (DIC,DIE)="^FH(119.73,",DIC(0)="AEQLM",DLAYGO=119.73 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN7:Y<1 + S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.73 D ^DIE,KIL G EN7 +EN8 ; Enter/Edit Supplemental Feeding Sites + K DIC S (DIC,DIE)="^FH(119.74,",DIC(0)="AEQLM",DLAYGO=119.74 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN8:Y<1 + S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.74 D ^DIE,KIL G EN8 +RSET K %ZIS S IOP="" D ^%ZIS +KIL G KILL^XUSCLEAN Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHPRW.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHPRW.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHPRW.m (revision 623) @@ -1,76 +1,70 @@ -FHPRW ;Hines OIFO/REL,RTK - List Dietetic Locations ;5/13/94 14:57 - ;;5.5;DIETETICS;**12**;Jan 28, 2005;Build 3 - ; 10/24/07 BAY/KAM FH*5.5*12 CALL 214407 Display new Clinician Field -F1 R !!,"Select LOCATION (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S WRD=0 - E K DIC S DIC="^FH(119.6,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 F1 S WRD=+Y - I 'WRD W !!,"Verifying completeness of room-bed & ward assignments ..." D VER - W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL - I $D(IO("Q")) S FHPGM="Q1^FHPRW",FHLST="WRD" D EN2^FH G KIL - U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL -Q1 ; Print Dietetic Ward Profile - K ^TMP($J) D NOW^%DTC S NOW=%,PG=0 I WRD S K1=WRD D Q2 W ! Q - 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 - S NX="" F S NX=$O(^TMP($J,"FHW",NX)) Q:NX="" S K1=+$G(^(NX)) I K1 D Q2 - W ! Q -Q2 S X=^FH(119.6,K1,0),NODE1=$G(^FH(119.6,K1,1)) D BLD,HDR - W !!,"Print Order:",?22,$P(X,"^",4) - W !,"Type of Location:",?22,$S($P(X,U,3)="O":"OUTPATIENT",1:"INPATIENT") - ; - ;10/24/07 BAY/KAM *12 214407 Print new Clinician Multiple field - N C1 S C1="" - F S C1=$O(^FH(119.6,K1,2,C1)) Q:C1="" D - . S Z=$G(^FH(119.6,K1,2,C1,0)) I Z W !,"Assigned Clinician(s):",?22,$P($G(^VA(200,Z,0)),"^",1) - ; - 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,"%)" - 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,"%)" - W !,"Dining Room:",?22 S Z=$P(X,"^",7) I Z W "Yes" S Z=$P(X,"^",19) S:Z="" Z=100 W " (",Z,"%)" - W !,"Supplemental Fdgs.:",?22 S Z=$P(X,"^",9) I Z W $P($G(^FH(119.74,Z,0)),"^",1) - W !,"Diet Communication:",?22 S Z=$P(X,"^",8) I Z W $P($G(^FH(119.73,Z,0)),"^",1) - W !!,"Admission Diet:",?22 S Z=$P(X,"^",15) I Z W $P($G(^FH(111,Z,0)),"^",1) - E I $P(X,"^",16)="Y" W "NO ORDER" - W !!,"Review Frequencies:" - W !!?5,"NPO's:" S Z=$P(X,"^",11) W:Z ?19,$J(Z,3,0)," days" - W ?45,"Admit Status:" S Z=$P(X,"^",14) W:Z ?59,$J(Z,3,0)," days" - W !?5,"Tubefeedings:" S Z=$P(X,"^",12) W:Z ?19,$J(Z,3,0)," days" - W ?45,"Supp. Fdgs.:" S Z=$P(X,"^",13) W:Z ?59,$J(Z,3,0)," days" - W !!?5,"Status I:" S Z=$P(X,"^",20) W:Z ?19,$J(Z,3,0)," days" - W ?45,"Status III:" S Z=$P(X,"^",22) W:Z ?59,$J(Z,3,0)," days" - W !?5,"Status II:" S Z=$P(X,"^",21) W:Z ?19,$J(Z,3,0)," days" - W ?45,"Status IV:" S Z=$P(X,"^",23) W:Z ?59,$J(Z,3,0)," days" - S FHY=$P(X,"^",24) W !!,"Bulk Nourishment Orders:",! - 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) - 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) - W !!,"Room-Beds Assigned:",! - 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) - 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)) - W !!,"Default MAS Wards:",! - 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) - 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) - W !!,"Print Cafeteria on Tray Tickets: ",$S(FHY="Y":"YES",1:"NO") - S FHOL=$P(NODE1,U,1),FHOLFIL=$S(FHOL["SC(":44,FHOL["DIC(42":42,1:0) - S FHOLNM="" I FHOLFIL D - .S FHOLIEN=$P(FHOL,";",1) - .I FHOLFIL=42 S FHOLNM=$P($G(^DIC(42,FHOLIEN,0)),U,1) - .I FHOLFIL=44 S FHOLNM=$P($G(^SC(FHOLIEN,0)),U,1) - .W !!,"Outpatient Location: ",FHOLNM,! - W !,"Maximum # of Days to Schedule Recurring Meal: ",$P(NODE1,U,2) - W !,"Number of Days for Review of Recurring Meal: ",$P(NODE1,U,3) - W !!,"Non-VA Facility? ",$S($P(NODE1,U,4)="Y":"YES",1:"NO") - W ! Q -BLD ; Build temp files - K ^TMP($J,"B"),^TMP($J,"R"),^TMP($J,"W") - F LL=0:0 S LL=$O(^FH(119.6,K1,"BN",LL)) Q:LL<1 S Y=^(LL,0) D B1 - F LL=0:0 S LL=$O(^FH(119.6,K1,"W",LL)) Q:LL<1 S Y=^(LL,0) D B2 - F LL=0:0 S LL=$O(^FH(119.6,K1,"R",LL)) Q:LL<1 S Y=^(LL,0) D B3 - Q -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 -B2 S N=$P($G(^DIC(42,+Y,0)),"^",1) Q:N="" S ^TMP($J,"W",N_"~"_(+Y))="" Q -B3 S N=$P($G(^DG(405.4,+Y,0)),"^",1) Q:N="" S ^TMP($J,"R",N_"~"_(+Y))="" Q -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 - S Y=$P(X,"^",1) W !!?(78-$L(Y)\2),Y - W !,"-------------------------------------------------------------------------------",! Q -VER ; Verify completeness of data base - 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" - 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" - Q -KIL K ^TMP($J) G KILL^XUSCLEAN +FHPRW ;Hines OIFO/REL,RTK - List Dietetic Locations ;5/13/94 14:57 + ;;5.5;DIETETICS;;Jan 28, 2005 +F1 R !!,"Select LOCATION (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S WRD=0 + E K DIC S DIC="^FH(119.6,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 F1 S WRD=+Y + I 'WRD W !!,"Verifying completeness of room-bed & ward assignments ..." D VER + W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL + I $D(IO("Q")) S FHPGM="Q1^FHPRW",FHLST="WRD" D EN2^FH G KIL + U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL +Q1 ; Print Dietetic Ward Profile + K ^TMP($J) D NOW^%DTC S NOW=%,PG=0 I WRD S K1=WRD D Q2 W ! Q + 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 + S NX="" F S NX=$O(^TMP($J,"FHW",NX)) Q:NX="" S K1=+$G(^(NX)) I K1 D Q2 + W ! Q +Q2 S X=^FH(119.6,K1,0),NODE1=$G(^FH(119.6,K1,1)) D BLD,HDR + W !!,"Print Order:",?22,$P(X,"^",4) + W !,"Type of Location:",?22,$S($P(X,U,3)="O":"OUTPATIENT",1:"INPATIENT") + W !,"Assigned Clinician:",?22 S Z=$P(X,"^",2) I Z W $P($G(^VA(200,Z,0)),"^",1) + 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,"%)" + 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,"%)" + W !,"Dining Room:",?22 S Z=$P(X,"^",7) I Z W "Yes" S Z=$P(X,"^",19) S:Z="" Z=100 W " (",Z,"%)" + W !,"Supplemental Fdgs.:",?22 S Z=$P(X,"^",9) I Z W $P($G(^FH(119.74,Z,0)),"^",1) + W !,"Diet Communication:",?22 S Z=$P(X,"^",8) I Z W $P($G(^FH(119.73,Z,0)),"^",1) + W !!,"Admission Diet:",?22 S Z=$P(X,"^",15) I Z W $P($G(^FH(111,Z,0)),"^",1) + E I $P(X,"^",16)="Y" W "NO ORDER" + W !!,"Review Frequencies:" + W !!?5,"NPO's:" S Z=$P(X,"^",11) W:Z ?19,$J(Z,3,0)," days" + W ?45,"Admit Status:" S Z=$P(X,"^",14) W:Z ?59,$J(Z,3,0)," days" + W !?5,"Tubefeedings:" S Z=$P(X,"^",12) W:Z ?19,$J(Z,3,0)," days" + W ?45,"Supp. Fdgs.:" S Z=$P(X,"^",13) W:Z ?59,$J(Z,3,0)," days" + W !!?5,"Status I:" S Z=$P(X,"^",20) W:Z ?19,$J(Z,3,0)," days" + W ?45,"Status III:" S Z=$P(X,"^",22) W:Z ?59,$J(Z,3,0)," days" + W !?5,"Status II:" S Z=$P(X,"^",21) W:Z ?19,$J(Z,3,0)," days" + W ?45,"Status IV:" S Z=$P(X,"^",23) W:Z ?59,$J(Z,3,0)," days" + S FHY=$P(X,"^",24) W !!,"Bulk Nourishment Orders:",! + 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) + 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) + W !!,"Room-Beds Assigned:",! + 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) + 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)) + W !!,"Default MAS Wards:",! + 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) + 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) + W !!,"Print Cafeteria on Tray Tickets: ",$S(FHY="Y":"YES",1:"NO") + S FHOL=$P(NODE1,U,1),FHOLFIL=$S(FHOL["SC(":44,FHOL["DIC(42":42,1:0) + S FHOLNM="" I FHOLFIL D + .S FHOLIEN=$P(FHOL,";",1) + .I FHOLFIL=42 S FHOLNM=$P($G(^DIC(42,FHOLIEN,0)),U,1) + .I FHOLFIL=44 S FHOLNM=$P($G(^SC(FHOLIEN,0)),U,1) + .W !!,"Outpatient Location: ",FHOLNM,! + W !,"Maximum # of Days to Schedule Recurring Meal: ",$P(NODE1,U,2) + W !,"Number of Days for Review of Recurring Meal: ",$P(NODE1,U,3) + W !!,"Non-VA Facility? ",$S($P(NODE1,U,4)="Y":"YES",1:"NO") + W ! Q +BLD ; Build temp files + K ^TMP($J,"B"),^TMP($J,"R"),^TMP($J,"W") + F LL=0:0 S LL=$O(^FH(119.6,K1,"BN",LL)) Q:LL<1 S Y=^(LL,0) D B1 + F LL=0:0 S LL=$O(^FH(119.6,K1,"W",LL)) Q:LL<1 S Y=^(LL,0) D B2 + F LL=0:0 S LL=$O(^FH(119.6,K1,"R",LL)) Q:LL<1 S Y=^(LL,0) D B3 + Q +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 +B2 S N=$P($G(^DIC(42,+Y,0)),"^",1) Q:N="" S ^TMP($J,"W",N_"~"_(+Y))="" Q +B3 S N=$P($G(^DG(405.4,+Y,0)),"^",1) Q:N="" S ^TMP($J,"R",N_"~"_(+Y))="" Q +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 + S Y=$P(X,"^",1) W !!?(78-$L(Y)\2),Y + W !,"-------------------------------------------------------------------------------",! Q +VER ; Verify completeness of data base + 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" + 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" + Q +KIL K ^TMP($J) G KILL^XUSCLEAN Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHREP1.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHREP1.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHREP1.m (revision 623) @@ -1,86 +1,86 @@ -FHREP1 ; HISC/NCA - Inventory Worksheet and Report ;3/9/95 08:28 - ;;5.5;DIETETICS;**13**;Jan 28, 2005;Build 1 -EN2 ; Print the Inventory Worksheet & Report - S FHXX="F" - R !!,"Select W=Worksheet or R=Report: ",FHR:DTIME G:'$T!("^"[FHR) KIL^FHREP - I "wr"[FHR S X=FHR D TR^FH S FHR=X - I FHR'?1U!("WR"'[FHR) W *7," Enter W or R" G EN2 -E0 ; Read in Month and Year - D NOW^%DTC S NOW=%\1 - K %DT W !!,"Enter Mth/Yr: "_+$E(NOW,4,5)_"/"_$E(NOW,2,3)_"// " R X:DTIME G:'$T!(X["^") KIL^FHREP - I X="" S X=$E(NOW,1,5)_"00" - 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 E0 - 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 - I FHR="W" D F1^FHREP G:FHXX["^"!("^"[X) KIL^FHREP - I FHR="R" D D1^FHREP G:"^"[X KIL^FHREP -E1 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL^FHREP - I $D(IO("Q")) S FHPGM="Q0^FHREP1",FHLST="FHR^FHXX^MTH^SRT" D EN2^FH G KIL^FHREP - U IO D Q0 D ^%ZISC K %ZIS,IOP G KIL^FHREP -Q0 ; Process Printing worksheet or report - D Q1 G KIL^FHREP -Q1 ; Loop through Ingredients - 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 - 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) - S REC=0 - 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="^" - I FHR="R",ANS="",SRT W !!,?55,"TOTAL: ",$J(SUBTOT,8,2) - I FHR="R",ANS="",'SRT D SUB W !!?49,"GRAND TOTAL: ",$J(GRDTOT,8,2) - Q -LP ; Get Food Group or Storage - 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="" - S DTP=UDC D:DTP'="" DTP^FH S UDC=DTP,DTP=UDQ D:DTP'="" DTP^FH S UDQ=DTP - I FHXX="F" S P0=$P(X,"^",13) S:P0<1!(P0>6) P0=7 S:SRT&(P0'=SRT) OK=0 Q - 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 - Q -P1 ; Loop to print or if FHR="E" edit QOH - 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 - I FHR="E" D Q - .W !!,"Ingredient: ",$P(^FHING(K,0),"^",1) - .W:UDQ'="" !?12,"QOH LAST UPDATED ON ",UDQ,! - .K DIE S DIE="^FHING(",DA=K - .S:OKAY DR="8;S:X=COST Y=""@1"";29////"_DT_";@1;10;S:X=QOH Y="""";30////"_DT - .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 - .Q - D CHK Q:ANS="^" - D:$Y'<(IOSL-5) HD W ! Q:ANS="^" - I $L(ING)'>30 D - .W !,$J(MIN,5),?6,ING,?39,UP,?43,$J(COST,8,3) - .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q - .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) - .Q - E D - .S L=$L($E(ING,1,30),",") - .S:L=1 L=L+1 W !,$J(MIN,5),?6,$P(ING,",",1,L-1),"," - .W !?6,$P(ING,",",L,99),?39,UP,?43,$J(COST,8,3) - .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q - .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) - .Q - Q -CHK ; Check the Food Group or Storage to do Subtotal & Grandtotal - S P1=$S(FHXX="F":+P0,1:$E(P0,3,17)) - I REC=1 S OLD=P1 D HDR - I OLD'=P1 D:FHR="R" SUB D HD - S OLD=P1 - ; Calculate subtotal grand total - Q:FHR'="R" - S TOTAL=COST*QOH - S SUBTOT=SUBTOT+TOTAL - S GRDTOT=GRDTOT+TOTAL - Q -SUB ; Write subtotal - W !!,?52,"SUBTOTAL: ",$J(SUBTOT,8,2) - S SUBTOT=0 - Q -HD ; Check for end of page - G:REC=1 HDR - I IOST?1"C".E W:$X>1 ! W *7 K DIR S DIR(0)="E" D ^DIR I 'Y S ANS="^" Q -HDR ; Heading for the Inventory - W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 - 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"),!! - W ?(80-$L(MTH)/2),MTH,!! - I FHXX="F" S P2="FOOD GROUP: "_$P("MEAT PRODUCTS^MILK PRODUCTS^FRUITS & VEGETABLES^BREADS^COMMERCIAL NUTRITION SUPPLEMENTS^MISCELLANEOUS^UNCLASSIFIED","^",+P1) - E S P2=P1 - W ?(80-$L(P2)/2),P2,!! - 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 - W !?47,"ITEM",?58,"QOH",?67,"TOTAL",!,"ITEM#",?20,"NAME",?38,"U/P",?47,"COST",?56,"CURRENT",?68,"COST",! - Q +FHREP1 ; HISC/NCA - Inventory Worksheet and Report ;3/9/95 08:28 + ;;5.5;DIETETICS;;Jan 28, 2005 +EN2 ; Print the Inventory Worksheet & Report + S FHXX="F" + R !!,"Select W=Worksheet or R=Report: ",FHR:DTIME G:'$T!("^"[FHR) KIL^FHREP + I "wr"[FHR S X=FHR D TR^FH S FHR=X + I FHR'?1U!("WR"'[FHR) W *7," Enter W or R" G EN2 +E0 ; Read in Month and Year + D NOW^%DTC S NOW=%\1 + K %DT W !!,"Enter Mth/Yr: "_+$E(NOW,4,5)_"/"_$E(NOW,2,3)_"// " R X:DTIME G:'$T!(X["^") KIL^FHREP + I X="" S X=$E(NOW,1,5)_"00" + 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 + 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 + I FHR="W" D F1^FHREP G:FHXX["^"!("^"[X) KIL^FHREP + I FHR="R" D D1^FHREP G:"^"[X KIL^FHREP +E1 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL^FHREP + I $D(IO("Q")) S FHPGM="Q0^FHREP1",FHLST="FHR^FHXX^MTH^SRT" D EN2^FH G KIL^FHREP + U IO D Q0 D ^%ZISC K %ZIS,IOP G KIL^FHREP +Q0 ; Process Printing worksheet or report + D Q1 G KIL^FHREP +Q1 ; Loop through Ingredients + 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 + 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) + S REC=0 + 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="^" + I FHR="R",ANS="",SRT W !!,?55,"TOTAL: ",$J(SUBTOT,8,2) + I FHR="R",ANS="",'SRT D SUB W !!?49,"GRAND TOTAL: ",$J(GRDTOT,8,2) + Q +LP ; Get Food Group or Storage + 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="" + S DTP=UDC D:DTP'="" DTP^FH S UDC=DTP,DTP=UDQ D:DTP'="" DTP^FH S UDQ=DTP + I FHXX="F" S P0=$P(X,"^",13) S:P0<1!(P0>6) P0=7 S:SRT&(P0'=SRT) OK=0 Q + 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 + Q +P1 ; Loop to print or if FHR="E" edit QOH + 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 + I FHR="E" D Q + .W !!,"Ingredient: ",$P(^FHING(K,0),"^",1) + .W:UDQ'="" !?12,"QOH LAST UPDATED ON ",UDQ,! + .K DIE S DIE="^FHING(",DA=K + .S:OKAY DR="8;S:X=COST Y=""@1"";29////"_DT_";@1;10;S:X=QOH Y="""";30////"_DT + .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 + .Q + D CHK Q:ANS="^" + D:$Y'<(IOSL-5) HD W ! Q:ANS="^" + I $L(ING)'>30 D + .W !,$J(MIN,5),?6,ING,?39,UP,?43,$J(COST,8,3) + .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q + .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) + .Q + E D + .S L=$L($E(ING,1,30),",") + .S:L=1 L=L+1 W !,$J(MIN,5),?6,$P(ING,",",1,L-1),"," + .W !?6,$P(ING,",",L,99),?39,UP,?43,$J(COST,8,3) + .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q + .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) + .Q + Q +CHK ; Check the Food Group or Storage to do Subtotal & Grandtotal + S P1=$S(FHXX="F":+P0,1:$E(P0,3,17)) + I REC=1 S OLD=P1 D HDR + I OLD'=P1 D:FHR="R" SUB D HD + S OLD=P1 + ; Calculate subtotal grand total + Q:FHR'="R" + S TOTAL=COST*QOH + S SUBTOT=SUBTOT+TOTAL + S GRDTOT=GRDTOT+TOTAL + Q +SUB ; Write subtotal + W !!,?52,"SUBTOTAL: ",$J(SUBTOT,8,2) + S SUBTOT=0 + Q +HD ; Check for end of page + G:REC=1 HDR + I IOST?1"C".E W:$X>1 ! W *7 K DIR S DIR(0)="E" D ^DIR I 'Y S ANS="^" Q +HDR ; Heading for the Inventory + W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 + 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"),!! + W ?(80-$L(MTH)/2),MTH,!! + I FHXX="F" S P2="FOOD GROUP: "_$P("MEAT PRODUCTS^MILK PRODUCTS^FRUITS & VEGETABLES^BREADS^COMMERCIAL NUTRITION SUPPLEMENTS^MISCELLANEOUS^UNCLASSIFIED","^",+P1) + E S P2=P1 + W ?(80-$L(P2)/2),P2,!! + 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 + W !?47,"ITEM",?58,"QOH",?67,"TOTAL",!,"ITEM#",?20,"NAME",?38,"U/P",?47,"COST",?56,"CURRENT",?68,"COST",! + Q Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHSELA1.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHSELA1.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHSELA1.m (revision 623) @@ -1,173 +1,168 @@ -FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 - ;;5.5;DIETETICS;**8,12**;Jan 28, 2005;Build 3 - ; - ;10/16/2007 BAY/KAM FH*5.5*12 Remedy Call 210385 Do not allow - ; user to change Food Preference name or - ; LIKE/DISLIKE field - ; -CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 - ; and allow user to create the FP on the fly - D ^FHSELA2 S NUM=0,FHQUIT=0 - W !!!,"The following Allergy Food Preference titles are not on file." - W !,"You may use this option to create these Food Preference entries:" - D CRLIST I NUM=0 W !,"No Food Preferences need to be mapped." D EXIT Q - I FHQUIT=1 D EXIT Q - I FHRESP=""!(FHRESP="M") D EXIT Q - S FHAFPNM=$P(FHLIST(FHRESP),"^",1) - W !,FHAFPNM," " - K DIR S DIR("A")="Add to Food Preference file",DIR(0)="Y" D ^DIR - I $D(DIRUT) D EXIT Q - I Y'=1 D CREATE Q - D ADD - W !!," ...done. ",FHAFPNM," Food Preference has been added!" H 1 - D CREATE Q - D EXIT Q -CRLIST ; - W !!?5,"MISSING FOOD PREFERENCE LIST" - W !?5,"============================" - S FHSEL=0,FHK="" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK=""!(FHQUIT=1)!(FHSEL=1) D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) - .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) - .I $D(^FH(115.2,"B",FHZ1)) Q - .S NUM=NUM+1,PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM - .W ?8,FHZ1 - .S FHLIST(NUM)=FHZ1_"^"_FHFPS - .I NUM#5=0!($O(^TMP($J,"FHALG",FHK))="") D PG Q - .Q - I FHQUIT=0,FHSEL=0,NUM#5'=0 D PG Q - Q -ADD ; - S FHALGMZ=1 - S X=FHAFPNM K DIC,DO - S (DIC,DIE)="^FH(115.2,",DIC(0)="L" D FILE^DICN - ; 10/16/2007 BP/KAM FH*5.5*12 Default DISLIKE and prevent Food Preference name change in the next line - S (FHDA,DA)=+Y,DR="26;1////D" - D ^DIE K DA,DIE,DR - D TRAN^FHSEL1 - Q -PG ; - S FHRESP="" W ! K DIR - S DIR("A")="Select Food Preference or 'M' to see more ('^' to EXIT)" - S DIR(0)="F",DIR("B")="M" D ^DIR I $D(DIRUT) S FHQUIT=1 Q - S FHRESP=Y - I FHRESP?1"M" Q - I FHRESP?1.3N,FHRESP>0,FHRESP<(NUM+1) S FHSEL=1 Q - W !!,"Select from 1 to ",NUM D PG Q - Q -MAP ; Map allergies by setting pointers in 115.2 to correct entries in 120.82 - D ^FHSELA2 - S FHK="" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) - .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) - .I '$D(^FH(115.2,"B",FHZ1)) Q ;not set-up in 115.2, can't map - .S FHFPIEN=$O(^FH(115.2,"B",FHZ1,"")) - .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q ;no allergies to map - .S FHZ=0 F S FHZ=FHZ+1 S FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D - ..D LOOKUP - Q -LOOKUP ; Look-up the Allergy in 120.82 and set the pointer - S FHX=FHANAM - F FHVAL=0:0 S FHVAL=$O(^GMRD(120.82,"B",FHX,FHVAL)) Q:FHVAL'>0 D - .I $D(^FH(115.2,FHFPIEN,"ALG","B",FHVAL)) Q ;pointer already exists - .S Y=FHVAL K DIC,DO S DA(1)=FHFPIEN,DIC="^FH(115.2,"_DA(1)_",""ALG""," - .S DIC(0)="L",DIC("P")=$P(^DD(115.2,25,0),U,2),X=+Y - .D FILE^DICN - Q -DISPMAP ; - W !!,"This option can be used to display the Standard GMR Allergy" - W !,"entries and the Food Preferences they map to.",!! K DIR - S DIR("A")="Display Map by Allergies or by Food Preferences (A/F): " - S DIR(0)="SA^A:Allergies;F:Food Preferences" D ^DIR - I $D(DIRUT) D EXIT Q - S FHSEL=Y - D DEV - Q -DEV ;get device and set up queue - W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP - I '$D(IO("Q")) U IO D LISTMAP,^%ZISC,EXIT Q - S ZTRTN="LISTMAP^FHSELA1",ZTSAVE("FHSEL")="" - S ZTDESC="GMR Allergy/Food Preference Map Display" D ^%ZTLOAD - D ^%ZISC K %ZIS,IOP - D EXIT - Q -LISTMAP ; List Map by Allergies or by Food Preferences - I FHSEL="A" D LISTAL Q - I FHSEL="F" D LISTFP Q - Q -LISTFP ; List all the Allergy-type Food Pref's and corresponding GMR Allergies - D ^FHSELA2 - S FHK="" W !!,"ALLERGY TYPE FOOD PREFERENCE MAP" - W !!,"NFS Food Preference Title",?40,"GMR Standard Allergy(s)" - W !,"===================================" - W ?40,"===================================" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) - .W !,"ALLERGY - ",FHZ1 - .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" W ?40,"** NONE **" Q - .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D - ..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 - D EXIT Q -LISTAL ; List all the GMR Allergies and the Food Pref to map to - D ^FHSELA2 - S FHK="" W !!,"GMR STANDARD FOOD ALLERGY MAP" - W !!,"GMR Allergy Name",?25,"Corresponding NFS Food Preference" - W !,"=======================",?25,"====================================" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) - .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q - .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D - ..S ^TMP($J,"FHAL",FHANAM)="ALLERGY - "_FHZ1 - S FHANAMZ="" - F S FHANAMZ=$O(^TMP($J,"FHAL",FHANAMZ)) Q:FHANAMZ="" D - .W !,FHANAMZ,?25,"...maps to: ",^TMP($J,"FHAL",FHANAMZ) - D EXIT Q -MISSING ; List all Food Pref's with no pointers to 120.82 - D ^FHSELA2 - S FHK="" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) - .I $P(FHFPS,";",2)'="" Q - .W !?5,"ALLERGY - ",FHZ1," does not have corresponding 120.82 entries" - D EXIT Q -CHECK ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 - D ^FHSELA2 - S FHK="",FLG=0 - W !,"The following Food Preferences titles were not found in file #115.2:" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) - .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) - .I '$D(^FH(115.2,"B",FHZ1)) W !,FHZ1 S FLG=1 - I FLG=0 W !,"ALL FOOD PREFERENCES HAVE BEEN RENAMED!" - D EXIT Q - ; -UPDATE ;Update Food Preferences for all Patient's based on Allergies - D ^FHSELA2 S FHCOUNT=0,FHQT=0 - W !!,"...Updating Patient Food Preferences based on Food-Type Allergies" - W "..." K FHMISS F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 D - .S FHCOUNT=FHCOUNT+1 I FHCOUNT#100=0 W "." - .D GETZN^FHOMUTL I FILE'="P" Q - .S DFN=IEN D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q - .F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP1^FHWGMR - I $G(FHPST8)=1 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT Q - D LIST - K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT,FHQT - Q -LIST ; - I '$D(^TMP($J,"FHMISS")) Q - W !!,"The following entries need to be mapped in order to automatically" - W !,"update the Patient Food Preferences:",! S FHCOUNT=0,FHQT=0 - S FHMSFP="" F S FHMSFP=$O(^TMP($J,"FHMISS",FHMSFP)) Q:FHMSFP=""!(FHQT=1) D - .W !,"'ALLERGY - ",FHMSFP,"'" S FHCOUNT=FHCOUNT+1 - .S FHMSPT="" F S FHMSPT=$O(^TMP($J,"FHMISS",FHMSFP,FHMSPT)) Q:FHMSPT="" D - ..S FHMSAL=$P($G(^TMP($J,"FHMISS",FHMSFP,FHMSPT)),U,1) - ..W !?3,"Patient: ",$E(FHMSPT,1,30),?43,"Allergy: ",FHMSAL - ..S FHCOUNT=FHCOUNT+1 - ..I FHCOUNT>14 S FHCOUNT=0 W ! K DIR S DIR(0)="E" D ^DIR W ! I X="^" S FHQT=1 - Q -EXIT ; - D MAP - K ^TMP($J,"FHALG"),^TMP($J,"FHAL") - K FHFPIEN,FHK,FHX,FHZ,FHFPS,FHZ1,FHVAL,N,FHANAM,FHANAMZ - K FHQUIT,NUM,FHRESP,FHAFPNM,FHSEL,PAD,FHLIST,FHALGMZ,FHALMP +FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 + ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 + ; +CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 + ; and allow user to create the FP on the fly + D ^FHSELA2 S NUM=0,FHQUIT=0 + W !!!,"The following Allergy Food Preference titles are not on file." + W !,"You may use this option to create these Food Preference entries:" + D CRLIST I NUM=0 W !,"No Food Preferences need to be mapped." D EXIT Q + I FHQUIT=1 D EXIT Q + I FHRESP=""!(FHRESP="M") D EXIT Q + S FHAFPNM=$P(FHLIST(FHRESP),"^",1) + W !,FHAFPNM," " + K DIR S DIR("A")="Add to Food Preference file",DIR(0)="Y" D ^DIR + I $D(DIRUT) D EXIT Q + I Y'=1 D CREATE Q + D ADD + W !!," ...done. ",FHAFPNM," Food Preference has been added!" H 1 + D CREATE Q + D EXIT Q +CRLIST ; + W !!?5,"MISSING FOOD PREFERENCE LIST" + W !?5,"============================" + S FHSEL=0,FHK="" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK=""!(FHQUIT=1)!(FHSEL=1) D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) + .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) + .I $D(^FH(115.2,"B",FHZ1)) Q + .S NUM=NUM+1,PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM + .W ?8,FHZ1 + .S FHLIST(NUM)=FHZ1_"^"_FHFPS + .I NUM#5=0!($O(^TMP($J,"FHALG",FHK))="") D PG Q + .Q + I FHQUIT=0,FHSEL=0,NUM#5'=0 D PG Q + Q +ADD ; + S FHALGMZ=1 + S X=FHAFPNM K DIC,DO + S (DIC,DIE)="^FH(115.2,",DIC(0)="L" D FILE^DICN + S (FHDA,DA)=+Y,DR=".01;26;1//DISLIKE;S:X=""D"" Y=0;3;20;S:'X Y=99;21;99" + D ^DIE K DA,DIE,DR + D TRAN^FHSEL1 + Q +PG ; + S FHRESP="" W ! K DIR + S DIR("A")="Select Food Preference or 'M' to see more ('^' to EXIT)" + S DIR(0)="F",DIR("B")="M" D ^DIR I $D(DIRUT) S FHQUIT=1 Q + S FHRESP=Y + I FHRESP?1"M" Q + I FHRESP?1.3N,FHRESP>0,FHRESP<(NUM+1) S FHSEL=1 Q + W !!,"Select from 1 to ",NUM D PG Q + Q +MAP ; Map allergies by setting pointers in 115.2 to correct entries in 120.82 + D ^FHSELA2 + S FHK="" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) + .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) + .I '$D(^FH(115.2,"B",FHZ1)) Q ;not set-up in 115.2, can't map + .S FHFPIEN=$O(^FH(115.2,"B",FHZ1,"")) + .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q ;no allergies to map + .S FHZ=0 F S FHZ=FHZ+1 S FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D + ..D LOOKUP + Q +LOOKUP ; Look-up the Allergy in 120.82 and set the pointer + S FHX=FHANAM + F FHVAL=0:0 S FHVAL=$O(^GMRD(120.82,"B",FHX,FHVAL)) Q:FHVAL'>0 D + .I $D(^FH(115.2,FHFPIEN,"ALG","B",FHVAL)) Q ;pointer already exists + .S Y=FHVAL K DIC,DO S DA(1)=FHFPIEN,DIC="^FH(115.2,"_DA(1)_",""ALG""," + .S DIC(0)="L",DIC("P")=$P(^DD(115.2,25,0),U,2),X=+Y + .D FILE^DICN + Q +DISPMAP ; + W !!,"This option can be used to display the Standard GMR Allergy" + W !,"entries and the Food Preferences they map to.",!! K DIR + S DIR("A")="Display Map by Allergies or by Food Preferences (A/F): " + S DIR(0)="SA^A:Allergies;F:Food Preferences" D ^DIR + I $D(DIRUT) D EXIT Q + S FHSEL=Y + D DEV + Q +DEV ;get device and set up queue + W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP + I '$D(IO("Q")) U IO D LISTMAP,^%ZISC,EXIT Q + S ZTRTN="LISTMAP^FHSELA1",ZTSAVE("FHSEL")="" + S ZTDESC="GMR Allergy/Food Preference Map Display" D ^%ZTLOAD + D ^%ZISC K %ZIS,IOP + D EXIT + Q +LISTMAP ; List Map by Allergies or by Food Preferences + I FHSEL="A" D LISTAL Q + I FHSEL="F" D LISTFP Q + Q +LISTFP ; List all the Allergy-type Food Pref's and corresponding GMR Allergies + D ^FHSELA2 + S FHK="" W !!,"ALLERGY TYPE FOOD PREFERENCE MAP" + W !!,"NFS Food Preference Title",?40,"GMR Standard Allergy(s)" + W !,"===================================" + W ?40,"===================================" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) + .W !,"ALLERGY - ",FHZ1 + .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" W ?40,"** NONE **" Q + .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D + ..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 + D EXIT Q +LISTAL ; List all the GMR Allergies and the Food Pref to map to + D ^FHSELA2 + S FHK="" W !!,"GMR STANDARD FOOD ALLERGY MAP" + W !!,"GMR Allergy Name",?25,"Corresponding NFS Food Preference" + W !,"=======================",?25,"====================================" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) + .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q + .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D + ..S ^TMP($J,"FHAL",FHANAM)="ALLERGY - "_FHZ1 + S FHANAMZ="" + F S FHANAMZ=$O(^TMP($J,"FHAL",FHANAMZ)) Q:FHANAMZ="" D + .W !,FHANAMZ,?25,"...maps to: ",^TMP($J,"FHAL",FHANAMZ) + D EXIT Q +MISSING ; List all Food Pref's with no pointers to 120.82 + D ^FHSELA2 + S FHK="" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) + .I $P(FHFPS,";",2)'="" Q + .W !?5,"ALLERGY - ",FHZ1," does not have corresponding 120.82 entries" + D EXIT Q +CHECK ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 + D ^FHSELA2 + S FHK="",FLG=0 + W !,"The following Food Preferences titles were not found in file #115.2:" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) + .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) + .I '$D(^FH(115.2,"B",FHZ1)) W !,FHZ1 S FLG=1 + I FLG=0 W !,"ALL FOOD PREFERENCES HAVE BEEN RENAMED!" + D EXIT Q + ; +UPDATE ;Update Food Preferences for all Patient's based on Allergies + D ^FHSELA2 S FHCOUNT=0,FHQT=0 + W !!,"...Updating Patient Food Preferences based on Food-Type Allergies" + W "..." K FHMISS F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 D + .S FHCOUNT=FHCOUNT+1 I FHCOUNT#100=0 W "." + .D GETZN^FHOMUTL I FILE'="P" Q + .S DFN=IEN D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q + .F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP1^FHWGMR + I $G(FHPST8)=1 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT Q + D LIST + K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT,FHQT + Q +LIST ; + I '$D(^TMP($J,"FHMISS")) Q + W !!,"The following entries need to be mapped in order to automatically" + W !,"update the Patient Food Preferences:",! S FHCOUNT=0,FHQT=0 + S FHMSFP="" F S FHMSFP=$O(^TMP($J,"FHMISS",FHMSFP)) Q:FHMSFP=""!(FHQT=1) D + .W !,"'ALLERGY - ",FHMSFP,"'" S FHCOUNT=FHCOUNT+1 + .S FHMSPT="" F S FHMSPT=$O(^TMP($J,"FHMISS",FHMSFP,FHMSPT)) Q:FHMSPT="" D + ..S FHMSAL=$P($G(^TMP($J,"FHMISS",FHMSFP,FHMSPT)),U,1) + ..W !?3,"Patient: ",$E(FHMSPT,1,30),?43,"Allergy: ",FHMSAL + ..S FHCOUNT=FHCOUNT+1 + ..I FHCOUNT>14 S FHCOUNT=0 W ! K DIR S DIR(0)="E" D ^DIR W ! I X="^" S FHQT=1 + Q +EXIT ; + D MAP + K ^TMP($J,"FHALG"),^TMP($J,"FHAL") + K FHFPIEN,FHK,FHX,FHZ,FHFPS,FHZ1,FHVAL,N,FHANAM,FHANAMZ + K FHQUIT,NUM,FHRESP,FHAFPNM,FHSEL,PAD,FHLIST,FHALGMZ,FHALMP Index: WorldVistAEHR/trunk/r/DIETETICS-FH/FHSELA2.m =================================================================== --- WorldVistAEHR/trunk/r/DIETETICS-FH/FHSELA2.m (revision 613) +++ WorldVistAEHR/trunk/r/DIETETICS-FH/FHSELA2.m (revision 623) @@ -1,309 +1,309 @@ -FHSELA2 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 - ;;5.5;DIETETICS;**8,13**;Jan 28, 2005;Build 1 - ; -TMPGL ; Create ^TMP Global - K ^TMP($J,"FHALG") S FHK=0 - F S FHK=FHK+1,FHFPS=$T(FPS+FHK),FHZ1=$P(FHFPS,";",3) Q:FHZ1="" D - .S ^TMP($J,"FHALG",FHZ1)=$P(FHFPS,";",3,99) -EXIT K FHK,FHFPS,FHZ1 - Q -FPS ;; - ;;ALCOHOL;ALCOHOL - ;;ALCOHOL, BEER;HOPS - ;;ALCOHOL, GIN;GIN - ;;ALCOHOL, RUM;RUM - ;;ALCOHOL, SCOTCH;SCOTCH - ;;ALCOHOL, TEQUILA;TEQUILA - ;;ALCOHOL, VODKA;VODKA - ;;ALCOHOL, WINE;WINE - ;;ALCOHOL, WINE, WHITE;WHITE WINE - ;;ALFALFA SPROUTS;ALFALFA SPROUTS - ;;ALMONDS;ALMONDS - ;;ANISE OIL;ANISE OIL - ;;APPLES;APPLE JUICE;APPLES - ;;APRICOTS;APRICOTS - ;;ARTICHOKES;ARTICHOKES - ;;ARTIFICIAL COLORS;ARTIFICIAL COLORS;BLACK DYES;BLUE DYES;FD&C BLUE DYE #2;FD&C GREEN DYE #6;GREEN DYES;PINK DYES;PURPLE DYES - ;;ASPARAGUS;ASPARAGUS - ;;AVOCADOS;AVOCADOS - ;;BACON;BACON - ;;BANANAS;BANANAS - ;;BARBEQUE SAUCE;BARBEQUE SAUCE - ;;BARLEY;BARLEY;MALT BARLEY - ;;BASIL;BASIL - ;;BEANS;BEANS;LEGUMES - ;;BEANS, BAKED;BAKED BEANS - ;;BEANS, FAVA;FAVA BEANS (BROAD BEANS) - ;;BEANS, GREEN;GREEN BEANS - ;;BEANS, LENTILS;LENTILS - ;;BEANS, LIMA;LIMA BEANS - ;;BEANS, PINTO;PINTO BEANS - ;;BEANS, SOY;SOYBEANS - ;;BEANS, STRING;STRING BEANS - ;;BEANS, WHITE;WHITE BEANS - ;;BEEF;BEEF;BEEF PRODUCTS - ;;BEEF, CORNED;CORNED BEEF - ;;BEETS;BEETS - ;;BEETS, PICKLES;PICKLED BEETS - ;;BERRIES;BERRIES - ;;BLACKBERRIES;BLACKBERRIES - ;;BLUEBERRIES;BLUEBERRIES - ;;BROCCOLI;BROCCOLI - ;;BRUSSELS SPROUTS;BRUSSELS SPROUTS - ;;BUCKWHEAT;BUCKWHEAT - ;;BUTTER;BUTTER - ;;CABBAGE;CABBAGE - ;;CAFFEINE;CAFFEINE;COFFEE;COFFEE BEANS - ;;CAFFEINE, COLAS;COLA DRINKS - ;;CANTALOUPE;CANTALOUPE - ;;CARBONATED BEVERAGES;CARBONATED BEVERAGES;SOFT DRINKS - ;;CARROTS;CARROTS - ;;CATSUP;CATSUP - ;;CAULIFLOWER;CAULIFLOWER - ;;CAVIAR;CAVIAR - ;;CELERY;CELERY - ;;CEREAL;CEREALS - ;;CEREAL, CORNFLAKES;CORNFLAKES - ;;CEREAL, CRM OF WHEAT;CREAM OF WHEAT - ;;CEREAL, GRITS;GRITS - ;;CEREAL, OATMEAL;OATMEAL - ;;CHEESE;CHEESE - ;;CHEESE, BLUE;BLUE CHEESE - ;;CHEESE, CHEDDAR;CHEDDAR CHEESE - ;;CHEESE, COTTAGE;COTTAGE CHEESE - ;;CHEESE, FETA;FETA CHEESE - ;;CHEESE, GOAT;GOAT CHEESE - ;;CHEESE, PARMESAN;PARMESAN CHEESE - ;;CHEESE, RICOTTA;RICOTTA CHEESE - ;;CHEESE, SWISS;SWISS CHEESE - ;;CHERRIES;CHERRIES;CHERRY JUICE - ;;CHICKEN;CHICKEN - ;;CHICKPEAS;CHICKPEAS - ;;CHICORY;CHICORY - ;;CHILI;CHILI - ;;CHIVES;CHIVES - ;;CHOCOLATE;CHOCOLATE;COCOA - ;;CILANTRO;CILANTRO;CUMIN - ;;CINNAMON;CINNAMON;CINNAMON OIL - ;;CITRUS;CITRUS;CITRUS FRUIT;CITRUS JUICE - ;;CLOVES;CLOVES - ;;COCONUT;COCONUTS - ;;COLA;COLA DRINKS - ;;CORN;CORN - ;;CRACKERS;CRACKERS - ;;CRACKERS, GRAHAM;GRAHAM CRACKERS - ;;CRANBERRIES;CRANBERRIES - ;;CREAM, SOUR;SOUR CREAM - ;;CREAMER, NON-DAIRY;NON-DAIRY CREAMER - ;;CREAMER, POWDER;POWDERED CREAMER - ;;CUCUMBERS;CUCUMBERS - ;;DAIRY PRODUCTS;DAIRY PRODUCTS - ;;DATES;DATES - ;;DILL;DILL - ;;DUCK;DUCK;WATERFOWL - ;;DYES, VEGETABLES;VEGETABLE DYES - ;;EGGNOG;EGGNOG - ;;EGGPLANT;EGGPLANT - ;;EGGS;EGGS;EGG PRODUCTS;EGG WHITES;EGG YOLKS - ;;EGGS, SUBSTITUTES;EGG, SUBSTITUTES - ;;FAT EMULSIONS;FAT EMULSIONS - ;;FIGS;FIGS - ;;FISH;FISH - ;;FISH, ABALONE;ABALONE - ;;FISH, ANCHOVIES;ANCHOVIES - ;;FISH, CATFISH;CATFISH - ;;FISH, COD;CODFISH - ;;FISH, FLOUNDER;FLOUNDER - ;;FISH, HERRING;HERRING - ;;FISH, MACKEREL;MACKEREL - ;;FISH, PERCH;PERCH - ;;FISH, RED SNAPPER;RED SNAPPER - ;;FISH, SALMON;SALMON - ;;FISH, SARDINES;SARDINES - ;;FISH, SHARK;SHARK - ;;FISH, SWORDFISH;SWORDFISH - ;;FISH, TROUT;TROUT - ;;FISH, TUNA;TUNA - ;;FISH, WHITE;WHITE FISH - ;;FLAVORING, HICKORY;HICKORY - ;;FLAVORING, LICORICE;LICORICE - ;;FLAVORING, VANILLA;VANILLA - ;;FOOD PRESERVATIVES;FOOD PRESERVATIVES - ;;FRUIT, FRESH;FRESH FRUIT - ;;FROG;FROG LEGS;FROGS - ;;FRUIT;FRUIT - ;;FRUIT JUICE;FRUIT JUICE - ;;FRUITCAKES;FRUITCAKES - ;;GARLIC;GARLIC - ;;GELATIN;GELATIN - ;;GINGER;GINGER - ;;GLUTEN;GLUTENS - ;;GRAINS;GRAINS - ;;GRAPEFRUIT;GRAPEFRUIT - ;;GRAPES;GRAPES - ;;GRAVY;GRAVY - ;;GREENS, COLLARD;COLLARD GREENS - ;;GREENS, MUSTARD;MUSTARD GREENS - ;;GREENS, TURNIP;TURNIP GREENS - ;;GREEN LEAFY VEG;GREEN LEAFY VEGETABLES - ;;GUAVA;GUAVA - ;;HOMINY;HOMINY - ;;HONEY;HONEY - ;;HONEYDEW;HONEYDEW - ;;HORSERADISH;HORSERADISH - ;;IODINE;IODIZED SALT - ;;JUICE;JUICE - ;;KIWI;KIWI FRUIT - ;;LACTOSE;LACTOSE - ;;LEEKS;LEEKS - ;;LEMON;LEMON JUICE;LEMONS - ;;LETTUCE;LETTUCE - ;;LIMES;LIMES - ;;LYCHEE NUTS;LYCHEES - ;;MALTOSE;MALTOSE - ;;MANGOS;MANGOS - ;;MARSHMALLOWS;MARSHMALLOWS - ;;MAYONNAISE;MAYONNAISE - ;;MEAT;MEAT - ;;MEAT, LAMB;LAMB - ;;MEAT, LIVER;LIVER - ;;MEAT, PROCESSED;PROCESSED MEATS - ;;MEAT, RED;RED MEAT - ;;MEAT, VENISON;VENISON - ;;MELONS;MELONS - ;;MELONS, MUSK;MUSK MELONS - ;;MELONS, WATER;WATERMELONS - ;;MILK;MILK;DAIRY PRODUCTS - ;;MILK, BUTTER;BUTTERMILK - ;;MILK, GOAT;GOAT MILK - ;;MILK, YOGURT;YOGURT - ;;MINT;MINT - ;;MODIFIED FOOD STARCH;MODIFIED FOOD STARCH;FOOD STARCH, MODIFIED - ;;MSG;MONOSODIUM GLUTAMATE - ;;MUSHROOMS;MUSHROOMS - ;;MUSTARD;MUSTARD - ;;MUTTON/LAMB;MUTTON - ;;NECTARINES;NECTARINES - ;;NITRITES;NITRITES - ;;NON-FOOD RELATED;EGGSHELLS - ;;NUTMEG;NUTMEG - ;;NUTS;BRAZIL NUTS;CASHEWS;CHESTNUTS;HAZELNUTS;MACADAMIA NUTS;NUTS;PECANS - ;;NUTS, PEANUT;PEANUT BUTTER;PEANUT OIL;PEANUTS - ;;NUTS, PINE;PINE NUTS - ;;NUTS, PISTACHIOS;PISTACHIOS - ;;NUTS, TREE;PECANS;TREE NUTS - ;;NUTS, WALNUT;WALNUTS - ;;OATS;OATS - ;;OIL, COCONUT;COCONUT OIL - ;;OIL, COTTONSEED;COTTONSEED OIL - ;;OIL, PALM;PALM OIL - ;;OIL, SAFFLOWER;SAFFLOWER OIL - ;;OIL, SOY;SOYBEAN OIL - ;;OIL, SUNFLOWER;SUNFLOWER OIL - ;;OKRA;OKRA - ;;OLIVES;BLACK OLIVES;OLIVES - ;;ONIONS;ONIONS - ;;ONIONS, RED;RED ONIONS - ;;ORANGE;ORANGE;ORANGES;ORANGE JUICE;ORANGE OIL - ;;OREGANO;OREGANO - ;;OYSTERS;OYSTERS - ;;PAPAYAS;PAPAYAS - ;;PAPRIKA;PAPRIKA - ;;PARSLEY;PARSLEY - ;;PARSNIP;PARSNIP - ;;PASSION FRUIT;PASSION FRUIT - ;;PEACHES;PEACHES - ;;PEARS;PEARS - ;;PEAS;PEAS - ;;PEAS, BLACK-EYED;BLACK-EYED PEAS - ;;PEAS, ENGLISH;ENGLISH PEAS - ;;PEAS, SNOW;SNOW PEAS - ;;PEPPER;PEPPER;WHITE PEPPER - ;;PEPPER, BLACK;BLACK PEPPER;PEPPER - ;;PEPPERMINT;PEPPERMINT - ;;PEPPERONI;PEPPERONI - ;;PEPPERS;BELL PEPPERS;PEPPERS - ;;PEPPERS, CHILI;CHILI PEPPER;CHILI PEPPERS - ;;PEPPERS, GREEN;GREEN BELL PEPPERS;PEPPERS - ;;PEPPERS, HOT;CAPSAICIN;CAYENNE PEPPER;HOT PEPPER;HOT PEPPERS;JALAPENO PEPPERS - ;;PEPPERS, RED;RED BELL PEPPERS - ;;PERSIMMONS;PERSIMMONS - ;;PHEASANT;PHEASANT - ;;PICKLES;PICKLES - ;;PIMENTOS;PIMENTOS - ;;PINEAPPLE;PINEAPPLES - ;;PIZZA;PIZZA - ;;PLUMS;PLUMS - ;;POPCORN;POPCORN - ;;POPPY SEEDS;POPPY SEEDS - ;;PORK;PORK;PORK PRODUCTS;HAM - ;;PORK, HAM;HAM - ;;POTATOES;POTATOES - ;;POTATOES, SALAD;POTATO SALAD - ;;POTATOES, SWEET/YAMS;SWEET POTATOES;YAMS - ;;POULTRY;FOWL;POULTRY - ;;PRUNES;PRUNES - ;;PUDDING, TAPIOCA;TAPIOCA PUDDING - ;;PUMPKIN;PUMPKINS - ;;RABBIT;RABBIT - ;;RADISH;RADISHES - ;;RAISINS;RAISINS - ;;RASPBERRIES;RASPBERRIES - ;;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 - ;;RHUBARB;RHUBARB - ;;RICE;RICE;WHITE RICE - ;;ROSEMARY;ROSEMARY - ;;RUTABAGAS;RUTABAGAS - ;;RYE;RYE - ;;SALAD DRESSING, ITAL;ITALIAN DRESSING - ;;SALT;NON-IODIZED SALT;SALT - ;;SALT, SUBSTITUTES;SALT SUBSTITUTES - ;;SAUERKRAUT;SAUERKRAUT - ;;SAUSAGES;SAUSAGES - ;;SEAFOOD;SEAFOOD - ;;SEEDS;SEEDS - ;;SEEDS, SUNFLOWER;SUNFLOWER SEEDS - ;;SESAME;SESAME;SESAME OIL;SESAME SEEDS - ;;SHELLFISH;CLAMS;CRAB;CRAWFISH;CRUSTACEANS;LOBSTER;MUSSELS;SCALLOPS;SHELL FISH;SHELLFISH - ;;SHERBET;SHERBET - ;;SHRIMP;SHRIMP - ;;SNAILS;SNAILS - ;;SOUR CREAM;SOUR CREAM - ;;SOY;SOY;SOY MILK;SOY PRODUCTS;SOY SAUCE;SOYBEANS;TOFU - ;;SOY SAUCE;SOY SAUCE - ;;SPAGHETTI;SPAGHETTI - ;;SPAM;SPAM - ;;SPICES;CONDIMENTS;SPICES - ;;SPINACH;SPINACH - ;;SQUASH;SQUASH - ;;SQUID;SQUID - ;;STARCHY FOODS;STARCHES - ;;STRAWBERRIES;STRAWBERRIES;STRAWBERRIES PLUS - ;;SUCRALOSE;SUCRALOSE - ;;SUGAR;SUGAR;SUGAR BEETS;WHITE SUGAR - ;;SUGAR SUB;ARTIFICIAL SWEETENERS - ;;SUGAR SUB, ASPARTAME;ASPARTAME - ;;SUGAR SUB, SACCHARIN;SACCHARIN;SWEET'N LOW - ;;SUGAR, BROWN;BROWN SUGAR - ;;SULFITES;SULFITES - ;;SYRUP, MAPLE;MAPLE SYRUP - ;;TANGERINES;TANGERINES - ;;TARRAGON;TARRAGON - ;;TEA;TEA - ;;TOFFEE;TOFFEE - ;;TOMATO;TOMATO;TOMATO JUICE;TOMATO PRODUCTS;TOMATO SAUCE;TOMATOES - ;;TOMATOES, FRESH;FRESH TOMATOES - ;;TUMERIC;TUMERIC - ;;TURKEY;TURKEY - ;;TURNIPS;TURNIPS - ;;VEAL;VEAL - ;;VEGETABLES;VEGETABLES - ;;VEGETABLES, GREEN;GREEN VEGETABLES - ;;VINEGAR;VINEGAR - ;;WATERFOWL;WATERFOWL - ;;WHEAT;FLOUR;WHEAT - ;;WHEY;WHEY - ;;WINE, RED;RED WINE - ;;YEAST;YEAST - ;;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 - ;;ZUCCHINI;ZUCCHINI +FHSELA2 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 + ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 + ; +TMPGL ; Create ^TMP Global + K ^TMP($J,"FHALG") S FHK=0 + F S FHK=FHK+1,FHFPS=$T(FPS+FHK),FHZ1=$P(FHFPS,";",3) Q:FHZ1="" D + .S ^TMP($J,"FHALG",FHZ1)=$P(FHFPS,";",3,99) +EXIT K FHK,FHFPS,FHZ1 + Q +FPS ;; + ;;ALCOHOL;ALCOHOL + ;;ALCOHOL, BEER;HOPS + ;;ALCOHOL, GIN;GIN + ;;ALCOHOL, RUM;RUM + ;;ALCOHOL, SCOTCH;SCOTCH + ;;ALCOHOL, TEQUILA;TEQUILA + ;;ALCOHOL, VODKA;VODKA + ;;ALCOHOL, WINE;WINE + ;;ALCOHOL, WINE, WHITE;WHITE WINE + ;;ALFALFA SPROUTS;ALFALFA SPROUTS + ;;ALMONDS;ALMONDS + ;;ANISE OIL;ANISE OIL + ;;APPLES;APPLE JUICE;APPLES + ;;APRICOTS;APRICOTS + ;;ARTICHOKES;ARTICHOKES + ;;ARTIFICIAL COLORS;ARTIFICIAL COLORS;BLACK DYES;BLUE DYES;FD&C BLUE DYE #2;FD&C GREEN DYE #6;GREEN DYES;PINK DYES;PURPLE DYES + ;;ASPARAGUS;ASPARAGUS + ;;AVOCADOS;AVOCADOS + ;;BACON;BACON + ;;BANANAS;BANANAS + ;;BARBEQUE SAUCE;BARBEQUE SAUCE + ;;BARLEY;BARLEY;MALT BARLEY + ;;BASIL;BASIL + ;;BEANS;BEANS;LEGUMES + ;;BEANS, BAKED;BAKED BEANS + ;;BEANS, FAVA;FAVA BEANS (BROAD BEANS) + ;;BEANS, GREEN;GREEN BEANS + ;;BEANS, LENTILS;LENTILS + ;;BEANS, LIMA;LIMA BEANS + ;;BEANS, PINTO;PINTO BEANS + ;;BEANS, SOY;SOYBEANS + ;;BEANS, STRING;STRING BEANS + ;;BEANS, WHITE;WHITE BEANS + ;;BEEF;BEEF;BEEF PRODUCTS + ;;BEEF, CORNED;CORNED BEEF + ;;BEETS;BEETS + ;;BEETS, PICKLES;PICKLED BEETS + ;;BERRIES;BERRIES + ;;BLACKBERRIES;BLACKBERRIES + ;;BLUEBERRIES;BLUEBERRIES + ;;BROCCOLI;BROCCOLI + ;;BRUSSELS SPROUTS;BRUSSELS SPROUTS + ;;BUCKWHEAT;BUCKWHEAT + ;;BUTTER;BUTTER + ;;CABBAGE;CABBAGE + ;;CAFFEINE;CAFFEINE;COFFEE;COFFEE BEANS + ;;CAFFEINE, COLAS;COLA DRINKS + ;;CANTALOUPE;CANTALOUPE + ;;CARBONATED BEVERAGES;CARBONATED BEVERAGES;SOFT DRINKS + ;;CARROTS;CARROTS + ;;CATSUP;CATSUP + ;;CAULIFLOWER;CAULIFLOWER + ;;CAVIAR;CAVIAR + ;;CELERY;CELERY + ;;CEREAL;CEREALS + ;;CEREAL, CORNFLAKES;CORNFLAKES + ;;CEREAL, CRM OF WHEAT;CREAM OF WHEAT + ;;CEREAL, GRITS;GRITS + ;;CEREAL, OATMEAL;OATMEAL + ;;CHEESE;CHEESE + ;;CHEESE, BLUE;BLUE CHEESE + ;;CHEESE, CHEDDAR;CHEDDAR CHEESE + ;;CHEESE, COTTAGE;COTTAGE CHEESE + ;;CHEESE, FETA;FETA CHEESE + ;;CHEESE, GOAT;GOAT CHEESE + ;;CHEESE, PARMESAN;PARMESAN CHEESE + ;;CHEESE, RICOTTA;RICOTTA CHEESE + ;;CHEESE, SWISS;SWISS CHEESE + ;;CHERRIES;CHERRIES;CHERRY JUICE + ;;CHICKEN;CHICKEN + ;;CHICKPEAS;CHICKPEAS + ;;CHICORY;CHICORY + ;;CHILI;CHILI + ;;CHIVES;CHIVES + ;;CHOCOLATE;CHOCOLATE;COCOA + ;;CILANTRO;CILANTRO;CUMIN + ;;CINNAMON;CINNAMON;CINNAMON OIL + ;;CITRUS;CITRUS;CITRUS FRUIT;CITRUS JUICE + ;;CLOVES;CLOVES + ;;COCONUT;COCONUTS + ;;COLA;COLA DRINKS + ;;CORN;CORN + ;;CRACKERS;CRACKERS + ;;CRACKERS, GRAHAM;GRAHAM CRACKERS + ;;CRANBERRIES;CRANBERRIES + ;;CREAM, SOUR;SOUR CREAM + ;;CREAMER, NON-DAIRY;NON-DAIRY CREAMER + ;;CREAMER, POWDER;POWDERED CREAMER + ;;CUCUMBERS;CUCUMBERS + ;;DAIRY PRODUCTS;DAIRY PRODUCTS + ;;DATES;DATES + ;;DILL;DILL + ;;DUCK;DUCK;WATERFOWL + ;;DYES, VEGETABLES;VEGETABLE DYES + ;;EGGNOG;EGGNOG + ;;EGGPLANT;EGGPLANT + ;;EGGS;EGGS;EGG PRODUCTS;EGG WHITES;EGG YOLKS + ;;EGGS, SUBSTITUTES;EGG, SUBSTITUTES + ;;FAT EMULSIONS;FAT EMULSIONS + ;;FIGS;FIGS + ;;FISH;FISH + ;;FISH, ABALONE;ABALONE + ;;FISH, ANCHOVIES;ANCHOVIES + ;;FISH, CATFISH;CATFISH + ;;FISH, COD;CODFISH + ;;FISH, FLOUNDER;FLOUNDER + ;;FISH, HERRING;HERRING + ;;FISH, MACKEREL;MACKEREL + ;;FISH, PERCH;PERCH + ;;FISH, RED SNAPPER;RED SNAPPER + ;;FISH, SALMON;SALMON + ;;FISH, SARDINES;SARDINES + ;;FISH, SHARK;SHARK + ;;FISH, SWORDFISH;SWORDFISH + ;;FISH, TROUT;TROUT + ;;FISH, TUNA;TUNA + ;;FISH, WHITE;WHITE FISH + ;;FLAVORING, HICKORY;HICKORY + ;;FLAVORING, LICORICE;LICORICE + ;;FLAVORING, VANILLA;VANILLA + ;;FOOD PRESERVATIVES;FOOD PRESERVATIVES + ;;FRUIT, FRESH;FRESH FRUIT + ;;FROG;FROG LEGS;FROGS + ;;FRUIT;FRUIT + ;;FRUIT JUICE;FRUIT JUICE + ;;FRUITCAKES;FRUITCAKES + ;;GARLIC;GARLIC + ;;GELATIN;GELATIN + ;;GINGER;GINGER + ;;GLUTEN;GLUTENS + ;;GRAINS;GRAINS + ;;GRAPEFRUIT;GRAPEFRUIT + ;;GRAPES;GRAPES + ;;GRAVY;GRAVY + ;;GREENS, COLLARD;COLLARD GREENS + ;;GREENS, MUSTARD;MUSTARD GREENS + ;;GREENS, TURNIP;TURNIP GREENS + ;;GREEN LEAFY VEGETABLES;GREEN LEAFY VEGETABLES + ;;GUAVA;GUAVA + ;;HOMINY;HOMINY + ;;HONEY;HONEY + ;;HONEYDEW;HONEYDEW + ;;HORSERADISH;HORSERADISH + ;;IODINE;IODIZED SALT + ;;JUICE;JUICE + ;;KIWI;KIWI FRUIT + ;;LACTOSE;LACTOSE + ;;LEEKS;LEEKS + ;;LEMON;LEMON JUICE;LEMONS + ;;LETTUCE;LETTUCE + ;;LIMES;LIMES + ;;LYCHEE NUTS;LYCHEES + ;;MALTOSE;MALTOSE + ;;MANGOS;MANGOS + ;;MARSHMALLOWS;MARSHMALLOWS + ;;MAYONNAISE;MAYONNAISE + ;;MEAT;MEAT + ;;MEAT, LAMB;LAMB + ;;MEAT, LIVER;LIVER + ;;MEAT, PROCESSED;PROCESSED MEATS + ;;MEAT, RED;RED MEAT + ;;MEAT, VENISON;VENISON + ;;MELONS;MELONS + ;;MELONS, MUSK;MUSK MELONS + ;;MELONS, WATER;WATERMELONS + ;;MILK;MILK;DAIRY PRODUCTS + ;;MILK, BUTTER;BUTTERMILK + ;;MILK, GOAT;GOAT MILK + ;;MILK, YOGURT;YOGURT + ;;MINT;MINT + ;;MODIFIED FOOD STARCH;MODIFIED FOOD STARCH;FOOD STARCH, MODIFIED + ;;MSG;MONOSODIUM GLUTAMATE + ;;MUSHROOMS;MUSHROOMS + ;;MUSTARD;MUSTARD + ;;MUTTON/LAMB;MUTTON + ;;NECTARINES;NECTARINES + ;;NITRITES;NITRITES + ;;NON-FOOD RELATED;EGGSHELLS + ;;NUTMEG;NUTMEG + ;;NUTS;BRAZIL NUTS;CASHEWS;CHESTNUTS;HAZELNUTS;MACADAMIA NUTS;NUTS;PECANS + ;;NUTS, PEANUT;PEANUT BUTTER;PEANUT OIL;PEANUTS + ;;NUTS, PINE;PINE NUTS + ;;NUTS, PISTACHIOS;PISTACHIOS + ;;NUTS, TREE;PECANS;TREE NUTS + ;;NUTS, WALNUT;WALNUTS + ;;OATS;OATS + ;;OIL, COCONUT;COCONUT OIL + ;;OIL, COTTONSEED;COTTONSEED OIL + ;;OIL, PALM;PALM OIL + ;;OIL, SAFFLOWER;SAFFLOWER OIL + ;;OIL, SOY;SOYBEAN OIL + ;;OIL, SUNFLOWER;SUNFLOWER OIL + ;;OKRA;OKRA + ;;OLIVES;BLACK OLIVES;OLIVES + ;;ONIONS;ONIONS + ;;ONIONS, RED;RED ONIONS + ;;ORANGE;ORANGE;ORANGES;ORANGE JUICE;ORANGE OIL + ;;OREGANO;OREGANO + ;;OYSTERS;OYSTERS + ;;PAPAYAS;PAPAYAS + ;;PAPRIKA;PAPRIKA + ;;PARSLEY;PARSLEY + ;;PARSNIP;PARSNIP + ;;PASSION FRUIT;PASSION FRUIT + ;;PEACHES;PEACHES + ;;PEARS;PEARS + ;;PEAS;PEAS + ;;PEAS, BLACK-EYED;BLACK-EYED PEAS + ;;PEAS, ENGLISH;ENGLISH PEAS + ;;PEAS, SNOW;SNOW PEAS + ;;PEPPER;PEPPER;WHITE PEPPER + ;;PEPPER, BLACK;BLACK PEPPER;PEPPER + ;;PEPPERMINT;PEPPERMINT + ;;PEPPERONI;PEPPERONI + ;;PEPPERS;BELL PEPPERS;PEPPERS + ;;PEPPERS, CHILI;CHILI PEPPER;CHILI PEPPERS + ;;PEPPERS, GREEN;GREEN BELL PEPPERS;PEPPERS + ;;PEPPERS, HOT;CAPSAICIN;CAYENNE PEPPER;HOT PEPPER;HOT PEPPERS;JALAPENO PEPPERS + ;;PEPPERS, RED;RED BELL PEPPERS + ;;PERSIMMONS;PERSIMMONS + ;;PHEASANT;PHEASANT + ;;PICKLES;PICKLES + ;;PIMENTOS;PIMENTOS + ;;PINEAPPLE;PINEAPPLES + ;;PIZZA;PIZZA + ;;PLUMS;PLUMS + ;;POPCORN;POPCORN + ;;POPPY SEEDS;POPPY SEEDS + ;;PORK;PORK;PORK PRODUCTS;HAM + ;;PORK, HAM;HAM + ;;POTATOES;POTATOES + ;;POTATOES, SALAD;POTATO SALAD + ;;POTATOES, SWEET/YAMS;SWEET POTATOES;YAMS + ;;POULTRY;FOWL;POULTRY + ;;PRUNES;PRUNES + ;;PUDDING, TAPIOCA;TAPIOCA PUDDING + ;;PUMPKIN;PUMPKINS + ;;RABBIT;RABBIT + ;;RADISH;RADISHES + ;;RAISINS;RAISINS + ;;RASPBERRIES;RASPBERRIES + ;;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 + ;;RHUBARB;RHUBARB + ;;RICE;RICE;WHITE RICE + ;;ROSEMARY;ROSEMARY + ;;RUTABAGAS;RUTABAGAS + ;;RYE;RYE + ;;SALAD DRESSING, ITAL;ITALIAN DRESSING + ;;SALT;NON-IODIZED SALT;SALT + ;;SALT, SUBSTITUTES;SALT SUBSTITUTES + ;;SAUERKRAUT;SAUERKRAUT + ;;SAUSAGES;SAUSAGES + ;;SEAFOOD;SEAFOOD + ;;SEEDS;SEEDS + ;;SEEDS, SUNFLOWER;SUNFLOWER SEEDS + ;;SESAME;SESAME;SESAME OIL;SESAME SEEDS + ;;SHELLFISH;CLAMS;CRAB;CRAWFISH;CRUSTACEANS;LOBSTER;MUSSELS;SCALLOPS;SHELL FISH;SHELLFISH + ;;SHERBET;SHERBET + ;;SHRIMP;SHRIMP + ;;SNAILS;SNAILS + ;;SOUR CREAM;SOUR CREAM + ;;SOY;SOY;SOY MILK;SOY PRODUCTS;SOY SAUCE;SOYBEANS;TOFU + ;;SOY SAUCE;SOY SAUCE + ;;SPAGHETTI;SPAGHETTI + ;;SPAM;SPAM + ;;SPICES;CONDIMENTS;SPICES + ;;SPINACH;SPINACH + ;;SQUASH;SQUASH + ;;SQUID;SQUID + ;;STARCHY FOODS;STARCHES + ;;STRAWBERRIES;STRAWBERRIES;STRAWBERRIES PLUS + ;;SUCRALOSE;SUCRALOSE + ;;SUGAR;SUGAR;SUGAR BEETS;WHITE SUGAR + ;;SUGAR SUB;ARTIFICIAL SWEETENERS + ;;SUGAR SUB, ASPARTAME;ASPARTAME + ;;SUGAR SUB, SACCHARIN;SACCHARIN;SWEET'N LOW + ;;SUGAR, BROWN;BROWN SUGAR + ;;SULFITES;SULFITES + ;;SYRUP, MAPLE;MAPLE SYRUP + ;;TANGERINES;TANGERINES + ;;TARRAGON;TARRAGON + ;;TEA;TEA + ;;TOFFEE;TOFFEE + ;;TOMATO;TOMATO;TOMATO JUICE;TOMATO PRODUCTS;TOMATO SAUCE;TOMATOES + ;;TOMATOES, FRESH;FRESH TOMATOES + ;;TUMERIC;TUMERIC + ;;TURKEY;TURKEY + ;;TURNIPS;TURNIPS + ;;VEAL;VEAL + ;;VEGETABLES;VEGETABLES + ;;VEGETABLES, GREEN;GREEN VEGETABLES + ;;VINEGAR;VINEGAR + ;;WATERFOWL;WATERFOWL + ;;WHEAT;FLOUR;WHEAT + ;;WHEY;WHEY + ;;WINE, RED;RED WINE + ;;YEAST;YEAST + ;;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 + ;;ZUCCHINI;ZUCCHINI