FHASM7 ; HISC/REL - KCAL Distribution ;8/18/93 11:05
;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1
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 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASM7 8660 printed Apr 09, 2024@20:59:30 Page 2
FHASM7 ; HISC/REL - KCAL Distribution ;8/18/93 11:05
+1 ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1
+2 SET PRT=0
SET (ASN,NB)=""
E31 SET FH7FLG=1
DO ^FHASMR1
KILL FH7FLG
+1 READ !!,"Do you want to do a NITROGEN BALANCE? NO// ",X:DTIME
if '$TEST!(X["^")
GOTO KIL^FHASM1
if X=""
SET X="N"
DO TR^FHASM1
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7," Answer YES or NO"
GOTO E31
+2 IF $EXTRACT(X,1)="N"
if 'FHDFN
GOTO KIL
GOTO EDU
E32 READ !!,"Enter Protein Intake (gm/24hr): ",X1:DTIME
if X1=U
SET FHQUIT=1
if '$TEST!(X1["^")
GOTO KIL^FHASM1
if X1=""
GOTO E35
+1 IF X1'?.N.1".".N!(X1<0)!(X1>200)
WRITE !?5,"Enter 0-200 grams of protein intake"
GOTO E32
E33 READ !,"Enter Urinary Nitrogen Output (gm/24hr): ",X2:DTIME
if X2=U
SET FHQUIT=1
if '$TEST!(X2["^")
GOTO KIL^FHASM1
if X2=""
GOTO E35
+1 IF X2'?.N.1".".N!(X2<0)!(X2>30)
WRITE !?5,"Enter 0-30 gms of Urinary Nitrogen output (24 hr UUN)"
GOTO E33
E34 READ !,"Enter Insensible Nitrogen Output (gm/24hr): 4// ",X3:DTIME
if X3=""
SET X3=4
if X3=U
SET FHQUIT=1
if '$TEST!(X3["^")
GOTO KIL^FHASM1
+1 IF X3'?.N.1".".N!(X3<0)!(X3>10)
WRITE !?5,"Insensible Nitrogen output should be between 0-10 grams"
GOTO E34
+2 SET NB=X1/6.25-(X2+X3)
SET NB=$JUSTIFY(NB,0,0)
WRITE !,"Nitrogen Balance: ",NB
E35 if 'FHDFN
GOTO KIL
EDU ;
+1 WRITE !!,"Did you educate patient on Food/Drug Interactions (Y/N): "
if FHEDU'=""
WRITE FHEDU_"//"
if FHEDU=""
WRITE "N//"
READ X:DTIME
+2 if '$TEST!(X["^")
GOTO KIL^FHASM1
+3 IF X=""
IF FHEDU=""
SET X="N"
+4 IF X=""
IF FHEDU'=""
SET X=FHEDU
+5 DO TR^FH
+6 IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7,!,"Enter 'Y' for yes or 'N' for no."
GOTO EDU
+7 SET FHEDU=$EXTRACT(X,1)
EDC ;food/drug comment.
+1 SET FHFDC=FHFDCSV
+2 WRITE !!,"Food/Drug Comment: ",FHFDCSV,"// "
READ FHFDC:DTIME
IF '$TEST!(FHFDC["^")
SET FHQUIT=1
GOTO KIL^FHASM1
+3 IF FHFDC="@"
SET FHFDCSV=""
WRITE " deleted..."
GOTO DPL
+4 IF (FHFDC="")
IF (FHFDCSV'="")
SET FHFDC=FHFDCSV
+5 IF FHFDC["?"!($LENGTH(FHFDC)>30)
WRITE *7,!,"Enter Food/Drug Comment or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!"
GOTO EDC
+6 SET FHFDCSV=FHFDC
+7 ;adding diagnosis, follow-up date
DPL ;get diagnosis from Problem List package.
+1 if DFN
DO LIST^GMPLUTL2(.FHPLIST,DFN,"A","")
+2 SET FHDIACT=0
+3 IF $DATA(FHPLIST(0))
SET FHDIACT=FHPLIST(0)
DP1 IF FHDIACT
Begin DoDot:1
+1 SET FHDCH=""
+2 WRITE !!,"Patient's Diagnosis from Problem List:",!
+3 FOR FHDLI=0:0
SET FHDLI=$ORDER(FHPLIST(FHDLI))
if 'FHDLI
QUIT
Begin DoDot:2
+4 SET DTP=$PIECE(FHPLIST(FHDLI),U,6)
DO DTP^FH
+5 WRITE !,?6,FHDLI_" ",$PIECE(FHPLIST(FHDLI),U,3)," - Date entered: ",DTP
End DoDot:2
End DoDot:1
+6 if 'FHDIACT
GOTO ANF
+7 WRITE !!,"Diagnosis: "
if FHDIPL'=""
WRITE FHDIPL
WRITE "// "
READ FHDCH:DTIME
if FHDCH=U
SET FHQUIT=1
if '$TEST!(FHDCH["^")
GOTO KIL^FHASM1
+8 if FHDCH=""
GOTO ANF
+9 IF FHDCH="@"
SET (FHDIPL,FHDIPLD)=""
GOTO ANF
+10 IF '$DATA(FHPLIST(FHDCH))
WRITE !!,*7,"Choose a number from the list or Hit Return to accept default!!",!
GOTO DP1
+11 SET FHDIPL=$PIECE(FHPLIST(FHDCH),U,3)
SET FHDIPLD=$PIECE(FHPLIST(FHDCH),U,6)
ANF ;problem through NFS.
+1 SET AFDIA=FHDINA
+2 WRITE !!,"Problem: ",FHDINA,"// "
READ AFDIA:DTIME
IF '$TEST!(AFDIA["^")
SET FHQUIT=1
GOTO KIL^FHASM1
+3 IF AFDIA="@"
SET FHDINA=""
WRITE " deleted..."
GOTO DNF
+4 IF (AFDIA="")
IF (FHDINA'="")
SET AFDIA=FHDINA
+5 IF AFDIA["?"!($LENGTH(AFDIA)>30)
WRITE *7,!,"Enter patient's Problem or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!"
GOTO ANF
+6 SET FHDINA=AFDIA
+7 ;
DNF ;aditional problem through NFS.
+1 SET NFDIA=FHDINF
+2 WRITE !!,"Additional Problem: ",FHDINF,"// "
READ NFDIA:DTIME
IF '$TEST!(NFDIA["^")
SET FHQUIT=1
GOTO KIL^FHASM1
+3 IF NFDIA="@"
SET FHDINF=""
WRITE " deleted..."
GOTO E4
+4 IF (NFDIA="")
IF (FHDINF'="")
SET NFDIA=FHDINF
+5 IF NFDIA["?"!($LENGTH(NFDIA)>30)
WRITE *7,!,"Enter Additional Problem of a patient or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!"
GOTO DNF
+6 SET FHDINF=NFDIA
+7 ;
E4 ;
+1 SET APP=FHAPP
+2 WRITE !!,"Appearance: ",FHAPP,"// "
READ APP:DTIME
IF '$TEST!(APP["^")
SET FHQUIT=1
GOTO KIL^FHASM1
+3 IF APP="@"
SET FHAPP=""
WRITE " deleted..."
GOTO EC1
+4 IF (APP="")
IF (FHAPP'="")
SET APP=FHAPP
+5 IF APP["?"!(APP'?.ANP)!($LENGTH(APP)>60)
WRITE *7,!,"Enter Physical Appearance of patient or Hit Return to Accept or @ to Delete and cannot exceed 60 characters."
GOTO E4
+6 SET FHAPP=APP
EC1 WRITE !
SET DIC="^FH(115.3,"
SET DIC(0)="AEQMZ"
SET DIC("B")=XD
DO ^DIC
KILL DIC
if X["^"!$DATA(DTOUT)
GOTO KIL^FHASM1
SET XD=$SELECT(Y>0:+Y,1:"")
E5 WRITE !
SET DIC="^FH(115.4,"
SET DIC(0)="AEQMZ"
SET DIC("B")=RC
SET DIC("S")="I $P(^(0),U,2)'="""""
DO ^DIC
KILL DIC
if X["^"!$DATA(DTOUT)
GOTO KIL^FHASM1
SET RC=$SELECT(Y>0:+Y,1:"")
+1 WRITE !!,"Comments:"
KILL ^TMP("FH",$JOB)
SET DIC="^TMP(""FH"",$J,"
SET DWPK=1
+2 IF FHASK="E"
IF $DATA(^FHPT(FHDFN,"N",FHCAS,"X"))
MERGE ^TMP("FH",$JOB)=^FHPT(FHDFN,"N",FHCAS,"X")
DO EN^DIWE
GOTO FDT
+3 DO EN^DIWE
FDT ;enter follow-up date.
+1 SET (FHDD,DTP)=""
+2 IF $GET(RC)
Begin DoDot:1
+3 SET X=$PIECE($GET(^FH(115.4,RC,0)),U,2)
DO TR^FH
+4 IF X["NORMAL"
Begin DoDot:2
+5 if FHLOC
SET FHDD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,20)
+6 if FHDD
SET DTP="T+"_FHDD
+7 if 'FHDD
SET DTP="T+11"
End DoDot:2
+8 IF X["MILD"
Begin DoDot:2
+9 if FHLOC
SET FHDD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,21)
+10 if FHDD
SET DTP="T+"_FHDD
+11 if 'FHDD
SET DTP="T+9"
End DoDot:2
+12 IF X["MODERATE"
Begin DoDot:2
+13 if FHLOC
SET FHDD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,22)
+14 if FHDD
SET DTP="T+"_FHDD
+15 if 'FHDD
SET DTP="T+7"
End DoDot:2
+16 IF X["SEVERE"
Begin DoDot:2
+17 if FHLOC
SET FHDD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,23)
+18 if FHDD
SET DTP="T+"_FHDD
+19 if 'FHDD
SET DTP="T+5"
End DoDot:2
End DoDot:1
+20 KILL %DT
SET %DT="AEF"
SET %DT("A")="Enter Follow-up Assessment Date: "
+21 IF FHFUD'=""
IF FHFUD>DT
SET DTP=$EXTRACT(FHFUD,4,5)_"/"_$EXTRACT(FHFUD,6,7)_"/"_$EXTRACT(FHFUD,2,3)
+22 if DTP'=""
SET %DT("B")=DTP
if DTP=""
SET %DT("B")="TODAY"
+23 SET %DT(0)=DT
+24 WRITE !
DO ^%DT
KILL %DT
if X["^"!$DATA(DTOUT)
GOTO KIL^FHASM1
if Y<1
GOTO FDT
+25 SET FHFUD=Y
SDAT ;create or update nutrition assessment and file to Progress Notes.
+1 if '$DATA(FHASK)
GOTO KILL^XUSCLEAN
+2 IF '$DATA(^FHPT(FHDFN,0))
SET ^(0)=FHDFN
+3 IF '$DATA(^FHPT(FHDFN,"N",0))
SET ^FHPT(FHDFN,"N",0)="^115.011D^^"
+4 KILL DIC,DD,DO
SET DIC="^FHPT(FHDFN,""N"","
SET DIC(0)="L"
SET DLAYGO=115
SET DA(1)=FHDFN
+5 ;re-calculate calorie, protien and fluid requirement.
IF FHASK="E"
SET ASN=FHCAS
DO REC^FHASM3
+6 ;if not an update, create.
IF FHASK="C"
SET X=ADT
SET DINUM=9999999-ADT
DO FILE^DICN
SET ASN=+Y
+7 DO NOW^%DTC
SET NOW=%
+8 SET A2=HGT*.0254
SET BMI=+$JUSTIFY(WGT/2.2/(A2*A2),0,1)
+9 SET Y=ADT_"^"_SEX_"^"_AGE_"^"_HGT_"^"_HGP_"^"_WGT_"^"_WGP_"^"_DWGT_"^"_UWGT_"^"_IBW_"^"_FRM_"^"_AMP_"^^^^"_KCAL_"^"_PRO_"^"_FLD_"^"_RC_"^"_XD_"^"_BMI_"^"_BMIP_"^"_DUZ_"^"_NOW_"^"_NB
+10 SET ^FHPT(FHDFN,"N",ASN,0)=Y
+11 if 'FHFUD
SET FHFUD=DT
+12 SET 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
+13 SET ^FHPT(FHDFN,"N",ASN,1)=FHASN1
+14 SET ^FHPT(FHDFN,"N",ASN,2)=FHAPP
+15 SET ^FHPT(FHDFN,"N",ASN,3)=FHYN_U_FHFEC_U_FHFPC_U_FHDINA_U_FHEDU_U_FHFDCSV_U_FHPL_U_FHSPC
+16 SET ^FHPT(FHDFN,"N",ASN,"DI")=FHDIPL_U_FHDIPLD_U_FHDINF_U_FHDINFD_U_FHFUD_U_FHDIST_U_FHDIDI_U_FHDITFDT
+17 SET $PIECE(^FHPT(FHDFN,"N",ASN,"DI"),U,10)=FHDITFML
+18 SET $PIECE(^FHPT(FHDFN,"N",ASN,"DI"),U,11)=FHDITFKC
+19 SET $PIECE(^FHPT(FHDFN,"N",ASN,4),U,1)=FHDITFCM
+20 IF $DATA(FHDITFPR)
IF '$DATA(^FHPT(FHDFN,"N",ASN,"TF"))
FOR FHTUN=0:0
SET FHTUN=$ORDER(FHDITFPR(FHTUN))
if FHTUN'>0
QUIT
Begin DoDot:1
+21 SET Y=FHTUN
KILL DIC,DO
SET DA(2)=FHDFN
SET DA(1)=ASN
+22 SET DIC="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF"","
+23 SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(115.011,67.1,0),U,2)
SET X=+Y
+24 DO FILE^DICN
IF Y=-1
QUIT
+25 KILL DIE
SET DA(2)=FHDFN
SET DA(1)=ASN
SET DA=+Y
+26 SET FH1=$PIECE(FHDITFPR(FHTUN),U,2)
SET FH2=$PIECE(FHDITFPR(FHTUN),U,3)
+27 SET DIE="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF"","
+28 SET DR="1////^S X=FH1;2////^S X=FH2"
DO ^DIE
End DoDot:1
+29 IF FHFUDS
IF (FHFUDS'=FHFUD)
KILL ^FHPT("E",FHFUDS,FHDFN,ASN)
+30 IF FHFUD
SET DA(1)=FHDFN
SET DA=ASN
SET DIK="^FHPT(DA(1)"_",""N"","
SET DIK(1)="64^E"
DO IX^DIK
+31 if '$DATA(LRTST)
GOTO E7
+32 SET N1=0
FOR K=0:0
SET K=$ORDER(LRTST(K))
if K=""
QUIT
SET ^FHPT(FHDFN,"N",ASN,"L",K,0)=LRTST(K)
SET N1=N1+1
+33 IF N1
IF '$DATA(^FHPT(FHDFN,"N",ASN,"L",0))
SET ^(0)="^115.021^^"
E7 if '$DATA(^TMP("FH",$JOB))
GOTO E8
+1 SET ^FHPT(FHDFN,"N",ASN,"X",0)=^TMP("FH",$JOB,0)
+2 SET N1=0
FOR K=0:0
SET K=$ORDER(^TMP("FH",$JOB,K))
if K'>0
QUIT
SET N1=N1+1
SET ^FHPT(FHDFN,"N",ASN,"X",N1,0)=^TMP("FH",$JOB,K,0)
E8 SET DTE=ADT
SET S1=1
SET S2="I"
SET S3=$SELECT('RC:"",1:"Nutrition Status: "_$PIECE(^FH(115.4,RC,0),"^",2))
+1 IF $GET(DFN)
DO FIL^FHASE3
IF 'RC
GOTO E9
+2 IF '$DATA(^FHPT(FHDFN,"S",0))
SET ^(0)="^115.012D^^"
+3 KILL DIC,DD,DO
SET DIC="^FHPT(FHDFN,""S"","
SET DIC(0)="L"
SET DLAYGO=115
SET DA(1)=FHDFN
SET X=ADT
SET DINUM=9999999-ADT
DO FILE^DICN
SET ASE=+Y
+4 IF $GET(DFN)
DO DID^FHDPA
SET $PIECE(^FHPT(FHDFN,"S",ASE,0),"^",2,3)=RC_"^"_DUZ
if FHWRD
SET $PIECE(^(0),"^",6)=FHWRD
E9 ;D P0^FHASMR
E6 READ !!,"Save as Work in Progress or Complete or Delete this assessment: W// ",X:DTIME
if '$TEST!(X["^")
GOTO KILL^XUSCLEAN
+1 if X=""
SET X="W"
DO TR^FHASM1
+2 IF ($EXTRACT(X)'="W")
IF ($EXTRACT(X)'="C")
IF ($EXTRACT(X)'="D")
WRITE *7,!," Answer 'W' to file as Work in progress or 'C' to Complete and send to TIU or 'D' to Delete"
GOTO E6
+3 IF $EXTRACT(X)="D"
SET DA(1)=FHDFN
SET DIK="^FHPT(FHDFN,""N"","
SET DA=ASN
DO ^DIK
WRITE !!,"Deleted...",!
GOTO KILL^XUSCLEAN
+4 IF $EXTRACT(X)="W"
SET $PIECE(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W"
WRITE !!,"This Assessment has been saved as Work in Progress...",!
+5 IF $EXTRACT(X)="C"
Begin DoDot:1
+6 ;send assessment to TIU if pt has entry in #2 and is inpatient.
+7 IF $GET(DFN)
SET WARD=$GET(^DPT(DFN,.1))
IF WARD'=""
DO ^FHASMR2
KILL ^TMP($JOB)
IF $GET(FHOUT)
Begin DoDot:2
+8 WRITE !!,"TIU Progress Note was NOT created!!"
+9 SET $PIECE(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W"
End DoDot:2
QUIT
+10 SET $PIECE(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="C"
+11 WRITE !!,"Assessment is completed"
IF $GET(DFN)
IF WARD'=""
WRITE " and forwarded to TIU"
WRITE "...",!
End DoDot:1
KIL GOTO KILL^XUSCLEAN
