source: FOIAVistA/tag/r/DIETETICS-FH/FHBIR.m@ 1618

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

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1FHBIR ; HISC/REL - Birthday List ;1/23/98 16:06
2 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
3 ;patch #5 - adding outpt room-bed.
4 S FHP=$O(^FH(119.73,0)) I FHP'<1,$O(^FH(119.73,FHP))<1 S FHP=0 G R1
5R0 ;
6 R !!,"Select COMMUNICATION OFFICE (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHP=0
7 E K DIC S DIC="^FH(119.73,",DIC(0)="EMQ" D ^DIC G:Y<1 R0 S FHP=+Y
8R1 ;
9 S %DT="AEP",%DT("A")="Birthday DATE: " W ! D ^%DT G:Y<1 KIL S DAT=Y
10 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
11 I $D(IO("Q")) S FHPGM="Q1^FHBIR",FHLST="DAT^FHP" D EN2^FH G KIL
12 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
13Q1 ; Process Printing Birthday List
14 K ^TMP($J) S PG=0,TYP=$E(DAT,6,7)="00" D NOW^%DTC S NOW=% K %,%H,%I
15 F FHWRD=0:0 S FHWRD=$O(^FH(119.6,FHWRD)) Q:FHWRD'>0 S DP=$P(^(FHWRD,0),"^",8) I 'FHP!(DP=FHP) S WRD=$P(^(0),"^",1) F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",FHWRD,FHDFN)) Q:FHDFN<1 D Q2
16 S PATTYP="INPATIENTS" D HDR S NAM="" F K=0:0 S NAM=$O(^TMP($J,NAM)) Q:NAM="" F FHDFN=0:0 S FHDFN=$O(^TMP($J,NAM,FHDFN)) Q:FHDFN<1 D Q3
17 D OUTP
18 Q
19Q2 ;
20 D PATNAME^FHOMUTL I DFN="" Q
21 Q:'$D(^DPT(DFN,.1))
22 S Y0=$G(^DPT(DFN,0)),X=$P(Y0,"^",3) Q:'X
23 I 'TYP Q:$E(X,4,7)'=$E(DAT,4,7)
24 Q:$E(X,4,5)'=$E(DAT,4,5)
25 S BD=$E(X,4,7)_$E($P(Y0,"^",1),1,26),^TMP($J,BD,FHDFN)=X_"^"_WRD Q
26Q3 ;
27 D PATNAME^FHOMUTL I DFN="" Q
28 S X1=^TMP($J,NAM,FHDFN),DTP=$P(X1,"^",1),WRD=$P(X1,"^",2)
29 S RM=$G(^DPT(DFN,.101))
30 S DTP=$J(+$E(DTP,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(DTP,4,5))_"-"_(1700+$E(DTP,1,3))
31 D:$Y>(IOSL-10) HDR
32 W !,$E(NAM,5,30),?32,$E(WRD,1,10),?44,$E(RM,1,10),?56,DTP Q
33HDR ;
34 N DTP
35 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=NOW D DTP^FH W !,DTP,?27,"B I R T H D A Y L I S T",?74,"Page ",PG
36 S DTP=DAT D DTP^FH S DTP=$P(DTP,"-",$S(TYP:2,1:1),2) S:FHP DTP=$P(^FH(119.73,FHP,0),"^",1)_" "_DTP W !!,PATTYP,?(79-$L(DTP)\2),DTP
37 ;I $G(FHOPFLG)=1 W !!,"Name",?32,"Location",?57,"Birthday",! Q
38 W !!,"Name",?32,"Ward",?44,"Room",?57,"Birthday",! Q
39KIL K ^TMP($J),FHOPFLG G KILL^XUSCLEAN
40 Q
41OUTP ;Add Outpatient Display Here - RTK
42 ;Only birthdays with Recurring, Special, Guest Meals for date selected
43 ;
44 K ^TMP($J) S PATTYP="OUTPATIENTS",FHOPFLG=1
45 I TYP=1 S FHDTQ=$E(DAT,1,5)_"99.999999",FHRM=DAT-.0001
46 I TYP=0 S FHDTQ=DAT_".999999" S X1=DAT,X2=-1 D C^%DTC S FHRM=X
47 S RM=""
48 F FHOMDT=FHRM:0 S FHOMDT=$O(^FHPT("RM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHDTQ) D
49 .F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHOMDT,FHDFN)) Q:FHDFN="" D
50 ..F FHRNUM=0:0 S FHRNUM=$O(^FHPT("RM",FHOMDT,FHDFN,FHRNUM)) Q:FHRNUM="" D
51 ...S FHLOC=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,3) Q:FHLOC=""
52 ...S RM=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,18)
53 ...I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^DG(405.4,RM,0),U,1)
54 ...D CHECK
55 F FHOM=DAT:0 S FHOM=$O(^FHPT("SM",FHOM)) Q:FHOM=""!(FHOM>FHDTQ) D
56 .F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHOM,FHDFN)) Q:FHDFN="" D
57 ..S FHLOC=$P($G(^FHPT(FHDFN,"SM",FHOM,0)),U,3) Q:FHLOC=""
58 ..S RM=$P($G(^FHPT(FHDFN,"SM",FHOM,0)),U,13)
59 ..I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^DG(405.4,RM,0),U,1)
60 ..D CHECK
61 F FHOM=DAT:0 S FHOM=$O(^FHPT("GM",FHOM)) Q:FHOM=""!(FHOM>FHDTQ) D
62 .F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHOM,FHDFN)) Q:FHDFN="" D
63 ..S FHLOC=$P($G(^FHPT(FHDFN,"GM",FHOM,0)),U,5) Q:FHLOC=""
64 ..S RM=$P($G(^FHPT(FHDFN,"GM",FHOM,0)),U,11)
65 ..I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^DG(405.4,RM,0),U,1)
66 ..D CHECK
67 ;
68 D HDR S NAM="" F K=0:0 S NAM=$O(^TMP($J,NAM)) Q:NAM="" F FHDFN=0:0 S FHDFN=$O(^TMP($J,NAM,FHDFN)) Q:FHDFN<1 D
69 .S X1=^TMP($J,NAM,FHDFN),DTP=$P(X1,"^",1),WRD=$P(X1,"^",2),RM=$P(X1,"^",3)
70 .S DTP=$J(+$E(DTP,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(DTP,4,5))_"-"_(1700+$E(DTP,1,3))
71 .D:$Y>(IOSL-10) HDR
72 .W !,$E(NAM,5,30),?32,$E(WRD,1,10),?44,$E(RM,1,10),?56,DTP Q
73 W ! K FHOPFLG Q
74CHECK ;
75 D PATNAME^FHOMUTL
76 I 'TYP Q:$E(FHDOB,4,7)'=$E(DAT,4,7)
77 Q:$E(FHDOB,4,5)'=$E(DAT,4,5)
78 S FHCOM=$P($G(^FH(119.6,FHLOC,0)),U,8)
79 I FHP'=0,FHCOM'=FHP Q
80 S FHLNM=$P($G(^FH(119.6,FHLOC,0)),U,1)
81 S:'$D(RM) RM=" "
82 S BD=$E(FHDOB,4,7)_$E(FHPTNM,1,26),^TMP($J,BD,FHDFN)=FHDOB_"^"_FHLNM_"^"_RM Q
Note: See TracBrowser for help on using the repository browser.