FHORT11 ; HISC/REL/NCA - File Tubefeeding Order ;9/4/96 09:18
;;5.5;DIETETICS;;Jan 28, 2005
L +^FHPT(FHDFN,"A",ADM,"TF",0) S:'$D(^FHPT(FHDFN,"A",ADM,"TF",0)) ^FHPT(FHDFN,"A",ADM,"TF",0)="^115.04^^"
S TF=$P(^FHPT(FHDFN,"A",ADM,"TF",0),"^",3)+1,$P(^(0),"^",3,4)=TF_"^"_TF L -^FHPT(FHDFN,"A",ADM,"TF",0)
D NOW^%DTC S NOW=%,DT=NOW\1
S ^FHPT(FHDFN,"A",ADM,"TF",TF,0)=NOW_"^^^^"_TFCOM_"^"_TC_"^"_TK_"^^^"_DUZ
S TF2=0 F P=0:0 S P=$O(TUN(P)) Q:P<1 D TF1
S ^FHPT(FHDFN,"A",ADM,"TF",TF,"P",0)="^115.1P^"_TF2_"^"_TF2
S $P(^FHPT(FHDFN,"A",ADM,0),"^",4)=TF,^FHPT("ADTF",FHDFN,ADM)="",EVT="T^O^"_TF D ^FHORX
S:FHWF'=2 (FHORN,FHSAV)=""
I CAN S FHOR="^^^^",FHLD="X",TYP="",D1=NOW,D2="",D4=0,COM="Hold Tray due to Tubefeeding" D STR^FHORD7 I $P(^FHPT(FHDFN,"A",ADM,0),"^",7) S CAN=CAN+1 D CAN^FHNO5 K NO
D POST^FHORT3 W:FHWF'=2 " ... filed" Q
TF1 S TF2=TF2+1,^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2,0)=$P(TUN(P),"^",1,6)
S ^FHPT(FHDFN,"A",ADM,"TF",TF,"P","B",+TUN(P),TF2)="" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORT11 985 printed Oct 16, 2024@17:54:44 Page 2
FHORT11 ; HISC/REL/NCA - File Tubefeeding Order ;9/4/96 09:18
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 LOCK +^FHPT(FHDFN,"A",ADM,"TF",0)
if '$DATA(^FHPT(FHDFN,"A",ADM,"TF",0))
SET ^FHPT(FHDFN,"A",ADM,"TF",0)="^115.04^^"
+3 SET TF=$PIECE(^FHPT(FHDFN,"A",ADM,"TF",0),"^",3)+1
SET $PIECE(^(0),"^",3,4)=TF_"^"_TF
LOCK -^FHPT(FHDFN,"A",ADM,"TF",0)
+4 DO NOW^%DTC
SET NOW=%
SET DT=NOW\1
+5 SET ^FHPT(FHDFN,"A",ADM,"TF",TF,0)=NOW_"^^^^"_TFCOM_"^"_TC_"^"_TK_"^^^"_DUZ
+6 SET TF2=0
FOR P=0:0
SET P=$ORDER(TUN(P))
if P<1
QUIT
DO TF1
+7 SET ^FHPT(FHDFN,"A",ADM,"TF",TF,"P",0)="^115.1P^"_TF2_"^"_TF2
+8 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",4)=TF
SET ^FHPT("ADTF",FHDFN,ADM)=""
SET EVT="T^O^"_TF
DO ^FHORX
+9 if FHWF'=2
SET (FHORN,FHSAV)=""
+10 IF CAN
SET FHOR="^^^^"
SET FHLD="X"
SET TYP=""
SET D1=NOW
SET D2=""
SET D4=0
SET COM="Hold Tray due to Tubefeeding"
DO STR^FHORD7
IF $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",7)
SET CAN=CAN+1
DO CAN^FHNO5
KILL NO
+11 DO POST^FHORT3
if FHWF'=2
WRITE " ... filed"
QUIT
TF1 SET TF2=TF2+1
SET ^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2,0)=$PIECE(TUN(P),"^",1,6)
+1 SET ^FHPT(FHDFN,"A",ADM,"TF",TF,"P","B",+TUN(P),TF2)=""
QUIT
