FHSPTAB ; HISC/REL/NCA - Tabulate Standing Orders ;4/27/93 13:07
;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
;11/10/05 modified to add outpatient standing order.
S FHOPT=3 ;tabulate standing order flag.
S FHP=$O(^FH(119.72,0)) I FHP'<1,$O(^FH(119.72,FHP))<1 S FHP=0 G R1
R0 R !!,"Select SERVICE POINT (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHP=0
E K DIC S DIC="^FH(119.72,",DIC(0)="EMQ" D ^DIC G:Y<1 R0 S FHP=+Y
R1 R !!,"Select Meal (B,N,E or ALL): ",MEAL:DTIME G:'$T!("^"[MEAL) KIL S X=MEAL D TR^FH S MEAL=X S:$P("ALL",MEAL,1)="" MEAL="A"
I "BNEA"'[MEAL!(MEAL'?1U) W *7,!,"Enter B for Breakfast, N for Noon , E for Evening or ALL for all meals" G R1
R3 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHSPTAB",FHLST="FHP^MEAL^FHOPT" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Print the Tabulated List of Standing Orders
D NOW^%DTC S NOW=%,PG=0 I MEAL'="A" G Q2
F MEAL="B","N","E" D Q2
Q
Q2 S T0=(NOW\1)_$S(MEAL="B":".07",MEAL="N":".11",1:".17")
K N F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 D DP I DP'="" F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=^FHPT("AW",W1,FHDFN) D ADD
;get outpatient so.
D ADDO^FHSP1
D HDR S NX="" F K1=0:0 S NX=$O(^FH(118.3,"B",NX)) Q:NX="" F K=0:0 S K=$O(^FH(118.3,"B",NX,K)) Q:K<1 I $D(N(K)) D:$Y>56 HDR W !,$J(N(K),6)," ",$P(^FH(118.3,K,0),"^",1)
W ! Q
ADD Q:ADM<1 D CHK I K2 F K2=0:0 S K2=$O(^FHPT("ASP",FHDFN,ADM,K2)) Q:K2<1 S X=^FHPT(FHDFN,"A",ADM,"SP",K2,0) D A1
Q
A1 S FHORD=$P(X,"^",2),M1=$P(X,"^",3) I FHORD,M1[MEAL S:'$D(N(FHORD)) N(FHORD)=0 S Q=$P(X,"^",8),N(FHORD)=N(FHORD)+$S(Q:Q,1:1)
Q
CHK S K2=0,X1=$G(^FHPT(FHDFN,"A",ADM,0)),FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1
I X1>1,X1'>T0 G C2
C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2
S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",8) I X1="" G C1
S:X1="D" X1="T" S:DP[X1 K2=1
C1 K FHORD,A1,K,X1 Q
C2 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>T0) S A1=K
G:'A1 C1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G:FHORD'<1 C0 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G C2
DP S DP="" I 'FHP S DP="TC" Q
S X=$P($G(^FH(119.6,W1,0)),"^",5,6) S:$P(X,"^",1)=FHP DP="T" S:$P(X,"^",2)=FHP DP=DP_"C" Q
HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=NOW D DTP^FH W !,DTP,?25,"S T A N D I N G O R D E R S",?74,"Page ",PG
W !! W:FHP $P(^FH(119.72,FHP,0),"^",1) S Y=$S(MEAL="B":"BREAKFAST",MEAL="N":"NOON",1:"EVENING") W ?(80-$L(Y)\2),Y
W !!,"Quantity Order",! Q
KIL G KILL^XUSCLEAN
FHSPTAB ; HISC/REL/NCA - Tabulate Standing Orders ;4/27/93 13:07
+1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
+2 ;11/10/05 modified to add outpatient standing order.
+3 ;tabulate standing order flag.
SET FHOPT=3
+4 SET FHP=$ORDER(^FH(119.72,0))
IF FHP'<1
IF $ORDER(^FH(119.72,FHP))<1
SET FHP=0
GOTO R1
R0 READ !!,"Select SERVICE POINT (or ALL): ",X:DTIME
IF '$TEST!("^"[X)
GOTO KIL
IF X="all"
DO TR^FH
IF X="ALL"
SET FHP=0
+1 IF '$TEST
KILL DIC
SET DIC="^FH(119.72,"
SET DIC(0)="EMQ"
DO ^DIC
IF Y<1
GOTO R0
SET FHP=+Y
R1 READ !!,"Select Meal (B,N,E or ALL): ",MEAL:DTIME
IF '$TEST!("^"[MEAL)
GOTO KIL
SET X=MEAL
DO TR^FH
SET MEAL=X
IF $PIECE("ALL",MEAL,1)=""
SET MEAL="A"
+1 IF "BNEA"'[MEAL!(MEAL'?1U)
WRITE *7,!,"Enter B for Breakfast, N for Noon , E for Evening or ALL for all meals"
GOTO R1
R3 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
IF POP
GOTO KIL
+1 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHSPTAB"
SET FHLST="FHP^MEAL^FHOPT"
DO EN2^FH
GOTO KIL
+2 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Print the Tabulated List of Standing Orders
+1 DO NOW^%DTC
SET NOW=%
SET PG=0
IF MEAL'="A"
GOTO Q2
+2 FOR MEAL="B","N","E"
DO Q2
+3 QUIT
Q2 SET T0=(NOW\1)_$SELECT(MEAL="B":".07",MEAL="N":".11",1:".17")
+1 KILL N
FOR W1=0:0
SET W1=$ORDER(^FH(119.6,W1))
IF W1<1
QUIT
DO DP
IF DP'=""
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
IF FHDFN<1
QUIT
SET ADM=^FHPT("AW",W1,FHDFN)
DO ADD
+2 ;get outpatient so.
+3 DO ADDO^FHSP1
+4 DO HDR
SET NX=""
FOR K1=0:0
SET NX=$ORDER(^FH(118.3,"B",NX))
IF NX=""
QUIT
FOR K=0:0
SET K=$ORDER(^FH(118.3,"B",NX,K))
IF K<1
QUIT
IF $DATA(N(K))
IF $Y>56
DO HDR
WRITE !,$JUSTIFY(N(K),6)," ",$PIECE(^FH(118.3,K,0),"^",1)
+5 WRITE !
QUIT
ADD IF ADM<1
QUIT
DO CHK
IF K2
FOR K2=0:0
SET K2=$ORDER(^FHPT("ASP",FHDFN,ADM,K2))
IF K2<1
QUIT
SET X=^FHPT(FHDFN,"A",ADM,"SP",K2,0)
DO A1
+1 QUIT
A1 SET FHORD=$PIECE(X,"^",2)
SET M1=$PIECE(X,"^",3)
IF FHORD
IF M1[MEAL
IF '$DATA(N(FHORD))
SET N(FHORD)=0
SET Q=$PIECE(X,"^",8)
SET N(FHORD)=N(FHORD)+$SELECT(Q:Q,1:1)
+1 QUIT
CHK SET K2=0
SET X1=$GET(^FHPT(FHDFN,"A",ADM,0))
SET FHORD=$PIECE(X1,"^",2)
SET X1=$PIECE(X1,"^",3)
IF FHORD<1
GOTO C1
+1 IF X1>1
IF X1'>T0
GOTO C2
C0 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
GOTO C2
+1 SET X1=$PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",8)
IF X1=""
GOTO C1
+2 IF X1="D"
SET X1="T"
IF DP[X1
SET K2=1
C1 KILL FHORD,A1,K,X1
QUIT
C2 SET A1=0
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K))
IF K<1!(K>T0)
QUIT
SET A1=K
+1 IF 'A1
GOTO C1
SET FHORD=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2)
IF FHORD'<1
GOTO C0
KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
GOTO C2
DP SET DP=""
IF 'FHP
SET DP="TC"
QUIT
+1 SET X=$PIECE($GET(^FH(119.6,W1,0)),"^",5,6)
IF $PIECE(X,"^",1)=FHP
SET DP="T"
IF $PIECE(X,"^",2)=FHP
SET DP=DP_"C"
QUIT
HDR IF '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
SET DTP=NOW
DO DTP^FH
WRITE !,DTP,?25,"S T A N D I N G O R D E R S",?74,"Page ",PG
+1 WRITE !!
IF FHP
WRITE $PIECE(^FH(119.72,FHP,0),"^",1)
SET Y=$SELECT(MEAL="B":"BREAKFAST",MEAL="N":"NOON",1:"EVENING")
WRITE ?(80-$LENGTH(Y)\2),Y
+2 WRITE !!,"Quantity Order",!
QUIT
KIL GOTO KILL^XUSCLEAN
