FHNO4 ; HISC/REL - Bulk Nourishments ;4/25/93 19:01
;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Enter/Edit Bulk Nourishments
D WRD G:'WRD KIL S DA=WRD,DR="20" D ^DIE G EN1
EN2 ; List Bulk Nourishments
D WRD G:'WRD KIL S CT=0 W !
F K=0:0 S K=$O(^FH(119.6,WRD,"BN",K)) Q:K<1 S X=^(K,0),X1=$P(X,"^",1),X2=$P(X,"^",2) I X1,$D(^FH(118,X1,0)) W !,$J(X2,6)," ",$P(^(0),"^",1) S CT=CT+1
I 'CT W !,"No Bulk Nourishment Order entered for this Ward."
G EN2
WRD K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQM",WRD=0
S DIC("DR")=".01" W ! D ^DIC Q:U[X!$D(DTOUT) G:Y<1 WRD S WRD=+Y Q
KIL G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHNO4 602 printed Dec 13, 2024@01:52:20 Page 2
FHNO4 ; HISC/REL - Bulk Nourishments ;4/25/93 19:01
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Enter/Edit Bulk Nourishments
+1 DO WRD
if 'WRD
GOTO KIL
SET DA=WRD
SET DR="20"
DO ^DIE
GOTO EN1
EN2 ; List Bulk Nourishments
+1 DO WRD
if 'WRD
GOTO KIL
SET CT=0
WRITE !
+2 FOR K=0:0
SET K=$ORDER(^FH(119.6,WRD,"BN",K))
if K<1
QUIT
SET X=^(K,0)
SET X1=$PIECE(X,"^",1)
SET X2=$PIECE(X,"^",2)
IF X1
IF $DATA(^FH(118,X1,0))
WRITE !,$JUSTIFY(X2,6)," ",$PIECE(^(0),"^",1)
SET CT=CT+1
+3 IF 'CT
WRITE !,"No Bulk Nourishment Order entered for this Ward."
+4 GOTO EN2
WRD KILL DIC
SET (DIC,DIE)="^FH(119.6,"
SET DIC(0)="AEQM"
SET WRD=0
+1 SET DIC("DR")=".01"
WRITE !
DO ^DIC
if U[X!$DATA(DTOUT)
QUIT
if Y<1
GOTO WRD
SET WRD=+Y
QUIT
KIL GOTO KILL^XUSCLEAN
