FHORX1B ; HISC/REL/RVD - Diet Activity Labels ;8/26/94 12:10
;;5.5;DIETETICS;**1,8**;Jan 28, 2005;Build 28
;
;^tmp($J,"I" - for inpatient data.
;^tmp($J,"O" - for outpatient data;
;
;S FHPIO="** INPATIENT **"
S S2=LAB=2*5+36 I LAB<3 D LHD
S COUNT=0,LINE=1
S P0="",NN=0 F S P0=$O(^TMP($J,"I",P0)) Q:P0="" D LST
;S FHPIO="** OUTPATIENT **"
D LST1 ;go process event for outpatient
S:$G(FHP) $P(^FH(119.73,FHP,0),"^",3)=NOW
I '$G(FHP) F FHII=0:0 S FHII=$O(^FH(119.73,FHII)) Q:FHII'>0 S $P(^FH(119.73,FHII,0),"^",3)=NOW
I LAB>2 D DPLL^FHLABEL
I LAB<3 F L=1:1:18 W !
K ^TMP($J) D KILL^XUSCLEAN
Q
LST K PP S NP=0,LOC=0 F DA=0:0 S DA=$O(^TMP($J,"I",P0,DA)) Q:DA<1 S Z=^(DA) D L1
Q:LOC
I $D(PP) D L2 D:$G(FHORD) WRT
Q
;
LST1 ;process outpatient
K PP S NP=0,LOC=0,P0="" F S P0=$O(^TMP($J,"O",P0)) Q:P0="" D T2
Q
;
L1 ; Process event for inpatient
S ADM=$P(Z,"^",1),TYP=$P(Z,"^",2),ACT=$P(Z,"^",3),FHORD=$P(Z,"^",4),TXT=$P(Z,"^",5)
Q:"DIL"'[TYP I 'FHORD S NN=NN+1,FHORD=NN
I "DI"[TYP D
.I $D(PP(TYP,ADM_"~"_FHORD)),ACT="C" K PP(TYP,ADM_"~"_FHORD) Q
.K PP(TYP) S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT Q
I TYP="L" D
.I ACT="D" S LOC=1 Q
.S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT S:ACT="A" NP=1 Q
Q
;
L2 S W1=$P(P0,"~",2),R1=$P(P0,"~",4),FHDFN=$P(P0,"~",5)
D PATNAME^FHOMUTL I DFN="" Q
S Y0=$G(^DPT(DFN,0))
S N1=$P(Y0,"^",1) D PID^FHDPA
S TC=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",5),IS=$P($G(^(0)),"^",10),FHORD=+$P($G(^(0)),"^",2)
Q:'FHORD
I IS S IS=$G(^FH(119.4,IS,0)) I IS'="" S TC=TC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) D CUR
Q
;
T2 ;get the last outpatient entry.
K PP S NP=0,LOC=0 F FH8=0:0 S FH8=$O(^TMP($J,"O",P0,FH8)) Q:FH8'>0 D
.S FHTDAT=$G(^TMP($J,"O",P0,FH8))
.S FHACTI=$P(FHTDAT,"^",1)
.Q:FHACTI'="O"
.S BID=$P(FHTDAT,"^",3)
.S FHDESC=$P(FHTDAT,"^",4)
.S TC=$P(FHTDAT,"^",5)
.S FHDES1=$P(FHDESC,",",1)
.S FHDIET=$P(FHDES1,":",2),FHDIET=$E(FHDIET,2,$L(FHDIET))
.I FHDIET'="",$D(^FH(111,"B",FHDIET)) S FHDIDA=$O(^FH(111,"B",FHDIET,0))
.Q:'$G(FHDIDA)
.I $G(FHDIDA),$D(^FH(111,FHDIDA,0)) S FHDIET=$P(^FH(111,FHDIDA,0),U,7)
.;S:FHDIET="" FHDIET="NO ORDER"
.S Y=FHDIET
.S W1=$P(P0,"~",2),R1="",N1=$P(P0,"~",5)
.D WRT
Q
;
WRT S ALG="" D ALG^FHCLN
I LAB>2 D LL Q
W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W:NP " *"
W @FHIO("EON") W ?(S2-3\2),TC W @FHIO("EOF") W ?(S2-3-$L(R1)),R1 W @FHIO("EON") I $L(Y)<S2 W:LAB=2 ! W !,$S(ALG="":"",1:"*ALG"),!,Y,!!
E S L=$S($L($P(Y,",",1,3))<S2:3,1:2) W !!,$P(Y,",",1,L) W:LAB=2 ! W !,$E($P(Y,",",L+1,5),2,99),!
W @FHIO("EOF") W:LAB=2 ?(S2-20),$P(H1," - ",2),!! Q
;
LHD S A1=S2-30\2 W:LAB=2 ! W !?A1,"***************************",!?A1,"*",?(A1+26),"*",!?A1,"*",?(A1+5),$P(H1," - ",2),?(A1+26),"*"
W !?A1,"*",?(A1+26),"*",!?A1,"***************************",! W:LAB=2 !! Q
CUR S Y="" Q:X="" S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7)
I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") Q:%<1 S Y=$P($E(FHDU,%,999),";",1) Q
F A1=1:1:5 S D3=$P(FHOR,"^",A1) I D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7)
Q
LL ;
S X1=TC S:NP BID=BID_" *"
D LAB^FHLABEL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORX1B 3196 printed Sep 23, 2025@19:30:04 Page 2
FHORX1B ; HISC/REL/RVD - Diet Activity Labels ;8/26/94 12:10
+1 ;;5.5;DIETETICS;**1,8**;Jan 28, 2005;Build 28
+2 ;
+3 ;^tmp($J,"I" - for inpatient data.
+4 ;^tmp($J,"O" - for outpatient data;
+5 ;
+6 ;S FHPIO="** INPATIENT **"
+7 SET S2=LAB=2*5+36
IF LAB<3
DO LHD
+8 SET COUNT=0
SET LINE=1
+9 SET P0=""
SET NN=0
FOR
SET P0=$ORDER(^TMP($JOB,"I",P0))
if P0=""
QUIT
DO LST
+10 ;S FHPIO="** OUTPATIENT **"
+11 ;go process event for outpatient
DO LST1
+12 if $GET(FHP)
SET $PIECE(^FH(119.73,FHP,0),"^",3)=NOW
+13 IF '$GET(FHP)
FOR FHII=0:0
SET FHII=$ORDER(^FH(119.73,FHII))
if FHII'>0
QUIT
SET $PIECE(^FH(119.73,FHII,0),"^",3)=NOW
+14 IF LAB>2
DO DPLL^FHLABEL
+15 IF LAB<3
FOR L=1:1:18
WRITE !
+16 KILL ^TMP($JOB)
DO KILL^XUSCLEAN
+17 QUIT
LST KILL PP
SET NP=0
SET LOC=0
FOR DA=0:0
SET DA=$ORDER(^TMP($JOB,"I",P0,DA))
if DA<1
QUIT
SET Z=^(DA)
DO L1
+1 if LOC
QUIT
+2 IF $DATA(PP)
DO L2
if $GET(FHORD)
DO WRT
+3 QUIT
+4 ;
LST1 ;process outpatient
+1 KILL PP
SET NP=0
SET LOC=0
SET P0=""
FOR
SET P0=$ORDER(^TMP($JOB,"O",P0))
if P0=""
QUIT
DO T2
+2 QUIT
+3 ;
L1 ; Process event for inpatient
+1 SET ADM=$PIECE(Z,"^",1)
SET TYP=$PIECE(Z,"^",2)
SET ACT=$PIECE(Z,"^",3)
SET FHORD=$PIECE(Z,"^",4)
SET TXT=$PIECE(Z,"^",5)
+2 if "DIL"'[TYP
QUIT
IF 'FHORD
SET NN=NN+1
SET FHORD=NN
+3 IF "DI"[TYP
Begin DoDot:1
+4 IF $DATA(PP(TYP,ADM_"~"_FHORD))
IF ACT="C"
KILL PP(TYP,ADM_"~"_FHORD)
QUIT
+5 KILL PP(TYP)
SET PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT
QUIT
End DoDot:1
+6 IF TYP="L"
Begin DoDot:1
+7 IF ACT="D"
SET LOC=1
QUIT
+8 SET PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT
if ACT="A"
SET NP=1
QUIT
End DoDot:1
+9 QUIT
+10 ;
L2 SET W1=$PIECE(P0,"~",2)
SET R1=$PIECE(P0,"~",4)
SET FHDFN=$PIECE(P0,"~",5)
+1 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+2 SET Y0=$GET(^DPT(DFN,0))
+3 SET N1=$PIECE(Y0,"^",1)
DO PID^FHDPA
+4 SET TC=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",5)
SET IS=$PIECE($GET(^(0)),"^",10)
SET FHORD=+$PIECE($GET(^(0)),"^",2)
+5 if 'FHORD
QUIT
+6 IF IS
SET IS=$GET(^FH(119.4,IS,0))
IF IS'=""
SET TC=TC_"-"_$PIECE(IS,"^",2)_$PIECE(IS,"^",3)
+7 SET X=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
DO CUR
+8 QUIT
+9 ;
T2 ;get the last outpatient entry.
+1 KILL PP
SET NP=0
SET LOC=0
FOR FH8=0:0
SET FH8=$ORDER(^TMP($JOB,"O",P0,FH8))
if FH8'>0
QUIT
Begin DoDot:1
+2 SET FHTDAT=$GET(^TMP($JOB,"O",P0,FH8))
+3 SET FHACTI=$PIECE(FHTDAT,"^",1)
+4 if FHACTI'="O"
QUIT
+5 SET BID=$PIECE(FHTDAT,"^",3)
+6 SET FHDESC=$PIECE(FHTDAT,"^",4)
+7 SET TC=$PIECE(FHTDAT,"^",5)
+8 SET FHDES1=$PIECE(FHDESC,",",1)
+9 SET FHDIET=$PIECE(FHDES1,":",2)
SET FHDIET=$EXTRACT(FHDIET,2,$LENGTH(FHDIET))
+10 IF FHDIET'=""
IF $DATA(^FH(111,"B",FHDIET))
SET FHDIDA=$ORDER(^FH(111,"B",FHDIET,0))
+11 if '$GET(FHDIDA)
QUIT
+12 IF $GET(FHDIDA)
IF $DATA(^FH(111,FHDIDA,0))
SET FHDIET=$PIECE(^FH(111,FHDIDA,0),U,7)
+13 ;S:FHDIET="" FHDIET="NO ORDER"
+14 SET Y=FHDIET
+15 SET W1=$PIECE(P0,"~",2)
SET R1=""
SET N1=$PIECE(P0,"~",5)
+16 DO WRT
End DoDot:1
+17 QUIT
+18 ;
WRT SET ALG=""
DO ALG^FHCLN
+1 IF LAB>2
DO LL
QUIT
+2 WRITE !,$EXTRACT(N1,1,S2-5-$LENGTH(W1)),?(S2-3-$LENGTH(W1)),W1,!,BID
if NP
WRITE " *"
+3 WRITE @FHIO("EON")
WRITE ?(S2-3\2),TC
WRITE @FHIO("EOF")
WRITE ?(S2-3-$LENGTH(R1)),R1
WRITE @FHIO("EON")
IF $LENGTH(Y)<S2
if LAB=2
WRITE !
WRITE !,$SELECT(ALG="":"",1:"*ALG"),!,Y,!!
+4 IF '$TEST
SET L=$SELECT($LENGTH($PIECE(Y,",",1,3))<S2:3,1:2)
WRITE !!,$PIECE(Y,",",1,L)
if LAB=2
WRITE !
WRITE !,$EXTRACT($PIECE(Y,",",L+1,5),2,99),!
+5 WRITE @FHIO("EOF")
if LAB=2
WRITE ?(S2-20),$PIECE(H1," - ",2),!!
QUIT
+6 ;
LHD SET A1=S2-30\2
if LAB=2
WRITE !
WRITE !?A1,"***************************",!?A1,"*",?(A1+26),"*",!?A1,"*",?(A1+5),$PIECE(H1," - ",2),?(A1+26),"*"
+1 WRITE !?A1,"*",?(A1+26),"*",!?A1,"***************************",!
if LAB=2
WRITE !!
QUIT
CUR SET Y=""
if X=""
QUIT
SET FHOR=$PIECE(X,"^",2,6)
SET FHLD=$PIECE(X,"^",7)
+1 IF FHLD'=""
SET FHDU=";"_$PIECE(^DD(115.02,6,0),"^",3)
SET %=$FIND(FHDU,";"_FHLD_":")
if %<1
QUIT
SET Y=$PIECE($EXTRACT(FHDU,%,999),";",1)
QUIT
+2 FOR A1=1:1:5
SET D3=$PIECE(FHOR,"^",A1)
IF D3
if Y'=""
SET Y=Y_", "
SET Y=Y_$PIECE(^FH(111,D3,0),"^",7)
+3 QUIT
LL ;
+1 SET X1=TC
if NP
SET BID=BID_" *"
+2 DO LAB^FHLABEL
QUIT
