FHORX1 ; HISC/REL/RVD - Diet Activity Report ;9/10/98 15:31
;;5.5;DIETETICS;**1,8**;Jan 28, 2005;Build 28
;RVD patch #1 - get outpatient info from Nutrition Events file.
;
D NOW^%DTC S NOW=%,TIM=""
R0 D DIV^FHOMUTL G:'$D(FHSITE) KIL
S FHP=FHSITE
R1 R !!,"Do you want labels? N// ",X:DTIME G:'$T!(X["^") KIL S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Enter YES or NO" G R1
S LAB=X?1"Y".E
S:$G(FHP) TIM=$P($G(^FH(119.73,FHP,0)),"^",$S(LAB:3,1:2))
I 'TIM S TIM=DT
S FHLBFLG=1 I LAB D I FHLBFLG=0 Q
.W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If using laser label sheets, what row do you want to begin printing at? ",DIR("B")=1 D ^DIR
.I $D(DIRUT) S FHLBFLG=0 Q
.S LABSTART=Y Q
S DTP=TIM D DTP^FH
R3 W !!,"Changes since Date/Time: ",DTP," // " R X:DTIME G:'$T!(X["^") KIL I X'="" S %DT="EXTS" D ^%DT K %DT G:Y<1 R3 S TIM=Y
W ! K IOP,%ZIS S %ZIS("A")="Select "_$S(LAB:"LABEL",1:"LIST")_" Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHORX1",FHLST="TIM^LAB^FHP^LABSTART^FHSITE^FHSITENM" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Print the Diet Activity Report
S FHTIM=TIM ;save date/time for recurring meal data.
K ^TMP($J) D NOW^%DTC S NOW=%,DTP=TIM,TIM=TIM-.000001 D DTP^FH S H1=DTP_" - " S DTP=NOW D DTP^FH S H1=H1_DTP D ^FHDEV
F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 D WRD
I LAB S LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1
F LLL=TIM:0 S LLL=$O(^FH(119.8,"AD",LLL)) Q:LLL<1 F DA=0:0 S DA=$O(^FH(119.8,"AD",LLL,DA)) Q:DA<1 D Q3
;
OUTP ;get outpatient data
F LLL=TIM:0 S LLL=$O(^FH(119.8,"AD",LLL)) Q:LLL<1 F DA=0:0 S DA=$O(^FH(119.8,"AD",LLL,DA)) Q:DA<1 D
.S FHPROR=99,(FHTC,FHCOMO)=""
.S Z=$G(^FH(119.8,DA,0)) Q:Z=""
.S FHDTIM=$P(Z,"^",2),FHDFN=$P(Z,"^",3),FHOUTP=$P(Z,"^",5)
.Q:FHOUTP'="Z"
.S FHACTI=$P(Z,"^",6)
.S FHDESC=$P(Z,"^",8),FHLOCN=$P(FHDESC,",",2)
.S FHLOCN=$E(FHLOCN,2,$L(FHLOCN))
.S:FHLOCN'="" FHLIEN=$O(^FH(119.6,"B",FHLOCN,0))
.I $G(FHLIEN) D
..S FHPROR=$P($G(^FH(119.6,FHLIEN,0)),U,4)
..S FHSERV1=$P($G(^FH(119.6,FHLIEN,0)),U,5)
..I $G(FHSERV1),$D(^FH(119.72,FHSERV1,0)) S FHTC=FHTC_$P(^(0),U,2)
..S FHSERV2=$P($G(^FH(119.6,FHLIEN,0)),U,6)
..I $G(FHSERV2),$D(^FH(119.72,FHSERV2,0)) S FHTC=FHTC_$P(^(0),U,2)
..S FHSERV3=$P($G(^FH(119.6,FHLIEN,0)),U,7)
..I $G(FHSERV3) S FHTC=FHTC_"D"
..S FHCOMO=$P($G(^FH(119.6,FHLIEN,0)),U,8)
.I $G(FHSITE),FHCOMO'=FHSITE Q
.S FHCLER=$P(Z,"^",9)
.S FHPTNM="***"
.S:FHLOCN="" FHLOCN="***"
.D PATNAME^FHOMUTL
.S FHLPAT=FHPROR_"~"_FHLOCN_"~~"_DFN_"~"_FHPTNM
.S DTP=FHDTIM D DTP^FH
.S ^TMP($J,"O",FHLPAT,DA)=FHACTI_"^"_DTP_"^"_FHBID_"^"_FHDESC_"^"_FHTC
;
;D PROSG ;print outpatient data
;go to routines for printing report
G ^FHORX1A:'LAB,^FHORX1B
WRD S P0=$G(^FH(119.6,W1,0)),WRDN=$P(P0,"^",1),D2=$P(P0,"^",8),P0=$P(P0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
I $G(FHP),D2=FHP S ^TMP($J,"W",W1)=P0_"~"_WRDN
I '$G(FHP) S ^TMP($J,"W",W1)=P0_"~"_WRDN
Q
Q3 S Z=$G(^FH(119.8,DA,0)) Q:Z="" S TM1=($P(Z,"^",2)\1),FHDFN=$P(Z,"^",3),ADM=$P(Z,"^",4) Q:'$G(ADM) Q:'$D(^FHPT(FHDFN,"A",ADM,0))
D PATNAME^FHOMUTL I DFN="" Q
S WARD=$G(^DPT(DFN,.1)) G:WARD="" Q5 ; Not an inpatient
I $G(^DPT("CN",WARD,DFN))'=ADM Q ; Not current admission
S X0=^FHPT(FHDFN,"A",ADM,0),W1=+$P(X0,"^",8) I '$D(^TMP($J,"W",W1)) Q ; Not in this Comm Office
S R1=$G(^DPT(DFN,.101))
S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"")
S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
S ^TMP($J,"I",^TMP($J,"W",W1)_"~"_R0_"~"_R1_"~"_FHDFN,DA)=$P(Z,"^",4,9) Q
Q5 ; process discharges
S W1=+$P(Z,"^",8) Q:'W1 Q:'$D(^TMP($J,"W",W1))
S ^TMP($J,"I",^TMP($J,"W",W1)_"~~***~"_FHDFN,DA)=$P(Z,"^",4,9)
Q
;
PROSG ;process recurring, special and guest meals.
S FHPLNM=""
S:$G(FHP) FHPLNM=$P($G(^FH(119.73,FHP,0)),U,1)
REC ;for recurring meals
;S FHTMPS=$NA(^TMP($J,"OP","R",FHPLNM))
S FHTMPS="^TMP($J,""OP"",""R"")"
S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
.I (FHPLNM'=""),(FHN'=FHPLNM) Q
.S FHPROR="01",FHLOC=""
.S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
.S:$G(FHLOC) FHPROR=$P($G(^FH(119.6,FHLOC,0)),U,4)
.F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>NOW) D
..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
..S $P(FHRDAT,U,3)=$P(FHIJKDAT,U,18)
..S $P(FHRDAT,U,4)=$P(FHIJKDAT,U,3)
..S $P(FHRDAT,U,9)=$P(FHIJKDAT,U,4)
..S $P(FHRDAT,U,5)=$P(FHIJKDAT,U,8)
..S $P(FHRDAT,U,8)=$P(FHIJKDAT,U,7)
..S $P(FHRDAT,U,13)=$P(FHIJKDAT,U,17)
..S FHLPAT=FHPROR_"~"_FHI_"~~~"_$P(FHIJKDAT,U,1)
..S ^TMP($J,"O",FHLPAT,FHK)="RECURRING"_"^"_FHJ_"^"_FHRDAT
SPEC ;for special meals
;S FHPLNM=$P($G(^FH(119.73,FHP,0)),U,1) Q:FHPLNM="" ;quit if no comm
;S FHTMPS=$NA(^TMP($J,"OP","S"))
S FHTMPS="^TMP($J,""OP"",""S"")"
S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
.I (FHPLNM'=""),(FHN'=FHPLNM) Q
.S FHPROR="01",FHLOC=""
.S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
.S:$G(FHLOC) FHPROR=$P($G(^FH(119.6,FHLOC,0)),U,4)
.F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>NOW) D
..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
..S FHLPAT=FHPROR_"~"_FHI_"~~~"_$P(FHIJKDAT,U,1)
..S ^TMP($J,"O",FHLPAT,FHK)="SPECIAL"_"^"_FHJ_"^"_FHIJKDAT
;for guest meals
GUEST ;S FHTMPS=$NA(^TMP($J,"OP","G",FHPLNM))
S FHTMPS="^TMP($J,""OP"",""G"")"
S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
.I (FHPLNM'=""),(FHN'=FHPLNM) Q
.S FHPROR="01",FHLOC=""
.S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
.S:$G(FHLOC) FHPROR=$P($G(^FH(119.6,FHLOC,0)),U,4)
.F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>NOW) D
..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
..S FHGDIET=$P($G(^FH(119.9,1,0)),U,2)
..S $P(FHIJKDAT,U,9)=$P(FHIJKDAT,U,3)
..S $P(FHIJKDAT,U,14)=$P(FHIJKDAT,U,4)
..S $P(FHIJKDAT,U,15)=$P(FHIJKDAT,U,5)
..S FHGDIETN=$P(FHIJKDAT,U,6)
..I $G(FHGDIETN),$D(^FH(111,FHGDIETN,0)) D
...S FHGDTNM=$P(^FH(111,FHGDIETN,0),U,1)
..E S:$G(FHGDIET) FHGDTNM=$P($G(^FH(111,FHGDIET,0)),U,1)
..S $P(FHIJKDAT,U,4)=FHGDTNM
..I $G(FHGDIET),$D(^FH(111,FHGDIET,0)) D
...S $P(FHIJKDAT,U,4)=$P(^FH(111,FHGDIET,0),U,1)
..S FHLPAT=FHPROR_"~"_FHI_"~~~"_$P(FHIJKDAT,U,1)
..S ^TMP($J,"O",FHLPAT,FHK)="GUEST"_"^"_FHJ_"^"_FHIJKDAT
Q
;
KIL K ^TMP($J) G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORX1 6693 printed Sep 02, 2024@18:39:24 Page 2
FHORX1 ; HISC/REL/RVD - Diet Activity Report ;9/10/98 15:31
+1 ;;5.5;DIETETICS;**1,8**;Jan 28, 2005;Build 28
+2 ;RVD patch #1 - get outpatient info from Nutrition Events file.
+3 ;
+4 DO NOW^%DTC
SET NOW=%
SET TIM=""
R0 DO DIV^FHOMUTL
if '$DATA(FHSITE)
GOTO KIL
+1 SET FHP=FHSITE
R1 READ !!,"Do you want labels? N// ",X:DTIME
if '$TEST!(X["^")
GOTO KIL
if X=""
SET X="N"
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7," Enter YES or NO"
GOTO R1
+1 SET LAB=X?1"Y".E
+2 if $GET(FHP)
SET TIM=$PIECE($GET(^FH(119.73,FHP,0)),"^",$SELECT(LAB:3,1:2))
+3 IF 'TIM
SET TIM=DT
+4 SET FHLBFLG=1
IF LAB
Begin DoDot:1
+5 WRITE !
KILL DIR,LABSTART
SET DIR(0)="NA^1:10"
SET DIR("A")="If using laser label sheets, what row do you want to begin printing at? "
SET DIR("B")=1
DO ^DIR
+6 IF $DATA(DIRUT)
SET FHLBFLG=0
QUIT
+7 SET LABSTART=Y
QUIT
End DoDot:1
IF FHLBFLG=0
QUIT
+8 SET DTP=TIM
DO DTP^FH
R3 WRITE !!,"Changes since Date/Time: ",DTP," // "
READ X:DTIME
if '$TEST!(X["^")
GOTO KIL
IF X'=""
SET %DT="EXTS"
DO ^%DT
KILL %DT
if Y<1
GOTO R3
SET TIM=Y
+1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select "_$SELECT(LAB:"LABEL",1:"LIST")_" Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+2 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHORX1"
SET FHLST="TIM^LAB^FHP^LABSTART^FHSITE^FHSITENM"
DO EN2^FH
GOTO KIL
+3 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Print the Diet Activity Report
+1 ;save date/time for recurring meal data.
SET FHTIM=TIM
+2 KILL ^TMP($JOB)
DO NOW^%DTC
SET NOW=%
SET DTP=TIM
SET TIM=TIM-.000001
DO DTP^FH
SET H1=DTP_" - "
SET DTP=NOW
DO DTP^FH
SET H1=H1_DTP
DO ^FHDEV
+3 FOR W1=0:0
SET W1=$ORDER(^FH(119.6,W1))
if W1<1
QUIT
DO WRD
+4 IF LAB
SET LAB=$PIECE($GET(^FH(119.9,1,"D",IOS,0)),"^",2)
if 'LAB
SET LAB=1
+5 FOR LLL=TIM:0
SET LLL=$ORDER(^FH(119.8,"AD",LLL))
if LLL<1
QUIT
FOR DA=0:0
SET DA=$ORDER(^FH(119.8,"AD",LLL,DA))
if DA<1
QUIT
DO Q3
+6 ;
OUTP ;get outpatient data
+1 FOR LLL=TIM:0
SET LLL=$ORDER(^FH(119.8,"AD",LLL))
if LLL<1
QUIT
FOR DA=0:0
SET DA=$ORDER(^FH(119.8,"AD",LLL,DA))
if DA<1
QUIT
Begin DoDot:1
+2 SET FHPROR=99
SET (FHTC,FHCOMO)=""
+3 SET Z=$GET(^FH(119.8,DA,0))
if Z=""
QUIT
+4 SET FHDTIM=$PIECE(Z,"^",2)
SET FHDFN=$PIECE(Z,"^",3)
SET FHOUTP=$PIECE(Z,"^",5)
+5 if FHOUTP'="Z"
QUIT
+6 SET FHACTI=$PIECE(Z,"^",6)
+7 SET FHDESC=$PIECE(Z,"^",8)
SET FHLOCN=$PIECE(FHDESC,",",2)
+8 SET FHLOCN=$EXTRACT(FHLOCN,2,$LENGTH(FHLOCN))
+9 if FHLOCN'=""
SET FHLIEN=$ORDER(^FH(119.6,"B",FHLOCN,0))
+10 IF $GET(FHLIEN)
Begin DoDot:2
+11 SET FHPROR=$PIECE($GET(^FH(119.6,FHLIEN,0)),U,4)
+12 SET FHSERV1=$PIECE($GET(^FH(119.6,FHLIEN,0)),U,5)
+13 IF $GET(FHSERV1)
IF $DATA(^FH(119.72,FHSERV1,0))
SET FHTC=FHTC_$PIECE(^(0),U,2)
+14 SET FHSERV2=$PIECE($GET(^FH(119.6,FHLIEN,0)),U,6)
+15 IF $GET(FHSERV2)
IF $DATA(^FH(119.72,FHSERV2,0))
SET FHTC=FHTC_$PIECE(^(0),U,2)
+16 SET FHSERV3=$PIECE($GET(^FH(119.6,FHLIEN,0)),U,7)
+17 IF $GET(FHSERV3)
SET FHTC=FHTC_"D"
+18 SET FHCOMO=$PIECE($GET(^FH(119.6,FHLIEN,0)),U,8)
End DoDot:2
+19 IF $GET(FHSITE)
IF FHCOMO'=FHSITE
QUIT
+20 SET FHCLER=$PIECE(Z,"^",9)
+21 SET FHPTNM="***"
+22 if FHLOCN=""
SET FHLOCN="***"
+23 DO PATNAME^FHOMUTL
+24 SET FHLPAT=FHPROR_"~"_FHLOCN_"~~"_DFN_"~"_FHPTNM
+25 SET DTP=FHDTIM
DO DTP^FH
+26 SET ^TMP($JOB,"O",FHLPAT,DA)=FHACTI_"^"_DTP_"^"_FHBID_"^"_FHDESC_"^"_FHTC
End DoDot:1
+27 ;
+28 ;D PROSG ;print outpatient data
+29 ;go to routines for printing report
+30 if 'LAB
GOTO ^FHORX1A
GOTO ^FHORX1B
WRD SET P0=$GET(^FH(119.6,W1,0))
SET WRDN=$PIECE(P0,"^",1)
SET D2=$PIECE(P0,"^",8)
SET P0=$PIECE(P0,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
+1 IF $GET(FHP)
IF D2=FHP
SET ^TMP($JOB,"W",W1)=P0_"~"_WRDN
+2 IF '$GET(FHP)
SET ^TMP($JOB,"W",W1)=P0_"~"_WRDN
+3 QUIT
Q3 SET Z=$GET(^FH(119.8,DA,0))
if Z=""
QUIT
SET TM1=($PIECE(Z,"^",2)\1)
SET FHDFN=$PIECE(Z,"^",3)
SET ADM=$PIECE(Z,"^",4)
if '$GET(ADM)
QUIT
if '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
+1 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+2 ; Not an inpatient
SET WARD=$GET(^DPT(DFN,.1))
if WARD=""
GOTO Q5
+3 ; Not current admission
IF $GET(^DPT("CN",WARD,DFN))'=ADM
QUIT
+4 ; Not in this Comm Office
SET X0=^FHPT(FHDFN,"A",ADM,0)
SET W1=+$PIECE(X0,"^",8)
IF '$DATA(^TMP($JOB,"W",W1))
QUIT
+5 SET R1=$GET(^DPT(DFN,.101))
+6 SET RI=$GET(^DPT(DFN,.108))
SET RE=$SELECT(RI:$ORDER(^FH(119.6,"AR",+RI,W1,0)),1:"")
+7 SET R0=$SELECT(RE:$PIECE($GET(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
+8 SET R0=$SELECT(R0<1:99,R0<10:"0"_R0,1:R0)
+9 SET ^TMP($JOB,"I",^TMP($JOB,"W",W1)_"~"_R0_"~"_R1_"~"_FHDFN,DA)=$PIECE(Z,"^",4,9)
QUIT
Q5 ; process discharges
+1 SET W1=+$PIECE(Z,"^",8)
if 'W1
QUIT
if '$DATA(^TMP($JOB,"W",W1))
QUIT
+2 SET ^TMP($JOB,"I",^TMP($JOB,"W",W1)_"~~***~"_FHDFN,DA)=$PIECE(Z,"^",4,9)
+3 QUIT
+4 ;
PROSG ;process recurring, special and guest meals.
+1 SET FHPLNM=""
+2 if $GET(FHP)
SET FHPLNM=$PIECE($GET(^FH(119.73,FHP,0)),U,1)
REC ;for recurring meals
+1 ;S FHTMPS=$NA(^TMP($J,"OP","R",FHPLNM))
+2 SET FHTMPS="^TMP($J,""OP"",""R"")"
+3 SET FHN=""
FOR
SET FHN=$ORDER(@FHTMPS@(FHN))
if FHN=""
QUIT
SET FHI=""
FOR
SET FHI=$ORDER(@FHTMPS@(FHN,FHI))
if FHI=""
QUIT
SET FHJ=""
FOR
SET FHJ=$ORDER(@FHTMPS@(FHN,FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:1
+4 IF (FHPLNM'="")
IF (FHN'=FHPLNM)
QUIT
+5 SET FHPROR="01"
SET FHLOC=""
+6 if $DATA(^FH(119.6,"B",FHI))
SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
+7 if $GET(FHLOC)
SET FHPROR=$PIECE($GET(^FH(119.6,FHLOC,0)),U,4)
+8 FOR FHK=0:0
SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
if (FHK'>0)!(FHK>NOW)
QUIT
Begin DoDot:2
+9 SET (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
+10 SET $PIECE(FHRDAT,U,3)=$PIECE(FHIJKDAT,U,18)
+11 SET $PIECE(FHRDAT,U,4)=$PIECE(FHIJKDAT,U,3)
+12 SET $PIECE(FHRDAT,U,9)=$PIECE(FHIJKDAT,U,4)
+13 SET $PIECE(FHRDAT,U,5)=$PIECE(FHIJKDAT,U,8)
+14 SET $PIECE(FHRDAT,U,8)=$PIECE(FHIJKDAT,U,7)
+15 SET $PIECE(FHRDAT,U,13)=$PIECE(FHIJKDAT,U,17)
+16 SET FHLPAT=FHPROR_"~"_FHI_"~~~"_$PIECE(FHIJKDAT,U,1)
+17 SET ^TMP($JOB,"O",FHLPAT,FHK)="RECURRING"_"^"_FHJ_"^"_FHRDAT
End DoDot:2
End DoDot:1
SPEC ;for special meals
+1 ;S FHPLNM=$P($G(^FH(119.73,FHP,0)),U,1) Q:FHPLNM="" ;quit if no comm
+2 ;S FHTMPS=$NA(^TMP($J,"OP","S"))
+3 SET FHTMPS="^TMP($J,""OP"",""S"")"
+4 SET FHN=""
FOR
SET FHN=$ORDER(@FHTMPS@(FHN))
if FHN=""
QUIT
SET FHI=""
FOR
SET FHI=$ORDER(@FHTMPS@(FHN,FHI))
if FHI=""
QUIT
SET FHJ=""
FOR
SET FHJ=$ORDER(@FHTMPS@(FHN,FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:1
+5 IF (FHPLNM'="")
IF (FHN'=FHPLNM)
QUIT
+6 SET FHPROR="01"
SET FHLOC=""
+7 if $DATA(^FH(119.6,"B",FHI))
SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
+8 if $GET(FHLOC)
SET FHPROR=$PIECE($GET(^FH(119.6,FHLOC,0)),U,4)
+9 FOR FHK=0:0
SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
if (FHK'>0)!(FHK>NOW)
QUIT
Begin DoDot:2
+10 SET FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
+11 SET FHLPAT=FHPROR_"~"_FHI_"~~~"_$PIECE(FHIJKDAT,U,1)
+12 SET ^TMP($JOB,"O",FHLPAT,FHK)="SPECIAL"_"^"_FHJ_"^"_FHIJKDAT
End DoDot:2
End DoDot:1
+13 ;for guest meals
GUEST ;S FHTMPS=$NA(^TMP($J,"OP","G",FHPLNM))
+1 SET FHTMPS="^TMP($J,""OP"",""G"")"
+2 SET FHN=""
FOR
SET FHN=$ORDER(@FHTMPS@(FHN))
if FHN=""
QUIT
SET FHI=""
FOR
SET FHI=$ORDER(@FHTMPS@(FHN,FHI))
if FHI=""
QUIT
SET FHJ=""
FOR
SET FHJ=$ORDER(@FHTMPS@(FHN,FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:1
+3 IF (FHPLNM'="")
IF (FHN'=FHPLNM)
QUIT
+4 SET FHPROR="01"
SET FHLOC=""
+5 if $DATA(^FH(119.6,"B",FHI))
SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
+6 if $GET(FHLOC)
SET FHPROR=$PIECE($GET(^FH(119.6,FHLOC,0)),U,4)
+7 FOR FHK=0:0
SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
if (FHK'>0)!(FHK>NOW)
QUIT
Begin DoDot:2
+8 SET FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
+9 SET FHGDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
+10 SET $PIECE(FHIJKDAT,U,9)=$PIECE(FHIJKDAT,U,3)
+11 SET $PIECE(FHIJKDAT,U,14)=$PIECE(FHIJKDAT,U,4)
+12 SET $PIECE(FHIJKDAT,U,15)=$PIECE(FHIJKDAT,U,5)
+13 SET FHGDIETN=$PIECE(FHIJKDAT,U,6)
+14 IF $GET(FHGDIETN)
IF $DATA(^FH(111,FHGDIETN,0))
Begin DoDot:3
+15 SET FHGDTNM=$PIECE(^FH(111,FHGDIETN,0),U,1)
End DoDot:3
+16 IF '$TEST
if $GET(FHGDIET)
SET FHGDTNM=$PIECE($GET(^FH(111,FHGDIET,0)),U,1)
+17 SET $PIECE(FHIJKDAT,U,4)=FHGDTNM
+18 IF $GET(FHGDIET)
IF $DATA(^FH(111,FHGDIET,0))
Begin DoDot:3
+19 SET $PIECE(FHIJKDAT,U,4)=$PIECE(^FH(111,FHGDIET,0),U,1)
End DoDot:3
+20 SET FHLPAT=FHPROR_"~"_FHI_"~~~"_$PIECE(FHIJKDAT,U,1)
+21 SET ^TMP($JOB,"O",FHLPAT,FHK)="GUEST"_"^"_FHJ_"^"_FHIJKDAT
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
