- 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 Feb 18, 2025@23:19:04 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