FHDMP ; HISC/REL/NCA/JH/RK/FAI - Patient Data Log ;10/19/04 13:26
;;5.5;DIETETICS;**1,2**;Jan 28, 2005
BEGIN S ADM="",FHALL=1 D ^FHOMDPA
G:'FHDFN CLEAN
I $O(^FHPT(FHDFN,"A",0))<1 W !!,"NO ADMISSIONS ON FILE!" G OMDATE
S DIC="^FHPT(FHDFN,""A"",",DIC(0)="Q",DA=FHDFN,X="??" D ^DIC
S WARD="" I $G(DFN)'="" S WARD=$G(^DPT(DFN,.1))
K ADM
A0 W !!,"Select ADMISSION or RETURN for OUTPATIENT ",$S(WARD'="":" (or C for CURRENT)",1:""),": " R X:DTIME G:X["^" KIL D:X="c" TR^FH
I (X="")&'($D(^FHPT(FHDFN,"OP"))!$D(^FHPT(FHDFN,"GM"))!$D(^FHPT(FHDFN,"SM"))) W !!,"NO OUTPATIENT DATA ON FILE!" G FHDMP
I (X="")&($D(^FHPT(FHDFN,"OP"))!$D(^FHPT(FHDFN,"GM"))!$D(^FHPT(FHDFN,"SM"))) G OMDATE
I WARD'="",X="C" S ADM=$G(^DPT("CN",WARD,DFN)) G CAD:ADM
S DIC="^FHPT(FHDFN,""A"",",DIC(0)="EQM" D ^DIC G:Y<1 A0 S ADM=+Y
CAD I ADM,$G(^FHPT(FHDFN,"A",ADM,0)) S (SDT,STDT)=$P(^FHPT(FHDFN,"A",ADM,0),U,1),ENDT=DT G P0:SDT
;
OMDATE I '($D(^FHPT(FHDFN,"OP"))!$D(^FHPT(FHDFN,"GM"))!$D(^FHPT(FHDFN,"SM"))) W !!,"NO OUTPATIENT DATA ON FILE!" G FHDMP
W !!,"This report will also display any existing outpatient meals data."
W !,"Enter the Start Date and End Date for outpatient data.",!
D STDATE^FHOMUTL S SDT=STDT I STDT="" Q
S X="T+30" D ^%DT S ENDT=Y
D DD^%DT S FHDTDF=Y K DIR
S DIR("A")="Select End Date: ",DIR("B")=FHDTDF,DIR(0)="DAO^"_STDT
D ^DIR
Q:$D(DIRUT) S ENDT=Y S Y=ENDT D DD^%DT W " ",Y
D P0
Q
P0 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="INOUT^FHDMP",FHLST="ADM^FHDFN^DFN^IEN200^PID^OPSD^STDT^ENDT^SDT" D EN2^FH G KIL
U IO D INOUT D ^%ZISC K %ZIS,IOP G FHDMP
Q
INOUT D F0
Q:QT="^" I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q
Q:$G(ADM)
W:QT'="^" !,LN,!,?15,"*** O U T P A T I E N T M E A L D A T A ***"
Q:QT="^" D DISP^FHOMRMD I EX=U Q
I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q
Q:QT="^" D ^FHDPSM I EX=U Q
I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q
Q:QT="^" D ^FHDPGM I EX=U Q
CLEAN G KILL^XUSCLEAN
F0 D NOW^%DTC S DT=%\1,DTP=% D DTP^FH S NOW=DTP,S1=$S(IOST?1"C".E:IOSL,1:IOSL-6)
D PATNAME^FHOMUTL
;S Y(0)=^DPT(DFN,0)
S NAM=FHPTNM,SEX=FHSEX,DOB=FHDOB,PID=$G(PID),AGE=FHAGE,PG=0,QT=""
S PRTFM=STDT_" TO "_ENDT
S DTP=STDT D DTP^FH S SDT1=DTP
S DTP=ENDT D DTP^FH S EDT1=DTP
S PRTFM=SDT1_" TO "_EDT1
S LN="",$P(LN,"-",80)=""
D HDR
D ALG^FHCLN W !!,"Allergies: " S ALG=$S(ALG="":"None on file",1:ALG) D LNE
W !!,"Food Preferences Currently on file:",!!?26,"Likes",?58,"Dislikes",!
K N S P1=1 F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0) D SP
W ! S (M1,MM)="",L=0 F S M1=$O(N(M1)) Q:M1="" I $D(N(M1)) W $P(M1,"~",2) D S MM=M1
. S (P1,P2)=0 F S:P1'="" P1=$O(N(M1,"L",P1)) S X1=$S(P1>0:N(M1,"L",P1),1:"") S:P2'="" P2=$O(N(M1,"D",P2)) S X2=$S(P2>0:N(M1,"D",P2),1:"") Q:P1=""&(P2="") D W0 W:MM'=M1 !
. Q
I $O(N(""))="" W !!,"No Food Preferences on file",! D ^FHDMP1 Q
W ! K L,N,M,M1,M2 D ^FHDMP1 Q
W0 I X1'="" W ?12 S X=X1 D W1 S X1=X
I X2'="" W ?46 S X=X2 D W1 S X2=X
Q:X1=""&(X2="") S:$Y'<S1 L=1 D:$Y'<S1 HDR G:QT="^" KIL W ! W:L ! S L=0 G W0
W1 I $L(X)<34 W X S X="" Q
F KK=35:-1:1 Q:$E(X,KK-1,KK)=", "
W $E(X,1,KK-2) S X=$E(X,KK+1,999) Q
SP S M=$P(X,"^",2) S:M="A" M="BNE" S Z=$G(^FH(115.2,+X,0)),L1=$P(Z,"^",1),KK=$P(Z,"^",2),M1="",DAS=$P(X,"^",4)
I KK="L" S Q=$P(X,"^",3),L1=$S(Q:Q,1:1)_" "_L1
I M="BNE" S M1="1~All Meals" G SP1
S Z1=$E(M,1) I Z1'="" S M1=$S(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
S Z1=$E(M,2) I Z1'="" S M1=M1_","_$S(Z1="B":"Break",Z1="N":"Noon",1:"Even")
SP1 S:'$D(N(M1,KK,P1)) N(M1,KK,P1)="" I $L(N(M1,KK,P1))+$L(L1)<255 S N(M1,KK,P1)=N(M1,KK,P1)_$S(N(M1,KK,P1)="":"",1:", ")_L1_$S(DAS="Y":" (D)",1:"")
E S:'$D(N(M1,KK,K)) N(M1,KK,K)="" S N(M1,KK,K)=L1_$S(DAS="Y":" (D)",1:"") S P1=K
Q
LNE ; Break Line if longer than 65 chars
I $L(ALG)<66 W ALG Q
F L=67:-1:1 Q:$E(ALG,L-1,L)=", "
W $E(ALG,1,L-2)
S ALG=$E(ALG,L+1,999)
Q:ALG="" W !?11
G LNE
HDR ; Print Header
S (EX,QT)="" I PG,IOST?1"C".E W:$X>1 ! W *7 R QT:DTIME S:'$T QT="^" Q:QT="^"
W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
W !,?15,"P A T I E N T D A T A L O G",!
W !,"Date Range: ",PRTFM,?62,NOW,!!,PID,?17,NAM,?49,$S(SEX="M":"Male",SEX="F":"Female",1:""),?58,"Age ",AGE,?72,"Page ",PG Q
DTP ; Printable Date/Time
Q:Y<1 W $J(+$E(Y,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(Y,4,5))_"-"_$E(Y,2,3)
I Y["." S %=+$E(Y_"0",9,10) W $J($S(%>12:%-12,1:%),3)_":"_$E(Y_"000",11,12)_$S(%<12:"am",%<24:"pm",1:"m")
K % Q
KIL ; User exit
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHDMP 4624 printed Sep 23, 2025@19:23:31 Page 2
FHDMP ; HISC/REL/NCA/JH/RK/FAI - Patient Data Log ;10/19/04 13:26
+1 ;;5.5;DIETETICS;**1,2**;Jan 28, 2005
BEGIN SET ADM=""
SET FHALL=1
DO ^FHOMDPA
+1 if 'FHDFN
GOTO CLEAN
+2 IF $ORDER(^FHPT(FHDFN,"A",0))<1
WRITE !!,"NO ADMISSIONS ON FILE!"
GOTO OMDATE
+3 SET DIC="^FHPT(FHDFN,""A"","
SET DIC(0)="Q"
SET DA=FHDFN
SET X="??"
DO ^DIC
+4 SET WARD=""
IF $GET(DFN)'=""
SET WARD=$GET(^DPT(DFN,.1))
+5 KILL ADM
A0 WRITE !!,"Select ADMISSION or RETURN for OUTPATIENT ",$SELECT(WARD'="":" (or C for CURRENT)",1:""),": "
READ X:DTIME
if X["^"
GOTO KIL
if X="c"
DO TR^FH
+1 IF (X="")&'($DATA(^FHPT(FHDFN,"OP"))!$DATA(^FHPT(FHDFN,"GM"))!$DATA(^FHPT(FHDFN,"SM")))
WRITE !!,"NO OUTPATIENT DATA ON FILE!"
GOTO FHDMP
+2 IF (X="")&($DATA(^FHPT(FHDFN,"OP"))!$DATA(^FHPT(FHDFN,"GM"))!$DATA(^FHPT(FHDFN,"SM")))
GOTO OMDATE
+3 IF WARD'=""
IF X="C"
SET ADM=$GET(^DPT("CN",WARD,DFN))
if ADM
GOTO CAD
+4 SET DIC="^FHPT(FHDFN,""A"","
SET DIC(0)="EQM"
DO ^DIC
if Y<1
GOTO A0
SET ADM=+Y
CAD IF ADM
IF $GET(^FHPT(FHDFN,"A",ADM,0))
SET (SDT,STDT)=$PIECE(^FHPT(FHDFN,"A",ADM,0),U,1)
SET ENDT=DT
if SDT
GOTO P0
+1 ;
OMDATE IF '($DATA(^FHPT(FHDFN,"OP"))!$DATA(^FHPT(FHDFN,"GM"))!$DATA(^FHPT(FHDFN,"SM")))
WRITE !!,"NO OUTPATIENT DATA ON FILE!"
GOTO FHDMP
+1 WRITE !!,"This report will also display any existing outpatient meals data."
+2 WRITE !,"Enter the Start Date and End Date for outpatient data.",!
+3 DO STDATE^FHOMUTL
SET SDT=STDT
IF STDT=""
QUIT
+4 SET X="T+30"
DO ^%DT
SET ENDT=Y
+5 DO DD^%DT
SET FHDTDF=Y
KILL DIR
+6 SET DIR("A")="Select End Date: "
SET DIR("B")=FHDTDF
SET DIR(0)="DAO^"_STDT
+7 DO ^DIR
+8 if $DATA(DIRUT)
QUIT
SET ENDT=Y
SET Y=ENDT
DO DD^%DT
WRITE " ",Y
+9 DO P0
+10 QUIT
P0 KILL IOP
SET %ZIS="MQ"
SET %ZIS("B")="HOME"
WRITE !
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+1 IF $DATA(IO("Q"))
SET FHPGM="INOUT^FHDMP"
SET FHLST="ADM^FHDFN^DFN^IEN200^PID^OPSD^STDT^ENDT^SDT"
DO EN2^FH
GOTO KIL
+2 USE IO
DO INOUT
DO ^%ZISC
KILL %ZIS,IOP
GOTO FHDMP
+3 QUIT
INOUT DO F0
+1 if QT="^"
QUIT
IF IOST?1"C".E
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET EX=U
QUIT
+2 if $GET(ADM)
QUIT
+3 if QT'="^"
WRITE !,LN,!,?15,"*** O U T P A T I E N T M E A L D A T A ***"
+4 if QT="^"
QUIT
DO DISP^FHOMRMD
IF EX=U
QUIT
+5 IF IOST?1"C".E
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET EX=U
QUIT
+6 if QT="^"
QUIT
DO ^FHDPSM
IF EX=U
QUIT
+7 IF IOST?1"C".E
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET EX=U
QUIT
+8 if QT="^"
QUIT
DO ^FHDPGM
IF EX=U
QUIT
CLEAN GOTO KILL^XUSCLEAN
F0 DO NOW^%DTC
SET DT=%\1
SET DTP=%
DO DTP^FH
SET NOW=DTP
SET S1=$SELECT(IOST?1"C".E:IOSL,1:IOSL-6)
+1 DO PATNAME^FHOMUTL
+2 ;S Y(0)=^DPT(DFN,0)
+3 SET NAM=FHPTNM
SET SEX=FHSEX
SET DOB=FHDOB
SET PID=$GET(PID)
SET AGE=FHAGE
SET PG=0
SET QT=""
+4 SET PRTFM=STDT_" TO "_ENDT
+5 SET DTP=STDT
DO DTP^FH
SET SDT1=DTP
+6 SET DTP=ENDT
DO DTP^FH
SET EDT1=DTP
+7 SET PRTFM=SDT1_" TO "_EDT1
+8 SET LN=""
SET $PIECE(LN,"-",80)=""
+9 DO HDR
+10 DO ALG^FHCLN
WRITE !!,"Allergies: "
SET ALG=$SELECT(ALG="":"None on file",1:ALG)
DO LNE
+11 WRITE !!,"Food Preferences Currently on file:",!!?26,"Likes",?58,"Dislikes",!
+12 KILL N
SET P1=1
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"P",K))
if K<1
QUIT
SET X=^(K,0)
DO SP
+13 WRITE !
SET (M1,MM)=""
SET L=0
FOR
SET M1=$ORDER(N(M1))
if M1=""
QUIT
IF $DATA(N(M1))
WRITE $PIECE(M1,"~",2)
Begin DoDot:1
+14 SET (P1,P2)=0
FOR
if P1'=""
SET P1=$ORDER(N(M1,"L",P1))
SET X1=$SELECT(P1>0:N(M1,"L",P1),1:"")
if P2'=""
SET P2=$ORDER(N(M1,"D",P2))
SET X2=$SELECT(P2>0:N(M1,"D",P2),1:"")
if P1=""&(P2="")
QUIT
DO W0
if MM'=M1
WRITE !
+15 QUIT
End DoDot:1
SET MM=M1
+16 IF $ORDER(N(""))=""
WRITE !!,"No Food Preferences on file",!
DO ^FHDMP1
QUIT
+17 WRITE !
KILL L,N,M,M1,M2
DO ^FHDMP1
QUIT
W0 IF X1'=""
WRITE ?12
SET X=X1
DO W1
SET X1=X
+1 IF X2'=""
WRITE ?46
SET X=X2
DO W1
SET X2=X
+2 if X1=""&(X2="")
QUIT
if $Y'<S1
SET L=1
if $Y'<S1
DO HDR
if QT="^"
GOTO KIL
WRITE !
if L
WRITE !
SET L=0
GOTO W0
W1 IF $LENGTH(X)<34
WRITE X
SET X=""
QUIT
+1 FOR KK=35:-1:1
if $EXTRACT(X,KK-1,KK)=", "
QUIT
+2 WRITE $EXTRACT(X,1,KK-2)
SET X=$EXTRACT(X,KK+1,999)
QUIT
SP SET M=$PIECE(X,"^",2)
if M="A"
SET M="BNE"
SET Z=$GET(^FH(115.2,+X,0))
SET L1=$PIECE(Z,"^",1)
SET KK=$PIECE(Z,"^",2)
SET M1=""
SET DAS=$PIECE(X,"^",4)
+1 IF KK="L"
SET Q=$PIECE(X,"^",3)
SET L1=$SELECT(Q:Q,1:1)_" "_L1
+2 IF M="BNE"
SET M1="1~All Meals"
GOTO SP1
+3 SET Z1=$EXTRACT(M,1)
IF Z1'=""
SET M1=$SELECT(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
+4 SET Z1=$EXTRACT(M,2)
IF Z1'=""
SET M1=M1_","_$SELECT(Z1="B":"Break",Z1="N":"Noon",1:"Even")
SP1 if '$DATA(N(M1,KK,P1))
SET N(M1,KK,P1)=""
IF $LENGTH(N(M1,KK,P1))+$LENGTH(L1)<255
SET N(M1,KK,P1)=N(M1,KK,P1)_$SELECT(N(M1,KK,P1)="":"",1:", ")_L1_$SELECT(DAS="Y":" (D)",1:"")
+1 IF '$TEST
if '$DATA(N(M1,KK,K))
SET N(M1,KK,K)=""
SET N(M1,KK,K)=L1_$SELECT(DAS="Y":" (D)",1:"")
SET P1=K
+2 QUIT
LNE ; Break Line if longer than 65 chars
+1 IF $LENGTH(ALG)<66
WRITE ALG
QUIT
+2 FOR L=67:-1:1
if $EXTRACT(ALG,L-1,L)=", "
QUIT
+3 WRITE $EXTRACT(ALG,1,L-2)
+4 SET ALG=$EXTRACT(ALG,L+1,999)
+5 if ALG=""
QUIT
WRITE !?11
+6 GOTO LNE
HDR ; Print Header
+1 SET (EX,QT)=""
IF PG
IF IOST?1"C".E
if $X>1
WRITE !
WRITE *7
READ QT:DTIME
if '$TEST
SET QT="^"
if QT="^"
QUIT
+2 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
+3 WRITE !,?15,"P A T I E N T D A T A L O G",!
+4 WRITE !,"Date Range: ",PRTFM,?62,NOW,!!,PID,?17,NAM,?49,$SELECT(SEX="M":"Male",SEX="F":"Female",1:""),?58,"Age ",AGE,?72,"Page ",PG
QUIT
DTP ; Printable Date/Time
+1 if Y<1
QUIT
WRITE $JUSTIFY(+$EXTRACT(Y,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(Y,4,5))_"-"_$EXTRACT(Y,2,3)
+2 IF Y["."
SET %=+$EXTRACT(Y_"0",9,10)
WRITE $JUSTIFY($SELECT(%>12:%-12,1:%),3)_":"_$EXTRACT(Y_"000",11,12)_$SELECT(%<12:"am",%<24:"pm",1:"m")
+3 KILL %
QUIT
KIL ; User exit
+1 QUIT
