- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHSPED 9791 printed Jan 18, 2025@02:56:21 Page 2
- 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