- FHORX3 ; HISC/REL/NCA/RTK - List Dietetic Events ;2/23/01 09:17
- ;;5.5;DIETETICS;;Jan 28, 2005
- S Z=$G(^FH(119.8,DA,0)) Q:Z="" S D1=$P(Z,"^",2),FHDFN=$P(Z,"^",3),ADM=$P(Z,"^",4),TYP=$P(Z,"^",5),ACT=$P(Z,"^",6),FHORD=$P(Z,"^",7),TXT=$P(Z,"^",8),CLK=$P(Z,"^",9)
- I TYP="Z" D OUTPEV Q
- I "DITOS"[TYP,'FHORD Q
- G L:TYP="L",D:TYP="D",M:TYP="M",I:TYP="I",T:TYP="T",O:TYP="O",P:TYP="P",S:TYP="S",F:TYP="F" Q ;P30
- 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 EX
- D ; Diet
- Q:'FHORD Q:'$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
- D C2^FHORD7 S EVT="Diet: "_Y G:FHLD'="" EX
- S X9=$P(X,"^",8) S:X9'="" EVT=EVT_" ("_$S(X9="T":"Tray",X9="D":"Dining Room",1:"Cafe")_")" G EX
- I ; Isolation
- S EVT="Isolation: "_$P($G(^FH(119.4,FHORD,0)),"^",1)
- S:ACT="C" EVT=EVT_" Cancelled" G EX
- 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 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 EX
- Q
- O ; Additional Order
- S Y=$P($G(^FHPT(FHDFN,"A",ADM,"OO",FHORD,0)),"^",3) Q:Y=""
- S EVT="Add. Order: "_Y S:ACT="C" EVT=EVT_" Cancelled" G EX
- P ; Food Preferences
- S EVT="Pref: "_TXT_$S(CLK:" By: "_$P($G(^VA(200,+CLK,0)),"^",1),1:"") G EX
- M ; Message
- S EVT="Msg: "_TXT G EX
- 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="Std. Order: "_$S(QTY:QTY,1:1)_" "_$P($G(^FH(118.3,+SP,0)),"^",1)_" ("_MEAL_")" S:ACT="C" EVT=EVT_" Cancelled" G EX
- Q
- F ; Suppl. feedings P30
- S Z=$G(^FHPT(FHDFN,"A",ADM,"SF",+FHORD,0)) Q:Z="" S SP=$P(Z,"^",4)
- S EVT="Supp. Fdg. Menu: "_$P($G(^FH(118.1,+SP,0)),"^",1) S:ACT="C" EVT=EVT_" Cancelled" G EX
- Q
- EX W ! D DTP W ?20,EVT Q
- DTP ; Printable Date/Time
- Q:D1<1 W $J(+$E(D1,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(D1,4,5))_"-"_$E(D1,2,3)
- I D1["." S %=+$E(D1_"0",9,10) W $J($S(%>12:%-12,1:%),3)_":"_$E(D1_"000",11,12)_$S(%<12:"am",%<24:"pm",1:"m")
- K % Q
- CALC ; Figure # of units for TF
- I $E($P(XX,"^",3),$L($P(XX,"^",3)))="G" D GRM Q
- S TU=$P(X3,"^",4)/$S(+$P(XX,"^",3):+$P(XX,"^",3),1:9999),TW=$P(X3,"^",5)
- I TW<6 S TU=TU+.75\1,P2=TU,P2=P2_" "_$S(P2>1:$P(XX,"^",2)_"S",1:$P(XX,"^",2)) Q
- S TU=TU+.2*4\1/4,P2=$S(TU<1:"",1:TU\1) I TU#1 S:P2 P2=P2_"-" S P3=TU#1,P2=P2_$S(P3<.3:"1/4",P3<.6:"1/2",1:"3/4")
- S P2=P2_" "_$S(P2>1:$P(XX,"^",2)_"S",1:$P(XX,"^",2))
- Q
- GRM ; Calculate for Grams
- S X=$P(X3,"^",3) D FIX^FHORT10 S Z5="" F LL=1:1:$L(X) I $E(X,LL)'=" " S Z5=Z5_$E(X,LL)
- S Z5=$P(Z5,"/",2),Z5=$P(Z5,"X",2)
- I 'Z5 S Z5=$P("1,24,2,3,12,8,6,4",",",K) G G1
- I Z5'["F" S Z5=$S(K=1:1,K=2:Z5,K=3:2,K=4:3,K=5:Z5\2,K=6:Z5\3,K=7:Z5\4,1:Z5\6)
- E S:K=1 Z5=1
- G1 S TU=+$P(X3,"^",3)*Z5
- S TU=TU/$S(+$P(XX,"^",3):+$P(XX,"^",3),1:9999)
- S P2=$S(TU<1:"",1:TU\1) I P2="" S TU=TU+.95\1,P2=TU
- I TU#1 S:P2 P2=P2_"-" S TU=TU#1,P2=P2_$S(TU<.3:"1/4",TU<.6:"1/2",1:"3/4")
- S P2=P2_" "_$S(P2>1:$P(XX,"^",2)_"S",1:$P(XX,"^",2))
- Q
- OUTPEV ; Display outpatient events
- S EVT=TXT D EX
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORX3 3586 printed Feb 18, 2025@23:20:30 Page 2
- FHORX3 ; HISC/REL/NCA/RTK - List Dietetic Events ;2/23/01 09:17
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 SET Z=$GET(^FH(119.8,DA,0))
- if Z=""
- QUIT
- SET D1=$PIECE(Z,"^",2)
- SET FHDFN=$PIECE(Z,"^",3)
- SET ADM=$PIECE(Z,"^",4)
- SET TYP=$PIECE(Z,"^",5)
- SET ACT=$PIECE(Z,"^",6)
- SET FHORD=$PIECE(Z,"^",7)
- SET TXT=$PIECE(Z,"^",8)
- SET CLK=$PIECE(Z,"^",9)
- +3 IF TYP="Z"
- DO OUTPEV
- QUIT
- +4 IF "DITOS"[TYP
- IF 'FHORD
- QUIT
- +5 ;P30
- if TYP="L"
- GOTO L
- if TYP="D"
- GOTO D
- if TYP="M"
- GOTO M
- if TYP="I"
- GOTO I
- if TYP="T"
- GOTO T
- if TYP="O"
- GOTO O
- if TYP="P"
- GOTO P
- if TYP="S"
- GOTO S
- if TYP="F"
- GOTO F
- 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 EX
- D ; Diet
- +1 if 'FHORD
- QUIT
- if '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
- QUIT
- +2 DO C2^FHORD7
- SET EVT="Diet: "_Y
- if FHLD'=""
- GOTO EX
- +3 SET X9=$PIECE(X,"^",8)
- if X9'=""
- SET EVT=EVT_" ("_$SELECT(X9="T":"Tray",X9="D":"Dining Room",1:"Cafe")_")"
- GOTO EX
- I ; Isolation
- +1 SET EVT="Isolation: "_$PIECE($GET(^FH(119.4,FHORD,0)),"^",1)
- +2 if ACT="C"
- SET EVT=EVT_" Cancelled"
- GOTO EX
- 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
- 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"
- GOTO EX
- +5 QUIT
- O ; Additional Order
- +1 SET Y=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"OO",FHORD,0)),"^",3)
- if Y=""
- QUIT
- +2 SET EVT="Add. Order: "_Y
- if ACT="C"
- SET EVT=EVT_" Cancelled"
- GOTO EX
- P ; Food Preferences
- +1 SET EVT="Pref: "_TXT_$SELECT(CLK:" By: "_$PIECE($GET(^VA(200,+CLK,0)),"^",1),1:"")
- GOTO EX
- M ; Message
- +1 SET EVT="Msg: "_TXT
- GOTO EX
- 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="Std. Order: "_$SELECT(QTY:QTY,1:1)_" "_$PIECE($GET(^FH(118.3,+SP,0)),"^",1)_" ("_MEAL_")"
- if ACT="C"
- SET EVT=EVT_" Cancelled"
- GOTO EX
- +3 QUIT
- 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="Supp. Fdg. Menu: "_$PIECE($GET(^FH(118.1,+SP,0)),"^",1)
- if ACT="C"
- SET EVT=EVT_" Cancelled"
- GOTO EX
- +3 QUIT
- EX WRITE !
- DO DTP
- WRITE ?20,EVT
- QUIT
- DTP ; Printable Date/Time
- +1 if D1<1
- QUIT
- WRITE $JUSTIFY(+$EXTRACT(D1,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(D1,4,5))_"-"_$EXTRACT(D1,2,3)
- +2 IF D1["."
- SET %=+$EXTRACT(D1_"0",9,10)
- WRITE $JUSTIFY($SELECT(%>12:%-12,1:%),3)_":"_$EXTRACT(D1_"000",11,12)_$SELECT(%<12:"am",%<24:"pm",1:"m")
- +3 KILL %
- QUIT
- CALC ; Figure # of units for TF
- +1 IF $EXTRACT($PIECE(XX,"^",3),$LENGTH($PIECE(XX,"^",3)))="G"
- DO GRM
- QUIT
- +2 SET TU=$PIECE(X3,"^",4)/$SELECT(+$PIECE(XX,"^",3):+$PIECE(XX,"^",3),1:9999)
- SET TW=$PIECE(X3,"^",5)
- +3 IF TW<6
- SET TU=TU+.75\1
- SET P2=TU
- SET P2=P2_" "_$SELECT(P2>1:$PIECE(XX,"^",2)_"S",1:$PIECE(XX,"^",2))
- QUIT
- +4 SET TU=TU+.2*4\1/4
- SET P2=$SELECT(TU<1:"",1:TU\1)
- IF TU#1
- if P2
- SET P2=P2_"-"
- SET P3=TU#1
- SET P2=P2_$SELECT(P3<.3:"1/4",P3<.6:"1/2",1:"3/4")
- +5 SET P2=P2_" "_$SELECT(P2>1:$PIECE(XX,"^",2)_"S",1:$PIECE(XX,"^",2))
- +6 QUIT
- GRM ; Calculate for Grams
- +1 SET X=$PIECE(X3,"^",3)
- DO FIX^FHORT10
- SET Z5=""
- FOR LL=1:1:$LENGTH(X)
- IF $EXTRACT(X,LL)'=" "
- SET Z5=Z5_$EXTRACT(X,LL)
- +2 SET Z5=$PIECE(Z5,"/",2)
- SET Z5=$PIECE(Z5,"X",2)
- +3 IF 'Z5
- SET Z5=$PIECE("1,24,2,3,12,8,6,4",",",K)
- GOTO G1
- +4 IF Z5'["F"
- SET Z5=$SELECT(K=1:1,K=2:Z5,K=3:2,K=4:3,K=5:Z5\2,K=6:Z5\3,K=7:Z5\4,1:Z5\6)
- +5 IF '$TEST
- if K=1
- SET Z5=1
- G1 SET TU=+$PIECE(X3,"^",3)*Z5
- +1 SET TU=TU/$SELECT(+$PIECE(XX,"^",3):+$PIECE(XX,"^",3),1:9999)
- +2 SET P2=$SELECT(TU<1:"",1:TU\1)
- IF P2=""
- SET TU=TU+.95\1
- SET P2=TU
- +3 IF TU#1
- if P2
- SET P2=P2_"-"
- SET TU=TU#1
- SET P2=P2_$SELECT(TU<.3:"1/4",TU<.6:"1/2",1:"3/4")
- +4 SET P2=P2_" "_$SELECT(P2>1:$PIECE(XX,"^",2)_"S",1:$PIECE(XX,"^",2))
- +5 QUIT
- OUTPEV ; Display outpatient events
- +1 SET EVT=TXT
- DO EX
- +2 QUIT