- FHSP1 ; HISC/NCA - Consolidated Standing Orders List ;7/28/94 12:59
- ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
- ;11/09/05 - modified for SO patch
- ;if FHOPT=1, it's consolidated
- ;if FHOPT=2,it's print labels
- ;if FHOPT=3, it's tabulated
- E1 ; Set Consolidated List flag
- S FHOPT=1 G E3
- E2 ; Set Print Label flag
- S FHOPT=2
- E3 S FHP=$O(^FH(119.72,0)) I FHP'<1,$O(^FH(119.72,FHP))<1 G D2
- D0 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 D0 S FHP=+Y
- D2 R !!,"Select Meal (B,N,E,or ALL): ",MEAL:DTIME G:'$T!(U[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 D2
- S D3="" G:FHOPT=2 D5
- D3 R !!,"Consolidated List Only? Y//",X:DTIME G:'$T!(X="^") KIL S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G D3
- S X=$E(X,1),D3=1 S:X="Y" D3=D3+1
- D5 W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If using laser label sheets, what row do you want to begin printing at? ",DIR("B")=1 D ^DIR
- Q:$D(DIRUT) S LABSTART=Y
- W:'D3 !!,"Place Labels in Printer"
- PR K IOP S %ZIS="MQ",%ZIS("A")="Select "_$S('D3:"LABEL",1:"LIST")_" Printer: " W ! D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) S FHPGM="Q1^FHSP1",FHLST="D3^FHOPT^FHP^MEAL^LABSTART" D EN2^FH G KIL
- U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
- Q1 ; Print Standing Orders List or Labels
- K ^TMP($J),C,D,N S (CHK,N1,PG)=0 D NOW^%DTC S NOW=%,DT=%\1
- S COUNT=0,LINE=1,DTP=NOW D DTP^FH S DTR=DTP
- I FHOPT=2 S LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1
- S FHMLSAV=MEAL
- I MEAL="A" S MEAL="B" D Q2 S MEAL="N" D Q2 S MEAL="E"
- D Q2
- I $G(LAB)>2 D DPLL^FHLABEL Q
- F L=1:1:$S('D3:18,1:1) W !
- Q
- Q2 S T0=NOW\1_$S(MEAL="B":".07",MEAL="N":".11",1:".17"),TT=0
- F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 D DP I DP'="" D P0 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=^FHPT("AW",W1,FHDFN) D ADD
- ;check and include outpatient stnading orders.
- D ADDO
- ;
- G:FHOPT=2 ^FHSP11
- S DTP=DT D DTP^FH S DTE=DTP_" "_$S(MEAL="B":"Break",MEAL="N":"Noon",1:"Even")
- G:D3=2 CON
- K S F K=0:0 S K=$O(D(K)) Q:K="" S X=$G(^FH(119.72,K,0)),N2=$P(X,"^",1),N3=$P(X,"^",4) S:N3="" N3=$E(N2,1,6) S S(N3,K)=$E(N3,1,6)
- S A1="" F S A1=$O(S(A1)) Q:A1="" F K=0:0 S K=$O(S(A1,K)) Q:K="" S N2=$G(S(A1,K)) D LST
- K C,D,N 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 Y=^FHPT(FHDFN,"A",ADM,"SP",K2,0) D A1
- Q
- ;
- A1 D PATNAME^FHOMUTL I DFN="" Q
- S Y=$P(Y,"^",2,3)_"^"_$P(Y,"^",8) Q:Y?."^" I FHOPT=2 S Y=Y_"^"_IS,RM=$G(^DPT(DFN,.101)),WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM,^TMP($J,"SOL",SP,WRD,FHDFN,K2)=Y Q
- S FHORD=$P(Y,"^",1),M1=$P(Y,"^",2)
- I FHORD,M1[MEAL S:'$D(N(FHORD,SP)) N(FHORD,SP)=0 S Q=$P(Y,"^",3),N(FHORD,SP)=N(FHORD,SP)+$S(Q:Q,1:1) S:'$D(C(MEAL,SP)) C(MEAL,SP)=0 I TT'=FHDFN S C(MEAL,SP)=C(MEAL,SP)+1,TT=FHDFN
- Q
- CHK S K2=0,X1=$G(^FHPT(FHDFN,"A",ADM,0)),FHORD=$P(X1,"^",2),IS=$P(X1,"^",10),X1=$P(X1,"^",3) G:FHORD<1 C1
- I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS=""
- 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" Q:'$D(S(X1)) S:DP[X1 K2=1 S:K2 SP=S(X1)
- 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 K S S DP=""
- F L=5,6 S X=$P($G(^FH(119.6,W1,0)),"^",L) I X=FHP!('FHP) S:X S($E("TC",L-4))=X,D(X)="",DP=DP_$E("TC",L-4)
- Q
- P0 S X=^FH(119.6,W1,0),P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0),WRDN=$P(X,"^",1) Q
- ;
- LST D HDR1 S NX="" F S NX=$O(^FH(118.3,"B",NX)) Q:NX="" F KK=0:0 S KK=$O(^FH(118.3,"B",NX,KK)) Q:KK<1 S Z=$G(N(KK,K)) D:$Y>(IOSL-6) HDR1 I Z W !?(80-30\2),$J(Z,6)," ",$P(^FH(118.3,KK,0),"^",1)
- S N1=N1+$G(C(MEAL,K))
- D PP S N1=0 Q
- CON K S S L1=36
- F K=0:0 S K=$O(D(K)) Q:K="" S X=^FH(119.72,K,0),N2=$P(X,"^",1),N3=$P(X,"^",4) S:N3="" N3=$E(N2,1,6) S S(N3,K)=$J(N3,8),L1=L1+8
- S:L1<80 L1=80 D HDR
- S NX="" F S NX=$O(^FH(118.3,"B",NX)) Q:NX="" F KK=0:0 S KK=$O(^FH(118.3,"B",NX,KK)) Q:KK<1 I $D(N(KK)) D SOR
- W !!,"# OF PATIENTS",?31
- S X="" F S X=$O(S(X)) Q:X="" F K=0:0 S K=$O(S(X,K)) Q:K="" S Z=$G(C(MEAL,K)) W $S(Z:$J(Z,6),1:$J("",6))," " S N1=N1+Z
- W $S(N1:$J(N1,6),1:$J("",6))
- S N1=0 K C,D,N Q
- SOR D:$Y>(IOSL-6) HDR
- W !,$P($G(^FH(118.3,KK,0)),"^",1),?31
- S Z1=0,X="" F S X=$O(S(X)) Q:X="" F K=0:0 S K=$O(S(X,K)) Q:K="" S Z=$G(N(KK,K)) W $S(Z:$J(Z,6),1:$J("",6))," " S Z1=Z1+Z
- W $S(Z1:$J(Z1,6),1:$J("",6))
- Q
- PP W !!?(80-21\2),"**** PATIENTS = ",N1," ****",! Q
- HDR ; Header for Consolidated List
- W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
- W !,DTR,?(L1-11),"Page ",PG,!!?(L1-55\2),"C O N S O L I D A T E D S T A N D I N G O R D E R S",!!?(L1-$L(DTE)\2),DTE,!!?29
- S X="" F S X=$O(S(X)) Q:X="" F K=0:0 S K=$O(S(X,K)) Q:K="" W S(X,K)
- W " TOTAL",! Q
- HDR1 ; Header for Standing Order List
- W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !,DTR,?69,"Page ",PG,!!?20,"S T A N D I N G O R D E R S L I S T"
- W !?(80-$L(N2)\2),N2,!?(80-$L(DTE)\2),DTE,! Q
- ;
- ADDO ;process outpatient STANDING ORDER for consolidated, print labels and tabulated reports.
- S IS=""
- F FHI=0:0 S FHI=$O(^FHPT("ASPO",FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(^FHPT("ASPO",FHI,FHJ)) Q:FHJ'>0 D
- .S FHOPDAT=^FHPT(FHI,"OP",FHJ,0)
- .S FHDATE=$P(FHOPDAT,U,1)
- .Q:$P(FHOPDAT,U,15)="C"
- .Q:FHDATE'=DT
- .S RM="",RMIEN=$P(FHOPDAT,U,18) I $G(RMIEN),$D(^DG(405.4,RMIEN,0)) S RM=$E($P(^DG(405.4,RMIEN,0),U,1),1,10)
- .S FHLOC=$P(FHOPDAT,U,3)
- .F K2=0:0 S K2=$O(^FHPT("ASPO",FHI,FHJ,K2)) Q:K2'>0 D
- ..S Y=^FHPT(FHI,"OP",FHJ,"SP",K2,0),(SP,WRD)="***"
- ..Q:$P(Y,U,6) ;quit if cancelled.
- ..S (FHLODAT,FHSER1,FHSER2,FHSERV,FHSRFLG,WRDN,P0)=""
- ..I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHLODAT=^FH(119.6,FHLOC,0)
- ..I FHLODAT'="" S WRDN=$P(FHLODAT,U,1),FHSER1=$P(FHLODAT,U,5),FHSER2=$P(FHLODAT,U,6),P0=$P(FHLODAT,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
- ..I $G(FHSER1) S SP=FHSER1
- ..I SP="***",$G(FHSER2) S SP=FHSER2
- ..I $G(FHP),$G(FHSER1),FHP=FHSER1 S FHSRFLG=1
- ..I $G(FHP),$G(FHSER2),FHP=FHSER2 S FHSRFLG=1
- ..I $G(FHP),'$G(FHSRFLG) Q
- ..S FHMLOUT=$P(FHOPDAT,U,4)
- ..I MEAL'=FHMLOUT Q
- ..S FHDFN=FHI,ADM=FHJ
- ..S Y=$P(Y,"^",2,3)_"^"_$P(Y,"^",8) Q:Y?."^"
- ..I FHOPT=2 S Y=Y_"^"_IS,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM,^TMP($J,"SOL",SP,WRD,FHDFN,K2)=Y Q
- ..S FHORD=$P(Y,"^",1),M1=$P(Y,"^",2)
- ..I FHOPT=1,FHORD,M1[MEAL S:'$D(N(FHORD,SP)) N(FHORD,SP)=0 S Q=$P(Y,"^",3),N(FHORD,SP)=N(FHORD,SP)+$S(Q:Q,1:1) S:'$D(C(MEAL,SP)) C(MEAL,SP)=0 I TT'=FHDFN S C(MEAL,SP)=C(MEAL,SP)+1,TT=FHDFN
- ..I FHOPT=3,FHORD,M1[MEAL S:'$D(N(FHORD)) N(FHORD)=0 S Q=$P(Y,"^",3),N(FHORD)=N(FHORD)+$S(Q:Q,1:1)
- Q
- ;
- KIL K ^TMP($J) G KILL^XUSCLEAN
- ;
- EVNT Q:FHCNSOF=0 S:'$D(FHDTP) FHDTP=""
- I $D(FHDT1) S DTP=FHDT1 D DTP^FH S FHDTP=DTP
- I $D(FHDT2) S DTP=FHDT2 D DTP^FH S:FHDTP'=DTP FHDTP=FHDTP_" to "_DTP
- S FHACT="O",FHTXT="Outpatient Standing Order: "_NUM_" "_$P($G(^FH(118.3,SP,0)),U,1)_" ("_FHALML_"), "_FHLOCN_", "_FHDTP D OPFILE^FHORX
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHSP1 7250 printed Jan 18, 2025@02:56:19 Page 2
- FHSP1 ; HISC/NCA - Consolidated Standing Orders List ;7/28/94 12:59
- +1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
- +2 ;11/09/05 - modified for SO patch
- +3 ;if FHOPT=1, it's consolidated
- +4 ;if FHOPT=2,it's print labels
- +5 ;if FHOPT=3, it's tabulated
- E1 ; Set Consolidated List flag
- +1 SET FHOPT=1
- GOTO E3
- E2 ; Set Print Label flag
- +1 SET FHOPT=2
- E3 SET FHP=$ORDER(^FH(119.72,0))
- IF FHP'<1
- IF $ORDER(^FH(119.72,FHP))<1
- GOTO D2
- D0 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 D0
- SET FHP=+Y
- D2 READ !!,"Select Meal (B,N,E,or ALL): ",MEAL:DTIME
- if '$TEST!(U[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 D2
- +2 SET D3=""
- if FHOPT=2
- GOTO D5
- D3 READ !!,"Consolidated List Only? Y//",X:DTIME
- if '$TEST!(X="^")
- GOTO KIL
- if X=""
- SET X="Y"
- DO TR^FH
- IF $PIECE("YES",X,1)'=""
- IF $PIECE("NO",X,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO D3
- +1 SET X=$EXTRACT(X,1)
- SET D3=1
- if X="Y"
- SET D3=D3+1
- D5 WRITE !
- KILL DIR,LABSTART
- SET DIR(0)="NA^1:10"
- SET DIR("A")="If using laser label sheets, what row do you want to begin printing at? "
- SET DIR("B")=1
- DO ^DIR
- +1 if $DATA(DIRUT)
- QUIT
- SET LABSTART=Y
- +2 if 'D3
- WRITE !!,"Place Labels in Printer"
- PR KILL IOP
- SET %ZIS="MQ"
- SET %ZIS("A")="Select "_$SELECT('D3:"LABEL",1:"LIST")_" Printer: "
- WRITE !
- DO ^%ZIS
- KILL %ZIS,IOP
- if POP
- GOTO KIL
- +1 IF $DATA(IO("Q"))
- SET FHPGM="Q1^FHSP1"
- SET FHLST="D3^FHOPT^FHP^MEAL^LABSTART"
- DO EN2^FH
- GOTO KIL
- +2 USE IO
- DO Q1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- Q1 ; Print Standing Orders List or Labels
- +1 KILL ^TMP($JOB),C,D,N
- SET (CHK,N1,PG)=0
- DO NOW^%DTC
- SET NOW=%
- SET DT=%\1
- +2 SET COUNT=0
- SET LINE=1
- SET DTP=NOW
- DO DTP^FH
- SET DTR=DTP
- +3 IF FHOPT=2
- SET LAB=$PIECE($GET(^FH(119.9,1,"D",IOS,0)),"^",2)
- if 'LAB
- SET LAB=1
- +4 SET FHMLSAV=MEAL
- +5 IF MEAL="A"
- SET MEAL="B"
- DO Q2
- SET MEAL="N"
- DO Q2
- SET MEAL="E"
- +6 DO Q2
- +7 IF $GET(LAB)>2
- DO DPLL^FHLABEL
- QUIT
- +8 FOR L=1:1:$SELECT('D3:18,1:1)
- WRITE !
- +9 QUIT
- Q2 SET T0=NOW\1_$SELECT(MEAL="B":".07",MEAL="N":".11",1:".17")
- SET TT=0
- +1 FOR W1=0:0
- SET W1=$ORDER(^FH(119.6,W1))
- if W1<1
- QUIT
- DO DP
- IF DP'=""
- DO P0
- FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
- if FHDFN<1
- QUIT
- SET ADM=^FHPT("AW",W1,FHDFN)
- DO ADD
- +2 ;check and include outpatient stnading orders.
- +3 DO ADDO
- +4 ;
- +5 if FHOPT=2
- GOTO ^FHSP11
- +6 SET DTP=DT
- DO DTP^FH
- SET DTE=DTP_" "_$SELECT(MEAL="B":"Break",MEAL="N":"Noon",1:"Even")
- +7 if D3=2
- GOTO CON
- +8 KILL S
- FOR K=0:0
- SET K=$ORDER(D(K))
- if K=""
- QUIT
- SET X=$GET(^FH(119.72,K,0))
- SET N2=$PIECE(X,"^",1)
- SET N3=$PIECE(X,"^",4)
- if N3=""
- SET N3=$EXTRACT(N2,1,6)
- SET S(N3,K)=$EXTRACT(N3,1,6)
- +9 SET A1=""
- FOR
- SET A1=$ORDER(S(A1))
- if A1=""
- QUIT
- FOR K=0:0
- SET K=$ORDER(S(A1,K))
- if K=""
- QUIT
- SET N2=$GET(S(A1,K))
- DO LST
- +10 KILL C,D,N
- QUIT
- ADD if ADM<1
- QUIT
- +1 DO CHK
- IF K2
- FOR K2=0:0
- SET K2=$ORDER(^FHPT("ASP",FHDFN,ADM,K2))
- if K2<1
- QUIT
- SET Y=^FHPT(FHDFN,"A",ADM,"SP",K2,0)
- DO A1
- +2 QUIT
- +3 ;
- A1 DO PATNAME^FHOMUTL
- IF DFN=""
- QUIT
- +1 SET Y=$PIECE(Y,"^",2,3)_"^"_$PIECE(Y,"^",8)
- if Y?."^"
- QUIT
- IF FHOPT=2
- SET Y=Y_"^"_IS
- SET RM=$GET(^DPT(DFN,.101))
- SET WRD=P0_$EXTRACT(WRDN,1,27-$LENGTH(RM))_"/"_RM
- SET ^TMP($JOB,"SOL",SP,WRD,FHDFN,K2)=Y
- QUIT
- +2 SET FHORD=$PIECE(Y,"^",1)
- SET M1=$PIECE(Y,"^",2)
- +3 IF FHORD
- IF M1[MEAL
- if '$DATA(N(FHORD,SP))
- SET N(FHORD,SP)=0
- SET Q=$PIECE(Y,"^",3)
- SET N(FHORD,SP)=N(FHORD,SP)+$SELECT(Q:Q,1:1)
- if '$DATA(C(MEAL,SP))
- SET C(MEAL,SP)=0
- IF TT'=FHDFN
- SET C(MEAL,SP)=C(MEAL,SP)+1
- SET TT=FHDFN
- +4 QUIT
- CHK SET K2=0
- SET X1=$GET(^FHPT(FHDFN,"A",ADM,0))
- SET FHORD=$PIECE(X1,"^",2)
- SET IS=$PIECE(X1,"^",10)
- SET X1=$PIECE(X1,"^",3)
- if FHORD<1
- GOTO C1
- +1 IF IS
- SET IS=$PIECE($GET(^FH(119.4,IS,0)),"^",3)
- if IS'="N"
- SET IS=""
- +2 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 '$DATA(S(X1))
- QUIT
- if DP[X1
- SET K2=1
- if K2
- SET SP=S(X1)
- 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
- +2 ;
- DP KILL S
- SET DP=""
- +1 FOR L=5,6
- SET X=$PIECE($GET(^FH(119.6,W1,0)),"^",L)
- IF X=FHP!('FHP)
- if X
- SET S($EXTRACT("TC",L-4))=X
- SET D(X)=""
- SET DP=DP_$EXTRACT("TC",L-4)
- +2 QUIT
- P0 SET X=^FH(119.6,W1,0)
- SET P0=$PIECE(X,"^",4)
- SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
- SET WRDN=$PIECE(X,"^",1)
- QUIT
- +1 ;
- LST DO HDR1
- SET NX=""
- FOR
- SET NX=$ORDER(^FH(118.3,"B",NX))
- if NX=""
- QUIT
- FOR KK=0:0
- SET KK=$ORDER(^FH(118.3,"B",NX,KK))
- if KK<1
- QUIT
- SET Z=$GET(N(KK,K))
- if $Y>(IOSL-6)
- DO HDR1
- IF Z
- WRITE !?(80-30\2),$JUSTIFY(Z,6)," ",$PIECE(^FH(118.3,KK,0),"^",1)
- +1 SET N1=N1+$GET(C(MEAL,K))
- +2 DO PP
- SET N1=0
- QUIT
- CON KILL S
- SET L1=36
- +1 FOR K=0:0
- SET K=$ORDER(D(K))
- if K=""
- QUIT
- SET X=^FH(119.72,K,0)
- SET N2=$PIECE(X,"^",1)
- SET N3=$PIECE(X,"^",4)
- if N3=""
- SET N3=$EXTRACT(N2,1,6)
- SET S(N3,K)=$JUSTIFY(N3,8)
- SET L1=L1+8
- +2 if L1<80
- SET L1=80
- DO HDR
- +3 SET NX=""
- FOR
- SET NX=$ORDER(^FH(118.3,"B",NX))
- if NX=""
- QUIT
- FOR KK=0:0
- SET KK=$ORDER(^FH(118.3,"B",NX,KK))
- if KK<1
- QUIT
- IF $DATA(N(KK))
- DO SOR
- +4 WRITE !!,"# OF PATIENTS",?31
- +5 SET X=""
- FOR
- SET X=$ORDER(S(X))
- if X=""
- QUIT
- FOR K=0:0
- SET K=$ORDER(S(X,K))
- if K=""
- QUIT
- SET Z=$GET(C(MEAL,K))
- WRITE $SELECT(Z:$JUSTIFY(Z,6),1:$JUSTIFY("",6))," "
- SET N1=N1+Z
- +6 WRITE $SELECT(N1:$JUSTIFY(N1,6),1:$JUSTIFY("",6))
- +7 SET N1=0
- KILL C,D,N
- QUIT
- SOR if $Y>(IOSL-6)
- DO HDR
- +1 WRITE !,$PIECE($GET(^FH(118.3,KK,0)),"^",1),?31
- +2 SET Z1=0
- SET X=""
- FOR
- SET X=$ORDER(S(X))
- if X=""
- QUIT
- FOR K=0:0
- SET K=$ORDER(S(X,K))
- if K=""
- QUIT
- SET Z=$GET(N(KK,K))
- WRITE $SELECT(Z:$JUSTIFY(Z,6),1:$JUSTIFY("",6))," "
- SET Z1=Z1+Z
- +3 WRITE $SELECT(Z1:$JUSTIFY(Z1,6),1:$JUSTIFY("",6))
- +4 QUIT
- PP WRITE !!?(80-21\2),"**** PATIENTS = ",N1," ****",!
- QUIT
- HDR ; Header for Consolidated List
- +1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- +2 WRITE !,DTR,?(L1-11),"Page ",PG,!!?(L1-55\2),"C O N S O L I D A T E D S T A N D I N G O R D E R S",!!?(L1-$LENGTH(DTE)\2),DTE,!!?29
- +3 SET X=""
- FOR
- SET X=$ORDER(S(X))
- if X=""
- QUIT
- FOR K=0:0
- SET K=$ORDER(S(X,K))
- if K=""
- QUIT
- WRITE S(X,K)
- +4 WRITE " TOTAL",!
- QUIT
- HDR1 ; Header for Standing Order List
- +1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- WRITE !,DTR,?69,"Page ",PG,!!?20,"S T A N D I N G O R D E R S L I S T"
- +2 WRITE !?(80-$LENGTH(N2)\2),N2,!?(80-$LENGTH(DTE)\2),DTE,!
- QUIT
- +3 ;
- ADDO ;process outpatient STANDING ORDER for consolidated, print labels and tabulated reports.
- +1 SET IS=""
- +2 FOR FHI=0:0
- SET FHI=$ORDER(^FHPT("ASPO",FHI))
- if FHI'>0
- QUIT
- FOR FHJ=0:0
- SET FHJ=$ORDER(^FHPT("ASPO",FHI,FHJ))
- if FHJ'>0
- QUIT
- Begin DoDot:1
- +3 SET FHOPDAT=^FHPT(FHI,"OP",FHJ,0)
- +4 SET FHDATE=$PIECE(FHOPDAT,U,1)
- +5 if $PIECE(FHOPDAT,U,15)="C"
- QUIT
- +6 if FHDATE'=DT
- QUIT
- +7 SET RM=""
- SET RMIEN=$PIECE(FHOPDAT,U,18)
- IF $GET(RMIEN)
- IF $DATA(^DG(405.4,RMIEN,0))
- SET RM=$EXTRACT($PIECE(^DG(405.4,RMIEN,0),U,1),1,10)
- +8 SET FHLOC=$PIECE(FHOPDAT,U,3)
- +9 FOR K2=0:0
- SET K2=$ORDER(^FHPT("ASPO",FHI,FHJ,K2))
- if K2'>0
- QUIT
- Begin DoDot:2
- +10 SET Y=^FHPT(FHI,"OP",FHJ,"SP",K2,0)
- SET (SP,WRD)="***"
- +11 ;quit if cancelled.
- if $PIECE(Y,U,6)
- QUIT
- +12 SET (FHLODAT,FHSER1,FHSER2,FHSERV,FHSRFLG,WRDN,P0)=""
- +13 IF $GET(FHLOC)
- IF $DATA(^FH(119.6,FHLOC,0))
- SET FHLODAT=^FH(119.6,FHLOC,0)
- +14 IF FHLODAT'=""
- SET WRDN=$PIECE(FHLODAT,U,1)
- SET FHSER1=$PIECE(FHLODAT,U,5)
- SET FHSER2=$PIECE(FHLODAT,U,6)
- SET P0=$PIECE(FHLODAT,"^",4)
- SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
- +15 IF $GET(FHSER1)
- SET SP=FHSER1
- +16 IF SP="***"
- IF $GET(FHSER2)
- SET SP=FHSER2
- +17 IF $GET(FHP)
- IF $GET(FHSER1)
- IF FHP=FHSER1
- SET FHSRFLG=1
- +18 IF $GET(FHP)
- IF $GET(FHSER2)
- IF FHP=FHSER2
- SET FHSRFLG=1
- +19 IF $GET(FHP)
- IF '$GET(FHSRFLG)
- QUIT
- +20 SET FHMLOUT=$PIECE(FHOPDAT,U,4)
- +21 IF MEAL'=FHMLOUT
- QUIT
- +22 SET FHDFN=FHI
- SET ADM=FHJ
- +23 SET Y=$PIECE(Y,"^",2,3)_"^"_$PIECE(Y,"^",8)
- if Y?."^"
- QUIT
- +24 IF FHOPT=2
- SET Y=Y_"^"_IS
- SET WRD=P0_$EXTRACT(WRDN,1,20-$LENGTH(RM))_"/"_RM
- SET ^TMP($JOB,"SOL",SP,WRD,FHDFN,K2)=Y
- QUIT
- +25 SET FHORD=$PIECE(Y,"^",1)
- SET M1=$PIECE(Y,"^",2)
- +26 IF FHOPT=1
- IF FHORD
- IF M1[MEAL
- if '$DATA(N(FHORD,SP))
- SET N(FHORD,SP)=0
- SET Q=$PIECE(Y,"^",3)
- SET N(FHORD,SP)=N(FHORD,SP)+$SELECT(Q:Q,1:1)
- if '$DATA(C(MEAL,SP))
- SET C(MEAL,SP)=0
- IF TT'=FHDFN
- SET C(MEAL,SP)=C(MEAL,SP)+1
- SET TT=FHDFN
- +27 IF FHOPT=3
- IF FHORD
- IF M1[MEAL
- if '$DATA(N(FHORD))
- SET N(FHORD)=0
- SET Q=$PIECE(Y,"^",3)
- SET N(FHORD)=N(FHORD)+$SELECT(Q:Q,1:1)
- End DoDot:2
- End DoDot:1
- +28 QUIT
- +29 ;
- KIL KILL ^TMP($JOB)
- GOTO KILL^XUSCLEAN
- +1 ;
- EVNT if FHCNSOF=0
- QUIT
- if '$DATA(FHDTP)
- SET FHDTP=""
- +1 IF $DATA(FHDT1)
- SET DTP=FHDT1
- DO DTP^FH
- SET FHDTP=DTP
- +2 IF $DATA(FHDT2)
- SET DTP=FHDT2
- DO DTP^FH
- if FHDTP'=DTP
- SET FHDTP=FHDTP_" to "_DTP
- +3 SET FHACT="O"
- SET FHTXT="Outpatient Standing Order: "_NUM_" "_$PIECE($GET(^FH(118.3,SP,0)),U,1)_" ("_FHALML_"), "_FHLOCN_", "_FHDTP
- DO OPFILE^FHORX
- +4 QUIT