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