- FHORD6 ; HISC/REL/NCA/JH/RTK - Diet Inquiry ;5/3/01 11:04
- ;;5.5;DIETETICS;**1,5**;Jan 28, 2005;Build 53
- S FHALL=1 D ^FHOMDPA I 'FHDFN G KIL
- D MONUM^FHOMUTL I FHNUM="" Q
- I FHDFN,DFN="" D ^FHOMPP Q ;profile for file #200 outpatients
- I FHDFN,$G(^DPT(DFN,.1))="" D ^FHOMPP Q ;profile for file #2 outpts
- K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) S FHPGM="F0^FHORD6",FHLST="FHDFN^DFN^PID^ADM^FHNUM" D EN2^FH G KIL
- U IO D F0 D ^%ZISC K %ZIS,IOP G FHORD6
- F0 ; Display Diet
- D NOW^%DTC S NOW=%,DT=NOW\1,QT=""
- S WARD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8) S:WARD WARD=$P($G(^FH(119.6,WARD,0)),"^",1)
- S Y(0)=^DPT(DFN,0),SEX=$P(Y(0),"^",2),DOB=$P(Y(0),"^",3)
- S AGE=$E(NOW,1,3)-$E(DOB,1,3)-($E(NOW,4,7)<$E(DOB,4,7)),X=$P($G(^DPT(DFN,.101)),"^",1),RM=$E(WARD,1,15) S:X'="" RM=RM_"/"_X
- S QT="",PG=0 D HDR
- D ALG^FHCLN I ALG'="" W !!,"Allergies: ",ALG
- K N S P1=1 F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0),M=$P(X,"^",2) S:M="A" M="BNE" D SP
- I $O(N(""))="" W !!,"No Food Preferences on file",! G A0
- W !!,"Food Preferences Currently on file",!!?23,"Likes",?57,"Dislikes",!
- W ! S (M,MM)="" F S M=$O(N(M)) Q:M="" I $D(N(M)) W $P(M,"~",2) D Q:QT="^" S MM=M ;P32
- . S (P1,P2)=0 F S:P1'="" P1=$O(N(M,"L",P1)) S X1=$S(P1>0:N(M,"L",P1),1:"") S:P2'="" P2=$O(N(M,"D",P2)) S X2=$S(P2>0:N(M,"D",P2),1:"") Q:P1=""&(P2="") D W0 Q:QT="^" W:MM'=M ! ;P32
- . Q
- W ! K L,N,M,M1,M2
- G:QT="^" KIL ;P32
- A0 S X(0)=^FHPT(FHDFN,"A",ADM,0),X=$P(X(0),"^",10) G:X="" F1
- D:$Y>(IOSL-3) HDR G:QT="^" KIL W !!,"Isolation/Precaution Type is ",$P($G(^FH(119.4,X,0)),"^",1)
- F1 D CUR^FHORD7 D:$Y>(IOSL-6) HDR G:QT="^" KIL W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
- I Y'="",FHORD>0 I $D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1)) S COM=^(1) W:COM'="" !,"Comment: ",COM
- S TYP=$P(X,"^",8) I TYP'="" W !,"Service: ",$S(TYP="T":"Tray",TYP="D":"Dining Room",1:"Cafeteria")
- S DTP=$P(X(0),"^",3) I DTP D DTP^FH W !,"Expires: ",DTP
- S TF=$P(X(0),"^",4) G:TF<1 F2
- S Y=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
- S DTP=$P(Y,"^",1),COM=$P(Y,"^",5),TQU=$P(Y,"^",6),CAL=$P(Y,"^",7)
- D DTP^FH W !!,"Tubefeed Ordered: ",DTP
- F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 S XY=^(TF2,0) D LP
- W !,"Total Quantity: ",TQU," ml",?42,"Total KCAL: ",CAL
- W:COM'="" !,"Comment: ",COM
- F2 S NO=$P(X(0),"^",7),Y=$S('NO:"",1:^FHPT(FHDFN,"A",ADM,"SF",NO,0)) D:$Y>(IOSL-3) HDR G:QT="^" KIL
- S L=$P(Y,"^",4) W !!,"Supplemental Feeding: ",$S('L:"No Order",1:$P(^FH(118.1,L,0),"^",1)) G:'NO F3
- S DTP=$P(Y,"^",30) D DTP^FH W ?50,"Reviewed: ",DTP
- S L=4 F K1=1:1:3 S K=0,N(K1)="" F K2=1:1:4 S Z=$P(Y,U,L+1),Q=$P(Y,U,L+2),L=L+2 I Z'="" S:'Q Q=1 S:N(K1)'="" N(K1)=N(K1)_"; " S N(K1)=N(K1)_Q_" "_$P(^FH(118,Z,0),"^",1)
- D:$Y>(IOSL-4) HDR G:QT="^" KIL F K1=1:1:3 I N(K1)'="" W !?5,$P("10am; 2pm; 8pm",";",K1),":",?13,N(K1)
- F3 G ^FHORD61
- LP S TUN=$P(XY,"^",1),STR=$P(XY,"^",2),QUA=$P(XY,"^",3)
- I QUA["CC" S QUAFI=$P(QUA,"CC",1),QUASE=$P(QUA,"CC",2),QUA=QUAFI_"ML"_QUASE
- W !,"Product: ",$P($G(^FH(118.2,TUN,0)),"^",1),", ",$S(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")," Str., ",QUA Q
- SP S Z=$G(^FH(115.2,+X,0)),L1=$P(Z,"^",1),KK=$P(Z,"^",2),M1="",DAS=$P(X,"^",4)
- I KK="L" S Q=$P(X,"^",3),L1=$S(Q:Q,1:1)_" "_L1
- I M="BNE" S M1="1~All Meals" G SP1
- S Z1=$E(M,1) I Z1'="" S M1=$S(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
- S Z1=$E(M,2) I Z1'="" S M1=M1_","_$S(Z1="B":"Break",Z1="N":"Noon",1:"Even")
- SP1 S:'$D(N(M1,KK,P1)) N(M1,KK,P1)="" I $L(N(M1,KK,P1))+$L(L1)<255 S N(M1,KK,P1)=N(M1,KK,P1)_$S(N(M1,KK,P1)="":"",1:", ")_L1_$S(DAS="Y":" (D)",1:"")
- E S:'$D(N(M1,KK,K)) N(M1,KK,K)="" S N(M1,KK,K)=L1_$S(DAS="Y":" (D)",1:"") S P1=K
- Q
- W0 I X1'="" W ?12 S X=X1 D W1 S X1=X
- I X2'="" W ?46 S X=X2 D W1 S X2=X
- Q:X1=""&(X2="") D:$Y'<(IOSL-2) HDR Q:QT="^" W ! G W0 ;P32
- W1 I $L(X)<34 W X S X="" Q
- F KK=35:-1:1 Q:$E(X,KK-1,KK)=", "
- W $E(X,1,KK-2) S X=$E(X,KK+1,999) Q
- PAUSE ; Pause For Scroll
- I $E(IOST,1,2)="C-",PG R !!,"Press return to continue ",YN:DTIME S:'$T!(YN["^") QT="^" Q:QT="^" I "^"'[YN W !,"Enter a RETURN to Continue." G PAUSE
- Q
- HDR ; Print Header
- D PAUSE Q:QT="^"
- W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
- W !,PID,?16,$P(Y(0),"^",1),?48,SEX," Age ",AGE,?(79-$L(RM)),RM Q
- KIL ; Final variable kill
- K %,%H,%I,%T,%ZIS,A1,ADM,AGE,ALG,ALL,BAG,C,CAL,COM,CON,CT,D3,DA,DAS,FHDU,FHDFN,DFN,DOB,DTP,FHOR,FHLD,I,IOP,K,K1,K2,KK,L,L1,LST,MEAL,N,NO,NOW,FHORD,FHWF,FHPV
- K POP,Q,QUA,QT,QTY,RM,SEX,PID,BID,STR,TYP,TF,TF2,TIM,TQU,TUN,WARD,X,X1,X2,XY,Y,YN,Z,Z1 Q
- FHORD6 ; HISC/REL/NCA/JH/RTK - Diet Inquiry ;5/3/01 11:04
- +1 ;;5.5;DIETETICS;**1,5**;Jan 28, 2005;Build 53
- +2 SET FHALL=1
- DO ^FHOMDPA
- IF 'FHDFN
- GOTO KIL
- +3 DO MONUM^FHOMUTL
- IF FHNUM=""
- QUIT
- +4 ;profile for file #200 outpatients
- IF FHDFN
- IF DFN=""
- DO ^FHOMPP
- QUIT
- +5 ;profile for file #2 outpts
- IF FHDFN
- IF $GET(^DPT(DFN,.1))=""
- DO ^FHOMPP
- QUIT
- +6 KILL IOP
- SET %ZIS="MQ"
- SET %ZIS("B")="HOME"
- WRITE !
- DO ^%ZIS
- KILL %ZIS,IOP
- IF POP
- GOTO KIL
- +7 IF $DATA(IO("Q"))
- SET FHPGM="F0^FHORD6"
- SET FHLST="FHDFN^DFN^PID^ADM^FHNUM"
- DO EN2^FH
- GOTO KIL
- +8 USE IO
- DO F0
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO FHORD6
- F0 ; Display Diet
- +1 DO NOW^%DTC
- SET NOW=%
- SET DT=NOW\1
- SET QT=""
- +2 SET WARD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
- IF WARD
- SET WARD=$PIECE($GET(^FH(119.6,WARD,0)),"^",1)
- +3 SET Y(0)=^DPT(DFN,0)
- SET SEX=$PIECE(Y(0),"^",2)
- SET DOB=$PIECE(Y(0),"^",3)
- +4 SET AGE=$EXTRACT(NOW,1,3)-$EXTRACT(DOB,1,3)-($EXTRACT(NOW,4,7)<$EXTRACT(DOB,4,7))
- SET X=$PIECE($GET(^DPT(DFN,.101)),"^",1)
- SET RM=$EXTRACT(WARD,1,15)
- IF X'=""
- SET RM=RM_"/"_X
- +5 SET QT=""
- SET PG=0
- DO HDR
- +6 DO ALG^FHCLN
- IF ALG'=""
- WRITE !!,"Allergies: ",ALG
- +7 KILL N
- SET P1=1
- FOR K=0:0
- SET K=$ORDER(^FHPT(FHDFN,"P",K))
- IF K<1
- QUIT
- SET X=^(K,0)
- SET M=$PIECE(X,"^",2)
- IF M="A"
- SET M="BNE"
- DO SP
- +8 IF $ORDER(N(""))=""
- WRITE !!,"No Food Preferences on file",!
- GOTO A0
- +9 WRITE !!,"Food Preferences Currently on file",!!?23,"Likes",?57,"Dislikes",!
- +10 ;P32
- WRITE !
- SET (M,MM)=""
- FOR
- SET M=$ORDER(N(M))
- IF M=""
- QUIT
- IF $DATA(N(M))
- WRITE $PIECE(M,"~",2)
- Begin DoDot:1
- +11 ;P32
- SET (P1,P2)=0
- FOR
- IF P1'=""
- SET P1=$ORDER(N(M,"L",P1))
- SET X1=$SELECT(P1>0:N(M,"L",P1),1:"")
- IF P2'=""
- SET P2=$ORDER(N(M,"D",P2))
- SET X2=$SELECT(P2>0:N(M,"D",P2),1:"")
- IF P1=""&(P2="")
- QUIT
- DO W0
- IF QT="^"
- QUIT
- IF MM'=M
- WRITE !
- +12 QUIT
- End DoDot:1
- IF QT="^"
- QUIT
- SET MM=M
- +13 WRITE !
- KILL L,N,M,M1,M2
- +14 ;P32
- IF QT="^"
- GOTO KIL
- A0 SET X(0)=^FHPT(FHDFN,"A",ADM,0)
- SET X=$PIECE(X(0),"^",10)
- IF X=""
- GOTO F1
- +1 IF $Y>(IOSL-3)
- DO HDR
- IF QT="^"
- GOTO KIL
- WRITE !!,"Isolation/Precaution Type is ",$PIECE($GET(^FH(119.4,X,0)),"^",1)
- F1 DO CUR^FHORD7
- IF $Y>(IOSL-6)
- DO HDR
- IF QT="^"
- GOTO KIL
- WRITE !!,"Current Diet: ",$SELECT(Y'="":Y,1:"No current order")
- +1 IF Y'=""
- IF FHORD>0
- IF $DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
- SET COM=^(1)
- IF COM'=""
- WRITE !,"Comment: ",COM
- +2 SET TYP=$PIECE(X,"^",8)
- IF TYP'=""
- WRITE !,"Service: ",$SELECT(TYP="T":"Tray",TYP="D":"Dining Room",1:"Cafeteria")
- +3 SET DTP=$PIECE(X(0),"^",3)
- IF DTP
- DO DTP^FH
- WRITE !,"Expires: ",DTP
- +4 SET TF=$PIECE(X(0),"^",4)
- IF TF<1
- GOTO F2
- +5 SET Y=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
- +6 SET DTP=$PIECE(Y,"^",1)
- SET COM=$PIECE(Y,"^",5)
- SET TQU=$PIECE(Y,"^",6)
- SET CAL=$PIECE(Y,"^",7)
- +7 DO DTP^FH
- WRITE !!,"Tubefeed Ordered: ",DTP
- +8 FOR TF2=0:0
- SET TF2=$ORDER(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2))
- IF TF2<1
- QUIT
- SET XY=^(TF2,0)
- DO LP
- +9 WRITE !,"Total Quantity: ",TQU," ml",?42,"Total KCAL: ",CAL
- +10 IF COM'=""
- WRITE !,"Comment: ",COM
- F2 SET NO=$PIECE(X(0),"^",7)
- SET Y=$SELECT('NO:"",1:^FHPT(FHDFN,"A",ADM,"SF",NO,0))
- IF $Y>(IOSL-3)
- DO HDR
- IF QT="^"
- GOTO KIL
- +1 SET L=$PIECE(Y,"^",4)
- WRITE !!,"Supplemental Feeding: ",$SELECT('L:"No Order",1:$PIECE(^FH(118.1,L,0),"^",1))
- IF 'NO
- GOTO F3
- +2 SET DTP=$PIECE(Y,"^",30)
- DO DTP^FH
- WRITE ?50,"Reviewed: ",DTP
- +3 SET L=4
- FOR K1=1:1:3
- SET K=0
- SET N(K1)=""
- FOR K2=1:1:4
- SET Z=$PIECE(Y,U,L+1)
- SET Q=$PIECE(Y,U,L+2)
- SET L=L+2
- IF Z'=""
- IF 'Q
- SET Q=1
- IF N(K1)'=""
- SET N(K1)=N(K1)_"; "
- SET N(K1)=N(K1)_Q_" "_$PIECE(^FH(118,Z,0),"^",1)
- +4 IF $Y>(IOSL-4)
- DO HDR
- IF QT="^"
- GOTO KIL
- FOR K1=1:1:3
- IF N(K1)'=""
- WRITE !?5,$PIECE("10am; 2pm; 8pm",";",K1),":",?13,N(K1)
- F3 GOTO ^FHORD61
- LP SET TUN=$PIECE(XY,"^",1)
- SET STR=$PIECE(XY,"^",2)
- SET QUA=$PIECE(XY,"^",3)
- +1 IF QUA["CC"
- SET QUAFI=$PIECE(QUA,"CC",1)
- SET QUASE=$PIECE(QUA,"CC",2)
- SET QUA=QUAFI_"ML"_QUASE
- +2 WRITE !,"Product: ",$PIECE($GET(^FH(118.2,TUN,0)),"^",1),", ",$SELECT(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")," Str., ",QUA
- QUIT
- SP SET Z=$GET(^FH(115.2,+X,0))
- SET L1=$PIECE(Z,"^",1)
- SET KK=$PIECE(Z,"^",2)
- SET M1=""
- SET DAS=$PIECE(X,"^",4)
- +1 IF KK="L"
- SET Q=$PIECE(X,"^",3)
- SET L1=$SELECT(Q:Q,1:1)_" "_L1
- +2 IF M="BNE"
- SET M1="1~All Meals"
- GOTO SP1
- +3 SET Z1=$EXTRACT(M,1)
- IF Z1'=""
- SET M1=$SELECT(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
- +4 SET Z1=$EXTRACT(M,2)
- IF Z1'=""
- SET M1=M1_","_$SELECT(Z1="B":"Break",Z1="N":"Noon",1:"Even")
- SP1 IF '$DATA(N(M1,KK,P1))
- SET N(M1,KK,P1)=""
- IF $LENGTH(N(M1,KK,P1))+$LENGTH(L1)<255
- SET N(M1,KK,P1)=N(M1,KK,P1)_$SELECT(N(M1,KK,P1)="":"",1:", ")_L1_$SELECT(DAS="Y":" (D)",1:"")
- +1 IF '$TEST
- IF '$DATA(N(M1,KK,K))
- SET N(M1,KK,K)=""
- SET N(M1,KK,K)=L1_$SELECT(DAS="Y":" (D)",1:"")
- SET P1=K
- +2 QUIT
- W0 IF X1'=""
- WRITE ?12
- SET X=X1
- DO W1
- SET X1=X
- +1 IF X2'=""
- WRITE ?46
- SET X=X2
- DO W1
- SET X2=X
- +2 ;P32
- IF X1=""&(X2="")
- QUIT
- IF $Y'<(IOSL-2)
- DO HDR
- IF QT="^"
- QUIT
- WRITE !
- GOTO W0
- W1 IF $LENGTH(X)<34
- WRITE X
- SET X=""
- QUIT
- +1 FOR KK=35:-1:1
- IF $EXTRACT(X,KK-1,KK)=", "
- QUIT
- +2 WRITE $EXTRACT(X,1,KK-2)
- SET X=$EXTRACT(X,KK+1,999)
- QUIT
- PAUSE ; Pause For Scroll
- +1 IF $EXTRACT(IOST,1,2)="C-"
- IF PG
- READ !!,"Press return to continue ",YN:DTIME
- IF '$TEST!(YN["^")
- SET QT="^"
- IF QT="^"
- QUIT
- IF "^"'[YN
- WRITE !,"Enter a RETURN to Continue."
- GOTO PAUSE
- +2 QUIT
- HDR ; Print Header
- +1 DO PAUSE
- IF QT="^"
- QUIT
- +2 IF '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- +3 WRITE !,PID,?16,$PIECE(Y(0),"^",1),?48,SEX," Age ",AGE,?(79-$LENGTH(RM)),RM
- QUIT
- KIL ; Final variable kill
- +1 KILL %,%H,%I,%T,%ZIS,A1,ADM,AGE,ALG,ALL,BAG,C,CAL,COM,CON,CT,D3,DA,DAS,FHDU,FHDFN,DFN,DOB,DTP,FHOR,FHLD,I,IOP,K,K1,K2,KK,L,L1,LST,MEAL,N,NO,NOW,FHORD,FHWF,FHPV
- +2 KILL POP,Q,QUA,QT,QTY,RM,SEX,PID,BID,STR,TYP,TF,TF2,TIM,TQU,TUN,WARD,X,X1,X2,XY,Y,YN,Z,Z1
- QUIT
