FHCMSR1.m

FHCMSR1 ; HISC/NCA - Cost of Meals Served (cont.) ;4/25/93  13:57

 ;;5.5;DIETETICS;;Jan 28, 2005

Q1 ; Process Calculating Cost of Meals

 ; STG contains a string of number that is used to indicate which column

 ; to print each cost in the row.

 S DA=SDT D NOW^%DTC S DTP=% D DTP^FH S HD=DTP,PG=0 D HDR

 S S1=$E(SDT,4,5),S2=$S(S1<4:"01",S1<7:"04",S1<10:"07",1:10) S:$E(SDT,4,5)'=S2 SDT=$E(SDT,1,3)_S2_"00"

 K S S (STG,X1)=""

 S STG="1,7,13,1,19,8,15,1;2,8,14,2,20,9,16,2;3,9,15,3,21,10,17,3;4,10,16,4,22,11,18,4;5,11,17,5,23,12,19,5;6,12,18,6,24,13,20,6"

 S L=SDT-100 F L1=L:0 S L1=$O(^FH(117.2,L1)) Q:L1<1!(L1>EDT)  S X1=$G(^(L1,0)) D ADD

 Q:X1=""  D CAL

 Q

CAL ; Calculate the costs

 ; P(1) contains the cost entered for calculating all the cost of the

 ; Food Groups. P(2) contains the total of the beg inv, issue, end inv,

 ; and recommanded.

 K P F L=1:1:4 S P(L)=""

 S P1=$P($G(^FH(117.2,SDT,0)),"^",2,7)_"^"_$P(X1,"^",8,25) Q:P1=""

 F L=1:1:24 S $P(P(1),"^",L)=$P(P1,"^",L)

 S K=6 F L=1:1:6 S $P(P(1),"^",K+L)=S(L)

 S K=0 F I=1:1:4 F L=1:1:6 S K=K+1,$P(P(2),"^",I)=$P(P(2),"^",I)+$P(P(1),"^",K)

 ; P(3) contains Beg Inv + Issue - End Inv.  Piece 7 Total,

 ; Pieces 8-13 contains Usage / Total Usage and Total.

 ; Pieces 15-20 contains % Actual - % Cost rec (F-E) and Total.

 ; P(4) contains Usage / Total Meals Served (FHTOT) AND Total/Total Meals.

 F L=1:1:6 S $P(P(3),"^",L)=($P(P(1),"^",L)+$P(P(1),"^",L+6))-$P(P(1),"^",L+12),$P(P(3),"^",7)=$P(P(3),"^",7)+$P(P(3),"^",L)

 F L=1:1:6 D

 .S $P(P(3),"^",L+7)=$S(+$P(P(3),"^",7)'<1:($P(P(3),"^",L)/$P(P(3),"^",7))*100,1:"")

 .S $P(P(3),"^",L+7)=$J($P(P(3),"^",L+7),0,0)

 .S $P(P(3),"^",L+14)=$P(P(3),"^",L+7)-$P(P(1),"^",L+18)

 .Q

 S K=7 F L=1:1:6 S K=K+1,$P(P(3),"^",14)=$P(P(3),"^",14)+$P(P(3),"^",K)

 S K=14 F L=1:1:6 S K=K+1,$P(P(3),"^",21)=$P(P(3),"^",21)+$P(P(3),"^",K)

 K N F I=1:1:21 S N(I)=0

 D ^FHCMS1

 G:'FHTOT PRT F I=1:1:6 S $P(P(4),"^",I)=$S(FHTOT:$P(P(3),"^",I)/FHTOT,1:"")

 S $P(P(4),"^",7)=$S(FHTOT:$P(P(3),"^",7)/FHTOT,1:"")

PRT ; Print the costs

 F L=1:1:18 S X=$P(P(1),"^",L),X2="0",X3=11 D COMMA^%DTC S $P(P(1),"^",L)=X

 F L=1:1:3 S X=$P(P(2),"^",L),X2="0",X3=11 D COMMA^%DTC S $P(P(2),"^",L)=X

 F L=1:1:7 S X=$P(P(3),"^",L),X2="0",X3=11 D COMMA^%DTC S $P(P(3),"^",L)=X

 F L=19:1:24 S $P(P(1),"^",L)=$J($P(P(1),"^",L),5)

 F L=8:1:20 S $P(P(3),"^",L)=$J($P(P(3),"^",L),5)

 F I=1:1:7 S $P(P(4),"^",I)=$J($P(P(4),"^",I),9,4)

 F I=1:1:6 S PC=$P(STG,";",I),T1=0 D LP

 G ND

LP ; Loop to print costs for each group

 W $P("I II III IV V VI"," ",I)

 W ?7,$P(P(1),"^",$P(PC,"^",1)),?18,$P(P(1),"^",$P(PC,",",2)),?29,$P(P(1),"^",$P(PC,",",3)),?40,$P(P(3),"^",$P(PC,",",4)),?50,$P(P(1),"^",$P(PC,",",5))_"%"

 W ?57,$P(P(3),"^",$P(PC,",",6))_"%",?64,$P(P(3),"^",$P(PC,",",7))_"%",?71,$P(P(4),"^",$P(PC,",",8))

 W !

 Q

ND ; Print the last line,the total of each column

 W !,"Total",?7,$P(P(2),"^",1),?18,$P(P(2),"^",2),?29,$P(P(2),"^",3),?40,$P(P(3),"^",7),?50,$J($P(P(2),"^",4),5)_"%",?57,$J($P(P(3),"^",14),5),"%",?64,$J($P(P(3),"^",21),5),"%",?71,$P(P(4),"^",7),! Q

ADD ; Add Issue for the quarter

 Q:X1=""

 S K=7 F I=1:1:6 S:'$D(S(I)) S(I)=0 S S(I)=S(I)+$P(X1,"^",K+I)

 Q

HDR ; Print Heading

 W:'($E(IOST,1,2)'="C-"&'PG) @IOF

 W !,HD D HDR1 S Y=X_" "_(1700+$E(DA,1,3)) I SDT'=EDT S DA=EDT D HDR1 S Y=Y_"-"_X_" "_(1700+$E(DA,1,3))

 W !!,?(80-$L(Y)/2),Y

 W !!,?24,"COST  OF  MEALS  SERVED  WORKSHEET"

 S PG=PG+1 W ?74,"Page ",PG

 W !!!?24,"Costs",! S LN="",$P(LN,"-",43)="" W ?8,LN,!

 W "Food",?11,"Beg",?32,"Close",?54,"%",?61,"%",?68,"%",?73,"Food",!

 W "Group",?11,"Inv",?21,"Issue",?33,"Inv",?43,"Usage",?53,"Rec",?60,"Act",?67,"Dev",?73,"Cost"

 W !?12,"A",?23,"B",?34,"C",?45,"D",?54,"E",?61,"F",?68,"G",?75,"H"

 S LN="",$P(LN,"-",81)="" W !,LN,! Q

HDR1 S X=$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(DA,4,5)) Q

