Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHWADM

FHWADM.m

Go to the documentation of this file.
  1. FHWADM ; HISC/REL - Set up admission ;12/4/00 10:35
  1. ;;5.5;DIETETICS;**5,8,21**;Jan 28, 2005;Build 6
  1. ; Changes necessary for new file #115 design:
  1. ; The .01 (1 piece of 0 node) for inpatients is now "P"_DFN (ie P7623)
  1. ; Therefore this file is no longer DINUMed to file #2.
  1. N FHWF S FHWF=$S($D(^ORD(101)):1,1:0)
  1. S FHZ115="P"_DFN D ADD^FHOMDPA
  1. I '$D(^FHPT(FHDFN,"A",0)) S ^FHPT(FHDFN,"A",0)="^115.01^^"
  1. D UPALFP ;update food pref's based on allergy data
  1. D OPM ;cancel any existing outpatient meals
  1. D NOW^%DTC S (FHNOW,FHX3,X)=$S($D(^DGPM(ADM,0)):$P(^(0),"^",1),1:%)
  1. I $D(^FHPT(FHDFN,"A",ADM)) S $P(^(ADM,0),"^",1)=X G:$G(^DPT(DFN,.105))'=ADM KIL G UPD
  1. S $P(^FHPT(FHDFN,"A",0),"^",3)=ADM,$P(^(0),"^",4)=$P(^(0),"^",4)+1
  1. S ^FHPT(FHDFN,"A",ADM,0)=X_"^^^^^^^^"
  1. S FHX1=$G(^DPT(DFN,.108)),FHX2=""
  1. I FHX1 S FHX1=$O(^FH(119.6,"AR",FHX1,0))
  1. 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))
  1. S FHX1=$G(^FH(119.6,+FHX1,0))
  1. S FHX2=$P(FHX1,"^",16),FHX1=$P(FHX1,"^",15) I 'FHX1,FHX2'="Y" G UPD
  1. S X=$S(FHX3>%:FHX3,1:%)
  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"
  1. S $P(^FHPT(FHDFN,"A",ADM,0),"^",2)=1
  1. I 'FHX1 S ^FHPT(FHDFN,"A",ADM,"DI",1,0)="1^^^^^^X^^"_X_"^^"_DUZ_"^"_% S EVT="D^O^1" D ^FHORX G UPD
  1. S FHX2=$P($G(^FH(111,FHX1,0)),"^",5)
  1. S ^FHPT(FHDFN,"A",ADM,"DI",1,0)="1^"_FHX1_"^^^^^^T^"_X_"^^"_DUZ_"^"_%_"^"_FHX2
  1. S $P(^FHPT(FHDFN,"A",ADM,0),"^",5)="T" S EVT="D^O^1" D ^FHORX
  1. I 'FHWF S FHOR=FHX1_"^^^^" D ADD K FHOR G UPD
  1. S FHNEW="D;"_ADM_";"_1_";"_X_";;;;T;;"_FHX1_";;;;",D1=X,D2="" D NOW^%DTC S NOW=%,FHPV=DUZ,FHOR=FHX1_"^^^^" D DO^FHWOR2
  1. 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
  1. UPD S $P(^FHPT(FHDFN,"A",ADM,0),"^",14)="" D WRD G KIL
  1. WRD ; Update Room/Bed & Ward for current admission
  1. N FHWRD,FHRMB,WARD D DID^FHDPA Q:WARD="" S ADM=$G(^DPT("CN",WARD,DFN)) Q:'ADM
  1. I '$D(^FHPT(FHDFN,"A",ADM,0)) Q
  1. 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
  1. I $P(^FHPT(FHDFN,"A",ADM,0),"^",9)'=FHRMB S $P(^(0),"^",9)=FHRMB S EVT=EVT_"~"_FHWRD_"~"_FHRMB D ^FHORX
  1. Q
  1. NEW ; New Ward
  1. S $P(^FHPT(FHDFN,"A",ADM,0),"^",8,9)=FHWRD_"^"_FHRMB
  1. K:WARD ^FHPT("AW",WARD,FHDFN) I FHWRD S ^FHPT("AW",FHWRD,FHDFN)=ADM S EVT=EVT_"~"_FHWRD_"~"_FHRMB D ^FHORX
  1. ; Update Type of Service
  1. S FHX3=$P($G(^FH(119.6,+FHWRD,0)),"^",10) S:FHX3="" FHX3="TCD" I FHX3[$P(^FHPT(FHDFN,"A",ADM,0),"^",5) Q
  1. S FHX3=$S($L(FHX3)=1:FHX3,FHX3["D":"D",1:"C"),$P(^FHPT(FHDFN,"A",ADM,0),"^",5)=FHX3
  1. 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
  1. Q
  1. ADD ; Add diet associated Diet Restriction
  1. D NOW^%DTC S NOW=%
  1. S DPAT=$O(^FH(111.1,"AB",FHOR,0))
  1. D UPD^FHMTK7
  1. 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
  1. Q
  1. UPALFP ;Update Food Preferences for all Patient's based on Allergies
  1. I FHDFN="" Q
  1. K FHMISS D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q
  1. F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP^FHWGMR
  1. K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT
  1. Q
  1. OPM ; Delete any future outpatient meals orders upon patient admission
  1. I '$D(^FHPT(FHDFN,"OP")),'$D(^FHPT(FHDFN,"SM")),'$D(^FHPT(FHDFN,"GM")) Q
  1. S X1=DT,X2=-1 D C^%DTC S FHDT=X_.999
  1. 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
  1. F FHSM=FHDT:0 S FHSM=$O(^FHPT(FHDFN,"SM",FHSM)) Q:FHSM'>0 D CANSM
  1. F FHGM=FHDT:0 S FHGM=$O(^FHPT(FHDFN,"GM",FHGM)) Q:FHGM'>0 D CANGM
  1. Q
  1. CANRM ;
  1. D CANRM^FHOMRC1
  1. S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,12)
  1. S FHMPNUM=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,6)
  1. S FHDT2=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,1)
  1. S FILL="R;"_FHMPNUM_";"_FHDT2_";"_FHDT2_";;"
  1. D CAN
  1. I $D(^FHPT(FHDFN,"OP",FHRNUM,1)) D CNAO100,CANAO^FHOMRC1
  1. I $D(^FHPT(FHDFN,"OP",FHRNUM,2)) D CNEL100,CANEL^FHOMRC1
  1. I $D(^FHPT(FHDFN,"OP",FHRNUM,3)) D CNTF100,CANTF^FHOMRC1
  1. Q
  1. CNAO100 ;Backdoor message to update file #100 with AO cancel order
  1. S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,1)),U,4),FILL="A;"_FHRNUM D CAN Q
  1. CNEL100 ;Backdoor message to update file #100 with EL cancel order
  1. S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,2)),U,5),FILL="E;"_FHRNUM D CAN Q
  1. CNTF100 ;Backdoor message to update file #100 with TF cancel order
  1. S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,3)),U,4),FILL="T;"_FHRNUM D CAN Q
  1. ;
  1. CANSM ;
  1. S FHSTAT="C",(DA,FHDA)=FHSM,DA(1)=FHDFN
  1. I $G(FHORN)="" S FHORN=$P($G(^FHPT(FHDFN,"SM",FHDA,0)),U,12)
  1. I '$D(^FHPT(DA(1),"SM",DA,0)) Q
  1. S DIE="^FHPT("_DA(1)_",""SM"","
  1. S DR="1////^S X=FHSTAT;14////^S X=FHORN;11.5////^S X=FHSTAT" D ^DIE
  1. S FHZN=$G(^FHPT(FHDFN,"SM",FHDA,0))
  1. S FHACT="C",FHOPTY="S",FHOPDT=FHDA D SETSM^FHOMRO2
  1. CNSM100 ;Backdoor message to update file #100 with SM cancel order
  1. S FHORN=$P($G(^FHPT(FHDFN,"SM",FHDA,0)),U,12),FILL="S;"_FHDA D CAN
  1. ;if an SM E/L Tray exists cancel that too:
  1. CNSMEL S FHORN=$P($G(^FHPT(FHDFN,"SM",FHDA,1)),U,4) I FHORN="" Q
  1. S FILL="G;"_FHDA D CAN Q
  1. ;
  1. CANGM ;
  1. S FHSTAT="C",(DA,FHDA)=FHGM,DA(1)=FHDFN
  1. S DIE="^FHPT("_DA(1)_",""GM"","
  1. S DR="8////^S X=FHSTAT;9////^S X=DUZ" D ^DIE
  1. S FHZN=$G(^FHPT(FHDFN,"GM",FHDA,0))
  1. S FHACT="C",FHOPTY="G",FHOPDT=FHDA D SETGM^FHOMRO2 ;set event
  1. Q
  1. CAN ;
  1. Q:'$$PATCH^XPDUTL("OR*3.0*215") ;must have CPRSv26 for O.M. backdoor
  1. D MSHCA^FHOMUTL,EVSEND^FHWOR
  1. Q
  1. KIL ;
  1. K %,%H,%I,DIC,DIE,DIR,FHDT,FHDT2,FHRMDT,FHRNUM,FHNOW,FHX1,FHX2,FHX3
  1. K FHRMB,FHWRD,X Q