FHOMRP1 ;Hines OIFO/RTK RECURRING MEALS PRINT EXPIRING LIST ;4/17/03 09:45
;;5.5;DIETETICS;**1**;Jan 28, 2005
W ! K DIR,DIC S DIR("A")="Select Outpatient Ordering Location: "
S DIR(0)="PAO^119.6:EMQZ" D ^DIR Q:$D(DIRUT)
I Y'=-1 S FHLOC=+Y
S FHPARAM=$P($G(^FH(119.6,FHLOC,1)),U,3),FHNOEP=0
I FHPARAM="" D Q
.W !!?5,"NOTICE: No value set for 'NUMBER OF DAYS FOR REVIEW' "
.W !?5,"parameter -- CAN'T CONTINUE",!! Q
D NOW^%DTC S FHTODAY=X,X1=FHTODAY,X2=FHPARAM D C^%DTC S FHDSDT=X
S FHD=$$FMTE^XLFDT(FHDSDT,"P")
W ! K DIR,DIC S DIR("A")="Display recurring meals expiring by: "
S DIR(0)="DAEO^"_DT,DIR("B")=FHD D ^DIR Q:$D(DIRUT)
I Y'=-1 S FHNDAYS=+Y
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^FHOMRP1"
S ZTSAVE("FHLOC")="",ZTSAVE("FHPARAM")="",ZTSAVE("FHNDAYS")=""
S ZTSAVE("FHTODAY")="",ZTSAVE("FHNOEP")=""
S ZTDESC="Print Recurring Meals Expiration List" D ^%ZTLOAD
D ^%ZISC K %ZIS,IOP
D END Q
DISP ;
S FHLZN=$G(^FH(119.6,FHLOC,0)),FHLOCNM=$P(FHLZN,U,1)
W !!?2,"OUTPATIENT LOCATION: ",FHLOCNM
F FHDFN=0:0 S FHDFN=$O(^FHPT("C",FHLOC,FHDFN)) Q:FHDFN'>0 D
.S FHRNUM=$O(^FHPT("C",FHLOC,FHDFN,""),-1)
.S FHDT=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,1)
.I FHDT<FHNDAYS,FHDT>FHTODAY D
..S FHNODE=$G(^FHPT(FHDFN,"OP",FHRNUM,0))
..D PATNAME^FHOMUTL S FHNOEP=1
..S FHDATE=$$FMTE^XLFDT(FHDT,"P")
..W !!?3,FHPTNM," RECURRING DIET ORDER EXPIRES ON: ",$E(FHDATE,1,12)
..W !?26,"Ordering",?38,"Service",!?6,"Date/Time",?26,"Location"
..W ?38,"Point",?50,"Meal",?56,"Diet Ordered"
..W !?6,"==================",?26,"=========="
..W ?38,"==========",?50,"====",?56,"================"
..;S FHDTP=$$FMTE^XLFDT(FHRM,"P") W ?6,FHDOW," - ",$E(FHDTP,1,12)
..S FHLNM=$E($P(FHLZN,U,1),1,10),FHSERV=$P(FHLZN,U,10)
..S FHSRV=$S(FHSERV["T":$P(FHLZN,U,5),FHSERV["C":$P(FHLZN,U,6),1:"")
..I FHSRV="" S FHSRVPT="" Q
..S FHSRVPT=$P($G(^FH(119.72,FHSRV,0)),U,1)
..W !?6,$E(FHDATE,1,12),?26,FHLNM,?38,$E(FHSRVPT,1,9),?51,$P(FHNODE,U,4)
..I $P($G(^FH(119.6,FHLOC,1)),U,4)="Y" D DIETPAT^FHOMRR1 W ?56,$E(FHDIETP,1,24)
..I $P($G(^FH(119.6,FHLOC,1)),U,4)'="Y" S FHDPTR=$P(FHNODE,U,2) W ?56,$E($P($G(^FH(111,FHDPTR,0)),U,1),1,24)
I FHNOEP=0 D
.S FHDSPDT=$$FMTE^XLFDT(FHNDAYS,"P")
.W !!?3,"NO RECURRING MEAL PLANS EXPIRING FOR ",FHLOCNM
.W " BEFORE ",FHDSPDT,"."
Q
END ;
K FHLOC,FHPARAM Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMRP1 2433 printed Apr 09, 2024@20:58:34 Page 2
FHOMRP1 ;Hines OIFO/RTK RECURRING MEALS PRINT EXPIRING LIST ;4/17/03 09:45
+1 ;;5.5;DIETETICS;**1**;Jan 28, 2005
+2 WRITE !
KILL DIR,DIC
SET DIR("A")="Select Outpatient Ordering Location: "
+3 SET DIR(0)="PAO^119.6:EMQZ"
DO ^DIR
if $DATA(DIRUT)
QUIT
+4 IF Y'=-1
SET FHLOC=+Y
+5 SET FHPARAM=$PIECE($GET(^FH(119.6,FHLOC,1)),U,3)
SET FHNOEP=0
+6 IF FHPARAM=""
Begin DoDot:1
+7 WRITE !!?5,"NOTICE: No value set for 'NUMBER OF DAYS FOR REVIEW' "
+8 WRITE !?5,"parameter -- CAN'T CONTINUE",!!
QUIT
End DoDot:1
QUIT
+9 DO NOW^%DTC
SET FHTODAY=X
SET X1=FHTODAY
SET X2=FHPARAM
DO C^%DTC
SET FHDSDT=X
+10 SET FHD=$$FMTE^XLFDT(FHDSDT,"P")
+11 WRITE !
KILL DIR,DIC
SET DIR("A")="Display recurring meals expiring by: "
+12 SET DIR(0)="DAEO^"_DT
SET DIR("B")=FHD
DO ^DIR
if $DATA(DIRUT)
QUIT
+13 IF Y'=-1
SET FHNDAYS=+Y
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^FHOMRP1"
+4 SET ZTSAVE("FHLOC")=""
SET ZTSAVE("FHPARAM")=""
SET ZTSAVE("FHNDAYS")=""
+5 SET ZTSAVE("FHTODAY")=""
SET ZTSAVE("FHNOEP")=""
+6 SET ZTDESC="Print Recurring Meals Expiration List"
DO ^%ZTLOAD
+7 DO ^%ZISC
KILL %ZIS,IOP
+8 DO END
QUIT
DISP ;
+1 SET FHLZN=$GET(^FH(119.6,FHLOC,0))
SET FHLOCNM=$PIECE(FHLZN,U,1)
+2 WRITE !!?2,"OUTPATIENT LOCATION: ",FHLOCNM
+3 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("C",FHLOC,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:1
+4 SET FHRNUM=$ORDER(^FHPT("C",FHLOC,FHDFN,""),-1)
+5 SET FHDT=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,1)
+6 IF FHDT<FHNDAYS
IF FHDT>FHTODAY
Begin DoDot:2
+7 SET FHNODE=$GET(^FHPT(FHDFN,"OP",FHRNUM,0))
+8 DO PATNAME^FHOMUTL
SET FHNOEP=1
+9 SET FHDATE=$$FMTE^XLFDT(FHDT,"P")
+10 WRITE !!?3,FHPTNM," RECURRING DIET ORDER EXPIRES ON: ",$EXTRACT(FHDATE,1,12)
+11 WRITE !?26,"Ordering",?38,"Service",!?6,"Date/Time",?26,"Location"
+12 WRITE ?38,"Point",?50,"Meal",?56,"Diet Ordered"
+13 WRITE !?6,"==================",?26,"=========="
+14 WRITE ?38,"==========",?50,"====",?56,"================"
+15 ;S FHDTP=$$FMTE^XLFDT(FHRM,"P") W ?6,FHDOW," - ",$E(FHDTP,1,12)
+16 SET FHLNM=$EXTRACT($PIECE(FHLZN,U,1),1,10)
SET FHSERV=$PIECE(FHLZN,U,10)
+17 SET FHSRV=$SELECT(FHSERV["T":$PIECE(FHLZN,U,5),FHSERV["C":$PIECE(FHLZN,U,6),1:"")
+18 IF FHSRV=""
SET FHSRVPT=""
QUIT
+19 SET FHSRVPT=$PIECE($GET(^FH(119.72,FHSRV,0)),U,1)
+20 WRITE !?6,$EXTRACT(FHDATE,1,12),?26,FHLNM,?38,$EXTRACT(FHSRVPT,1,9),?51,$PIECE(FHNODE,U,4)
+21 IF $PIECE($GET(^FH(119.6,FHLOC,1)),U,4)="Y"
DO DIETPAT^FHOMRR1
WRITE ?56,$EXTRACT(FHDIETP,1,24)
+22 IF $PIECE($GET(^FH(119.6,FHLOC,1)),U,4)'="Y"
SET FHDPTR=$PIECE(FHNODE,U,2)
WRITE ?56,$EXTRACT($PIECE($GET(^FH(111,FHDPTR,0)),U,1),1,24)
End DoDot:2
End DoDot:1
+23 IF FHNOEP=0
Begin DoDot:1
+24 SET FHDSPDT=$$FMTE^XLFDT(FHNDAYS,"P")
+25 WRITE !!?3,"NO RECURRING MEAL PLANS EXPIRING FOR ",FHLOCNM
+26 WRITE " BEFORE ",FHDSPDT,"."
End DoDot:1
+27 QUIT
END ;
+1 KILL FHLOC,FHPARAM
QUIT
