FHORTR.m

FHORTR ; HISC/NCA - Tubefeeding Product Search ;8/8/96  08:12

 ;;5.5;DIETETICS;;Jan 28, 2005

SRCH(FHX) ; Search For Tubefeeding Product

 N DIC,FHY,X,Y

 S X=FHX,FHY=""

 W ! K DIC S DIC="^FH(118.2,",DIC(0)="EQM" D ^DIC G:"^"[X!$D(DTOUT) EXIT

 G:Y<1 EXIT

 S FHY=+Y

EXIT Q FHY

DISP ; Display Edited Tubefeeding

 N TC,TK S (TC,TK)=0 W !

 I $O(TUN(0))="" W !!,"No Tubefeeding Products Selected." Q

 F K=0:0 S K=$O(TUN(K)) Q:K<1  D

 .S TC=TC+$P(TUN(K),"^",4)+$P(TUN(K),"^",5)

 .S TK=TK+$P(TUN(K),"^",6),STR=$P(TUN(K),"^",2)

 .S PRO=$P(TUN(K),"^",1)

 .W !,"Product: ",$P($G(^FH(118.2,PRO,0)),"^",1),", "

 .W $S(STR=4:"Full",STR=2:"1/2",STR=1:"1/4",STR=3:"3/4",1:""),", "

 .W $P(TUN(K),"^",3)

 .Q

 W !!,"Total Kcal: ",TK,?36,"Total Quantity: ",TC

 Q

HELP ; Help Prompt for Tubefeeding Product.

 W !!,"Hit return to take the default.",!,"Enter a ""@"" to delete the product, strength and quantity.",!,"Enter another product name to replace existing product name."

 W !,"To Replace, enter first few characters of the product name, e.g., SUS for SUSTACAL."

 W !,"Enter a ""^"" will Exit Completely."

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FHORTR   1118     printed  Mar 13, 2025@20:58:39                                                                                                                                                                                                      Page 2

FHORTR    ; HISC/NCA - Tubefeeding Product Search ;8/8/96  08:12

 +1       ;;5.5;DIETETICS;;Jan 28, 2005

SRCH(FHX) ; Search For Tubefeeding Product

 +1        NEW DIC,FHY,X,Y

 +2        SET X=FHX

           SET FHY=""

 +3        WRITE !

           KILL DIC

           SET DIC="^FH(118.2,"

           SET DIC(0)="EQM"

           DO ^DIC

           if "^"[X!$DATA(DTOUT)

               GOTO EXIT

 +4        if Y<1

               GOTO EXIT

 +5        SET FHY=+Y

EXIT       QUIT FHY

DISP      ; Display Edited Tubefeeding

 +1        NEW TC,TK

           SET (TC,TK)=0

           WRITE !

 +2        IF $ORDER(TUN(0))=""

               WRITE !!,"No Tubefeeding Products Selected."

               QUIT 

 +3        FOR K=0:0

               SET K=$ORDER(TUN(K))

               if K<1

                   QUIT 

               Begin DoDot:1

 +4                SET TC=TC+$PIECE(TUN(K),"^",4)+$PIECE(TUN(K),"^",5)

 +5                SET TK=TK+$PIECE(TUN(K),"^",6)

                   SET STR=$PIECE(TUN(K),"^",2)

 +6                SET PRO=$PIECE(TUN(K),"^",1)

 +7                WRITE !,"Product: ",$PIECE($GET(^FH(118.2,PRO,0)),"^",1),", "

 +8                WRITE $SELECT(STR=4:"Full",STR=2:"1/2",STR=1:"1/4",STR=3:"3/4",1:""),", "

 +9                WRITE $PIECE(TUN(K),"^",3)

 +10               QUIT 

               End DoDot:1

 +11       WRITE !!,"Total Kcal: ",TK,?36,"Total Quantity: ",TC

 +12       QUIT 

HELP      ; Help Prompt for Tubefeeding Product.

 +1        WRITE !!,"Hit return to take the default.",!,"Enter a ""@"" to delete the product, strength and quantity.",!,"Enter another product name to replace existing product name."

 +2        WRITE !,"To Replace, enter first few characters of the product name, e.g., SUS for SUSTACAL."

 +3        WRITE !,"Enter a ""^"" will Exit Completely."

 +4        QUIT