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
Q
;
QUIT ;
;W @IOF
S NAME="Total All Communications Offices "
D HDR
D FTOTALS
D LN,LN
Q
;
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),!
Q
;
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),!
Q
;
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 !,"-----------------------------------------------------------------------------------------------------------------------------------"
Q
;
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
Q
;
KIL G KILL^XUSCLEAN Q
EXIT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMADM3 4379 printed Dec 13, 2024@01:47:50 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
