source: FOIAVistA/trunk/r/DIETETICS-FH/FHWOR5.m@ 1354

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