FHORX1C ; HISC/REL/NCA/RVD - List Dietetic Events ;11/15/00 14:38
;;5.5;DIETETICS;;Jan 28, 2005
;
F TYP="L","D","M","I","T","O","P","S","F" I $D(PP(TYP)) S NXT="" F S NXT=$O(PP(TYP,NXT)) Q:NXT="" S ADM=$P(NXT,"~",1),FHORD=$P(NXT,"~",2),ACT=$P(PP(TYP,NXT),"^",1),TXT=$P(PP(TYP,NXT),"^",2),CLK=$P(PP(TYP,NXT),"^",3) D @TYP
Q
L ; Location
S EVT=$S(ACT="A":"Admit to ",ACT="T":"Transfer from ",1:"Discharge from ")
I "DT"[ACT S X1=$P(TXT,"~",1) S:X1 X1=$P($G(^FH(119.6,X1,0)),"^",1) S EVT=EVT_X1 S X1=$P(TXT,"~",2) S:X1 X1=$P($G(^DG(405.4,X1,0)),"^",1) S:X1'="" EVT=EVT_" "_X1
S:ACT="T" EVT=EVT_" to "
I "AT"[ACT S X1=$P(TXT,"~",3) S:X1 X1=$P($G(^FH(119.6,X1,0)),"^",1) S EVT=EVT_X1 S X1=$P(TXT,"~",4) S:X1 X1=$P($G(^DG(405.4,X1,0)),"^",1) S:X1'="" EVT=EVT_" "_X1
G LNE
D ; Diet
S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),COM=$G(^(1)) Q:X="" D CUR S EVT="Diet: "_Y
I FHLD="" S X9=$P(X,"^",8) I X9'="",X9'=TC S EVT=EVT_" ("_$S(X9="T":"Tray",X9="D":"Dining Room",1:"Cafe")_")"
S:COM'="" EVT=EVT_", "_COM D LNE
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
S EVT="Old: "_Y G LNE
I ; Isolation
S EVT="IS: "_$P($G(^FH(119.4,FHORD,0)),"^",1)
S:ACT="C" EVT=EVT_" Cancelled" G LNE
T ; Tubefeed
S EVT=""
F K1=0:0 S K1=$O(^FHPT(FHDFN,"A",ADM,"TF",FHORD,"P",K1)) Q:K1<1 S X3=$G(^(K1,0)),TUN=$P(X3,"^",1),XX=$G(^FH(118.2,TUN,0)) D CALC^FHORX3 S:EVT'="" EVT=EVT_", " S EVT=EVT_P2_" "_$P(XX,"^",1)
S COM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",FHORD,0)),"^",5) I COM'="" S EVT=EVT_", "_COM
S EVT="TF: "_EVT S:ACT="C" EVT=EVT_" Cancelled"
G LNE
O ; Additional Order
S Y=$P($G(^FHPT(FHDFN,"A",ADM,"OO",FHORD,0)),"^",3) Q:Y=""
S EVT="AO: "_Y S:ACT="C" EVT=EVT_" Cancelled" G LNE
P ; Food Preferences
S EVT="FP: "_TXT D CLK G LNE
M ; Message
S EVT="Msg: "_TXT G LNE
F ; Suppl. feedings P30
S Z=$G(^FHPT(FHDFN,"A",ADM,"SF",+FHORD,0)) Q:Z="" S SP=$P(Z,"^",4)
S EVT="SF: "_$P($G(^FH(118.1,+SP,0)),"^",1) S:ACT="C" EVT=EVT_" Cancelled" G LNE
S ; Standing Orders
S Z=$G(^FHPT(FHDFN,"A",ADM,"SP",+FHORD,0)) Q:Z="" S SP=$P(Z,"^",2),MEAL=$P(Z,"^",3),QTY=$P(Z,"^",8)
S EVT="SO: "_$S(QTY:QTY,1:1)_" "_$P($G(^FH(118.3,+SP,0)),"^",1)_" ("_MEAL_")" S:ACT="C" EVT=EVT_" Cancelled" G LNE
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
CLK ; Get entered clerk
I CLK S EVT=EVT_" By: "_$P($G(^VA(200,+CLK,0)),"^",1)
Q
LNE ; Break line if longer than 48 chars
I $Y>(IOSL-6) D HDR^FHORX1A W !
I $L(EVT)<49 G EX
F KK=49:-1:4 Q:$E(EVT,KK)?1P
I KK=4 S KK=48 W !?12,$E(EVT,1,48)
E W !?12,$E(EVT,1,KK-1)
S EVT=" "_$E(EVT,KK+1,999) G LNE
EX W !?12,EVT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORX1C 2925 printed Dec 13, 2024@01:54:06 Page 2
FHORX1C ; HISC/REL/NCA/RVD - List Dietetic Events ;11/15/00 14:38
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 ;
+3 FOR TYP="L","D","M","I","T","O","P","S","F"
IF $DATA(PP(TYP))
SET NXT=""
FOR
SET NXT=$ORDER(PP(TYP,NXT))
if NXT=""
QUIT
SET ADM=$PIECE(NXT,"~",1)
SET FHORD=$PIECE(NXT,"~",2)
SET ACT=$PIECE(PP(TYP,NXT),"^",1)
SET TXT=$PIECE(PP(TYP,NXT),"^",2)
SET CLK=$PIECE(PP(TYP,NXT),"^",3)
DO @TYP
+4 QUIT
L ; Location
+1 SET EVT=$SELECT(ACT="A":"Admit to ",ACT="T":"Transfer from ",1:"Discharge from ")
+2 IF "DT"[ACT
SET X1=$PIECE(TXT,"~",1)
if X1
SET X1=$PIECE($GET(^FH(119.6,X1,0)),"^",1)
SET EVT=EVT_X1
SET X1=$PIECE(TXT,"~",2)
if X1
SET X1=$PIECE($GET(^DG(405.4,X1,0)),"^",1)
if X1'=""
SET EVT=EVT_" "_X1
+3 if ACT="T"
SET EVT=EVT_" to "
+4 IF "AT"[ACT
SET X1=$PIECE(TXT,"~",3)
if X1
SET X1=$PIECE($GET(^FH(119.6,X1,0)),"^",1)
SET EVT=EVT_X1
SET X1=$PIECE(TXT,"~",4)
if X1
SET X1=$PIECE($GET(^DG(405.4,X1,0)),"^",1)
if X1'=""
SET EVT=EVT_" "_X1
+5 GOTO LNE
D ; Diet
+1 SET X=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
SET COM=$GET(^(1))
if X=""
QUIT
DO CUR
SET EVT="Diet: "_Y
+2 IF FHLD=""
SET X9=$PIECE(X,"^",8)
IF X9'=""
IF X9'=TC
SET EVT=EVT_" ("_$SELECT(X9="T":"Tray",X9="D":"Dining Room",1:"Cafe")_")"
+3 if COM'=""
SET EVT=EVT_", "_COM
DO LNE
+4 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)
+5 if X2=FHORD!(X2="")
QUIT
SET X=$GET(^FHPT(FHDFN,"A",ADM,"DI",X2,0))
DO CUR
+6 SET EVT="Old: "_Y
GOTO LNE
I ; Isolation
+1 SET EVT="IS: "_$PIECE($GET(^FH(119.4,FHORD,0)),"^",1)
+2 if ACT="C"
SET EVT=EVT_" Cancelled"
GOTO LNE
T ; Tubefeed
+1 SET EVT=""
+2 FOR K1=0:0
SET K1=$ORDER(^FHPT(FHDFN,"A",ADM,"TF",FHORD,"P",K1))
if K1<1
QUIT
SET X3=$GET(^(K1,0))
SET TUN=$PIECE(X3,"^",1)
SET XX=$GET(^FH(118.2,TUN,0))
DO CALC^FHORX3
if EVT'=""
SET EVT=EVT_", "
SET EVT=EVT_P2_" "_$PIECE(XX,"^",1)
+3 SET COM=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"TF",FHORD,0)),"^",5)
IF COM'=""
SET EVT=EVT_", "_COM
+4 SET EVT="TF: "_EVT
if ACT="C"
SET EVT=EVT_" Cancelled"
+5 GOTO LNE
O ; Additional Order
+1 SET Y=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"OO",FHORD,0)),"^",3)
if Y=""
QUIT
+2 SET EVT="AO: "_Y
if ACT="C"
SET EVT=EVT_" Cancelled"
GOTO LNE
P ; Food Preferences
+1 SET EVT="FP: "_TXT
DO CLK
GOTO LNE
M ; Message
+1 SET EVT="Msg: "_TXT
GOTO LNE
F ; Suppl. feedings P30
+1 SET Z=$GET(^FHPT(FHDFN,"A",ADM,"SF",+FHORD,0))
if Z=""
QUIT
SET SP=$PIECE(Z,"^",4)
+2 SET EVT="SF: "_$PIECE($GET(^FH(118.1,+SP,0)),"^",1)
if ACT="C"
SET EVT=EVT_" Cancelled"
GOTO LNE
S ; Standing Orders
+1 SET Z=$GET(^FHPT(FHDFN,"A",ADM,"SP",+FHORD,0))
if Z=""
QUIT
SET SP=$PIECE(Z,"^",2)
SET MEAL=$PIECE(Z,"^",3)
SET QTY=$PIECE(Z,"^",8)
+2 SET EVT="SO: "_$SELECT(QTY:QTY,1:1)_" "_$PIECE($GET(^FH(118.3,+SP,0)),"^",1)_" ("_MEAL_")"
if ACT="C"
SET EVT=EVT_" Cancelled"
GOTO LNE
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
CLK ; Get entered clerk
+1 IF CLK
SET EVT=EVT_" By: "_$PIECE($GET(^VA(200,+CLK,0)),"^",1)
+2 QUIT
LNE ; Break line if longer than 48 chars
+1 IF $Y>(IOSL-6)
DO HDR^FHORX1A
WRITE !
+2 IF $LENGTH(EVT)<49
GOTO EX
+3 FOR KK=49:-1:4
if $EXTRACT(EVT,KK)?1P
QUIT
+4 IF KK=4
SET KK=48
WRITE !?12,$EXTRACT(EVT,1,48)
+5 IF '$TEST
WRITE !?12,$EXTRACT(EVT,1,KK-1)
+6 SET EVT=" "_$EXTRACT(EVT,KK+1,999)
GOTO LNE
EX WRITE !?12,EVT
QUIT
