FHASM7.m

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

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"","