- 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 Feb 18, 2025@23:13:37 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