Routine: FHMADM3

FHMADM3 ; HISC/REL/AAC - Additional Meals Report ;10/9/03  16:07

 ;;5.5;DIETETICS;;Jan 28, 2005

EN1 ; Print Meal Report

 D DT G:"^"[X KIL

 ;Get Communication Offices data

 F K=1:1:22 S SS(K)=0,S(K)=0

 S CONUM="",ZCO="",COXX="",CO="",CONAME="",CONAM="",COUNT=0

 ;S ZZOUT=$G(^FH(119.73,0)),ZOUT=$P(ZZOUT,"^",4)

 S ZZCOUNT=0 F ZZCOUNT=0:0 S ZZCOUNT=$O(^FH(119.73,ZZCOUNT)) Q:ZZCOUNT'>0  S ZOUT=ZZCOUNT

 R !,"Print report for all Communications Offices Y or N: ",ZCO:DTIME W ! S ZCO=$TR(ZCO,"y","Y") I ZCO'="Y" D N2 G KIL Q

PRINT W !!,"The report requires a 132 column printer.",!

 K IOP,%ZIS S %ZIS("A")="Print on Device: ",%ZIS="MQ" W ! D ^%ZIS K %ZIS,IOP G:POP KIL

 I $D(IO("Q")) S FHPGM="Q1^FHMADM3",FHLST="CONAME^CO^CONUMX^EDT^SDT^ZCO^COUNT^ZOUT^S(^SS(" D EN2^FH G KIL

 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL

Q1 ; Process Printing the Meal Report

 S DTP=SDT\1 D DTP^FH S DTE=DTP_" to " S DTP=EDT\1 D DTP^FH S DTE=DTE_DTP

 S X=SDT D DOW^%DTC S DOW=Y+1

 D NOW^%DTC S DTP=% D DTP^FH S HDT=DTP,PG=0

Q2 ;

 ;Get Specific Communication Offices

 I ZCO'="Y" S CONUMX=CONUMX-1 G:CONUMX=0 QUIT  S COXX=$P(CO,"^",CONUMX),NAME=$P(CONAME,"^",CONUMX) G:$D(^FH(119.73,COXX,"I")) Q2 G:'$D(^FH(119.73,COXX,0)) Q2

 I ZCO="Y" S COUNT=COUNT+1 G:COUNT>ZOUT QUIT  S NAME=$G(^FH(119.73,COUNT,0)),NAME=$P(NAME,"^") G:$D(^FH(119.73,COUNT,"I")) Q2 G:'$D(^FH(119.73,COUNT,0)) Q2

 ;W @IOF

 D HDR

 S DOW=Y+1 D Q3

 I ZCO'="Y" I CONUMX>0  G Q2

 I ZCO="Y" G Q2

QUIT ;

 ;W @IOF

 S NAME="Total All Communications Offices "

 D HDR

 D FTOTALS

 D LN,LN

Q3 F L1=19:1:22 S N(L1)=0

 S D1=SDT F L1=0:0 D N1 S X1=D1,X2=1 D C^%DTC  Q:X>EDT  S D1=X,DOW=DOW+1 S:DOW=8 DOW=1

TOTALS ;

 ;Print Totals

 F K=1:1:22 S Z=$S(K<19:5,1:6),S(K)=$S(S(K)<1:$J("",Z),S(K)<10000:$J(S(K),Z-1)_" ",1:$J(S(K),Z))

 D LN W !,"  Total",?10,"|",S(1),S(2),S(3),S(4),S(5),S(6),S(19)," |",S(7),S(8),S(9),S(10),S(11),S(12),S(20)," |",S(13),S(14),S(15),S(16),S(17),S(18),S(21)," |",S(22),!

FTOTALS ; Final Totals

 F K=1:1:22 S Z=$S(K<19:5,1:6),SS(K)=$S(SS(K)<1:$J("",Z),SS(K)<10000:$J(SS(K),Z-1)_" ",1:$J(SS(K),Z))

 W !,"ALL Total",?10,"|",SS(1),SS(2),SS(3),SS(4),SS(5),SS(6),SS(19)," |",SS(7),SS(8),SS(9),SS(10),SS(11),SS(12),SS(20)," |",SS(13),SS(14),SS(15),SS(16),SS(17),SS(18),SS(21)," |",SS(22),!

HDR ;Print page headers

 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !,HDT,?50,"A D D I T I O N A L   M E A L S",?125,"Page ",PG

 W !!,?1,NAME

 W !!?(131-$L(DTE)\2),DTE

 W !!,?10,"|",?21,"B R E A K F A S T",?48,"|",?64,"N O O N",?86,"|",?99,"E V E N I N G",?124,"| TOTAL"

 W !,?10,"| Opt. Emp. Paid OOD  Vol. Grt. Total | Opt. Emp. Paid OOD  Vol. Grt. Total | Opt. Emp. Paid OOD  Vol. Grt. Total |"

LN W !,"-----------------------------------------------------------------------------------------------------------------------------------"

N1 ;Get specific records based on Communications Offices,Start/End Dates, etc

 I ZCO'="Y" F CONUM=1:1  Q:CONUM>ZOUT  S Y0=$G(^FH(117,D1,2,CONUM,0)),Y2=$P(Y0,"^"),Y1=$P(Y0,"^",2,99)  Q:COXX=Y2

 I ZCO="Y" F CONUM=1:1  Q:CONUM>ZOUT  S Y0=$G(^FH(117,D1,2,CONUM,0)),Y2=$P(Y0,"^"),Y1=$P(Y0,"^",2,99)  Q:COUNT=Y2

 S K=0 F L1=1:1:6 F L2=1:1:3 S K=K+1,N=L2-1*6+L1,Z=$P(Y1,"^",K),N(N)=Z,N(18+L2)=N(18+L2)+Z

 S N(22)=N(19)+N(20)+N(21)

 F K=1:1:22 S S(K)=S(K)+N(K),SS(K)=SS(K)+N(K),N(K)=$J($S(N(K)<1:"",1:N(K)),$S(K<19:4,1:5))_" "

 S DTP=D1 D DTP^FH D:$Y>(IOSL-8) HDR

 W !,$P("Sun Mon Tue Wed Thu Fri Sat"," ",DOW)," ",$E(DTP,1,6)

 W "|",N(1),N(2),N(3),N(4),N(5),N(6),N(19)," |",N(7),N(8),N(9),N(10),N(11),N(12),N(20)," |",N(13),N(14),N(15),N(16),N(17),N(18),N(21)," |",N(22) Q

N2 ;Get Communciation Offices

 S DIC=119.73,DIC(0)="AEQ",DIC("A")="Select Communication Offices: "

 D ^DIC I (Y=-1)&(CO="") Q

 I Y=-1 G PRINT Q

 S CON=$P(Y,"^",1),CO=CON_"^"_CO,CONAM=$P(Y,"^",2),CONAME=CONAM_"^"_CONAME S CONUMX=$L(CO,"^") G N2 Q

 I Y=-1 K DIC Q

DT ; Get From/To Dates

D1 S %DT="AEPX",%DT("A")="Starting Date: " W ! D ^%DT S:$D(DTOUT) X="^" Q:U[X  G:Y<1 D1 S SDT=+Y

 I SDT'<DT W *7,"  [Must Start before Today!] " G D1

D2 ;

 S %DT="AEPX",%DT("A")=" Ending Date: " D ^%DT S:$D(DTOUT) X="^" Q:U[X  G:Y<1 D2 S EDT=+Y

 I EDT'<DT W *7,"  [Must End before Today!] " G D2

 I EDT<SDT W *7,"  [End before Start?] " G D1

KIL G KILL^XUSCLEAN Q

EXIT Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMADM3   4379     printed  Feb 18, 2025@23:14:12                                                                                                                                                                                                     Page 2

FHMADM3   ; HISC/REL/AAC - Additional Meals Report ;10/9/03  16:07

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

EN1       ; Print Meal Report

 +1        DO DT

           if "^"[X

               GOTO KIL

 +2       ;

 +3       ;Get Communication Offices data

 +4        FOR K=1:1:22

               SET SS(K)=0

               SET S(K)=0

 +5        SET CONUM=""

           SET ZCO=""

           SET COXX=""

           SET CO=""

           SET CONAME=""

           SET CONAM=""

           SET COUNT=0

 +6       ;S ZZOUT=$G(^FH(119.73,0)),ZOUT=$P(ZZOUT,"^",4)

 +7        SET ZZCOUNT=0

           FOR ZZCOUNT=0:0

               SET ZZCOUNT=$ORDER(^FH(119.73,ZZCOUNT))

               if ZZCOUNT'>0

                   QUIT

               SET ZOUT=ZZCOUNT

 +8       ;

 +9        READ !,"Print report for all Communications Offices Y or N: ",ZCO:DTIME

           WRITE !

           SET ZCO=$TRANSLATE(ZCO,"y","Y")

           IF ZCO'="Y"

               DO N2

               GOTO KIL

               QUIT

 +10      ;

PRINT      WRITE !!,"The report requires a 132 column printer.",!

 +1        KILL IOP,%ZIS

           SET %ZIS("A")="Print on Device: "

           SET %ZIS="MQ"

           WRITE !

           DO ^%ZIS

           KILL %ZIS,IOP

           if POP

               GOTO KIL

 +2        IF $DATA(IO("Q"))

               SET FHPGM="Q1^FHMADM3"

               SET FHLST="CONAME^CO^CONUMX^EDT^SDT^ZCO^COUNT^ZOUT^S(^SS("

               DO EN2^FH

               GOTO KIL

 +3        USE IO

           DO Q1

           DO ^%ZISC

           KILL %ZIS,IOP

           GOTO KIL

 +4       ;

Q1        ; Process Printing the Meal Report

 +1       ;

 +2        SET DTP=SDT\1

           DO DTP^FH

           SET DTE=DTP_" to "

           SET DTP=EDT\1

           DO DTP^FH

           SET DTE=DTE_DTP

 +3        SET X=SDT

           DO DOW^%DTC

           SET DOW=Y+1

 +4        DO NOW^%DTC

           SET DTP=%

           DO DTP^FH

           SET HDT=DTP

           SET PG=0

 +5       ;

Q2        ;

 +1       ;Get Specific Communication Offices

 +2        IF ZCO'="Y"

               SET CONUMX=CONUMX-1

               if CONUMX=0

                   GOTO QUIT

               SET COXX=$PIECE(CO,"^",CONUMX)

               SET NAME=$PIECE(CONAME,"^",CONUMX)

               if $DATA(^FH(119.73,COXX,"I"))

                   GOTO Q2

               if '$DATA(^FH(119.73,COXX,0))

                   GOTO Q2

 +3        IF ZCO="Y"

               SET COUNT=COUNT+1

               if COUNT>ZOUT

                   GOTO QUIT

               SET NAME=$GET(^FH(119.73,COUNT,0))

               SET NAME=$PIECE(NAME,"^")

               if $DATA(^FH(119.73,COUNT,"I"))

                   GOTO Q2

               if '$DATA(^FH(119.73,COUNT,0))

                   GOTO Q2

 +4       ;W @IOF

 +5        DO HDR

 +6        SET DOW=Y+1

           DO Q3

 +7        IF ZCO'="Y"

               IF CONUMX>0

                   GOTO Q2

 +8        IF ZCO="Y"

               GOTO Q2

 +9        QUIT

 +10      ;

QUIT      ;

 +1       ;W @IOF

 +2        SET NAME="Total All Communications Offices "

 +3        DO HDR

 +4        DO FTOTALS

 +5        DO LN

           DO LN

 +6        QUIT

 +7       ;

Q3         FOR L1=19:1:22

               SET N(L1)=0

 +1        SET D1=SDT

           FOR L1=0:0

               DO N1

               SET X1=D1

               SET X2=1

               DO C^%DTC

               if X>EDT

                   QUIT

               SET D1=X

               SET DOW=DOW+1

               if DOW=8

                   SET DOW=1

 +2       ;

TOTALS    ;

 +1       ;Print Totals

 +2        FOR K=1:1:22

               SET Z=$SELECT(K<19:5,1:6)

               SET S(K)=$SELECT(S(K)<1:$JUSTIFY("",Z),S(K)<10000:$JUSTIFY(S(K),Z-1)_" ",1:$JUSTIFY(S(K),Z))

 +3       ;

 +4        DO LN

           WRITE !,"  Total",?10,"|",S(1),S(2),S(3),S(4),S(5),S(6),S(19)," |",S(7),S(8),S(9),S(10),S(11),S(12),S(20)," |",S(13),S(14),S(15),S(16),S(17),S(18),S(21)," |",S(22),!

 +5        QUIT

 +6       ;

FTOTALS   ; Final Totals

 +1       ;

 +2        FOR K=1:1:22

               SET Z=$SELECT(K<19:5,1:6)

               SET SS(K)=$SELECT(SS(K)<1:$JUSTIFY("",Z),SS(K)<10000:$JUSTIFY(SS(K),Z-1)_" ",1:$JUSTIFY(SS(K),Z))

 +3       ;

 +4        WRITE !,"ALL Total",?10,"|",SS(1),SS(2),SS(3),SS(4),SS(5),SS(6),SS(19)," |",SS(7),SS(8),SS(9),SS(10),SS(11),SS(12),SS(20)," |",SS(13),SS(14),SS(15),SS(16),SS(17),SS(18),SS(21)," |",SS(22),!

 +5        QUIT

 +6       ;

HDR       ;Print page headers

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

               WRITE @IOF

           SET PG=PG+1

           WRITE !,HDT,?50,"A D D I T I O N A L   M E A L S",?125,"Page ",PG

 +2        WRITE !!,?1,NAME

 +3        WRITE !!?(131-$LENGTH(DTE)\2),DTE

 +4        WRITE !!,?10,"|",?21,"B R E A K F A S T",?48,"|",?64,"N O O N",?86,"|",?99,"E V E N I N G",?124,"| TOTAL"

 +5        WRITE !,?10,"| Opt. Emp. Paid OOD  Vol. Grt. Total | Opt. Emp. Paid OOD  Vol. Grt. Total | Opt. Emp. Paid OOD  Vol. Grt. Total |"

LN         WRITE !,"-----------------------------------------------------------------------------------------------------------------------------------"

 +1        QUIT

 +2       ;

N1        ;Get specific records based on Communications Offices,Start/End Dates, etc

 +1        IF ZCO'="Y"

               FOR CONUM=1:1

                   if CONUM>ZOUT

                       QUIT

                   SET Y0=$GET(^FH(117,D1,2,CONUM,0))

                   SET Y2=$PIECE(Y0,"^")

                   SET Y1=$PIECE(Y0,"^",2,99)

                   if COXX=Y2

                       QUIT

 +2       ;

 +3        IF ZCO="Y"

               FOR CONUM=1:1

                   if CONUM>ZOUT

                       QUIT

                   SET Y0=$GET(^FH(117,D1,2,CONUM,0))

                   SET Y2=$PIECE(Y0,"^")

                   SET Y1=$PIECE(Y0,"^",2,99)

                   if COUNT=Y2

                       QUIT

 +4       ;

 +5        SET K=0

           FOR L1=1:1:6

               FOR L2=1:1:3

                   SET K=K+1

                   SET N=L2-1*6+L1

                   SET Z=$PIECE(Y1,"^",K)

                   SET N(N)=Z

                   SET N(18+L2)=N(18+L2)+Z

 +6        SET N(22)=N(19)+N(20)+N(21)

 +7       ;

 +8        FOR K=1:1:22

               SET S(K)=S(K)+N(K)

               SET SS(K)=SS(K)+N(K)

               SET N(K)=$JUSTIFY($SELECT(N(K)<1:"",1:N(K)),$SELECT(K<19:4,1:5))_" "

 +9       ;

 +10       SET DTP=D1

           DO DTP^FH

           if $Y>(IOSL-8)

               DO HDR

 +11       WRITE !,$PIECE("Sun Mon Tue Wed Thu Fri Sat"," ",DOW)," ",$EXTRACT(DTP,1,6)

 +12       WRITE "|",N(1),N(2),N(3),N(4),N(5),N(6),N(19)," |",N(7),N(8),N(9),N(10),N(11),N(12),N(20)," |",N(13),N(14),N(15),N(16),N(17),N(18),N(21)," |",N(22)

           QUIT

 +13      ;

N2        ;Get Communciation Offices

 +1        SET DIC=119.73

           SET DIC(0)="AEQ"

           SET DIC("A")="Select Communication Offices: "

 +2        DO ^DIC

           IF (Y=-1)&(CO="")

               QUIT

 +3        IF Y=-1

               GOTO PRINT

               QUIT

 +4        SET CON=$PIECE(Y,"^",1)

           SET CO=CON_"^"_CO

           SET CONAM=$PIECE(Y,"^",2)

           SET CONAME=CONAM_"^"_CONAME

           SET CONUMX=$LENGTH(CO,"^")

           GOTO N2

           QUIT

 +5        IF Y=-1

               KILL DIC

               QUIT

 +6       ;

DT        ; Get From/To Dates

D1         SET %DT="AEPX"

           SET %DT("A")="Starting Date: "

           WRITE !

           DO ^%DT

           if $DATA(DTOUT)

               SET X="^"

           if U[X

               QUIT

           if Y<1

               GOTO D1

           SET SDT=+Y

 +1        IF SDT'<DT

               WRITE *7,"  [Must Start before Today!] "

               GOTO D1

 +2       ;

D2        ;

 +1        SET %DT="AEPX"

           SET %DT("A")=" Ending Date: "

           DO ^%DT

           if $DATA(DTOUT)

               SET X="^"

           if U[X

               QUIT

           if Y<1

               GOTO D2

           SET EDT=+Y

 +2        IF EDT'<DT

               WRITE *7,"  [Must End before Today!] "

               GOTO D2

 +3        IF EDT<SDT

               WRITE *7,"  [End before Start?] "

               GOTO D1

 +4        QUIT

 +5       ;

KIL        GOTO KILL^XUSCLEAN

           QUIT

EXIT       QUIT

FHMADM3.m