1 | FHBIR ; 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
|
---|
5 | R0 ;
|
---|
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
|
---|
8 | R1 ;
|
---|
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
|
---|
13 | Q1 ; 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
|
---|
19 | Q2 ;
|
---|
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
|
---|
26 | Q3 ;
|
---|
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
|
---|
33 | HDR ;
|
---|
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
|
---|
39 | KIL K ^TMP($J),FHOPFLG G KILL^XUSCLEAN
|
---|
40 | Q
|
---|
41 | OUTP ;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
|
---|
74 | CHECK ;
|
---|
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
|
---|