- 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 Feb 18, 2025@23:19:57 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
