- FHORT1 ; HISC/REL/NCA - Tubefeeding ;8/19/96 14:55 ;
- ;;5.5;DIETETICS;**1**;Jan 28, 2005
- S ALL=0 D ^FHDPA G:'DFN KIL G:'FHDFN KIL
- ; Set HL7
- D E0 G:'DFN KIL G:'FHDFN KIL S TF=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",4) D:TF CAN^FHORT2 D ^FHORT11 G:'FHWF KIL
- D TF^FHWOR5 F FHTF=0:0 S FHTF=$O(TUN(FHTF)) Q:FHTF<1 S XX=$G(TUN(FHTF)) D TF1^FHWOR5
- D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG
- G KIL
- E0 ; Process tubefeeding
- S (NO,T1,T2,T3,T4)=0,(PRO,TFCOM)="" K TUN
- S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4) G:TF<1 E3
- W !!,"An ACTVE TUBEFEEDING ORDER exists!" D DIS^FHORT2
- R !!,"Do You Wish to Cancel the Existing Tubefeeding and Enter a New One? Y// ",ANS:DTIME I '$T!(ANS="^") W *7,!!,"No order entered!" S (DFN,FHDFN)="" Q
- S:ANS="" ANS="Y" S X=ANS D TR^FH S ANS=X
- I $P("YES",ANS,1)'="",$P("NO",ANS,1)'="" W !!,"Answer YES to Cancel Existing Order and Enter a New One.",!,"Answer NO to Edit the Existing Tubefeeding Order.",!,"Enter ""^"" to Exit Completely." G E0
- I ANS?1"Y".E K TUN S TFCOM="",NO=0
- I ANS'?1"Y".E W *7,!!,"Edit the Existing Tubefeeding." S TFCOM=$P(T,"^",5)
- I NO=5 W !!,*7,"There are FIVE products already!",!,"You may edit them, or delete a product before adding any."
- E3 D ^FHORT10 Q:'DFN Q:'FHDFN
- I $O(TUN(0))="" W !!,"No Tubefeeding Products selected." G AB
- S (TC,TK)=0 W !
- F K=0:0 S K=$O(TUN(K)) Q:K<1 D
- .S TC=TC+$P(TUN(K),"^",4)+$P(TUN(K),"^",5)
- .S TK=TK+$P(TUN(K),"^",6),STR=$P(TUN(K),"^",2)
- .S PRO=$P(TUN(K),"^",1)
- .W !,"Product: ",$P($G(^FH(118.2,PRO,0)),"^",1),", "
- .W $S(STR=4:"Full",STR=2:"1/2",STR=1:"1/4",1:"3/4"),", "
- .W $P(TUN(K),"^",3)
- .Q
- W !!,"Total Kcal: ",TK,?36,"Total Quantity: ",TC
- I TC>5000 W *7,!!,"WARNING: Total amount exceeds 5000ml: ",TC," ml",!,"Please Edit the Tubefeeding and Modify." G E3
- E31 R !!,"Is this Correct ? Y// ",X:DTIME G:'$T!(X="^") AB S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G E31
- G:X'?1"Y".E E3
- G:TC>5000 AB
- E4 W !,"Comment: ",$S(TFCOM'="":TFCOM_"// ",1:"") R X:DTIME G:'$T!(X[U) AB I X'?.ANP W *7," ??" G E4
- I $L(X)>160!(X?1"?".E) W *7,!,"Enter a comment of up to 160 characters" G E4
- I X'="" S TFCOM=X
- E5 R !,"Cancel all current or future tray orders? Y// ",YN:DTIME G:'$T!(YN["^") AB 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 E5
- S CAN=YN?1"Y".E
- E6 Q:FHWF=2 R !,"Ok to Enter Order? Y// ",YN:DTIME G:'$T!(YN["^") AB 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 E6
- G:YN'?1"Y".E AB Q
- KIL K %,%H,%I,A,A1,A2,A3,A4,ADM,ALL,ANS,C,CAN,COM,TFCOM,CS,D1,D2,D3,D4,FHDFN,DFN,DX,E,PID,BID,DIC,FHD,FHDR,FHORD,FLG,FLG1,FHLD,FHOR,FHPAR,FHWF,FHPV,FHTF,FHDU,I,K,NO,NOW,DTP,P,P1,P2,POP
- K OLDT,FHSAV,FHORN,MNUM,PR,PRO,NU,QUA,S1,S2,S3,STR,ST1,ST3,T,T1,T2,T3,T4,TC,TK,TF,TF2,TP,TT,TU,TUN,TW,TYP,UNT,WARD,WRD,X,X1,X2,XX,Y,Y0,Y2,YN,YY,Z,Z1,ZZ Q
- AB W *7,!!,"Tubefeeding Order TERMINATED - No order entered!" S (DFN,FHDFN)="" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORT1 3000 printed Dec 13, 2024@01:53:52 Page 2
- FHORT1 ; HISC/REL/NCA - Tubefeeding ;8/19/96 14:55 ;
- +1 ;;5.5;DIETETICS;**1**;Jan 28, 2005
- +2 SET ALL=0
- DO ^FHDPA
- if 'DFN
- GOTO KIL
- if 'FHDFN
- GOTO KIL
- +3 ; Set HL7
- +4 DO E0
- if 'DFN
- GOTO KIL
- if 'FHDFN
- GOTO KIL
- SET TF=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",4)
- if TF
- DO CAN^FHORT2
- DO ^FHORT11
- if 'FHWF
- GOTO KIL
- +5 DO TF^FHWOR5
- FOR FHTF=0:0
- SET FHTF=$ORDER(TUN(FHTF))
- if FHTF<1
- QUIT
- SET XX=$GET(TUN(FHTF))
- DO TF1^FHWOR5
- +6 if $DATA(MSG)
- DO MSG^XQOR("FH EVSEND OR",.MSG)
- KILL MSG
- +7 GOTO KIL
- E0 ; Process tubefeeding
- +1 SET (NO,T1,T2,T3,T4)=0
- SET (PRO,TFCOM)=""
- KILL TUN
- +2 SET TF=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",4)
- if TF<1
- GOTO E3
- +3 WRITE !!,"An ACTVE TUBEFEEDING ORDER exists!"
- DO DIS^FHORT2
- +4 READ !!,"Do You Wish to Cancel the Existing Tubefeeding and Enter a New One? Y// ",ANS:DTIME
- IF '$TEST!(ANS="^")
- WRITE *7,!!,"No order entered!"
- SET (DFN,FHDFN)=""
- QUIT
- +5 if ANS=""
- SET ANS="Y"
- SET X=ANS
- DO TR^FH
- SET ANS=X
- +6 IF $PIECE("YES",ANS,1)'=""
- IF $PIECE("NO",ANS,1)'=""
- WRITE !!,"Answer YES to Cancel Existing Order and Enter a New One.",!,"Answer NO to Edit the Existing Tubefeeding Order.",!,"Enter ""^"" to Exit Completely."
- GOTO E0
- +7 IF ANS?1"Y".E
- KILL TUN
- SET TFCOM=""
- SET NO=0
- +8 IF ANS'?1"Y".E
- WRITE *7,!!,"Edit the Existing Tubefeeding."
- SET TFCOM=$PIECE(T,"^",5)
- +9 IF NO=5
- WRITE !!,*7,"There are FIVE products already!",!,"You may edit them, or delete a product before adding any."
- E3 DO ^FHORT10
- if 'DFN
- QUIT
- if 'FHDFN
- QUIT
- +1 IF $ORDER(TUN(0))=""
- WRITE !!,"No Tubefeeding Products selected."
- GOTO AB
- +2 SET (TC,TK)=0
- WRITE !
- +3 FOR K=0:0
- SET K=$ORDER(TUN(K))
- if K<1
- QUIT
- Begin DoDot:1
- +4 SET TC=TC+$PIECE(TUN(K),"^",4)+$PIECE(TUN(K),"^",5)
- +5 SET TK=TK+$PIECE(TUN(K),"^",6)
- SET STR=$PIECE(TUN(K),"^",2)
- +6 SET PRO=$PIECE(TUN(K),"^",1)
- +7 WRITE !,"Product: ",$PIECE($GET(^FH(118.2,PRO,0)),"^",1),", "
- +8 WRITE $SELECT(STR=4:"Full",STR=2:"1/2",STR=1:"1/4",1:"3/4"),", "
- +9 WRITE $PIECE(TUN(K),"^",3)
- +10 QUIT
- End DoDot:1
- +11 WRITE !!,"Total Kcal: ",TK,?36,"Total Quantity: ",TC
- +12 IF TC>5000
- WRITE *7,!!,"WARNING: Total amount exceeds 5000ml: ",TC," ml",!,"Please Edit the Tubefeeding and Modify."
- GOTO E3
- E31 READ !!,"Is this Correct ? Y// ",X:DTIME
- if '$TEST!(X="^")
- GOTO AB
- if X=""
- SET X="Y"
- DO TR^FH
- IF $PIECE("YES",X,1)'=""
- IF $PIECE("NO",X,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO E31
- +1 if X'?1"Y".E
- GOTO E3
- +2 if TC>5000
- GOTO AB
- E4 WRITE !,"Comment: ",$SELECT(TFCOM'="":TFCOM_"// ",1:"")
- READ X:DTIME
- if '$TEST!(X[U)
- GOTO AB
- IF X'?.ANP
- WRITE *7," ??"
- GOTO E4
- +1 IF $LENGTH(X)>160!(X?1"?".E)
- WRITE *7,!,"Enter a comment of up to 160 characters"
- GOTO E4
- +2 IF X'=""
- SET TFCOM=X
- E5 READ !,"Cancel all current or future tray orders? Y// ",YN:DTIME
- if '$TEST!(YN["^")
- GOTO AB
- 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 E5
- +1 SET CAN=YN?1"Y".E
- E6 if FHWF=2
- QUIT
- READ !,"Ok to Enter Order? Y// ",YN:DTIME
- if '$TEST!(YN["^")
- GOTO AB
- 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 E6
- +1 if YN'?1"Y".E
- GOTO AB
- QUIT
- KIL KILL %,%H,%I,A,A1,A2,A3,A4,ADM,ALL,ANS,C,CAN,COM,TFCOM,CS,D1,D2,D3,D4,FHDFN,DFN,DX,E,PID,BID,DIC,FHD,FHDR,FHORD,FLG,FLG1,FHLD,FHOR,FHPAR,FHWF,FHPV,FHTF,FHDU,I,K,NO,NOW,DTP,P,P1,P2,POP
- +1 KILL OLDT,FHSAV,FHORN,MNUM,PR,PRO,NU,QUA,S1,S2,S3,STR,ST1,ST3,T,T1,T2,T3,T4,TC,TK,TF,TF2,TP,TT,TU,TUN,TW,TYP,UNT,WARD,WRD,X,X1,X2,XX,Y,Y0,Y2,YN,YY,Z,Z1,ZZ
- QUIT
- AB WRITE *7,!!,"Tubefeeding Order TERMINATED - No order entered!"
- SET (DFN,FHDFN)=""
- QUIT