FHORD10 ; HISC/REL/NCA - Diet Activity Report ;5/17/93 09:57
;;5.5;DIETETICS;;Jan 28, 2005
S FHP=$O(^FH(119.73,0)) I FHP'<1,$O(^FH(119.73,FHP))<1 G R1
R0 R !!,"Select COMMUNICATION OFFICE: ",X:DTIME G:'$T!("^"[X) KIL
K DIC S DIC="^FH(119.73,",DIC(0)="EMQ" D ^DIC G:Y<1 R0 S FHP=+Y
R1 R !!,"Do you want labels? N// ",X:DTIME G:'$T!(X["^") KIL S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Enter YES or NO" G R1
S LAB=X?1"Y".E,TIM=$P($G(^FH(119.73,FHP,0)),"^",2) I 'TIM D NOW^%DTC S TIM=%
S DTP=TIM D DTP^FH
R2 R !!,"Do you wish to update ward/rooms? N // ",X:DTIME G:'$T!(X["^") KIL S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G R2
S UPD=X?1"Y".E
R3 W !!,"Changes since Date/Time: ",DTP," // " R X:DTIME G:'$T!(X["^") KIL I X'="" S %DT="EXTS" D ^%DT K %DT G:Y<1 R3 S TIM=Y
W ! K IOP,%ZIS S %ZIS("A")="Select "_$S(LAB:"LABEL",1:"LIST")_" Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHORD10",FHLST="TIM^LAB^FHP^UPD" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Print Diet Activity Report
K ^TMP($J) D NOW^%DTC S NOW=%,DTP=TIM,TIM=TIM-.0001 D DTP^FH S H1=DTP_" - " S DTP=NOW D DTP^FH S H1=H1_DTP D ^FHDEV
I LAB S LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1
F W1=0:0 S W1=$O(^FHPT("AW",W1)) Q:W1'>0 D WRD I FHP=D2 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) D:ADM Q3
G ^FHORD11
WRD S P0=$G(^FH(119.6,W1,0)),WRDN=$P(P0,"^",1),D2=$P(P0,"^",8),P0=$P(P0,"^",4) S:P0<1 P0=99 Q
Q3 Q:'$D(^FHPT(FHDFN,"A",ADM,0))
Q4 S X0=^FHPT(FHDFN,"A",ADM,0)
S FHORD=$P(X0,"^",2),X1=$P(X0,"^",3) Q:'FHORD
S E1="" F NX=TIM:0 S NX=$O(^FHPT(FHDFN,"A",ADM,"AC",NX)) Q:NX<1!(NX>NOW) S E1=NX
S OLW=$P(X0,"^",11),OLR=$P(X0,"^",12) I W1'=OLW S E1=1 I UPD S $P(^FHPT(FHDFN,"A",ADM,0),"^",11)=W1
D PATNAME^FHOMUTL I DFN="" Q
S R1=$G(^DPT(DFN,.101)) I R1'=OLR S E1=1 I UPD S $P(^FHPT(FHDFN,"A",ADM,0),"^",12)=R1
S OLW=$S(OLW=W1:" ",'OLW:"",1:$P($G(^FH(119.6,OLW,0)),"^",1)),OLR=$S(R1=OLR:" ",1:OLR)
S:E1 ^TMP($J,D2,$S(P0<10:"0"_P0,1:P0)_$S(R1'="":R1,1:" "),FHDFN)=WRDN_"^"_R1_"^"_ADM_"^"_FHORD_"^"_$P(X0,"^",7)_"^"_$P(X0,"^",10)_"^"_OLW_"^"_OLR Q
KIL K %,%H,%I,%DT,A1,ADM,ALG,CADM,COM,D2,D3,DA,FHDFN,DFN,DIC,DTP,E1,FHOR,FHP,H1,IS,K,L1,L2,LAB,N1,NOW,NX,OLW,OLR,FHORD,FHDU,FHIO,FHLD
K L,SF,SO,SVC,P0,PG,POP,R1,S1,S2,TC,TIM,UPD,W1,WRDN,X,X0,X1,X2,Y,Y0,^TMP($J) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD10 2436 printed Sep 23, 2025@19:29:23 Page 2
FHORD10 ; HISC/REL/NCA - Diet Activity Report ;5/17/93 09:57
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 SET FHP=$ORDER(^FH(119.73,0))
IF FHP'<1
IF $ORDER(^FH(119.73,FHP))<1
GOTO R1
R0 READ !!,"Select COMMUNICATION OFFICE: ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
+1 KILL DIC
SET DIC="^FH(119.73,"
SET DIC(0)="EMQ"
DO ^DIC
if Y<1
GOTO R0
SET FHP=+Y
R1 READ !!,"Do you want labels? N// ",X:DTIME
if '$TEST!(X["^")
GOTO KIL
if X=""
SET X="N"
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7," Enter YES or NO"
GOTO R1
+1 SET LAB=X?1"Y".E
SET TIM=$PIECE($GET(^FH(119.73,FHP,0)),"^",2)
IF 'TIM
DO NOW^%DTC
SET TIM=%
+2 SET DTP=TIM
DO DTP^FH
R2 READ !!,"Do you wish to update ward/rooms? N // ",X:DTIME
if '$TEST!(X["^")
GOTO KIL
if X=""
SET X="N"
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7," Answer YES or NO"
GOTO R2
+1 SET UPD=X?1"Y".E
R3 WRITE !!,"Changes since Date/Time: ",DTP," // "
READ X:DTIME
if '$TEST!(X["^")
GOTO KIL
IF X'=""
SET %DT="EXTS"
DO ^%DT
KILL %DT
if Y<1
GOTO R3
SET TIM=Y
+1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select "_$SELECT(LAB:"LABEL",1:"LIST")_" Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+2 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHORD10"
SET FHLST="TIM^LAB^FHP^UPD"
DO EN2^FH
GOTO KIL
+3 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Print Diet Activity Report
+1 KILL ^TMP($JOB)
DO NOW^%DTC
SET NOW=%
SET DTP=TIM
SET TIM=TIM-.0001
DO DTP^FH
SET H1=DTP_" - "
SET DTP=NOW
DO DTP^FH
SET H1=H1_DTP
DO ^FHDEV
+2 IF LAB
SET LAB=$PIECE($GET(^FH(119.9,1,"D",IOS,0)),"^",2)
if 'LAB
SET LAB=1
+3 FOR W1=0:0
SET W1=$ORDER(^FHPT("AW",W1))
if W1'>0
QUIT
DO WRD
IF FHP=D2
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
if FHDFN=""
QUIT
SET ADM=$GET(^FHPT("AW",W1,FHDFN))
if ADM
DO Q3
+4 GOTO ^FHORD11
WRD SET P0=$GET(^FH(119.6,W1,0))
SET WRDN=$PIECE(P0,"^",1)
SET D2=$PIECE(P0,"^",8)
SET P0=$PIECE(P0,"^",4)
if P0<1
SET P0=99
QUIT
Q3 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
Q4 SET X0=^FHPT(FHDFN,"A",ADM,0)
+1 SET FHORD=$PIECE(X0,"^",2)
SET X1=$PIECE(X0,"^",3)
if 'FHORD
QUIT
+2 SET E1=""
FOR NX=TIM:0
SET NX=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",NX))
if NX<1!(NX>NOW)
QUIT
SET E1=NX
+3 SET OLW=$PIECE(X0,"^",11)
SET OLR=$PIECE(X0,"^",12)
IF W1'=OLW
SET E1=1
IF UPD
SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",11)=W1
+4 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+5 SET R1=$GET(^DPT(DFN,.101))
IF R1'=OLR
SET E1=1
IF UPD
SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",12)=R1
+6 SET OLW=$SELECT(OLW=W1:" ",'OLW:"",1:$PIECE($GET(^FH(119.6,OLW,0)),"^",1))
SET OLR=$SELECT(R1=OLR:" ",1:OLR)
+7 if E1
SET ^TMP($JOB,D2,$SELECT(P0<10:"0"_P0,1:P0)_$SELECT(R1'="":R1,1:" "),FHDFN)=WRDN_"^"_R1_"^"_ADM_"^"_FHORD_"^"_$PIECE(X0,"^",7)_"^"_$PIECE(X0,"^",10)_"^"_OLW_"^"_OLR
QUIT
KIL KILL %,%H,%I,%DT,A1,ADM,ALG,CADM,COM,D2,D3,DA,FHDFN,DFN,DIC,DTP,E1,FHOR,FHP,H1,IS,K,L1,L2,LAB,N1,NOW,NX,OLW,OLR,FHORD,FHDU,FHIO,FHLD
+1 KILL L,SF,SO,SVC,P0,PG,POP,R1,S1,S2,TC,TIM,UPD,W1,WRDN,X,X0,X1,X2,Y,Y0,^TMP($JOB)
QUIT
