- 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
