- FHWOR5R ; HISC/NCA - HL7 Tubefeeding Function Call ;6/28/96 16:28
- ;;5.5;DIETETICS;**1**;Jan 28, 2005
- QUAN(FHS,FHQ) ; Entry Point for OE to get Tubefeeding Quantity.
- N A1,A2,A3,DX,K,QUA,S1,S2,STR,T,TC,TK,TT,X,FDG
- S QUA=FHQ,A1=+QUA,A2=$E($P(QUA,"&",2),1),A3=$P(QUA,"^",2),FDG=$P(QUA,"^",3),TC=""
- 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 TT=+$P(FHS,"-",1) I 'TT G:'TT EXIT
- S STR=+$P(FHS,"-",2) Q:'STR
- 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 EXIT
- 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 EXIT I $L(A2)=1,"DH"'[A2 G EXIT
- S S2=$F("DAY QD QH HOUR HR BID TID Q2H Q3H Q4H Q6H QID",A2) G:'S2 EXIT 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 EXIT 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 EXIT 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)
- ;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)
- EXIT Q TC
- 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[HFHWOR5R 1942 printed Feb 18, 2025@23:21:50 Page 2
- FHWOR5R ; HISC/NCA - HL7 Tubefeeding Function Call ;6/28/96 16:28
- +1 ;;5.5;DIETETICS;**1**;Jan 28, 2005
- QUAN(FHS,FHQ) ; Entry Point for OE to get Tubefeeding Quantity.
- +1 NEW A1,A2,A3,DX,K,QUA,S1,S2,STR,T,TC,TK,TT,X,FDG
- +2 SET QUA=FHQ
- SET A1=+QUA
- SET A2=$EXTRACT($PIECE(QUA,"&",2),1)
- SET A3=$PIECE(QUA,"^",2)
- SET FDG=$PIECE(QUA,"^",3)
- SET TC=""
- +3 SET X=A1_A2_"/"_A3
- +4 IF FDG'=""
- IF "XH"'[$EXTRACT(FDG,1)
- SET FDG=""
- +5 if '$EXTRACT(FDG,2,99)
- SET FDG=""
- +6 IF FDG'=""
- SET X=X_$SELECT($EXTRACT(FDG,1)="H":"X"_$EXTRACT(FDG,2,99),1:FDG_"F")
- +7 SET QUA=X
- SET A2=A2_"/"_$PIECE(QUA,"/",2)
- +8 SET TT=+$PIECE(FHS,"-",1)
- IF 'TT
- if 'TT
- GOTO EXIT
- +9 SET STR=+$PIECE(FHS,"-",2)
- if 'STR
- QUIT
- +10 SET T(0)=$GET(^FH(118.2,+TT,0))
- +11 SET A3=$PIECE(A2,"/",2)
- SET A2=$PIECE(A2,"/",1)
- +12 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"
- +13 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
- +14 GOTO EXIT
- 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 EXIT
- IF $LENGTH(A2)=1
- IF "DH"'[A2
- GOTO EXIT
- +2 SET S2=$FIND("DAY QD QH HOUR HR BID TID Q2H Q3H Q4H Q6H QID",A2)
- if 'S2
- GOTO EXIT
- 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 EXIT
- 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 EXIT
- 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 ;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
- +2 ;I S1'=1!(S1'=6) S TK="",DX=$P(T(0),"^",4) I DX S TK=DX*TP,TK=$J(TK,0,0)
- EXIT QUIT TC
- F6 ;;per Day;per Hour;Twice a Day;Three times a Day;Every 2 Hours;Every 3 Hours;Every 4 Hours;Every 6 Hours
