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

FHASM2A.m

Go to the documentation of this file. 
  1. FHASM2A ; HISC/REL - Target Weight - Metropolitan 83 ;5/14/93  08:59
  1.  ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
  1. M ; Metropolitan Height & Weight tables
  1.  ; 1983 Metropolitan Life Insurance Company Height & Weight Tables
  1.  ; as measured with 1" heels and clothes weighing 5# for men and 3# for women.
  1. M1 S OFF=$S(SEX="M":H1-61,1:H1-43),A1=$P($T(MM1+OFF),";",$F("SML",FRM)+2)
  1.  S W1=$P(A1,"-",1),W2=$P(A1,"-",2) G:METH="M" M3
  1.  ; Target Weight for Spinal Cord Patients
  1.  ; Nutrition Assessment of the Spinal Cord Injured Patient by
  1.  ; Suzanne C Peiffer, R.D., Patricia Blust, R.D., and Jose Florante J Leyson
  1. M2 W !!,"Extent of Injury:",!!?7,"P   Paraplegic",!?7,"Q   Quadriplegic"
  1.  W !!,"Select: ",FHSPC,"//" R SP:DTIME I '$T!(SP["^") S FHQUIT=1 Q
  1.  I SP="",FHSPC'="" S SP=FHSPC
  1.  S X=SP D TR^FHASM1 S SP=X
  1.  I SP'="P",SP'="Q" W !?3,*7,"Only P or Q are Valid Choices" G M2
  1.  S FHSPC=SP
  1.  S W1=W1-$S(SP="P":15,1:20),W2=W2-$S(SP="P":20,1:25)
  1. M3 S W3=+$J(W1+W2/2,0,0),X1=$S(FHU'="M":W1,1:+$J(W1/2.2,0,1)),X2=$S(FHU'="M":W2,1:+$J(W2/2.2,0,1)),X3=$S(FHU'="M":W3,1:+$J(W3/2.2,0,1))
  1. M4 W !!,"Select Target Weight (",X1,"-",X2,") ",X3,$S(FHU'="M":" lb",1:" kg"),"// " R X:DTIME I '$T!(X["^") S FHQUIT=1 Q
  1.  I X="" S IBW=W3 Q
  1.  D WGT^FHASM1 I Y<1 D WGP^FHASM1 G M4
  1.  S IBW=+Y I IBW<W1!(IBW>W2) S METH="E"
  1.  Q
  1.  ;
  1. ALRT ;process nutrition assessment alert.
  1.  Q:'DFN    ;only inpt will have the alert
  1.  Q:'$G(WRD)
  1.  S WARD=$G(^DPT(DFN,.1)) Q:WARD=""
  1.  S ADM=$P($G(^FHPT(FHDFN,"A",0)),U,3)
  1.  S:'$G(FHDUZ) FHDUZ=""
  1.  I $G(DT) S DTE=DT
  1.  S FHSDT=DTE
  1.  F FHPDT=FHSDT:0 S FHPDT=$O(^FHPT("E",FHPDT)) Q:FHPDT'>0  I $D(^FHPT("E",FHPDT,FHDFN)) D
  1.  .S FHNAS=$O(^FHPT("E",FHPDT,FHDFN,0))
  1.  .I $P($G(^FHPT(FHDFN,"N",FHNAS,"DI")),U,9)'=""!($P($G(^FHPT(FHDFN,"N",FHNAS,"DI")),U,5)<DTE) Q
  1.  .Q:$P($G(^FHPT(FHDFN,"N",FHNAS,"DI")),U,6)'="C"
  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 XQAMSG=XQAMSG_" has Assessment Follow-up Date on "_$E(FHPDT,4,5)_"/"_$E(FHPDT,6,7)_"/"_$E(FHPDT,2,3)
  1.  .F A=0:0 S A=$O(^FH(119.6,WRD,2,A)) Q:A'>0  S TK=$P($G(^FH(119.6,WRD,2,A,0)),U,1),XQA(TK)=""
  1.  .S:'$D(XQA(FHDUZ)) XQA(FHDUZ)=""
  1.  .D SETUP^XQALERT
  1.  .S $P(^FHPT(FHDFN,"N",FHNAS,"DI"),U,9)=FHSDT
  1.  K XQA,XQAMSG,XQAOPT,XQAROU,TK,FHSDT,FHPDT,FHNAS,FHNAA
  1.  ;
  1. PHA ;process food/drug classification alert
  1.  I $G(DT) S DTE=DT
  1.  ;call Pharmacy API
  1.  S PX=1 D DRUG^FHASM4
  1.  S FHI9=""
  1.  F  S FHI9=$O(PCLS(FHI9)) Q:FHI9=""  S FHP605=PCLS(FHI9) D
  1.  .D AL1
  1.  .Q:$G(FHALFLG)
  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 XQAMSG=XQAMSG_"Food/drug interaction w/ "_FHI9
  1.  .F A=0:0 S A=$O(^FH(119.6,WRD,2,A)) Q:A'>0  D
  1.  ..S TK=$P($G(^FH(119.6,WRD,2,A,0)),U,1),XQA(TK)=""
  1.  ..S:'$D(XQA(FHDUZ)) XQA(FHDUZ)=""
  1.  .D SETUP^XQALERT
  1.  .S DIC="^FHPT("_FHDFN_",""D"",",DIC(0)="L",X=DT,DA(1)=FHDFN
  1.  .K DD,DO D FILE^DICN I +Y<0 Q
  1.  .S $P(^FHPT(FHDFN,"D",+Y,0),U,2)="S"
  1.  .S $P(^FHPT(FHDFN,"D",+Y,0),U,3)=WRD
  1.  .S $P(^FHPT(FHDFN,"D",+Y,0),U,4)=FHI9
  1.  .K DIC
  1.  K POP,PORD,PSCL605,PSNIEN,PSSTMP2,RMSDF,SCR,PCA,PCAL,PCNS,PCORD
  1.  K FHAL,FHALDAT,FHALFLG,FHALWRD,FHDOB,FHFDNM,FHGMDT,FHI9,FHP605,FHPAL,FHPPA
  1.  K XQA,XQAMSG,XQAOPT,XQAROU,TK,FHSDT,FHPDT,FHNAS,FHNAA,FHPPOR,FHPPNS
  1.  Q
  1.  ;
  1. AL1 S FHALFLG=0
  1.  F FHAL=0:0 S FHAL=$O(^FHPT(FHDFN,"D",FHAL)) Q:FHAL'>0  D
  1.  .S FHALDAT=$G(^FHPT(FHDFN,"D",FHAL,0))
  1.  .S FHFDNM=$P(FHALDAT,U,4),FHALWRD=$P(FHALDAT,U,3)
  1.  .I FHALWRD=WRD,FHFDNM=FHI9 S FHALFLG=1
  1.  Q
  1. MM1 ;;62;128-134;131-141;138-150
  1.  ;;63;130-136;133-143;140-153
  1.  ;;64;132-138;135-145;142-156
  1.  ;;65;134-140;137-148;144-160
  1.  ;;66;136-142;139-151;146-164
  1.  ;;67;138-145;142-154;149-168
  1.  ;;68;140-148;145-157;152-172
  1.  ;;69;142-151;148-160;155-176
  1.  ;;70;144-154;151-163;158-180
  1.  ;;71;146-157;154-166;161-184
  1.  ;;72;149-160;157-170;164-188
  1.  ;;73;152-164;160-174;168-192
  1.  ;;74;155-168;164-178;172-197
  1.  ;;75;158-172;167-182;176-202
  1.  ;;76;162-176;171-187;181-207
  1. MW1 ;;58;102-111;109-121;118-131
  1.  ;;59;103-113;111-123;120-134
  1.  ;;60;104-115;113-126;122-137
  1.  ;;61;106-118;115-129;125-140
  1.  ;;62;108-121;118-132;128-143
  1.  ;;63;111-124;121-135;131-147
  1.  ;;64;114-127;124-138;134-151
  1.  ;;65;117-130;127-141;137-155
  1.  ;;66;120-133;130-144;140-159
  1.  ;;67;123-136;133-147;143-163
  1.  ;;68;126-139;136-150;146-167
  1.  ;;69;129-142;139-153;149-170
  1.  ;;70;132-145;142-156;152-173
  1.  ;;71;135-148;145-159;155-176
  1.  ;;72;138-151;148-162;158-179