Changeset 623 for WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM7.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM7.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM7.m
r613 r623 1 FHASM7 2 ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1 3 4 E31 5 6 7 E32 8 9 E33 10 11 E34 12 13 14 E35 15 EDU 16 17 18 19 20 21 22 23 EDC 24 25 26 27 28 29 30 31 DPL 32 33 34 35 DP1 36 37 38 39 40 41 42 43 44 45 46 47 ANF 48 49 50 51 52 53 54 55 DNF 56 57 58 59 60 61 62 63 E4 64 65 66 67 68 69 70 EC1 71 E5 72 73 74 75 FDT 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 SDAT 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 E7 136 137 138 E8 139 140 141 142 143 E9 144 E6 145 146 147 148 149 150 .;send assessment to TIU if pt has entry in #2 and is inpatient.151 .I $G(DFN) S WARD=$G(^DPT(DFN,.1)) I WARD'=""D ^FHASMR2 K ^TMP($J) I $G(FHOUT) D Q152 153 154 155 .W !!,"Assessment is completed" I $G(DFN),WARD'="" W" and forwarded to TIU" W "...",!156 KIL 1 FHASM7 ; HISC/REL - KCAL Distribution ;8/18/93 11:05 2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 3 S PRT=0,(ASN,NB)="" 4 E31 S FH7FLG=1 D ^FHASMR1 K FH7FLG 5 R !!,"Do you want to do a NITROGEN BALANCE? NO// ",X:DTIME G:'$T!(X["^") KIL^FHASM1 S:X="" X="N" D TR^FHASM1 I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G E31 6 I $E(X,1)="N" G KIL:'FHDFN,EDU 7 E32 R !!,"Enter Protein Intake (gm/24hr): ",X1:DTIME S:X1=U FHQUIT=1 G KIL^FHASM1:'$T!(X1["^"),E35:X1="" 8 I X1'?.N.1".".N!(X1<0)!(X1>200) W !?5,"Enter 0-200 grams of protein intake" G E32 9 E33 R !,"Enter Urinary Nitrogen Output (gm/24hr): ",X2:DTIME S:X2=U FHQUIT=1 G KIL^FHASM1:'$T!(X2["^"),E35:X2="" 10 I X2'?.N.1".".N!(X2<0)!(X2>30) W !?5,"Enter 0-30 gms of Urinary Nitrogen output (24 hr UUN)" G E33 11 E34 R !,"Enter Insensible Nitrogen Output (gm/24hr): 4// ",X3:DTIME S:X3="" X3=4 S:X3=U FHQUIT=1 G:'$T!(X3["^") KIL^FHASM1 12 I X3'?.N.1".".N!(X3<0)!(X3>10) W !?5,"Insensible Nitrogen output should be between 0-10 grams" G E34 13 S NB=X1/6.25-(X2+X3),NB=$J(NB,0,0) W !,"Nitrogen Balance: ",NB 14 E35 G:'FHDFN KIL 15 EDU ; 16 W !!,"Did you educate patient on Food/Drug Interactions (Y/N): " W:FHEDU'="" FHEDU_"//" W:FHEDU="" "N//" R X:DTIME 17 G KIL^FHASM1:'$T!(X["^") 18 I X="",FHEDU="" S X="N" 19 I X="",FHEDU'="" S X=FHEDU 20 D TR^FH 21 I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!,"Enter 'Y' for yes or 'N' for no." G EDU 22 S FHEDU=$E(X,1) 23 EDC ;food/drug comment. 24 S FHFDC=FHFDCSV 25 W !!,"Food/Drug Comment: ",FHFDCSV,"// " R FHFDC:DTIME I '$T!(FHFDC["^") S FHQUIT=1 G KIL^FHASM1 26 I FHFDC="@" S FHFDCSV="" W " deleted..." G DPL 27 I (FHFDC=""),(FHFDCSV'="") S FHFDC=FHFDCSV 28 I FHFDC["?"!($L(FHFDC)>30) W *7,!,"Enter Food/Drug Comment or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G EDC 29 S FHFDCSV=FHFDC 30 ;adding diagnosis, follow-up date 31 DPL ;get diagnosis from Problem List package. 32 D:DFN LIST^GMPLUTL2(.FHPLIST,DFN,"A","") 33 S FHDIACT=0 34 I $D(FHPLIST(0)) S FHDIACT=FHPLIST(0) 35 DP1 I FHDIACT D 36 .S FHDCH="" 37 .W !!,"Patient's Diagnosis from Problem List:",! 38 .F FHDLI=0:0 S FHDLI=$O(FHPLIST(FHDLI)) Q:'FHDLI D 39 ..S DTP=$P(FHPLIST(FHDLI),U,6) D DTP^FH 40 ..W !,?6,FHDLI_" ",$P(FHPLIST(FHDLI),U,3)," - Date entered: ",DTP 41 G:'FHDIACT ANF 42 W !!,"Diagnosis: " W:FHDIPL'="" FHDIPL W "// " R FHDCH:DTIME S:FHDCH=U FHQUIT=1 G:'$T!(FHDCH["^") KIL^FHASM1 43 G:FHDCH="" ANF 44 I FHDCH="@" S (FHDIPL,FHDIPLD)="" G ANF 45 I '$D(FHPLIST(FHDCH)) W !!,*7,"Choose a number from the list or Hit Return to accept default!!",! G DP1 46 S FHDIPL=$P(FHPLIST(FHDCH),U,3),FHDIPLD=$P(FHPLIST(FHDCH),U,6) 47 ANF ;problem through NFS. 48 S AFDIA=FHDINA 49 W !!,"Problem: ",FHDINA,"// " R AFDIA:DTIME I '$T!(AFDIA["^") S FHQUIT=1 G KIL^FHASM1 50 I AFDIA="@" S FHDINA="" W " deleted..." G DNF 51 I (AFDIA=""),(FHDINA'="") S AFDIA=FHDINA 52 I AFDIA["?"!($L(AFDIA)>30) W *7,!,"Enter patient's Problem or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G ANF 53 S FHDINA=AFDIA 54 ; 55 DNF ;aditional problem through NFS. 56 S NFDIA=FHDINF 57 W !!,"Additional Problem: ",FHDINF,"// " R NFDIA:DTIME I '$T!(NFDIA["^") S FHQUIT=1 G KIL^FHASM1 58 I NFDIA="@" S FHDINF="" W " deleted..." G E4 59 I (NFDIA=""),(FHDINF'="") S NFDIA=FHDINF 60 I NFDIA["?"!($L(NFDIA)>30) W *7,!,"Enter Additional Problem of a patient or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G DNF 61 S FHDINF=NFDIA 62 ; 63 E4 ; 64 S APP=FHAPP 65 W !!,"Appearance: ",FHAPP,"// " R APP:DTIME I '$T!(APP["^") S FHQUIT=1 G KIL^FHASM1 66 I APP="@" S FHAPP="" W " deleted..." G EC1 67 I (APP=""),(FHAPP'="") S APP=FHAPP 68 I APP["?"!(APP'?.ANP)!($L(APP)>60) W *7,!,"Enter Physical Appearance of patient or Hit Return to Accept or @ to Delete and cannot exceed 60 characters." G E4 69 S FHAPP=APP 70 EC1 W ! S DIC="^FH(115.3,",DIC(0)="AEQMZ",DIC("B")=XD D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S XD=$S(Y>0:+Y,1:"") 71 E5 W ! S DIC="^FH(115.4,",DIC(0)="AEQMZ",DIC("B")=RC,DIC("S")="I $P(^(0),U,2)'=""""" D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S RC=$S(Y>0:+Y,1:"") 72 W !!,"Comments:" K ^TMP("FH",$J) S DIC="^TMP(""FH"",$J,",DWPK=1 73 I FHASK="E",$D(^FHPT(FHDFN,"N",FHCAS,"X")) M ^TMP("FH",$J)=^FHPT(FHDFN,"N",FHCAS,"X") D EN^DIWE G FDT 74 D EN^DIWE 75 FDT ;enter follow-up date. 76 S (FHDD,DTP)="" 77 I $G(RC) D 78 .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH 79 .I X["NORMAL" D 80 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20) 81 ..S:FHDD DTP="T+"_FHDD 82 ..S:'FHDD DTP="T+11" 83 .I X["MILD" D 84 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21) 85 ..S:FHDD DTP="T+"_FHDD 86 ..S:'FHDD DTP="T+9" 87 .I X["MODERATE" D 88 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22) 89 ..S:FHDD DTP="T+"_FHDD 90 ..S:'FHDD DTP="T+7" 91 .I X["SEVERE" D 92 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23) 93 ..S:FHDD DTP="T+"_FHDD 94 ..S:'FHDD DTP="T+5" 95 K %DT S %DT="AEF",%DT("A")="Enter Follow-up Assessment Date: " 96 I FHFUD'="",FHFUD>DT S DTP=$E(FHFUD,4,5)_"/"_$E(FHFUD,6,7)_"/"_$E(FHFUD,2,3) 97 S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" 98 S %DT(0)=DT 99 W ! D ^%DT K %DT G KIL^FHASM1:X["^"!$D(DTOUT),FDT:Y<1 100 S FHFUD=Y 101 SDAT ;create or update nutrition assessment and file to Progress Notes. 102 G:'$D(FHASK) KILL^XUSCLEAN 103 I '$D(^FHPT(FHDFN,0)) S ^(0)=FHDFN 104 I '$D(^FHPT(FHDFN,"N",0)) S ^FHPT(FHDFN,"N",0)="^115.011D^^" 105 K DIC,DD,DO S DIC="^FHPT(FHDFN,""N"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN 106 I FHASK="E" S ASN=FHCAS D REC^FHASM3 ;re-calculate calorie, protien and fluid requirement. 107 I FHASK="C" S X=ADT,DINUM=9999999-ADT D FILE^DICN S ASN=+Y ;if not an update, create. 108 D NOW^%DTC S NOW=% 109 S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) 110 S Y=ADT_"^"_SEX_"^"_AGE_"^"_HGT_"^"_HGP_"^"_WGT_"^"_WGP_"^"_DWGT_"^"_UWGT_"^"_IBW_"^"_FRM_"^"_AMP_"^^^^"_KCAL_"^"_PRO_"^"_FLD_"^"_RC_"^"_XD_"^"_BMI_"^"_BMIP_"^"_DUZ_"^"_NOW_"^"_NB 111 S ^FHPT(FHDFN,"N",ASN,0)=Y 112 S:'FHFUD FHFUD=DT 113 S FHASN1=TSF_U_TSFP_U_SCA_U_SCAP_U_ACIR_U_ACIRP_U_CCIR_U_CCIRP_U_BFAMA_U_BFAMAP_U_WCCM_U_CIBW_U_CERBO_U_CENB_U_PCTB_U_SEF_U_CFRB_U_CFRBO_U_CPRBO_U_EKKG 114 S ^FHPT(FHDFN,"N",ASN,1)=FHASN1 115 S ^FHPT(FHDFN,"N",ASN,2)=FHAPP 116 S ^FHPT(FHDFN,"N",ASN,3)=FHYN_U_FHFEC_U_FHFPC_U_FHDINA_U_FHEDU_U_FHFDCSV_U_FHPL_U_FHSPC 117 S ^FHPT(FHDFN,"N",ASN,"DI")=FHDIPL_U_FHDIPLD_U_FHDINF_U_FHDINFD_U_FHFUD_U_FHDIST_U_FHDIDI_U_FHDITFDT 118 S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,10)=FHDITFML 119 S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,11)=FHDITFKC 120 S $P(^FHPT(FHDFN,"N",ASN,4),U,1)=FHDITFCM 121 I $D(FHDITFPR),'$D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 D 122 .S Y=FHTUN K DIC,DO S DA(2)=FHDFN,DA(1)=ASN 123 .S DIC="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," 124 .S DIC(0)="L",DIC("P")=$P(^DD(115.011,67.1,0),U,2),X=+Y 125 .D FILE^DICN I Y=-1 Q 126 .K DIE S DA(2)=FHDFN,DA(1)=ASN,DA=+Y 127 .S FH1=$P(FHDITFPR(FHTUN),U,2),FH2=$P(FHDITFPR(FHTUN),U,3) 128 .S DIE="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," 129 .S DR="1////^S X=FH1;2////^S X=FH2" D ^DIE 130 I FHFUDS,(FHFUDS'=FHFUD) K ^FHPT("E",FHFUDS,FHDFN,ASN) 131 I FHFUD S DA(1)=FHDFN,DA=ASN,DIK="^FHPT(DA(1)"_",""N"",",DIK(1)="64^E" D IX^DIK 132 G:'$D(LRTST) E7 133 S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" S ^FHPT(FHDFN,"N",ASN,"L",K,0)=LRTST(K),N1=N1+1 134 I N1,'$D(^FHPT(FHDFN,"N",ASN,"L",0)) S ^(0)="^115.021^^" 135 E7 G:'$D(^TMP("FH",$J)) E8 136 S ^FHPT(FHDFN,"N",ASN,"X",0)=^TMP("FH",$J,0) 137 S N1=0 F K=0:0 S K=$O(^TMP("FH",$J,K)) Q:K'>0 S N1=N1+1,^FHPT(FHDFN,"N",ASN,"X",N1,0)=^TMP("FH",$J,K,0) 138 E8 S DTE=ADT,S1=1,S2="I",S3=$S('RC:"",1:"Nutrition Status: "_$P(^FH(115.4,RC,0),"^",2)) 139 I $G(DFN) D FIL^FHASE3 I 'RC G E9 140 I '$D(^FHPT(FHDFN,"S",0)) S ^(0)="^115.012D^^" 141 K DIC,DD,DO S DIC="^FHPT(FHDFN,""S"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN,X=ADT,DINUM=9999999-ADT D FILE^DICN S ASE=+Y 142 I $G(DFN) D DID^FHDPA S $P(^FHPT(FHDFN,"S",ASE,0),"^",2,3)=RC_"^"_DUZ S:FHWRD $P(^(0),"^",6)=FHWRD 143 E9 ;D P0^FHASMR 144 E6 R !!,"Save as Work in Progress or Complete or Delete this assessment: W// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN 145 S:X="" X="W" D TR^FHASM1 146 I ($E(X)'="W"),($E(X)'="C"),($E(X)'="D") W *7,!," Answer 'W' to file as Work in progress or 'C' to Complete and send to TIU or 'D' to Delete" G E6 147 I $E(X)="D" S DA(1)=FHDFN,DIK="^FHPT(FHDFN,""N"",",DA=ASN D ^DIK W !!,"Deleted...",! G KILL^XUSCLEAN 148 I $E(X)="W" S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" W !!,"This Assessment has been saved as Work in Progress...",! 149 I $E(X)="C" D 150 .;send assessment to TIU if pt has entry in #2. 151 .I $G(DFN) D ^FHASMR2 K ^TMP($J) I $G(FHOUT) D Q 152 ..W !!,"TIU Progress Note was NOT created!!" 153 ..S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" 154 .S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="C" 155 .W !!,"Assessment is completed" W:$G(DFN) " and forwarded to TIU" W "...",! 156 KIL G KILL^XUSCLEAN
Note:
See TracChangeset
for help on using the changeset viewer.
