FHOMSS2 ;Hines OIFO/RTK SPECIAL MEALS STATUS LIST ;2/07/06 10:05
;;5.5;DIETETICS;**5,19**;Jan 28, 2005;Build 2
;
W @IOF,!!?20,"S P E C I A L M E A L S S T A T U 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
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 LIST,^%ZISC,END Q
S ZTSAVE("STDT")="",ZTSAVE("ENDT")="",ZTSAVE("FHLBY")=""
S ZTSAVE("FHSELOC")="",ZTSAVE("FHSLCOM")="",ZTSAVE("FHSLPRO")=""
S ZTRTN="LIST^FHOMSS2",ZTDESC="Special Meals Display" 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,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 FHNODE=$G(^FHPT(FHDFN,"SM",FHSMDT,0)),FHSTAT=$P(FHNODE,U,2)
.I FHSTAT="C" Q
.S FHLOC=$P(FHNODE,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(FHNODE,U,9)
.S FHML=$S(FHML="B":1,FHML="N":2,FHML="E":3,1:4)
.S ^TMP($J,FHPRORD_"~"_FHLOCNM,FHSMDTX_"."_FHML,FHPTNM_"~"_FHDFN)=FHNODE
.Q
; Now display data from the ^TMP global
I '$D(^TMP($J)) W !!,"NO SPECIAL MEALS TO PRINT FOR GIVEN DATE RANGE" Q
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 FHSMDT=0:0 S FHSMDT=$O(^TMP($J,FHLSRT,FHSMDT)) Q:FHSMDT'>0!(EX=U) D
..S FHPTN="" F S FHPTN=$O(^TMP($J,FHLSRT,FHSMDT,FHPTN)) Q:FHPTN=""!(EX=U) D
...S FHNODE=$G(^TMP($J,FHLSRT,FHSMDT,FHPTN)),FHLOC=$P(FHNODE,U,3)
...S FHLOCZN=$G(^FH(119.6,FHLOC,0)),FHDFN=$P(FHPTN,"~",2)
...S FHSTAT=$P(FHNODE,U,2),FHSTAT=$S(FHSTAT="P":"PENDING",FHSTAT="A":"AUTH",FHSTAT="D":"DENIED",1:"CANCEL")
...S NUM=NUM+1 D PATNAME^FHOMUTL W !,$E(FHPTNM,1,20)
...S FHSMDTX=$P(FHNODE,U,1)
...S FHD=$$FMTE^XLFDT(FHSMDTX,"P") W ?22,$E(FHD,1,12)
...S FHLPT=$P(FHNODE,U,3),FHLOC=$E($P($G(^FH(119.6,FHLPT,0)),U,1),1,10)
...S FHRMBD=$P(FHNODE,U,13),FHRMBNM=""
...I FHRMBD'="" S FHRMBNM=$E($P($G(^DG(405.4,FHRMBD,0)),U,1),1,14)
...W ?36,FHRMBNM
...S FHDPT=$P(FHNODE,U,4),FHDIET=$S(FHDPT="":"",1:$E($P($G(^FH(111,FHDPT,0)),U,1),1,15))
...W ?52,FHDIET
...S FHMEAL=$P(FHNODE,U,9) W ?69,FHMEAL,?73,FHSTAT
...I $E(FHSTAT,1)="D" D
....S FHDENY=$P(FHNODE,U,6) W !?6,"Denied by: "
....I FHDENY'="" W $P($G(^VA(200,FHDENY,0)),U,1)
...S FHCMNT=$P(FHNODE,U,8) I FHCMNT'="" W !?6,"Comment: ",FHCMNT
...I $D(^FHPT(FHDFN,"SM",FHSMDTX,1)) D
....S FHEL=$G(^FHPT(FHDFN,"SM",FHSMDTX,1))
....W !?6,"Early/Late Tray Time: ",$P(FHEL,U,1)
....W " Bagged Meal: ",$P(FHEL,U,2)
....Q
...Q
..Q
.I $Y>(IOSL-4) D PG I EX=U Q
.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 !?5,"S P E C I A L M E A L S S T A T U S R E P O R T"
W !!?5,"LOCATION: ",$P(FHLSRT,"~",2)
W !!!,"Patient Name",?22,"Date",?36,"Room-Bed"
W ?52,"Diet Ordered",?68,"Meal",?73,"Status"
W !,"====================",?22,"============",?36,"=============="
W ?52,"===============",?68,"====",?73,"======="
Q
END ;
K STDT,ENDT,EX,FHNODE,FHSELOC,FHSLCOM,FHSLPRO,FHPRD,FHSTAT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMSS2 4199 printed Nov 22, 2024@17:03:19 Page 2
FHOMSS2 ;Hines OIFO/RTK SPECIAL MEALS STATUS LIST ;2/07/06 10:05
+1 ;;5.5;DIETETICS;**5,19**;Jan 28, 2005;Build 2
+2 ;
+3 WRITE @IOF,!!?20,"S P E C I A L M E A L S S T A T U 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 DO DEV
DO START
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 ZTSAVE("STDT")=""
SET ZTSAVE("ENDT")=""
SET ZTSAVE("FHLBY")=""
+4 SET ZTSAVE("FHSELOC")=""
SET ZTSAVE("FHSLCOM")=""
SET ZTSAVE("FHSLPRO")=""
+5 SET ZTRTN="LIST^FHOMSS2"
SET ZTDESC="Special Meals Display"
DO ^%ZTLOAD
+6 DO ^%ZISC
KILL %ZIS,IOP
+7 DO END
QUIT
LIST ; First build data in ^TMP global
+1 KILL ^TMP($JOB)
SET NUM=0
SET EX=""
SET FHPG=0
SET ENDT=ENDT_.99
+2 FOR FHSMDT=STDT:0
SET FHSMDT=$ORDER(^FHPT("SM",FHSMDT))
if FHSMDT'>0!(FHSMDT>ENDT)!(EX=U)
QUIT
Begin DoDot:1
+3 SET FHSMDTX=$EXTRACT(FHSMDT,1,7)
+4 SET FHDFN=$ORDER(^FHPT("SM",FHSMDT,""))
DO PATNAME^FHOMUTL
+5 SET FHNODE=$GET(^FHPT(FHDFN,"SM",FHSMDT,0))
SET FHSTAT=$PIECE(FHNODE,U,2)
+6 IF FHSTAT="C"
QUIT
+7 SET FHLOC=$PIECE(FHNODE,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)
SET FHML=$PIECE(FHNODE,U,9)
+13 SET FHML=$SELECT(FHML="B":1,FHML="N":2,FHML="E":3,1:4)
+14 SET ^TMP($JOB,FHPRORD_"~"_FHLOCNM,FHSMDTX_"."_FHML,FHPTNM_"~"_FHDFN)=FHNODE
+15 QUIT
End DoDot:1
+16 ; Now display data from the ^TMP global
+17 IF '$DATA(^TMP($JOB))
WRITE !!,"NO SPECIAL MEALS TO PRINT FOR GIVEN DATE RANGE"
QUIT
+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 FHSMDT=0:0
SET FHSMDT=$ORDER(^TMP($JOB,FHLSRT,FHSMDT))
if FHSMDT'>0!(EX=U)
QUIT
Begin DoDot:2
+22 SET FHPTN=""
FOR
SET FHPTN=$ORDER(^TMP($JOB,FHLSRT,FHSMDT,FHPTN))
if FHPTN=""!(EX=U)
QUIT
Begin DoDot:3
+23 SET FHNODE=$GET(^TMP($JOB,FHLSRT,FHSMDT,FHPTN))
SET FHLOC=$PIECE(FHNODE,U,3)
+24 SET FHLOCZN=$GET(^FH(119.6,FHLOC,0))
SET FHDFN=$PIECE(FHPTN,"~",2)
+25 SET FHSTAT=$PIECE(FHNODE,U,2)
SET FHSTAT=$SELECT(FHSTAT="P":"PENDING",FHSTAT="A":"AUTH",FHSTAT="D":"DENIED",1:"CANCEL")
+26 SET NUM=NUM+1
DO PATNAME^FHOMUTL
WRITE !,$EXTRACT(FHPTNM,1,20)
+27 SET FHSMDTX=$PIECE(FHNODE,U,1)
+28 SET FHD=$$FMTE^XLFDT(FHSMDTX,"P")
WRITE ?22,$EXTRACT(FHD,1,12)
+29 SET FHLPT=$PIECE(FHNODE,U,3)
SET FHLOC=$EXTRACT($PIECE($GET(^FH(119.6,FHLPT,0)),U,1),1,10)
+30 SET FHRMBD=$PIECE(FHNODE,U,13)
SET FHRMBNM=""
+31 IF FHRMBD'=""
SET FHRMBNM=$EXTRACT($PIECE($GET(^DG(405.4,FHRMBD,0)),U,1),1,14)
+32 WRITE ?36,FHRMBNM
+33 SET FHDPT=$PIECE(FHNODE,U,4)
SET FHDIET=$SELECT(FHDPT="":"",1:$EXTRACT($PIECE($GET(^FH(111,FHDPT,0)),U,1),1,15))
+34 WRITE ?52,FHDIET
+35 SET FHMEAL=$PIECE(FHNODE,U,9)
WRITE ?69,FHMEAL,?73,FHSTAT
+36 IF $EXTRACT(FHSTAT,1)="D"
Begin DoDot:4
+37 SET FHDENY=$PIECE(FHNODE,U,6)
WRITE !?6,"Denied by: "
+38 IF FHDENY'=""
WRITE $PIECE($GET(^VA(200,FHDENY,0)),U,1)
End DoDot:4
+39 SET FHCMNT=$PIECE(FHNODE,U,8)
IF FHCMNT'=""
WRITE !?6,"Comment: ",FHCMNT
+40 IF $DATA(^FHPT(FHDFN,"SM",FHSMDTX,1))
Begin DoDot:4
+41 SET FHEL=$GET(^FHPT(FHDFN,"SM",FHSMDTX,1))
+42 WRITE !?6,"Early/Late Tray Time: ",$PIECE(FHEL,U,1)
+43 WRITE " Bagged Meal: ",$PIECE(FHEL,U,2)
+44 QUIT
End DoDot:4
+45 QUIT
End DoDot:3
+46 QUIT
End DoDot:2
+47 IF $Y>(IOSL-4)
DO PG
IF EX=U
QUIT
+48 QUIT
End DoDot:1
+49 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 !?5,"S P E C I A L M E A L S S T A T U S R E P O R T"
+3 WRITE !!?5,"LOCATION: ",$PIECE(FHLSRT,"~",2)
+4 WRITE !!!,"Patient Name",?22,"Date",?36,"Room-Bed"
+5 WRITE ?52,"Diet Ordered",?68,"Meal",?73,"Status"
+6 WRITE !,"====================",?22,"============",?36,"=============="
+7 WRITE ?52,"===============",?68,"====",?73,"======="
+8 QUIT
END ;
+1 KILL STDT,ENDT,EX,FHNODE,FHSELOC,FHSLCOM,FHSLPRO,FHPRD,FHSTAT
QUIT
