- 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
- 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
