- FHNO7 ; HISC/REL - List Supplemental Fdgs. ;12/15/94 09:14
- ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- ;patch #5 - add outpatient SF. ;patch #8 - add allergy display
- LIS ; Display Feeding
- S (FHLOCN,Y)=""
- I WARD'="" S NAM=$P($G(^DPT(DFN,0)),"^",1) D CUR^FHORD7
- I WARD="",'$G(ADM) Q
- I WARD="" D PATNAME^FHOMUTL S NAM=FHPTNM,FHDIET=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,2) D
- .S:FHDIET Y=$P($G(^FH(111,FHDIET,0)),U,7) I 'FHDIET S FHRNUM=ADM D DIETPAT^FHOMRR1 S Y=FHDIETP
- .S FHLOC=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,3) S:$G(FHLOC) FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1)
- W:$E(IOST,1,2)="C-" @IOF W !!,NAM," " W:WARD'="" "( ",WARD," )" W:FHLOCN'="" "( ",FHLOCN," )"
- I WARD="",$D(^FHPT(FHDFN,"OP",ADM,0)) S DTP=$P(^FHPT(FHDFN,"OP",ADM,0),U,1) D DTP^FH W ?50,"Outpatient Date: ",DTP
- W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
- D ALG^FHCLN W !," Allergies: ",$S(ALG="":"None on file",1:ALG)
- I WARD'="" S NO=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",7),Y=$S('NO:"",1:$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)))
- I WARD="" S NO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),"^",3),Y=$S('NO:"",1:$G(^FHPT(FHDFN,"OP",ADM,"SF",NO,0))) I $P(Y,"^",32)'="" S (NO,Y)=""
- I WARD="" W:$D(FHMEAL) ?50,"MEAL: ",$S(FHMEAL="B":"Breakfast",FHMEAL="N":"Noon",1:"Evening")
- L1 ; Display SF Order
- I '$D(WARD) S WARD=""
- S NM=$P(Y,"^",4) W !,"Feeding Menu: ",$S('NM:"None",1:$P(^FH(118.1,NM,0),"^",1)) Q:'NO S DTP=$P(Y,"^",30) D DTP^FH W ?50,"Reviewed: ",DTP
- I WARD'="" W !!,"10AM",?26,"2PM",?52,"8PM",!,"----------------------- ----------------------- -----------------------"
- I WARD="",$D(FHMEAL),FHMEAL="B" W !!,"10AM",!,"----------------------------------------------------------------------------"
- I WARD="",$D(FHMEAL),FHMEAL="N" W !!,"2PM",!,"-----------------------------------------------------------------------------"
- I WARD="",$D(FHMEAL),FHMEAL="E" W !!,"8PM",!,"-----------------------------------------------------------------------------"
- K N F K1=1:1:3 F K2=1:1:4 S N(K1,K2)=""
- S L=4 F K1=1:1:3 S K=0 F K2=1:1:4 S Z=$P(Y,"^",L+1),Q=$P(Y,"^",L+2),L=L+2 I Z'="" S:'Q Q=1 S K=K+1,N(K1,K)=$J(Q,2)_" "_$P($G(^FH(118,Z,0)),"^",1)
- I WARD'="" F K2=1:1:4 W !,N(1,K2),?26,N(2,K2),?52,N(3,K2)
- I WARD="",$D(FHMEAL) F K2=1:1:4 W !,$S(FHMEAL="B":N(1,K2),FHMEAL="N":N(2,K2),1:N(3,K2))
- W:$P(Y,"^",34)'="" !!,"Diet Pattern Associated: ",$S($P(Y,"^",34)="Y":"YES",1:"NO")
- Q
- EN2 ; Supplemental Feeding Inquiry
- K FHSFLG,FHDFN,FHPTNM,FHMEAL,ADM,NO,Y,X
- S FHALL=1 D ^FHOMDPA G:'FHDFN KIL
- S WARD="" I $G(DFN)'="" S WARD=$G(^DPT(DFN,.1)) I WARD'="" D LIS G EN2
- I WARD="" D SF
- I '$G(FHSFLG) W !,"NO OUTPATIENT DATA ON FILE for today's date and the future!!" G EN2
- D SF0
- D:$G(ADM) LIS G EN2
- ;
- SF ;LIST outpatient SF
- W @IOF,!,"Outpatient Recurring Meals... "
- S FHQ=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 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,FHSF)=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
- .S FHSFLG=1
- .W !,DTP,?12,FH11
- .S FHDATL=$L(DTP)+13+$L(FH11)
- .S:$D(^FHPT(FHDFN,"OP",FHJ,"SF",0)) FHSF=$P(^FHPT(FHDFN,"OP",FHJ,"SF",0),U,3)
- .Q:'$G(FHSF)
- .S FHDA15SF=$G(^FHPT(FHDFN,"OP",FHJ,"SF",FHSF,0))
- .Q:$P(FHDA15SF,U,32)
- .S FHDASFNM=$P($G(^FH(118.1,$P(FHDA15SF,U,4),0)),U,1)
- .W ?40," (",FHDASFNM,")"
- W !
- Q
- ;
- ;K DIC
- ;S DIC("S")="I $P(^FHPT(FHDFN,""OP"",+Y,0),U,1)>(DT-1),($P(^(0),U,15)'=""C"")"
- ;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="^FHPT(FHDFN,""OP"",",DIC(0)="Q",DA=FHDFN,X="??" D ^DIC
- SF0 ;ask for outpatient SF.
- 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
- S FHMEAL=$P($G(^FHPT(FHDFN,"OP",ADM,0)),U,4)
- Q
- ;
- OIS ;Outpatient Individualized SF
- Q:'NM
- I '$D(FHX) S FHX="ALL"
- I (FHX="ALL")!($L(FHX)=3) S FHIDI="BNE"
- I $L(FHX)=2 S FHIDI=$S(FHX="NB":"BN",FHX="EB":"BE",FHX="EN":"NE",1:FHX)
- I $L(FHX)=1 S FHIDI=FHX
- F FHII=1,2,3 S FHMEAL=$E(FHIDI,FHII) Q:FHII'>0!(FHMEAL="") D G0
- D G6
- Q
- G0 ;process each meals for individualized SF.
- S T1=$S(FHMEAL="B":"10am",FHMEAL="N":"2pm",1:"8pm")
- S KK=$S(FHMEAL="B":1,FHMEAL="N":5,1:9)
- ;I NM'=1 D CAN^FHNO5,ADD^FHNO5
- 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^FHNO5 Q
- Q
- ;
- G6 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^FHNO5 D CAN^FHNO5
- S FHPNNSV=PNN
- S FHIDFLG=1
- Q
- ;
- CPRSF ;check previous SF
- K PNN
- S (FHDAT,FHSF)=""
- CPRS1 I FHSF="" S FHSF=$O(^FHPT(FHDFN,"OP",999999999),-1)
- E S FHSF=$O(^FHPT(FHDFN,"OP",FHSF),-1)
- Q:'$G(FHSF)
- S FHDAT=$G(^FHPT(FHDFN,"OP",FHSF,0)),FHPRML=$P(FHDAT,U,4),FHPRCN=$P(FHDAT,U,15),FHLOCN=$P(FHDAT,U,3)
- I (FHPRML'=FHMEAL)!(FHPRCN="C")!'$D(^FHPT(FHDFN,"OP",FHSF,"SF",0)) G CPRS1
- S FHI=$P($G(^FHPT(FHDFN,"OP",FHSF,"SF",0)),U,3) Q:FHI'>0
- S PNN=$G(^FHPT(FHDFN,"OP",FHSF,"SF",FHI,0)),FHSFCX=$P(PNN,U,32)
- I $G(FHSFCX) K PNN G CPRS1
- I $P(PNN,U,34)="Y" K PNN Q
- S $P(PNN,U,3)=DUZ,FHNMSAV=$P(PNN,U,4)
- Q
- PPRSF ;PROCESS previous SF
- Q:'$D(PNN)
- D NOW^%DTC S NOW=%
- D ADDOUT^FHNO5
- Q
- SFEVNT ;
- 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
- I FHADSFF=1 S FHACT="O",FHTXT="Outpatient Supplemental Feeding: "_FHSFMEN_" ("_FHMEAL_") , "_FHLOCN_", "_FHDTP D OPFILE^FHORX
- Q
- ;
- KIL G KILL^XUSCLEAN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHNO7 7794 printed Jan 18, 2025@02:53:37 Page 2
- FHNO7 ; HISC/REL - List Supplemental Fdgs. ;12/15/94 09:14
- +1 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- +2 ;patch #5 - add outpatient SF. ;patch #8 - add allergy display
- LIS ; Display Feeding
- +1 SET (FHLOCN,Y)=""
- +2 IF WARD'=""
- SET NAM=$PIECE($GET(^DPT(DFN,0)),"^",1)
- DO CUR^FHORD7
- +3 IF WARD=""
- IF '$GET(ADM)
- QUIT
- +4 IF WARD=""
- DO PATNAME^FHOMUTL
- SET NAM=FHPTNM
- SET FHDIET=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,0)),U,2)
- Begin DoDot:1
- +5 if FHDIET
- SET Y=$PIECE($GET(^FH(111,FHDIET,0)),U,7)
- IF 'FHDIET
- SET FHRNUM=ADM
- DO DIETPAT^FHOMRR1
- SET Y=FHDIETP
- +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)
- End DoDot:1
- +7 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- WRITE !!,NAM," "
- if WARD'=""
- WRITE "( ",WARD," )"
- if FHLOCN'=""
- WRITE "( ",FHLOCN," )"
- +8 IF WARD=""
- IF $DATA(^FHPT(FHDFN,"OP",ADM,0))
- SET DTP=$PIECE(^FHPT(FHDFN,"OP",ADM,0),U,1)
- DO DTP^FH
- WRITE ?50,"Outpatient Date: ",DTP
- +9 WRITE !!,"Current Diet: ",$SELECT(Y'="":Y,1:"No current order")
- +10 DO ALG^FHCLN
- WRITE !," Allergies: ",$SELECT(ALG="":"None on file",1:ALG)
- +11 IF WARD'=""
- SET NO=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",7)
- SET Y=$SELECT('NO:"",1:$GET(^FHPT(FHDFN,"A",ADM,"SF",NO,0)))
- +12 IF WARD=""
- SET NO=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,"SF",0)),"^",3)
- SET Y=$SELECT('NO:"",1:$GET(^FHPT(FHDFN,"OP",ADM,"SF",NO,0)))
- IF $PIECE(Y,"^",32)'=""
- SET (NO,Y)=""
- +13 IF WARD=""
- if $DATA(FHMEAL)
- WRITE ?50,"MEAL: ",$SELECT(FHMEAL="B":"Breakfast",FHMEAL="N":"Noon",1:"Evening")
- L1 ; Display SF Order
- +1 IF '$DATA(WARD)
- SET WARD=""
- +2 SET NM=$PIECE(Y,"^",4)
- WRITE !,"Feeding Menu: ",$SELECT('NM:"None",1:$PIECE(^FH(118.1,NM,0),"^",1))
- if 'NO
- QUIT
- SET DTP=$PIECE(Y,"^",30)
- DO DTP^FH
- WRITE ?50,"Reviewed: ",DTP
- +3 IF WARD'=""
- WRITE !!,"10AM",?26,"2PM",?52,"8PM",!,"----------------------- ----------------------- -----------------------"
- +4 IF WARD=""
- IF $DATA(FHMEAL)
- IF FHMEAL="B"
- WRITE !!,"10AM",!,"----------------------------------------------------------------------------"
- +5 IF WARD=""
- IF $DATA(FHMEAL)
- IF FHMEAL="N"
- WRITE !!,"2PM",!,"-----------------------------------------------------------------------------"
- +6 IF WARD=""
- IF $DATA(FHMEAL)
- IF FHMEAL="E"
- WRITE !!,"8PM",!,"-----------------------------------------------------------------------------"
- +7 KILL N
- FOR K1=1:1:3
- FOR K2=1:1:4
- SET N(K1,K2)=""
- +8 SET L=4
- FOR K1=1:1:3
- SET K=0
- FOR K2=1:1:4
- SET Z=$PIECE(Y,"^",L+1)
- SET Q=$PIECE(Y,"^",L+2)
- SET L=L+2
- IF Z'=""
- if 'Q
- SET Q=1
- SET K=K+1
- SET N(K1,K)=$JUSTIFY(Q,2)_" "_$PIECE($GET(^FH(118,Z,0)),"^",1)
- +9 IF WARD'=""
- FOR K2=1:1:4
- WRITE !,N(1,K2),?26,N(2,K2),?52,N(3,K2)
- +10 IF WARD=""
- IF $DATA(FHMEAL)
- FOR K2=1:1:4
- WRITE !,$SELECT(FHMEAL="B":N(1,K2),FHMEAL="N":N(2,K2),1:N(3,K2))
- +11 if $PIECE(Y,"^",34)'=""
- WRITE !!,"Diet Pattern Associated: ",$SELECT($PIECE(Y,"^",34)="Y":"YES",1:"NO")
- +12 QUIT
- EN2 ; Supplemental Feeding Inquiry
- +1 KILL FHSFLG,FHDFN,FHPTNM,FHMEAL,ADM,NO,Y,X
- +2 SET FHALL=1
- DO ^FHOMDPA
- if 'FHDFN
- GOTO KIL
- +3 SET WARD=""
- IF $GET(DFN)'=""
- SET WARD=$GET(^DPT(DFN,.1))
- IF WARD'=""
- DO LIS
- GOTO EN2
- +4 IF WARD=""
- DO SF
- +5 IF '$GET(FHSFLG)
- WRITE !,"NO OUTPATIENT DATA ON FILE for today's date and the future!!"
- GOTO EN2
- +6 DO SF0
- +7 if $GET(ADM)
- DO LIS
- GOTO EN2
- +8 ;
- SF ;LIST outpatient SF
- +1 WRITE @IOF,!,"Outpatient Recurring Meals... "
- +2 SET FHQ=0
- +3 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
- +4 SET FHDA15=$GET(^FHPT(FHDFN,"OP",FHJ,0))
- +5 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
- +6 SET Y=$PIECE(FHDA15,U,1)
- XECUTE ^DD("DD")
- SET DTP=Y
- +7 SET (FHCOFLG,FHDATL,FHSF)=0
- +8 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
- +9 SET FHSFLG=1
- +10 WRITE !,DTP,?12,FH11
- +11 SET FHDATL=$LENGTH(DTP)+13+$LENGTH(FH11)
- +12 if $DATA(^FHPT(FHDFN,"OP",FHJ,"SF",0))
- SET FHSF=$PIECE(^FHPT(FHDFN,"OP",FHJ,"SF",0),U,3)
- +13 if '$GET(FHSF)
- QUIT
- +14 SET FHDA15SF=$GET(^FHPT(FHDFN,"OP",FHJ,"SF",FHSF,0))
- +15 if $PIECE(FHDA15SF,U,32)
- QUIT
- +16 SET FHDASFNM=$PIECE($GET(^FH(118.1,$PIECE(FHDA15SF,U,4),0)),U,1)
- +17 WRITE ?40," (",FHDASFNM,")"
- End DoDot:1
- +18 WRITE !
- +19 QUIT
- +20 ;
- +21 ;K DIC
- +22 ;S DIC("S")="I $P(^FHPT(FHDFN,""OP"",+Y,0),U,1)>(DT-1),($P(^(0),U,15)'=""C"")"
- +23 ;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"")"
- +24 ;S DIC="^FHPT(FHDFN,""OP"",",DIC(0)="Q",DA=FHDFN,X="??" D ^DIC
- SF0 ;ask for outpatient SF.
- +1 KILL DIC
- SET DIC(0)="AEQM"
- +2 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"")"
- +3 SET DIC("S")="I $P(^FHPT(FHDFN,""OP"",+Y,0),U,1)>(DT-1),($P(^(0),U,15)'=""C"")"
- +4 SET DIC="^FHPT(FHDFN,""OP"","
- +5 SET DIC("?")="Select a Date, '^' to exit"
- +6 SET DIC("A")="Select the Outpatient Date :"
- DO ^DIC
- KILL DIC
- if (Y'>0)!$DATA(DTOUT)
- QUIT
- +7 SET ADM=+Y
- +8 SET FHMEAL=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,0)),U,4)
- +9 QUIT
- +10 ;
- OIS ;Outpatient Individualized SF
- +1 if 'NM
- QUIT
- +2 IF '$DATA(FHX)
- SET FHX="ALL"
- +3 IF (FHX="ALL")!($LENGTH(FHX)=3)
- SET FHIDI="BNE"
- +4 IF $LENGTH(FHX)=2
- SET FHIDI=$SELECT(FHX="NB":"BN",FHX="EB":"BE",FHX="EN":"NE",1:FHX)
- +5 IF $LENGTH(FHX)=1
- SET FHIDI=FHX
- +6 FOR FHII=1,2,3
- SET FHMEAL=$EXTRACT(FHIDI,FHII)
- if FHII'>0!(FHMEAL="")
- QUIT
- DO G0
- +7 DO G6
- +8 QUIT
- G0 ;process each meals for individualized SF.
- +1 SET T1=$SELECT(FHMEAL="B":"10am",FHMEAL="N":"2pm",1:"8pm")
- +2 SET KK=$SELECT(FHMEAL="B":1,FHMEAL="N":5,1:9)
- +3 ;I NM'=1 D CAN^FHNO5,ADD^FHNO5
- +4 SET DIC="^FH(118,"
- SET DIC(0)="EQM"
- SET DIC("S")="I $P(^(0),U,3)'=""Y"""
- +5 ;
- G1 if KK>12
- GOTO G5
- +1 IF ((WARD="")&(FHMEAL="B")&(KK>4))!((WARD="")&(FHMEAL="N")&(KK>8))
- GOTO G5
- +2 ;I WARD'="" S T1=$P("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)_"// "
- +6 ;
- 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
- +6 ;
- G3 SET OLD=$PIECE(PNN,"^",P1+1)
- +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
- +6 ;
- 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 ;I X="" D CAN^FHNO5 Q
- +2 QUIT
- +3 ;
- G6 SET P1=$PIECE(PNN,"^",29)
- if P1=""
- SET P1="D"
- WRITE !!,"Dietary or Therapeutic? ",P1,"// "
- READ Y:DTIME
- if '$TEST!("^"[Y)
- SET Y=P1
- +1 if $PIECE("dietary",Y,1)=""
- SET Y="D"
- if $PIECE("therapeutic",Y,1)=""
- SET Y="T"
- +2 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
- +3 SET $PIECE(X,"^",25)=$EXTRACT(Y,1)
- SET PNN=$PIECE(PNN,"^",1,4)_"^"_X
- +4 ;G:$P(PNO,"^",5,29)=X UPD^FHNO5 D CAN^FHNO5
- +5 SET FHPNNSV=PNN
- +6 SET FHIDFLG=1
- +7 QUIT
- +8 ;
- CPRSF ;check previous SF
- +1 KILL PNN
- +2 SET (FHDAT,FHSF)=""
- CPRS1 IF FHSF=""
- SET FHSF=$ORDER(^FHPT(FHDFN,"OP",999999999),-1)
- +1 IF '$TEST
- SET FHSF=$ORDER(^FHPT(FHDFN,"OP",FHSF),-1)
- +2 if '$GET(FHSF)
- QUIT
- +3 SET FHDAT=$GET(^FHPT(FHDFN,"OP",FHSF,0))
- SET FHPRML=$PIECE(FHDAT,U,4)
- SET FHPRCN=$PIECE(FHDAT,U,15)
- SET FHLOCN=$PIECE(FHDAT,U,3)
- +4 IF (FHPRML'=FHMEAL)!(FHPRCN="C")!'$DATA(^FHPT(FHDFN,"OP",FHSF,"SF",0))
- GOTO CPRS1
- +5 SET FHI=$PIECE($GET(^FHPT(FHDFN,"OP",FHSF,"SF",0)),U,3)
- if FHI'>0
- QUIT
- +6 SET PNN=$GET(^FHPT(FHDFN,"OP",FHSF,"SF",FHI,0))
- SET FHSFCX=$PIECE(PNN,U,32)
- +7 IF $GET(FHSFCX)
- KILL PNN
- GOTO CPRS1
- +8 IF $PIECE(PNN,U,34)="Y"
- KILL PNN
- QUIT
- +9 SET $PIECE(PNN,U,3)=DUZ
- SET FHNMSAV=$PIECE(PNN,U,4)
- +10 QUIT
- PPRSF ;PROCESS previous SF
- +1 if '$DATA(PNN)
- QUIT
- +2 DO NOW^%DTC
- SET NOW=%
- +3 DO ADDOUT^FHNO5
- +4 QUIT
- SFEVNT ;
- +1 SET FHDTC=0
- +2 SET FHLOCN=""
- IF $DATA(FHLOC)
- IF $GET(FHLOC)
- IF $DATA(^FH(119.6,FHLOC,0))
- SET FHLOCN=$PIECE(^(0),U,1)
- +3 SET FHDTC=FHDTC+1
- SET DTP=FHOSTDT
- DO DTP^FH
- if FHDTC=1
- SET FHDTP=DTP
- +4 SET DTP=$PIECE(ENDT,".",1)
- DO DTP^FH
- +5 IF DTP'=FHDTP
- SET FHDTP=FHDTP_" to "_DTP
- +6 IF FHADSFF=1
- SET FHACT="O"
- SET FHTXT="Outpatient Supplemental Feeding: "_FHSFMEN_" ("_FHMEAL_") , "_FHLOCN_", "_FHDTP
- DO OPFILE^FHORX
- +7 QUIT
- +8 ;
- KIL GOTO KILL^XUSCLEAN