- 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 Feb 18, 2025@23:21:48 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