FHOMGP1 ;Hines OIFO/RTK PRINT GUEST MEALS LIST ; 8/27/19 3:09pm
;;5.5;DIETETICS;**5,52**;Jan 28, 2005;Build 4
;
W @IOF,!!?20,"G U E S T M E A L S L I S T"
EN ;
W !! K DIR S DIR("A")="Print by LOCATION, COMM OFFICE, PRODUCTION FACILITY or ALL: "
S DIR(0)="SAO^A:ALL;C:COMM OFFICE;L:LOCATION;P:PROD FACILITY" D ^DIR
Q:$D(DIRUT) S FHLBY=Y
I FHLBY="L" W ! D OUTLOC^FHOMUTL Q:FHLOC="" S FHSELOC=FHLOC,FHLOC=""
I FHLBY="C" D Q:FHSLCOM=""
. S FHSLCOM=""
.W ! K DIC S DIC=119.73,DIC("A")="Select Communication Office: "
.S DIC(0)="AEQZ" D ^DIC Q:$D(DUOUT) I Y=-1 S FHSLCOM="" Q
.S FHSLCOM=+Y
I FHLBY="P" D Q:FHSLPRO=""
. S FHSLPRO=""
.W ! K DIC S DIC=119.71,DIC("A")="Select Production Facility: "
.S DIC(0)="AEQZ" D ^DIC Q:$D(DUOUT) I Y=-1 S FHSLPRO="" Q
.S FHSLPRO=+Y
W ! D STDATE^FHOMUTL I STDT="" Q
W ! D ENDATE^FHOMUTL I ENDT="" Q
S ENDT=ENDT_.99
D DEV,EN Q
DEV ;get device and set up queue
W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP
I '$D(IO("Q")) U IO D LIST,^%ZISC,END Q
S ZTRTN="LIST^FHOMGP1"
S ZTSAVE("STDT")="",ZTSAVE("ENDT")="",ZTSAVE("FHDFN")=""
S ZTSAVE("FHLBY")="",ZTSAVE("FHSELOC")="",ZTSAVE("FHSLCOM")="",ZTSAVE("FHSLPRO")=""
S ZTDESC="Guest Meals Display" D ^%ZTLOAD
D ^%ZISC K %ZIS,IOP
D END Q
LIST ; First build data in ^TMP global
K ^TMP($J) S NUM=0,EX="",FHPG=0
F FHGMDT=STDT:0 S FHGMDT=$O(^FHPT("GM",FHGMDT)) Q:FHGMDT'>0!(FHGMDT>ENDT) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHGMDT,FHDFN)) Q:FHDFN'>0 D
..S FHZN=$G(^FHPT(FHDFN,"GM",FHGMDT,0)),FHST=$P(FHZN,U,9) I FHST="C" Q
..D PATNAME^FHOMUTL
..S FHLOC=$P(FHZN,U,5) Q:FHLOC="" I FHLBY="L",FHSELOC'=FHLOC Q
..S FHCOMM=$P($G(^FH(119.6,FHLOC,0)),U,8) I FHLBY="C",FHSLCOM'=FHCOMM Q
..S FHPRD=$P($G(^FH(119.73,FHCOMM,0)),U,4) I FHLBY="P",FHSLPRO'=FHPRD Q
..S FHPRORD=$P($G(^FH(119.6,FHLOC,0)),U,4) I FHPRORD="" S FHPRORD=99
..S FHPRORD=$S(FHPRORD<1:99,FHPRORD<10:"0"_FHPRORD,1:FHPRORD)
..S FHLOCNM=$P($G(^FH(119.6,FHLOC,0)),U,1)
..S ^TMP($J,FHPRORD_"~"_FHLOCNM,FHGMDT,FHPTNM_"~"_FHDFN)=FHZN
..Q
.Q
; Now display data from the ^TMP global
I '$D(^TMP($J)) W !!,"THERE ARE CURRENTLY NO GUEST MEALS TO PRINT" Q
S FHLSRT="" F S FHLSRT=$O(^TMP($J,FHLSRT)) Q:FHLSRT=""!(EX=U) D
.D:FHPG>0&(IOST?1"C".E) PG Q:EX=U
.D HDR S FHPG=FHPG+1
.F FHGMDT=0:0 S FHGMDT=$O(^TMP($J,FHLSRT,FHGMDT)) Q:FHGMDT'>0!(EX=U) D
..S FHPTN="" F S FHPTN=$O(^TMP($J,FHLSRT,FHGMDT,FHPTN)) Q:FHPTN=""!(EX=U) D
...S FHNODE=$G(^TMP($J,FHLSRT,FHGMDT,FHPTN)),FHLOC=$P(FHNODE,U,5)
...S FHLOCZN=$G(^FH(119.6,FHLOC,0))
...S FHRMBD=$P(FHNODE,U,11),FHRMBNM=""
...I FHRMBD'="" S FHRMBNM=$E($P($G(^DG(405.4,FHRMBD,0)),U,1),1,11)
...S FHDFN=$P(FHPTN,"~",2) ;,FHLIST(NUM)=FHDFN_"^"_FHGMDT
...S FHCL=$P(FHNODE,U,2),FHML=$P(FHNODE,U,3),FHCH=$P(FHNODE,U,4)
...S FHSTAT=$P(FHNODE,U,9),NUM=NUM+1
...S FHCL=$S(FHCL="E":"EMP",FHCL="G":"GRAT",FHCL="O":"OOD",FHCL="P":"PAID",1:"VOL")
...S FHLOC=$E($P($G(^FH(119.6,FHLOC,0)),U,1),1,12)
...; S PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM
...D PATNAME^FHOMUTL W !,$E(FHPTNM,1,22)
...S FHD=$$FMTE^XLFDT(FHGMDT,"P") W ?22,$E(FHD,1,12)
...W ?36,FHLOC,?49,FHRMBNM,?62,FHML,?67,FHCL,?74,FHCH
...S FHLIST(NUM)=FHDFN_"^"_FHGMDT
...I $Y>(IOSL-4) D PG I EX=U Q
..Q
.Q
Q
END ;
K DIR,ENDT,STDT,FHGMDT,FHML,FHCL,FHCH,FHSELOC,FHSLCOM,FHNODE,FHZN
K FHSLPRO,FHPRD
Q
PG ;
;Q:$O(^FHPT(FHDFN,"GM",FHGMDT))'>0
I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q
D HDR Q
HDR ;
W:$Y @IOF
W !?5,"G U E S T M E A L L I S T"
W !!?5,"LOCATION: ",$P(FHLSRT,"~",2)
W !!,"Name",?22,"Date",?36,"Location",?49,"Room-Bed",?61,"Meal"
W ?67,"Class",?74,"Charge"
W !,"====================",?22,"============"
W ?36,"============ ===========",?61,"====",?67,"=====",?74,"======"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMGP1 3785 printed Sep 23, 2025@19:28:46 Page 2
FHOMGP1 ;Hines OIFO/RTK PRINT GUEST MEALS LIST ; 8/27/19 3:09pm
+1 ;;5.5;DIETETICS;**5,52**;Jan 28, 2005;Build 4
+2 ;
+3 WRITE @IOF,!!?20,"G U E S T M E A L S L I S T"
EN ;
+1 WRITE !!
KILL DIR
SET DIR("A")="Print by LOCATION, COMM OFFICE, PRODUCTION FACILITY or ALL: "
+2 SET DIR(0)="SAO^A:ALL;C:COMM OFFICE;L:LOCATION;P:PROD FACILITY"
DO ^DIR
+3 if $DATA(DIRUT)
QUIT
SET FHLBY=Y
+4 IF FHLBY="L"
WRITE !
DO OUTLOC^FHOMUTL
if FHLOC=""
QUIT
SET FHSELOC=FHLOC
SET FHLOC=""
+5 IF FHLBY="C"
Begin DoDot:1
+6 SET FHSLCOM=""
+7 WRITE !
KILL DIC
SET DIC=119.73
SET DIC("A")="Select Communication Office: "
+8 SET DIC(0)="AEQZ"
DO ^DIC
if $DATA(DUOUT)
QUIT
IF Y=-1
SET FHSLCOM=""
QUIT
+9 SET FHSLCOM=+Y
End DoDot:1
if FHSLCOM=""
QUIT
+10 IF FHLBY="P"
Begin DoDot:1
+11 SET FHSLPRO=""
+12 WRITE !
KILL DIC
SET DIC=119.71
SET DIC("A")="Select Production Facility: "
+13 SET DIC(0)="AEQZ"
DO ^DIC
if $DATA(DUOUT)
QUIT
IF Y=-1
SET FHSLPRO=""
QUIT
+14 SET FHSLPRO=+Y
End DoDot:1
if FHSLPRO=""
QUIT
+15 WRITE !
DO STDATE^FHOMUTL
IF STDT=""
QUIT
+16 WRITE !
DO ENDATE^FHOMUTL
IF ENDT=""
QUIT
+17 SET ENDT=ENDT_.99
+18 DO DEV
DO EN
QUIT
DEV ;get device and set up queue
+1 WRITE !
KILL %ZIS,IOP
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+2 IF '$DATA(IO("Q"))
USE IO
DO LIST
DO ^%ZISC
DO END
QUIT
+3 SET ZTRTN="LIST^FHOMGP1"
+4 SET ZTSAVE("STDT")=""
SET ZTSAVE("ENDT")=""
SET ZTSAVE("FHDFN")=""
+5 SET ZTSAVE("FHLBY")=""
SET ZTSAVE("FHSELOC")=""
SET ZTSAVE("FHSLCOM")=""
SET ZTSAVE("FHSLPRO")=""
+6 SET ZTDESC="Guest Meals Display"
DO ^%ZTLOAD
+7 DO ^%ZISC
KILL %ZIS,IOP
+8 DO END
QUIT
LIST ; First build data in ^TMP global
+1 KILL ^TMP($JOB)
SET NUM=0
SET EX=""
SET FHPG=0
+2 FOR FHGMDT=STDT:0
SET FHGMDT=$ORDER(^FHPT("GM",FHGMDT))
if FHGMDT'>0!(FHGMDT>ENDT)
QUIT
Begin DoDot:1
+3 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("GM",FHGMDT,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+4 SET FHZN=$GET(^FHPT(FHDFN,"GM",FHGMDT,0))
SET FHST=$PIECE(FHZN,U,9)
IF FHST="C"
QUIT
+5 DO PATNAME^FHOMUTL
+6 SET FHLOC=$PIECE(FHZN,U,5)
if FHLOC=""
QUIT
IF FHLBY="L"
IF FHSELOC'=FHLOC
QUIT
+7 SET FHCOMM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,8)
IF FHLBY="C"
IF FHSLCOM'=FHCOMM
QUIT
+8 SET FHPRD=$PIECE($GET(^FH(119.73,FHCOMM,0)),U,4)
IF FHLBY="P"
IF FHSLPRO'=FHPRD
QUIT
+9 SET FHPRORD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,4)
IF FHPRORD=""
SET FHPRORD=99
+10 SET FHPRORD=$SELECT(FHPRORD<1:99,FHPRORD<10:"0"_FHPRORD,1:FHPRORD)
+11 SET FHLOCNM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
+12 SET ^TMP($JOB,FHPRORD_"~"_FHLOCNM,FHGMDT,FHPTNM_"~"_FHDFN)=FHZN
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ; Now display data from the ^TMP global
+16 IF '$DATA(^TMP($JOB))
WRITE !!,"THERE ARE CURRENTLY NO GUEST MEALS TO PRINT"
QUIT
+17 SET FHLSRT=""
FOR
SET FHLSRT=$ORDER(^TMP($JOB,FHLSRT))
if FHLSRT=""!(EX=U)
QUIT
Begin DoDot:1
+18 if FHPG>0&(IOST?1"C".E)
DO PG
if EX=U
QUIT
+19 DO HDR
SET FHPG=FHPG+1
+20 FOR FHGMDT=0:0
SET FHGMDT=$ORDER(^TMP($JOB,FHLSRT,FHGMDT))
if FHGMDT'>0!(EX=U)
QUIT
Begin DoDot:2
+21 SET FHPTN=""
FOR
SET FHPTN=$ORDER(^TMP($JOB,FHLSRT,FHGMDT,FHPTN))
if FHPTN=""!(EX=U)
QUIT
Begin DoDot:3
+22 SET FHNODE=$GET(^TMP($JOB,FHLSRT,FHGMDT,FHPTN))
SET FHLOC=$PIECE(FHNODE,U,5)
+23 SET FHLOCZN=$GET(^FH(119.6,FHLOC,0))
+24 SET FHRMBD=$PIECE(FHNODE,U,11)
SET FHRMBNM=""
+25 IF FHRMBD'=""
SET FHRMBNM=$EXTRACT($PIECE($GET(^DG(405.4,FHRMBD,0)),U,1),1,11)
+26 ;,FHLIST(NUM)=FHDFN_"^"_FHGMDT
SET FHDFN=$PIECE(FHPTN,"~",2)
+27 SET FHCL=$PIECE(FHNODE,U,2)
SET FHML=$PIECE(FHNODE,U,3)
SET FHCH=$PIECE(FHNODE,U,4)
+28 SET FHSTAT=$PIECE(FHNODE,U,9)
SET NUM=NUM+1
+29 SET FHCL=$SELECT(FHCL="E":"EMP",FHCL="G":"GRAT",FHCL="O":"OOD",FHCL="P":"PAID",1:"VOL")
+30 SET FHLOC=$EXTRACT($PIECE($GET(^FH(119.6,FHLOC,0)),U,1),1,12)
+31 ; S PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM
+32 DO PATNAME^FHOMUTL
WRITE !,$EXTRACT(FHPTNM,1,22)
+33 SET FHD=$$FMTE^XLFDT(FHGMDT,"P")
WRITE ?22,$EXTRACT(FHD,1,12)
+34 WRITE ?36,FHLOC,?49,FHRMBNM,?62,FHML,?67,FHCL,?74,FHCH
+35 SET FHLIST(NUM)=FHDFN_"^"_FHGMDT
+36 IF $Y>(IOSL-4)
DO PG
IF EX=U
QUIT
End DoDot:3
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
+39 QUIT
END ;
+1 KILL DIR,ENDT,STDT,FHGMDT,FHML,FHCL,FHCH,FHSELOC,FHSLCOM,FHNODE,FHZN
+2 KILL FHSLPRO,FHPRD
+3 QUIT
PG ;
+1 ;Q:$O(^FHPT(FHDFN,"GM",FHGMDT))'>0
+2 IF IOST?1"C".E
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET EX=U
QUIT
+3 DO HDR
QUIT
HDR ;
+1 if $Y
WRITE @IOF
+2 WRITE !?5,"G U E S T M E A L L I S T"
+3 WRITE !!?5,"LOCATION: ",$PIECE(FHLSRT,"~",2)
+4 WRITE !!,"Name",?22,"Date",?36,"Location",?49,"Room-Bed",?61,"Meal"
+5 WRITE ?67,"Class",?74,"Charge"
+6 WRITE !,"====================",?22,"============"
+7 WRITE ?36,"============ ===========",?61,"====",?67,"=====",?74,"======"
+8 QUIT
