FHORD1 ; HISC/REL/NCA - Diet Order ;3/28/01 10:28
;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
F0 S ALL=1 D ^FHDPA G:'DFN KIL G:'FHDFN KIL
I $G(ADM)="" W *7,!!," NOT CURRENTLY AN INPATIENT" D KIL Q
D D0 G:'DFN KIL G:'FHDFN KIL D PROC
S DTE="" D ^FHORD1A I FHWF,DTE S (SDT,EDT)=DTE,WKD="",SERV="L" D EL^FHWOR3 D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG
S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4) I TF W !!,"An ACTIVE Tubefeeding Order Exists!" S FHD="Y" D DIS^FHORT2,ASK^FHORT2 D:FHD="Y" CAN^FHORT2
G F0
D0 ; Process Diet Order
D CUR^FHORD7 W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
D ALG^FHCLN W !!,"Allergies: ",$S(ALG="":"None on file",1:ALG)
I FHORD S COM=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1)) I COM'="" W !,"Comment: ",COM
D NOW^%DTC S NOW=% K %,%H,%I D FUT
C0 I CT W *7 R !!,"A new order with no expiration date will CANCEL these diets.",!!,"Do you wish to CONTINUE? (Y/N): ",X:DTIME G:'$T!(X="^") AB S:X="" X="^" D TR^FH G:$P("NO",X,1)="" AB I $P("YES",X,1)'="" W *7," Answer YES or NO" G C0
F7 S WRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8),SVC="" I WRD>0 S SVC=$P($G(^FH(119.6,WRD,0)),"^",10)
S:SVC="" SVC="T" I $L(SVC)=1 S TYP=SVC G F8
S N1=$P(^FHPT(FHDFN,"A",ADM,0),"^",5) S:SVC'[N1 N1=""
S X="Tray^Cafeteria^Dining Room" W !!,$P(X,"^",$F("TCD",$E(SVC,1))-1),$S($L(SVC)=2:" or ",1:", "),$P(X,"^",$F("TCD",$E(SVC,2))-1)
W:$L(SVC)=3 " or ",$P(X,"^",$F("TCD",$E(SVC,3))-1) W ": ",$S(N1="":$E(SVC,1),1:N1),"// "
R X:DTIME G:'$T!(X="^") AB S:X="" X=$S(N1="":$E(SVC,1),1:N1) S X=$E(X,1) D TR^FH
I SVC'[X W *7,!,"Enter one of the given type of services." G F7
S TYP=X
I 'FHORD!(N1="")!(N1=TYP) G F8
S N1=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0) I "^^^^"[$P(N1,"^",2,6) G F8
R1 R !!,"Retain Current Diet? N// ",Y:DTIME G:'$T!(Y="^") AB S:Y="" Y="N" S X=Y D TR^FH S Y=X I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7," Answer YES or NO" G R1
G:Y?1"N".E F8 S FHOR=$P(N1,"^",2,6),(D3,D4)=0,D2=$P(N1,"^",10)
S D1=NOW G F10
F8 K DI S N1=0 G:FHWF=2 F1 R !!,"Order a REGULAR Diet? (Y/N) ",Y:DTIME G:'$T!(Y="^") AB S:Y="" Y="^" S X=Y D TR^FH S Y=X I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7," Answer YES or NO" G F8
G:Y'?1"Y".E F1 S Y(0)=^FH(111,1,0),PREC=$P(Y(0),U,4),DI(PREC)="1^"_Y(0),N1=1 G F5
F1 W ! K DIC S DIC="^FH(111,",DIC(0)="AEQMZ" S DIC("S")="I '$D(^(""I""))&(Y>1)" D ^DIC K DIC G AB:X[U!$D(DTOUT),F5:X="",F1:Y<1
S PREC=$P(Y(0),U,4) I PREC,$D(DI(PREC)) W *7,!!,"This conflicts with ",$P(DI(PREC),"^",2),! G F1
S N1=N1+1,DI(PREC)=+Y_"^"_Y(0) G F5:+Y=1,F1:N1<5 W *7,!!,"You have now selected the maximum of 5 Diet Modifications!"
F5 G:'N1 AB W !!,"You have selected the following Diet:",!
S (D3,D4)=0 F D0=0:0 S D0=$O(DI(D0)) Q:D0="" W !?5,$P(DI(D0),U,2) S:$P(DI(D0),U,4)="Y" D3=1 S:$P(DI(D0),U,7)="Y" D4=1
F9 G:FHWF=2 F6 R !!,"Is this Correct? Y// ",Y:DTIME G:'$T!(Y="^") AB S:Y="" Y="Y" S X=Y D TR^FH S Y=X
I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7,!," Answer YES to accept diet list; NO to select diets again" G F9
I Y'?1"Y".E K DI S N1=0 W !!,"Select new diets ..." G F1
F6 S COM="" ;R !!,"Comment: ",COM:DTIME G:'$T!(COM["^") AB I COM'?.ANP W *7," ??" G F6
I $L(COM)>80!(COM?1"?".E) W *7,!,"Enter any special instructions of up to 80 characters!" G F6
D GETD^FHORD71 G:'D1 AB
S FHOR="^^^^",FHEVTX="",N1=0 F D0=0:0 S D0=$O(DI(D0)) Q:D0="" S N1=N1+1,$P(FHOR,U,N1)=+DI(D0),FHEVTX=FHEVTX_", "_$P(DI(D0),U,8)
; [SEE NOIS SDC-0402-62498] S FHDPATT=$O(^FH(111.1,"AB",FHOR,0)) I FHDPATT'="" I $G(^FH(111.1,FHDPATT,"I"))="Y" W !!," ** INACTIVE DIET PATTERN! **" G AB
I '$O(^FH(111.1,"AB",FHOR,0)),$P($G(^FH(119.9,1,4)),"^",2)="Y" S EVT="M^O^^No Diet Pattern ("_$E(FHEVTX,3,999)_")" D ^FHORX
F10 S FHLD="" W:FHWF'=2 !!,"... Diet Order Accepted"
Q
PROC ; Process & file order
D STR^FHORD7,^FHORDR D:D4 POST^FHORD7 Q
AB W *7,!!,"Diet Order for this Patient is UNCHANGED -- No order entered!",! S (DFN,FHDFN)="" Q
KIL ; Final variable kill
K %,%H,%I,%T,%DT,A1,A2,ADM,ALL,C,COM,CORD,CT,D0,D1,D2,D3,D4,DA,FHDFN,DFN,DTP,DI,DIC,FHDU,FHD,FHLD,FHOR,FHPAR,FHWF,FHPV,FLG,I,J,K,KK,N1,NOW,FHORD,FHSAV,FHSAV1,FHDAY
K FHK,FHK1,FHOE,FHOLD,FHMSG,FHNEW,K1,K2,KK1,LC,M,PREC,SVC,TYP,X,X1,X2,Y,WRD,WARD,TF,QUA,STR,TUN,XMKK,Z Q
FUT ; List future diets
S CT=0,CORD=FHORD F KK=NOW:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1 S FHORD=$P(^(KK,0),"^",2) D T1
S FHORD=CORD Q
T1 Q:'$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) S DTP=KK D DTP^FH,C2^FHORD7
I 'CT W !!,"Future Diet Orders:",!
S CT=CT+1 W !?5,DTP,?25,Y Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD1 4484 printed Dec 13, 2024@01:53:22 Page 2
FHORD1 ; HISC/REL/NCA - Diet Order ;3/28/01 10:28
+1 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
F0 SET ALL=1
DO ^FHDPA
if 'DFN
GOTO KIL
if 'FHDFN
GOTO KIL
+1 IF $GET(ADM)=""
WRITE *7,!!," NOT CURRENTLY AN INPATIENT"
DO KIL
QUIT
+2 DO D0
if 'DFN
GOTO KIL
if 'FHDFN
GOTO KIL
DO PROC
+3 SET DTE=""
DO ^FHORD1A
IF FHWF
IF DTE
SET (SDT,EDT)=DTE
SET WKD=""
SET SERV="L"
DO EL^FHWOR3
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG
+4 SET TF=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",4)
IF TF
WRITE !!,"An ACTIVE Tubefeeding Order Exists!"
SET FHD="Y"
DO DIS^FHORT2
DO ASK^FHORT2
if FHD="Y"
DO CAN^FHORT2
+5 GOTO F0
D0 ; Process Diet Order
+1 DO CUR^FHORD7
WRITE !!,"Current Diet: ",$SELECT(Y'="":Y,1:"No current order")
+2 DO ALG^FHCLN
WRITE !!,"Allergies: ",$SELECT(ALG="":"None on file",1:ALG)
+3 IF FHORD
SET COM=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
IF COM'=""
WRITE !,"Comment: ",COM
+4 DO NOW^%DTC
SET NOW=%
KILL %,%H,%I
DO FUT
C0 IF CT
WRITE *7
READ !!,"A new order with no expiration date will CANCEL these diets.",!!,"Do you wish to CONTINUE? (Y/N): ",X:DTIME
if '$TEST!(X="^")
GOTO AB
if X=""
SET X="^"
DO TR^FH
if $PIECE("NO",X,1)=""
GOTO AB
IF $PIECE("YES",X,1)'=""
WRITE *7," Answer YES or NO"
GOTO C0
F7 SET WRD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
SET SVC=""
IF WRD>0
SET SVC=$PIECE($GET(^FH(119.6,WRD,0)),"^",10)
+1 if SVC=""
SET SVC="T"
IF $LENGTH(SVC)=1
SET TYP=SVC
GOTO F8
+2 SET N1=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",5)
if SVC'[N1
SET N1=""
+3 SET X="Tray^Cafeteria^Dining Room"
WRITE !!,$PIECE(X,"^",$FIND("TCD",$EXTRACT(SVC,1))-1),$SELECT($LENGTH(SVC)=2:" or ",1:", "),$PIECE(X,"^",$FIND("TCD",$EXTRACT(SVC,2))-1)
+4 if $LENGTH(SVC)=3
WRITE " or ",$PIECE(X,"^",$FIND("TCD",$EXTRACT(SVC,3))-1)
WRITE ": ",$SELECT(N1="":$EXTRACT(SVC,1),1:N1),"// "
+5 READ X:DTIME
if '$TEST!(X="^")
GOTO AB
if X=""
SET X=$SELECT(N1="":$EXTRACT(SVC,1),1:N1)
SET X=$EXTRACT(X,1)
DO TR^FH
+6 IF SVC'[X
WRITE *7,!,"Enter one of the given type of services."
GOTO F7
+7 SET TYP=X
+8 IF 'FHORD!(N1="")!(N1=TYP)
GOTO F8
+9 SET N1=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)
IF "^^^^"[$PIECE(N1,"^",2,6)
GOTO F8
R1 READ !!,"Retain Current Diet? N// ",Y:DTIME
if '$TEST!(Y="^")
GOTO AB
if Y=""
SET Y="N"
SET X=Y
DO TR^FH
SET Y=X
IF $PIECE("YES",Y,1)'=""
IF $PIECE("NO",Y,1)'=""
WRITE *7," Answer YES or NO"
GOTO R1
+1 if Y?1"N".E
GOTO F8
SET FHOR=$PIECE(N1,"^",2,6)
SET (D3,D4)=0
SET D2=$PIECE(N1,"^",10)
+2 SET D1=NOW
GOTO F10
F8 KILL DI
SET N1=0
if FHWF=2
GOTO F1
READ !!,"Order a REGULAR Diet? (Y/N) ",Y:DTIME
if '$TEST!(Y="^")
GOTO AB
if Y=""
SET Y="^"
SET X=Y
DO TR^FH
SET Y=X
IF $PIECE("YES",Y,1)'=""
IF $PIECE("NO",Y,1)'=""
WRITE *7," Answer YES or NO"
GOTO F8
+1 if Y'?1"Y".E
GOTO F1
SET Y(0)=^FH(111,1,0)
SET PREC=$PIECE(Y(0),U,4)
SET DI(PREC)="1^"_Y(0)
SET N1=1
GOTO F5
F1 WRITE !
KILL DIC
SET DIC="^FH(111,"
SET DIC(0)="AEQMZ"
SET DIC("S")="I '$D(^(""I""))&(Y>1)"
DO ^DIC
KILL DIC
if X[U!$DATA(DTOUT)
GOTO AB
if X=""
GOTO F5
if Y<1
GOTO F1
+1 SET PREC=$PIECE(Y(0),U,4)
IF PREC
IF $DATA(DI(PREC))
WRITE *7,!!,"This conflicts with ",$PIECE(DI(PREC),"^",2),!
GOTO F1
+2 SET N1=N1+1
SET DI(PREC)=+Y_"^"_Y(0)
if +Y=1
GOTO F5
if N1<5
GOTO F1
WRITE *7,!!,"You have now selected the maximum of 5 Diet Modifications!"
F5 if 'N1
GOTO AB
WRITE !!,"You have selected the following Diet:",!
+1 SET (D3,D4)=0
FOR D0=0:0
SET D0=$ORDER(DI(D0))
if D0=""
QUIT
WRITE !?5,$PIECE(DI(D0),U,2)
if $PIECE(DI(D0),U,4)="Y"
SET D3=1
if $PIECE(DI(D0),U,7)="Y"
SET D4=1
F9 if FHWF=2
GOTO F6
READ !!,"Is this Correct? Y// ",Y:DTIME
if '$TEST!(Y="^")
GOTO AB
if Y=""
SET Y="Y"
SET X=Y
DO TR^FH
SET Y=X
+1 IF $PIECE("YES",Y,1)'=""
IF $PIECE("NO",Y,1)'=""
WRITE *7,!," Answer YES to accept diet list; NO to select diets again"
GOTO F9
+2 IF Y'?1"Y".E
KILL DI
SET N1=0
WRITE !!,"Select new diets ..."
GOTO F1
F6 ;R !!,"Comment: ",COM:DTIME G:'$T!(COM["^") AB I COM'?.ANP W *7," ??" G F6
SET COM=""
+1 IF $LENGTH(COM)>80!(COM?1"?".E)
WRITE *7,!,"Enter any special instructions of up to 80 characters!"
GOTO F6
+2 DO GETD^FHORD71
if 'D1
GOTO AB
+3 SET FHOR="^^^^"
SET FHEVTX=""
SET N1=0
FOR D0=0:0
SET D0=$ORDER(DI(D0))
if D0=""
QUIT
SET N1=N1+1
SET $PIECE(FHOR,U,N1)=+DI(D0)
SET FHEVTX=FHEVTX_", "_$PIECE(DI(D0),U,8)
+4 ; [SEE NOIS SDC-0402-62498] S FHDPATT=$O(^FH(111.1,"AB",FHOR,0)) I FHDPATT'="" I $G(^FH(111.1,FHDPATT,"I"))="Y" W !!," ** INACTIVE DIET PATTERN! **" G AB
+5 IF '$ORDER(^FH(111.1,"AB",FHOR,0))
IF $PIECE($GET(^FH(119.9,1,4)),"^",2)="Y"
SET EVT="M^O^^No Diet Pattern ("_$EXTRACT(FHEVTX,3,999)_")"
DO ^FHORX
F10 SET FHLD=""
if FHWF'=2
WRITE !!,"... Diet Order Accepted"
+1 QUIT
PROC ; Process & file order
+1 DO STR^FHORD7
DO ^FHORDR
if D4
DO POST^FHORD7
QUIT
AB WRITE *7,!!,"Diet Order for this Patient is UNCHANGED -- No order entered!",!
SET (DFN,FHDFN)=""
QUIT
KIL ; Final variable kill
+1 KILL %,%H,%I,%T,%DT,A1,A2,ADM,ALL,C,COM,CORD,CT,D0,D1,D2,D3,D4,DA,FHDFN,DFN,DTP,DI,DIC,FHDU,FHD,FHLD,FHOR,FHPAR,FHWF,FHPV,FLG,I,J,K,KK,N1,NOW,FHORD,FHSAV,FHSAV1,FHDAY
+2 KILL FHK,FHK1,FHOE,FHOLD,FHMSG,FHNEW,K1,K2,KK1,LC,M,PREC,SVC,TYP,X,X1,X2,Y,WRD,WARD,TF,QUA,STR,TUN,XMKK,Z
QUIT
FUT ; List future diets
+1 SET CT=0
SET CORD=FHORD
FOR KK=NOW:0
SET KK=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",KK))
if KK<1
QUIT
SET FHORD=$PIECE(^(KK,0),"^",2)
DO T1
+2 SET FHORD=CORD
QUIT
T1 if '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
QUIT
SET DTP=KK
DO DTP^FH
DO C2^FHORD7
+1 IF 'CT
WRITE !!,"Future Diet Orders:",!
+2 SET CT=CT+1
WRITE !?5,DTP,?25,Y
QUIT
