FHWOR51 ; HISC/NCA - HL7 Tubefeeding (Cont.) ;6/28/96 16:28
;;5.5;DIETETICS;**1**;Jan 28, 2005
I $E(DATA,1,3)'="ODS" S TXT="Message 5 not ODS as expected." Q
S TYP=$P(DATA,"|",2)
I TYP'="ZE" S TXT="Type of Diet Order not ZE as expected." Q
I $E(DATA1,1,3)'="ZQT" S TXT="Message not ZQT as expected." Q
S QUA=$P(DATA1,"|",3),A1=+QUA,A2=$E($P(QUA,"&",2),1),A3=$P(QUA,"^",2),FDG=$P(QUA,"^",3)
S (TC,TK,TP,TW)=0
S X=A1_A2_"/"_A3
I FDG'="","XH"'[$E(FDG,1) S FDG=""
S:'$E(FDG,2,99) FDG=""
I FDG'="" S X=X_$S($E(FDG,1)="H":"X"_$E(FDG,2,99),1:FDG_"F")
S QUA=X,A2=A2_"/"_$P(QUA,"/",2)
S DIET=$P(DATA,"|",4),DIET=$E(DIET,4,$L(DIET)),TFCOM=$E($P(DATA,"|",5),1,160)
S TT=+$P(DIET,"-",1) I 'TT S TXT="No internal entry number in coded identifier." Q
S STR=+$P(DIET,"-",2) I 'STR S TXT="No Tubefeeding Product Strength." Q
I $E($P(DIET,"^",3),1,5)'="99FHT" S TXT="No 99FHT code."
S T(0)=$G(^FH(118.2,+TT,0))
S A3=$P(A2,"/",2),A2=$P(A2,"/",1)
I $E($P(T(0),"^",3),$L($P(T(0),"^",3)))?1"G" S:$E(A2,1)'="G" A1=A1*+$P(T(0),"^",3),A2="GRAM"
F K=1:1:11 S S1=$P("KCAL CC ML OZ UNITS BOTTLES CANS PKG TBSP GMS GRAMS"," ",K) G:$P(S1,A2,1)="" F3
G ERR
F3 S S1=$S(K=1:1,K<4:2,K=4:3,K=9:5,K>9:6,1:4),A2=$P(A3,"X",1),A3=$P(A3,"X",2)
G:A2'?1U.E ERR I $L(A2)=1,"DH"'[A2 G ERR
S S2=$F("DAY QD QH HOUR HR BID TID Q2H Q3H Q4H Q6H QID",A2) G:'S2 ERR S S2=$S(S2<8:1,S2<19:2,S2<23:3,S2<27:4,S2<31:5,S2<35:6,S2<39:7,1:8)
S QUA=A1_" "_$P("KCAL ML OZ UNITS TBSP GM"," ",S1),QUA=QUA_" "_$P($T(F6),";",S2+2)
S:A3'="" QUA=QUA_" X "_(+A3)_" "_$S(A3["F":"fdgs",1:"hrs")
I S1=1 S DX=$P(T(0),"^",4) G:'DX ERR S TK=A1,TC=A1/DX*$S(STR=4:1,STR=3:1.333,STR=2:2,1:4)
I S1=4 S DX=+$P(T(0),"^",3) G:'DX ERR S TC=A1*DX*$S(STR=4:1,STR=3:1.333,STR=2:2,1:4)
S:S1=2 TC=A1 S:S1=3 TC=A1*29.5 S:S1=5 TC=A1*15 I S1=6 S TC=0,A3=0 G C1
ML I 'A3 S A3=$P("1,24,2,3,12,8,6,4",",",S2) G C1
I A3'["F" S A3=$S(S2=1:1,S2=2:A3,S2=3:2,S2=4:3,S2=5:A3\2,S2=6:A3\3,S2=7:A3\4,1:A3\6)
E S:S2=1 A3=1
C1 S TC=$J(TC*A3,0,0)
I TC>5000 S TXT="WARNING: Total Amount should be between 0 to 5000 ml." Q
S:TC'<1 TP=$S(STR=4:TC,STR=3:TC*.75,STR=2:TC/2,1:TC/4),TP=$J(TP,0,0),TW=TC-TP
I S1'=1!(S1'=6) S TK="",DX=$P(T(0),"^",4) I DX S TK=DX*TP,TK=$J(TK,0,0)
S $P(TUN(TT),"^",1,6)=TT_"^"_STR_"^"_QUA_"^"_TP_"^"_TW_"^"_TK,NO=NO+1
Q
ERR S TXT="Wrong Interval/Duration." Q
F6 ;;per Day;per Hour;Twice a Day;Three times a Day;Every 2 Hours;Every 3 Hours;Every 4 Hours;Every 6 Hours
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHWOR51 2466 printed Nov 22, 2024@17:05:37 Page 2
FHWOR51 ; HISC/NCA - HL7 Tubefeeding (Cont.) ;6/28/96 16:28
+1 ;;5.5;DIETETICS;**1**;Jan 28, 2005
+2 IF $EXTRACT(DATA,1,3)'="ODS"
SET TXT="Message 5 not ODS as expected."
QUIT
+3 SET TYP=$PIECE(DATA,"|",2)
+4 IF TYP'="ZE"
SET TXT="Type of Diet Order not ZE as expected."
QUIT
+5 IF $EXTRACT(DATA1,1,3)'="ZQT"
SET TXT="Message not ZQT as expected."
QUIT
+6 SET QUA=$PIECE(DATA1,"|",3)
SET A1=+QUA
SET A2=$EXTRACT($PIECE(QUA,"&",2),1)
SET A3=$PIECE(QUA,"^",2)
SET FDG=$PIECE(QUA,"^",3)
+7 SET (TC,TK,TP,TW)=0
+8 SET X=A1_A2_"/"_A3
+9 IF FDG'=""
IF "XH"'[$EXTRACT(FDG,1)
SET FDG=""
+10 if '$EXTRACT(FDG,2,99)
SET FDG=""
+11 IF FDG'=""
SET X=X_$SELECT($EXTRACT(FDG,1)="H":"X"_$EXTRACT(FDG,2,99),1:FDG_"F")
+12 SET QUA=X
SET A2=A2_"/"_$PIECE(QUA,"/",2)
+13 SET DIET=$PIECE(DATA,"|",4)
SET DIET=$EXTRACT(DIET,4,$LENGTH(DIET))
SET TFCOM=$EXTRACT($PIECE(DATA,"|",5),1,160)
+14 SET TT=+$PIECE(DIET,"-",1)
IF 'TT
SET TXT="No internal entry number in coded identifier."
QUIT
+15 SET STR=+$PIECE(DIET,"-",2)
IF 'STR
SET TXT="No Tubefeeding Product Strength."
QUIT
+16 IF $EXTRACT($PIECE(DIET,"^",3),1,5)'="99FHT"
SET TXT="No 99FHT code."
+17 SET T(0)=$GET(^FH(118.2,+TT,0))
+18 SET A3=$PIECE(A2,"/",2)
SET A2=$PIECE(A2,"/",1)
+19 IF $EXTRACT($PIECE(T(0),"^",3),$LENGTH($PIECE(T(0),"^",3)))?1"G"
if $EXTRACT(A2,1)'="G"
SET A1=A1*+$PIECE(T(0),"^",3)
SET A2="GRAM"
+20 FOR K=1:1:11
SET S1=$PIECE("KCAL CC ML OZ UNITS BOTTLES CANS PKG TBSP GMS GRAMS"," ",K)
if $PIECE(S1,A2,1)=""
GOTO F3
+21 GOTO ERR
F3 SET S1=$SELECT(K=1:1,K<4:2,K=4:3,K=9:5,K>9:6,1:4)
SET A2=$PIECE(A3,"X",1)
SET A3=$PIECE(A3,"X",2)
+1 if A2'?1U.E
GOTO ERR
IF $LENGTH(A2)=1
IF "DH"'[A2
GOTO ERR
+2 SET S2=$FIND("DAY QD QH HOUR HR BID TID Q2H Q3H Q4H Q6H QID",A2)
if 'S2
GOTO ERR
SET S2=$SELECT(S2<8:1,S2<19:2,S2<23:3,S2<27:4,S2<31:5,S2<35:6,S2<39:7,1:8)
+3 SET QUA=A1_" "_$PIECE("KCAL ML OZ UNITS TBSP GM"," ",S1)
SET QUA=QUA_" "_$PIECE($TEXT(F6),";",S2+2)
+4 if A3'=""
SET QUA=QUA_" X "_(+A3)_" "_$SELECT(A3["F":"fdgs",1:"hrs")
+5 IF S1=1
SET DX=$PIECE(T(0),"^",4)
if 'DX
GOTO ERR
SET TK=A1
SET TC=A1/DX*$SELECT(STR=4:1,STR=3:1.333,STR=2:2,1:4)
+6 IF S1=4
SET DX=+$PIECE(T(0),"^",3)
if 'DX
GOTO ERR
SET TC=A1*DX*$SELECT(STR=4:1,STR=3:1.333,STR=2:2,1:4)
+7 if S1=2
SET TC=A1
if S1=3
SET TC=A1*29.5
if S1=5
SET TC=A1*15
IF S1=6
SET TC=0
SET A3=0
GOTO C1
ML IF 'A3
SET A3=$PIECE("1,24,2,3,12,8,6,4",",",S2)
GOTO C1
+1 IF A3'["F"
SET A3=$SELECT(S2=1:1,S2=2:A3,S2=3:2,S2=4:3,S2=5:A3\2,S2=6:A3\3,S2=7:A3\4,1:A3\6)
+2 IF '$TEST
if S2=1
SET A3=1
C1 SET TC=$JUSTIFY(TC*A3,0,0)
+1 IF TC>5000
SET TXT="WARNING: Total Amount should be between 0 to 5000 ml."
QUIT
+2 if TC'<1
SET TP=$SELECT(STR=4:TC,STR=3:TC*.75,STR=2:TC/2,1:TC/4)
SET TP=$JUSTIFY(TP,0,0)
SET TW=TC-TP
+3 IF S1'=1!(S1'=6)
SET TK=""
SET DX=$PIECE(T(0),"^",4)
IF DX
SET TK=DX*TP
SET TK=$JUSTIFY(TK,0,0)
+4 SET $PIECE(TUN(TT),"^",1,6)=TT_"^"_STR_"^"_QUA_"^"_TP_"^"_TW_"^"_TK
SET NO=NO+1
+5 QUIT
ERR SET TXT="Wrong Interval/Duration."
QUIT
F6 ;;per Day;per Hour;Twice a Day;Three times a Day;Every 2 Hours;Every 3 Hours;Every 4 Hours;Every 6 Hours
