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

FHWTRN.m

Go to the documentation of this file.
  1. FHWTRN ; HISC/REL - Process Transfers ;3/17/92 14:39
  1. ;;5.5;DIETETICS;**4**;Jan 28, 2005;Build 32
  1. ;patch 4 - added alert if pt is transferred
  1. S (FHWRNEW,FHWROLD)=""
  1. S FHZ115="P"_DFN,FHWROLD="" D CHECK^FHOMDPA I FHDFN'="" D
  1. .S:ADM FHWROLD=$P($G(^FHPT(FHDFN,"A",ADM,0)),U,8)
  1. I FHOLD="" G T0
  1. ; Edit,Delete Transfers
  1. I $P(FHOLD,"^",18)=$P(FHNEW,"^",18) G EX
  1. S XT=$P(FHOLD,"^",18)
  1. I "^1^2^3^"[("^"_XT_"^") D RET
  1. I "^22^23^24^"[("^"_XT_"^") D PASS
  1. T0 S XT=$P(FHNEW,"^",18)
  1. I "^1^2^3^"[("^"_XT_"^") D PASS
  1. I "^22^23^24^"[("^"_XT_"^") D RET
  1. EX D WRD^FHWADM
  1. G:'$G(FHDFN) KIL
  1. S:ADM FHWRNEW=$P($G(^FHPT(FHDFN,"A",ADM,0)),U,8)
  1. I FHWRNEW,(FHWROLD'=FHWRNEW) D XQAL ;process alert for transfer
  1. G KIL
  1. PASS ; Place on Pass
  1. S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
  1. D SET Q:FHLD="P" Q:'$D(^FHPT(FHDFN,"A",ADM))
  1. S FHOR="^^^^",FHLD="P",TYP="",D1=X1,D2="",D4=0,COM="" D STR^FHORD7 Q
  1. RET ; Remove from Pass
  1. D SET I FHLD'="P",FHLD'="X" Q
  1. S X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),D1=$P(X,"^",9),D2=$S(D1'>X1:X1,1:D1)
  1. S $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",10)=D2
  1. S A2=0 F KK=0:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1!(KK>X1) S A2=KK
  1. Q:'A2 Q:$P(^FHPT(FHDFN,"A",ADM,"AC",A2,0),"^",2)'=FHORD
  1. F K9=A2-.000001:0 S K9=$O(^FHPT(FHDFN,"A",ADM,"AC",K9)) Q:K9<1 I $P(^(K9,0),"^",2)=FHORD S D1=K9 D S0^FHORD3
  1. D UPD^FHORD7 Q
  1. SET D NOW^%DTC S NOW=%,DT=%\1,FHPV=DUZ,FHWF=$S($D(^ORD(101)):1,1:0)
  1. S X=$P($G(^DGPM(ADM,0)),"^",1),X1=$S(X'>NOW:NOW,1:X)
  1. S A1=0,(FHOR,FHLD)="" F KK=0:0 S KK=$O(^FHPT(FHDFN,"A",ADM,"AC",KK)) Q:KK<1!(KK>X1) S A1=KK
  1. Q:'A1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2),X=^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7) Q
  1. ;
  1. XQAL ; Check a patient
  1. S FHCLIN=""
  1. D PATNAME^FHOMUTL I DFN="" Q
  1. D CLR
  1. D NOW^%DTC S NOW=%,FHEDT=$P(NOW,".")
  1. S Y=^DPT(DFN,0),NAM=$P(Y,"^",1),SEX=$P(Y,"^",2),DOB=$P(Y,"^",3)
  1. S AGE="" I DOB'="" S AGE=$E(NOW,1,3)-$E(DOB,1,3)-($E(NOW,4,7)<$E(DOB,4,7))
  1. S FHDUZ=$P($G(^FH(119.6,FHWRNEW,0)),U,2)
  1. S:FHDUZ FHCLIN=$P($G(^VA(200,FHDUZ,0)),U,1)
  1. P0 ; Calculate BMI
  1. S GMRVSTR="WT" D EN6^GMRVUTL S WT=$P(X,"^",8),FHWTDT=$P(X,"^",1)
  1. S GMRVSTR="HT" D EN6^GMRVUTL S HT=$P(X,"^",8),FHHTDT=$P(X,"^",1)
  1. S FHGMDT=$S(FHWTDT>FHHTDT:FHWTDT,FHHTDT>FHWTDT:FHHTDT,1:FHWTDT)
  1. S BMI="" I WT,HT S A2=HT*.0254,BMI=+$J(WT/2.2/(A2*A2),0,1)
  1. I $G(BMI)=""!($G(BMI)'<18.5) G P1
  1. S MONTX="Monitor: BMI < 18.5",DTE=NOW
  1. S N=$O(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1)
  1. I N,'$P(^FHPT(FHDFN,"A",ADM,"MO",N,0),U,4) D FIL S MONIFN=N D TCK G P1
  1. I 'N,(FHGMDT>(FHEDT-7)) D FIL,TFIL G P1
  1. I 'N G P1
  1. ; Check if been 30 days
  1. S LST=$P($G(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)
  1. S X=$$FMDIFF^XLFDT(DTE,LST,3) I X>30 D FIL,TFIL
  1. P1 ; Check for current Tubefeeding
  1. S TF=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",4) I 'TF G P2
  1. S MONTX="Monitor: On Tubefeeding",DTE=NOW
  1. S N=$O(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1)
  1. I N,'$P(^FHPT(FHDFN,"A",ADM,"MO",N,0),U,4) D FIL S MONIFN=N D TCK G P2
  1. I 'N D FIL,TFIL G P2
  1. ; Check if been 7 days
  1. S LST=$P($G(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)
  1. S X=$$FMDIFF^XLFDT(DTE,LST,3) I X>7 D FIL,TFIL
  1. P2 ; Check for Hyperals
  1. S MONTX="",DTE=NOW
  1. D PSS435^PSS55(DFN,,"FHIV") F DA=0:0 S DA=$O(^TMP($J,"FHIV",DA)) Q:DA<1 D
  1. .S X0=$P($G(^TMP($J,"FHIV",DA,.02)),"^",2) I X0>NOW Q
  1. .S MONTX="Monitor: On Hyperals" Q
  1. I MONTX'="" D FIL,TFIL
  1. P3 ; Check for Serum Albumin
  1. S MONTX="",PX=6 D LAB^FHASM4 I $D(^TMP($J,"LRTST")) D
  1. .F L=0:0 S L=$O(^TMP($J,"LRTST",L)) Q:L<1 S Y=$TR($P(^(L),"^",6)," ","") I Y'?1A.E,Y<2.8 S MONTX="Monitor: Albumin < 2.8",DTE=$P(^(L),"^",7) Q
  1. .Q
  1. I MONTX="" G P4
  1. S N=$O(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1)
  1. I N,'$P(^FHPT(FHDFN,"A",ADM,"MO",N,0),U,4) D FIL S MONIFN=N D TCK G P4
  1. ;process new Albumin if old test date is within 7 days.
  1. I 'N S X=$$FMDIFF^XLFDT(NOW,DTE) I X<8 D FIL,TFIL G P4
  1. I 'N G P4
  1. ; Check if same test
  1. S LST=$P($G(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2) I DTE>LST D FIL,TFIL
  1. P4 ; Check for NPO+Clr Liq > 3 days
  1. S A1=NOW,DTE=NOW
  1. F D Q:'A1
  1. .S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1),-1) Q:'A1
  1. .S FHORD=$P($G(^FHPT(FHDFN,"A",ADM,"AC",A1,0)),"^",2) I 'FHORD S A1="" Q
  1. .S FHOR=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
  1. .I $P(FHOR,"^",7)="N" S DTE=A1 Q
  1. .I $P(FHOR,"^",2)=CLR S DTE=A1 Q
  1. .S A1="" Q
  1. I DTE'<NOW G P5
  1. S X=$$FMDIFF^XLFDT(NOW,DTE,3) G:X<3 P5
  1. S MONTX="Monitor: NPO+Clr Liq > 3 days",DTE=NOW
  1. S N=$O(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1)
  1. I N,'$P(^FHPT(FHDFN,"A",ADM,"MO",N,0),U,4) D FIL S MONIFN=N D TCK G P5
  1. I 'N D FIL,TFIL G P5
  1. ; Check if been 3 days
  1. S LST=$P($G(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)
  1. S X=$$FMDIFF^XLFDT(NOW,LST,3) I X>3 D FIL,TFIL
  1. P5 ; Done
  1. Q
  1. CLR ; Find Clear Liquid
  1. S CLR=$O(^FH(111,"B","CLEAR LIQUID",0)) Q:CLR
  1. S CLR=$O(^FH(111,"C","CLEAR LIQUID",0)) Q:CLR
  1. S CLR=$O(^FH(111,"C","CLR LIQ",0)) Q:CLR
  1. S CLR=$O(^FH(111,"C","CL",0)) Q:CLR
  1. Q
  1. FIL ; File Monitor
  1. K XQA
  1. D PATNAME^FHOMUTL
  1. Q:(MONTX["BMI")&($P($G(^FH(119.6,FHWRNEW,1)),"^",5)'="Y")
  1. Q:(MONTX["Tubefeed")&($P($G(^FH(119.6,FHWRNEW,1)),"^",6)'="Y")
  1. Q:(MONTX["Hyperals")&($P($G(^FH(119.6,FHWRNEW,1)),"^",7)'="Y")
  1. Q:(MONTX["Albumin")&($P($G(^FH(119.6,FHWRNEW,1)),"^",8)'="Y")
  1. Q:(MONTX["NPO+Clr")&($P($G(^FH(119.6,FHWRNEW,1)),"^",9)'="Y")
  1. K XQA,XQAMSG,XQAOPT,XQAROU
  1. S XQAID="FH,"_$J_","_$H
  1. S XQAMSG=$E(FHPTNM,1,9)_" ("_$E(FHPTNM,1,1)_$P(FHSSN,"-",3)_"): "
  1. S XQAOPT="FHCTF2",XQAMSG=XQAMSG_" "_MONTX_" "_$E(DTE,4,5)_"/"_$E(DTE,6,7)_"/"_$E(DTE,2,3)_" Clinician: "_FHCLIN
  1. F A=0:0 S A=$O(^FH(119.6,FHWRNEW,2,A)) Q:A'>0 S TK=$P($G(^FH(119.6,FHWRNEW,2,A,0)),U,1),XQA(TK)=""
  1. I '$D(XQA(FHDUZ)) S XQA(FHDUZ)=""
  1. D SETUP^XQALERT
  1. Q
  1. TFIL ;File patient info
  1. L +^FHPT(FHDFN,"A",ADM,"MO",0)
  1. I '$D(^FHPT(FHDFN,"A",ADM,"MO",0)) S ^FHPT(FHDFN,"A",ADM,"MO",0)="^115.11^^"
  1. L -^FHPT(FHDFN,"A",ADM,"MO",0)
  1. K DIC,DD,DO,DINUM S DIC="^FHPT(FHDFN,""A"",ADM,""MO"",",DIC(0)="L",DA(1)=ADM,DA(2)=FHDFN,DLAYGO=115,X=MONTX D FILE^DICN K DIC,DLAYGO
  1. Q:Y<1 S MONIFN=+Y
  1. S $P(^FHPT(FHDFN,"A",ADM,"MO",MONIFN,0),"^",2)=DTE,^FHPT(FHDFN,"A",ADM,"MO","AC",DTE,MONIFN)=""
  1. TCK S FHTF=DTE_"^M^"_MONTX_"^"_DFN_"^"_ADM_"^"_MONIFN ;set tickler for a clinician
  1. D:FHDUZ FILE^FHCTF2
  1. Q
  1. ;
  1. KIL K %,A1,A2,COM,D1,D2,D4,FHDU,FHLD,FHOR,FHPV,FHX1,FHX2,FHX3,K,K9,KK,NOW,FHORD,TYP,X,X1,X2,X9
  1. K FHEDT,FHGMDT,FHWTDT,FHHTDT Q