source: FOIAVistA/trunk/r/DIETETICS-FH/FHOMGP1.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1FHOMGP1 ;Hines OIFO/RTK PRINT GUEST MEALS LIST ;6/30/03 15:45
2 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
3 ;
4 W @IOF,!!?20,"G U E S T M E A L S L I S T"
5EN ;
6 W !! K DIR S DIR("A")="Print by LOCATION, COMM OFFICE, PRODUCTION FACILITY or ALL: "
7 S DIR(0)="SAO^A:ALL;C:COMM OFFICE;L:LOCATION;P:PROD FACILITY" D ^DIR
8 Q:$D(DIRUT) S FHLBY=Y
9 I FHLBY="L" W ! D OUTLOC^FHOMUTL Q:FHLOC="" S FHSELOC=FHLOC,FHLOC=""
10 I FHLBY="C" D Q:FHSLCOM=""
11 .W ! K DIC S DIC=119.73,DIC("A")="Select Communication Office: "
12 .S DIC(0)="AEQZ" D ^DIC Q:$D(DUOUT) I Y=-1 S FHSLCOM="" Q
13 .S FHSLCOM=+Y
14 I FHLBY="P" D Q:FHSLPRO=""
15 .W ! K DIC S DIC=119.71,DIC("A")="Select Production Facility: "
16 .S DIC(0)="AEQZ" D ^DIC Q:$D(DUOUT) I Y=-1 S FHSLPRO="" Q
17 .S FHSLPRO=+Y
18 W ! D STDATE^FHOMUTL I STDT="" Q
19 W ! D ENDATE^FHOMUTL I ENDT="" Q
20 S ENDT=ENDT_.99
21 D DEV,EN Q
22DEV ;get device and set up queue
23 W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP
24 I '$D(IO("Q")) U IO D LIST,^%ZISC,END Q
25 S ZTRTN="LIST^FHOMGP1"
26 S ZTSAVE("STDT")="",ZTSAVE("ENDT")="",ZTSAVE("FHDFN")=""
27 S ZTSAVE("FHLBY")="",ZTSAVE("FHSELOC")="",ZTSAVE("FHSLCOM")="",ZTSAVE("FHSLPRO")=""
28 S ZTDESC="Guest Meals Display" D ^%ZTLOAD
29 D ^%ZISC K %ZIS,IOP
30 D END Q
31LIST ; First build data in ^TMP global
32 K ^TMP($J) S NUM=0,EX="",FHPG=0
33 F FHGMDT=STDT:0 S FHGMDT=$O(^FHPT("GM",FHGMDT)) Q:FHGMDT'>0!(FHGMDT>ENDT) D
34 .F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHGMDT,FHDFN)) Q:FHDFN'>0 D
35 ..S FHZN=$G(^FHPT(FHDFN,"GM",FHGMDT,0)),FHST=$P(FHZN,U,9) I FHST="C" Q
36 ..D PATNAME^FHOMUTL
37 ..S FHLOC=$P(FHZN,U,5) Q:FHLOC="" I FHLBY="L",FHSELOC'=FHLOC Q
38 ..S FHCOMM=$P($G(^FH(119.6,FHLOC,0)),U,8) I FHLBY="C",FHSLCOM'=FHCOMM Q
39 ..S FHPRD=$P($G(^FH(119.73,FHCOMM,0)),U,4) I FHLBY="P",FHSLPRO'=FHPRD Q
40 ..S FHPRORD=$P($G(^FH(119.6,FHLOC,0)),U,4) I FHPRORD="" S FHPRORD=99
41 ..S FHPRORD=$S(FHPRORD<1:99,FHPRORD<10:"0"_FHPRORD,1:FHPRORD)
42 ..S FHLOCNM=$P($G(^FH(119.6,FHLOC,0)),U,1)
43 ..S ^TMP($J,FHPRORD_"~"_FHLOCNM,FHGMDT,FHPTNM_"~"_FHDFN)=FHZN
44 ..Q
45 .Q
46 ; Now display data from the ^TMP global
47 I '$D(^TMP($J)) W !!,"THERE ARE CURRENTLY NO GUEST MEALS TO PRINT" Q
48 S FHLSRT="" F S FHLSRT=$O(^TMP($J,FHLSRT)) Q:FHLSRT=""!(EX=U) D
49 .D:FHPG>0&(IOST?1"C".E) PG Q:EX=U
50 .D HDR S FHPG=FHPG+1
51 .F FHGMDT=0:0 S FHGMDT=$O(^TMP($J,FHLSRT,FHGMDT)) Q:FHGMDT'>0!(EX=U) D
52 ..S FHPTN="" F S FHPTN=$O(^TMP($J,FHLSRT,FHGMDT,FHPTN)) Q:FHPTN=""!(EX=U) D
53 ...S FHNODE=$G(^TMP($J,FHLSRT,FHGMDT,FHPTN)),FHLOC=$P(FHNODE,U,5)
54 ...S FHLOCZN=$G(^FH(119.6,FHLOC,0))
55 ...S FHRMBD=$P(FHNODE,U,11),FHRMBNM=""
56 ...I FHRMBD'="" S FHRMBNM=$E($P($G(^DG(405.4,FHRMBD,0)),U,1),1,11)
57 ...S FHDFN=$P(FHPTN,"~",2) ;,FHLIST(NUM)=FHDFN_"^"_FHGMDT
58 ...S FHCL=$P(FHNODE,U,2),FHML=$P(FHNODE,U,3),FHCH=$P(FHNODE,U,4)
59 ...S FHSTAT=$P(FHNODE,U,9),NUM=NUM+1
60 ...S FHCL=$S(FHCL="E":"EMP",FHCL="G":"GRAT",FHCL="O":"OOD",FHCL="P":"PAID",1:"VOL")
61 ...S FHLOC=$E($P($G(^FH(119.6,FHLOC,0)),U,1),1,12)
62 ...; S PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM
63 ...D PATNAME^FHOMUTL W !,$E(FHPTNM,1,22)
64 ...S FHD=$$FMTE^XLFDT(FHGMDT,"P") W ?22,$E(FHD,1,12)
65 ...W ?36,FHLOC,?49,FHRMBNM,?62,FHML,?67,FHCL,?74,FHCH
66 ...S FHLIST(NUM)=FHDFN_"^"_FHGMDT
67 ...I $Y>(IOSL-4) D PG I EX=U Q
68 ..Q
69 .Q
70 Q
71END ;
72 K DIR,ENDT,STDT,FHGMDT,FHML,FHCL,FHCH,FHSELOC,FHSLCOM,FHNODE,FHZN
73 K FHSLPRO,FHPRD
74 Q
75PG ;
76 ;Q:$O(^FHPT(FHDFN,"GM",FHGMDT))'>0
77 I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q
78 D HDR Q
79HDR ;
80 W:$Y @IOF
81 W !?5,"G U E S T M E A L L I S T"
82 W !!?5,"LOCATION: ",$P(FHLSRT,"~",2)
83 W !!,"Name",?22,"Date",?36,"Location",?49,"Room-Bed",?61,"Meal"
84 W ?67,"Class",?74,"Charge"
85 W !,"====================",?22,"============"
86 W ?36,"============ ===========",?61,"====",?67,"=====",?74,"======"
87 Q
Note: See TracBrowser for help on using the repository browser.