FHORD3 ; HISC/REL/NCA - Withhold Service ;8/20/96 09:09 ;
;;5.5;DIETETICS;;Jan 28, 2005;
F0 S ALL=0 D ^FHDPA G:'DFN KIL^FHORD1 G:'FHDFN KIL^FHORD1
D NOW^%DTC S NOW=% D CUR,FUT^FHORD1
W !!,"Place patient on NPO/HOLD-TRAY." D F5 Q:'$D(DFN) Q:'$D(FHDFN) D F7 W !!,"... done" G F0
F5 ; Process NPO
S D3=1 D GETD^FHORD71 G:'D1 AB
F6 R !!,"Comment: ",COM:DTIME G:'$T!(COM[U) AB I COM'?.ANP W *7," ??" G F6
I $L(COM)>80!(COM?1"?".E) W *7,!,"Enter comment of up to 80 characters!" G F6
Q
F7 ; File NPO
S FHOR="^^^^",FHLD="N",TYP="",D4=0 D STR^FHORD7
G KIL^FHORD1
EN2 ; Cancel Withhold Order
D NOW^%DTC S NOW=%,DT=%\1
S ALL=0 D ^FHDPA G:'DFN KIL G:'FHDFN KIL D CUR S OLD=FHLD
S (A2,CT)=0 F KK=0:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1!(KK'<NOW) S A2=KK
S XT="" K N F KK=A2-.000001:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1 S FHORD=$P(^(KK,0),"^",2) D T1
I 'CT W !!,"No WITHHOLD Orders to Cancel" G KIL
C0 R !!,"Cancel Which Order #? ",X:DTIME G:'$T!("^"[X) AB I X'?1N.N!(X<1)!(X>CT) W *7," Enter # of Order to Cancel" G C0
S FHORD=$P(XT,",",X),KK=N(FHORD) D T0 G KIL
T0 ; Update cancelled NPO
S X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),D1=$P(X,"^",9),D2=$S(D1'>NOW:NOW,1:D1)
S $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",10)=D2
S $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",18,19)=D2_"^"_DUZ
S:FHWF'=2 FHORN=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",14)
F K9=KK-.000001:0 S K9=$O(^FHPT(FHDFN,"A",ADM,"AC",K9)) Q:K9<1 I $P(^(K9,0),"^",2)=FHORD S D1=K9 D S0
D UPD^FHORD7 W:FHWF'=2 " ... done" Q:FHWF=2 D CUR
I OLD'="","^^^^"'[FHOR S D1=NOW D ^FHORD1A
Q
S0 ; Set AC cross-ref data field
S X2=D1+.0000001,D2=$O(^FHPT(FHDFN,"A",ADM,"AC",D1)) S:D2<1 D2=""
S1 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'>D1 G S1
D:'A2 NOR S Z6=D1_"^"_A2 D ACR^FHORD71
I X1'="",D2=""!(X1<D2) S D1=X1 G S0
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 Q
SK K ^FHPT(FHDFN,"A",ADM,"AC",A1) S Z6=-1 G ACR^FHORD71
NOR L +^FHPT(FHDFN,"A",ADM,"DI",0)
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),A2=$P(X,"^",3)+1,^(0)=$P(X,"^",1,2)_"^"_A2_"^"_($P(X,"^",4)+1) L -^FHPT(FHDFN,"A",ADM,"DI",0)
S ^FHPT(FHDFN,"A",ADM,"DI",A2,0)=A2_"^^^^^^X^^"_D1_"^^"_DUZ_"^"_NOW,X="" Q
CUR D CUR^FHORD7 W !!,"Current Diet: ",$S(Y'="":Y,1:"No Current Order")
Q:'FHORD S X9=$P(X,"^",8) W:X9'="" " (",$S(X9="T":"Tray",X9="D":"Dining Room",1:"Cafe"),")" Q
T1 Q:'$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))!($D(N(FHORD))) Q:$P(^(0),"^",7)="" S P2=$P(^(0),"^",10)
S DTP=KK D DTP^FH,C2^FHORD7
I 'CT W !!," # Effective Expires Order",!
S CT=CT+1,XT=XT_FHORD_",",N(FHORD)=KK W !,$J(CT,2)," ",DTP
S DTP=P2 D:DTP DTP^FH W ?24,DTP,?47,Y Q
AB W *7,!!,"Withhold entry TERMINATED - No change!"
KIL K %,%H,%I,C,CT,DA,DG,DLB,DTP,I,K9,N,OLD,POP,P2,X9,XT G KIL^FHORD1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD3 3344 printed Apr 09, 2024@21:01 Page 2
FHORD3 ; HISC/REL/NCA - Withhold Service ;8/20/96 09:09 ;
+1 ;;5.5;DIETETICS;;Jan 28, 2005;
F0 SET ALL=0
DO ^FHDPA
if 'DFN
GOTO KIL^FHORD1
if 'FHDFN
GOTO KIL^FHORD1
+1 DO NOW^%DTC
SET NOW=%
DO CUR
DO FUT^FHORD1
+2 WRITE !!,"Place patient on NPO/HOLD-TRAY."
DO F5
if '$DATA(DFN)
QUIT
if '$DATA(FHDFN)
QUIT
DO F7
WRITE !!,"... done"
GOTO F0
F5 ; Process NPO
+1 SET D3=1
DO GETD^FHORD71
if 'D1
GOTO AB
F6 READ !!,"Comment: ",COM:DTIME
if '$TEST!(COM[U)
GOTO AB
IF COM'?.ANP
WRITE *7," ??"
GOTO F6
+1 IF $LENGTH(COM)>80!(COM?1"?".E)
WRITE *7,!,"Enter comment of up to 80 characters!"
GOTO F6
+2 QUIT
F7 ; File NPO
+1 SET FHOR="^^^^"
SET FHLD="N"
SET TYP=""
SET D4=0
DO STR^FHORD7
+2 GOTO KIL^FHORD1
EN2 ; Cancel Withhold Order
+1 DO NOW^%DTC
SET NOW=%
SET DT=%\1
+2 SET ALL=0
DO ^FHDPA
if 'DFN
GOTO KIL
if 'FHDFN
GOTO KIL
DO CUR
SET OLD=FHLD
+3 SET (A2,CT)=0
FOR KK=0:0
SET KK=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",KK))
if KK<1!(KK'<NOW)
QUIT
SET A2=KK
+4 SET XT=""
KILL N
FOR KK=A2-.000001:0
SET KK=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",KK))
if KK<1
QUIT
SET FHORD=$PIECE(^(KK,0),"^",2)
DO T1
+5 IF 'CT
WRITE !!,"No WITHHOLD Orders to Cancel"
GOTO KIL
C0 READ !!,"Cancel Which Order #? ",X:DTIME
if '$TEST!("^"[X)
GOTO AB
IF X'?1N.N!(X<1)!(X>CT)
WRITE *7," Enter # of Order to Cancel"
GOTO C0
+1 SET FHORD=$PIECE(XT,",",X)
SET KK=N(FHORD)
DO T0
GOTO KIL
T0 ; Update cancelled NPO
+1 SET X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)
SET D1=$PIECE(X,"^",9)
SET D2=$SELECT(D1'>NOW:NOW,1:D1)
+2 SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",10)=D2
+3 SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",18,19)=D2_"^"_DUZ
+4 if FHWF'=2
SET FHORN=$PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",14)
+5 FOR K9=KK-.000001:0
SET K9=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K9))
if K9<1
QUIT
IF $PIECE(^(K9,0),"^",2)=FHORD
SET D1=K9
DO S0
+6 DO UPD^FHORD7
if FHWF'=2
WRITE " ... done"
if FHWF=2
QUIT
DO CUR
+7 IF OLD'=""
IF "^^^^"'[FHOR
SET D1=NOW
DO ^FHORD1A
+8 QUIT
S0 ; Set AC cross-ref data field
+1 SET X2=D1+.0000001
SET D2=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",D1))
if D2<1
SET D2=""
S1 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'>D1
GOTO S1
+2 if 'A2
DO NOR
SET Z6=D1_"^"_A2
DO ACR^FHORD71
+3 IF X1'=""
IF D2=""!(X1<D2)
SET D1=X1
GOTO S0
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
QUIT
SK KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
SET Z6=-1
GOTO ACR^FHORD71
NOR LOCK +^FHPT(FHDFN,"A",ADM,"DI",0)
+1 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",0))
SET ^FHPT(FHDFN,"A",ADM,"DI",0)="^115.02A^^"
+2 SET X=^FHPT(FHDFN,"A",ADM,"DI",0)
SET A2=$PIECE(X,"^",3)+1
SET ^(0)=$PIECE(X,"^",1,2)_"^"_A2_"^"_($PIECE(X,"^",4)+1)
LOCK -^FHPT(FHDFN,"A",ADM,"DI",0)
+3 SET ^FHPT(FHDFN,"A",ADM,"DI",A2,0)=A2_"^^^^^^X^^"_D1_"^^"_DUZ_"^"_NOW
SET X=""
QUIT
CUR DO CUR^FHORD7
WRITE !!,"Current Diet: ",$SELECT(Y'="":Y,1:"No Current Order")
+1 if 'FHORD
QUIT
SET X9=$PIECE(X,"^",8)
if X9'=""
WRITE " (",$SELECT(X9="T":"Tray",X9="D":"Dining Room",1:"Cafe"),")"
QUIT
T1 if '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))!($DATA(N(FHORD)))
QUIT
if $PIECE(^(0),"^",7)=""
QUIT
SET P2=$PIECE(^(0),"^",10)
+1 SET DTP=KK
DO DTP^FH
DO C2^FHORD7
+2 IF 'CT
WRITE !!," # Effective Expires Order",!
+3 SET CT=CT+1
SET XT=XT_FHORD_","
SET N(FHORD)=KK
WRITE !,$JUSTIFY(CT,2)," ",DTP
+4 SET DTP=P2
if DTP
DO DTP^FH
WRITE ?24,DTP,?47,Y
QUIT
AB WRITE *7,!!,"Withhold entry TERMINATED - No change!"
KIL KILL %,%H,%I,C,CT,DA,DG,DLB,DTP,I,K9,N,OLD,POP,P2,X9,XT
GOTO KIL^FHORD1
