FHORD71 ; HISC/REL - Diet Order Utilities (cont) ;10/1/96 10:00
;;5.5;DIETETICS;;Jan 28, 2005
GETD ; Get from/to dates
S (D1,D2)=0 D NOW^%DTC S NOW=%,DT=NOW\1 K %,%H,%I
D1 R !!,"Effective Date/Time: NOW// ",X:DTIME Q:'$T!(X="^") S:X="" X="NOW" D:$E($P(X,"@",2),1)?1U CNV S %DT="ETSX" D ^%DT Q:U[X G:Y<1 D1
I Y<NOW W *7," Cannot be effective before now!" G GETD
S D1=+Y Q:'D3
D2 R !!,"Expiration Date/Time: ",X:DTIME G:'$T!(X["^") D3 Q:X="" D:$P(X,"@",2)?1U CNV S %DT="ETSX" D ^%DT G D3:U[X,D2:Y<1
I Y'>D1 W *7," Cannot end before effective date!" G GETD
S D2=+Y Q
D3 S D1=0 Q
CNV S DP=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8)
I DP'="" S DP=$P($G(^FH(119.6,DP,0)),"^",8)
S FHPAR=$G(^FH(119.73,+DP,2))
S A1=$E($P(X,"@",2),1) I A1'="M" S A1=$S(A1="B":$P(FHPAR,"^",7),A1="N":$P(FHPAR,"^",8),A1="E":$P(FHPAR,"^",9),1:A1),$P(X,"@",2)=A1 Q
S X=$P(X,"@",1),%DT="X" D ^%DT I Y<1 S X=X_"@2359" Q
S X1=Y,X2=1 D C^%DTC K %H,%T Q:X<1 S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))_"@0001" Q
ACR ; Store AC diet sequence data
G:Z6<1 A1 I '$D(^FHPT(FHDFN,"A",ADM,"AC",0)) S ^(0)="^115.14^^"
S ^FHPT(FHDFN,"A",ADM,"AC",+Z6,0)=Z6,$P(^FHPT(FHDFN,"A",ADM,"AC",0),"^",3)=+Z6
I Z6'>NOW S Z6=1 G A1
N X,X1,FHORN K ZTSAVE
S ZTIO="",ZTRTN="UPD^FHORD7",ZTREQ="@",ZTDESC="Diet Update",ZTDTH=+Z6
S ZTSAVE("DFN")=DFN,ZTSAVE("FHDFN")=FHDFN,ZTSAVE("ADM")=ADM,ZTSAVE("Z6")=+Z6,ZTSAVE("ZTREQ")="" D ^%ZTLOAD K ZTSK
S Z6=1
A1 S $P(^FHPT(FHDFN,"A",ADM,"AC",0),"^",4)=$P(^FHPT(FHDFN,"A",ADM,"AC",0),"^",4)+Z6 K Z6 Q
OE ; File OE/RR Diet Order
Q:FHLD="X"!(FHLD="P")
S FHO=FHOR,VAL="" D VAL^FHWORP(FHO,.VAL) Q:VAL=""
S FHNEW=$S(FHLD'="":"N",1:"D")_";"_ADM_";"_FHORD_";"_D1_";"_D2_";"_FHLD_";"_COM_";"_TYP_";"_D4_";"_VAL
S (FHSTS,FHDU)=$S(D1>NOW:8,1:6)
I FHWF=1 D FILE S:FHDU $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",15)=FHDU Q
I FHWF=2 S FHDU=+FHORN_"^"_FHDU D FHWF2
S:+FHDU $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",14,15)=FHDU Q
OEU ; Update status of OE/RR orders
N FHORN K A1 S A1=0
F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K>NOW!(K<1) S A1=K
I A1 S X=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2),A1(+X)=A1,A1=+X
F K=NOW:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1 S X=$P(^(K,0),"^",2) I '$D(A1(+X)) S A1(+X)=K
F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"DI",K)) Q:K="" S FHORN=$P(^(K,0),"^",14) I FHORN S STS=$P(^(0),"^",15) D U1
K A1,K,X,FHORN,FHL,FHO,FHMSG1,FHSAV,STS Q
U1 I '$D(A1(K)) Q:STS<3 S $P(^FHPT(FHDFN,"A",ADM,"DI",K,0),"^",15)=1,FHSTS=1,FHSAV=$G(^FHPT(FHDFN,"A",ADM,"DI",K,0)) Q:'$D(^OR(100,FHORN)) G U3
N FHMSG1,FHO,FHSAV S FHSAV=$G(^FHPT(FHDFN,"A",ADM,"DI",K,0))
S FHO=$P(FHSAV,"^",2,6),VAL="" D VAL^FHWORP(FHO,.VAL) Q:VAL=""
S FHMSG1=$S($P(FHSAV,"^",7)="N":"N",1:"D")_";"_ADM_";"_K_";"_$P(FHSAV,"^",9)_";"_$P(FHSAV,"^",10)_";"_$P(FHSAV,"^",7)_";"_$G(^FHPT(FHDFN,"A",ADM,"DI",K,1))_";"_$P(FHSAV,"^",8)_";;"_VAL
S FHDAT="",FHSTRT=$P(^FHPT(FHDFN,"A",ADM,"DI",K,0),"^",9) I FHSTRT'=A1(K) S FHDAT=A1(K)
S FHDAT=FHDAT_"^"_$P(^FHPT(FHDFN,"A",ADM,"DI",K,0),"^",10)
S FHSTS=$S(K=A1:6,1:8) I FHSTS'=STS S $P(^FHPT(FHDFN,"A",ADM,"DI",K,0),"^",15)=FHSTS
I '$D(^OR(100,FHORN)) K FHDAT,FHSTRT,FHSTS Q
I $D(FHORN1),FHORN1=FHORN S FHORR=1
I $P(FHSAV,"^",7)="N" D CODE^FHWOR4 D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG,FHDAT,FHSTRT,FHSTS Q
I $P(FHSAV,"^",7)="" D CODE^FHWOR2 D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG
K FHDAT,FHSTRT,FHSTS Q
U3 S FHO=$P(FHSAV,"^",2,6),VAL="" D VAL^FHWORP(FHO,.VAL) Q:VAL=""
S FHMSG1=$S($P(FHSAV,"^",7)="N":"N",1:"D")_";"_ADM_";"_K_";"_$P(FHSAV,"^",9)_";"_$P(FHSAV,"^",10)_";"_$P(FHSAV,"^",7)_";"_$G(^FHPT(FHDFN,"A",ADM,"DI",K,1))_";"_$P(FHSAV,"^",8)_";;"_VAL
I $D(FHORN1),FHORN1=FHORN S FHORR=1
S FHDAT=""
I $P(FHSAV,"^",7)="N" D CODE^FHWOR4 D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG Q
I $P(FHSAV,"^",7)="" D CODE^FHWOR2 D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG
Q
FILE ; File Orders from Dietetics
I FHLD="N" D NPO^FHWOR4 D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG Q
I FHLD="" D DO^FHWOR2 D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG
Q
FHWF2 ; Perform if orders comes from OE/RR
S $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",14)=$S(+FHORN:+FHORN,1:0)
Q:FHLD="X"!(FHLD="P")
Q:'FHORN S VAL="" D VAL^FHWORP(FHOR,.VAL) Q:VAL=""
S FILL=$S(FHLD="N":"N;",1:"D;")_ADM_";"_FHORD_";"_D1_";"_D2_";"_FHLD_";"_COM_";"_TYP_";"_D4_";"_VAL
I FHLD="N" D SEND^FHWOR D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG Q
I FHLD="" D SEND^FHWOR D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) K MSG
Q
WAIT ; Hold screen for OE/RR
Q:$E(IOST,1)'="C" R !!?5,"Press return to continue ",X:DTIME Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD71 4611 printed Apr 09, 2024@21:00:43 Page 2
FHORD71 ; HISC/REL - Diet Order Utilities (cont) ;10/1/96 10:00
+1 ;;5.5;DIETETICS;;Jan 28, 2005
GETD ; Get from/to dates
+1 SET (D1,D2)=0
DO NOW^%DTC
SET NOW=%
SET DT=NOW\1
KILL %,%H,%I
D1 READ !!,"Effective Date/Time: NOW// ",X:DTIME
if '$TEST!(X="^")
QUIT
if X=""
SET X="NOW"
if $EXTRACT($PIECE(X,"@",2),1)?1U
DO CNV
SET %DT="ETSX"
DO ^%DT
if U[X
QUIT
if Y<1
GOTO D1
+1 IF Y<NOW
WRITE *7," Cannot be effective before now!"
GOTO GETD
+2 SET D1=+Y
if 'D3
QUIT
D2 READ !!,"Expiration Date/Time: ",X:DTIME
if '$TEST!(X["^")
GOTO D3
if X=""
QUIT
if $PIECE(X,"@",2)?1U
DO CNV
SET %DT="ETSX"
DO ^%DT
if U[X
GOTO D3
if Y<1
GOTO D2
+1 IF Y'>D1
WRITE *7," Cannot end before effective date!"
GOTO GETD
+2 SET D2=+Y
QUIT
D3 SET D1=0
QUIT
CNV SET DP=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
+1 IF DP'=""
SET DP=$PIECE($GET(^FH(119.6,DP,0)),"^",8)
+2 SET FHPAR=$GET(^FH(119.73,+DP,2))
+3 SET A1=$EXTRACT($PIECE(X,"@",2),1)
IF A1'="M"
SET A1=$SELECT(A1="B":$PIECE(FHPAR,"^",7),A1="N":$PIECE(FHPAR,"^",8),A1="E":$PIECE(FHPAR,"^",9),1:A1)
SET $PIECE(X,"@",2)=A1
QUIT
+4 SET X=$PIECE(X,"@",1)
SET %DT="X"
DO ^%DT
IF Y<1
SET X=X_"@2359"
QUIT
+5 SET X1=Y
SET X2=1
DO C^%DTC
KILL %H,%T
if X<1
QUIT
SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))_"@0001"
QUIT
ACR ; Store AC diet sequence data
+1 if Z6<1
GOTO A1
IF '$DATA(^FHPT(FHDFN,"A",ADM,"AC",0))
SET ^(0)="^115.14^^"
+2 SET ^FHPT(FHDFN,"A",ADM,"AC",+Z6,0)=Z6
SET $PIECE(^FHPT(FHDFN,"A",ADM,"AC",0),"^",3)=+Z6
+3 IF Z6'>NOW
SET Z6=1
GOTO A1
+4 NEW X,X1,FHORN
KILL ZTSAVE
+5 SET ZTIO=""
SET ZTRTN="UPD^FHORD7"
SET ZTREQ="@"
SET ZTDESC="Diet Update"
SET ZTDTH=+Z6
+6 SET ZTSAVE("DFN")=DFN
SET ZTSAVE("FHDFN")=FHDFN
SET ZTSAVE("ADM")=ADM
SET ZTSAVE("Z6")=+Z6
SET ZTSAVE("ZTREQ")=""
DO ^%ZTLOAD
KILL ZTSK
+7 SET Z6=1
A1 SET $PIECE(^FHPT(FHDFN,"A",ADM,"AC",0),"^",4)=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",0),"^",4)+Z6
KILL Z6
QUIT
OE ; File OE/RR Diet Order
+1 if FHLD="X"!(FHLD="P")
QUIT
+2 SET FHO=FHOR
SET VAL=""
DO VAL^FHWORP(FHO,.VAL)
if VAL=""
QUIT
+3 SET FHNEW=$SELECT(FHLD'="":"N",1:"D")_";"_ADM_";"_FHORD_";"_D1_";"_D2_";"_FHLD_";"_COM_";"_TYP_";"_D4_";"_VAL
+4 SET (FHSTS,FHDU)=$SELECT(D1>NOW:8,1:6)
+5 IF FHWF=1
DO FILE
if FHDU
SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",15)=FHDU
QUIT
+6 IF FHWF=2
SET FHDU=+FHORN_"^"_FHDU
DO FHWF2
+7 if +FHDU
SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",14,15)=FHDU
QUIT
OEU ; Update status of OE/RR orders
+1 NEW FHORN
KILL A1
SET A1=0
+2 FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K))
if K>NOW!(K<1)
QUIT
SET A1=K
+3 IF A1
SET X=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2)
SET A1(+X)=A1
SET A1=+X
+4 FOR K=NOW:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K))
if K<1
QUIT
SET X=$PIECE(^(K,0),"^",2)
IF '$DATA(A1(+X))
SET A1(+X)=K
+5 FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"DI",K))
if K=""
QUIT
SET FHORN=$PIECE(^(K,0),"^",14)
IF FHORN
SET STS=$PIECE(^(0),"^",15)
DO U1
+6 KILL A1,K,X,FHORN,FHL,FHO,FHMSG1,FHSAV,STS
QUIT
U1 IF '$DATA(A1(K))
if STS<3
QUIT
SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",K,0),"^",15)=1
SET FHSTS=1
SET FHSAV=$GET(^FHPT(FHDFN,"A",ADM,"DI",K,0))
if '$DATA(^OR(100,FHORN))
QUIT
GOTO U3
+1 NEW FHMSG1,FHO,FHSAV
SET FHSAV=$GET(^FHPT(FHDFN,"A",ADM,"DI",K,0))
+2 SET FHO=$PIECE(FHSAV,"^",2,6)
SET VAL=""
DO VAL^FHWORP(FHO,.VAL)
if VAL=""
QUIT
+3 SET FHMSG1=$SELECT($PIECE(FHSAV,"^",7)="N":"N",1:"D")_";"_ADM_";"_K_";"_$PIECE(FHSAV,"^",9)_";"_$PIECE(FHSAV,"^",10)_";"_$PIECE(FHSAV,"^",7)_";"_$GET(^FHPT(FHDFN,"A",ADM,"DI",K,1))_";"_$PIECE(FHSAV,"^",8)_";;"_VAL
+4 SET FHDAT=""
SET FHSTRT=$PIECE(^FHPT(FHDFN,"A",ADM,"DI",K,0),"^",9)
IF FHSTRT'=A1(K)
SET FHDAT=A1(K)
+5 SET FHDAT=FHDAT_"^"_$PIECE(^FHPT(FHDFN,"A",ADM,"DI",K,0),"^",10)
+6 SET FHSTS=$SELECT(K=A1:6,1:8)
IF FHSTS'=STS
SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",K,0),"^",15)=FHSTS
+7 IF '$DATA(^OR(100,FHORN))
KILL FHDAT,FHSTRT,FHSTS
QUIT
+8 IF $DATA(FHORN1)
IF FHORN1=FHORN
SET FHORR=1
+9 IF $PIECE(FHSAV,"^",7)="N"
DO CODE^FHWOR4
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG,FHDAT,FHSTRT,FHSTS
QUIT
+10 IF $PIECE(FHSAV,"^",7)=""
DO CODE^FHWOR2
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG
+11 KILL FHDAT,FHSTRT,FHSTS
QUIT
U3 SET FHO=$PIECE(FHSAV,"^",2,6)
SET VAL=""
DO VAL^FHWORP(FHO,.VAL)
if VAL=""
QUIT
+1 SET FHMSG1=$SELECT($PIECE(FHSAV,"^",7)="N":"N",1:"D")_";"_ADM_";"_K_";"_$PIECE(FHSAV,"^",9)_";"_$PIECE(FHSAV,"^",10)_";"_$PIECE(FHSAV,"^",7)_";"_$GET(^FHPT(FHDFN,"A",ADM,"DI",K,1))_";"_$PIECE(FHSAV,"^",8)_";;"_VAL
+2 IF $DATA(FHORN1)
IF FHORN1=FHORN
SET FHORR=1
+3 SET FHDAT=""
+4 IF $PIECE(FHSAV,"^",7)="N"
DO CODE^FHWOR4
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG
QUIT
+5 IF $PIECE(FHSAV,"^",7)=""
DO CODE^FHWOR2
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG
+6 QUIT
FILE ; File Orders from Dietetics
+1 IF FHLD="N"
DO NPO^FHWOR4
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG
QUIT
+2 IF FHLD=""
DO DO^FHWOR2
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG
+3 QUIT
FHWF2 ; Perform if orders comes from OE/RR
+1 SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",14)=$SELECT(+FHORN:+FHORN,1:0)
+2 if FHLD="X"!(FHLD="P")
QUIT
+3 if 'FHORN
QUIT
SET VAL=""
DO VAL^FHWORP(FHOR,.VAL)
if VAL=""
QUIT
+4 SET FILL=$SELECT(FHLD="N":"N;",1:"D;")_ADM_";"_FHORD_";"_D1_";"_D2_";"_FHLD_";"_COM_";"_TYP_";"_D4_";"_VAL
+5 IF FHLD="N"
DO SEND^FHWOR
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG
QUIT
+6 IF FHLD=""
DO SEND^FHWOR
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL MSG
+7 QUIT
WAIT ; Hold screen for OE/RR
+1 if $EXTRACT(IOST,1)'="C"
QUIT
READ !!?5,"Press return to continue ",X:DTIME
QUIT
