FHORT5B.m

FHORT5B ; HISC/REL/NCA - Tubefeeding Reports (cont) ;5/4/93  10:47 

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

PREP ; Preparation Report

 D:SUM HD1 S TNOD="" F  S TNOD=$O(^TMP($J,"T",TNOD)) Q:TNOD=""  D:'SUM HD1 D A2

 Q

A2 S PNOD="" F  S PNOD=$O(^TMP($J,"T",TNOD,PNOD)) Q:PNOD=""  S X0=^(PNOD,0) D A3

 Q

A3 D:$Y>(IOSL-10) HD1 W !,$P(X0,"^",3)," ",$P(X0,"^",4),!,$P(X0,"^",1),?23,$P(X0,"^",2)

 F TF2=0:0 S TF2=$O(^TMP($J,"T",TNOD,PNOD,TF2)) Q:'TF2  S X1=^(TF2,0) D A4

 S COM=$P(X0,"^",5) W:COM'="" ?66,COM,! Q

A4 W ?31,$E($P(X1,"^",1),1,29) S STR=$P(X1,"^",7) W ?61,$S(STR=4:"Full",STR=2:"1/2",STR=1:"1/4",1:"3/4")

 W ?66,$P(X1,"^",8),?101,$P(X1,"^",2),?110,$P(X1,"^",6)

 S TW=$P(X1,"^",4) I TW W ?117,$J($P(X1,"^",3),5),?126,$J(TW,4)

 W ! Q

HD1 ; Preparation Header

 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1

 W !,DTP,?39,"P R E P A R A T I O N   O F   T U B E F E E D I N G S",?125,"Page ",PG

 S Y=$S(SUM:"CONSOLIDATED",1:$P(TNOD,"~",2)) W:Y'="" !!?(131-$L(Y)\2),Y

 W !!,?112,"#",?119,"ML",?127,"ML"

 W !,"Patient",?24,"ID#",?31,"Product",?61,"Str",?66,"Quantity",?101,"Unit",?110,"Units",?117,"Product",?126,"Water",!

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FHORT5B   1138     printed  Apr 09, 2024@20:55:23                                                                                                                                                                                                     Page 2

FHORT5B   ; HISC/REL/NCA - Tubefeeding Reports (cont) ;5/4/93  10:47 

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

PREP      ; Preparation Report

 +1        if SUM

               DO HD1

           SET TNOD=""

           FOR 

               SET TNOD=$ORDER(^TMP($JOB,"T",TNOD))

               if TNOD=""

                   QUIT 

               if 'SUM

                   DO HD1

               DO A2

 +2        QUIT 

A2         SET PNOD=""

           FOR 

               SET PNOD=$ORDER(^TMP($JOB,"T",TNOD,PNOD))

               if PNOD=""

                   QUIT 

               SET X0=^(PNOD,0)

               DO A3

 +1        QUIT 

A3         if $Y>(IOSL-10)

               DO HD1

           WRITE !,$PIECE(X0,"^",3)," ",$PIECE(X0,"^",4),!,$PIECE(X0,"^",1),?23,$PIECE(X0,"^",2)

 +1        FOR TF2=0:0

               SET TF2=$ORDER(^TMP($JOB,"T",TNOD,PNOD,TF2))

               if 'TF2

                   QUIT 

               SET X1=^(TF2,0)

               DO A4

 +2        SET COM=$PIECE(X0,"^",5)

           if COM'=""

               WRITE ?66,COM,!

           QUIT 

A4         WRITE ?31,$EXTRACT($PIECE(X1,"^",1),1,29)

           SET STR=$PIECE(X1,"^",7)

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

 +1        WRITE ?66,$PIECE(X1,"^",8),?101,$PIECE(X1,"^",2),?110,$PIECE(X1,"^",6)

 +2        SET TW=$PIECE(X1,"^",4)

           IF TW

               WRITE ?117,$JUSTIFY($PIECE(X1,"^",3),5),?126,$JUSTIFY(TW,4)

 +3        WRITE !

           QUIT 

HD1       ; Preparation Header

 +1        if '($EXTRACT(IOST,1,2)'="C-"&'PG)

               WRITE @IOF

           SET PG=PG+1

 +2        WRITE !,DTP,?39,"P R E P A R A T I O N   O F   T U B E F E E D I N G S",?125,"Page ",PG

 +3        SET Y=$SELECT(SUM:"CONSOLIDATED",1:$PIECE(TNOD,"~",2))

           if Y'=""

               WRITE !!?(131-$LENGTH(Y)\2),Y

 +4        WRITE !!,?112,"#",?119,"ML",?127,"ML"

 +5        WRITE !,"Patient",?24,"ID#",?31,"Product",?61,"Str",?66,"Quantity",?101,"Unit",?110,"Units",?117,"Product",?126,"Water",!

 +6        QUIT