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