FHWDISD ; HISC/REL - Delete Discharge ;2/2/95 10:14
;;5.5;DIETETICS;;Jan 28, 2005
D DID^FHDPA Q:WARD="" S ADM=$G(^DPT("CN",WARD,DFN)) Q:'ADM
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
S A0=$G(^FHPT(FHDFN,"A",ADM,0)),FHWF=$S($D(^ORD(101)):1,1:0) Q:A0=""
S TIM=$P(A0,"^",14) Q:'TIM S $P(^FHPT(FHDFN,"A",ADM,0),"^",14)="" Q
; Re-instate Additional Orders
F FHDR=0:0 S FHDR=$O(^FHPT("AOO",FHDFN,ADM,FHDR)) Q:FHDR<1 S Y=$G(^(FHDR,0)) D AOO
; Re-instate Consults
F FHDR=0:0 S FHDR=$O(^FHPT(FHDFN,"A",ADM,"DR",FHDR)) Q:FHDR<1 S Y=$G(^(FHDR,0)) D CON
; Re-instate Standing Orders
F FHDR=0:0 S FHDR=$O(^FHPT(FHDFN,"A",ADM,"SP",FHDR)) Q:FHDR<1 S Y=^(FHDR,0) D SP
; Re-instate Tubefeeding
F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"TF",K)) Q:K<1 I $P($G(^(K,0)),"^",11)=TIM D TF
; Re-instate Supplemental Feeding
F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"SF",K)) Q:K<1 I $P($G(^(K,0)),"^",32)=TIM D SF
; Re-instate Diet Order
D DO,WRD^FHWADM
KIL K %,%H,%I,A0,A1,FHDR,K,TIM,FHORD,FHRMB,FHWRD,FHX1,FHX2,FHX3,X,Y Q
AOO Q:$P(Y,"^",5,6)'=("X^"_TIM)
S $P(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",5,7)="A^^"
S ^FHPT("AOO",FHDFN,ADM,FHDR)="" Q
CON Q:$P(Y,"^",8,9)'=("X^"_TIM) S $P(^FHPT(FHDFN,"A",ADM,"DR",FHDR,0),"^",8,11)="A^^^"
S K=$P(Y,"^",5) S:K ^FHPT("ADRU",K,FHDFN,ADM,FHDR)="" Q
SP Q:$P(Y,"^",6)'=TIM S $P(^FHPT(FHDFN,"A",ADM,"SP",FHDR,0),"^",6,7)="^"
S ^FHPT("ASP",FHDFN,ADM,FHDR)="" Q
TF S $P(^FHPT(FHDFN,"A",ADM,0),"^",4)=K S ^FHPT("ADTF",FHDFN,ADM)=""
S $P(^FHPT(FHDFN,"A",ADM,"TF",K,0),"^",11,12)="^" Q
SF S $P(^FHPT(FHDFN,"A",ADM,0),"^",7)=K
S $P(^FHPT(FHDFN,"A",ADM,"SF",K,0),"^",32,33)="^" Q
DO S FHORD=$P($G(^FHPT(FHDFN,"A",ADM,"AC",TIM,0)),"^",2) Q:'FHORD
Q:$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),"^",7)'="X"
K ^FHPT(FHDFN,"A",ADM,"AC",TIM)
S FHORD="" F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>TIM) S FHORD=$P(^(K,0),"^",2)
Q:'FHORD S $P(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=FHORD_"^" S EVT="D^O^"_FHORD D ^FHORX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHWDISD 1984 printed Nov 22, 2024@17:05:27 Page 2
FHWDISD ; HISC/REL - Delete Discharge ;2/2/95 10:14
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 DO DID^FHDPA
if WARD=""
QUIT
SET ADM=$GET(^DPT("CN",WARD,DFN))
if 'ADM
QUIT
+3 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+4 SET A0=$GET(^FHPT(FHDFN,"A",ADM,0))
SET FHWF=$SELECT($DATA(^ORD(101)):1,1:0)
if A0=""
QUIT
+5 SET TIM=$PIECE(A0,"^",14)
if 'TIM
QUIT
SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",14)=""
QUIT
+6 ; Re-instate Additional Orders
+7 FOR FHDR=0:0
SET FHDR=$ORDER(^FHPT("AOO",FHDFN,ADM,FHDR))
if FHDR<1
QUIT
SET Y=$GET(^(FHDR,0))
DO AOO
+8 ; Re-instate Consults
+9 FOR FHDR=0:0
SET FHDR=$ORDER(^FHPT(FHDFN,"A",ADM,"DR",FHDR))
if FHDR<1
QUIT
SET Y=$GET(^(FHDR,0))
DO CON
+10 ; Re-instate Standing Orders
+11 FOR FHDR=0:0
SET FHDR=$ORDER(^FHPT(FHDFN,"A",ADM,"SP",FHDR))
if FHDR<1
QUIT
SET Y=^(FHDR,0)
DO SP
+12 ; Re-instate Tubefeeding
+13 FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"TF",K))
if K<1
QUIT
IF $PIECE($GET(^(K,0)),"^",11)=TIM
DO TF
+14 ; Re-instate Supplemental Feeding
+15 FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"SF",K))
if K<1
QUIT
IF $PIECE($GET(^(K,0)),"^",32)=TIM
DO SF
+16 ; Re-instate Diet Order
+17 DO DO
DO WRD^FHWADM
KIL KILL %,%H,%I,A0,A1,FHDR,K,TIM,FHORD,FHRMB,FHWRD,FHX1,FHX2,FHX3,X,Y
QUIT
AOO if $PIECE(Y,"^",5,6)'=("X^"_TIM)
QUIT
+1 SET $PIECE(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",5,7)="A^^"
+2 SET ^FHPT("AOO",FHDFN,ADM,FHDR)=""
QUIT
CON if $PIECE(Y,"^",8,9)'=("X^"_TIM)
QUIT
SET $PIECE(^FHPT(FHDFN,"A",ADM,"DR",FHDR,0),"^",8,11)="A^^^"
+1 SET K=$PIECE(Y,"^",5)
if K
SET ^FHPT("ADRU",K,FHDFN,ADM,FHDR)=""
QUIT
SP if $PIECE(Y,"^",6)'=TIM
QUIT
SET $PIECE(^FHPT(FHDFN,"A",ADM,"SP",FHDR,0),"^",6,7)="^"
+1 SET ^FHPT("ASP",FHDFN,ADM,FHDR)=""
QUIT
TF SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",4)=K
SET ^FHPT("ADTF",FHDFN,ADM)=""
+1 SET $PIECE(^FHPT(FHDFN,"A",ADM,"TF",K,0),"^",11,12)="^"
QUIT
SF SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",7)=K
+1 SET $PIECE(^FHPT(FHDFN,"A",ADM,"SF",K,0),"^",32,33)="^"
QUIT
DO SET FHORD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"AC",TIM,0)),"^",2)
if 'FHORD
QUIT
+1 if $PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),"^",7)'="X"
QUIT
+2 KILL ^FHPT(FHDFN,"A",ADM,"AC",TIM)
+3 SET FHORD=""
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K))
if K<1!(K>TIM)
QUIT
SET FHORD=$PIECE(^(K,0),"^",2)
+4 if 'FHORD
QUIT
SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=FHORD_"^"
SET EVT="D^O^"_FHORD
DO ^FHORX
+5 QUIT
