- 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 Mar 13, 2025@20:58:43 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
