- 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 Mar 13, 2025@20:59:54 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
