FHORD7 ; HISC/REL/NCA/JH - Diet Order Utilities ; 3/10/16 3:13pm
;;5.5;DIETETICS;**8,41,42**;Jan 28, 2005;Build 1
;Patch #41 - adds timeout to incremental locks
;Patch #42 - adds setting of variable WARD
CUR ; Get Diet
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
S X1=$G(^FHPT(FHDFN,"A",ADM,0)),FHORD=$P(X1,"^",2),X1=$P(X1,"^",3),(FHLD,FHOR,X,Y)=""
Q:'FHORD Q:'$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
C2 ; Set FHOR & FHLD variables & Y = diet text
S X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7),Y=""
I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") S:%>0 Y=$P($E(FHDU,%,999),";",1) K % Q
C3 S Y="" F A1=1:1:5 S D3=$P(FHOR,"^",A1) I D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7)
Q
NOW D NOW^%DTC S NOW=% Q
POST ; Generate bulletin
S WRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8) Q:WRD<1
F FHXMKK=0:0 S FHXMKK=$O(^FH(119.6,WRD,2,"B",FHXMKK)) Q:FHXMKK'>0 D
.S XMY(FHXMKK)=""
Q:'$D(XMY) S XMB="FHDIORD"
D PATNAME^FHOMUTL I DFN="" Q
S XMB(1)=$P(^DPT(DFN,0),"^",1),XMB(2)=$P(^FH(119.6,WRD,0),"^",1) D C3 S XMB(3)=Y
S XMB(5)=$S($D(^DPT(DFN,.101)):^(.101),1:"unknown")
S DTP=D1 D DTP^FH S XMB(4)=DTP D ^XMB K XMB,XMY,XMM,XMDT,FHXMKK Q
STR ; Store new diet order
D ORD,NOW
S X=FHORD_"^"_FHOR_"^"_FHLD_"^"_TYP_"^"_D1_"^"_$S(D2:D2,1:"")_"^"_DUZ_"^"_NOW,FHNOW=NOW
S ^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)=X S:COM'="" ^(1)=COM I FHWF D OE^FHORD71 S NOW=FHNOW
S0 G:'D2 S1 S X2=D2+.000001
S01 S A2=0 F A1=0:0 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) Q:A1<1!(A1'<X2) S A2=A1
I A2 S X2=A2,A2=$P(^FHPT(FHDFN,"A",ADM,"AC",A2,0),"^",2),X1=$P(^FHPT(FHDFN,"A",ADM,"DI",A2,0),"^",10) I X1'="",X1'>D2 G S01
F A1=D1:0 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) Q:A1<1!(A1'<D2) D SK
S Z6=D1_"^"_FHORD D ACR^FHORD71
I 'A2 D ORD S A2=FHORD,^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)=FHORD_"^^^^^^X^^"_D2_"^^"_DUZ_"^"_NOW
E D OE3
S Z6=D2_"^"_A2 D ACR^FHORD71 G S2
S1 I FHLD'="P" F A1=D1:0 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) Q:A1="" D SK
S Z6=D1_"^"_FHORD D ACR^FHORD71
S2 S X1="",A1=0 G S4
S3 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) G:A1="" S4 S X2=$P(^(A1,0),"^",2)
I X2<1 D SK G S3
I '$D(^FHPT(FHDFN,"A",ADM,"DI",X2,0)) D SK G S3
S X2=^FHPT(FHDFN,"A",ADM,"DI",X2,0) I $P(X2,"^",2,8)'=$P(X1,"^",2,8) S X1=X2 G S3
I $P(X1,"^",10)="" D SK G S3
I $P(X2,"^",10),$P(X2,"^",10)'>$P(X1,"^",10) D SK G S3
S X1=X2 G S3
S4 D OEU^FHORD71 S NOW=FHNOW K FHNOW G U1
UPD ; Get time & update diet
D NOW I $D(ZTQUEUED),$D(Z6) I NOW<Z6 S NOW=Z6+.0002
U1 ; Update diet
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" W "Could not find patient" Q
S WARD=$G(^DPT(DFN,.1)) ;Patch #42
S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>NOW) S A1=K
G:'A1 U3 S X1=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G S2:X1<1,S2:'$D(^FHPT(FHDFN,"A",ADM,"DI",X1,0))
S X2=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) S:X2<1 X2=""
U2 I $P(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=X1_"^"_X2 Q
S FHYES=0 I $P(^FHPT(FHDFN,"A",ADM,0),"^",2)=X1 S FHYES=1
S $P(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=X1_"^"_X2,X9="" I X1 S X9=$P(^FHPT(FHDFN,"A",ADM,"DI",X1,0),"^",8) I 'FHYES S EVT="D^O^"_X1 D ^FHORX
I X9'="",X9'=$P(^FHPT(FHDFN,"A",ADM,0),"^",5) S $P(^(0),"^",5)=X9
K X9 D ^FHORD72 K FHYES Q
U3 S (X1,X2)="" G U2
SK K ^FHPT(FHDFN,"A",ADM,"AC",A1) S Z6=-1 G ACR^FHORD71
ORD ; Get next order #
L +^FHPT(FHDFN,"A",ADM,"DI",0):$S($G(DILOCKTM):DILOCKTM,1:3)
I '$D(^FHPT(FHDFN,"A",ADM,"DI",0)) S ^FHPT(FHDFN,"A",ADM,"DI",0)="^115.02A^^"
S X=^FHPT(FHDFN,"A",ADM,"DI",0),FHORD=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_FHORD_"^"_($P(X,"^",4)+1)
L -^FHPT(FHDFN,"A",ADM,"DI",0) Q:'$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD)) G ORD
OE3 ; Enter New Re-enstated Order
Q:$$VERSION^XPDUTL("OR")=2.5
D ORD^FHORR S FHNO1=$G(^FHPT(FHDFN,"A",ADM,"DI",A2,0)),FHNO2=$G(^(1)),FHNO3=$G(^(2))
S ^FHPT(FHDFN,"A",ADM,"DI",FHORD1,0)=FHORD1_"^"_$P(FHNO1,"^",2,8)_"^"_D2_"^"_$P(FHNO1,"^",10)_"^"_DUZ_"^"_NOW_"^"_$P(FHNO1,"^",13) S:FHNO2'="" ^(1)=FHNO2
S:FHNO3 ^(2)=FHNO3,^(3)=DUZ_"^"_NOW S A2=FHORD1 I FHWF D OE^FHORR S NOW=FHNOW
K FHNO1,FHNO2,FHNO3,FHORD1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD7 4083 printed Sep 23, 2025@19:29:33 Page 2
FHORD7 ; HISC/REL/NCA/JH - Diet Order Utilities ; 3/10/16 3:13pm
+1 ;;5.5;DIETETICS;**8,41,42**;Jan 28, 2005;Build 1
+2 ;Patch #41 - adds timeout to incremental locks
+3 ;Patch #42 - adds setting of variable WARD
CUR ; Get Diet
+1 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+2 SET X1=$GET(^FHPT(FHDFN,"A",ADM,0))
SET FHORD=$PIECE(X1,"^",2)
SET X1=$PIECE(X1,"^",3)
SET (FHLD,FHOR,X,Y)=""
+3 if 'FHORD
QUIT
if '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
QUIT
C2 ; Set FHOR & FHLD variables & Y = diet text
+1 SET X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)
SET FHOR=$PIECE(X,"^",2,6)
SET FHLD=$PIECE(X,"^",7)
SET Y=""
+2 IF FHLD'=""
SET FHDU=";"_$PIECE(^DD(115.02,6,0),"^",3)
SET %=$FIND(FHDU,";"_FHLD_":")
if %>0
SET Y=$PIECE($EXTRACT(FHDU,%,999),";",1)
KILL %
QUIT
C3 SET Y=""
FOR A1=1:1:5
SET D3=$PIECE(FHOR,"^",A1)
IF D3
if Y'=""
SET Y=Y_", "
SET Y=Y_$PIECE(^FH(111,D3,0),"^",7)
+1 QUIT
NOW DO NOW^%DTC
SET NOW=%
QUIT
POST ; Generate bulletin
+1 SET WRD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
if WRD<1
QUIT
+2 FOR FHXMKK=0:0
SET FHXMKK=$ORDER(^FH(119.6,WRD,2,"B",FHXMKK))
if FHXMKK'>0
QUIT
Begin DoDot:1
+3 SET XMY(FHXMKK)=""
End DoDot:1
+4 if '$DATA(XMY)
QUIT
SET XMB="FHDIORD"
+5 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+6 SET XMB(1)=$PIECE(^DPT(DFN,0),"^",1)
SET XMB(2)=$PIECE(^FH(119.6,WRD,0),"^",1)
DO C3
SET XMB(3)=Y
+7 SET XMB(5)=$SELECT($DATA(^DPT(DFN,.101)):^(.101),1:"unknown")
+8 SET DTP=D1
DO DTP^FH
SET XMB(4)=DTP
DO ^XMB
KILL XMB,XMY,XMM,XMDT,FHXMKK
QUIT
STR ; Store new diet order
+1 DO ORD
DO NOW
+2 SET X=FHORD_"^"_FHOR_"^"_FHLD_"^"_TYP_"^"_D1_"^"_$SELECT(D2:D2,1:"")_"^"_DUZ_"^"_NOW
SET FHNOW=NOW
+3 SET ^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)=X
if COM'=""
SET ^(1)=COM
IF FHWF
DO OE^FHORD71
SET NOW=FHNOW
S0 if 'D2
GOTO S1
SET X2=D2+.000001
S01 SET A2=0
FOR A1=0:0
SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",A1))
if A1<1!(A1'<X2)
QUIT
SET A2=A1
+1 IF A2
SET X2=A2
SET A2=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A2,0),"^",2)
SET X1=$PIECE(^FHPT(FHDFN,"A",ADM,"DI",A2,0),"^",10)
IF X1'=""
IF X1'>D2
GOTO S01
+2 FOR A1=D1:0
SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",A1))
if A1<1!(A1'<D2)
QUIT
DO SK
+3 SET Z6=D1_"^"_FHORD
DO ACR^FHORD71
+4 IF 'A2
DO ORD
SET A2=FHORD
SET ^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)=FHORD_"^^^^^^X^^"_D2_"^^"_DUZ_"^"_NOW
+5 IF '$TEST
DO OE3
+6 SET Z6=D2_"^"_A2
DO ACR^FHORD71
GOTO S2
S1 IF FHLD'="P"
FOR A1=D1:0
SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",A1))
if A1=""
QUIT
DO SK
+1 SET Z6=D1_"^"_FHORD
DO ACR^FHORD71
S2 SET X1=""
SET A1=0
GOTO S4
S3 SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",A1))
if A1=""
GOTO S4
SET X2=$PIECE(^(A1,0),"^",2)
+1 IF X2<1
DO SK
GOTO S3
+2 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",X2,0))
DO SK
GOTO S3
+3 SET X2=^FHPT(FHDFN,"A",ADM,"DI",X2,0)
IF $PIECE(X2,"^",2,8)'=$PIECE(X1,"^",2,8)
SET X1=X2
GOTO S3
+4 IF $PIECE(X1,"^",10)=""
DO SK
GOTO S3
+5 IF $PIECE(X2,"^",10)
IF $PIECE(X2,"^",10)'>$PIECE(X1,"^",10)
DO SK
GOTO S3
+6 SET X1=X2
GOTO S3
S4 DO OEU^FHORD71
SET NOW=FHNOW
KILL FHNOW
GOTO U1
UPD ; Get time & update diet
+1 DO NOW
IF $DATA(ZTQUEUED)
IF $DATA(Z6)
IF NOW<Z6
SET NOW=Z6+.0002
U1 ; Update diet
+1 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
WRITE "Could not find patient"
QUIT
+2 ;Patch #42
SET WARD=$GET(^DPT(DFN,.1))
+3 SET A1=0
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K))
if K<1!(K>NOW)
QUIT
SET A1=K
+4 if 'A1
GOTO U3
SET X1=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2)
if X1<1
GOTO S2
if '$DATA(^FHPT(FHDFN,"A",ADM,"DI",X1,0))
GOTO S2
+5 SET X2=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",A1))
if X2<1
SET X2=""
U2 IF $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=X1_"^"_X2
QUIT
+1 SET FHYES=0
IF $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",2)=X1
SET FHYES=1
+2 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=X1_"^"_X2
SET X9=""
IF X1
SET X9=$PIECE(^FHPT(FHDFN,"A",ADM,"DI",X1,0),"^",8)
IF 'FHYES
SET EVT="D^O^"_X1
DO ^FHORX
+3 IF X9'=""
IF X9'=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",5)
SET $PIECE(^(0),"^",5)=X9
+4 KILL X9
DO ^FHORD72
KILL FHYES
QUIT
U3 SET (X1,X2)=""
GOTO U2
SK KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
SET Z6=-1
GOTO ACR^FHORD71
ORD ; Get next order #
+1 LOCK +^FHPT(FHDFN,"A",ADM,"DI",0):$SELECT($GET(DILOCKTM):DILOCKTM,1:3)
+2 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",0))
SET ^FHPT(FHDFN,"A",ADM,"DI",0)="^115.02A^^"
+3 SET X=^FHPT(FHDFN,"A",ADM,"DI",0)
SET FHORD=$PIECE(X,"^",3)+1
SET ^(0)=$PIECE(X,"^",1,2)_"^"_FHORD_"^"_($PIECE(X,"^",4)+1)
+4 LOCK -^FHPT(FHDFN,"A",ADM,"DI",0)
if '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD))
QUIT
GOTO ORD
OE3 ; Enter New Re-enstated Order
+1 if $$VERSION^XPDUTL("OR")=2.5
QUIT
+2 DO ORD^FHORR
SET FHNO1=$GET(^FHPT(FHDFN,"A",ADM,"DI",A2,0))
SET FHNO2=$GET(^(1))
SET FHNO3=$GET(^(2))
+3 SET ^FHPT(FHDFN,"A",ADM,"DI",FHORD1,0)=FHORD1_"^"_$PIECE(FHNO1,"^",2,8)_"^"_D2_"^"_$PIECE(FHNO1,"^",10)_"^"_DUZ_"^"_NOW_"^"_$PIECE(FHNO1,"^",13)
if FHNO2'=""
SET ^(1)=FHNO2
+4 if FHNO3
SET ^(2)=FHNO3
SET ^(3)=DUZ_"^"_NOW
SET A2=FHORD1
IF FHWF
DO OE^FHORR
SET NOW=FHNOW
+5 KILL FHNO1,FHNO2,FHNO3,FHORD1
QUIT
