FHBIR ; HISC/REL - Birthday List ;1/23/98 16:06
;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
;patch #5 - adding outpt room-bed.
S FHP=$O(^FH(119.73,0)) I FHP'<1,$O(^FH(119.73,FHP))<1 S FHP=0 G R1
R0 ;
R !!,"Select COMMUNICATION OFFICE (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHP=0
E K DIC S DIC="^FH(119.73,",DIC(0)="EMQ" D ^DIC G:Y<1 R0 S FHP=+Y
R1 ;
S %DT="AEP",%DT("A")="Birthday DATE: " W ! D ^%DT G:Y<1 KIL S DAT=Y
W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHBIR",FHLST="DAT^FHP" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Process Printing Birthday List
K ^TMP($J) S PG=0,TYP=$E(DAT,6,7)="00" D NOW^%DTC S NOW=% K %,%H,%I
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
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
D OUTP
Q
Q2 ;
D PATNAME^FHOMUTL I DFN="" Q
Q:'$D(^DPT(DFN,.1))
S Y0=$G(^DPT(DFN,0)),X=$P(Y0,"^",3) Q:'X
I 'TYP Q:$E(X,4,7)'=$E(DAT,4,7)
Q:$E(X,4,5)'=$E(DAT,4,5)
S BD=$E(X,4,7)_$E($P(Y0,"^",1),1,26),^TMP($J,BD,FHDFN)=X_"^"_WRD Q
Q3 ;
D PATNAME^FHOMUTL I DFN="" Q
S X1=^TMP($J,NAM,FHDFN),DTP=$P(X1,"^",1),WRD=$P(X1,"^",2)
S RM=$G(^DPT(DFN,.101))
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))
D:$Y>(IOSL-10) HDR
W !,$E(NAM,5,30),?32,$E(WRD,1,10),?44,$E(RM,1,10),?56,DTP Q
HDR ;
N DTP
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
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
;I $G(FHOPFLG)=1 W !!,"Name",?32,"Location",?57,"Birthday",! Q
W !!,"Name",?32,"Ward",?44,"Room",?57,"Birthday",! Q
KIL K ^TMP($J),FHOPFLG G KILL^XUSCLEAN
Q
OUTP ;Add Outpatient Display Here - RTK
;Only birthdays with Recurring, Special, Guest Meals for date selected
;
K ^TMP($J) S PATTYP="OUTPATIENTS",FHOPFLG=1
I TYP=1 S FHDTQ=$E(DAT,1,5)_"99.999999",FHRM=DAT-.0001
I TYP=0 S FHDTQ=DAT_".999999" S X1=DAT,X2=-1 D C^%DTC S FHRM=X
S RM=""
F FHOMDT=FHRM:0 S FHOMDT=$O(^FHPT("RM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHDTQ) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHOMDT,FHDFN)) Q:FHDFN="" D
..F FHRNUM=0:0 S FHRNUM=$O(^FHPT("RM",FHOMDT,FHDFN,FHRNUM)) Q:FHRNUM="" D
...S FHLOC=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,3) Q:FHLOC=""
...S RM=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,18)
...I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^DG(405.4,RM,0),U,1)
...D CHECK
F FHOM=DAT:0 S FHOM=$O(^FHPT("SM",FHOM)) Q:FHOM=""!(FHOM>FHDTQ) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHOM,FHDFN)) Q:FHDFN="" D
..S FHLOC=$P($G(^FHPT(FHDFN,"SM",FHOM,0)),U,3) Q:FHLOC=""
..S RM=$P($G(^FHPT(FHDFN,"SM",FHOM,0)),U,13)
..I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^DG(405.4,RM,0),U,1)
..D CHECK
F FHOM=DAT:0 S FHOM=$O(^FHPT("GM",FHOM)) Q:FHOM=""!(FHOM>FHDTQ) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHOM,FHDFN)) Q:FHDFN="" D
..S FHLOC=$P($G(^FHPT(FHDFN,"GM",FHOM,0)),U,5) Q:FHLOC=""
..S RM=$P($G(^FHPT(FHDFN,"GM",FHOM,0)),U,11)
..I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^DG(405.4,RM,0),U,1)
..D CHECK
;
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
.S X1=^TMP($J,NAM,FHDFN),DTP=$P(X1,"^",1),WRD=$P(X1,"^",2),RM=$P(X1,"^",3)
.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))
.D:$Y>(IOSL-10) HDR
.W !,$E(NAM,5,30),?32,$E(WRD,1,10),?44,$E(RM,1,10),?56,DTP Q
W ! K FHOPFLG Q
CHECK ;
D PATNAME^FHOMUTL
I 'TYP Q:$E(FHDOB,4,7)'=$E(DAT,4,7)
Q:$E(FHDOB,4,5)'=$E(DAT,4,5)
S FHCOM=$P($G(^FH(119.6,FHLOC,0)),U,8)
I FHP'=0,FHCOM'=FHP Q
S FHLNM=$P($G(^FH(119.6,FHLOC,0)),U,1)
S:'$D(RM) RM=" "
S BD=$E(FHDOB,4,7)_$E(FHPTNM,1,26),^TMP($J,BD,FHDFN)=FHDOB_"^"_FHLNM_"^"_RM Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHBIR 4156 printed Dec 13, 2024@01:47:14 Page 2
FHBIR ; HISC/REL - Birthday List ;1/23/98 16:06
+1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
+2 ;patch #5 - adding outpt room-bed.
+3 SET FHP=$ORDER(^FH(119.73,0))
IF FHP'<1
IF $ORDER(^FH(119.73,FHP))<1
SET FHP=0
GOTO R1
R0 ;
+1 READ !!,"Select COMMUNICATION OFFICE (or ALL): ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
if X="all"
DO TR^FH
IF X="ALL"
SET FHP=0
+2 IF '$TEST
KILL DIC
SET DIC="^FH(119.73,"
SET DIC(0)="EMQ"
DO ^DIC
if Y<1
GOTO R0
SET FHP=+Y
R1 ;
+1 SET %DT="AEP"
SET %DT("A")="Birthday DATE: "
WRITE !
DO ^%DT
if Y<1
GOTO KIL
SET DAT=Y
+2 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+3 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHBIR"
SET FHLST="DAT^FHP"
DO EN2^FH
GOTO KIL
+4 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Process Printing Birthday List
+1 KILL ^TMP($JOB)
SET PG=0
SET TYP=$EXTRACT(DAT,6,7)="00"
DO NOW^%DTC
SET NOW=%
KILL %,%H,%I
+2 FOR FHWRD=0:0
SET FHWRD=$ORDER(^FH(119.6,FHWRD))
if FHWRD'>0
QUIT
SET DP=$PIECE(^(FHWRD,0),"^",8)
IF 'FHP!(DP=FHP)
SET WRD=$PIECE(^(0),"^",1)
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",FHWRD,FHDFN))
if FHDFN<1
QUIT
DO Q2
+3 SET PATTYP="INPATIENTS"
DO HDR
SET NAM=""
FOR K=0:0
SET NAM=$ORDER(^TMP($JOB,NAM))
if NAM=""
QUIT
FOR FHDFN=0:0
SET FHDFN=$ORDER(^TMP($JOB,NAM,FHDFN))
if FHDFN<1
QUIT
DO Q3
+4 DO OUTP
+5 QUIT
Q2 ;
+1 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+2 if '$DATA(^DPT(DFN,.1))
QUIT
+3 SET Y0=$GET(^DPT(DFN,0))
SET X=$PIECE(Y0,"^",3)
if 'X
QUIT
+4 IF 'TYP
if $EXTRACT(X,4,7)'=$EXTRACT(DAT,4,7)
QUIT
+5 if $EXTRACT(X,4,5)'=$EXTRACT(DAT,4,5)
QUIT
+6 SET BD=$EXTRACT(X,4,7)_$EXTRACT($PIECE(Y0,"^",1),1,26)
SET ^TMP($JOB,BD,FHDFN)=X_"^"_WRD
QUIT
Q3 ;
+1 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+2 SET X1=^TMP($JOB,NAM,FHDFN)
SET DTP=$PIECE(X1,"^",1)
SET WRD=$PIECE(X1,"^",2)
+3 SET RM=$GET(^DPT(DFN,.101))
+4 SET DTP=$JUSTIFY(+$EXTRACT(DTP,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(DTP,4,5))_"-"_(1700+$EXTRACT(DTP,1,3))
+5 if $Y>(IOSL-10)
DO HDR
+6 WRITE !,$EXTRACT(NAM,5,30),?32,$EXTRACT(WRD,1,10),?44,$EXTRACT(RM,1,10),?56,DTP
QUIT
HDR ;
+1 NEW DTP
+2 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
SET DTP=NOW
DO DTP^FH
WRITE !,DTP,?27,"B I R T H D A Y L I S T",?74,"Page ",PG
+3 SET DTP=DAT
DO DTP^FH
SET DTP=$PIECE(DTP,"-",$SELECT(TYP:2,1:1),2)
if FHP
SET DTP=$PIECE(^FH(119.73,FHP,0),"^",1)_" "_DTP
WRITE !!,PATTYP,?(79-$LENGTH(DTP)\2),DTP
+4 ;I $G(FHOPFLG)=1 W !!,"Name",?32,"Location",?57,"Birthday",! Q
+5 WRITE !!,"Name",?32,"Ward",?44,"Room",?57,"Birthday",!
QUIT
KIL KILL ^TMP($JOB),FHOPFLG
GOTO KILL^XUSCLEAN
+1 QUIT
OUTP ;Add Outpatient Display Here - RTK
+1 ;Only birthdays with Recurring, Special, Guest Meals for date selected
+2 ;
+3 KILL ^TMP($JOB)
SET PATTYP="OUTPATIENTS"
SET FHOPFLG=1
+4 IF TYP=1
SET FHDTQ=$EXTRACT(DAT,1,5)_"99.999999"
SET FHRM=DAT-.0001
+5 IF TYP=0
SET FHDTQ=DAT_".999999"
SET X1=DAT
SET X2=-1
DO C^%DTC
SET FHRM=X
+6 SET RM=""
+7 FOR FHOMDT=FHRM:0
SET FHOMDT=$ORDER(^FHPT("RM",FHOMDT))
if FHOMDT=""!(FHOMDT'<FHDTQ)
QUIT
Begin DoDot:1
+8 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",FHOMDT,FHDFN))
if FHDFN=""
QUIT
Begin DoDot:2
+9 FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT("RM",FHOMDT,FHDFN,FHRNUM))
if FHRNUM=""
QUIT
Begin DoDot:3
+10 SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,3)
if FHLOC=""
QUIT
+11 SET RM=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,18)
+12 IF $GET(RM)
IF $DATA(^DG(405.4,RM,0))
SET RM=$PIECE(^DG(405.4,RM,0),U,1)
+13 DO CHECK
End DoDot:3
End DoDot:2
End DoDot:1
+14 FOR FHOM=DAT:0
SET FHOM=$ORDER(^FHPT("SM",FHOM))
if FHOM=""!(FHOM>FHDTQ)
QUIT
Begin DoDot:1
+15 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("SM",FHOM,FHDFN))
if FHDFN=""
QUIT
Begin DoDot:2
+16 SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"SM",FHOM,0)),U,3)
if FHLOC=""
QUIT
+17 SET RM=$PIECE($GET(^FHPT(FHDFN,"SM",FHOM,0)),U,13)
+18 IF $GET(RM)
IF $DATA(^DG(405.4,RM,0))
SET RM=$PIECE(^DG(405.4,RM,0),U,1)
+19 DO CHECK
End DoDot:2
End DoDot:1
+20 FOR FHOM=DAT:0
SET FHOM=$ORDER(^FHPT("GM",FHOM))
if FHOM=""!(FHOM>FHDTQ)
QUIT
Begin DoDot:1
+21 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("GM",FHOM,FHDFN))
if FHDFN=""
QUIT
Begin DoDot:2
+22 SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"GM",FHOM,0)),U,5)
if FHLOC=""
QUIT
+23 SET RM=$PIECE($GET(^FHPT(FHDFN,"GM",FHOM,0)),U,11)
+24 IF $GET(RM)
IF $DATA(^DG(405.4,RM,0))
SET RM=$PIECE(^DG(405.4,RM,0),U,1)
+25 DO CHECK
End DoDot:2
End DoDot:1
+26 ;
+27 DO HDR
SET NAM=""
FOR K=0:0
SET NAM=$ORDER(^TMP($JOB,NAM))
if NAM=""
QUIT
FOR FHDFN=0:0
SET FHDFN=$ORDER(^TMP($JOB,NAM,FHDFN))
if FHDFN<1
QUIT
Begin DoDot:1
+28 SET X1=^TMP($JOB,NAM,FHDFN)
SET DTP=$PIECE(X1,"^",1)
SET WRD=$PIECE(X1,"^",2)
SET RM=$PIECE(X1,"^",3)
+29 SET DTP=$JUSTIFY(+$EXTRACT(DTP,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(DTP,4,5))_"-"_(1700+$EXTRACT(DTP,1,3))
+30 if $Y>(IOSL-10)
DO HDR
+31 WRITE !,$EXTRACT(NAM,5,30),?32,$EXTRACT(WRD,1,10),?44,$EXTRACT(RM,1,10),?56,DTP
QUIT
End DoDot:1
+32 WRITE !
KILL FHOPFLG
QUIT
CHECK ;
+1 DO PATNAME^FHOMUTL
+2 IF 'TYP
if $EXTRACT(FHDOB,4,7)'=$EXTRACT(DAT,4,7)
QUIT
+3 if $EXTRACT(FHDOB,4,5)'=$EXTRACT(DAT,4,5)
QUIT
+4 SET FHCOM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,8)
+5 IF FHP'=0
IF FHCOM'=FHP
QUIT
+6 SET FHLNM=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
+7 if '$DATA(RM)
SET RM=" "
+8 SET BD=$EXTRACT(FHDOB,4,7)_$EXTRACT(FHPTNM,1,26)
SET ^TMP($JOB,BD,FHDFN)=FHDOB_"^"_FHLNM_"^"_RM
QUIT
