- FHORD9 ; HISC/REL/NCA/RVD - Diet Order Census ;7/1/94 14:24
- ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
- ;
- ;patch #5 - added screen for cancelled guest meals.
- ;
- D NOW^%DTC S DT=%\1 K %,^TMP($J)
- D DIV^FHOMUTL G:'$D(FHSITE) KIL
- S FHP=$O(^FH(119.71,0)) I FHP'<1,$O(^FH(119.71,FHP))<1 G F0
- D0 R !!,"Select PRODUCTION FACILITY: ",X:DTIME G:'$T!("^"[X) KIL
- K DIC S DIC="^FH(119.71,",DIC(0)="EMQ" D ^DIC G:Y<1 D0 S FHP=+Y
- F0 R !!,"Effective Date/Time: ",X:DTIME G:'$T!("^"[X) KIL S %DT="ETSX" D ^%DT G:Y<1 F0 S TIM=Y
- I (TIM\1)<DT W *7," Cannot be before TODAY!" G F0
- 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^FHORD9",FHLST="FHP^TIM^FHSITE^FHSITENM" D EN2^FH G KIL
- U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
- Q1 ; Calculate census
- K ^TMP($J) S CT=0 D NOW^%DTC S NOW=% K %,D,P
- F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 S X=^(WRD,0) D
- .I '$G(FHSITE) D WRD
- .I ($G(FHSITE)),($P(X,U,8)=FHSITE) D WRD
- ;
- ;get outpatient data
- S:'$G(FHSITE) FHSITE=""
- S:'$D(FHSITENM) FHSITENM="CONSOLIDATED"
- D GETSM^FHOMRBLD(TIM,FHSITE,"","")
- D GETGM^FHOMRBL1(TIM,FHSITE,"","")
- S FHTIM=$P(TIM,".",1),FHTIM=FHTIM-.000001
- D GETRM^FHOMRBLD(FHTIM,FHSITE,"","")
- D PROSG ;process recurring, special and guest meal from "OP" node
- G ^FHORD91
- WRD ; Calculate census for ward
- K S S X1="" F D2=5,6 S N1=$P(X,"^",D2) Q:$G(^FH(119.72,+N1,"I"))="Y" S N2=$P($G(^FH(119.72,+N1,0)),"^",3) I N2=FHP S S($E("TC",D2-4))=N1,D(N1)="",X1=X1_$E("TC",D2-4)
- Q:'$D(S)
- S:$L(X1)>1 X1=$E(X1,1) Q:'$D(S(X1)) S SP=S(X1)
- F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",WRD,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",WRD,FHDFN)) I ADM>0 S K=SP D W3
- Q
- W3 Q:'$D(^FHPT(FHDFN,"A",ADM,0))
- S X0=^FHPT(FHDFN,"A",ADM,0)
- S FHORD=$P(X0,"^",2),X1=$P(X0,"^",3),TF=$P(X0,"^",4),N1=$P(X0,"^",5) S:N1="" N1="T"
- I FHORD<1 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",0)) G:A1=""!(A1>TIM) W4 D U1 G:'FHORD W4 S X1=""
- I X1>1,X1'>TIM D U1 G:'FHORD W4
- I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) D U1 G:'FHORD W4
- S X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7),X1=$P(X,"^",8)
- S:X1="" X1=N1 S:X1="D" X1="T" Q:'$D(S(X1)) S K=S(X1) D CNT
- I FHLD="" S Z=$P(X,"^",13) S:Z="" FHLD="X" I Z S:'$D(P(Z,K)) P(Z,K)=0 S P(Z,K)=P(Z,K)+1 Q
- I FHLD="P" S:'$D(P(.8,K)) P(.8,K)=0 S P(.8,K)=P(.8,K)+1 Q
- I FHLD="N" D Q
- .I TF="" S:'$D(P(.5,K)) P(.5,K)=0 S P(.5,K)=P(.5,K)+1 Q
- .S:'$D(P(.7,K)) P(.7,K)=0 S P(.7,K)=P(.7,K)+1 Q
- Q:'TF S:'$D(P(.7,K)) P(.7,K)=0 S P(.7,K)=P(.7,K)+1 Q
- W4 G:'TF CNT S:'$D(P(.7,K)) P(.7,K)=0 S P(.7,K)=P(.7,K)+1
- CNT S:'$D(P(.6,K)) P(.6,K)=0 S P(.6,K)=P(.6,K)+1 Q
- U1 S (A1,FHORD)=0 F K1=0:0 S K1=$O(^FHPT(FHDFN,"A",ADM,"AC",K1)) Q:K1<1!(K1>TIM) S A1=K1
- Q:'A1 S X1=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G U2:X1<1,U2:'$D(^FHPT(FHDFN,"A",ADM,"DI",X1,0)) S FHORD=X1 Q
- U2 S X1="",A1=0
- U3 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) G:A1="" U1 S X2=$P(^(A1,0),"^",2)
- I X2<1 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G U3
- I '$D(^FHPT(FHDFN,"A",ADM,"DI",X2,0)) K ^FHPT(FHDFN,"A",ADM,"AC",A1) G U3
- G U3
- PROSG ;process outpatient data from ^tmp($j global.
- S FHPLNM=""
- S:$G(FHSITE) FHPLNM=$P($G(^FH(119.73,FHSITE,0)),U,1)
- REC ;for recurring meals
- S FHDT=TIM+.999999
- ;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
- .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
- ..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
- ..Q:$P(FHRDAT,U,19)="C" ;quit if status is cancelled.
- ..S (FHPDIET,FHDIET,FHSER,FHLOC)="***"
- ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
- ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
- ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
- ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
- ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
- ..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
- ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
- ..S FHREIEN=$P(FHIJKDAT,U,1)
- ..S FHDIETN=$P(FHIJKDAT,U,3)
- ..S:$D(^FH(111,"B",FHDIETN)) FHDIET=$O(^FH(111,"B",FHDIETN,0))
- ..S:$D(^FH(111,FHDIET,0)) FHPDIET=$P(^FH(111,FHDIET,0),U,5)
- ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
- ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
- ..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
- ..;if tubefeeding, also count the TF data.
- ..I $D(^FHPT(FHREIEN,"OP",FHK,"TF")) D
- ...I '$D(P(.7,FHSER)) S P(.7,FHSER)=1
- ...E S P(.7,FHSER)=P(.7,FHSER)+1
- ...S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
- ;
- SPEC ;for special meals
- S FHTMPS="^TMP($J,""OP"",""S"")" I '$D(FHPLNM) S FHPLNM=""
- 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
- .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
- ..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
- ..S (FHPDIET,FHDIET,FHSER,FHLOC)="***"
- ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
- ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
- ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
- ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
- ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
- ..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
- ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
- ..S FHSTAT=$P(FHIJKDAT,U,3)
- ..Q:FHSTAT'="A" ;quit if status is not Authorized
- ..S FHDIETN=$P(FHIJKDAT,U,4)
- ..S:$D(^FH(111,"B",FHDIETN)) FHDIET=$O(^FH(111,"B",FHDIETN,0))
- ..S:$D(^FH(111,FHDIET,0)) FHPDIET=$P(^FH(111,FHDIET,0),U,5)
- ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
- ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
- ..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
- ;
- GUEST ;for guest meals.
- ;If no diet, use default outpatient diet in file #119.9.
- ;S FHTMPS=$NA(^TMP($J,"OP","G",FHPLNM))
- S FHTMPS="^TMP($J,""OP"",""G"")" I '$D(FHPLNM) S FHPLNM=""
- 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
- .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
- ..S (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
- ..I $P(FHRDAT,U,7)="C" Q
- ..S (FHPDIET,FHDIET,FHSER,FHLOC)="***"
- ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
- ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
- ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
- ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
- ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
- ..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
- ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
- ..S FHDIETN=$P(FHIJKDAT,U,6)
- ..S:$D(^FH(111,FHDIETN,0)) FHPDIET=$P(^FH(111,FHDIETN,0),U,5)
- ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
- ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
- ..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
- ;
- Q
- ;
- KIL K ^TMP($J) G KILL^XUSCLEAN
- ;K %,%H,%I,%T,%DT,%ZIS,A1,ADM,CHK,CT,D,D1,D2,FHDFN,DFN,DIC,DOW,DTP,FHLD,FHOR,FHP,FHPAR,K,K1,KK,L1,LP,N,N1,N2,N3,NOW,NXW,FHORD,P,P1,POP,S,SP,TF,TIM,TOT,TYP,WRD,WRDN,X,X0,X1,X2,Y,Z K ^TMP($J) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD9 7311 printed Feb 18, 2025@23:20:02 Page 2
- FHORD9 ; HISC/REL/NCA/RVD - Diet Order Census ;7/1/94 14:24
- +1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
- +2 ;
- +3 ;patch #5 - added screen for cancelled guest meals.
- +4 ;
- +5 DO NOW^%DTC
- SET DT=%\1
- KILL %,^TMP($JOB)
- +6 DO DIV^FHOMUTL
- if '$DATA(FHSITE)
- GOTO KIL
- +7 SET FHP=$ORDER(^FH(119.71,0))
- IF FHP'<1
- IF $ORDER(^FH(119.71,FHP))<1
- GOTO F0
- D0 READ !!,"Select PRODUCTION FACILITY: ",X:DTIME
- if '$TEST!("^"[X)
- GOTO KIL
- +1 KILL DIC
- SET DIC="^FH(119.71,"
- SET DIC(0)="EMQ"
- DO ^DIC
- if Y<1
- GOTO D0
- SET FHP=+Y
- F0 READ !!,"Effective Date/Time: ",X:DTIME
- if '$TEST!("^"[X)
- GOTO KIL
- SET %DT="ETSX"
- DO ^%DT
- if Y<1
- GOTO F0
- SET TIM=Y
- +1 IF (TIM\1)<DT
- WRITE *7," Cannot be before TODAY!"
- GOTO F0
- +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^FHORD9"
- SET FHLST="FHP^TIM^FHSITE^FHSITENM"
- DO EN2^FH
- GOTO KIL
- +4 USE IO
- DO Q1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- Q1 ; Calculate census
- +1 KILL ^TMP($JOB)
- SET CT=0
- DO NOW^%DTC
- SET NOW=%
- KILL %,D,P
- +2 FOR WRD=0:0
- SET WRD=$ORDER(^FH(119.6,WRD))
- if WRD<1
- QUIT
- SET X=^(WRD,0)
- Begin DoDot:1
- +3 IF '$GET(FHSITE)
- DO WRD
- +4 IF ($GET(FHSITE))
- IF ($PIECE(X,U,8)=FHSITE)
- DO WRD
- End DoDot:1
- +5 ;
- +6 ;get outpatient data
- +7 if '$GET(FHSITE)
- SET FHSITE=""
- +8 if '$DATA(FHSITENM)
- SET FHSITENM="CONSOLIDATED"
- +9 DO GETSM^FHOMRBLD(TIM,FHSITE,"","")
- +10 DO GETGM^FHOMRBL1(TIM,FHSITE,"","")
- +11 SET FHTIM=$PIECE(TIM,".",1)
- SET FHTIM=FHTIM-.000001
- +12 DO GETRM^FHOMRBLD(FHTIM,FHSITE,"","")
- +13 ;process recurring, special and guest meal from "OP" node
- DO PROSG
- +14 GOTO ^FHORD91
- WRD ; Calculate census for ward
- +1 KILL S
- SET X1=""
- FOR D2=5,6
- SET N1=$PIECE(X,"^",D2)
- if $GET(^FH(119.72,+N1,"I"))="Y"
- QUIT
- SET N2=$PIECE($GET(^FH(119.72,+N1,0)),"^",3)
- IF N2=FHP
- SET S($EXTRACT("TC",D2-4))=N1
- SET D(N1)=""
- SET X1=X1_$EXTRACT("TC",D2-4)
- +2 if '$DATA(S)
- QUIT
- +3 if $LENGTH(X1)>1
- SET X1=$EXTRACT(X1,1)
- if '$DATA(S(X1))
- QUIT
- SET SP=S(X1)
- +4 FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("AW",WRD,FHDFN))
- if FHDFN<1
- QUIT
- SET ADM=$GET(^FHPT("AW",WRD,FHDFN))
- IF ADM>0
- SET K=SP
- DO W3
- +5 QUIT
- W3 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
- QUIT
- +1 SET X0=^FHPT(FHDFN,"A",ADM,0)
- +2 SET FHORD=$PIECE(X0,"^",2)
- SET X1=$PIECE(X0,"^",3)
- SET TF=$PIECE(X0,"^",4)
- SET N1=$PIECE(X0,"^",5)
- if N1=""
- SET N1="T"
- +3 IF FHORD<1
- SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",0))
- if A1=""!(A1>TIM)
- GOTO W4
- DO U1
- if 'FHORD
- GOTO W4
- SET X1=""
- +4 IF X1>1
- IF X1'>TIM
- DO U1
- if 'FHORD
- GOTO W4
- +5 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
- DO U1
- if 'FHORD
- GOTO W4
- +6 SET X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)
- SET FHOR=$PIECE(X,"^",2,6)
- SET FHLD=$PIECE(X,"^",7)
- SET X1=$PIECE(X,"^",8)
- +7 if X1=""
- SET X1=N1
- if X1="D"
- SET X1="T"
- if '$DATA(S(X1))
- QUIT
- SET K=S(X1)
- DO CNT
- +8 IF FHLD=""
- SET Z=$PIECE(X,"^",13)
- if Z=""
- SET FHLD="X"
- IF Z
- if '$DATA(P(Z,K))
- SET P(Z,K)=0
- SET P(Z,K)=P(Z,K)+1
- QUIT
- +9 IF FHLD="P"
- if '$DATA(P(.8,K))
- SET P(.8,K)=0
- SET P(.8,K)=P(.8,K)+1
- QUIT
- +10 IF FHLD="N"
- Begin DoDot:1
- +11 IF TF=""
- if '$DATA(P(.5,K))
- SET P(.5,K)=0
- SET P(.5,K)=P(.5,K)+1
- QUIT
- +12 if '$DATA(P(.7,K))
- SET P(.7,K)=0
- SET P(.7,K)=P(.7,K)+1
- QUIT
- End DoDot:1
- QUIT
- +13 if 'TF
- QUIT
- if '$DATA(P(.7,K))
- SET P(.7,K)=0
- SET P(.7,K)=P(.7,K)+1
- QUIT
- W4 if 'TF
- GOTO CNT
- if '$DATA(P(.7,K))
- SET P(.7,K)=0
- SET P(.7,K)=P(.7,K)+1
- CNT if '$DATA(P(.6,K))
- SET P(.6,K)=0
- SET P(.6,K)=P(.6,K)+1
- QUIT
- U1 SET (A1,FHORD)=0
- FOR K1=0:0
- SET K1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K1))
- if K1<1!(K1>TIM)
- QUIT
- SET A1=K1
- +1 if 'A1
- QUIT
- SET X1=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2)
- if X1<1
- GOTO U2
- if '$DATA(^FHPT(FHDFN,"A",ADM,"DI",X1,0))
- GOTO U2
- SET FHORD=X1
- QUIT
- U2 SET X1=""
- SET A1=0
- U3 SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",A1))
- if A1=""
- GOTO U1
- SET X2=$PIECE(^(A1,0),"^",2)
- +1 IF X2<1
- KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
- GOTO U3
- +2 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",X2,0))
- KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
- GOTO U3
- +3 GOTO U3
- PROSG ;process outpatient data from ^tmp($j global.
- +1 SET FHPLNM=""
- +2 if $GET(FHSITE)
- SET FHPLNM=$PIECE($GET(^FH(119.73,FHSITE,0)),U,1)
- REC ;for recurring meals
- +1 SET FHDT=TIM+.999999
- +2 ;S FHTMPS=$NA(^TMP($J,"OP","R",FHPLNM))
- +3 SET FHTMPS="^TMP($J,""OP"",""R"")"
- +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 FOR FHK=0:0
- SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
- if (FHK'>0)!(FHK>FHDT)
- QUIT
- Begin DoDot:2
- +7 SET (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
- +8 ;quit if status is cancelled.
- if $PIECE(FHRDAT,U,19)="C"
- QUIT
- +9 SET (FHPDIET,FHDIET,FHSER,FHLOC)="***"
- +10 if $DATA(^FH(119.6,"B",FHI))
- SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
- +11 if $GET(FHLOC)
- SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
- +12 if '$GET(FHSER)
- SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
- +13 if '$GET(FHSER)
- SET FHSER=$ORDER(^FH(119.72,0))
- +14 IF $DATA(^FH(119.72,FHSER,0))
- IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
- QUIT
- +15 IF $GET(FHSITE)
- IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHSITE
- QUIT
- +16 SET FHDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
- +17 SET FHREIEN=$PIECE(FHIJKDAT,U,1)
- +18 SET FHDIETN=$PIECE(FHIJKDAT,U,3)
- +19 if $DATA(^FH(111,"B",FHDIETN))
- SET FHDIET=$ORDER(^FH(111,"B",FHDIETN,0))
- +20 if $DATA(^FH(111,FHDIET,0))
- SET FHPDIET=$PIECE(^FH(111,FHDIET,0),U,5)
- +21 if '$DATA(P(FHPDIET,FHSER))
- SET P(FHPDIET,FHSER)=0
- +22 SET P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
- +23 if '$DATA(P(.6,FHSER))
- SET P(.6,FHSER)=0
- SET P(.6,FHSER)=P(.6,FHSER)+1
- +24 ;if tubefeeding, also count the TF data.
- +25 IF $DATA(^FHPT(FHREIEN,"OP",FHK,"TF"))
- Begin DoDot:3
- +26 IF '$DATA(P(.7,FHSER))
- SET P(.7,FHSER)=1
- +27 IF '$TEST
- SET P(.7,FHSER)=P(.7,FHSER)+1
- +28 if '$DATA(P(.6,FHSER))
- SET P(.6,FHSER)=0
- SET P(.6,FHSER)=P(.6,FHSER)+1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +29 ;
- SPEC ;for special meals
- +1 SET FHTMPS="^TMP($J,""OP"",""S"")"
- IF '$DATA(FHPLNM)
- SET FHPLNM=""
- +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 FOR FHK=0:0
- SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
- if (FHK'>0)!(FHK>FHDT)
- QUIT
- Begin DoDot:2
- +5 SET (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
- +6 SET (FHPDIET,FHDIET,FHSER,FHLOC)="***"
- +7 if $DATA(^FH(119.6,"B",FHI))
- SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
- +8 if $GET(FHLOC)
- SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
- +9 if '$GET(FHSER)
- SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
- +10 if '$GET(FHSER)
- SET FHSER=$ORDER(^FH(119.72,0))
- +11 IF $DATA(^FH(119.72,FHSER,0))
- IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
- QUIT
- +12 IF $GET(FHSITE)
- IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHSITE
- QUIT
- +13 SET FHDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
- +14 SET FHSTAT=$PIECE(FHIJKDAT,U,3)
- +15 ;quit if status is not Authorized
- if FHSTAT'="A"
- QUIT
- +16 SET FHDIETN=$PIECE(FHIJKDAT,U,4)
- +17 if $DATA(^FH(111,"B",FHDIETN))
- SET FHDIET=$ORDER(^FH(111,"B",FHDIETN,0))
- +18 if $DATA(^FH(111,FHDIET,0))
- SET FHPDIET=$PIECE(^FH(111,FHDIET,0),U,5)
- +19 if '$DATA(P(FHPDIET,FHSER))
- SET P(FHPDIET,FHSER)=0
- +20 SET P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
- +21 if '$DATA(P(.6,FHSER))
- SET P(.6,FHSER)=0
- SET P(.6,FHSER)=P(.6,FHSER)+1
- End DoDot:2
- End DoDot:1
- +22 ;
- GUEST ;for guest meals.
- +1 ;If no diet, use default outpatient diet in file #119.9.
- +2 ;S FHTMPS=$NA(^TMP($J,"OP","G",FHPLNM))
- +3 SET FHTMPS="^TMP($J,""OP"",""G"")"
- IF '$DATA(FHPLNM)
- SET FHPLNM=""
- +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 FOR FHK=0:0
- SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
- if (FHK'>0)!(FHK>FHDT)
- QUIT
- Begin DoDot:2
- +7 SET (FHRDAT,FHIJKDAT)=@FHTMPS@(FHN,FHI,FHJ,FHK)
- +8 IF $PIECE(FHRDAT,U,7)="C"
- QUIT
- +9 SET (FHPDIET,FHDIET,FHSER,FHLOC)="***"
- +10 if $DATA(^FH(119.6,"B",FHI))
- SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
- +11 if $GET(FHLOC)
- SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
- +12 if '$GET(FHSER)
- SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
- +13 if '$GET(FHSER)
- SET FHSER=$ORDER(^FH(119.72,0))
- +14 IF $DATA(^FH(119.72,FHSER,0))
- IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
- QUIT
- +15 IF $GET(FHSITE)
- IF $PIECE($GET(^FH(119.6,FHLOC,0)),U,8)'=FHSITE
- QUIT
- +16 SET FHDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
- +17 SET FHDIETN=$PIECE(FHIJKDAT,U,6)
- +18 if $DATA(^FH(111,FHDIETN,0))
- SET FHPDIET=$PIECE(^FH(111,FHDIETN,0),U,5)
- +19 if '$DATA(P(FHPDIET,FHSER))
- SET P(FHPDIET,FHSER)=0
- +20 SET P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
- +21 if '$DATA(P(.6,FHSER))
- SET P(.6,FHSER)=0
- SET P(.6,FHSER)=P(.6,FHSER)+1
- End DoDot:2
- End DoDot:1
- +22 ;
- +23 QUIT
- +24 ;
- KIL KILL ^TMP($JOB)
- GOTO KILL^XUSCLEAN
- +1 ;K %,%H,%I,%T,%DT,%ZIS,A1,ADM,CHK,CT,D,D1,D2,FHDFN,DFN,DIC,DOW,DTP,FHLD,FHOR,FHP,FHPAR,K,K1,KK,L1,LP,N,N1,N2,N3,NOW,NXW,FHORD,P,P1,POP,S,SP,TF,TIM,TOT,TYP,WRD,WRDN,X,X0,X1,X2,Y,Z K ^TMP($J) Q
