FHOMCBRP ;Hines OIFO/RTK COMBINED OUTPATIENT MEALS LIST ;6/30/03 15:45
;;5.5;DIETETICS;**5,15**;Jan 28, 2005;Build 2
;
W @IOF,!!,"C O M B I N E D O U T P A T I E N 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=""
.W ! K DIC S DIC=119.73,DIC("A")="Select Communication Office: "
.S DIC(0)="AEQZ" D ^DIC I $D(DUOUT) S FHSLCOM="" Q
.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 I $D(DUOUT) S FHSLPRO="" Q
.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 STDT1=X,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^FHOMCBRP",ZTDESC="Combined Outpatient Meals Display"
S ZTSAVE("STDT")="",ZTSAVE("STDT1")="",ZTSAVE("ENDT")=""
S ZTSAVE("FHLBY")="",ZTSAVE("FHSELOC")="",ZTSAVE("FHSLCOM")=""
S ZTSAVE("FHSLPRO")="" 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
;Recurring Meals
F FHXRDT=STDT1: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 FHML=$P(FHZN,U,4) Q:FHML="" S FHML=$S(FHML="B":1,FHML="N":2,FHML="E":3)
...S ^TMP($J,FHXRDT_"~"_FHML,FHPRORD_"~"_FHLOCNM_"~"_FHLOC,FHPTNM_"~"_FHDFN_"~"_FHRM)="R~"_FHZN
...Q
..Q
.Q
;Special Meals
S ENDT=ENDT_.99
F FHSMDT=STDT:0 S FHSMDT=$O(^FHPT("SM",FHSMDT)) Q:FHSMDT'>0!(FHSMDT>ENDT)!(EX=U) D
.S FHSMDTX=$E(FHSMDT,1,7)
.S FHDFN=$O(^FHPT("SM",FHSMDT,"")) D PATNAME^FHOMUTL
.S FHZN=$G(^FHPT(FHDFN,"SM",FHSMDT,0)),FHSTAT=$P(FHZN,U,2)
.I FHSTAT="C" Q
.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),FHML=$P(FHZN,U,9) Q:FHML=""
.S FHML=$S(FHML="B":1,FHML="N":2,FHML="E":3)
.S ^TMP($J,FHSMDTX_"~"_FHML,FHPRORD_"~"_FHLOCNM_"~"_FHLOC,FHPTNM_"~"_FHDFN)="S~"_FHZN
.Q
;Guest Meals
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 FHML=$P(FHZN,U,3) Q:FHML="" S FHML=$S(FHML="B":1,FHML="N":2,FHML="E":3)
..S FHGMDTX=$E(FHGMDT,1,7)
..S ^TMP($J,FHGMDTX_"~"_FHML,FHPRORD_"~"_FHLOCNM_"~"_FHLOC,FHPTNM_"~"_FHDFN)="G~"_FHZN
..Q
.Q
; Now display data from the ^TMP global
I '$D(^TMP($J)) W !!,"NO OUTPATIENT MEALS WITHIN SELECTED PARAMETERS" Q
S FHDTML="" F S FHDTML=$O(^TMP($J,FHDTML)) Q:FHDTML=""!(EX=U) D
.I FHPG<1 D HDR
.S FHWDT=$P(FHDTML,"~",1),FHWML=$P(FHDTML,"~",2)
.S FHWDT=$$FMTE^XLFDT(FHWDT,"P")
.S FHWML=$S(FHWML=1:"Breakfast",FHWML=2:"Noon",1:"Evening")
.S FHPG=FHPG+1
.S FHLOC="" F S FHLOC=$O(^TMP($J,FHDTML,FHLOC)) Q:FHLOC=""!(EX=U) D
..W !!,FHWDT,?14,"- ",FHWML,?28,"LOCATION: "
..W $P(FHLOC,"~",2),!,"Patient Name",?28,"Diet",?55,"Room-Bed"
..W !,"========================",?28,"========================"
..W ?55,"========================"
..S FHPTN="" F S FHPTN=$O(^TMP($J,FHDTML,FHLOC,FHPTN)) Q:FHPTN=""!(EX=U) D
...S FHNODE=$G(^TMP($J,FHDTML,FHLOC,FHPTN))
...W !,$E($P(FHPTN,"~",1),1,24)
...S FHPCE=2 S:$E(FHNODE,1)="S" FHPCE=4 S:$E(FHNODE,1)="G" FHPCE=6
...S FHDIET=$P(FHNODE,U,FHPCE)
...I FHDIET'="" W ?28,$E($P($G(^FH(111,FHDIET,0)),U,1),1,24)
...I $E(FHNODE,1)="R" I $P($G(^FH(119.6,$P(FHLOC,"~",3),1)),U,4)="Y" S FHDFN=$P(FHPTN,"~",2),FHRNUM=$P(FHPTN,"~",3) D DIETPAT^FHOMRR1 W ?28,$E(FHDIETP,1,24)
...S FHPCE=18 S:$E(FHNODE,1)="S" FHPCE=13 S:$E(FHNODE,1)="G" FHPCE=11
...S FHRMBD=$P(FHNODE,U,FHPCE),FHRMBNM=""
...I FHRMBD'="" S FHRMBNM=$E($P($G(^DG(405.4,FHRMBD,0)),U,1),1,24)
...W ?55,FHRMBNM
...I $Y>(IOSL-4) D PG I EX=U Q
...Q
..Q
.Q
Q
END ;
K DIR,ENDT,STDT,FHGMDT,FHGMDTX,FHRM,FHXRDT,FHSMDT,FHSMDTX,FHML,FHCL
K FHCH,FHDIET,FHLOC,FHPTN,FHSELOC,FHSLCOM,FHNODE,FHZN,FHSLPRO,FHPRD
K FHDIETP,FHPCE,FHPG
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 !,"C O M B I N E D O U T P A T I E N T M E A L S L I S T",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMCBRP 5812 printed Apr 09, 2024@21:00:45 Page 2
FHOMCBRP ;Hines OIFO/RTK COMBINED OUTPATIENT MEALS LIST ;6/30/03 15:45
+1 ;;5.5;DIETETICS;**5,15**;Jan 28, 2005;Build 2
+2 ;
+3 WRITE @IOF,!!,"C O M B I N E D O U T P A T I E N 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 WRITE !
KILL DIC
SET DIC=119.73
SET DIC("A")="Select Communication Office: "
+7 SET DIC(0)="AEQZ"
DO ^DIC
IF $DATA(DUOUT)
SET FHSLCOM=""
QUIT
+8 IF Y=-1
SET FHSLCOM=""
QUIT
+9 SET FHSLCOM=+Y
End DoDot:1
if FHSLCOM=""
QUIT
+10 IF FHLBY="P"
Begin DoDot:1
+11 WRITE !
KILL DIC
SET DIC=119.71
SET DIC("A")="Select Production Facility: "
+12 SET DIC(0)="AEQZ"
DO ^DIC
IF $DATA(DUOUT)
SET FHSLPRO=""
QUIT
+13 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 X1=STDT
SET X2=-1
DO C^%DTC
SET STDT1=X
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^FHOMCBRP"
SET ZTDESC="Combined Outpatient Meals Display"
+4 SET ZTSAVE("STDT")=""
SET ZTSAVE("STDT1")=""
SET ZTSAVE("ENDT")=""
+5 SET ZTSAVE("FHLBY")=""
SET ZTSAVE("FHSELOC")=""
SET ZTSAVE("FHSLCOM")=""
+6 SET ZTSAVE("FHSLPRO")=""
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 ;Recurring Meals
+3 FOR FHXRDT=STDT1:0
SET FHXRDT=$ORDER(^FHPT("RM",FHXRDT))
if FHXRDT'>0!(FHXRDT>ENDT)!(EX=U)
QUIT
Begin DoDot:1
+4 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",FHXRDT,FHDFN))
if FHDFN'>0!(EX=U)
QUIT
Begin DoDot:2
+5 FOR FHRM=0:0
SET FHRM=$ORDER(^FHPT("RM",FHXRDT,FHDFN,FHRM))
if FHRM'>0!(EX=U)
QUIT
Begin DoDot:3
+6 SET FHZN=$GET(^FHPT(FHDFN,"OP",FHRM,0))
SET FHST=$PIECE(FHZN,U,15)
IF FHST="C"
QUIT
+7 DO PATNAME^FHOMUTL
+8 SET FHLOC=$PIECE(FHZN,U,3)
if FHLOC=""
QUIT
IF FHLBY="L"
IF FHSELOC'=FHLOC
QUIT
+9 SET FHCOMM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,8)
IF FHLBY="C"
IF FHSLCOM'=FHCOMM
QUIT
+10 SET FHPRD=$PIECE($GET(^FH(119.73,FHCOMM,0)),U,4)
IF FHLBY="P"
IF FHSLPRO'=FHPRD
QUIT
+11 SET FHPRORD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,4)
IF FHPRORD=""
SET FHPRORD=99
+12 SET FHPRORD=$SELECT(FHPRORD<1:99,FHPRORD<10:"0"_FHPRORD,1:FHPRORD)
+13 SET FHLOCNM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
+14 SET FHML=$PIECE(FHZN,U,4)
if FHML=""
QUIT
SET FHML=$SELECT(FHML="B":1,FHML="N":2,FHML="E":3)
+15 SET ^TMP($JOB,FHXRDT_"~"_FHML,FHPRORD_"~"_FHLOCNM_"~"_FHLOC,FHPTNM_"~"_FHDFN_"~"_FHRM)="R~"_FHZN
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 ;Special Meals
+20 SET ENDT=ENDT_.99
+21 FOR FHSMDT=STDT:0
SET FHSMDT=$ORDER(^FHPT("SM",FHSMDT))
if FHSMDT'>0!(FHSMDT>ENDT)!(EX=U)
QUIT
Begin DoDot:1
+22 SET FHSMDTX=$EXTRACT(FHSMDT,1,7)
+23 SET FHDFN=$ORDER(^FHPT("SM",FHSMDT,""))
DO PATNAME^FHOMUTL
+24 SET FHZN=$GET(^FHPT(FHDFN,"SM",FHSMDT,0))
SET FHSTAT=$PIECE(FHZN,U,2)
+25 IF FHSTAT="C"
QUIT
+26 SET FHLOC=$PIECE(FHZN,U,3)
if FHLOC=""
QUIT
IF FHLBY="L"
IF FHSELOC'=FHLOC
QUIT
+27 SET FHCOMM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,8)
IF FHLBY="C"
IF FHSLCOM'=FHCOMM
QUIT
+28 SET FHPRD=$PIECE($GET(^FH(119.73,FHCOMM,0)),U,4)
IF FHLBY="P"
IF FHSLPRO'=FHPRD
QUIT
+29 SET FHPRORD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,4)
IF FHPRORD=""
SET FHPRORD=99
+30 SET FHPRORD=$SELECT(FHPRORD<1:99,FHPRORD<10:"0"_FHPRORD,1:FHPRORD)
+31 SET FHLOCNM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
SET FHML=$PIECE(FHZN,U,9)
if FHML=""
QUIT
+32 SET FHML=$SELECT(FHML="B":1,FHML="N":2,FHML="E":3)
+33 SET ^TMP($JOB,FHSMDTX_"~"_FHML,FHPRORD_"~"_FHLOCNM_"~"_FHLOC,FHPTNM_"~"_FHDFN)="S~"_FHZN
+34 QUIT
End DoDot:1
+35 ;Guest Meals
+36 FOR FHGMDT=STDT:0
SET FHGMDT=$ORDER(^FHPT("GM",FHGMDT))
if FHGMDT'>0!(FHGMDT>ENDT)
QUIT
Begin DoDot:1
+37 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("GM",FHGMDT,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+38 SET FHZN=$GET(^FHPT(FHDFN,"GM",FHGMDT,0))
SET FHST=$PIECE(FHZN,U,9)
IF FHST="C"
QUIT
+39 DO PATNAME^FHOMUTL
+40 SET FHLOC=$PIECE(FHZN,U,5)
if FHLOC=""
QUIT
IF FHLBY="L"
IF FHSELOC'=FHLOC
QUIT
+41 SET FHCOMM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,8)
IF FHLBY="C"
IF FHSLCOM'=FHCOMM
QUIT
+42 SET FHPRD=$PIECE($GET(^FH(119.73,FHCOMM,0)),U,4)
IF FHLBY="P"
IF FHSLPRO'=FHPRD
QUIT
+43 SET FHPRORD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,4)
IF FHPRORD=""
SET FHPRORD=99
+44 SET FHPRORD=$SELECT(FHPRORD<1:99,FHPRORD<10:"0"_FHPRORD,1:FHPRORD)
+45 SET FHLOCNM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
+46 SET FHML=$PIECE(FHZN,U,3)
if FHML=""
QUIT
SET FHML=$SELECT(FHML="B":1,FHML="N":2,FHML="E":3)
+47 SET FHGMDTX=$EXTRACT(FHGMDT,1,7)
+48 SET ^TMP($JOB,FHGMDTX_"~"_FHML,FHPRORD_"~"_FHLOCNM_"~"_FHLOC,FHPTNM_"~"_FHDFN)="G~"_FHZN
+49 QUIT
End DoDot:2
+50 QUIT
End DoDot:1
+51 ; Now display data from the ^TMP global
+52 IF '$DATA(^TMP($JOB))
WRITE !!,"NO OUTPATIENT MEALS WITHIN SELECTED PARAMETERS"
QUIT
+53 SET FHDTML=""
FOR
SET FHDTML=$ORDER(^TMP($JOB,FHDTML))
if FHDTML=""!(EX=U)
QUIT
Begin DoDot:1
+54 IF FHPG<1
DO HDR
+55 SET FHWDT=$PIECE(FHDTML,"~",1)
SET FHWML=$PIECE(FHDTML,"~",2)
+56 SET FHWDT=$$FMTE^XLFDT(FHWDT,"P")
+57 SET FHWML=$SELECT(FHWML=1:"Breakfast",FHWML=2:"Noon",1:"Evening")
+58 SET FHPG=FHPG+1
+59 SET FHLOC=""
FOR
SET FHLOC=$ORDER(^TMP($JOB,FHDTML,FHLOC))
if FHLOC=""!(EX=U)
QUIT
Begin DoDot:2
+60 WRITE !!,FHWDT,?14,"- ",FHWML,?28,"LOCATION: "
+61 WRITE $PIECE(FHLOC,"~",2),!,"Patient Name",?28,"Diet",?55,"Room-Bed"
+62 WRITE !,"========================",?28,"========================"
+63 WRITE ?55,"========================"
+64 SET FHPTN=""
FOR
SET FHPTN=$ORDER(^TMP($JOB,FHDTML,FHLOC,FHPTN))
if FHPTN=""!(EX=U)
QUIT
Begin DoDot:3
+65 SET FHNODE=$GET(^TMP($JOB,FHDTML,FHLOC,FHPTN))
+66 WRITE !,$EXTRACT($PIECE(FHPTN,"~",1),1,24)
+67 SET FHPCE=2
if $EXTRACT(FHNODE,1)="S"
SET FHPCE=4
if $EXTRACT(FHNODE,1)="G"
SET FHPCE=6
+68 SET FHDIET=$PIECE(FHNODE,U,FHPCE)
+69 IF FHDIET'=""
WRITE ?28,$EXTRACT($PIECE($GET(^FH(111,FHDIET,0)),U,1),1,24)
+70 IF $EXTRACT(FHNODE,1)="R"
IF $PIECE($GET(^FH(119.6,$PIECE(FHLOC,"~",3),1)),U,4)="Y"
SET FHDFN=$PIECE(FHPTN,"~",2)
SET FHRNUM=$PIECE(FHPTN,"~",3)
DO DIETPAT^FHOMRR1
WRITE ?28,$EXTRACT(FHDIETP,1,24)
+71 SET FHPCE=18
if $EXTRACT(FHNODE,1)="S"
SET FHPCE=13
if $EXTRACT(FHNODE,1)="G"
SET FHPCE=11
+72 SET FHRMBD=$PIECE(FHNODE,U,FHPCE)
SET FHRMBNM=""
+73 IF FHRMBD'=""
SET FHRMBNM=$EXTRACT($PIECE($GET(^DG(405.4,FHRMBD,0)),U,1),1,24)
+74 WRITE ?55,FHRMBNM
+75 IF $Y>(IOSL-4)
DO PG
IF EX=U
QUIT
+76 QUIT
End DoDot:3
+77 QUIT
End DoDot:2
+78 QUIT
End DoDot:1
+79 QUIT
END ;
+1 KILL DIR,ENDT,STDT,FHGMDT,FHGMDTX,FHRM,FHXRDT,FHSMDT,FHSMDTX,FHML,FHCL
+2 KILL FHCH,FHDIET,FHLOC,FHPTN,FHSELOC,FHSLCOM,FHNODE,FHZN,FHSLPRO,FHPRD
+3 KILL FHDIETP,FHPCE,FHPG
+4 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 !,"C O M B I N E D O U T P A T I E N T M E A L S L I S T",!!
+3 QUIT
