FHORX1A ; HISC/REL/NCA/RVD - Diet Activity Report (cont) ;3/17/95 10:06
;;5.5;DIETETICS;**1,5,8**;Jan 28, 2005;Build 28
;
;process inpatient data.
S PG=0 S FHPIO="** INPATIENT **" D HDR
S P0="",NN=0 F S P0=$O(^TMP($J,"I",P0)) Q:P0="" D LST
;
;process outpatient data.
S FHPIO="** OUTPATIENT **" D HDR
S (FHUSERNM,P0)="",(FHNMSV,NN)=0 F S P0=$O(^TMP($J,"O",P0)) Q:P0="" S (FHBRK,FHNON,FHEVE)=0 D LST1
S:$G(FHP) $P(^FH(119.73,FHP,0),"^",2)=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),"^",2)=NOW
Q
;
LST K PP S NP=0 F DA=0:0 S DA=$O(^TMP($J,"I",P0,DA)) Q:DA<1 S Z=^(DA) D L1
D L2 Q
;
LST1 K PP S NP=0 F DA=0:0 S DA=$O(^TMP($J,"O",P0,DA)) Q:DA'>0 D T1
Q
;
L1 ; Process event
S ADM=$P(Z,"^",1),TYP=$P(Z,"^",2),ACT=$P(Z,"^",3),FHORD=$P(Z,"^",4),TXT=$P(Z,"^",5),CLK=$P(Z,"^",6)
I 'FHORD S NN=NN+1,FHORD=NN
I "DIT"[TYP D
.I TYP="D",FHORD=1 S NP=1
.I $D(PP(TYP,ADM_"~"_FHORD)),ACT="C" K PP(TYP,ADM_"~"_FHORD) Q
.K PP(TYP) S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK Q
I "OPSF"[TYP D
.I $D(PP(TYP,ADM_"~"_FHORD)),ACT="C" K PP(TYP,ADM_"~"_FHORD) Q
.S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK Q
I "LM"[TYP S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK
Q
;
L2 S W1=$P(P0,"~",2),R1=$P(P0,"~",4),FHDFN=$P(P0,"~",5)
D PATNAME^FHOMUTL Q:'$G(DFN)
S Y0=$G(^DPT(DFN,0))
S N1=$P(Y0,"^",1)
;D PID^FHDPA
S TC=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",5),SF=$P($G(^(0)),"^",7),SO=$D(^FHPT("ASP",FHDFN,ADM))
D:$Y>(IOSL-6) HDR W !!,$E(W1_" "_R1,1,20),?22,N1,?50,BID,?63,$S(SF:"SF",1:""),?66,$S(SO:"SO",1:""),?73,TC
D ALG^FHCLN W !,"Allergies: ",$S(ALG="":"None on file",1:ALG),!
D ^FHORX1C D:NP NEWP Q
;
T1 ; Process outpatient event
S FHTDAT=$G(^TMP($J,"O",P0,DA)),DFN=$P(P0,"~",4)
S FHACTI=$P(FHTDAT,"^",1)
S DTP=$P(FHTDAT,"^",2)
S BID=$P(FHTDAT,"^",3)
S FHDESC=$P(FHTDAT,"^",4)
S FHTC=$P(FHTDAT,"^",5)
;I FHBRK=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Break") Q
;I FHNON=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Noon") Q
;I FHEVE=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Eve") Q
;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Break") S FHBRK=1
;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Noon") S FHNON=1
;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Eve") S FHEVE=1
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))
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=$P(P0,"~",4),(N1,FHDPTN)=$P(P0,"~",5)
;T2
I $D(^FH(119.8,DA,0)) S FHUSER=$P(^(0),U,9) S:$G(FHUSER) FHUSERN=$P(^VA(200,FHUSER,0),U,1)
;S EVT=FHDESC_" by "_FHUSERN
I FHDESC["Standing" S FHSO1=$P(FHDESC,":",1),FHDESC="Outpatient SO"_$E(FHDESC,$L(FHSO1)+1,$L(FHDESC))
I FHDESC["Supplemental" S FHSF1=$P(FHDESC,":",1),FHDESC="Outpatient SF"_$E(FHDESC,$L(FHSF1)+1,$L(FHDESC))
S EVT=FHDESC
I $Y>(IOSL-6) D HDR
I (FHNMSV=0)!(FHNMSV'=P0) W !!,$E(W1,1,20),?22,FHDPTN,?50,BID,?73,FHTC D ALG^FHCLN W !,"Allergies: ",$S(ALG="":"None on file",1:ALG),!
S FHNMSV=P0
D LNE
Q
;
HDR ;W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?20,"D I E T A C T I V I T Y R E P O R T",?72,"Page ",PG
W @IOF S PG=PG+1 W !?20,"D I E T A C T I V I T Y R E P O R T",?72,"Page ",PG
W !!?(80-$L(H1)\2),H1
W !,?30,FHPIO
W !!,"Location",?22,"Patient",?50,"ID#",?62,"Sup/Std Service"
Q
;
NEWP K ALG I $G(DFN) D ALG^FHCLN I ALG'="" S EVT="Allergies: "_ALG,TYP="A" D LNE^FHORX1C
Q:'$D(^FHPT(FHDFN,"P"))
S X1="Pref:" F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0) D N1
W:$L(X1)>6 !?12,X1 Q
;
N1 S Y=$G(^FH(115.2,+X,0)) Q:$P(Y,"^",2)'="D"
S Y=" "_$P(Y,"^",1)_" ("_$P(X,"^",2)_")"_$S($P(X,"^",4)="Y":" (D)",1:"") I $L(X1)+$L(Y)>48 W !?12,X1 S X1="Pref:"
S X1=X1_Y Q
;
LNE ; Break line if longer than 58 chars
I $Y>(IOSL-6) D HDR^FHORX1A W !
I $L(EVT)<59 G EX
F KK=59:-1:4 Q:$E(EVT,KK)?1P
I KK=4 S KK=45 W !?5,$E(EVT,1,58)
E W !?5,$E(EVT,1,KK-1)
S EVT=" "_$E(EVT,KK+1,999) G LNE
EX W !?5,EVT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORX1A 4152 printed Dec 13, 2024@01:54:04 Page 2
FHORX1A ; HISC/REL/NCA/RVD - Diet Activity Report (cont) ;3/17/95 10:06
+1 ;;5.5;DIETETICS;**1,5,8**;Jan 28, 2005;Build 28
+2 ;
+3 ;process inpatient data.
+4 SET PG=0
SET FHPIO="** INPATIENT **"
DO HDR
+5 SET P0=""
SET NN=0
FOR
SET P0=$ORDER(^TMP($JOB,"I",P0))
if P0=""
QUIT
DO LST
+6 ;
+7 ;process outpatient data.
+8 SET FHPIO="** OUTPATIENT **"
DO HDR
+9 SET (FHUSERNM,P0)=""
SET (FHNMSV,NN)=0
FOR
SET P0=$ORDER(^TMP($JOB,"O",P0))
if P0=""
QUIT
SET (FHBRK,FHNON,FHEVE)=0
DO LST1
+10 if $GET(FHP)
SET $PIECE(^FH(119.73,FHP,0),"^",2)=NOW
+11 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),"^",2)=NOW
+12 QUIT
+13 ;
LST KILL PP
SET NP=0
FOR DA=0:0
SET DA=$ORDER(^TMP($JOB,"I",P0,DA))
if DA<1
QUIT
SET Z=^(DA)
DO L1
+1 DO L2
QUIT
+2 ;
LST1 KILL PP
SET NP=0
FOR DA=0:0
SET DA=$ORDER(^TMP($JOB,"O",P0,DA))
if DA'>0
QUIT
DO T1
+1 QUIT
+2 ;
L1 ; Process event
+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)
SET CLK=$PIECE(Z,"^",6)
+2 IF 'FHORD
SET NN=NN+1
SET FHORD=NN
+3 IF "DIT"[TYP
Begin DoDot:1
+4 IF TYP="D"
IF FHORD=1
SET NP=1
+5 IF $DATA(PP(TYP,ADM_"~"_FHORD))
IF ACT="C"
KILL PP(TYP,ADM_"~"_FHORD)
QUIT
+6 KILL PP(TYP)
SET PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK
QUIT
End DoDot:1
+7 IF "OPSF"[TYP
Begin DoDot:1
+8 IF $DATA(PP(TYP,ADM_"~"_FHORD))
IF ACT="C"
KILL PP(TYP,ADM_"~"_FHORD)
QUIT
+9 SET PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK
QUIT
End DoDot:1
+10 IF "LM"[TYP
SET PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK
+11 QUIT
+12 ;
L2 SET W1=$PIECE(P0,"~",2)
SET R1=$PIECE(P0,"~",4)
SET FHDFN=$PIECE(P0,"~",5)
+1 DO PATNAME^FHOMUTL
if '$GET(DFN)
QUIT
+2 SET Y0=$GET(^DPT(DFN,0))
+3 SET N1=$PIECE(Y0,"^",1)
+4 ;D PID^FHDPA
+5 SET TC=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",5)
SET SF=$PIECE($GET(^(0)),"^",7)
SET SO=$DATA(^FHPT("ASP",FHDFN,ADM))
+6 if $Y>(IOSL-6)
DO HDR
WRITE !!,$EXTRACT(W1_" "_R1,1,20),?22,N1,?50,BID,?63,$SELECT(SF:"SF",1:""),?66,$SELECT(SO:"SO",1:""),?73,TC
+7 DO ALG^FHCLN
WRITE !,"Allergies: ",$SELECT(ALG="":"None on file",1:ALG),!
+8 DO ^FHORX1C
if NP
DO NEWP
QUIT
+9 ;
T1 ; Process outpatient event
+1 SET FHTDAT=$GET(^TMP($JOB,"O",P0,DA))
SET DFN=$PIECE(P0,"~",4)
+2 SET FHACTI=$PIECE(FHTDAT,"^",1)
+3 SET DTP=$PIECE(FHTDAT,"^",2)
+4 SET BID=$PIECE(FHTDAT,"^",3)
+5 SET FHDESC=$PIECE(FHTDAT,"^",4)
+6 SET FHTC=$PIECE(FHTDAT,"^",5)
+7 ;I FHBRK=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Break") Q
+8 ;I FHNON=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Noon") Q
+9 ;I FHEVE=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Eve") Q
+10 ;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Break") S FHBRK=1
+11 ;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Noon") S FHNON=1
+12 ;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Eve") S FHEVE=1
+13 SET FHDES1=$PIECE(FHDESC,",",1)
+14 SET FHDIET=$PIECE(FHDES1,":",2)
SET FHDIET=$EXTRACT(FHDIET,2,$LENGTH(FHDIET))
+15 IF FHDIET'=""
IF $DATA(^FH(111,"B",FHDIET))
SET FHDIDA=$ORDER(^FH(111,"B",FHDIET,0))
+16 IF $GET(FHDIDA)
IF $DATA(^FH(111,FHDIDA,0))
SET FHDIET=$PIECE(^FH(111,FHDIDA,0),U,7)
+17 if FHDIET=""
SET FHDIET="NO ORDER"
+18 SET Y=FHDIET
+19 SET W1=$PIECE(P0,"~",2)
SET R1=$PIECE(P0,"~",4)
SET (N1,FHDPTN)=$PIECE(P0,"~",5)
+20 ;T2
+21 IF $DATA(^FH(119.8,DA,0))
SET FHUSER=$PIECE(^(0),U,9)
if $GET(FHUSER)
SET FHUSERN=$PIECE(^VA(200,FHUSER,0),U,1)
+22 ;S EVT=FHDESC_" by "_FHUSERN
+23 IF FHDESC["Standing"
SET FHSO1=$PIECE(FHDESC,":",1)
SET FHDESC="Outpatient SO"_$EXTRACT(FHDESC,$LENGTH(FHSO1)+1,$LENGTH(FHDESC))
+24 IF FHDESC["Supplemental"
SET FHSF1=$PIECE(FHDESC,":",1)
SET FHDESC="Outpatient SF"_$EXTRACT(FHDESC,$LENGTH(FHSF1)+1,$LENGTH(FHDESC))
+25 SET EVT=FHDESC
+26 IF $Y>(IOSL-6)
DO HDR
+27 IF (FHNMSV=0)!(FHNMSV'=P0)
WRITE !!,$EXTRACT(W1,1,20),?22,FHDPTN,?50,BID,?73,FHTC
DO ALG^FHCLN
WRITE !,"Allergies: ",$SELECT(ALG="":"None on file",1:ALG),!
+28 SET FHNMSV=P0
+29 DO LNE
+30 QUIT
+31 ;
HDR ;W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?20,"D I E T A C T I V I T Y R E P O R T",?72,"Page ",PG
+1 WRITE @IOF
SET PG=PG+1
WRITE !?20,"D I E T A C T I V I T Y R E P O R T",?72,"Page ",PG
+2 WRITE !!?(80-$LENGTH(H1)\2),H1
+3 WRITE !,?30,FHPIO
+4 WRITE !!,"Location",?22,"Patient",?50,"ID#",?62,"Sup/Std Service"
+5 QUIT
+6 ;
NEWP KILL ALG
IF $GET(DFN)
DO ALG^FHCLN
IF ALG'=""
SET EVT="Allergies: "_ALG
SET TYP="A"
DO LNE^FHORX1C
+1 if '$DATA(^FHPT(FHDFN,"P"))
QUIT
+2 SET X1="Pref:"
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"P",K))
if K<1
QUIT
SET X=^(K,0)
DO N1
+3 if $LENGTH(X1)>6
WRITE !?12,X1
QUIT
+4 ;
N1 SET Y=$GET(^FH(115.2,+X,0))
if $PIECE(Y,"^",2)'="D"
QUIT
+1 SET Y=" "_$PIECE(Y,"^",1)_" ("_$PIECE(X,"^",2)_")"_$SELECT($PIECE(X,"^",4)="Y":" (D)",1:"")
IF $LENGTH(X1)+$LENGTH(Y)>48
WRITE !?12,X1
SET X1="Pref:"
+2 SET X1=X1_Y
QUIT
+3 ;
LNE ; Break line if longer than 58 chars
+1 IF $Y>(IOSL-6)
DO HDR^FHORX1A
WRITE !
+2 IF $LENGTH(EVT)<59
GOTO EX
+3 FOR KK=59:-1:4
if $EXTRACT(EVT,KK)?1P
QUIT
+4 IF KK=4
SET KK=45
WRITE !?5,$EXTRACT(EVT,1,58)
+5 IF '$TEST
WRITE !?5,$EXTRACT(EVT,1,KK-1)
+6 SET EVT=" "_$EXTRACT(EVT,KK+1,999)
GOTO LNE
EX WRITE !?5,EVT
QUIT
