FHORD11 ; HISC/REL/NCA - Diet Activity Report (cont) ;4/26/93 16:37
;;5.5;DIETETICS;;Jan 28, 2005
S PG=0,S2=LAB=2*5+36 D HDR:'LAB,LHD:LAB
F D2=0:0 S D2=$O(^TMP($J,D2)) Q:D2<1 S P0="" F E1=0:0 S P0=$O(^TMP($J,D2,P0)) Q:P0="" F FHDFN=0:0 S FHDFN=$O(^TMP($J,D2,P0,FHDFN)) Q:FHDFN<1 S X=$G(^TMP($J,D2,P0,FHDFN)) D LST
D DISC I LAB F L=1:1:18 W !
W:'LAB ! I UPD S $P(^FH(119.73,FHP,0),"^",2)=NOW
Q
LST D PATNAME^FHOMUTL I DFN="" Q
S W1=$P(X,"^",1),R1=$P(X,"^",2),ADM=$P(X,"^",3),FHORD=$P(X,"^",4),SF=$P(X,"^",5),IS=$P(X,"^",6),OLW=$P(X,"^",7),OLR=$P(X,"^",8) Q:'$D(^DPT(DFN,0)) S Y0=^(0)
S SO=$D(^FHPT("ASP",FHDFN,ADM))
S W1=$E(W1,1,15),R1=$E(R1,1,10),N1=$E($P(Y0,"^",1),1,22) D PID^FHDPA
S X0=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),COM=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
S TC=$P(X0,"^",8) I IS S IS=$G(^FH(119.4,IS,0)) I IS'="" S TC=TC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
G:LAB L1 D:$Y>54 HDR W !!,W1,?18,R1,?31,N1,?54,BID W:OLW="" " *" W ?63,$S(SF:"SF",1:""),?66,$S(SO:"SO",1:""),?73,TC W:" "'[OLW ?81,$E(OLW,1,15) W:" "'[OLR ?99,$E(OLR,1,10)
D:OLW="" NEWP D OLD S X=X0 D CUR W !?18,"Diet: ",Y W:COM'="" !?24,COM Q
L1 S X=X0 D CUR W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W:OLW="" " *"
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 !!,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
HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?35,"D I E T A C T I V I T Y R E P O R T",?102,"Page ",PG
W !!?(110-$L(H1)\2),H1
W !!,"Ward",?18,"Room",?31,"Patient",?55,"ID#",?62,"Sup/Std Service Old Ward",?99,"Old Room" 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
OLD S X2="" F NX=0:0 S NX=$O(^FHPT(FHDFN,"A",ADM,"AC",NX)) Q:NX<1!(NX>TIM) S X2=$P(^(NX,0),"^",2)
Q:X2=FHORD!(X2="") S X=$G(^FHPT(FHDFN,"A",ADM,"DI",X2,0)) D CUR
W !?18,"Old: ",Y Q
NEWP D ALG^FHCLN W:ALG'="" !?18,"Allergies: ",ALG
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 !?18,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)>92 W !?18,X1 S X1="Pref:"
S X1=X1_Y Q
DISC F NX=TIM:0 S NX=$O(^DGPM("ATT3",NX)) Q:NX<1!(NX>NOW) F DA=0:0 S DA=$O(^DGPM("ATT3",NX,DA)) Q:DA'>0 D D2
Q
D2 S X=$G(^DGPM(DA,0)),DFN=$P(X,"^",3),ADM=$P(X,"^",14) Q:'DFN!('ADM)
S W1=$G(^DPT(DFN,.1)),CADM=$S(W1="":"",$D(^DPT("CN",W1,DFN)):^(DFN),1:"") Q:CADM
S X=$P(X,"^",18) I X=41!(X=42)!(X=46)!(X=47) Q
S X=^DPT(DFN,0),N1=$P(X,"^",1),(R1,W1,SF,SO,D2)="" D PID^FHDPA
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
I $D(^FHPT(FHDFN,"A",ADM,0)) S X=^(0),W1=$P(X,"^",11),R1=$P(X,"^",12),SF=$P(X,"^",7)
S SO=$D(^FHPT("ASP",FHDFN,ADM))
S OLW=W1 D:'W1 D3 I W1 S D2=$P($G(^FH(119.6,W1,0)),"^",8),W1=$P($G(^FH(119.6,W1,0)),"^",1)
I FHP,FHP'=D2 Q
S W1=$E(W1,1,15),R1=$E(R1,1,10),N1=$E(N1,1,22)
I 'LAB D:$Y>54 HDR W !!,"** DISCHARGED **",?31,N1,?54,BID,?63,$S(SF:"SF",1:""),?66,$S(SO:"SO",1:""),?81,W1,?99,R1 Q
W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W:OLW="" " *" W ?(S2-3-$L(R1)),R1 W !!?(S2-18\2),"** DISCHARGED **",!! W:LAB=2 !?(S2-20),$P(H1," - ",2),!! Q
D3 S W1="" F L1=0:0 S L1=$O(^DGPM("APMV",DFN,ADM,L1)) Q:L1="" F L2=0:0 S L2=$O(^DGPM("APMV",DFN,ADM,L1,L2)) Q:L2="" S X1=$P($G(^DGPM(L2,0)),"^",6) I X1 S W1=X1 G D4
D4 S:W1 W1=$O(^FH(119.6,"AW",W1,0)) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD11 3906 printed Sep 23, 2025@19:29:24 Page 2
FHORD11 ; HISC/REL/NCA - Diet Activity Report (cont) ;4/26/93 16:37
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 SET PG=0
SET S2=LAB=2*5+36
if 'LAB
DO HDR
if LAB
DO LHD
+3 FOR D2=0:0
SET D2=$ORDER(^TMP($JOB,D2))
if D2<1
QUIT
SET P0=""
FOR E1=0:0
SET P0=$ORDER(^TMP($JOB,D2,P0))
if P0=""
QUIT
FOR FHDFN=0:0
SET FHDFN=$ORDER(^TMP($JOB,D2,P0,FHDFN))
if FHDFN<1
QUIT
SET X=$GET(^TMP($JOB,D2,P0,FHDFN))
DO LST
+4 DO DISC
IF LAB
FOR L=1:1:18
WRITE !
+5 if 'LAB
WRITE !
IF UPD
SET $PIECE(^FH(119.73,FHP,0),"^",2)=NOW
+6 QUIT
LST DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+1 SET W1=$PIECE(X,"^",1)
SET R1=$PIECE(X,"^",2)
SET ADM=$PIECE(X,"^",3)
SET FHORD=$PIECE(X,"^",4)
SET SF=$PIECE(X,"^",5)
SET IS=$PIECE(X,"^",6)
SET OLW=$PIECE(X,"^",7)
SET OLR=$PIECE(X,"^",8)
if '$DATA(^DPT(DFN,0))
QUIT
SET Y0=^(0)
+2 SET SO=$DATA(^FHPT("ASP",FHDFN,ADM))
+3 SET W1=$EXTRACT(W1,1,15)
SET R1=$EXTRACT(R1,1,10)
SET N1=$EXTRACT($PIECE(Y0,"^",1),1,22)
DO PID^FHDPA
+4 SET X0=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
SET COM=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
+5 SET TC=$PIECE(X0,"^",8)
IF IS
SET IS=$GET(^FH(119.4,IS,0))
IF IS'=""
SET TC=TC_"-"_$PIECE(IS,"^",2)_$PIECE(IS,"^",3)
+6 if LAB
GOTO L1
if $Y>54
DO HDR
WRITE !!,W1,?18,R1,?31,N1,?54,BID
if OLW=""
WRITE " *"
WRITE ?63,$SELECT(SF:"SF",1:""),?66,$SELECT(SO:"SO",1:""),?73,TC
if " "'[OLW
WRITE ?81,$EXTRACT(OLW,1,15)
if " "'[OLR
WRITE ?99,$EXTRACT(OLR,1,10)
+7 if OLW=""
DO NEWP
DO OLD
SET X=X0
DO CUR
WRITE !?18,"Diet: ",Y
if COM'=""
WRITE !?24,COM
QUIT
L1 SET X=X0
DO CUR
WRITE !,$EXTRACT(N1,1,S2-5-$LENGTH(W1)),?(S2-3-$LENGTH(W1)),W1,!,BID
if OLW=""
WRITE " *"
+1 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 !!,Y,!!
+2 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),!
+3 WRITE @FHIO("EOF")
if LAB=2
WRITE ?(S2-20),$PIECE(H1," - ",2),!!
QUIT
HDR if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
WRITE !?35,"D I E T A C T I V I T Y R E P O R T",?102,"Page ",PG
+1 WRITE !!?(110-$LENGTH(H1)\2),H1
+2 WRITE !!,"Ward",?18,"Room",?31,"Patient",?55,"ID#",?62,"Sup/Std Service Old Ward",?99,"Old Room"
QUIT
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
OLD SET X2=""
FOR NX=0:0
SET NX=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",NX))
if NX<1!(NX>TIM)
QUIT
SET X2=$PIECE(^(NX,0),"^",2)
+1 if X2=FHORD!(X2="")
QUIT
SET X=$GET(^FHPT(FHDFN,"A",ADM,"DI",X2,0))
DO CUR
+2 WRITE !?18,"Old: ",Y
QUIT
NEWP DO ALG^FHCLN
if ALG'=""
WRITE !?18,"Allergies: ",ALG
+1 SET X1="Pref:"
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"P",K))
if K<1
QUIT
SET X=^(K,0)
DO N1
+2 if $LENGTH(X1)>6
WRITE !?18,X1
QUIT
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)>92
WRITE !?18,X1
SET X1="Pref:"
+2 SET X1=X1_Y
QUIT
DISC FOR NX=TIM:0
SET NX=$ORDER(^DGPM("ATT3",NX))
if NX<1!(NX>NOW)
QUIT
FOR DA=0:0
SET DA=$ORDER(^DGPM("ATT3",NX,DA))
if DA'>0
QUIT
DO D2
+1 QUIT
D2 SET X=$GET(^DGPM(DA,0))
SET DFN=$PIECE(X,"^",3)
SET ADM=$PIECE(X,"^",14)
if 'DFN!('ADM)
QUIT
+1 SET W1=$GET(^DPT(DFN,.1))
SET CADM=$SELECT(W1="":"",$DATA(^DPT("CN",W1,DFN)):^(DFN),1:"")
if CADM
QUIT
+2 SET X=$PIECE(X,"^",18)
IF X=41!(X=42)!(X=46)!(X=47)
QUIT
+3 SET X=^DPT(DFN,0)
SET N1=$PIECE(X,"^",1)
SET (R1,W1,SF,SO,D2)=""
DO PID^FHDPA
+4 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+5 IF $DATA(^FHPT(FHDFN,"A",ADM,0))
SET X=^(0)
SET W1=$PIECE(X,"^",11)
SET R1=$PIECE(X,"^",12)
SET SF=$PIECE(X,"^",7)
+6 SET SO=$DATA(^FHPT("ASP",FHDFN,ADM))
+7 SET OLW=W1
if 'W1
DO D3
IF W1
SET D2=$PIECE($GET(^FH(119.6,W1,0)),"^",8)
SET W1=$PIECE($GET(^FH(119.6,W1,0)),"^",1)
+8 IF FHP
IF FHP'=D2
QUIT
+9 SET W1=$EXTRACT(W1,1,15)
SET R1=$EXTRACT(R1,1,10)
SET N1=$EXTRACT(N1,1,22)
+10 IF 'LAB
if $Y>54
DO HDR
WRITE !!,"** DISCHARGED **",?31,N1,?54,BID,?63,$SELECT(SF:"SF",1:""),?66,$SELECT(SO:"SO",1:""),?81,W1,?99,R1
QUIT
+11 WRITE !,$EXTRACT(N1,1,S2-5-$LENGTH(W1)),?(S2-3-$LENGTH(W1)),W1,!,BID
if OLW=""
WRITE " *"
WRITE ?(S2-3-$LENGTH(R1)),R1
WRITE !!?(S2-18\2),"** DISCHARGED **",!!
if LAB=2
WRITE !?(S2-20),$PIECE(H1," - ",2),!!
QUIT
D3 SET W1=""
FOR L1=0:0
SET L1=$ORDER(^DGPM("APMV",DFN,ADM,L1))
if L1=""
QUIT
FOR L2=0:0
SET L2=$ORDER(^DGPM("APMV",DFN,ADM,L1,L2))
if L2=""
QUIT
SET X1=$PIECE($GET(^DGPM(L2,0)),"^",6)
IF X1
SET W1=X1
GOTO D4
D4 if W1
SET W1=$ORDER(^FH(119.6,"AW",W1,0))
QUIT
