- FHORD91 ; HISC/REL/NCA/RVD - Diet Census Cont. ;1/23/98 16:08
- ;;5.5;DIETETICS;;Jan 28, 2005
- ;
- K S S L1=50
- STR F K=0:0 S K=$O(D(K)) Q:K="" S P(0,K)="",X=^FH(119.72,K,0),N1=$P(X,"^",1),N2=$P(X,"^",2),N3=$P(X,"^",4) S:N3="" N3=$E(N1,1,6) S S(N3,K)=$J(N3,8)_"^"_N2,L1=L1+8
- S:L1<80 L1=80
- LST S DTP=NOW D DTP^FH W:$E(IOST,1,2)="C-" @IOF W !,DTP,?(L1-35\2),"A C T U A L D I E T C E N S U S"
- S Z=$P(^FH(119.71,FHP,0),"^",1),DTP=TIM D DTP^FH
- S X=TIM D DOW^%DTC S DOW=Y+1,X=$P("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",DOW)_"day "_DTP
- S DTP=TIM D DTP^FH W !,FHSITENM
- W !,?(L1-$L(Z)\2),Z,!!?(L1-$L(X)\2),X
- W !!?(L1-31\2),"P R O D U C T I O N D I E T S",!!
- S X="",FHCNTX=0 F S X=$O(S(X)) Q:X="" S FHCNTX=FHCNTX+1
- S FHSP1=31
- S:FHCNTX=5 FHSP1=19
- S:FHCNTX=4 FHSP1=19
- S:FHCNTX=3 FHSP1=25
- S:FHCNTX=2 FHSP1=31
- S:FHCNTX=1 FHSP1=37
- S FHSP2=33
- S:FHCNTX=5 FHSP2=21
- S:FHCNTX=4 FHSP2=21
- S:FHCNTX=3 FHSP2=27
- S:FHCNTX=2 FHSP2=33
- S:FHCNTX=1 FHSP2=39
- W ?FHSP1
- S X="" F S X=$O(S(X)) Q:X="" F K=0:0 S K=$O(S(X,K)) Q:K="" W $P(S(X,K),"^",1)
- W " Tray Cafe Total",!
- F P1=0:0 S P1=$O(^FH(116.2,"AP",P1)) Q:P1<1 F K=0:0 S K=$O(^FH(116.2,"AP",P1,K)) Q:K<1 I $D(P(K)) D PRO
- W !?3,"N P O",?FHSP2 S K=.5 D P1 K P(.5)
- W !?3,"P A S S",?FHSP2 S K=.8 D P1 K P(.8)
- W !?3,"TF Only",?FHSP2 S K=.7 D P1 K P(.7)
- F X=0:0 S X=$O(P(.6,X)) Q:X<1 I $D(P(0,X)) S P(.6,X)=P(.6,X)-P(0,X)
- W !?3,"No Order",?FHSP2 S K=.6 D P1 K P(.6)
- W !!,"TOTAL MEALS",?FHSP2 S K=0 D P1 W ! K P(0) Q
- PRO W !,$E($P($G(^FH(116.2,K,0)),"^",1),1,21),?FHSP2
- P1 S (N("T"),N("C"),N("D"),N("G"))=""
- S X="" F S X=$O(S(X)) Q:X="" F K1=0:0 S K1=$O(S(X,K1)) Q:K1="" S Z=$G(P(K,K1)),TYP=$P(S(X,K1),"^",2) S:Z N(TYP)=N(TYP)+Z W $S(Z:$J(Z,6),1:$J("",6))," " I K>.4,Z S P(0,K1)=P(0,K1)+Z
- S:N("D") N("T")=N("T")+N("D") W $J(N("T"),6),$J(N("C"),6),$J(N("T")+N("C"),7) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD91 1877 printed Mar 13, 2025@20:58:20 Page 2
- FHORD91 ; HISC/REL/NCA/RVD - Diet Census Cont. ;1/23/98 16:08
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 ;
- +3 KILL S
- SET L1=50
- STR FOR K=0:0
- SET K=$ORDER(D(K))
- if K=""
- QUIT
- SET P(0,K)=""
- SET X=^FH(119.72,K,0)
- SET N1=$PIECE(X,"^",1)
- SET N2=$PIECE(X,"^",2)
- SET N3=$PIECE(X,"^",4)
- if N3=""
- SET N3=$EXTRACT(N1,1,6)
- SET S(N3,K)=$JUSTIFY(N3,8)_"^"_N2
- SET L1=L1+8
- +1 if L1<80
- SET L1=80
- LST SET DTP=NOW
- DO DTP^FH
- if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- WRITE !,DTP,?(L1-35\2),"A C T U A L D I E T C E N S U S"
- +1 SET Z=$PIECE(^FH(119.71,FHP,0),"^",1)
- SET DTP=TIM
- DO DTP^FH
- +2 SET X=TIM
- DO DOW^%DTC
- SET DOW=Y+1
- SET X=$PIECE("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",DOW)_"day "_DTP
- +3 SET DTP=TIM
- DO DTP^FH
- WRITE !,FHSITENM
- +4 WRITE !,?(L1-$LENGTH(Z)\2),Z,!!?(L1-$LENGTH(X)\2),X
- +5 WRITE !!?(L1-31\2),"P R O D U C T I O N D I E T S",!!
- +6 SET X=""
- SET FHCNTX=0
- FOR
- SET X=$ORDER(S(X))
- if X=""
- QUIT
- SET FHCNTX=FHCNTX+1
- +7 SET FHSP1=31
- +8 if FHCNTX=5
- SET FHSP1=19
- +9 if FHCNTX=4
- SET FHSP1=19
- +10 if FHCNTX=3
- SET FHSP1=25
- +11 if FHCNTX=2
- SET FHSP1=31
- +12 if FHCNTX=1
- SET FHSP1=37
- +13 SET FHSP2=33
- +14 if FHCNTX=5
- SET FHSP2=21
- +15 if FHCNTX=4
- SET FHSP2=21
- +16 if FHCNTX=3
- SET FHSP2=27
- +17 if FHCNTX=2
- SET FHSP2=33
- +18 if FHCNTX=1
- SET FHSP2=39
- +19 WRITE ?FHSP1
- +20 SET X=""
- FOR
- SET X=$ORDER(S(X))
- if X=""
- QUIT
- FOR K=0:0
- SET K=$ORDER(S(X,K))
- if K=""
- QUIT
- WRITE $PIECE(S(X,K),"^",1)
- +21 WRITE " Tray Cafe Total",!
- +22 FOR P1=0:0
- SET P1=$ORDER(^FH(116.2,"AP",P1))
- if P1<1
- QUIT
- FOR K=0:0
- SET K=$ORDER(^FH(116.2,"AP",P1,K))
- if K<1
- QUIT
- IF $DATA(P(K))
- DO PRO
- +23 WRITE !?3,"N P O",?FHSP2
- SET K=.5
- DO P1
- KILL P(.5)
- +24 WRITE !?3,"P A S S",?FHSP2
- SET K=.8
- DO P1
- KILL P(.8)
- +25 WRITE !?3,"TF Only",?FHSP2
- SET K=.7
- DO P1
- KILL P(.7)
- +26 FOR X=0:0
- SET X=$ORDER(P(.6,X))
- if X<1
- QUIT
- IF $DATA(P(0,X))
- SET P(.6,X)=P(.6,X)-P(0,X)
- +27 WRITE !?3,"No Order",?FHSP2
- SET K=.6
- DO P1
- KILL P(.6)
- +28 WRITE !!,"TOTAL MEALS",?FHSP2
- SET K=0
- DO P1
- WRITE !
- KILL P(0)
- QUIT
- PRO WRITE !,$EXTRACT($PIECE($GET(^FH(116.2,K,0)),"^",1),1,21),?FHSP2
- P1 SET (N("T"),N("C"),N("D"),N("G"))=""
- +1 SET X=""
- FOR
- SET X=$ORDER(S(X))
- if X=""
- QUIT
- FOR K1=0:0
- SET K1=$ORDER(S(X,K1))
- if K1=""
- QUIT
- SET Z=$GET(P(K,K1))
- SET TYP=$PIECE(S(X,K1),"^",2)
- if Z
- SET N(TYP)=N(TYP)+Z
- WRITE $SELECT(Z:$JUSTIFY(Z,6),1:$JUSTIFY("",6))," "
- IF K>.4
- IF Z
- SET P(0,K1)=P(0,K1)+Z
- +2 if N("D")
- SET N("T")=N("T")+N("D")
- WRITE $JUSTIFY(N("T"),6),$JUSTIFY(N("C"),6),$JUSTIFY(N("T")+N("C"),7)
- QUIT
