- 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 Mar 13, 2025@20:58:02 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
