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