FHMTK6 ; HISC/NCA/RTK/FAI - History of Diet Patterns ;10/20/04 07:12
;;5.5;DIETETICS;;Jan 28, 2005
S (ANS,O1,FHO1)="",FHALL=1 D ^FHOMDPA G:'FHDFN KIL
I $O(^FHPT(FHDFN,"A",0))<1 W !!,"NO ADMISSIONS ON FILE!" G FHMTK6
D ADM I ADM'="" S FHADM=ADM D CUR^FHORD7 G:FHLD'="" KIL S FHO1=FHORD,O1=Y,ANS=""
S DIC="^FHPT(FHDFN,""A"",",DIC(0)="Q",DA=FHDFN,X="??" D ^DIC
A0 W !!,"Select ADMISSION",$S($D(^DPT(DFN,.1)):" (or C for CURRENT)",1:""),": " R X:DTIME G:'$T!("^"[X) KIL D:X="c" TR^FH
I X="C" D ADM G P0:ADM'<1,FHMTK6
S DIC="^FHPT(FHDFN,""A"",",DIC(0)="EQM" D ^DIC G:Y<1 A0 S ADM=+Y
P0 W !!!,"Current Diet: ",$S(O1'="":O1,1:"No Current Diet") S FHORD=""
K S S (LST,N1)=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"DI",K)) Q:K<1 S X=$G(^(K,0)),X1=$G(^(2)),X2=$G(^(3)) I X1'="" S (FHORD,LST)=K D LIS
I 'N1 W !!,"No Diet Pattern for this Admission!" G FHMTK6
P1 R !!,"Detailed Display of which Pattern #? ",X:DTIME G:'$T!("^"[X) FHMTK6 I X'?1N.N!(X<1)!(X>N1) W *7," Enter Pattern # to List" G P1
I '$G(S(+X)) W !!,"No Pattern Saved for this Diet!" G FHMTK6
S FHORD=+S(+X) W ! S MP=0 D LIS^FHMTK4 G:ANS="^" FHMTK6
S PD=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),"^",13)
S CLERK=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,3)),"^",1)
W !!?25,"Pattern Entered By: ",$E($P($G(^VA(200,+CLERK,0)),"^",1),1,30),!
S Z=$O(^FHPT(FHDFN,"P",0)) I Z D PSE G:ANS="^" FHMTK6 D DISP^FHSEL1
I FHO1="" Q
S FHOR=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHO1,0)),"^",2,6)
R5 R !!,"Do You Want to Store this Pattern As the Patient's Individual Pattern? N// ",Y:DTIME G:'$T!(Y="^") FHMTK6 S:Y="" Y="N" S X=Y D TR^FH S Y=X
I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7,!," Answer YES to Store this Pattern as the patient's Diet Pattern; NO, not to store." G R5
G:Y'?1"Y".E FHMTK6 W !!,"Storing Patient's Diet Pattern ..."
G:STR="" FHMTK6
S:$E(STR,$L(STR))=";" STR=$E(STR,1,$L(STR)-1)
I $L(STR)>240 S LN=$L($E(STR,1,240)," "),STR=$P(STR," ",1,LN-1)
S ^FHPT(FHDFN,"A",FHADM,"DI",FHO1,2)=STR D NOW^%DTC S TIM=%
S:$G(^FHPT(FHDFN,"A",FHADM,"DI",FHO1,3))="" ^FHPT(FHDFN,"A",FHADM,"DI",FHO1,3)=DUZ_"^"_TIM
I PD S $P(^FHPT(FHDFN,"A",FHADM,"DI",FHO1,0),"^",13)=PD
G FHMTK6
ADM S WARD=$G(^DPT(DFN,.1))
I WARD="" W *7,!!,"NOT CURRENTLY AN INPATIENT!",! S ADM="" Q
S ADM=$G(^DPT("CN",WARD,DFN)) Q
LIS I 'N1 W !!,"Pat Date/Time Entered Diet Pattern",!
S D1=$P(X2,"^",2)
S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7),Y=""
I FHLD'="" Q
S N1=N1+1,S(N1)=FHORD
S DTP=D1 S:DTP="" DTP=$P(X,"^",9)
D:DTP'="" DTP^FH W !,$J(N1,3)," ",$S(DTP'="":DTP,1:"")
S Y="" F A1=1:1:5 S D3=$P(FHOR,"^",A1) I D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7)
W:Y'="" ?24,Y
Q
KIL K ^TMP($J) G KILL^XUSCLEAN
PSE I IOST?1"C-".E R !!,"Press RETURN to Continue ",X:DTIME W ! S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PSE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTK6 2841 printed Sep 23, 2025@19:24:14 Page 2
FHMTK6 ; HISC/NCA/RTK/FAI - History of Diet Patterns ;10/20/04 07:12
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 SET (ANS,O1,FHO1)=""
SET FHALL=1
DO ^FHOMDPA
if 'FHDFN
GOTO KIL
+3 IF $ORDER(^FHPT(FHDFN,"A",0))<1
WRITE !!,"NO ADMISSIONS ON FILE!"
GOTO FHMTK6
+4 DO ADM
IF ADM'=""
SET FHADM=ADM
DO CUR^FHORD7
if FHLD'=""
GOTO KIL
SET FHO1=FHORD
SET O1=Y
SET ANS=""
+5 SET DIC="^FHPT(FHDFN,""A"","
SET DIC(0)="Q"
SET DA=FHDFN
SET X="??"
DO ^DIC
A0 WRITE !!,"Select ADMISSION",$SELECT($DATA(^DPT(DFN,.1)):" (or C for CURRENT)",1:""),": "
READ X:DTIME
if '$TEST!("^"[X)
GOTO KIL
if X="c"
DO TR^FH
+1 IF X="C"
DO ADM
if ADM'<1
GOTO P0
GOTO FHMTK6
+2 SET DIC="^FHPT(FHDFN,""A"","
SET DIC(0)="EQM"
DO ^DIC
if Y<1
GOTO A0
SET ADM=+Y
P0 WRITE !!!,"Current Diet: ",$SELECT(O1'="":O1,1:"No Current Diet")
SET FHORD=""
+1 KILL S
SET (LST,N1)=0
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"DI",K))
if K<1
QUIT
SET X=$GET(^(K,0))
SET X1=$GET(^(2))
SET X2=$GET(^(3))
IF X1'=""
SET (FHORD,LST)=K
DO LIS
+2 IF 'N1
WRITE !!,"No Diet Pattern for this Admission!"
GOTO FHMTK6
P1 READ !!,"Detailed Display of which Pattern #? ",X:DTIME
if '$TEST!("^"[X)
GOTO FHMTK6
IF X'?1N.N!(X<1)!(X>N1)
WRITE *7," Enter Pattern # to List"
GOTO P1
+1 IF '$GET(S(+X))
WRITE !!,"No Pattern Saved for this Diet!"
GOTO FHMTK6
+2 SET FHORD=+S(+X)
WRITE !
SET MP=0
DO LIS^FHMTK4
if ANS="^"
GOTO FHMTK6
+3 SET PD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),"^",13)
+4 SET CLERK=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,3)),"^",1)
+5 WRITE !!?25,"Pattern Entered By: ",$EXTRACT($PIECE($GET(^VA(200,+CLERK,0)),"^",1),1,30),!
+6 SET Z=$ORDER(^FHPT(FHDFN,"P",0))
IF Z
DO PSE
if ANS="^"
GOTO FHMTK6
DO DISP^FHSEL1
+7 IF FHO1=""
QUIT
+8 SET FHOR=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",FHO1,0)),"^",2,6)
R5 READ !!,"Do You Want to Store this Pattern As the Patient's Individual Pattern? N// ",Y:DTIME
if '$TEST!(Y="^")
GOTO FHMTK6
if Y=""
SET Y="N"
SET X=Y
DO TR^FH
SET Y=X
+1 IF $PIECE("YES",Y,1)'=""
IF $PIECE("NO",Y,1)'=""
WRITE *7,!," Answer YES to Store this Pattern as the patient's Diet Pattern; NO, not to store."
GOTO R5
+2 if Y'?1"Y".E
GOTO FHMTK6
WRITE !!,"Storing Patient's Diet Pattern ..."
+3 if STR=""
GOTO FHMTK6
+4 if $EXTRACT(STR,$LENGTH(STR))=";"
SET STR=$EXTRACT(STR,1,$LENGTH(STR)-1)
+5 IF $LENGTH(STR)>240
SET LN=$LENGTH($EXTRACT(STR,1,240)," ")
SET STR=$PIECE(STR," ",1,LN-1)
+6 SET ^FHPT(FHDFN,"A",FHADM,"DI",FHO1,2)=STR
DO NOW^%DTC
SET TIM=%
+7 if $GET(^FHPT(FHDFN,"A",FHADM,"DI",FHO1,3))=""
SET ^FHPT(FHDFN,"A",FHADM,"DI",FHO1,3)=DUZ_"^"_TIM
+8 IF PD
SET $PIECE(^FHPT(FHDFN,"A",FHADM,"DI",FHO1,0),"^",13)=PD
+9 GOTO FHMTK6
ADM SET WARD=$GET(^DPT(DFN,.1))
+1 IF WARD=""
WRITE *7,!!,"NOT CURRENTLY AN INPATIENT!",!
SET ADM=""
QUIT
+2 SET ADM=$GET(^DPT("CN",WARD,DFN))
QUIT
LIS IF 'N1
WRITE !!,"Pat Date/Time Entered Diet Pattern",!
+1 SET D1=$PIECE(X2,"^",2)
+2 SET FHOR=$PIECE(X,"^",2,6)
SET FHLD=$PIECE(X,"^",7)
SET Y=""
+3 IF FHLD'=""
QUIT
+4 SET N1=N1+1
SET S(N1)=FHORD
+5 SET DTP=D1
if DTP=""
SET DTP=$PIECE(X,"^",9)
+6 if DTP'=""
DO DTP^FH
WRITE !,$JUSTIFY(N1,3)," ",$SELECT(DTP'="":DTP,1:"")
+7 SET Y=""
FOR A1=1:1:5
SET D3=$PIECE(FHOR,"^",A1)
IF D3
if Y'=""
SET Y=Y_", "
SET Y=Y_$PIECE(^FH(111,D3,0),"^",7)
+8 if Y'=""
WRITE ?24,Y
+9 QUIT
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
PSE IF IOST?1"C-".E
READ !!,"Press RETURN to Continue ",X:DTIME
WRITE !
if '$TEST!(X["^")
SET ANS="^"
if ANS="^"
QUIT
IF "^"'[X
WRITE !,"Enter a RETURN to Continue."
GOTO PSE
+1 QUIT
