FHOMRL1 ;Hines OIFO/RTK OUTPATIENT MEALS RECURRING MEALS LIST ;1/25/05 11:35
;;5.5;DIETETICS;**1,5**;Dec 22, 2004;Build 53
;
W @IOF,!!?20,"R E C U R R I N G M E A L S L I S T"
START S (FHSELOC,FHSLCOM,FHSLPRO)=""
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=""
.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=""
.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 X1=STDT,X2=-1 D C^%DTC S STDT=X
D DEV,START
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 DISP,^%ZISC,END Q
S ZTRTN="DISP^FHOMRL1"
S ZTSAVE("STDT")="",ZTSAVE("ENDT")="",ZTSAVE("FHDFN")=""
S ZTSAVE("FHLBY")="",ZTSAVE("FHSELOC")="",ZTSAVE("FHSLCOM")="",ZTSAVE("FHSLPRO")=""
S ZTDESC="Outpatient Meals Recurring Meals List" D ^%ZTLOAD
D ^%ZISC K %ZIS,IOP
D END Q
Q
DISP ; First build data in ^TMP global
K ^TMP($J) S EX="",FHPG=0
F FHXRDT=STDT:0 S FHXRDT=$O(^FHPT("RM",FHXRDT)) Q:FHXRDT'>0!(FHXRDT>ENDT)!(EX=U) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHXRDT,FHDFN)) Q:FHDFN'>0!(EX=U) D
..F FHRM=0:0 S FHRM=$O(^FHPT("RM",FHXRDT,FHDFN,FHRM)) Q:FHRM'>0!(EX=U) D
...S FHZN=$G(^FHPT(FHDFN,"OP",FHRM,0)),FHST=$P(FHZN,U,15) I FHST="C" Q
...D PATNAME^FHOMUTL
...S FHLOC=$P(FHZN,U,3) 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,FHXRDT,FHPTNM_"~"_FHRM_"~"_FHDFN)=FHZN
...Q
..Q
.Q
; Now display data from the ^TMP global
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 FHXRDT=0:0 S FHXRDT=$O(^TMP($J,FHLSRT,FHXRDT)) Q:FHXRDT'>0!(EX=U) D
..S FHPTN="" F S FHPTN=$O(^TMP($J,FHLSRT,FHXRDT,FHPTN)) Q:FHPTN=""!(EX=U) D
...S FHZN=$G(^TMP($J,FHLSRT,FHXRDT,FHPTN)),FHLOC=$P(FHZN,U,3)
...S FHLOCZN=$G(^FH(119.6,FHLOC,0)),FHRNUM=$P(FHPTN,"~",2)
...S FHRMBD=$P(FHZN,U,18),FHRMBNM=""
...I FHRMBD'="" S FHRMBNM=$E($P($G(^DG(405.4,FHRMBD,0)),U,1),1,14)
...S FHDFN=$P(FHPTN,"~",3)
...W ! S DTP=FHXRDT D DTP^FH W DTP
...W ?11,$E($P(FHPTN,"~",1),1,19)
...W ?32,$P(FHZN,U,4)
...S FHSRV=$P(FHLOCZN,U,10)
...S FHSPT=$S(FHSRV["T":$P(FHLOCZN,U,5),FHSRV["C":$P(FHLOCZN,U,6),1:"")
...S FHSRVPT="" I FHSPT'="" S FHSRVPT=$P($G(^FH(119.72,FHSPT,0)),U,1)
...W ?36,$E(FHSRVPT,1,11),?48,FHRMBNM
...I $P($G(^FH(119.6,FHLOC,1)),U,4)="Y" D DIETPAT^FHOMRR1 W ?64,$E(FHDIETP,1,16)
...I $P($G(^FH(119.6,FHLOC,1)),U,4)'="Y" S FHDPTR=$P(FHZN,U,2) Q:FHDPTR="" W ?64,$E($P($G(^FH(111,FHDPTR,0)),U,1),1,16)
...I $Y>(IOSL-4) D PG I EX=U Q
Q
PG ;
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 !?25,"R E C U R R I N G M E A L L I S T"
W !!?5,"LOCATION: ",$P(FHLSRT,"~",2)
W !!,"Date",?11,"Patient Name",?31,"Meal",?36,"Service Pnt"
W ?48,"Room-Bed",?64,"Diet Ordered"
W !,"=========",?11,"===================",?31,"===="
W ?36,"===========",?48,"==============",?64,"================"
Q
END ;
K ENDT,FHXRDT,FHRM,FHST,FHSLCOM,FHSLPRO,FHZN,STDT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMRL1 3840 printed Apr 09, 2024@20:51:47 Page 2
FHOMRL1 ;Hines OIFO/RTK OUTPATIENT MEALS RECURRING MEALS LIST ;1/25/05 11:35
+1 ;;5.5;DIETETICS;**1,5**;Dec 22, 2004;Build 53
+2 ;
+3 WRITE @IOF,!!?20,"R E C U R R I N G M E A L S L I S T"
START SET (FHSELOC,FHSLCOM,FHSLPRO)=""
+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 WRITE !
KILL DIC
SET DIC=119.73
SET DIC("A")="Select Communication Office: "
+7 SET DIC(0)="AEQZ"
DO ^DIC
if $DATA(DUOUT)
QUIT
IF Y=-1
SET FHSLCOM=""
QUIT
+8 SET FHSLCOM=+Y
End DoDot:1
if FHSLCOM=""
QUIT
+9 IF FHLBY="P"
Begin DoDot:1
+10 WRITE !
KILL DIC
SET DIC=119.71
SET DIC("A")="Select Production Facility: "
+11 SET DIC(0)="AEQZ"
DO ^DIC
if $DATA(DUOUT)
QUIT
IF Y=-1
SET FHSLPRO=""
QUIT
+12 SET FHSLPRO=+Y
End DoDot:1
if FHSLPRO=""
QUIT
+13 WRITE !
DO STDATE^FHOMUTL
IF STDT=""
QUIT
+14 WRITE !
DO ENDATE^FHOMUTL
IF ENDT=""
QUIT
+15 SET X1=STDT
SET X2=-1
DO C^%DTC
SET STDT=X
+16 DO DEV
DO START
+17 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 DISP
DO ^%ZISC
DO END
QUIT
+3 SET ZTRTN="DISP^FHOMRL1"
+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="Outpatient Meals Recurring Meals List"
DO ^%ZTLOAD
+7 DO ^%ZISC
KILL %ZIS,IOP
+8 DO END
QUIT
+9 QUIT
DISP ; First build data in ^TMP global
+1 KILL ^TMP($JOB)
SET EX=""
SET FHPG=0
+2 FOR FHXRDT=STDT:0
SET FHXRDT=$ORDER(^FHPT("RM",FHXRDT))
if FHXRDT'>0!(FHXRDT>ENDT)!(EX=U)
QUIT
Begin DoDot:1
+3 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",FHXRDT,FHDFN))
if FHDFN'>0!(EX=U)
QUIT
Begin DoDot:2
+4 FOR FHRM=0:0
SET FHRM=$ORDER(^FHPT("RM",FHXRDT,FHDFN,FHRM))
if FHRM'>0!(EX=U)
QUIT
Begin DoDot:3
+5 SET FHZN=$GET(^FHPT(FHDFN,"OP",FHRM,0))
SET FHST=$PIECE(FHZN,U,15)
IF FHST="C"
QUIT
+6 DO PATNAME^FHOMUTL
+7 SET FHLOC=$PIECE(FHZN,U,3)
if FHLOC=""
QUIT
IF FHLBY="L"
IF FHSELOC'=FHLOC
QUIT
+8 SET FHCOMM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,8)
IF FHLBY="C"
IF FHSLCOM'=FHCOMM
QUIT
+9 SET FHPRD=$PIECE($GET(^FH(119.73,FHCOMM,0)),U,4)
IF FHLBY="P"
IF FHSLPRO'=FHPRD
QUIT
+10 SET FHPRORD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,4)
IF FHPRORD=""
SET FHPRORD=99
+11 SET FHPRORD=$SELECT(FHPRORD<1:99,FHPRORD<10:"0"_FHPRORD,1:FHPRORD)
+12 SET FHLOCNM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
+13 SET ^TMP($JOB,FHPRORD_"~"_FHLOCNM,FHXRDT,FHPTNM_"~"_FHRM_"~"_FHDFN)=FHZN
+14 QUIT
End DoDot:3
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 ; Now display data from the ^TMP global
+18 SET FHLSRT=""
FOR
SET FHLSRT=$ORDER(^TMP($JOB,FHLSRT))
if FHLSRT=""!(EX=U)
QUIT
Begin DoDot:1
+19 if FHPG>0&(IOST?1"C".E)
DO PG
if EX=U
QUIT
+20 DO HDR
SET FHPG=FHPG+1
+21 FOR FHXRDT=0:0
SET FHXRDT=$ORDER(^TMP($JOB,FHLSRT,FHXRDT))
if FHXRDT'>0!(EX=U)
QUIT
Begin DoDot:2
+22 SET FHPTN=""
FOR
SET FHPTN=$ORDER(^TMP($JOB,FHLSRT,FHXRDT,FHPTN))
if FHPTN=""!(EX=U)
QUIT
Begin DoDot:3
+23 SET FHZN=$GET(^TMP($JOB,FHLSRT,FHXRDT,FHPTN))
SET FHLOC=$PIECE(FHZN,U,3)
+24 SET FHLOCZN=$GET(^FH(119.6,FHLOC,0))
SET FHRNUM=$PIECE(FHPTN,"~",2)
+25 SET FHRMBD=$PIECE(FHZN,U,18)
SET FHRMBNM=""
+26 IF FHRMBD'=""
SET FHRMBNM=$EXTRACT($PIECE($GET(^DG(405.4,FHRMBD,0)),U,1),1,14)
+27 SET FHDFN=$PIECE(FHPTN,"~",3)
+28 WRITE !
SET DTP=FHXRDT
DO DTP^FH
WRITE DTP
+29 WRITE ?11,$EXTRACT($PIECE(FHPTN,"~",1),1,19)
+30 WRITE ?32,$PIECE(FHZN,U,4)
+31 SET FHSRV=$PIECE(FHLOCZN,U,10)
+32 SET FHSPT=$SELECT(FHSRV["T":$PIECE(FHLOCZN,U,5),FHSRV["C":$PIECE(FHLOCZN,U,6),1:"")
+33 SET FHSRVPT=""
IF FHSPT'=""
SET FHSRVPT=$PIECE($GET(^FH(119.72,FHSPT,0)),U,1)
+34 WRITE ?36,$EXTRACT(FHSRVPT,1,11),?48,FHRMBNM
+35 IF $PIECE($GET(^FH(119.6,FHLOC,1)),U,4)="Y"
DO DIETPAT^FHOMRR1
WRITE ?64,$EXTRACT(FHDIETP,1,16)
+36 IF $PIECE($GET(^FH(119.6,FHLOC,1)),U,4)'="Y"
SET FHDPTR=$PIECE(FHZN,U,2)
if FHDPTR=""
QUIT
WRITE ?64,$EXTRACT($PIECE($GET(^FH(111,FHDPTR,0)),U,1),1,16)
+37 IF $Y>(IOSL-4)
DO PG
IF EX=U
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+38 QUIT
PG ;
+1 IF IOST?1"C".E
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET EX=U
QUIT
+2 DO HDR
QUIT
HDR ;
+1 if $Y
WRITE @IOF
+2 WRITE !?25,"R E C U R R I N G M E A L L I S T"
+3 WRITE !!?5,"LOCATION: ",$PIECE(FHLSRT,"~",2)
+4 WRITE !!,"Date",?11,"Patient Name",?31,"Meal",?36,"Service Pnt"
+5 WRITE ?48,"Room-Bed",?64,"Diet Ordered"
+6 WRITE !,"=========",?11,"===================",?31,"===="
+7 WRITE ?36,"===========",?48,"==============",?64,"================"
+8 QUIT
END ;
+1 KILL ENDT,FHXRDT,FHRM,FHST,FHSLCOM,FHSLPRO,FHZN,STDT
QUIT