FHCMSR1   ; HISC/NCA - Cost of Meals Served (cont.) ;4/25/93  13:57

 +1       ;;5.5;DIETETICS;;Jan 28, 2005

Q1        ; Process Calculating Cost of Meals

 +1       ; STG contains a string of number that is used to indicate which column

 +2       ; to print each cost in the row.

 +3        SET DA=SDT

           DO NOW^%DTC

           SET DTP=%

           DO DTP^FH

           SET HD=DTP

           SET PG=0

           DO HDR

 +4        SET S1=$EXTRACT(SDT,4,5)

           SET S2=$SELECT(S1<4:"01",S1<7:"04",S1<10:"07",1:10)

           IF $EXTRACT(SDT,4,5)'=S2

               SET SDT=$EXTRACT(SDT,1,3)_S2_"00"

 +5        KILL S

           SET (STG,X1)=""

 +6        SET STG="1,7,13,1,19,8,15,1;2,8,14,2,20,9,16,2;3,9,15,3,21,10,17,3;4,10,16,4,22,11,18,4;5,11,17,5,23,12,19,5;6,12,18,6,24,13,20,6"

 +7        SET L=SDT-100

           FOR L1=L:0

               SET L1=$ORDER(^FH(117.2,L1))

               IF L1<1!(L1>EDT)

                   QUIT 

               SET X1=$GET(^(L1,0))

               DO ADD

 +8        IF X1=""

               QUIT 

           DO CAL

 +9        QUIT 

