FHSPED ; HISC/REL/NCA - Enter/Cancel Standing Orders ;7/22/94 13:59
;;5.5;DIETETICS;**5,8,17**;Jan 28, 2005;Build 9
EN1 ; Enter Standing Orders for Patient
D NOW^%DTC S NOW=%
ASK K DIC,X,DFN,FHDFN,FHPTNM,Y S ADM="",FHALL=1 D ^FHOMDPA
G:'FHDFN KIL
S WARD="" I $G(DFN)'="" S WARD=$G(^DPT(DFN,.1))
I WARD="" W !!,"** NO CURRENT ADMISSION ON FILE! If this is an Inpatient, please admit the patient first.",! D SO^FHSP G ASK
K ADM
A0 W !!,"Return for OUTPATIENT or 'C' for CURRENT Admission: " R X:DTIME G:X["^" KIL D:X="c" TR^FH
I (X="")&'($D(^FHPT(FHDFN,"OP"))) W !!,"** NO OUTPATIENT DATA ON FILE! Please enter outpatient meals from Recurring Meals Menu [FHOMRMGR]!!" G ASK
I (X="") D SO^FHSP G ASK
I WARD'="",X="C" S ADM=$G(^DPT("CN",WARD,DFN)) G CAD:ADM
S DIC="^FHPT(FHDFN,""A"",",DIC(0)="EQM" D ^DIC G:Y<1 A0 S ADM=+Y
CAD I ADM,$G(^FHPT(FHDFN,"A",ADM,0)) S (SDT,STDT)=$P(^FHPT(FHDFN,"A",ADM,0),U,1),ENDT=DT G E1:SDT
;
E1 W ! S NO=1 D LIS G:'$G(LN) N1
K DIR W ! S DIR(0)="YA",DIR("A")="Edit a Standing Order? ",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT)!$D(DIROUT) EN1 G:Y<1 N1
N0 R !!,"Edit which Order #? ",X:DTIME G:'$T!("^"[X) EN1 I X'?1N.N!(X<1)!(X>LN) W *7," Enter # of Order to Edit" G N0
S SP=$P(LS,",",+X),SP=$P($G(^FHPT(FHDFN,"A",ADM,"SP",+SP,0)),"^",2) I $D(P(+X,SP)) S LN=+X G N1A
W !!,"Standing Order ",$P($G(^FH(118.3,+SP,0)),"^",1)," added" S LN=LN+1,P(LN,SP)="" G N1A
N1 K DIC W ! S DIC="^FH(118.3,",DIC("A")="Enter Standing Order: ",DIC(0)="AEQM"
D ^DIC K DIC,DLAYGO G EN1:"^"[X!$D(DTOUT),N1:Y<1 S SP=+Y
W !!,"Standing Order ",$P($G(^FH(118.3,+SP,0)),"^",1)," added"
S LN=LN+1,P(LN,SP)=""
N1A W !,"Standing Order: ",$P($G(^FH(118.3,+SP,0)),"^",1)_" // " R X:DTIME G KIL:'$T,FHSPED:X="^"
I X="@" D EN3 W " .. Done" G E1
I X'="" W *7,!,"Press Return to take Default or ""@"" to Delete" G N1A
S $P(P(LN,SP),"^",5)=SP
N2 W !,"Select Meal (B,N,E or ALL): ",$S($P(P(LN,SP),"^",3)'="":$P(P(LN,SP),"^",3)_" // ",1:"") R MEAL:DTIME G:'$T!(MEAL="^") KIL
I MEAL="" G:$P(P(LN,SP),"^",3)="" KIL S MEAL=$P(P(LN,SP),"^",3),$P(P(LN,SP),"^",6)=MEAL G N2A
I MEAL="@" S $P(P(LN,SP),"^",3)="" G N2
S X=MEAL D TR^FH S MEAL=X S:$P("ALL",MEAL,1)="" MEAL="BNE" S X=MEAL,MEAL="" S:X["B" MEAL="B" S:X["N" MEAL=MEAL_"N" S:X["E" MEAL=MEAL_"E"
I $L(X)'=$L(MEAL) W *7,!,"Select B for Breakfast, N for Noon, E for Evening or ALL for all meals",!,"Answer may be multiple meals, e.g., BN or NE" G N2
S $P(P(LN,SP),"^",6)=MEAL
N2A W !,"Quantity: ",$S($P(P(LN,SP),"^",4):$P(P(LN,SP),"^",4)_"// ",1:"1// ") R NUM:DTIME S:NUM="" NUM=$S($P(P(LN,SP),"^",4):$P(P(LN,SP),"^",4),1:1) G:'$T!(NUM="^") KIL
I NUM="@" S $P(P(LN,SP),"^",4)="" G N2A
I NUM'?1N!(NUM<1) W !,*7,"Enter a number from 1-9." G N2A
S $P(P(LN,SP),"^",7)=NUM
S C1=$P(P(LN,SP),"^",2,4),C2=$P(P(LN,SP),"^",5,7) G:C1=C2 E1
N3 W !!,"ADD this Order? Y// " R YN:DTIME G:'$T!(YN="^") KIL S:YN="" YN="Y" S X=YN D TR^FH S YN=X I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G N3
G:YN?1"N".E E1
I C1'="^^" S OLD=$P(P(LN,SP),"^",1),$P(^FHPT(FHDFN,"A",ADM,"SP",OLD,0),"^",6,7)=NOW_"^"_DUZ K ^FHPT("ASP",FHDFN,ADM,OLD) S EVT="S^C^"_OLD D ^FHORX
S $P(P(LN,SP),"^",2,4)="^^",$P(P(LN,SP),"^",2,4)=$P(P(LN,SP),"^",5,7),$P(P(LN,SP),"^",5,7)="^^"
ADD ; Add Standing Order
L +^FHPT(FHDFN,"A",ADM,"SP",0):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
I '$D(^FHPT(FHDFN,"A",ADM,"SP",0)) S ^FHPT(FHDFN,"A",ADM,"SP",0)="^115.08^^"
S X=^FHPT(FHDFN,"A",ADM,"SP",0),NO=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_NO_"^"_($P(X,"^",4)+1)
L -^FHPT(FHDFN,"A",ADM,"SP",0) I $D(^FHPT(FHDFN,"A",ADM,"SP",NO)) G ADD
S ^FHPT(FHDFN,"A",ADM,"SP",NO,0)=NO_"^"_SP_"^"_MEAL_"^"_NOW_"^"_DUZ_"^^^"_NUM,^FHPT("ASP",FHDFN,ADM,NO)="",LS=LS_NO_","
S $P(P(LN,SP),"^",1)=NO,EVT="S^O^"_NO D ^FHORX W " .. done" G E1
EN2 ; Standing Order Inquiry
K DIC,X,DFN,FHDFN,FHPTNM S ADM="",FHALL=1 D ^FHOMDPA
;S ALL=0 D ^FHDPA G:'DFN KIL G:'FHDFN KIL S NO=0 D LIS G EN2
S (FHSOFG,WARD)="" I $G(DFN)'="" S WARD=$G(^DPT(DFN,.1))
G:'FHDFN KIL S NO=0 D:$G(DFN) LIS
I $D(^FHPT("ASPO",FHDFN)) D OUT
G EN2
EN3 ; Cancel Standing Order
S NO=$P($G(P(LN,SP)),"^",1) Q:'NO
S $P(^FHPT(FHDFN,"A",ADM,"SP",NO,0),"^",6,7)=NOW_"^"_DUZ
S X=^FHPT(FHDFN,"A",ADM,"SP",NO,0),SP=$P(X,"^",2),MEAL=$P(X,"^",3),NUM=""
K ^FHPT("ASP",FHDFN,ADM,NO),P(LN,SP) S EVT="S^C^"_NO D ^FHORX Q
LIS ;list SO
Q:WARD=""
S NAM=$P(^DPT(DFN,0),"^",1) D CUR^FHORD7
W !!,NAM," " W:WARD'="" "( ",WARD," )"
W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
D ALG^FHCLN W !," Allergies: ",$S(ALG="":"None on file",1:ALG)
K N,P S CTR=0
F K=0:0 S K=$O(^FHPT("ASP",FHDFN,ADM,K)) Q:K<1 S X=^FHPT(FHDFN,"A",ADM,"SP",K,0),M=$P(X,"^",3),M=$S(M="BNE":"A",1:$E(M,1)),N(M,K)=$P(X,"^",2,3)_"^"_$P(X,"^",8,9)
S FHSOFG=1
S LN=0,LS="" I $O(N(""))="" W !!,"No Active Inpatient Standing Orders." Q
W !!,"Active Inpatient Standing Orders: ",!
F M="A","B","N","E" D
.F K=0:0 S K=$O(N(M,K)) Q:K<1 S Z=+N(M,K) I Z D
..S LN=LN+1,LS=LS_K_"," D L1 W ! W:NO $J(LN,2)
..S NUM=$P(N(M,K),"^",3)
..W ?5,M2,?18,$S(NUM:NUM,1:1)," ",$P(^FH(118.3,Z,0),"^",1)_$S($P(N(M,K),"^",4)'="Y":" (I)",1:"") I $G(^FH(118.3,Z,"I"))="Y" W " (** INACTIVE **)"
..S P(LN,+Z)=K_"^"_$P(N(M,K),"^",1,3) Q
.Q
Q
L1 ; Store Standing Order By Meal
S M1=$P(N(M,K),"^",2) I M1="BNE" S M2="All Meals" Q
S L=$E(M1,1),M2=$S(L="B":"Break",L="N":"Noon",1:"Even")
S L=$E(M1,2) Q:L="" S M2=M2_","_$S(L="B":"Break",L="N":"Noon",1:"Even") Q
OUT ;ask for Recurring Meal Entry
W @IOF
W "Outpatient Recurring Meals..."
K FHDM14,FHEDI,FHEDIF,FHIEN,FHMIEN,FHFLG
S FHQ=0
S (FHTOTML("B"),FHTOTML("N"),FHTOTML("E"),FHTOTML("A"))=0
F FHI=DT-1:0 S FHI=$O(^FHPT("RM",FHI)) Q:FHI'>0!FHQ F FHJ=0:0 S FHJ=$O(^FHPT("RM",FHI,FHDFN,FHJ)) Q:FHJ'>0!FHQ I ($P($G(^FHPT(FHDFN,"OP",FHJ,0)),U,15)'="C") D
.S FHDA15=$G(^FHPT(FHDFN,"OP",FHJ,0))
.S FHDM14(FHI,$P(FHDA15,U,4))=FHI_U_FHJ
.;
.S FHMEAL=$P(FHDA15,U,4),FHLOC=$P(FHDA15,U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHMEAL="B":"Break",FHMEAL="N":"Noon",1:"Even"),FH11=FHMEAL_" "_FHLOCN
.S Y=$P(FHDA15,U,1) X ^DD("DD") S DTP=Y
.S (FHCOFLG,FHDATL)=0
.I $Y>(IOSL-5) K DIR S DIR(0)="E",DIR("A")="Enter RETURN to Continue or '^' to Quit Listing" D ^DIR W:Y @IOF I 'Y S FHQ=1 Q
.W !,DTP,?12,FH11,":"
.S FHDATL=$L(DTP)+13+$L(FH11)
.F FHSF=0:0 S FHSF=$O(^FHPT(FHDFN,"OP",FHJ,"SP",FHSF)) Q:FHSF'>0 D
..S FHDA15SF=$G(^FHPT(FHDFN,"OP",FHJ,"SP",FHSF,0))
..Q:$P(FHDA15SF,U,6)
..S FHDASFNM=$P($G(^FH(118.3,$P(FHDA15SF,U,2),0)),U,1),FHDASFQT=$P(FHDA15SF,U,8)
..I (FHDATL+$L(FHDASFNM)+3+$L(FHDASFQT))>79 W !,?19 S FHDATL=19
..I (FHDATL>19),(FHCOFLG=1) W ","
..S FHDATL=FHDATL+4+$L(FHDASFNM)+3+$L(FHDASFQT)
..W " ",FHDASFNM," = ",FHDASFQT
I '$D(FHDM14) W !!,"NO OUTPATIENT DATA ON FILE for today's date and the future!!",! Q
W !
;
K DIC S DIC(0)="AEQM"
S DIC("W")="S FHMEAL=$P(^(0),U,4),FHLOC=$P(^(0),U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHMEAL=""B"":""Break"",FHMEAL=""N"":""Noon"",1:""Even""),FH11=FHMEAL_"" ""_FHLOCN D EN^DDIOL(FH11,"""",""?3"")"
S DIC("S")="I $P(^FHPT(FHDFN,""OP"",+Y,0),U,1)>(DT-1),($P(^(0),U,15)'=""C"")"
S DIC="^FHPT(FHDFN,""OP"","
S DIC("?")="Select a Date, '^' to exit"
S DIC("A")="Select the Outpatient Date :" D ^DIC K DIC Q:(Y'>0)!$D(DTOUT)
S ADM=+Y
D LIS^FHSP
Q
CHK ;ENTER DATES.
K FHDT1,FHDT2
S FHFLG=0
F1 ;START DATE
K DIC S DIC(0)="AEQM"
W !
S DIC("W")="S FHML=$P(^(0),U,4),FHLOC=$P(^(0),U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHML=""B"":""Break"",FHML=""N"":""Noon"",1:""Even""),FH11=FHMEAL_"" ""_FHLOCN D EN^DDIOL(FH11,"""",""?3"")"
S DIC("S")="S FHML=$P(^(0),U,4),FHDT1=$P(^(0),U,1) I $P(^(0),U,1)>(DT-1),($P(^(0),U,15)'=""C""),FHML=FHDTML"
S DIC="^FHPT(FHDFN,""OP"","
S DIC("?")="Enter a Date, '^' to exit"
S DIC("A")="Enter a Start Date :" D ^DIC K DIC Q:(Y'>0)!$D(DTOUT)
S FHDT1=$P(^FHPT(FHDFN,"OP",+Y,0),U,1)
F2 ;END DATE
K DIC S DIC(0)="AEQM"
W !
S DIC("W")="S FHML=$P(^(0),U,4),FHLOC=$P(^(0),U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHML=""B"":""Break"",FHML=""N"":""Noon"",1:""Even""),FH11=FHMEAL_"" ""_FHLOCN D EN^DDIOL(FH11,"""",""?3"")"
S DIC("S")="S FHML=$P(^(0),U,4),FHDT2=$P(^(0),U,1) I $P(^(0),U,1)>(FHDT1-1),($P(^(0),U,15)'=""C""),FHML=FHDTML"
S DIC="^FHPT(FHDFN,""OP"","
S DIC("?")="Enter a Date, '^' to exit"
S DIC("A")="Enter an End Date :" D ^DIC K DIC Q:(Y'>0)!$D(DTOUT)
S FHDT2=$P(^FHPT(FHDFN,"OP",+Y,0),U,1)
I FHDT2<FHDT1 W !!,"***End Date must be on or after Start Date!!!" G F2
S FHFLG=1
Q
CPRSO ;check previous SO
K FHSOO,FHCK
S (FHDAT,FHSO)=""
CPRS1 I FHSO="" S FHSO=$O(^FHPT("ASPO",FHDFN,""),-1)
E S FHSO=$O(^FHPT("ASPO",FHDFN,FHSO),-1)
Q:'$G(FHSO)
S FHDAT=$G(^FHPT(FHDFN,"OP",FHSO,0)),FHPRML=$P(FHDAT,U,4),FHPRCN=$P(FHDAT,U,15)
I (FHPRML'=FHMEAL)!(FHPRCN="C") G CPRS1
S FHCK(FHPRML)=""
F FHI=0:0 S FHI=$O(^FHPT(FHDFN,"OP",FHSO,"SP",FHI)) Q:FHI'>0 D
.S FHSODAT=$G(^FHPT(FHDFN,"OP",FHSO,"SP",FHI,0)),FHSOI=$P(FHSODAT,U,2),FHSOCN=$P(FHSODAT,U,6),FHSOQ=$P(FHSODAT,U,8)
.Q:$P(FHSODAT,U,9)="Y"
.I '$G(FHSOI)!$G(FHSOCN) Q
.S FHSOO(FHI,FHSOI)=FHSOQ,P(1,FHSOI)=""
Q
PPRSO ;PROCESS previous SO
Q:'$D(FHSOO)
S (LS,LN)=1
D NOW^%DTC S NOW=%
F FHI=0:0 S FHI=$O(FHSOO(FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(FHSOO(FHI,FHJ)) Q:FHJ'>0 S NUM=FHSOO(FHI,FHJ),SP=FHJ D AD1^FHSP
Q
SOEVNT S FHDTC=0
S FHLOCN="" I $D(FHLOC),$G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHLOCN=$P(^(0),U,1)
S FHDTC=FHDTC+1,DTP=FHOSTDT D DTP^FH S:FHDTC=1 FHDTP=DTP
S DTP=$P(ENDT,".",1) D DTP^FH
I DTP'=FHDTP S FHDTP=FHDTP_" to "_DTP
S FHALML=FHMEAL
F FHI=0:0 S FHI=$O(FHSOO(FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(FHSOO(FHI,FHJ)) Q:FHJ'>0 S NUM=FHSOO(FHI,FHJ),SP=FHJ D EVNT^FHSP1
Q
KIL G KILL^XUSCLEAN
FHSPED ; HISC/REL/NCA - Enter/Cancel Standing Orders ;7/22/94 13:59
+1 ;;5.5;DIETETICS;**5,8,17**;Jan 28, 2005;Build 9
EN1 ; Enter Standing Orders for Patient
+1 DO NOW^%DTC
SET NOW=%
ASK KILL DIC,X,DFN,FHDFN,FHPTNM,Y
SET ADM=""
SET FHALL=1
DO ^FHOMDPA
+1 IF 'FHDFN
GOTO KIL
+2 SET WARD=""
IF $GET(DFN)'=""
SET WARD=$GET(^DPT(DFN,.1))
+3 IF WARD=""
WRITE !!,"** NO CURRENT ADMISSION ON FILE! If this is an Inpatient, please admit the patient first.",!
DO SO^FHSP
GOTO ASK
+4 KILL ADM
A0 WRITE !!,"Return for OUTPATIENT or 'C' for CURRENT Admission: "
READ X:DTIME
IF X["^"
GOTO KIL
IF X="c"
DO TR^FH
+1 IF (X="")&'($DATA(^FHPT(FHDFN,"OP")))
WRITE !!,"** NO OUTPATIENT DATA ON FILE! Please enter outpatient meals from Recurring Meals Menu [FHOMRMGR]!!"
GOTO ASK
+2 IF (X="")
DO SO^FHSP
GOTO ASK
+3 IF WARD'=""
IF X="C"
SET ADM=$GET(^DPT("CN",WARD,DFN))
IF ADM
GOTO CAD
+4 SET DIC="^FHPT(FHDFN,""A"","
SET DIC(0)="EQM"
DO ^DIC
IF Y<1
GOTO A0
SET ADM=+Y
CAD IF ADM
IF $GET(^FHPT(FHDFN,"A",ADM,0))
SET (SDT,STDT)=$PIECE(^FHPT(FHDFN,"A",ADM,0),U,1)
SET ENDT=DT
IF SDT
GOTO E1
+1 ;
E1 WRITE !
SET NO=1
DO LIS
IF '$GET(LN)
GOTO N1
+1 KILL DIR
WRITE !
SET DIR(0)="YA"
SET DIR("A")="Edit a Standing Order? "
SET DIR("B")="YES"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO EN1
IF Y<1
GOTO N1
N0 READ !!,"Edit which Order #? ",X:DTIME
IF '$TEST!("^"[X)
GOTO EN1
IF X'?1N.N!(X<1)!(X>LN)
WRITE *7," Enter # of Order to Edit"
GOTO N0
+1 SET SP=$PIECE(LS,",",+X)
SET SP=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"SP",+SP,0)),"^",2)
IF $DATA(P(+X,SP))
SET LN=+X
GOTO N1A
+2 WRITE !!,"Standing Order ",$PIECE($GET(^FH(118.3,+SP,0)),"^",1)," added"
SET LN=LN+1
SET P(LN,SP)=""
GOTO N1A
N1 KILL DIC
WRITE !
SET DIC="^FH(118.3,"
SET DIC("A")="Enter Standing Order: "
SET DIC(0)="AEQM"
+1 DO ^DIC
KILL DIC,DLAYGO
IF "^"[X!$DATA(DTOUT)
GOTO EN1
IF Y<1
GOTO N1
SET SP=+Y
+2 WRITE !!,"Standing Order ",$PIECE($GET(^FH(118.3,+SP,0)),"^",1)," added"
+3 SET LN=LN+1
SET P(LN,SP)=""
N1A WRITE !,"Standing Order: ",$PIECE($GET(^FH(118.3,+SP,0)),"^",1)_" // "
READ X:DTIME
IF '$TEST
GOTO KIL
IF X="^"
GOTO FHSPED
+1 IF X="@"
DO EN3
WRITE " .. Done"
GOTO E1
+2 IF X'=""
WRITE *7,!,"Press Return to take Default or ""@"" to Delete"
GOTO N1A
+3 SET $PIECE(P(LN,SP),"^",5)=SP
N2 WRITE !,"Select Meal (B,N,E or ALL): ",$SELECT($PIECE(P(LN,SP),"^",3)'="":$PIECE(P(LN,SP),"^",3)_" // ",1:"")
READ MEAL:DTIME
IF '$TEST!(MEAL="^")
GOTO KIL
+1 IF MEAL=""
IF $PIECE(P(LN,SP),"^",3)=""
GOTO KIL
SET MEAL=$PIECE(P(LN,SP),"^",3)
SET $PIECE(P(LN,SP),"^",6)=MEAL
GOTO N2A
+2 IF MEAL="@"
SET $PIECE(P(LN,SP),"^",3)=""
GOTO N2
+3 SET X=MEAL
DO TR^FH
SET MEAL=X
IF $PIECE("ALL",MEAL,1)=""
SET MEAL="BNE"
SET X=MEAL
SET MEAL=""
IF X["B"
SET MEAL="B"
IF X["N"
SET MEAL=MEAL_"N"
IF X["E"
SET MEAL=MEAL_"E"
+4 IF $LENGTH(X)'=$LENGTH(MEAL)
WRITE *7,!,"Select B for Breakfast, N for Noon, E for Evening or ALL for all meals",!,"Answer may be multiple meals, e.g., BN or NE"
GOTO N2
+5 SET $PIECE(P(LN,SP),"^",6)=MEAL
N2A WRITE !,"Quantity: ",$SELECT($PIECE(P(LN,SP),"^",4):$PIECE(P(LN,SP),"^",4)_"// ",1:"1// ")
READ NUM:DTIME
IF NUM=""
SET NUM=$SELECT($PIECE(P(LN,SP),"^",4):$PIECE(P(LN,SP),"^",4),1:1)
IF '$TEST!(NUM="^")
GOTO KIL
+1 IF NUM="@"
SET $PIECE(P(LN,SP),"^",4)=""
GOTO N2A
+2 IF NUM'?1N!(NUM<1)
WRITE !,*7,"Enter a number from 1-9."
GOTO N2A
+3 SET $PIECE(P(LN,SP),"^",7)=NUM
+4 SET C1=$PIECE(P(LN,SP),"^",2,4)
SET C2=$PIECE(P(LN,SP),"^",5,7)
IF C1=C2
GOTO E1
N3 WRITE !!,"ADD this Order? Y// "
READ YN:DTIME
IF '$TEST!(YN="^")
GOTO KIL
IF YN=""
SET YN="Y"
SET X=YN
DO TR^FH
SET YN=X
IF $PIECE("YES",YN,1)'=""
IF $PIECE("NO",YN,1)'=""
WRITE *7," Answer YES or NO"
GOTO N3
+1 IF YN?1"N".E
GOTO E1
+2 IF C1'="^^"
SET OLD=$PIECE(P(LN,SP),"^",1)
SET $PIECE(^FHPT(FHDFN,"A",ADM,"SP",OLD,0),"^",6,7)=NOW_"^"_DUZ
KILL ^FHPT("ASP",FHDFN,ADM,OLD)
SET EVT="S^C^"_OLD
DO ^FHORX
+3 SET $PIECE(P(LN,SP),"^",2,4)="^^"
SET $PIECE(P(LN,SP),"^",2,4)=$PIECE(P(LN,SP),"^",5,7)
SET $PIECE(P(LN,SP),"^",5,7)="^^"
ADD ; Add Standing Order
+1 LOCK +^FHPT(FHDFN,"A",ADM,"SP",0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+2 IF '$DATA(^FHPT(FHDFN,"A",ADM,"SP",0))
SET ^FHPT(FHDFN,"A",ADM,"SP",0)="^115.08^^"
+3 SET X=^FHPT(FHDFN,"A",ADM,"SP",0)
SET NO=$PIECE(X,"^",3)+1
SET ^(0)=$PIECE(X,"^",1,2)_"^"_NO_"^"_($PIECE(X,"^",4)+1)
+4 LOCK -^FHPT(FHDFN,"A",ADM,"SP",0)
IF $DATA(^FHPT(FHDFN,"A",ADM,"SP",NO))
GOTO ADD
+5 SET ^FHPT(FHDFN,"A",ADM,"SP",NO,0)=NO_"^"_SP_"^"_MEAL_"^"_NOW_"^"_DUZ_"^^^"_NUM
SET ^FHPT("ASP",FHDFN,ADM,NO)=""
SET LS=LS_NO_","
+6 SET $PIECE(P(LN,SP),"^",1)=NO
SET EVT="S^O^"_NO
DO ^FHORX
WRITE " .. done"
GOTO E1
EN2 ; Standing Order Inquiry
+1 KILL DIC,X,DFN,FHDFN,FHPTNM
SET ADM=""
SET FHALL=1
DO ^FHOMDPA
+2 ;S ALL=0 D ^FHDPA G:'DFN KIL G:'FHDFN KIL S NO=0 D LIS G EN2
+3 SET (FHSOFG,WARD)=""
IF $GET(DFN)'=""
SET WARD=$GET(^DPT(DFN,.1))
+4 IF 'FHDFN
GOTO KIL
SET NO=0
IF $GET(DFN)
DO LIS
+5 IF $DATA(^FHPT("ASPO",FHDFN))
DO OUT
+6 GOTO EN2
EN3 ; Cancel Standing Order
+1 SET NO=$PIECE($GET(P(LN,SP)),"^",1)
IF 'NO
QUIT
+2 SET $PIECE(^FHPT(FHDFN,"A",ADM,"SP",NO,0),"^",6,7)=NOW_"^"_DUZ
+3 SET X=^FHPT(FHDFN,"A",ADM,"SP",NO,0)
SET SP=$PIECE(X,"^",2)
SET MEAL=$PIECE(X,"^",3)
SET NUM=""
+4 KILL ^FHPT("ASP",FHDFN,ADM,NO),P(LN,SP)
SET EVT="S^C^"_NO
DO ^FHORX
QUIT
LIS ;list SO
+1 IF WARD=""
QUIT
+2 SET NAM=$PIECE(^DPT(DFN,0),"^",1)
DO CUR^FHORD7
+3 WRITE !!,NAM," "
IF WARD'=""
WRITE "( ",WARD," )"
+4 WRITE !!,"Current Diet: ",$SELECT(Y'="":Y,1:"No current order")
+5 DO ALG^FHCLN
WRITE !," Allergies: ",$SELECT(ALG="":"None on file",1:ALG)
+6 KILL N,P
SET CTR=0
+7 FOR K=0:0
SET K=$ORDER(^FHPT("ASP",FHDFN,ADM,K))
IF K<1
QUIT
SET X=^FHPT(FHDFN,"A",ADM,"SP",K,0)
SET M=$PIECE(X,"^",3)
SET M=$SELECT(M="BNE":"A",1:$EXTRACT(M,1))
SET N(M,K)=$PIECE(X,"^",2,3)_"^"_$PIECE(X,"^",8,9)
+8 SET FHSOFG=1
+9 SET LN=0
SET LS=""
IF $ORDER(N(""))=""
WRITE !!,"No Active Inpatient Standing Orders."
QUIT
+10 WRITE !!,"Active Inpatient Standing Orders: ",!
+11 FOR M="A","B","N","E"
Begin DoDot:1
+12 FOR K=0:0
SET K=$ORDER(N(M,K))
IF K<1
QUIT
SET Z=+N(M,K)
IF Z
Begin DoDot:2
+13 SET LN=LN+1
SET LS=LS_K_","
DO L1
WRITE !
IF NO
WRITE $JUSTIFY(LN,2)
+14 SET NUM=$PIECE(N(M,K),"^",3)
+15 WRITE ?5,M2,?18,$SELECT(NUM:NUM,1:1)," ",$PIECE(^FH(118.3,Z,0),"^",1)_$SELECT($PIECE(N(M,K),"^",4)'="Y":" (I)",1:"")
IF $GET(^FH(118.3,Z,"I"))="Y"
WRITE " (** INACTIVE **)"
+16 SET P(LN,+Z)=K_"^"_$PIECE(N(M,K),"^",1,3)
QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
L1 ; Store Standing Order By Meal
+1 SET M1=$PIECE(N(M,K),"^",2)
IF M1="BNE"
SET M2="All Meals"
QUIT
+2 SET L=$EXTRACT(M1,1)
SET M2=$SELECT(L="B":"Break",L="N":"Noon",1:"Even")
+3 SET L=$EXTRACT(M1,2)
IF L=""
QUIT
SET M2=M2_","_$SELECT(L="B":"Break",L="N":"Noon",1:"Even")
QUIT
OUT ;ask for Recurring Meal Entry
+1 WRITE @IOF
+2 WRITE "Outpatient Recurring Meals..."
+3 KILL FHDM14,FHEDI,FHEDIF,FHIEN,FHMIEN,FHFLG
+4 SET FHQ=0
+5 SET (FHTOTML("B"),FHTOTML("N"),FHTOTML("E"),FHTOTML("A"))=0
+6 FOR FHI=DT-1:0
SET FHI=$ORDER(^FHPT("RM",FHI))
IF FHI'>0!FHQ
QUIT
FOR FHJ=0:0
SET FHJ=$ORDER(^FHPT("RM",FHI,FHDFN,FHJ))
IF FHJ'>0!FHQ
QUIT
IF ($PIECE($GET(^FHPT(FHDFN,"OP",FHJ,0)),U,15)'="C")
Begin DoDot:1
+7 SET FHDA15=$GET(^FHPT(FHDFN,"OP",FHJ,0))
+8 SET FHDM14(FHI,$PIECE(FHDA15,U,4))=FHI_U_FHJ
+9 ;
+10 SET FHMEAL=$PIECE(FHDA15,U,4)
SET FHLOC=$PIECE(FHDA15,U,3)
SET FHLOCN=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
SET FHMEAL=$SELECT(FHMEAL="B":"Break",FHMEAL="N":"Noon",1:"Even")
SET FH11=FHMEAL_" "_FHLOCN
+11 SET Y=$PIECE(FHDA15,U,1)
XECUTE ^DD("DD")
SET DTP=Y
+12 SET (FHCOFLG,FHDATL)=0
+13 IF $Y>(IOSL-5)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to Continue or '^' to Quit Listing"
DO ^DIR
IF Y
WRITE @IOF
IF 'Y
SET FHQ=1
QUIT
+14 WRITE !,DTP,?12,FH11,":"
+15 SET FHDATL=$LENGTH(DTP)+13+$LENGTH(FH11)
+16 FOR FHSF=0:0
SET FHSF=$ORDER(^FHPT(FHDFN,"OP",FHJ,"SP",FHSF))
IF FHSF'>0
QUIT
Begin DoDot:2
+17 SET FHDA15SF=$GET(^FHPT(FHDFN,"OP",FHJ,"SP",FHSF,0))
+18 IF $PIECE(FHDA15SF,U,6)
QUIT
+19 SET FHDASFNM=$PIECE($GET(^FH(118.3,$PIECE(FHDA15SF,U,2),0)),U,1)
SET FHDASFQT=$PIECE(FHDA15SF,U,8)
+20 IF (FHDATL+$LENGTH(FHDASFNM)+3+$LENGTH(FHDASFQT))>79
WRITE !,?19
SET FHDATL=19
+21 IF (FHDATL>19)
IF (FHCOFLG=1)
WRITE ","
+22 SET FHDATL=FHDATL+4+$LENGTH(FHDASFNM)+3+$LENGTH(FHDASFQT)
+23 WRITE " ",FHDASFNM," = ",FHDASFQT
End DoDot:2
End DoDot:1
+24 IF '$DATA(FHDM14)
WRITE !!,"NO OUTPATIENT DATA ON FILE for today's date and the future!!",!
QUIT
+25 WRITE !
+26 ;
+27 KILL DIC
SET DIC(0)="AEQM"
+28 SET DIC("W")="S FHMEAL=$P(^(0),U,4),FHLOC=$P(^(0),U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHMEAL=""B"":""Break"",FHMEAL=""N"":""Noon"",1:""Even""),FH11=FHMEAL_"" ""_FHLOCN D EN^DDIOL(FH11,"""",""?3"")"
+29 SET DIC("S")="I $P(^FHPT(FHDFN,""OP"",+Y,0),U,1)>(DT-1),($P(^(0),U,15)'=""C"")"
+30 SET DIC="^FHPT(FHDFN,""OP"","
+31 SET DIC("?")="Select a Date, '^' to exit"
+32 SET DIC("A")="Select the Outpatient Date :"
DO ^DIC
KILL DIC
IF (Y'>0)!$DATA(DTOUT)
QUIT
+33 SET ADM=+Y
+34 DO LIS^FHSP
+35 QUIT
CHK ;ENTER DATES.
+1 KILL FHDT1,FHDT2
+2 SET FHFLG=0
F1 ;START DATE
+1 KILL DIC
SET DIC(0)="AEQM"
+2 WRITE !
+3 SET DIC("W")="S FHML=$P(^(0),U,4),FHLOC=$P(^(0),U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHML=""B"":""Break"",FHML=""N"":""Noon"",1:""Even""),FH11=FHMEAL_"" ""_FHLOCN D EN^DDIOL(FH11,"""",""?3"")"
+4 SET DIC("S")="S FHML=$P(^(0),U,4),FHDT1=$P(^(0),U,1) I $P(^(0),U,1)>(DT-1),($P(^(0),U,15)'=""C""),FHML=FHDTML"
+5 SET DIC="^FHPT(FHDFN,""OP"","
+6 SET DIC("?")="Enter a Date, '^' to exit"
+7 SET DIC("A")="Enter a Start Date :"
DO ^DIC
KILL DIC
IF (Y'>0)!$DATA(DTOUT)
QUIT
+8 SET FHDT1=$PIECE(^FHPT(FHDFN,"OP",+Y,0),U,1)
F2 ;END DATE
+1 KILL DIC
SET DIC(0)="AEQM"
+2 WRITE !
+3 SET DIC("W")="S FHML=$P(^(0),U,4),FHLOC=$P(^(0),U,3),FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1),FHMEAL=$S(FHML=""B"":""Break"",FHML=""N"":""Noon"",1:""Even""),FH11=FHMEAL_"" ""_FHLOCN D EN^DDIOL(FH11,"""",""?3"")"
+4 SET DIC("S")="S FHML=$P(^(0),U,4),FHDT2=$P(^(0),U,1) I $P(^(0),U,1)>(FHDT1-1),($P(^(0),U,15)'=""C""),FHML=FHDTML"
+5 SET DIC="^FHPT(FHDFN,""OP"","
+6 SET DIC("?")="Enter a Date, '^' to exit"
+7 SET DIC("A")="Enter an End Date :"
DO ^DIC
KILL DIC
IF (Y'>0)!$DATA(DTOUT)
QUIT
+8 SET FHDT2=$PIECE(^FHPT(FHDFN,"OP",+Y,0),U,1)
+9 IF FHDT2<FHDT1
WRITE !!,"***End Date must be on or after Start Date!!!"
GOTO F2
+10 SET FHFLG=1
+11 QUIT
CPRSO ;check previous SO
+1 KILL FHSOO,FHCK
+2 SET (FHDAT,FHSO)=""
CPRS1 IF FHSO=""
SET FHSO=$ORDER(^FHPT("ASPO",FHDFN,""),-1)
+1 IF '$TEST
SET FHSO=$ORDER(^FHPT("ASPO",FHDFN,FHSO),-1)
+2 IF '$GET(FHSO)
QUIT
+3 SET FHDAT=$GET(^FHPT(FHDFN,"OP",FHSO,0))
SET FHPRML=$PIECE(FHDAT,U,4)
SET FHPRCN=$PIECE(FHDAT,U,15)
+4 IF (FHPRML'=FHMEAL)!(FHPRCN="C")
GOTO CPRS1
+5 SET FHCK(FHPRML)=""
+6 FOR FHI=0:0
SET FHI=$ORDER(^FHPT(FHDFN,"OP",FHSO,"SP",FHI))
IF FHI'>0
QUIT
Begin DoDot:1
+7 SET FHSODAT=$GET(^FHPT(FHDFN,"OP",FHSO,"SP",FHI,0))
SET FHSOI=$PIECE(FHSODAT,U,2)
SET FHSOCN=$PIECE(FHSODAT,U,6)
SET FHSOQ=$PIECE(FHSODAT,U,8)
+8 IF $PIECE(FHSODAT,U,9)="Y"
QUIT
+9 IF '$GET(FHSOI)!$GET(FHSOCN)
QUIT
+10 SET FHSOO(FHI,FHSOI)=FHSOQ
SET P(1,FHSOI)=""
End DoDot:1
+11 QUIT
PPRSO ;PROCESS previous SO
+1 IF '$DATA(FHSOO)
QUIT
+2 SET (LS,LN)=1
+3 DO NOW^%DTC
SET NOW=%
+4 FOR FHI=0:0
SET FHI=$ORDER(FHSOO(FHI))
IF FHI'>0
QUIT
FOR FHJ=0:0
SET FHJ=$ORDER(FHSOO(FHI,FHJ))
IF FHJ'>0
QUIT
SET NUM=FHSOO(FHI,FHJ)
SET SP=FHJ
DO AD1^FHSP
+5 QUIT
SOEVNT SET FHDTC=0
+1 SET FHLOCN=""
IF $DATA(FHLOC)
IF $GET(FHLOC)
IF $DATA(^FH(119.6,FHLOC,0))
SET FHLOCN=$PIECE(^(0),U,1)
+2 SET FHDTC=FHDTC+1
SET DTP=FHOSTDT
DO DTP^FH
IF FHDTC=1
SET FHDTP=DTP
+3 SET DTP=$PIECE(ENDT,".",1)
DO DTP^FH
+4 IF DTP'=FHDTP
SET FHDTP=FHDTP_" to "_DTP
+5 SET FHALML=FHMEAL
+6 FOR FHI=0:0
SET FHI=$ORDER(FHSOO(FHI))
IF FHI'>0
QUIT
FOR FHJ=0:0
SET FHJ=$ORDER(FHSOO(FHI,FHJ))
IF FHJ'>0
QUIT
SET NUM=FHSOO(FHI,FHJ)
SET SP=FHJ
DO EVNT^FHSP1
+7 QUIT
KIL GOTO KILL^XUSCLEAN
