- 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 Feb 18, 2025@23:13:55 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