CAL       ; Calculate the costs

 +1       ; P(1) contains the cost entered for calculating all the cost of the

 +2       ; Food Groups. P(2) contains the total of the beg inv, issue, end inv,

 +3       ; and recommanded.

 +4        KILL P

           FOR L=1:1:4

               SET P(L)=""

 +5        SET P1=$PIECE($GET(^FH(117.2,SDT,0)),"^",2,7)_"^"_$PIECE(X1,"^",8,25)

           IF P1=""

               QUIT 

 +6        FOR L=1:1:24

               SET $PIECE(P(1),"^",L)=$PIECE(P1,"^",L)

 +7        SET K=6

           FOR L=1:1:6

               SET $PIECE(P(1),"^",K+L)=S(L)

 +8        SET K=0

           FOR I=1:1:4

               FOR L=1:1:6

                   SET K=K+1

                   SET $PIECE(P(2),"^",I)=$PIECE(P(2),"^",I)+$PIECE(P(1),"^",K)

 +9       ; P(3) contains Beg Inv + Issue - End Inv.  Piece 7 Total,

 +10      ; Pieces 8-13 contains Usage / Total Usage and Total.

 +11      ; Pieces 15-20 contains % Actual - % Cost rec (F-E) and Total.

 +12      ; P(4) contains Usage / Total Meals Served (FHTOT) AND Total/Total Meals.

 +13       FOR L=1:1:6

               SET $PIECE(P(3),"^",L)=($PIECE(P(1),"^",L)+$PIECE(P(1),"^",L+6))-$PIECE(P(1),"^",L+12)

               SET $PIECE(P(3),"^",7)=$PIECE(P(3),"^",7)+$PIECE(P(3),"^",L)

 +14       FOR L=1:1:6

               Begin DoDot:1

 +15               SET $PIECE(P(3),"^",L+7)=$SELECT(+$PIECE(P(3),"^",7)'<1:($PIECE(P(3),"^",L)/$PIECE(P(3),"^",7))*100,1:"")

 +16               SET $PIECE(P(3),"^",L+7)=$JUSTIFY($PIECE(P(3),"^",L+7),0,0)

 +17               SET $PIECE(P(3),"^",L+14)=$PIECE(P(3),"^",L+7)-$PIECE(P(1),"^",L+18)

 +18               QUIT 

               End DoDot:1

 +19       SET K=7

           FOR L=1:1:6

               SET K=K+1

               SET $PIECE(P(3),"^",14)=$PIECE(P(3),"^",14)+$PIECE(P(3),"^",K)

 +20       SET K=14

           FOR L=1:1:6

               SET K=K+1

               SET $PIECE(P(3),"^",21)=$PIECE(P(3),"^",21)+$PIECE(P(3),"^",K)

 +21       KILL N

           FOR I=1:1:21

               SET N(I)=0

 +22       DO ^FHCMS1

 +23       IF 'FHTOT

               GOTO PRT

           FOR I=1:1:6

               SET $PIECE(P(4),"^",I)=$SELECT(FHTOT:$PIECE(P(3),"^",I)/FHTOT,1:"")

 +24       SET $PIECE(P(4),"^",7)=$SELECT(FHTOT:$PIECE(P(3),"^",7)/FHTOT,1:"")

PRT       ; Print the costs

 +1        FOR L=1:1:18

               SET X=$PIECE(P(1),"^",L)

               SET X2="0"

               SET X3=11

               DO COMMA^%DTC

               SET $PIECE(P(1),"^",L)=X

 +2        FOR L=1:1:3

               SET X=$PIECE(P(2),"^",L)

               SET X2="0"

               SET X3=11

               DO COMMA^%DTC

               SET $PIECE(P(2),"^",L)=X

 +3        FOR L=1:1:7

               SET X=$PIECE(P(3),"^",L)

               SET X2="0"

               SET X3=11

               DO COMMA^%DTC

               SET $PIECE(P(3),"^",L)=X

 +4        FOR L=19:1:24

               SET $PIECE(P(1),"^",L)=$JUSTIFY($PIECE(P(1),"^",L),5)

 +5        FOR L=8:1:20

               SET $PIECE(P(3),"^",L)=$JUSTIFY($PIECE(P(3),"^",L),5)

 +6        FOR I=1:1:7

               SET $PIECE(P(4),"^",I)=$JUSTIFY($PIECE(P(4),"^",I),9,4)

 +7        FOR I=1:1:6

               SET PC=$PIECE(STG,";",I)

               SET T1=0

               DO LP

 +8        GOTO ND

LP        ; Loop to print costs for each group

 +1        WRITE $PIECE("I II III IV V VI"," ",I)

 +2        WRITE ?7,$PIECE(P(1),"^",$PIECE(PC,"^",1)),?18,$PIECE(P(1),"^",$PIECE(PC,",",2)),?29,$PIECE(P(1),"^",$PIECE(PC,",",3)),?40,$PIECE(P(3),"^",$PIECE(PC,",",4)),?50,$PIECE(P(1),"^",$PIECE(PC,",",5))_"%"

 +3        WRITE ?57,$PIECE(P(3),"^",$PIECE(PC,",",6))_"%",?64,$PIECE(P(3),"^",$PIECE(PC,",",7))_"%",?71,$PIECE(P(4),"^",$PIECE(PC,",",8))

 +4        WRITE !

 +5        QUIT 

ND        ; Print the last line,the total of each column

 +1        WRITE !,"Total",?7,$PIECE(P(2),"^",1),?18,$PIECE(P(2),"^",2),?29,$PIECE(P(2),"^",3),?40,$PIECE(P(3),"^",7),?50,$JUSTIFY($PIECE(P(2),"^",4),5)_"%",?57,$JUSTIFY($PIECE(P(3),"^",14),5),"%",?64,$JUSTIFY($PIECE(P(3),"^",21),5),"%",?71,$PIECE(P(4),"^

",7),!

           QUIT 

ADD       ; Add Issue for the quarter

 +1        IF X1=""

               QUIT 

 +2        SET K=7

           FOR I=1:1:6

               IF '$DATA(S(I))

                   SET S(I)=0

               SET S(I)=S(I)+$PIECE(X1,"^",K+I)

 +3        QUIT 

HDR       ; Print Heading

 +1        IF '($EXTRACT(IOST,1,2)'="C-"&'PG)

               WRITE @IOF

 +2        WRITE !,HD

           DO HDR1

           SET Y=X_" "_(1700+$EXTRACT(DA,1,3))

           IF SDT'=EDT

               SET DA=EDT

               DO HDR1

               SET Y=Y_"-"_X_" "_(1700+$EXTRACT(DA,1,3))

 +3        WRITE !!,?(80-$LENGTH(Y)/2),Y

 +4        WRITE !!,?24,"COST  OF  MEALS  SERVED  WORKSHEET"

 +5        SET PG=PG+1

           WRITE ?74,"Page ",PG

 +6        WRITE !!!?24,"Costs",!

           SET LN=""

           SET $PIECE(LN,"-",43)=""

           WRITE ?8,LN,!

 +7        WRITE "Food",?11,"Beg",?32,"Close",?54,"%",?61,"%",?68,"%",?73,"Food",!

 +8        WRITE "Group",?11,"Inv",?21,"Issue",?33,"Inv",?43,"Usage",?53,"Rec",?60,"Act",?67,"Dev",?73,"Cost"

 +9        WRITE !?12,"A",?23,"B",?34,"C",?45,"D",?54,"E",?61,"F",?68,"G",?75,"H"

 +10       SET LN=""

           SET $PIECE(LN,"-",81)=""

           WRITE !,LN,!

           QUIT 

HDR1       SET X=$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(DA,4,5))

           QUIT