FHWADM ; HISC/REL - Set up admission ;12/4/00 10:35
;;5.5;DIETETICS;**5,8,21**;Jan 28, 2005;Build 6
; Changes necessary for new file #115 design:
; The .01 (1 piece of 0 node) for inpatients is now "P"_DFN (ie P7623)
; Therefore this file is no longer DINUMed to file #2.
N FHWF S FHWF=$S($D(^ORD(101)):1,1:0)
S FHZ115="P"_DFN D ADD^FHOMDPA
I '$D(^FHPT(FHDFN,"A",0)) S ^FHPT(FHDFN,"A",0)="^115.01^^"
D UPALFP ;update food pref's based on allergy data
D OPM ;cancel any existing outpatient meals
D NOW^%DTC S (FHNOW,FHX3,X)=$S($D(^DGPM(ADM,0)):$P(^(0),"^",1),1:%)
I $D(^FHPT(FHDFN,"A",ADM)) S $P(^(ADM,0),"^",1)=X G:$G(^DPT(DFN,.105))'=ADM KIL G UPD
S $P(^FHPT(FHDFN,"A",0),"^",3)=ADM,$P(^(0),"^",4)=$P(^(0),"^",4)+1
S ^FHPT(FHDFN,"A",ADM,0)=X_"^^^^^^^^"
S FHX1=$G(^DPT(DFN,.108)),FHX2=""
I FHX1 S FHX1=$O(^FH(119.6,"AR",FHX1,0))
I 'FHX1 S FHX1=$G(^DPT(DFN,.1)) I FHX1'="" S FHX1=$O(^DIC(42,"B",FHX1,0)) S:FHX1 FHX1=$O(^FH(119.6,"AW",FHX1,0))
S FHX1=$G(^FH(119.6,+FHX1,0))
S FHX2=$P(FHX1,"^",16),FHX1=$P(FHX1,"^",15) I 'FHX1,FHX2'="Y" G UPD
S X=$S(FHX3>%:FHX3,1:%)
S ^FHPT(FHDFN,"A",ADM,"AC",X,0)=X_"^1",^FHPT(FHDFN,"A",ADM,"AC",0)="^115.14^"_X_"^1",^FHPT(FHDFN,"A",ADM,"DI",0)="^115.02A^1^1"
S $P(^FHPT(FHDFN,"A",ADM,0),"^",2)=1
I 'FHX1 S ^FHPT(FHDFN,"A",ADM,"DI",1,0)="1^^^^^^X^^"_X_"^^"_DUZ_"^"_% S EVT="D^O^1" D ^FHORX G UPD
S FHX2=$P($G(^FH(111,FHX1,0)),"^",5)
S ^FHPT(FHDFN,"A",ADM,"DI",1,0)="1^"_FHX1_"^^^^^^T^"_X_"^^"_DUZ_"^"_%_"^"_FHX2
S $P(^FHPT(FHDFN,"A",ADM,0),"^",5)="T" S EVT="D^O^1" D ^FHORX
I 'FHWF S FHOR=FHX1_"^^^^" D ADD K FHOR G UPD
S FHNEW="D;"_ADM_";"_1_";"_X_";;;;T;;"_FHX1_";;;;",D1=X,D2="" D NOW^%DTC S NOW=%,FHPV=DUZ,FHOR=FHX1_"^^^^" D DO^FHWOR2
S $P(^FHPT(FHDFN,"A",ADM,0),"^",14)="" D WRD D MSG^XQOR("FH EVSEND OR",.MSG) K D1,D2,FHPV,FHNEW,MSG,NOW S $P(^FHPT(FHDFN,"A",ADM,"DI",1,0),"^",15)=6 D ADD K FHOR G KIL
UPD S $P(^FHPT(FHDFN,"A",ADM,0),"^",14)="" D WRD G KIL
WRD ; Update Room/Bed & Ward for current admission
N FHWRD,FHRMB,WARD D DID^FHDPA Q:WARD="" S ADM=$G(^DPT("CN",WARD,DFN)) Q:'ADM
I '$D(^FHPT(FHDFN,"A",ADM,0)) Q
S WARD=$P(^FHPT(FHDFN,"A",ADM,0),"^",8),EVT="L^"_$S(WARD:"T",1:"A")_"^^"_WARD_"~"_$P(^(0),"^",9) I WARD'=FHWRD G NEW
I $P(^FHPT(FHDFN,"A",ADM,0),"^",9)'=FHRMB S $P(^(0),"^",9)=FHRMB S EVT=EVT_"~"_FHWRD_"~"_FHRMB D ^FHORX
Q
NEW ; New Ward
S $P(^FHPT(FHDFN,"A",ADM,0),"^",8,9)=FHWRD_"^"_FHRMB
K:WARD ^FHPT("AW",WARD,FHDFN) I FHWRD S ^FHPT("AW",FHWRD,FHDFN)=ADM S EVT=EVT_"~"_FHWRD_"~"_FHRMB D ^FHORX
; Update Type of Service
S FHX3=$P($G(^FH(119.6,+FHWRD,0)),"^",10) S:FHX3="" FHX3="TCD" I FHX3[$P(^FHPT(FHDFN,"A",ADM,0),"^",5) Q
S FHX3=$S($L(FHX3)=1:FHX3,FHX3["D":"D",1:"C"),$P(^FHPT(FHDFN,"A",ADM,0),"^",5)=FHX3
S FHX2=$P(^FHPT(FHDFN,"A",ADM,0),"^",2) I FHX2,$P($G(^FHPT(FHDFN,"A",ADM,"DI",+FHX2,0)),"^",8)'="" S $P(^(0),"^",8)=FHX3
Q
ADD ; Add diet associated Diet Restriction
D NOW^%DTC S NOW=%
S DPAT=$O(^FH(111.1,"AB",FHOR,0))
D UPD^FHMTK7
K COM,DPAT,EVT,FP,L,LN,LP,LS,M,M1,M2,MEAL,N,NM,NO,NUM,NX,OPAT,P,PP,PNN,PNO,R1,SF,SP,X3,^TMP($J),Z
Q
UPALFP ;Update Food Preferences for all Patient's based on Allergies
I FHDFN="" Q
K FHMISS D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q
F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP^FHWGMR
K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT
Q
OPM ; Delete any future outpatient meals orders upon patient admission
I '$D(^FHPT(FHDFN,"OP")),'$D(^FHPT(FHDFN,"SM")),'$D(^FHPT(FHDFN,"GM")) Q
S X1=DT,X2=-1 D C^%DTC S FHDT=X_.999
F FHRMDT=FHDT:0 S FHRMDT=$O(^FHPT(FHDFN,"OP","B",FHRMDT)) Q:FHRMDT'>0 F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM)) Q:FHRNUM'>0 D CANRM
F FHSM=FHDT:0 S FHSM=$O(^FHPT(FHDFN,"SM",FHSM)) Q:FHSM'>0 D CANSM
F FHGM=FHDT:0 S FHGM=$O(^FHPT(FHDFN,"GM",FHGM)) Q:FHGM'>0 D CANGM
Q
CANRM ;
D CANRM^FHOMRC1
S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,12)
S FHMPNUM=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,6)
S FHDT2=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,1)
S FILL="R;"_FHMPNUM_";"_FHDT2_";"_FHDT2_";;"
D CAN
I $D(^FHPT(FHDFN,"OP",FHRNUM,1)) D CNAO100,CANAO^FHOMRC1
I $D(^FHPT(FHDFN,"OP",FHRNUM,2)) D CNEL100,CANEL^FHOMRC1
I $D(^FHPT(FHDFN,"OP",FHRNUM,3)) D CNTF100,CANTF^FHOMRC1
Q
CNAO100 ;Backdoor message to update file #100 with AO cancel order
S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,1)),U,4),FILL="A;"_FHRNUM D CAN Q
CNEL100 ;Backdoor message to update file #100 with EL cancel order
S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,2)),U,5),FILL="E;"_FHRNUM D CAN Q
CNTF100 ;Backdoor message to update file #100 with TF cancel order
S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,3)),U,4),FILL="T;"_FHRNUM D CAN Q
;
CANSM ;
S FHSTAT="C",(DA,FHDA)=FHSM,DA(1)=FHDFN
I $G(FHORN)="" S FHORN=$P($G(^FHPT(FHDFN,"SM",FHDA,0)),U,12)
I '$D(^FHPT(DA(1),"SM",DA,0)) Q
S DIE="^FHPT("_DA(1)_",""SM"","
S DR="1////^S X=FHSTAT;14////^S X=FHORN;11.5////^S X=FHSTAT" D ^DIE
S FHZN=$G(^FHPT(FHDFN,"SM",FHDA,0))
S FHACT="C",FHOPTY="S",FHOPDT=FHDA D SETSM^FHOMRO2
CNSM100 ;Backdoor message to update file #100 with SM cancel order
S FHORN=$P($G(^FHPT(FHDFN,"SM",FHDA,0)),U,12),FILL="S;"_FHDA D CAN
;if an SM E/L Tray exists cancel that too:
CNSMEL S FHORN=$P($G(^FHPT(FHDFN,"SM",FHDA,1)),U,4) I FHORN="" Q
S FILL="G;"_FHDA D CAN Q
;
CANGM ;
S FHSTAT="C",(DA,FHDA)=FHGM,DA(1)=FHDFN
S DIE="^FHPT("_DA(1)_",""GM"","
S DR="8////^S X=FHSTAT;9////^S X=DUZ" D ^DIE
S FHZN=$G(^FHPT(FHDFN,"GM",FHDA,0))
S FHACT="C",FHOPTY="G",FHOPDT=FHDA D SETGM^FHOMRO2 ;set event
Q
CAN ;
Q:'$$PATCH^XPDUTL("OR*3.0*215") ;must have CPRSv26 for O.M. backdoor
D MSHCA^FHOMUTL,EVSEND^FHWOR
Q
KIL ;
K %,%H,%I,DIC,DIE,DIR,FHDT,FHDT2,FHRMDT,FHRNUM,FHNOW,FHX1,FHX2,FHX3
K FHRMB,FHWRD,X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHWADM 5791 printed Apr 09, 2024@20:52:44 Page 2
FHWADM ; HISC/REL - Set up admission ;12/4/00 10:35
+1 ;;5.5;DIETETICS;**5,8,21**;Jan 28, 2005;Build 6
+2 ; Changes necessary for new file #115 design:
+3 ; The .01 (1 piece of 0 node) for inpatients is now "P"_DFN (ie P7623)
+4 ; Therefore this file is no longer DINUMed to file #2.
+5 NEW FHWF
SET FHWF=$SELECT($DATA(^ORD(101)):1,1:0)
+6 SET FHZ115="P"_DFN
DO ADD^FHOMDPA
+7 IF '$DATA(^FHPT(FHDFN,"A",0))
SET ^FHPT(FHDFN,"A",0)="^115.01^^"
+8 ;update food pref's based on allergy data
DO UPALFP
+9 ;cancel any existing outpatient meals
DO OPM
+10 DO NOW^%DTC
SET (FHNOW,FHX3,X)=$SELECT($DATA(^DGPM(ADM,0)):$PIECE(^(0),"^",1),1:%)
+11 IF $DATA(^FHPT(FHDFN,"A",ADM))
SET $PIECE(^(ADM,0),"^",1)=X
if $GET(^DPT(DFN,.105))'=ADM
GOTO KIL
GOTO UPD
+12 SET $PIECE(^FHPT(FHDFN,"A",0),"^",3)=ADM
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
+13 SET ^FHPT(FHDFN,"A",ADM,0)=X_"^^^^^^^^"
+14 SET FHX1=$GET(^DPT(DFN,.108))
SET FHX2=""
+15 IF FHX1
SET FHX1=$ORDER(^FH(119.6,"AR",FHX1,0))
+16 IF 'FHX1
SET FHX1=$GET(^DPT(DFN,.1))
IF FHX1'=""
SET FHX1=$ORDER(^DIC(42,"B",FHX1,0))
if FHX1
SET FHX1=$ORDER(^FH(119.6,"AW",FHX1,0))
+17 SET FHX1=$GET(^FH(119.6,+FHX1,0))
+18 SET FHX2=$PIECE(FHX1,"^",16)
SET FHX1=$PIECE(FHX1,"^",15)
IF 'FHX1
IF FHX2'="Y"
GOTO UPD
+19 SET X=$SELECT(FHX3>%:FHX3,1:%)
+20 SET ^FHPT(FHDFN,"A",ADM,"AC",X,0)=X_"^1"
SET ^FHPT(FHDFN,"A",ADM,"AC",0)="^115.14^"_X_"^1"
SET ^FHPT(FHDFN,"A",ADM,"DI",0)="^115.02A^1^1"
+21 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",2)=1
+22 IF 'FHX1
SET ^FHPT(FHDFN,"A",ADM,"DI",1,0)="1^^^^^^X^^"_X_"^^"_DUZ_"^"_%
SET EVT="D^O^1"
DO ^FHORX
GOTO UPD
+23 SET FHX2=$PIECE($GET(^FH(111,FHX1,0)),"^",5)
+24 SET ^FHPT(FHDFN,"A",ADM,"DI",1,0)="1^"_FHX1_"^^^^^^T^"_X_"^^"_DUZ_"^"_%_"^"_FHX2
+25 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",5)="T"
SET EVT="D^O^1"
DO ^FHORX
+26 IF 'FHWF
SET FHOR=FHX1_"^^^^"
DO ADD
KILL FHOR
GOTO UPD
+27 SET FHNEW="D;"_ADM_";"_1_";"_X_";;;;T;;"_FHX1_";;;;"
SET D1=X
SET D2=""
DO NOW^%DTC
SET NOW=%
SET FHPV=DUZ
SET FHOR=FHX1_"^^^^"
DO DO^FHWOR2
+28 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",14)=""
DO WRD
DO MSG^XQOR("FH EVSEND OR",.MSG)
KILL D1,D2,FHPV,FHNEW,MSG,NOW
SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",1,0),"^",15)=6
DO ADD
KILL FHOR
GOTO KIL
UPD SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",14)=""
DO WRD
GOTO KIL
WRD ; Update Room/Bed & Ward for current admission
+1 NEW FHWRD,FHRMB,WARD
DO DID^FHDPA
if WARD=""
QUIT
SET ADM=$GET(^DPT("CN",WARD,DFN))
if 'ADM
QUIT
+2 IF '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
+3 SET WARD=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",8)
SET EVT="L^"_$SELECT(WARD:"T",1:"A")_"^^"_WARD_"~"_$PIECE(^(0),"^",9)
IF WARD'=FHWRD
GOTO NEW
+4 IF $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",9)'=FHRMB
SET $PIECE(^(0),"^",9)=FHRMB
SET EVT=EVT_"~"_FHWRD_"~"_FHRMB
DO ^FHORX
+5 QUIT
NEW ; New Ward
+1 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",8,9)=FHWRD_"^"_FHRMB
+2 if WARD
KILL ^FHPT("AW",WARD,FHDFN)
IF FHWRD
SET ^FHPT("AW",FHWRD,FHDFN)=ADM
SET EVT=EVT_"~"_FHWRD_"~"_FHRMB
DO ^FHORX
+3 ; Update Type of Service
+4 SET FHX3=$PIECE($GET(^FH(119.6,+FHWRD,0)),"^",10)
if FHX3=""
SET FHX3="TCD"
IF FHX3[$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",5)
QUIT
+5 SET FHX3=$SELECT($LENGTH(FHX3)=1:FHX3,FHX3["D":"D",1:"C")
SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",5)=FHX3
+6 SET FHX2=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",2)
IF FHX2
IF $PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",+FHX2,0)),"^",8)'=""
SET $PIECE(^(0),"^",8)=FHX3
+7 QUIT
ADD ; Add diet associated Diet Restriction
+1 DO NOW^%DTC
SET NOW=%
+2 SET DPAT=$ORDER(^FH(111.1,"AB",FHOR,0))
+3 DO UPD^FHMTK7
+4 KILL COM,DPAT,EVT,FP,L,LN,LP,LS,M,M1,M2,MEAL,N,NM,NO,NUM,NX,OPAT,P,PP,PNN,PNO,R1,SF,SP,X3,^TMP($JOB),Z
+5 QUIT
UPALFP ;Update Food Preferences for all Patient's based on Allergies
+1 IF FHDFN=""
QUIT
+2 KILL FHMISS
DO ALG^FHCLN
IF '$ORDER(^TMP($JOB,"FHGMRAL",""))
QUIT
+3 FOR FHGMRN=0:0
SET FHGMRN=$ORDER(^TMP($JOB,"FHGMRAL",FHGMRN))
if FHGMRN=""
QUIT
DO UPDFP^FHWGMR
+4 KILL ^TMP($JOB,"FHGMRAL"),^TMP($JOB,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT
+5 QUIT
OPM ; Delete any future outpatient meals orders upon patient admission
+1 IF '$DATA(^FHPT(FHDFN,"OP"))
IF '$DATA(^FHPT(FHDFN,"SM"))
IF '$DATA(^FHPT(FHDFN,"GM"))
QUIT
+2 SET X1=DT
SET X2=-1
DO C^%DTC
SET FHDT=X_.999
+3 FOR FHRMDT=FHDT:0
SET FHRMDT=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT))
if FHRMDT'>0
QUIT
FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM))
if FHRNUM'>0
QUIT
DO CANRM
+4 FOR FHSM=FHDT:0
SET FHSM=$ORDER(^FHPT(FHDFN,"SM",FHSM))
if FHSM'>0
QUIT
DO CANSM
+5 FOR FHGM=FHDT:0
SET FHGM=$ORDER(^FHPT(FHDFN,"GM",FHGM))
if FHGM'>0
QUIT
DO CANGM
+6 QUIT
CANRM ;
+1 DO CANRM^FHOMRC1
+2 SET FHORN=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,12)
+3 SET FHMPNUM=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,6)
+4 SET FHDT2=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,1)
+5 SET FILL="R;"_FHMPNUM_";"_FHDT2_";"_FHDT2_";;"
+6 DO CAN
+7 IF $DATA(^FHPT(FHDFN,"OP",FHRNUM,1))
DO CNAO100
DO CANAO^FHOMRC1
+8 IF $DATA(^FHPT(FHDFN,"OP",FHRNUM,2))
DO CNEL100
DO CANEL^FHOMRC1
+9 IF $DATA(^FHPT(FHDFN,"OP",FHRNUM,3))
DO CNTF100
DO CANTF^FHOMRC1
+10 QUIT
CNAO100 ;Backdoor message to update file #100 with AO cancel order
+1 SET FHORN=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,1)),U,4)
SET FILL="A;"_FHRNUM
DO CAN
QUIT
CNEL100 ;Backdoor message to update file #100 with EL cancel order
+1 SET FHORN=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,2)),U,5)
SET FILL="E;"_FHRNUM
DO CAN
QUIT
CNTF100 ;Backdoor message to update file #100 with TF cancel order
+1 SET FHORN=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,3)),U,4)
SET FILL="T;"_FHRNUM
DO CAN
QUIT
+2 ;
CANSM ;
+1 SET FHSTAT="C"
SET (DA,FHDA)=FHSM
SET DA(1)=FHDFN
+2 IF $GET(FHORN)=""
SET FHORN=$PIECE($GET(^FHPT(FHDFN,"SM",FHDA,0)),U,12)
+3 IF '$DATA(^FHPT(DA(1),"SM",DA,0))
QUIT
+4 SET DIE="^FHPT("_DA(1)_",""SM"","
+5 SET DR="1////^S X=FHSTAT;14////^S X=FHORN;11.5////^S X=FHSTAT"
DO ^DIE
+6 SET FHZN=$GET(^FHPT(FHDFN,"SM",FHDA,0))
+7 SET FHACT="C"
SET FHOPTY="S"
SET FHOPDT=FHDA
DO SETSM^FHOMRO2
CNSM100 ;Backdoor message to update file #100 with SM cancel order
+1 SET FHORN=$PIECE($GET(^FHPT(FHDFN,"SM",FHDA,0)),U,12)
SET FILL="S;"_FHDA
DO CAN
+2 ;if an SM E/L Tray exists cancel that too:
CNSMEL SET FHORN=$PIECE($GET(^FHPT(FHDFN,"SM",FHDA,1)),U,4)
IF FHORN=""
QUIT
+1 SET FILL="G;"_FHDA
DO CAN
QUIT
+2 ;
CANGM ;
+1 SET FHSTAT="C"
SET (DA,FHDA)=FHGM
SET DA(1)=FHDFN
+2 SET DIE="^FHPT("_DA(1)_",""GM"","
+3 SET DR="8////^S X=FHSTAT;9////^S X=DUZ"
DO ^DIE
+4 SET FHZN=$GET(^FHPT(FHDFN,"GM",FHDA,0))
+5 ;set event
SET FHACT="C"
SET FHOPTY="G"
SET FHOPDT=FHDA
DO SETGM^FHOMRO2
+6 QUIT
CAN ;
+1 ;must have CPRSv26 for O.M. backdoor
if '$$PATCH^XPDUTL("OR*3.0*215")
QUIT
+2 DO MSHCA^FHOMUTL
DO EVSEND^FHWOR
+3 QUIT
KIL ;
+1 KILL %,%H,%I,DIC,DIE,DIR,FHDT,FHDT2,FHRMDT,FHRNUM,FHNOW,FHX1,FHX2,FHX3
+2 KILL FHRMB,FHWRD,X
QUIT
