- 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 Feb 18, 2025@23:18:44 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
