Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHWOR5

FHWOR5.m

Go to the documentation of this file.
  1. FHWOR5 ; HISC/NCA - HL7 Tubefeeding ;10/10/00 14:57
  1. ;;5.5;DIETETICS;**1**;Jan 28, 2005
  1. K TUN S (NO,TC,TK,TP,TW,S2)=0,CTR=5
  1. 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'=""
  1. I TXT'="" D ERR^FHWOR Q
  1. S (TC,TK)=0 W !
  1. F TT=0:0 S TT=$O(TUN(TT)) Q:TT<1 D
  1. .S TC=TC+$P(TUN(TT),"^",4)+$P(TUN(TT),"^",5)
  1. .S TK=TK+$P(TUN(TT),"^",6) Q
  1. I TC>5000 S TXT="WARNING: Total amount exceeds 5000ml. " D ERR^FHWOR Q
  1. S FHRDER=+FHORN,CAN=$$CANCEL^ORCDFH(FHRDER),FHRDER=FHORN
  1. ; Process TF
  1. S FHTF=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",4) I FHTF D ORCAN
  1. D ^FHORT11 S $P(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",14)=+FHORN
  1. S FILL="T"_";"_ADM_";"_TF_";"_TC_";"_TK_";"_TFCOM_";"_CAN D SEND^FHWOR
  1. 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
  1. Q
  1. ORCAN ; Cancel Tubefeeding when Order Comes From OE/RR
  1. N FHORN,FILL,COM D NOW^%DTC S NOW=%
  1. S $P(^FHPT(FHDFN,"A",ADM,0),"^",4)="" K ^FHPT("ADTF",FHDFN,ADM)
  1. S $P(^FHPT(FHDFN,"A",ADM,"TF",FHTF,0),"^",11,12)=NOW_"^"_DUZ
  1. S FHORN=$P(^FHPT(FHDFN,"A",ADM,"TF",FHTF,0),"^",14)
  1. S FHSAV=$G(^FHPT(FHDFN,"A",ADM,"TF",FHTF,0))
  1. 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
  1. Q
  1. CAN ; Process Cancel/Discontinue from OE/RR
  1. S TF=$P(FILL,";",3) I 'TF D CSEND^FHWOR Q
  1. D GADM^FHWORR
  1. I '$D(^FHPT(FHDFN,"A",+ADM,"TF",+TF,0)) D CSEND^FHWOR Q
  1. D NOW^%DTC S NOW=%
  1. I $P($G(^FHPT(FHDFN,"A",ADM,0)),"^",4)'=TF D CSEND^FHWOR Q
  1. I $P($G(^FHPT(FHDFN,"A",ADM,0)),"^",4)="" D CSEND^FHWOR Q
  1. S $P(^FHPT(FHDFN,"A",ADM,0),"^",4)="" K ^FHPT("ADTF",FHDFN,ADM)
  1. S $P(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",11,12)=NOW_"^"_DUZ
  1. S EVT="T^C^"_TF D ^FHORX K TF
  1. S FHRDER=FHORN
  1. D CSEND^FHWOR
  1. D CUR^FHORD7 Q:Y=""
  1. S FHCHK=$$RESUME^FHWORR(DFN) I 'FHCHK K FHDFN,FHRDER Q
  1. S FHRES=$$RESUME^ORCDFH(FHRDER) I FHRES D RES K FHRES,FHRDER,FHCHK,FHDFN
  1. Q
  1. RES ; Resume Current Tray Service From OE/RR.
  1. N A2,KK,OLD D NOW^%DTC S NOW=%
  1. 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
  1. I 'A2 Q
  1. S DT=$P(NOW,".",1),KK=A2,OLD=FHLD D T0^FHORD3
  1. 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
  1. Q
  1. TF ; Code Tubefeeding
  1. K MSG S FILL="T"_";"_ADM_";"_TF_";"_TC_";"_TK_";"_TFCOM_";"_CAN S MNUM=3
  1. S SDT=NOW D SET
  1. ; Code MSH, PID, and PV1
  1. D MSH^FHWOR
  1. ; Code ORC
  1. S MNUM=MNUM+1
  1. S MSG(MNUM)="ORC|SN||"_FILL_"^FH||||^^^"_SDT_"|||"_DUZ_"||"_DUZ_"|||"_NOW
  1. Q
  1. TF1 ; Code Multiple Products ODS and ZQT
  1. S STR=$P(XX,"^",2),STR=$S(STR=1:"1/4",STR="2":"1/2",STR=3:"3/4",1:"FULL")_" STRENGTH"
  1. S X=$P(XX,"^",3) D FIX^FHORT10 S QUA=X D DECOD
  1. S QUA=A1_"&"_$E(A2,1),ITVL=A3,MNUM=MNUM+1
  1. S MSG(MNUM)="ODS|ZE||^^^"_+XX_"-"_$P(XX,"^",2)_"^"_$P($G(^FH(118.2,+XX,0)),"^",1)_"^99FHT"_$S(TFCOM'="":"|"_TFCOM,1:"")
  1. S MNUM=MNUM+1
  1. S MSG(MNUM)="ZQT||"_QUA_"^"_ITVL_"^"_$S(FDG'="":FDG,1:"")_"^"_SDT
  1. K A1,A2,A3,FDG,FILL,FHWRD,HOSP,ITVL,L,RM,QUA,SITE,STR,WARD,Z,Z1
  1. Q
  1. DECOD ; Decode Tubefeeding to send
  1. S Z1="" F L=1:1:$L(QUA) S Z=$E(QUA,L) I Z'=" " S Z1=Z1_Z
  1. F L=1:1:$L(Z1) Q:$E(Z1,L)?1U
  1. S A2=$E(Z1,L,99),A1=+$E(Z1,1,L-1)
  1. S A3=$P(A2,"/",2),A2=$P(A2,"/",1)
  1. I A3'["X" S FDG="" Q
  1. S FDG=$P(A3,"X",2),FDG=$S($E(FDG,$L(FDG))="F":"X"_+FDG,1:"H"_+FDG),A3=$P(A3,"X",1)
  1. Q
  1. CODE ; Code Discontinue TF
  1. K MSG S ACT="OD" D SITE^FH
  1. ; code MSH
  1. S MSG(1)="MSH|^~\&|DIETETICS|"_SITE(1)_"|||||ORM"
  1. ; code PID
  1. S MSG(2)="PID|||"_DFN_"||"_$P($G(^DPT(DFN,0)),"^",1)
  1. ; code ORC
  1. S DATE=$$FMTHL7^XLFDT(NOW)
  1. S MSG(3)="ORC|"_ACT_"|"_FHORN_"^OR|"_FILL_"^FH|||||||||"_FHPV_"|||"_DATE_"|Dietetics Discontinued Tubefeeding order."
  1. K ACT,DATE,FILL,SITE
  1. Q
  1. SET ; Set Date/Time in HL7 format
  1. S:SDT SDT=$$FMTHL7^XLFDT(SDT)
  1. S:NOW NOW=$$FMTHL7^XLFDT(NOW)
  1. Q
  1. NA ; OE/RR Number Assign
  1. S TF=+$P(FILL,";",3) Q:'TF S:ADM'=$P(FILL,";",2) ADM=$P(FILL,";",2)
  1. G:'+FHORN KIL
  1. S $P(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",14)=+FHORN
  1. KIL K MSG,FHORN,TF Q