source: FOIAVistA/tag/r/DIETETICS-FH/FHWADM.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1FHWADM ; HISC/REL - Set up admission ;12/4/00 10:35
2 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
3 ; Changes necessary for new file #115 design:
4 ; The .01 (1 piece of 0 node) for inpatients is now "P"_DFN (ie P7623)
5 ; Therefore this file is no longer DINUMed to file #2.
6 N FHWF S FHWF=$S($D(^ORD(101)):1,1:0)
7 S FHZ115="P"_DFN D ADD^FHOMDPA
8 I '$D(^FHPT(FHDFN,"A",0)) S ^FHPT(FHDFN,"A",0)="^115.01^^"
9 D UPALFP ;update food pref's based on allergy data
10 D OPM ;cancel any existing outpatient meals
11 D NOW^%DTC S (FHNOW,FHX3,X)=$S($D(^DGPM(ADM,0)):$P(^(0),"^",1),1:%)
12 I $D(^FHPT(FHDFN,"A",ADM)) S $P(^(ADM,0),"^",1)=X G:$G(^DPT(DFN,.105))'=ADM KIL G UPD
13 S $P(^FHPT(FHDFN,"A",0),"^",3)=ADM,$P(^(0),"^",4)=$P(^(0),"^",4)+1
14 S ^FHPT(FHDFN,"A",ADM,0)=X_"^^^^^^^^"
15 S FHX1=$G(^DPT(DFN,.108)),FHX2=""
16 I FHX1 S FHX1=$O(^FH(119.6,"AR",FHX1,0))
17 E 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))
18 S FHX1=$G(^FH(119.6,+FHX1,0))
19 S FHX2=$P(FHX1,"^",16),FHX1=$P(FHX1,"^",15) I 'FHX1,FHX2'="Y" G UPD
20 S X=$S(FHX3>%:FHX3,1:%)
21 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"
22 S $P(^FHPT(FHDFN,"A",ADM,0),"^",2)=1
23 I 'FHX1 S ^FHPT(FHDFN,"A",ADM,"DI",1,0)="1^^^^^^X^^"_X_"^^"_DUZ_"^"_% S EVT="D^O^1" D ^FHORX G UPD
24 S FHX2=$P($G(^FH(111,FHX1,0)),"^",5)
25 S ^FHPT(FHDFN,"A",ADM,"DI",1,0)="1^"_FHX1_"^^^^^^T^"_X_"^^"_DUZ_"^"_%_"^"_FHX2
26 S $P(^FHPT(FHDFN,"A",ADM,0),"^",5)="T" S EVT="D^O^1" D ^FHORX
27 I 'FHWF S FHOR=FHX1_"^^^^" D ADD K FHOR G UPD
28 S FHNEW="D;"_ADM_";"_1_";"_X_";;;;T;;"_FHX1_";;;;",D1=X,D2="" D NOW^%DTC S NOW=%,FHPV=DUZ,FHOR=FHX1_"^^^^" D DO^FHWOR2
29 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
30UPD S $P(^FHPT(FHDFN,"A",ADM,0),"^",14)="" D WRD G KIL
31WRD ; Update Room/Bed & Ward for current admission
32 N FHWRD,FHRMB,WARD D DID^FHDPA Q:WARD="" S ADM=$G(^DPT("CN",WARD,DFN)) Q:'ADM
33 I '$D(^FHPT(FHDFN,"A",ADM,0)) Q
34 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
35 I $P(^FHPT(FHDFN,"A",ADM,0),"^",9)'=FHRMB S $P(^(0),"^",9)=FHRMB S EVT=EVT_"~"_FHWRD_"~"_FHRMB D ^FHORX
36 Q
37NEW ; New Ward
38 S $P(^FHPT(FHDFN,"A",ADM,0),"^",8,9)=FHWRD_"^"_FHRMB
39 K:WARD ^FHPT("AW",WARD,FHDFN) I FHWRD S ^FHPT("AW",FHWRD,FHDFN)=ADM S EVT=EVT_"~"_FHWRD_"~"_FHRMB D ^FHORX
40 ; Update Type of Service
41 S FHX3=$P($G(^FH(119.6,+FHWRD,0)),"^",10) S:FHX3="" FHX3="TCD" I FHX3[$P(^FHPT(FHDFN,"A",ADM,0),"^",5) Q
42 S FHX3=$S($L(FHX3)=1:FHX3,FHX3["D":"D",1:"C"),$P(^FHPT(FHDFN,"A",ADM,0),"^",5)=FHX3
43 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
44 Q
45ADD ; Add diet associated Diet Restriction
46 D NOW^%DTC S NOW=%
47 S DPAT=$O(^FH(111.1,"AB",FHOR,0))
48 D UPD^FHMTK7
49 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
50 Q
51UPALFP ;Update Food Preferences for all Patient's based on Allergies
52 I FHDFN="" Q
53 K FHMISS D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q
54 F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP^FHWGMR
55 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT
56 Q
57OPM ; Delete any future outpatient meals orders upon patient admission
58 I '$D(^FHPT(FHDFN,"OP")),'$D(^FHPT(FHDFN,"SM")),'$D(^FHPT(FHDFN,"GM")) Q
59 S X1=DT,X2=-1 D C^%DTC S FHDT=X_.999
60 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
61 F FHSM=FHDT:0 S FHSM=$O(^FHPT(FHDFN,"SM",FHSM)) Q:FHSM'>0 D CANSM
62 F FHGM=FHDT:0 S FHGM=$O(^FHPT(FHDFN,"GM",FHGM)) Q:FHGM'>0 D CANGM
63 Q
64CANRM ;
65 D CANRM^FHOMRC1
66 S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,12)
67 S FHMPNUM=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,6)
68 S FHDT2=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,1)
69 S FILL="R;"_FHMPNUM_";"_FHDT2_";"_FHDT2_";;"
70 D CAN
71 I $D(^FHPT(FHDFN,"OP",FHRNUM,1)) D CNAO100,CANAO^FHOMRC1
72 I $D(^FHPT(FHDFN,"OP",FHRNUM,2)) D CNEL100,CANEL^FHOMRC1
73 I $D(^FHPT(FHDFN,"OP",FHRNUM,3)) D CNTF100,CANTF^FHOMRC1
74 Q
75CNAO100 ;Backdoor message to update file #100 with AO cancel order
76 S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,1)),U,4),FILL="A;"_FHRNUM D CAN Q
77CNEL100 ;Backdoor message to update file #100 with EL cancel order
78 S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,2)),U,5),FILL="E;"_FHRNUM D CAN Q
79CNTF100 ;Backdoor message to update file #100 with TF cancel order
80 S FHORN=$P($G(^FHPT(FHDFN,"OP",FHRNUM,3)),U,4),FILL="T;"_FHRNUM D CAN Q
81 ;
82CANSM ;
83 S FHSTAT="C",(DA,FHDA)=FHSM,DA(1)=FHDFN
84 I $G(FHORN)="" S FHORN=$P($G(^FHPT(FHDFN,"SM",FHDA,0)),U,12)
85 I '$D(^FHPT(DA(1),"SM",DA,0)) Q
86 S DIE="^FHPT("_DA(1)_",""SM"","
87 S DR="1////^S X=FHSTAT;14////^S X=FHORN;11.5////^S X=FHSTAT" D ^DIE
88 S FHZN=$G(^FHPT(FHDFN,"SM",FHDA,0))
89 S FHACT="C",FHOPTY="S",FHOPDT=FHDA D SETSM^FHOMRO2
90CNSM100 ;Backdoor message to update file #100 with SM cancel order
91 S FHORN=$P($G(^FHPT(FHDFN,"SM",FHDA,0)),U,12),FILL="S;"_FHDA D CAN
92 ;if an SM E/L Tray exists cancel that too:
93CNSMEL S FHORN=$P($G(^FHPT(FHDFN,"SM",FHDA,1)),U,4) I FHORN="" Q
94 S FILL="G;"_FHDA D CAN Q
95 ;
96CANGM ;
97 S FHSTAT="C",(DA,FHDA)=FHGM,DA(1)=FHDFN
98 S DIE="^FHPT("_DA(1)_",""GM"","
99 S DR="8////^S X=FHSTAT;9////^S X=DUZ" D ^DIE
100 S FHZN=$G(^FHPT(FHDFN,"GM",FHDA,0))
101 S FHACT="C",FHOPTY="G",FHOPDT=FHDA D SETGM^FHOMRO2 ;set event
102 Q
103CAN ;
104 Q:'$$PATCH^XPDUTL("OR*3.0*215") ;must have CPRSv26 for O.M. backdoor
105 D MSHCA^FHOMUTL,EVSEND^FHWOR
106 Q
107KIL ;
108 K %,%H,%I,DIC,DIE,DIR,FHDT,FHDT2,FHRMDT,FHRNUM,FHNOW,FHX1,FHX2,FHX3
109 K FHRMB,FHWRD,X Q
Note: See TracBrowser for help on using the repository browser.