FHORT2 ; HISC/REL/NCA - Tubefeeding Inquiry/Cancel ;6/25/96 10:50 ;
;;5.5;DIETETICS;**1**;Jan 28, 2005
EN2 ; Current Tubefeeding
S (ALL,TF)=0 D ^FHDPA Q:'DFN Q:'FHDFN
S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4)
I TF<1 W !!,"No Tubefeeding Order Exists" Q
DIS ; Display Tubefeeding
S T=^FHPT(FHDFN,"A",ADM,"TF",TF,0),DTP=$P(T,"^",1),NO=0 D DTP^FH W !!,"Date Ordered: ",DTP
W ! F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 S Y=^(TF2,0),TUN(+Y)=Y,NO=NO+1 D D1
S TFCOM=$P(T,"^",5)
W !!,"Total KCAL: ",$P(T,"^",7),?42,"Total Quantity: ",$P(T,"^",6)," ml"
W:TFCOM'="" !,"Comment: ",TFCOM Q
D1 S TUN=$P(Y,"^",1),STR=$P(Y,"^",2),QUA=$P(Y,"^",3)
I QUA["CC" S QUAFI=$P(QUA,"CC",1),QUASE=$P(QUA,"CC",2),QUA=QUAFI_"ML"_QUASE
W !,"Product: ",$P($G(^FH(118.2,TUN,0)),"^",1),", ",$S(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")," Str., ",QUA Q
EN3 ; Cancel Tubefeeding
D EN2 G:TF<1 KIL S FHD="N" D ASK G:FHD'="Y" KIL D CAN
D CUR^FHORD7 I Y="" W *7,!!,"Note: NO current DIET ORDER exists for this patient!" G KIL
G:"^^^^"'[FHOR KIL I FHLD'="" W *7,!!,"Note: Patient is on a WITHHOLD SERVICE Order!"
C1 R !!,"Do you wish to RESUME Tray Service? N// ",X:DTIME G:'$T!(X="^") KIL S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G C1
G:X'?1"Y".E KIL S A2=0 F KK=0:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1!(KK'<NOW) I $P(^(KK,0),"^",2)=FHORD S A2=KK
I 'A2 W *7,!!,"Cannot CANCEL -- Try using Cancel Withhold option!" G KIL
S DT=$P(NOW,".",1),KK=A2,OLD=FHLD D T0^FHORD3 G KIL
ASK ; Ask if wish to cancel
W !!,"Do you wish to CANCEL the ORIGINAL Tubefeeding? ",FHD,"// " R X:DTIME I '$T!(X["^") S FHD="N" Q
S:X="" X=FHD D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G ASK
S FHD=$E(X,1) W:FHD'="Y" " ... no change" Q
CAN ; Perform cancel
N FHORN,FILL,COM D NOW^%DTC S NOW=%
S $P(^FHPT(FHDFN,"A",ADM,0),"^",4)="" K ^FHPT("ADTF",FHDFN,ADM)
S $P(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",11,12)=NOW_"^"_DUZ
S FHORN=$P(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",14)
S FHSAV=$G(^FHPT(FHDFN,"A",ADM,"TF",TF,0))
K % S EVT="T^C^"_TF D ^FHORX I FHORN S FILL="T"_";"_ADM_";"_TF_";"_$P(FHSAV,"^",6)_";"_$P(FHSAV,"^",7)_";"_$P(FHSAV,"^",5)_";" D CODE^FHWOR5 D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG,FHSAV,FILL
Q
KIL K %,%H,%I,A1,A2,C,D1,D2,D3,DA,KK,P2,FHDU,NOW,X1,X2,OLD,FHDR,FHORD,FHPAR,FHLD,FHWF,FHPV,FHOR,I,K9,ADM,ALL,COM,TFCOM,FHDFN,DFN,FHD,POP,PID,BID,DTP,QUA,STR,T,TF,TF2,TUN,WARD,X,X9,Y Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORT2 2499 printed Apr 09, 2024@20:56:01 Page 2
FHORT2 ; HISC/REL/NCA - Tubefeeding Inquiry/Cancel ;6/25/96 10:50 ;
+1 ;;5.5;DIETETICS;**1**;Jan 28, 2005
EN2 ; Current Tubefeeding
+1 SET (ALL,TF)=0
DO ^FHDPA
if 'DFN
QUIT
if 'FHDFN
QUIT
+2 SET TF=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",4)
+3 IF TF<1
WRITE !!,"No Tubefeeding Order Exists"
QUIT
DIS ; Display Tubefeeding
+1 SET T=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
SET DTP=$PIECE(T,"^",1)
SET NO=0
DO DTP^FH
WRITE !!,"Date Ordered: ",DTP
+2 WRITE !
FOR TF2=0:0
SET TF2=$ORDER(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2))
if TF2<1
QUIT
SET Y=^(TF2,0)
SET TUN(+Y)=Y
SET NO=NO+1
DO D1
+3 SET TFCOM=$PIECE(T,"^",5)
+4 WRITE !!,"Total KCAL: ",$PIECE(T,"^",7),?42,"Total Quantity: ",$PIECE(T,"^",6)," ml"
+5 if TFCOM'=""
WRITE !,"Comment: ",TFCOM
QUIT
D1 SET TUN=$PIECE(Y,"^",1)
SET STR=$PIECE(Y,"^",2)
SET QUA=$PIECE(Y,"^",3)
+1 IF QUA["CC"
SET QUAFI=$PIECE(QUA,"CC",1)
SET QUASE=$PIECE(QUA,"CC",2)
SET QUA=QUAFI_"ML"_QUASE
+2 WRITE !,"Product: ",$PIECE($GET(^FH(118.2,TUN,0)),"^",1),", ",$SELECT(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")," Str., ",QUA
QUIT
EN3 ; Cancel Tubefeeding
+1 DO EN2
if TF<1
GOTO KIL
SET FHD="N"
DO ASK
if FHD'="Y"
GOTO KIL
DO CAN
+2 DO CUR^FHORD7
IF Y=""
WRITE *7,!!,"Note: NO current DIET ORDER exists for this patient!"
GOTO KIL
+3 if "^^^^"'[FHOR
GOTO KIL
IF FHLD'=""
WRITE *7,!!,"Note: Patient is on a WITHHOLD SERVICE Order!"
C1 READ !!,"Do you wish to RESUME Tray Service? N// ",X:DTIME
if '$TEST!(X="^")
GOTO KIL
if X=""
SET X="N"
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7," Answer YES or NO"
GOTO C1
+1 if X'?1"Y".E
GOTO KIL
SET A2=0
FOR KK=0:0
SET KK=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",KK))
if KK<1!(KK'<NOW)
QUIT
IF $PIECE(^(KK,0),"^",2)=FHORD
SET A2=KK
+2 IF 'A2
WRITE *7,!!,"Cannot CANCEL -- Try using Cancel Withhold option!"
GOTO KIL
+3 SET DT=$PIECE(NOW,".",1)
SET KK=A2
SET OLD=FHLD
DO T0^FHORD3
GOTO KIL
ASK ; Ask if wish to cancel
+1 WRITE !!,"Do you wish to CANCEL the ORIGINAL Tubefeeding? ",FHD,"// "
READ X:DTIME
IF '$TEST!(X["^")
SET FHD="N"
QUIT
+2 if X=""
SET X=FHD
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7," Answer YES or NO"
GOTO ASK
+3 SET FHD=$EXTRACT(X,1)
if FHD'="Y"
WRITE " ... no change"
QUIT
CAN ; Perform cancel
+1 NEW FHORN,FILL,COM
DO NOW^%DTC
SET NOW=%
+2 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",4)=""
KILL ^FHPT("ADTF",FHDFN,ADM)
+3 SET $PIECE(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",11,12)=NOW_"^"_DUZ
+4 SET FHORN=$PIECE(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",14)
+5 SET FHSAV=$GET(^FHPT(FHDFN,"A",ADM,"TF",TF,0))
+6 KILL %
SET EVT="T^C^"_TF
DO ^FHORX
IF FHORN
SET FILL="T"_";"_ADM_";"_TF_";"_$PIECE(FHSAV,"^",6)_";"_$PIECE(FHSAV,"^",7)_";"_$PIECE(FHSAV,"^",5)_";"
DO CODE^FHWOR5
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG,FHSAV,FILL
+7 QUIT
KIL KILL %,%H,%I,A1,A2,C,D1,D2,D3,DA,KK,P2,FHDU,NOW,X1,X2,OLD,FHDR,FHORD,FHPAR,FHLD,FHWF,FHPV,FHOR,I,K9,ADM,ALL,COM,TFCOM,FHDFN,DFN,FHD,POP,PID,BID,DTP,QUA,STR,T,TF,TF2,TUN,WARD,X,X9,Y
QUIT
