FHNO5 ; HISC/REL - Enter/Edit Supplemental Fdgs. ; 3/10/16 3:11pm
;;5.5;DIETETICS;**5,41**;Jan 28, 2005;Build 4
;patch #5 - add SF to outpatient.
;patch #41 - add timeout to incremental locks
D NOW^%DTC S NOW=%
ASK K DIC,X,DFN,FHDFN,FHPTNM,Y S (FHMEAL,ADM,FHIDFLG,FHPNNSV)="",FHALL=1 D ^FHOMDPA
G:'FHDFN KIL
S WARD="" I $G(DFN)'="" S WARD=$G(^DPT(DFN,.1))
I WARD="" D SFOUT 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"))) G ASK
I (X="") D SFOUT G ASK
I WARD'="",X="C" S ADM=$G(^DPT("CN",WARD,DFN)) G:$G(ADM) S0
S DIC="^FHPT(FHDFN,""A"",",DIC(0)="EQM" D ^DIC G:Y<1 A0 S ADM=+Y
G:'$G(ADM) ASK
D S0
G ASK
S0 D LIS^FHNO7 S PNO=Y
SFA K DIC S FHNNSV="",DIC="^FH(118.1,",DIC(0)="EQM",OLD=$S('NM:"",1:$P(^FH(118.1,NM,0),"^",1))
W !!,"Supplemental Feeding Menu: " W:NM OLD," // " R X:DTIME
G KIL:'$T Q:X["^"
S FHNMSAV=NM
S FHXSAV=X
I X="" Q:'NM G S1
I X="@" D CAN W " .. cancelled" Q
D ^DIC K DIC G SFA:Y<1 S NM=+Y
S FHNMSAV=NM
S1 Q:'NM
S KK=1,PNN="^"_NOW_"^"_DUZ_"^"_NM_"^"_$S(NM=1:$P(PNO,"^",5,29),1:^FH(118.1,NM,1))
I WARD="" D ;if outpatient, only allow SF for specific meal.
.S T1=$S(FHMEAL="B":"10am",FHMEAL="N":"2pm",1:"8pm")
.S KK=$S(FHMEAL="B":1,FHMEAL="N":5,1:9)
.S FHKK9=$S(FHMEAL="B":5,FHMEAL="N":14,1:23)
I NM=1,WARD="" D OIS^FHNO7,CAN S FHSFQT9=$P(FHPNNSV,"^",FHKK9,FHKK9+6),PNN=FHPNNSV G:"^^^^^^^^"'[FHSFQT9 ADD
I NM'=1 G UPD:$P(PNO,"^",4,29)=$P(PNN,"^",4,29) D CAN G ADD
S DIC="^FH(118,",DIC(0)="EQM",DIC("S")="I $P(^(0),U,3)'=""Y"""
G1 G:KK>12 G5
I ((WARD="")&(FHMEAL="B")&(KK>4))!((WARD="")&(FHMEAL="N")&(KK>8)) G G5
I WARD'="" S T1=$P("10am^2pm^8pm","^",KK-1\4+1)
S T2="#"_(KK-1#4+1),P1=KK*2+3
S DIC("A")=T1_" Feeding "_T2_": "
S OLD=$P(PNN,"^",P1) I OLD S DIC("A")=DIC("A")_$P(^FH(118,+OLD,0),"^",1)_"// "
G2 W !!,DIC("A") R X:DTIME G:'$T!(X["^") G5
I X="" G:OLD G3 S KK=$S(KK<5:5,KK<9:9,1:13) G G1
I OLD,X="@" S $P(PNN,"^",P1)="",$P(PNN,"^",P1+1)="" S KK=KK+1 G G1
D ^DIC G:Y<1 G2 S Y=+Y,K1=$S(KK<5:1,KK<9:5,1:9)
F L=K1:1:K1+3 I L'=KK,$P(PNN,"^",L*2+3)=Y W *7," .. DUPLICATE OF EXISTING ITEM!" G G2
S:OLD'=Y $P(PNN,"^",P1)=Y
G3 S OLD=$P(PNN,"^",P1+1)
G4 W !,T1," ",T2," Qty: ",$S(OLD="":1,1:OLD),"// " R X:DTIME G:'$T!(X["^") G5
S:X="@" X=0 I X="" S:OLD="" $P(PNN,"^",P1+1)=1 S KK=KK+1 G G1
I X'?1N.N!(X>20) W *7," ??" S X="?"
I X["?" W !?5,"Enter a whole number between 1 and 20" G G4
I 'X S $P(PNN,"^",P1)="",$P(PNN,"^",P1+1)="" S KK=KK+1 G G1
S $P(PNN,"^",P1+1)=X,KK=KK+1 G G1
G5 S KK=3,X="" F T1=0:1:2 S P1=T1*8-1 F T2=1:1:4 S KK=KK+2 I $P(PNN,"^",KK) S P1=P1+2,$P(X,"^",P1,P1+1)=$P(PNN,"^",KK,KK+1)
I X="" D CAN Q
G6 Q:WARD=""
S P1=$P(PNN,"^",29) S:P1="" P1="D" W !!,"Dietary or Therapeutic? ",P1,"// " R Y:DTIME S:'$T!("^"[Y) Y=P1
S:$P("dietary",Y,1)="" Y="D" S:$P("therapeutic",Y,1)="" Y="T"
I $P("DIETARY",Y,1)'="",$P("THERAPEUTIC",Y,1)'="" W *7,!?5," Answer D for Dietary use or T for Therapeutic use" G G6
S $P(X,"^",25)=$E(Y,1),PNN=$P(PNN,"^",1,4)_"^"_X
G:$P(PNO,"^",5,29)=X UPD D CAN
ADD ; Add SF
Q:'$D(WARD)
I WARD="" G ADDOUT
L +^FHPT(FHDFN,"A",ADM,"SF",0):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
I '$D(^FHPT(FHDFN,"A",ADM,"SF",0)) S ^FHPT(FHDFN,"A",ADM,"SF",0)="^115.07^^"
S X=^FHPT(FHDFN,"A",ADM,"SF",0),NO=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_NO_"^"_($P(X,"^",4)+1)
L -^FHPT(FHDFN,"A",ADM,"SF",0) I $D(^FHPT(FHDFN,"A",ADM,"SF",NO)) G ADD
S ^FHPT(FHDFN,"A",ADM,"SF",NO,0)=NO_"^"_$P(PNN,"^",2,99)
S $P(^FHPT(FHDFN,"A",ADM,0),"^",7)=NO
I NO'="" S EVT="F^O^"_NO D ^FHORX
UPD Q:'$D(WARD) I WARD="" G UPDOUT
S:NO $P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",30,31)=NOW_"^"_DUZ
Q
CAN ; Cancel SF
Q:'$D(WARD)
I WARD="" G CANOUT
S NO=$P(^FHPT(FHDFN,"A",ADM,0),"^",7),$P(^(0),"^",7)=""
S:NO $P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",32,33)=NOW_"^"_DUZ
I NO'="" S EVT="F^C^"_NO D ^FHORX
Q
SFOUT ;outpt SF
K FHSFLG,FHNMSAV,FHXSAV,X,OLD,FHLOC,FHLOCN
D SF^FHNO7
I '$G(FHSFLG) W !,"NO OUTPATIENT DATA ON FILE for today's date and the future!!" Q
D ASK0
Q
ASK0 ;ask Rec Meal
K FHDM14,FHFLG,FHCK,FHDMIEN,FHIEN
S (FHTOTML("B"),FHTOTML("N"),FHTOTML("E"),FHTOTML("A"))=0
F FHI=DT-1:0 S FHI=$O(^FHPT("RM",FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(^FHPT("RM",FHI,FHDFN,FHJ)) Q:FHJ'>0 D
.S FHOPDAT=$G(^FHPT(FHDFN,"OP",FHJ,0))
.Q:$P(FHOPDAT,U,15)="C"
.S FHML=$P(FHOPDAT,U,4)
.S FHN=0
.S:FHML="B" FHN=1
.S:FHML="N" FHN=2
.S:FHML="E" FHN=3
.S FHDM14(FHI,FHN,FHML)=FHI_U_FHJ
F FHI=0:0 S FHI=$O(FHDM14(FHI)) Q:FHI'>0 D
.F FHN=1,2,3 Q:FHN="" F FHJ="B","N","E" Q:FHJ="" D
..I (FHJ="B")&$D(FHDM14(FHI,FHN,FHJ)) S FHTOTML("B")=FHTOTML("B")+1,(FHDMIEN(FHI,FHJ),FHIEN(FHJ))=FHDM14(FHI,FHN,FHJ)
..I (FHJ="N")&$D(FHDM14(FHI,FHN,FHJ)) S FHTOTML("N")=FHTOTML("N")+1,(FHDMIEN(FHI,FHJ),FHIEN(FHJ))=FHDM14(FHI,FHN,FHJ)
..I (FHJ="E")&$D(FHDM14(FHI,FHN,FHJ)) S FHTOTML("E")=FHTOTML("E")+1,(FHDMIEN(FHI,FHJ),FHIEN(FHJ))=FHDM14(FHI,FHN,FHJ)
Q:'$D(FHDM14)
R1 S (FHCNSFF,FHADSFF)=0,(FHLOCN,FHSFMEN)="",(FH1,FHQ,FHDTC)=0,(FHDTML,FHX)="" R !!,"Enter a Meal (B,N,E or ALL): ALL// ",FHDTML:DTIME
Q:'$T!(FHDTML["^")
S:FHDTML="" FHDTML="ALL"
I FHDTML["?" S FHQ=1 G MS1
S X=FHDTML D TR^FH S (FHX,FHDTML)=X
I FHDTML="A" S FHQ=1 G MS1
S FHALML=FHX
I FHDTML="ALL" S FHDTML=$E(FHDTML,1),FHALML="BNE"
I $L(FHDTML)=3 S:("BNE")'[$E(FHDTML,1) FHQ=1 S:("BNE")'[$E(FHDTML,2) FHQ=1 S:("BNE")'[$E(FHDTML,3) FHQ=1 S FHCK($E(FHDTML,1))="",FHCK($E(FHDTML,2))="",FHCK($E(FHDTML,3))=""
I $L(FHDTML)=2 S:("BNE")'[$E(FHDTML,1) FHQ=1 S:("BNE")'[$E(FHDTML,2) FHQ=1 S FHCK($E(FHDTML,1))="",FHCK($E(FHDTML,2))=""
I $L(FHDTML)=1 S:("ABNE")'[$E(FHDTML,1) FHQ=1 S FHCK(FHDTML)=""
I FHDTML="A" S (FHCK("B"),FHCK("N"),FHCK("E"))=""
S:$L(FHDTML)>3 FHQ=1
G:FHQ MS1
I $L(FHDTML)=3 S:'$G(FHTOTML($E(FHDTML,1))) FH1=1 S:'$G(FHTOTML($E(FHDTML,2))) FH1=1 S:'$G(FHTOTML($E(FHDTML,3))) FH1=1 I FH1 W !!,"There is no outpatient data for this Meal!!" G R1
I $L(FHDTML)=2 S:'$G(FHTOTML($E(FHDTML,1))) FH1=1 S:'$G(FHTOTML($E(FHDTML,2))) FH1=1 I FH1 W !!,"There is no outpatient data for this Meal!!" G R1
MS1 I FHQ 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 R1
S:$L(FHDTML)>1 FHDTML="A"
S (FHFLG,FHLIS)=0
I (FHDTML'="A"),(FHTOTML(FHDTML)'>0) W !!,"There is no outpatient data for this Meal!!" G R1
I FHDTML'="A",(FHTOTML(FHDTML)=1) F FHI=DT-1:0 S FHI=$O(FHDMIEN(FHI)) G:FHI'>0 EVNT I $D(FHDMIEN(FHI,FHDTML)) S FHDMDAT=FHDMIEN(FHI,FHDTML) D PR1
I FHDTML'="A",(FHTOTML(FHDTML)>1) D CHK^FHSPED
I 'FHFLG,FHDTML="A" G ALL
I $G(FHFLG) F FHI=FHDT1-1:0 S FHI=$O(FHDM14(FHI)) G:(FHI'>0)!(FHI>FHDT2) EVNT F FHN=1,2,3 Q:FHN="" I $D(FHDM14(FHI,FHN,FHDTML)) S FHDMDAT=FHDM14(FHI,FHN,FHDTML) D PR1
Q
ALL S FHCT=0,(FHDT1,FHDT2,FHDTSV)=DT
F FHI=DT-1:0 S FHI=$O(FHDM14(FHI)) S:'FHI FHDT2=FHDTSV Q:FHI'>0 S FHCT=FHCT+1,FHDTSV=FHI S:FHCT=1 FHDT1=FHI F FHN=1,2,3 Q:FHN="" D
.S FHJ="" F S FHJ=$O(FHDM14(FHI,FHN,FHJ)) Q:FHJ="" I $D(FHDM14(FHI,FHN,FHJ)) S FHDMDAT=FHDM14(FHI,FHN,FHJ) D PR1
;
EVNT 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
I FHCNSFF=1 S FHACT="C",FHTXT="Outpatient Supplemental Feeding: ("_FHALML_") , "_FHLOCN_", Cancelled "_FHDTP D OPFILE^FHORX
I FHADSFF=1 S FHACT="O",FHTXT="Outpatient Supplemental Feeding: "_FHSFMEN_" ("_FHALML_") , "_FHLOCN_", "_FHDTP D OPFILE^FHORX
Q
PR1 S FHDTE=$P(FHDMDAT,U,1),ADM=$P(FHDMDAT,U,2)
I '$G(^FHPT(FHDFN,"OP",ADM,0)) Q
S FHDTC=FHDTC+1,DTP=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,1) D DTP^FH S:FHDTC=1 FHDTP=DTP
S FHMEAL=$P(^FHPT(FHDFN,"OP",ADM,0),U,4)
I $G(FHIDFLG) D CAN S PNN=FHPNNSV,FHKK9=$S(FHMEAL="B":5,FHMEAL="N":14,1:23) S FHSFQT9=$P(FHPNNSV,"^",FHKK9,FHKK9+6) G:"^^^^^^^^"'[FHSFQT9 ADD Q
S (PNO,WARD,FHLOCN,FHSFMEN)=""
S FHLOC=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,3) S:$G(FHLOC) FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1)
I $D(FHXSAV),FHXSAV="@" D CAN W !," .. cancelled" Q
I $D(X),X="^" Q
I $D(FHNMSAV),FHNMSAV'="" D S1 Q
D CAD
D LIS^FHNO7 S PNO=Y
I $G(FHLIS),$G(NO) S PNO=^FHPT(FHDFN,"OP",ADM,"SF",NO,0)
I '$G(FHLIS) D SFA S FHLIS=FHLIS+1 Q
I $G(FHLIS) S NM=FHNMSAV D S1
Q
CAD ;
S FHCFLG=""
S NO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),"^",3)
I NO S FHCFLG=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",NO,0)),"^",32)
Q
ADDOUT ; Add outpt SF
S FHMEAL=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,4),FHSFMEN=""
L +^FHPT(FHDFN,"OP",ADM,"SF",0):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
I '$D(^FHPT(FHDFN,"OP",ADM,"SF",0)) S ^FHPT(FHDFN,"OP",ADM,"SF",0)="^115.1627^^"
S X=^FHPT(FHDFN,"OP",ADM,"SF",0),NO=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_NO_"^"_($P(X,"^",4)+1)
L -^FHPT(FHDFN,"OP",ADM,"SF",0) I $D(^FHPT(FHDFN,"OP",ADM,"SF",NO)) G ADDOUT
I FHMEAL="B" S $P(PNN,U,13,20)="^^^^^^^",$P(PNN,U,21,28)="^^^^^^^"
I FHMEAL="N" S $P(PNN,U,5,12)="^^^^^^^",$P(PNN,U,21,28)="^^^^^^^"
I FHMEAL="E" S $P(PNN,U,5,12)="^^^^^^^",$P(PNN,U,13,20)="^^^^^^^"
S ^FHPT(FHDFN,"OP",ADM,"SF",NO,0)=NO_"^"_$P(PNN,"^",2,99)
S:$G(FHNMSAV) FHSFMEN=$P($G(^FH(118.1,FHNMSAV,0)),U,1)
S FHADSFF=1
UPDOUT S:NO $P(^FHPT(FHDFN,"OP",ADM,"SF",NO,0),"^",30,31)=NOW_"^"_DUZ
Q
CANOUT ; Cancel outpt SF
S NO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),"^",3)
S:NO $P(^FHPT(FHDFN,"OP",ADM,"SF",NO,0),"^",32,33)=NOW_"^"_DUZ
S FHCNSFF=1
Q
KIL G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHNO5 9432 printed Sep 23, 2025@19:28:21 Page 2
FHNO5 ; HISC/REL - Enter/Edit Supplemental Fdgs. ; 3/10/16 3:11pm
+1 ;;5.5;DIETETICS;**5,41**;Jan 28, 2005;Build 4
+2 ;patch #5 - add SF to outpatient.
+3 ;patch #41 - add timeout to incremental locks
+4 DO NOW^%DTC
SET NOW=%
ASK KILL DIC,X,DFN,FHDFN,FHPTNM,Y
SET (FHMEAL,ADM,FHIDFLG,FHPNNSV)=""
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=""
DO SFOUT
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")))
GOTO ASK
+2 IF (X="")
DO SFOUT
GOTO ASK
+3 IF WARD'=""
IF X="C"
SET ADM=$GET(^DPT("CN",WARD,DFN))
if $GET(ADM)
GOTO S0
+4 SET DIC="^FHPT(FHDFN,""A"","
SET DIC(0)="EQM"
DO ^DIC
if Y<1
GOTO A0
SET ADM=+Y
+5 if '$GET(ADM)
GOTO ASK
+6 DO S0
+7 GOTO ASK
S0 DO LIS^FHNO7
SET PNO=Y
SFA KILL DIC
SET FHNNSV=""
SET DIC="^FH(118.1,"
SET DIC(0)="EQM"
SET OLD=$SELECT('NM:"",1:$PIECE(^FH(118.1,NM,0),"^",1))
+1 WRITE !!,"Supplemental Feeding Menu: "
if NM
WRITE OLD," // "
READ X:DTIME
+2 if '$TEST
GOTO KIL
if X["^"
QUIT
+3 SET FHNMSAV=NM
+4 SET FHXSAV=X
+5 IF X=""
if 'NM
QUIT
GOTO S1
+6 IF X="@"
DO CAN
WRITE " .. cancelled"
QUIT
+7 DO ^DIC
KILL DIC
if Y<1
GOTO SFA
SET NM=+Y
+8 SET FHNMSAV=NM
S1 if 'NM
QUIT
+1 SET KK=1
SET PNN="^"_NOW_"^"_DUZ_"^"_NM_"^"_$SELECT(NM=1:$PIECE(PNO,"^",5,29),1:^FH(118.1,NM,1))
+2 ;if outpatient, only allow SF for specific meal.
IF WARD=""
Begin DoDot:1
+3 SET T1=$SELECT(FHMEAL="B":"10am",FHMEAL="N":"2pm",1:"8pm")
+4 SET KK=$SELECT(FHMEAL="B":1,FHMEAL="N":5,1:9)
+5 SET FHKK9=$SELECT(FHMEAL="B":5,FHMEAL="N":14,1:23)
End DoDot:1
+6 IF NM=1
IF WARD=""
DO OIS^FHNO7
DO CAN
SET FHSFQT9=$PIECE(FHPNNSV,"^",FHKK9,FHKK9+6)
SET PNN=FHPNNSV
if "^^^^^^^^"'[FHSFQT9
GOTO ADD
+7 IF NM'=1
if $PIECE(PNO,"^",4,29)=$PIECE(PNN,"^",4,29)
GOTO UPD
DO CAN
GOTO ADD
+8 SET DIC="^FH(118,"
SET DIC(0)="EQM"
SET DIC("S")="I $P(^(0),U,3)'=""Y"""
G1 if KK>12
GOTO G5
+1 IF ((WARD="")&(FHMEAL="B")&(KK>4))!((WARD="")&(FHMEAL="N")&(KK>8))
GOTO G5
+2 IF WARD'=""
SET T1=$PIECE("10am^2pm^8pm","^",KK-1\4+1)
+3 SET T2="#"_(KK-1#4+1)
SET P1=KK*2+3
+4 SET DIC("A")=T1_" Feeding "_T2_": "
+5 SET OLD=$PIECE(PNN,"^",P1)
IF OLD
SET DIC("A")=DIC("A")_$PIECE(^FH(118,+OLD,0),"^",1)_"// "
G2 WRITE !!,DIC("A")
READ X:DTIME
if '$TEST!(X["^")
GOTO G5
+1 IF X=""
if OLD
GOTO G3
SET KK=$SELECT(KK<5:5,KK<9:9,1:13)
GOTO G1
+2 IF OLD
IF X="@"
SET $PIECE(PNN,"^",P1)=""
SET $PIECE(PNN,"^",P1+1)=""
SET KK=KK+1
GOTO G1
+3 DO ^DIC
if Y<1
GOTO G2
SET Y=+Y
SET K1=$SELECT(KK<5:1,KK<9:5,1:9)
+4 FOR L=K1:1:K1+3
IF L'=KK
IF $PIECE(PNN,"^",L*2+3)=Y
WRITE *7," .. DUPLICATE OF EXISTING ITEM!"
GOTO G2
+5 if OLD'=Y
SET $PIECE(PNN,"^",P1)=Y
G3 SET OLD=$PIECE(PNN,"^",P1+1)
G4 WRITE !,T1," ",T2," Qty: ",$SELECT(OLD="":1,1:OLD),"// "
READ X:DTIME
if '$TEST!(X["^")
GOTO G5
+1 if X="@"
SET X=0
IF X=""
if OLD=""
SET $PIECE(PNN,"^",P1+1)=1
SET KK=KK+1
GOTO G1
+2 IF X'?1N.N!(X>20)
WRITE *7," ??"
SET X="?"
+3 IF X["?"
WRITE !?5,"Enter a whole number between 1 and 20"
GOTO G4
+4 IF 'X
SET $PIECE(PNN,"^",P1)=""
SET $PIECE(PNN,"^",P1+1)=""
SET KK=KK+1
GOTO G1
+5 SET $PIECE(PNN,"^",P1+1)=X
SET KK=KK+1
GOTO G1
G5 SET KK=3
SET X=""
FOR T1=0:1:2
SET P1=T1*8-1
FOR T2=1:1:4
SET KK=KK+2
IF $PIECE(PNN,"^",KK)
SET P1=P1+2
SET $PIECE(X,"^",P1,P1+1)=$PIECE(PNN,"^",KK,KK+1)
+1 IF X=""
DO CAN
QUIT
G6 if WARD=""
QUIT
+1 SET P1=$PIECE(PNN,"^",29)
if P1=""
SET P1="D"
WRITE !!,"Dietary or Therapeutic? ",P1,"// "
READ Y:DTIME
if '$TEST!("^"[Y)
SET Y=P1
+2 if $PIECE("dietary",Y,1)=""
SET Y="D"
if $PIECE("therapeutic",Y,1)=""
SET Y="T"
+3 IF $PIECE("DIETARY",Y,1)'=""
IF $PIECE("THERAPEUTIC",Y,1)'=""
WRITE *7,!?5," Answer D for Dietary use or T for Therapeutic use"
GOTO G6
+4 SET $PIECE(X,"^",25)=$EXTRACT(Y,1)
SET PNN=$PIECE(PNN,"^",1,4)_"^"_X
+5 if $PIECE(PNO,"^",5,29)=X
GOTO UPD
DO CAN
ADD ; Add SF
+1 if '$DATA(WARD)
QUIT
+2 IF WARD=""
GOTO ADDOUT
+3 LOCK +^FHPT(FHDFN,"A",ADM,"SF",0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+4 IF '$DATA(^FHPT(FHDFN,"A",ADM,"SF",0))
SET ^FHPT(FHDFN,"A",ADM,"SF",0)="^115.07^^"
+5 SET X=^FHPT(FHDFN,"A",ADM,"SF",0)
SET NO=$PIECE(X,"^",3)+1
SET ^(0)=$PIECE(X,"^",1,2)_"^"_NO_"^"_($PIECE(X,"^",4)+1)
+6 LOCK -^FHPT(FHDFN,"A",ADM,"SF",0)
IF $DATA(^FHPT(FHDFN,"A",ADM,"SF",NO))
GOTO ADD
+7 SET ^FHPT(FHDFN,"A",ADM,"SF",NO,0)=NO_"^"_$PIECE(PNN,"^",2,99)
+8 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",7)=NO
+9 IF NO'=""
SET EVT="F^O^"_NO
DO ^FHORX
UPD if '$DATA(WARD)
QUIT
IF WARD=""
GOTO UPDOUT
+1 if NO
SET $PIECE(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",30,31)=NOW_"^"_DUZ
+2 QUIT
CAN ; Cancel SF
+1 if '$DATA(WARD)
QUIT
+2 IF WARD=""
GOTO CANOUT
+3 SET NO=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",7)
SET $PIECE(^(0),"^",7)=""
+4 if NO
SET $PIECE(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",32,33)=NOW_"^"_DUZ
+5 IF NO'=""
SET EVT="F^C^"_NO
DO ^FHORX
+6 QUIT
SFOUT ;outpt SF
+1 KILL FHSFLG,FHNMSAV,FHXSAV,X,OLD,FHLOC,FHLOCN
+2 DO SF^FHNO7
+3 IF '$GET(FHSFLG)
WRITE !,"NO OUTPATIENT DATA ON FILE for today's date and the future!!"
QUIT
+4 DO ASK0
+5 QUIT
ASK0 ;ask Rec Meal
+1 KILL FHDM14,FHFLG,FHCK,FHDMIEN,FHIEN
+2 SET (FHTOTML("B"),FHTOTML("N"),FHTOTML("E"),FHTOTML("A"))=0
+3 FOR FHI=DT-1:0
SET FHI=$ORDER(^FHPT("RM",FHI))
if FHI'>0
QUIT
FOR FHJ=0:0
SET FHJ=$ORDER(^FHPT("RM",FHI,FHDFN,FHJ))
if FHJ'>0
QUIT
Begin DoDot:1
+4 SET FHOPDAT=$GET(^FHPT(FHDFN,"OP",FHJ,0))
+5 if $PIECE(FHOPDAT,U,15)="C"
QUIT
+6 SET FHML=$PIECE(FHOPDAT,U,4)
+7 SET FHN=0
+8 if FHML="B"
SET FHN=1
+9 if FHML="N"
SET FHN=2
+10 if FHML="E"
SET FHN=3
+11 SET FHDM14(FHI,FHN,FHML)=FHI_U_FHJ
End DoDot:1
+12 FOR FHI=0:0
SET FHI=$ORDER(FHDM14(FHI))
if FHI'>0
QUIT
Begin DoDot:1
+13 FOR FHN=1,2,3
if FHN=""
QUIT
FOR FHJ="B","N","E"
if FHJ=""
QUIT
Begin DoDot:2
+14 IF (FHJ="B")&$DATA(FHDM14(FHI,FHN,FHJ))
SET FHTOTML("B")=FHTOTML("B")+1
SET (FHDMIEN(FHI,FHJ),FHIEN(FHJ))=FHDM14(FHI,FHN,FHJ)
+15 IF (FHJ="N")&$DATA(FHDM14(FHI,FHN,FHJ))
SET FHTOTML("N")=FHTOTML("N")+1
SET (FHDMIEN(FHI,FHJ),FHIEN(FHJ))=FHDM14(FHI,FHN,FHJ)
+16 IF (FHJ="E")&$DATA(FHDM14(FHI,FHN,FHJ))
SET FHTOTML("E")=FHTOTML("E")+1
SET (FHDMIEN(FHI,FHJ),FHIEN(FHJ))=FHDM14(FHI,FHN,FHJ)
End DoDot:2
End DoDot:1
+17 if '$DATA(FHDM14)
QUIT
R1 SET (FHCNSFF,FHADSFF)=0
SET (FHLOCN,FHSFMEN)=""
SET (FH1,FHQ,FHDTC)=0
SET (FHDTML,FHX)=""
READ !!,"Enter a Meal (B,N,E or ALL): ALL// ",FHDTML:DTIME
+1 if '$TEST!(FHDTML["^")
QUIT
+2 if FHDTML=""
SET FHDTML="ALL"
+3 IF FHDTML["?"
SET FHQ=1
GOTO MS1
+4 SET X=FHDTML
DO TR^FH
SET (FHX,FHDTML)=X
+5 IF FHDTML="A"
SET FHQ=1
GOTO MS1
+6 SET FHALML=FHX
+7 IF FHDTML="ALL"
SET FHDTML=$EXTRACT(FHDTML,1)
SET FHALML="BNE"
+8 IF $LENGTH(FHDTML)=3
if ("BNE")'[$EXTRACT(FHDTML,1)
SET FHQ=1
if ("BNE")'[$EXTRACT(FHDTML,2)
SET FHQ=1
if ("BNE")'[$EXTRACT(FHDTML,3)
SET FHQ=1
SET FHCK($EXTRACT(FHDTML,1))=""
SET FHCK($EXTRACT(FHDTML,2))=""
SET FHCK($EXTRACT(FHDTML,3))=""
+9 IF $LENGTH(FHDTML)=2
if ("BNE")'[$EXTRACT(FHDTML,1)
SET FHQ=1
if ("BNE")'[$EXTRACT(FHDTML,2)
SET FHQ=1
SET FHCK($EXTRACT(FHDTML,1))=""
SET FHCK($EXTRACT(FHDTML,2))=""
+10 IF $LENGTH(FHDTML)=1
if ("ABNE")'[$EXTRACT(FHDTML,1)
SET FHQ=1
SET FHCK(FHDTML)=""
+11 IF FHDTML="A"
SET (FHCK("B"),FHCK("N"),FHCK("E"))=""
+12 if $LENGTH(FHDTML)>3
SET FHQ=1
+13 if FHQ
GOTO MS1
+14 IF $LENGTH(FHDTML)=3
if '$GET(FHTOTML($EXTRACT(FHDTML,1)))
SET FH1=1
if '$GET(FHTOTML($EXTRACT(FHDTML,2)))
SET FH1=1
if '$GET(FHTOTML($EXTRACT(FHDTML,3)))
SET FH1=1
IF FH1
WRITE !!,"There is no outpatient data for this Meal!!"
GOTO R1
+15 IF $LENGTH(FHDTML)=2
if '$GET(FHTOTML($EXTRACT(FHDTML,1)))
SET FH1=1
if '$GET(FHTOTML($EXTRACT(FHDTML,2)))
SET FH1=1
IF FH1
WRITE !!,"There is no outpatient data for this Meal!!"
GOTO R1
MS1 IF FHQ
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 R1
+1 if $LENGTH(FHDTML)>1
SET FHDTML="A"
+2 SET (FHFLG,FHLIS)=0
+3 IF (FHDTML'="A")
IF (FHTOTML(FHDTML)'>0)
WRITE !!,"There is no outpatient data for this Meal!!"
GOTO R1
+4 IF FHDTML'="A"
IF (FHTOTML(FHDTML)=1)
FOR FHI=DT-1:0
SET FHI=$ORDER(FHDMIEN(FHI))
if FHI'>0
GOTO EVNT
IF $DATA(FHDMIEN(FHI,FHDTML))
SET FHDMDAT=FHDMIEN(FHI,FHDTML)
DO PR1
+5 IF FHDTML'="A"
IF (FHTOTML(FHDTML)>1)
DO CHK^FHSPED
+6 IF 'FHFLG
IF FHDTML="A"
GOTO ALL
+7 IF $GET(FHFLG)
FOR FHI=FHDT1-1:0
SET FHI=$ORDER(FHDM14(FHI))
if (FHI'>0)!(FHI>FHDT2)
GOTO EVNT
FOR FHN=1,2,3
if FHN=""
QUIT
IF $DATA(FHDM14(FHI,FHN,FHDTML))
SET FHDMDAT=FHDM14(FHI,FHN,FHDTML)
DO PR1
+8 QUIT
ALL SET FHCT=0
SET (FHDT1,FHDT2,FHDTSV)=DT
+1 FOR FHI=DT-1:0
SET FHI=$ORDER(FHDM14(FHI))
if 'FHI
SET FHDT2=FHDTSV
if FHI'>0
QUIT
SET FHCT=FHCT+1
SET FHDTSV=FHI
if FHCT=1
SET FHDT1=FHI
FOR FHN=1,2,3
if FHN=""
QUIT
Begin DoDot:1
+2 SET FHJ=""
FOR
SET FHJ=$ORDER(FHDM14(FHI,FHN,FHJ))
if FHJ=""
QUIT
IF $DATA(FHDM14(FHI,FHN,FHJ))
SET FHDMDAT=FHDM14(FHI,FHN,FHJ)
DO PR1
End DoDot:1
+3 ;
EVNT 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 IF FHCNSFF=1
SET FHACT="C"
SET FHTXT="Outpatient Supplemental Feeding: ("_FHALML_") , "_FHLOCN_", Cancelled "_FHDTP
DO OPFILE^FHORX
+4 IF FHADSFF=1
SET FHACT="O"
SET FHTXT="Outpatient Supplemental Feeding: "_FHSFMEN_" ("_FHALML_") , "_FHLOCN_", "_FHDTP
DO OPFILE^FHORX
+5 QUIT
PR1 SET FHDTE=$PIECE(FHDMDAT,U,1)
SET ADM=$PIECE(FHDMDAT,U,2)
+1 IF '$GET(^FHPT(FHDFN,"OP",ADM,0))
QUIT
+2 SET FHDTC=FHDTC+1
SET DTP=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,0)),U,1)
DO DTP^FH
if FHDTC=1
SET FHDTP=DTP
+3 SET FHMEAL=$PIECE(^FHPT(FHDFN,"OP",ADM,0),U,4)
+4 IF $GET(FHIDFLG)
DO CAN
SET PNN=FHPNNSV
SET FHKK9=$SELECT(FHMEAL="B":5,FHMEAL="N":14,1:23)
SET FHSFQT9=$PIECE(FHPNNSV,"^",FHKK9,FHKK9+6)
if "^^^^^^^^"'[FHSFQT9
GOTO ADD
QUIT
+5 SET (PNO,WARD,FHLOCN,FHSFMEN)=""
+6 SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,0)),U,3)
if $GET(FHLOC)
SET FHLOCN=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
+7 IF $DATA(FHXSAV)
IF FHXSAV="@"
DO CAN
WRITE !," .. cancelled"
QUIT
+8 IF $DATA(X)
IF X="^"
QUIT
+9 IF $DATA(FHNMSAV)
IF FHNMSAV'=""
DO S1
QUIT
+10 DO CAD
+11 DO LIS^FHNO7
SET PNO=Y
+12 IF $GET(FHLIS)
IF $GET(NO)
SET PNO=^FHPT(FHDFN,"OP",ADM,"SF",NO,0)
+13 IF '$GET(FHLIS)
DO SFA
SET FHLIS=FHLIS+1
QUIT
+14 IF $GET(FHLIS)
SET NM=FHNMSAV
DO S1
+15 QUIT
CAD ;
+1 SET FHCFLG=""
+2 SET NO=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,"SF",0)),"^",3)
+3 IF NO
SET FHCFLG=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,"SF",NO,0)),"^",32)
+4 QUIT
ADDOUT ; Add outpt SF
+1 SET FHMEAL=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,0)),U,4)
SET FHSFMEN=""
+2 LOCK +^FHPT(FHDFN,"OP",ADM,"SF",0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+3 IF '$DATA(^FHPT(FHDFN,"OP",ADM,"SF",0))
SET ^FHPT(FHDFN,"OP",ADM,"SF",0)="^115.1627^^"
+4 SET X=^FHPT(FHDFN,"OP",ADM,"SF",0)
SET NO=$PIECE(X,"^",3)+1
SET ^(0)=$PIECE(X,"^",1,2)_"^"_NO_"^"_($PIECE(X,"^",4)+1)
+5 LOCK -^FHPT(FHDFN,"OP",ADM,"SF",0)
IF $DATA(^FHPT(FHDFN,"OP",ADM,"SF",NO))
GOTO ADDOUT
+6 IF FHMEAL="B"
SET $PIECE(PNN,U,13,20)="^^^^^^^"
SET $PIECE(PNN,U,21,28)="^^^^^^^"
+7 IF FHMEAL="N"
SET $PIECE(PNN,U,5,12)="^^^^^^^"
SET $PIECE(PNN,U,21,28)="^^^^^^^"
+8 IF FHMEAL="E"
SET $PIECE(PNN,U,5,12)="^^^^^^^"
SET $PIECE(PNN,U,13,20)="^^^^^^^"
+9 SET ^FHPT(FHDFN,"OP",ADM,"SF",NO,0)=NO_"^"_$PIECE(PNN,"^",2,99)
+10 if $GET(FHNMSAV)
SET FHSFMEN=$PIECE($GET(^FH(118.1,FHNMSAV,0)),U,1)
+11 SET FHADSFF=1
UPDOUT if NO
SET $PIECE(^FHPT(FHDFN,"OP",ADM,"SF",NO,0),"^",30,31)=NOW_"^"_DUZ
+1 QUIT
CANOUT ; Cancel outpt SF
+1 SET NO=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,"SF",0)),"^",3)
+2 if NO
SET $PIECE(^FHPT(FHDFN,"OP",ADM,"SF",NO,0),"^",32,33)=NOW_"^"_DUZ
+3 SET FHCNSFF=1
+4 QUIT
KIL GOTO KILL^XUSCLEAN
