FHWOR5 ; HISC/NCA - HL7 Tubefeeding ;10/10/00 14:57
;;5.5;DIETETICS;**1**;Jan 28, 2005
K TUN S (NO,TC,TK,TP,TW,S2)=0,CTR=5
F NUM=1:1:5 S DATA=$G(FHMSG(CTR)) Q:DATA="" S CTR=CTR+1,DATA1=$G(FHMSG(CTR)) Q:DATA1="" D ^FHWOR51 S CTR=CTR+1 Q:TXT'=""
I TXT'="" D ERR^FHWOR Q
S (TC,TK)=0 W !
F TT=0:0 S TT=$O(TUN(TT)) Q:TT<1 D
.S TC=TC+$P(TUN(TT),"^",4)+$P(TUN(TT),"^",5)
.S TK=TK+$P(TUN(TT),"^",6) Q
I TC>5000 S TXT="WARNING: Total amount exceeds 5000ml. " D ERR^FHWOR Q
S FHRDER=+FHORN,CAN=$$CANCEL^ORCDFH(FHRDER),FHRDER=FHORN
; Process TF
S FHTF=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",4) I FHTF D ORCAN
D ^FHORT11 S $P(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",14)=+FHORN
S FILL="T"_";"_ADM_";"_TF_";"_TC_";"_TK_";"_TFCOM_";"_CAN D SEND^FHWOR
K %,A1,A2,A3,CAN,DATA,DATA1,DIET,DUR,DX,K,FHRDER,FHMSG,FHOL,FHSTR,FHY,QUA,S1,S2,T,TC,TF,TFCOM,TK,TP,TT,TUN,TW,TYP,X
Q
ORCAN ; Cancel Tubefeeding when Order Comes From OE/RR
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",FHTF,0),"^",11,12)=NOW_"^"_DUZ
S FHORN=$P(^FHPT(FHDFN,"A",ADM,"TF",FHTF,0),"^",14)
S FHSAV=$G(^FHPT(FHDFN,"A",ADM,"TF",FHTF,0))
K % S EVT="T^C^"_FHTF D ^FHORX I FHORN S FILL="T"_";"_ADM_";"_FHTF_";"_$P(FHSAV,"^",6)_";"_$P(FHSAV,"^",7)_";"_$P(FHSAV,"^",5)_";" D CODE D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG,FHSAV,FILL
Q
CAN ; Process Cancel/Discontinue from OE/RR
S TF=$P(FILL,";",3) I 'TF D CSEND^FHWOR Q
D GADM^FHWORR
I '$D(^FHPT(FHDFN,"A",+ADM,"TF",+TF,0)) D CSEND^FHWOR Q
D NOW^%DTC S NOW=%
I $P($G(^FHPT(FHDFN,"A",ADM,0)),"^",4)'=TF D CSEND^FHWOR Q
I $P($G(^FHPT(FHDFN,"A",ADM,0)),"^",4)="" D CSEND^FHWOR Q
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 EVT="T^C^"_TF D ^FHORX K TF
S FHRDER=FHORN
D CSEND^FHWOR
D CUR^FHORD7 Q:Y=""
S FHCHK=$$RESUME^FHWORR(DFN) I 'FHCHK K FHDFN,FHRDER Q
S FHRES=$$RESUME^ORCDFH(FHRDER) I FHRES D RES K FHRES,FHRDER,FHCHK,FHDFN
Q
RES ; Resume Current Tray Service From OE/RR.
N A2,KK,OLD D NOW^%DTC S NOW=%
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 Q
S DT=$P(NOW,".",1),KK=A2,OLD=FHLD D T0^FHORD3
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
TF ; Code Tubefeeding
K MSG S FILL="T"_";"_ADM_";"_TF_";"_TC_";"_TK_";"_TFCOM_";"_CAN S MNUM=3
S SDT=NOW D SET
; Code MSH, PID, and PV1
D MSH^FHWOR
; Code ORC
S MNUM=MNUM+1
S MSG(MNUM)="ORC|SN||"_FILL_"^FH||||^^^"_SDT_"|||"_DUZ_"||"_DUZ_"|||"_NOW
Q
TF1 ; Code Multiple Products ODS and ZQT
S STR=$P(XX,"^",2),STR=$S(STR=1:"1/4",STR="2":"1/2",STR=3:"3/4",1:"FULL")_" STRENGTH"
S X=$P(XX,"^",3) D FIX^FHORT10 S QUA=X D DECOD
S QUA=A1_"&"_$E(A2,1),ITVL=A3,MNUM=MNUM+1
S MSG(MNUM)="ODS|ZE||^^^"_+XX_"-"_$P(XX,"^",2)_"^"_$P($G(^FH(118.2,+XX,0)),"^",1)_"^99FHT"_$S(TFCOM'="":"|"_TFCOM,1:"")
S MNUM=MNUM+1
S MSG(MNUM)="ZQT||"_QUA_"^"_ITVL_"^"_$S(FDG'="":FDG,1:"")_"^"_SDT
K A1,A2,A3,FDG,FILL,FHWRD,HOSP,ITVL,L,RM,QUA,SITE,STR,WARD,Z,Z1
Q
DECOD ; Decode Tubefeeding to send
S Z1="" F L=1:1:$L(QUA) S Z=$E(QUA,L) I Z'=" " S Z1=Z1_Z
F L=1:1:$L(Z1) Q:$E(Z1,L)?1U
S A2=$E(Z1,L,99),A1=+$E(Z1,1,L-1)
S A3=$P(A2,"/",2),A2=$P(A2,"/",1)
I A3'["X" S FDG="" Q
S FDG=$P(A3,"X",2),FDG=$S($E(FDG,$L(FDG))="F":"X"_+FDG,1:"H"_+FDG),A3=$P(A3,"X",1)
Q
CODE ; Code Discontinue TF
K MSG S ACT="OD" D SITE^FH
; code MSH
S MSG(1)="MSH|^~\&|DIETETICS|"_SITE(1)_"|||||ORM"
; code PID
S MSG(2)="PID|||"_DFN_"||"_$P($G(^DPT(DFN,0)),"^",1)
; code ORC
S DATE=$$FMTHL7^XLFDT(NOW)
S MSG(3)="ORC|"_ACT_"|"_FHORN_"^OR|"_FILL_"^FH|||||||||"_FHPV_"|||"_DATE_"|Dietetics Discontinued Tubefeeding order."
K ACT,DATE,FILL,SITE
Q
SET ; Set Date/Time in HL7 format
S:SDT SDT=$$FMTHL7^XLFDT(SDT)
S:NOW NOW=$$FMTHL7^XLFDT(NOW)
Q
NA ; OE/RR Number Assign
S TF=+$P(FILL,";",3) Q:'TF S:ADM'=$P(FILL,";",2) ADM=$P(FILL,";",2)
G:'+FHORN KIL
S $P(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",14)=+FHORN
KIL K MSG,FHORN,TF Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHWOR5 4236 printed Sep 23, 2025@19:31:25 Page 2
FHWOR5 ; HISC/NCA - HL7 Tubefeeding ;10/10/00 14:57
+1 ;;5.5;DIETETICS;**1**;Jan 28, 2005
+2 KILL TUN
SET (NO,TC,TK,TP,TW,S2)=0
SET CTR=5
+3 FOR NUM=1:1:5
SET DATA=$GET(FHMSG(CTR))
if DATA=""
QUIT
SET CTR=CTR+1
SET DATA1=$GET(FHMSG(CTR))
if DATA1=""
QUIT
DO ^FHWOR51
SET CTR=CTR+1
if TXT'=""
QUIT
+4 IF TXT'=""
DO ERR^FHWOR
QUIT
+5 SET (TC,TK)=0
WRITE !
+6 FOR TT=0:0
SET TT=$ORDER(TUN(TT))
if TT<1
QUIT
Begin DoDot:1
+7 SET TC=TC+$PIECE(TUN(TT),"^",4)+$PIECE(TUN(TT),"^",5)
+8 SET TK=TK+$PIECE(TUN(TT),"^",6)
QUIT
End DoDot:1
+9 IF TC>5000
SET TXT="WARNING: Total amount exceeds 5000ml. "
DO ERR^FHWOR
QUIT
+10 SET FHRDER=+FHORN
SET CAN=$$CANCEL^ORCDFH(FHRDER)
SET FHRDER=FHORN
+11 ; Process TF
+12 SET FHTF=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",4)
IF FHTF
DO ORCAN
+13 DO ^FHORT11
SET $PIECE(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",14)=+FHORN
+14 SET FILL="T"_";"_ADM_";"_TF_";"_TC_";"_TK_";"_TFCOM_";"_CAN
DO SEND^FHWOR
+15 KILL %,A1,A2,A3,CAN,DATA,DATA1,DIET,DUR,DX,K,FHRDER,FHMSG,FHOL,FHSTR,FHY,QUA,S1,S2,T,TC,TF,TFCOM,TK,TP,TT,TUN,TW,TYP,X
+16 QUIT
ORCAN ; Cancel Tubefeeding when Order Comes From OE/RR
+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",FHTF,0),"^",11,12)=NOW_"^"_DUZ
+4 SET FHORN=$PIECE(^FHPT(FHDFN,"A",ADM,"TF",FHTF,0),"^",14)
+5 SET FHSAV=$GET(^FHPT(FHDFN,"A",ADM,"TF",FHTF,0))
+6 KILL %
SET EVT="T^C^"_FHTF
DO ^FHORX
IF FHORN
SET FILL="T"_";"_ADM_";"_FHTF_";"_$PIECE(FHSAV,"^",6)_";"_$PIECE(FHSAV,"^",7)_";"_$PIECE(FHSAV,"^",5)_";"
DO CODE
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG,FHSAV,FILL
+7 QUIT
CAN ; Process Cancel/Discontinue from OE/RR
+1 SET TF=$PIECE(FILL,";",3)
IF 'TF
DO CSEND^FHWOR
QUIT
+2 DO GADM^FHWORR
+3 IF '$DATA(^FHPT(FHDFN,"A",+ADM,"TF",+TF,0))
DO CSEND^FHWOR
QUIT
+4 DO NOW^%DTC
SET NOW=%
+5 IF $PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",4)'=TF
DO CSEND^FHWOR
QUIT
+6 IF $PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",4)=""
DO CSEND^FHWOR
QUIT
+7 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",4)=""
KILL ^FHPT("ADTF",FHDFN,ADM)
+8 SET $PIECE(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",11,12)=NOW_"^"_DUZ
+9 SET EVT="T^C^"_TF
DO ^FHORX
KILL TF
+10 SET FHRDER=FHORN
+11 DO CSEND^FHWOR
+12 DO CUR^FHORD7
if Y=""
QUIT
+13 SET FHCHK=$$RESUME^FHWORR(DFN)
IF 'FHCHK
KILL FHDFN,FHRDER
QUIT
+14 SET FHRES=$$RESUME^ORCDFH(FHRDER)
IF FHRES
DO RES
KILL FHRES,FHRDER,FHCHK,FHDFN
+15 QUIT
RES ; Resume Current Tray Service From OE/RR.
+1 NEW A2,KK,OLD
DO NOW^%DTC
SET NOW=%
+2 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
+3 IF 'A2
QUIT
+4 SET DT=$PIECE(NOW,".",1)
SET KK=A2
SET OLD=FHLD
DO T0^FHORD3
+5 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
+6 QUIT
TF ; Code Tubefeeding
+1 KILL MSG
SET FILL="T"_";"_ADM_";"_TF_";"_TC_";"_TK_";"_TFCOM_";"_CAN
SET MNUM=3
+2 SET SDT=NOW
DO SET
+3 ; Code MSH, PID, and PV1
+4 DO MSH^FHWOR
+5 ; Code ORC
+6 SET MNUM=MNUM+1
+7 SET MSG(MNUM)="ORC|SN||"_FILL_"^FH||||^^^"_SDT_"|||"_DUZ_"||"_DUZ_"|||"_NOW
+8 QUIT
TF1 ; Code Multiple Products ODS and ZQT
+1 SET STR=$PIECE(XX,"^",2)
SET STR=$SELECT(STR=1:"1/4",STR="2":"1/2",STR=3:"3/4",1:"FULL")_" STRENGTH"
+2 SET X=$PIECE(XX,"^",3)
DO FIX^FHORT10
SET QUA=X
DO DECOD
+3 SET QUA=A1_"&"_$EXTRACT(A2,1)
SET ITVL=A3
SET MNUM=MNUM+1
+4 SET MSG(MNUM)="ODS|ZE||^^^"_+XX_"-"_$PIECE(XX,"^",2)_"^"_$PIECE($GET(^FH(118.2,+XX,0)),"^",1)_"^99FHT"_$SELECT(TFCOM'="":"|"_TFCOM,1:"")
+5 SET MNUM=MNUM+1
+6 SET MSG(MNUM)="ZQT||"_QUA_"^"_ITVL_"^"_$SELECT(FDG'="":FDG,1:"")_"^"_SDT
+7 KILL A1,A2,A3,FDG,FILL,FHWRD,HOSP,ITVL,L,RM,QUA,SITE,STR,WARD,Z,Z1
+8 QUIT
DECOD ; Decode Tubefeeding to send
+1 SET Z1=""
FOR L=1:1:$LENGTH(QUA)
SET Z=$EXTRACT(QUA,L)
IF Z'=" "
SET Z1=Z1_Z
+2 FOR L=1:1:$LENGTH(Z1)
if $EXTRACT(Z1,L)?1U
QUIT
+3 SET A2=$EXTRACT(Z1,L,99)
SET A1=+$EXTRACT(Z1,1,L-1)
+4 SET A3=$PIECE(A2,"/",2)
SET A2=$PIECE(A2,"/",1)
+5 IF A3'["X"
SET FDG=""
QUIT
+6 SET FDG=$PIECE(A3,"X",2)
SET FDG=$SELECT($EXTRACT(FDG,$LENGTH(FDG))="F":"X"_+FDG,1:"H"_+FDG)
SET A3=$PIECE(A3,"X",1)
+7 QUIT
CODE ; Code Discontinue TF
+1 KILL MSG
SET ACT="OD"
DO SITE^FH
+2 ; code MSH
+3 SET MSG(1)="MSH|^~\&|DIETETICS|"_SITE(1)_"|||||ORM"
+4 ; code PID
+5 SET MSG(2)="PID|||"_DFN_"||"_$PIECE($GET(^DPT(DFN,0)),"^",1)
+6 ; code ORC
+7 SET DATE=$$FMTHL7^XLFDT(NOW)
+8 SET MSG(3)="ORC|"_ACT_"|"_FHORN_"^OR|"_FILL_"^FH|||||||||"_FHPV_"|||"_DATE_"|Dietetics Discontinued Tubefeeding order."
+9 KILL ACT,DATE,FILL,SITE
+10 QUIT
SET ; Set Date/Time in HL7 format
+1 if SDT
SET SDT=$$FMTHL7^XLFDT(SDT)
+2 if NOW
SET NOW=$$FMTHL7^XLFDT(NOW)
+3 QUIT
NA ; OE/RR Number Assign
+1 SET TF=+$PIECE(FILL,";",3)
if 'TF
QUIT
if ADM'=$PIECE(FILL,";",2)
SET ADM=$PIECE(FILL,";",2)
+2 if '+FHORN
GOTO KIL
+3 SET $PIECE(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",14)=+FHORN
KIL KILL MSG,FHORN,TF
QUIT
