FHWDIS ; HISC/REL - Close out on discharge ;10/10/00 14:55
;;5.5;DIETETICS;;Jan 28, 2005
; Updated for outpatient meals FHDFN/DFN
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
D NOW^%DTC S FHNOW=%,FHA0=$G(^FHPT(FHDFN,"A",ADM,0)),FHWF=$S($D(^ORD(101)):1,1:0) Q:FHA0="" Q:$P(FHA0,"^",14)
S $P(^FHPT(FHDFN,"A",ADM,0),"^",14)=FHNOW
S FHWRD=$P(FHA0,"^",8),FHRMB=$P(FHA0,"^",9) I FHWRD K ^FHPT("AW",FHWRD,FHDFN) S $P(^FHPT(FHDFN,"A",ADM,0),"^",8,9)="^"
S EVT="L^D^^"_FHWRD_"~"_FHRMB D ^FHORX
; Close out Additional Orders
F FHDR=0:0 S FHDR=$O(^FHPT("AOO",FHDFN,ADM,FHDR)) Q:FHDR<1 D AOO
; Close out Consults
F FHDR=0:0 S FHDR=$O(^FHPT(FHDFN,"A",ADM,"DR",FHDR)) Q:FHDR<1 S Y=^(FHDR,0) D CON
; Close out standing orders
F FHDR=0:0 S FHDR=$O(^FHPT(FHDFN,"A",ADM,"SP",FHDR)) Q:FHDR<1 S Y=^(FHDR,0) D SP
; Cancel tubefeeding
S K=$P(FHA0,"^",4) I K D TF
; Cancel future early/late trays
F FHDR=FHNOW:0 S FHDR=$O(^FHPT(FHDFN,"A",ADM,"EL",FHDR)) Q:FHDR<1 D EL
; Cancel supplemental feeding
S K=$P(FHA0,"^",7) I K D SF
; Cancel isolation/precaution
S K=$P(FHA0,"^",10) I K D IS
; Cancel diet/ place on no order
D DO
I $D(^DPT(DFN,.1)) D WRD^FHWADM
; Delete Diet related Food Restrictions
F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP<1 S FHFP1=$G(^(FHFP,0)) I $P(FHFP1,"^",4)="Y" D FP
KIL K %,%H,%I,%Y,EDT,A1,FHDR,K,FILL,FHNOW,FHO,FHA0,FHFP,FHFP1,FHORD,FHORN,FHPV,FHRMB,FHWRD,FHX,VAL,WKD,X,Y Q
AOO Q:$P(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",5)="X"
S $P(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",5,7)="X^"_FHNOW_"^"_DUZ
K ^FHPT("AOO",FHDFN,ADM,FHDR)
S FHORN=$P(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",8) Q:'FHORN
Q:'$D(^OR(100,+FHORN))
S FILL="A"_";"_ADM-";"_FHDR_$P(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",3)
D SEND
Q
CON Q:$P(Y,"^",8)'="A" S $P(^FHPT(FHDFN,"A",ADM,"DR",FHDR,0),"^",8,11)="X^"_FHNOW_"^"_DUZ_"^"
S K=$P(Y,"^",5)
K:K ^FHPT("ADRU",K,FHDFN,ADM,FHDR) Q
SP Q:$P(Y,"^",6) S $P(^FHPT(FHDFN,"A",ADM,"SP",FHDR,0),"^",6,7)=FHNOW_"^"_DUZ
K ^FHPT("ASP",FHDFN,ADM,FHDR) Q
TF S $P(^FHPT(FHDFN,"A",ADM,0),"^",4)="" K ^FHPT("ADTF",FHDFN,ADM)
S $P(^FHPT(FHDFN,"A",ADM,"TF",K,0),"^",11,12)=FHNOW_"^"_DUZ
S FHX=$G(^FHPT(FHDFN,"A",ADM,"TF",K,0))
S FHORN=$P(FHX,"^",14) Q:'FHORN
Q:'$D(^OR(100,+FHORN))
S FILL="T"_";"_ADM_";"_K_";"_$P(FHX,"^",6)_";"_$P(FHX,"^",7)_";"_$P(FHX,"^",5)_";"
D SEND
Q
EL S FHORN=$P(^FHPT(FHDFN,"A",ADM,"EL",FHDR,0),"^",7)
I FHORN D EL1
K ^FHPT(FHDFN,"A",ADM,"EL",FHDR),^FHPT("ADLT",FHDR,FHDFN,ADM)
S %=$P($G(^FHPT(FHDFN,"A",ADM,"EL",0)),"^",4)-1 S:%'<0 $P(^(0),"^",4)=% Q
EL1 S EDT=FHDR,WKD="" D WKD^FHWOR31
S FHX=$G(^FHPT(FHDFN,"A",ADM,"EL",FHDR,0))
Q:'$D(^OR(100,+FHORN))
S FILL="E"_";"_ADM_";;"_FHDR_";"_FHDR_";"_WKD_";"_$P(FHX,"^",2)_";"_$P(FHX,"^",3)_";"_$P(FHX,"^",4)
D SEND Q
SF S $P(^FHPT(FHDFN,"A",ADM,0),"^",7)=""
S $P(^FHPT(FHDFN,"A",ADM,"SF",K,0),"^",32,33)=FHNOW_"^"_DUZ Q
IS S $P(^FHPT(FHDFN,"A",ADM,0),"^",10)="" K ^FHPT("AIS",FHDFN,ADM)
S FHORN=$P(FHA0,"^",13) Q:'FHORN
Q:'$D(^OR(100,+FHORN))
S FILL="I"_";"_ADM_";"_K D SEND
Q
DO F A1=FHNOW:0 S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1)) Q:A1="" K ^FHPT(FHDFN,"A",ADM,"AC",A1)
F FHDR=0:0 S FHDR=$O(^FHPT(FHDFN,"A",ADM,"DI",FHDR)) Q:FHDR<1 D D1
S FHA0=$P(FHA0,"^",2) Q:'FHA0 S FHA0=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHA0,0)),"^",7) Q:FHA0="X"
D ORD^FHORD7 S ^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)=FHORD_"^^^^^^X^^"_FHNOW_"^^"_DUZ_"^"_FHNOW
S ^FHPT(FHDFN,"A",ADM,"AC",FHNOW,0)=FHNOW_"^"_FHORD
S $P(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=FHORD_"^" Q
D1 ; Get all filler fields for Diet
S FHORN=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0)),"^",14,15)
I +FHORN>0,$P(FHORN,"^",2)>2 S FHORN=+FHORN,$P(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0),"^",15)=1 D D2
Q
D2 S FHX=$G(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0))
Q:$P(FHX,"^",7)="P"!($P(FHX,"^",7)="X")
S FHO=$P(FHX,"^",2,6),VAL="" D VAL^FHWORP(FHO,.VAL) Q:VAL=""
Q:'$D(^OR(100,+FHORN))
S FILL=$S($P(FHX,"^",7)="N":"N",1:"D")_";"_ADM_";"_FHDR_";"_$P(FHX,"^",9)_";"_$P(FHX,"^",10)_";"_$P(FHX,"^",7)_";"_$G(^FHPT(FHDFN,"A",ADM,"DI",FHDR,1))_";"_$P(FHX,"^",8)_";;"_VAL
D SEND Q
FP K ^FHPT(FHDFN,"P",FHFP,0),^FHPT(FHDFN,"P","B",+FHFP1,FHFP)
S %=$P($G(^FHPT(FHDFN,"P",0)),"^",4)-1 S:%'<0 $P(^(0),"^",4)=% Q
SEND ; Send MSG to OE/RR
D CODE D:$D(MSG) MSG^XQOR("FH EVSEND OR",.MSG) Q
CODE ; Code Cancel For Discharge
K MSG S ACT="OC" D SITE^FH
; code MSH
S MSG(1)="MSH|^~\&|DIETETICS|"_SITE(1)_"|||||ORM"
; code PID
S MSG(2)="PID|||"_DFN_"||"_$P($G(^DPT(DFN,0)),"^",1)
; code ORC
S DATE=$$FMTHL7^XLFDT(FHNOW),FHPV=DUZ
S MSG(3)="ORC|"_ACT_"|"_FHORN_"^OR|"_FILL_"^FH|||||||||"_FHPV_"|||"_DATE_"|Dietetics Canceled Order."
K %,ACT,DATE,FILL,SITE Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHWDIS 4688 printed Dec 13, 2024@01:55:15 Page 2
FHWDIS ; HISC/REL - Close out on discharge ;10/10/00 14:55
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 ; Updated for outpatient meals FHDFN/DFN
+3 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+4 DO NOW^%DTC
SET FHNOW=%
SET FHA0=$GET(^FHPT(FHDFN,"A",ADM,0))
SET FHWF=$SELECT($DATA(^ORD(101)):1,1:0)
if FHA0=""
QUIT
if $PIECE(FHA0,"^",14)
QUIT
+5 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",14)=FHNOW
+6 SET FHWRD=$PIECE(FHA0,"^",8)
SET FHRMB=$PIECE(FHA0,"^",9)
IF FHWRD
KILL ^FHPT("AW",FHWRD,FHDFN)
SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",8,9)="^"
+7 SET EVT="L^D^^"_FHWRD_"~"_FHRMB
DO ^FHORX
+8 ; Close out Additional Orders
+9 FOR FHDR=0:0
SET FHDR=$ORDER(^FHPT("AOO",FHDFN,ADM,FHDR))
if FHDR<1
QUIT
DO AOO
+10 ; Close out Consults
+11 FOR FHDR=0:0
SET FHDR=$ORDER(^FHPT(FHDFN,"A",ADM,"DR",FHDR))
if FHDR<1
QUIT
SET Y=^(FHDR,0)
DO CON
+12 ; Close out standing orders
+13 FOR FHDR=0:0
SET FHDR=$ORDER(^FHPT(FHDFN,"A",ADM,"SP",FHDR))
if FHDR<1
QUIT
SET Y=^(FHDR,0)
DO SP
+14 ; Cancel tubefeeding
+15 SET K=$PIECE(FHA0,"^",4)
IF K
DO TF
+16 ; Cancel future early/late trays
+17 FOR FHDR=FHNOW:0
SET FHDR=$ORDER(^FHPT(FHDFN,"A",ADM,"EL",FHDR))
if FHDR<1
QUIT
DO EL
+18 ; Cancel supplemental feeding
+19 SET K=$PIECE(FHA0,"^",7)
IF K
DO SF
+20 ; Cancel isolation/precaution
+21 SET K=$PIECE(FHA0,"^",10)
IF K
DO IS
+22 ; Cancel diet/ place on no order
+23 DO DO
+24 IF $DATA(^DPT(DFN,.1))
DO WRD^FHWADM
+25 ; Delete Diet related Food Restrictions
+26 FOR FHFP=0:0
SET FHFP=$ORDER(^FHPT(FHDFN,"P",FHFP))
if FHFP<1
QUIT
SET FHFP1=$GET(^(FHFP,0))
IF $PIECE(FHFP1,"^",4)="Y"
DO FP
KIL KILL %,%H,%I,%Y,EDT,A1,FHDR,K,FILL,FHNOW,FHO,FHA0,FHFP,FHFP1,FHORD,FHORN,FHPV,FHRMB,FHWRD,FHX,VAL,WKD,X,Y
QUIT
AOO if $PIECE(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",5)="X"
QUIT
+1 SET $PIECE(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",5,7)="X^"_FHNOW_"^"_DUZ
+2 KILL ^FHPT("AOO",FHDFN,ADM,FHDR)
+3 SET FHORN=$PIECE(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",8)
if 'FHORN
QUIT
+4 if '$DATA(^OR(100,+FHORN))
QUIT
+5 SET FILL="A"_";"_ADM-";"_FHDR_$PIECE(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",3)
+6 DO SEND
+7 QUIT
CON if $PIECE(Y,"^",8)'="A"
QUIT
SET $PIECE(^FHPT(FHDFN,"A",ADM,"DR",FHDR,0),"^",8,11)="X^"_FHNOW_"^"_DUZ_"^"
+1 SET K=$PIECE(Y,"^",5)
+2 if K
KILL ^FHPT("ADRU",K,FHDFN,ADM,FHDR)
QUIT
SP if $PIECE(Y,"^",6)
QUIT
SET $PIECE(^FHPT(FHDFN,"A",ADM,"SP",FHDR,0),"^",6,7)=FHNOW_"^"_DUZ
+1 KILL ^FHPT("ASP",FHDFN,ADM,FHDR)
QUIT
TF SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",4)=""
KILL ^FHPT("ADTF",FHDFN,ADM)
+1 SET $PIECE(^FHPT(FHDFN,"A",ADM,"TF",K,0),"^",11,12)=FHNOW_"^"_DUZ
+2 SET FHX=$GET(^FHPT(FHDFN,"A",ADM,"TF",K,0))
+3 SET FHORN=$PIECE(FHX,"^",14)
if 'FHORN
QUIT
+4 if '$DATA(^OR(100,+FHORN))
QUIT
+5 SET FILL="T"_";"_ADM_";"_K_";"_$PIECE(FHX,"^",6)_";"_$PIECE(FHX,"^",7)_";"_$PIECE(FHX,"^",5)_";"
+6 DO SEND
+7 QUIT
EL SET FHORN=$PIECE(^FHPT(FHDFN,"A",ADM,"EL",FHDR,0),"^",7)
+1 IF FHORN
DO EL1
+2 KILL ^FHPT(FHDFN,"A",ADM,"EL",FHDR),^FHPT("ADLT",FHDR,FHDFN,ADM)
+3 SET %=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"EL",0)),"^",4)-1
if %'<0
SET $PIECE(^(0),"^",4)=%
QUIT
EL1 SET EDT=FHDR
SET WKD=""
DO WKD^FHWOR31
+1 SET FHX=$GET(^FHPT(FHDFN,"A",ADM,"EL",FHDR,0))
+2 if '$DATA(^OR(100,+FHORN))
QUIT
+3 SET FILL="E"_";"_ADM_";;"_FHDR_";"_FHDR_";"_WKD_";"_$PIECE(FHX,"^",2)_";"_$PIECE(FHX,"^",3)_";"_$PIECE(FHX,"^",4)
+4 DO SEND
QUIT
SF SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",7)=""
+1 SET $PIECE(^FHPT(FHDFN,"A",ADM,"SF",K,0),"^",32,33)=FHNOW_"^"_DUZ
QUIT
IS SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",10)=""
KILL ^FHPT("AIS",FHDFN,ADM)
+1 SET FHORN=$PIECE(FHA0,"^",13)
if 'FHORN
QUIT
+2 if '$DATA(^OR(100,+FHORN))
QUIT
+3 SET FILL="I"_";"_ADM_";"_K
DO SEND
+4 QUIT
DO FOR A1=FHNOW:0
SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",A1))
if A1=""
QUIT
KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
+1 FOR FHDR=0:0
SET FHDR=$ORDER(^FHPT(FHDFN,"A",ADM,"DI",FHDR))
if FHDR<1
QUIT
DO D1
+2 SET FHA0=$PIECE(FHA0,"^",2)
if 'FHA0
QUIT
SET FHA0=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",FHA0,0)),"^",7)
if FHA0="X"
QUIT
+3 DO ORD^FHORD7
SET ^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)=FHORD_"^^^^^^X^^"_FHNOW_"^^"_DUZ_"^"_FHNOW
+4 SET ^FHPT(FHDFN,"A",ADM,"AC",FHNOW,0)=FHNOW_"^"_FHORD
+5 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",2,3)=FHORD_"^"
QUIT
D1 ; Get all filler fields for Diet
+1 SET FHORN=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0)),"^",14,15)
+2 IF +FHORN>0
IF $PIECE(FHORN,"^",2)>2
SET FHORN=+FHORN
SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0),"^",15)=1
DO D2
+3 QUIT
D2 SET FHX=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0))
+1 if $PIECE(FHX,"^",7)="P"!($PIECE(FHX,"^",7)="X")
QUIT
+2 SET FHO=$PIECE(FHX,"^",2,6)
SET VAL=""
DO VAL^FHWORP(FHO,.VAL)
if VAL=""
QUIT
+3 if '$DATA(^OR(100,+FHORN))
QUIT
+4 SET FILL=$SELECT($PIECE(FHX,"^",7)="N":"N",1:"D")_";"_ADM_";"_FHDR_";"_$PIECE(FHX,"^",9)_";"_$PIECE(FHX,"^",10)_";"_$PIECE(FHX,"^",7)_";"_$GET(^FHPT(FHDFN,"A",ADM,"DI",FHDR,1))_";"_$PIECE(FHX,"^",8)_";;"_VAL
+5 DO SEND
QUIT
FP KILL ^FHPT(FHDFN,"P",FHFP,0),^FHPT(FHDFN,"P","B",+FHFP1,FHFP)
+1 SET %=$PIECE($GET(^FHPT(FHDFN,"P",0)),"^",4)-1
if %'<0
SET $PIECE(^(0),"^",4)=%
QUIT
SEND ; Send MSG to OE/RR
+1 DO CODE
if $DATA(MSG)
DO MSG^XQOR("FH EVSEND OR",.MSG)
QUIT
CODE ; Code Cancel For Discharge
+1 KILL MSG
SET ACT="OC"
DO SITE^FH
+2 ; code MSH
+3 SET MSG(1)="MSH|^~\&|DIETETICS|"_SITE(1)_"|||||ORM"
+4 ; code PID
+5 SET MSG(2)="PID|||"_DFN_"||"_$PIECE($GET(^DPT(DFN,0)),"^",1)
+6 ; code ORC
+7 SET DATE=$$FMTHL7^XLFDT(FHNOW)
SET FHPV=DUZ
+8 SET MSG(3)="ORC|"_ACT_"|"_FHORN_"^OR|"_FILL_"^FH|||||||||"_FHPV_"|||"_DATE_"|Dietetics Canceled Order."
+9 KILL %,ACT,DATE,FILL,SITE
QUIT
