- 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 Mar 13, 2025@20:58:33 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
