FHASM2 ; HISC/REL - Assessment (cont) ;5/14/93 10:03
;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
FRM ; Calculate Frame Size
W !!,"Wrist Circumference: " W:WCCM WCCM_" cm// " R X:DTIME G KIL^FHASM1:'$T!(X["^")
I X="",$G(WCCM) S X=WCCM
S WCCM=X
G F1:X=""
I X'?1.2N.1".".N!(X<2)!(X>50) W *7,!,"Value should be between 2 and 50cm.; press RETURN to bypass." G FRM
S WCIR=+X,RAT=HGT*2.54/WCIR
I SEX="F" S FRM=$S(RAT>11.0:"S",RAT<10.1:"L",1:"M")
I SEX="M" S FRM=$S(RAT>10.4:"S",RAT<9.6:"L",1:"M")
W " ",$S(FRM="S":"Small",FRM="M":"Medium",1:"Large")," Frame" G IBW
F1 I FRM="" S FRM="M"
S X="" W !!,"Frame Size (SMALL,MEDIUM,LARGE) "_FRM R "// ",X:DTIME
I '$T!(X["^") S FHQUIT=1 G KIL^FHASM1
S:X="" X=FRM D TR^FHASM1
I $P("SMALL",X,1)'="",$P("MEDIUM",X,1)'="",$P("LARGE",X,1)'="" W *7," Enter S, M or L" G F1
S FRM=$E(X,1)
IBW ; Target Body Weight
W !!,"Calculation of Target Body Weight",! S METH=""
I H1'<60 W !?10,"H Hamwi" S METH=METH_"H"
I SEX="M",(H1<76),(H1>60),(AGE'<19) W !?10,"M Metropolitan 83" W !?10,"S Spinal Cord Injury" S METH=METH_"MS"
I SEX="F",(H1<73),(H1>57),(AGE'<19) W !?10,"M Metropolitan 83" W !?10,"S Spinal Cord Injury" S METH=METH_"MS"
I SEX="M",(H1<74),(H1>60),(AGE>64) W !?10,"G Geriatric" S METH=METH_"G"
I SEX="F",(H1<70),(H1>57),(AGE>64) W !?10,"G Geriatric" S METH=METH_"G"
I AGE<10 W !?10,"P Pediatric" S METH=METH_"P"
W !?10,"E Enter Manually" S METH=METH_"E"
SEL W !!,"Method: " W:CIBW'="" CIBW_" // " R X:DTIME I '$T!(X["^") G KIL^FHASM1
I X="",CIBW'="" S X=CIBW
D TR^FHASM1
I METH'[$E(X,1)!(X="") W *7,!," You Must Choose from the List Above" G SEL
S CIBW=X
S METH=$E(X,1) D E:METH="E",H^FHASM2D:METH="H",^FHASM2A:METH="M",^FHASM2A:METH="S",^FHASM2B:METH="G",^FHASM2C:METH="P" G:FHQUIT KIL^FHASM1 I IBW'>0 G KIL^FHASM1:IBW="^",IBW
AMP S FHAMP="NO" I AMP'="" S FHAMP="YES"
G:FHQUIT KIL^FHASM1
S X="" W !!,"Does Patient have an Amputation? "_FHAMP R "// ",X:DTIME
I X="^" S FHQUIT=1 G:'$T!(X["^") KIL^FHASM1
S:X="" X=FHAMP D TR^FHASM1
S FHAMP=X
I $P("YES",FHAMP,1)'="",$P("NO",FHAMP,1)'="" W *7," Answer YES or NO" G AMP
;S FHAMP=$E(FHAMP,1),FHAMP=FHAMP="Y" G:'FHAMP A5
I $E(FHAMP,1)="N" S AMP="" G A5
A1 W !!,"Amputee Types: (may be multiple, e.g: 2,2,5)"
W !!?5,"1 Hand (0.7%)",?36,"2 Total Leg (16.1%)",!?5,"3 Total Arm (4.9%)",?36,"4 Foot (1.5%)"
W !?5,"5 Forearm and Hand (2.3%)",?36,"6 Calf and Foot (5.8%)"
A2 I AMP'="" W !!,"Total Amputee %: ",AMP K DIR S DIR(0)="SAO^Y:Yes;N:No",DIR("A")="Do you wish to change this? ",DIR("B")="N" D ^DIR G:$D(DIRUT) KIL^FHASM1 I Y="N" G A5
S AMP=0 R !!?2,"Amputee Types: ",X:DTIME G:'$T!(X["^") KIL^FHASM1
F K=1:1 S Y=$P(X,",",K) Q:Y="" G:Y'?1N!(Y<1)!(Y>6) A6 S AMP=AMP+$P(".7,16.1,4.9,1.5,2.3,5.8",",",Y)
A3 W !!,"Total Amputee %: ",AMP," // " R X:DTIME S:X="" X=AMP G:'$T!(X["^") KIL^FHASM1
I X<.5!(X>50) W *7,!,"Total % of amputations should be .5% to 50%" G A3
S AMP=+$J(X,0,1),IBW=100-AMP*IBW/100,IBW=+$J(IBW,0,0)
A4 S X1=$S(FHU'="M":IBW_"#",1:+$J(IBW/2.2,0,1)_"kg")
W !!,"Select TBW after Amputee Correction: ",X1,"// " R X:DTIME I '$T!(X["^") G KIL^FHASM1
I X=""!(X=+X1) G A5
D WGT^FHASM1 I Y<1 D WGP^FHASM1 G A4
S IBW=+Y
A5 S IBW=+$J(IBW,0,0) G ^FHASM3
A6 W *7,!!?5,"Enter a string of types (e.g: 1,1,4); no digit can exceed 6." G A2
E ; Manual Entry of Target Weight
W !!,"Enter Target Body Weight: " W:IBW'="" IBW_"lbs// " R X:DTIME I '$T!(X["^") S FHQUIT=1 Q
I X="",IBW'="" S X=IBW
D WGT^FHASM1 I Y<1 D WGP^FHASM1 G E
S IBW=+Y Q
;
ASK ;ask user to edit or create assessment.
D PRTA
I 'FHDIC S FHASK="C" Q
R !!,"Do you want to Edit or Create or Delete Assessment? E// ",FHASK:DTIME I '$T!(FHASK["^") S FHQUIT=1 Q
S:FHASK="" FHASK="E" S X=FHASK D TR^FH S FHASK=X
S FHASK=$E(FHASK)
I (FHASK'="E"),(FHASK'="C"),(FHASK'="D") W *7,!?5,"Enter 'E' to Edit work in progress assessment or 'C' to Create new assessment or 'D' to Delete assessment!!" G ASK
I (FHASK="E")!(FHASK="D") D AAS
Q
AAS ;ask user which assesment to edit or delete.
W !
K DIC S DIC="^FHPT(FHDFN,""N"",",DIC(0)="Q",DA=FHDFN,X="??"
S DIC("S")="D DCS^FHASM2 I FHDIC"
S DIC("W")="S FHASS=$P($D(^FHPT(FHDFN,""N"",+Y,""DI"")),U,6) W "" "",$S(FHASS=""C"":""Complete"",FHASS=""S"":""Signed"",1:""Work in Progress"")"
D ^DIC S DIC="^FHPT(FHDFN,""N"",",DIC(0)="AEQM"
S DIC("A")="SELECT Assessment Date: "
W !,"You can only access your own Work in Progress Assessment, unless you have an FHMGR key.",!
S DIC("W")="S FHASS=$P($D(^FHPT(FHDFN,""N"",+Y,""DI"")),U,6) W "" "",$S(FHASS=""C"":""Complete"",FHASS=""S"":""Signed"",1:""Work in Progress"")"
D ^DIC I "^"[X!$D(DTOUT) S FHQUIT=1 Q
G:Y<1 AAS
S FHCAS=+Y
K DIC
Q
DCS S FHDIC=0 I '$D(^FHPT(FHDFN,"N",Y,"DI")),$D(^XUSEC("FHMGR",DUZ)) S FHDIC=1
I '$D(^FHPT(FHDFN,"N",Y,"DI")),$D(^FHPT(FHDFN,"N",Y,0)),($P(^(0),U,23)=DUZ) S FHDIC=1
I $D(^FHPT(FHDFN,"N",Y,0)),($P(^(0),U,23)=DUZ),($D(^FHPT(FHDFN,"N",Y,"DI"))&(($P($G(^FHPT(FHDFN,"N",+Y,"DI")),U,6)="W"))) S FHDIC=1
I $D(^FHPT(FHDFN,"N",Y,"DI")) I ($P($G(^FHPT(FHDFN,"N",+Y,"DI")),U,6)="W"),$D(^XUSEC("FHMGR",DUZ)) S FHDIC=1
Q
;
DCS1 S FHDIC=0
F FHI9=0:0 S FHI9=$O(^FHPT(FHDFN,"N",FHI9)) Q:FHI9'>0 D
.I '$D(^FHPT(FHDFN,"N",FHI9,"DI")),$D(^XUSEC("FHMGR",DUZ)) S FHDIC=1
.I '$D(^FHPT(FHDFN,"N",FHI9,"DI")),$D(^FHPT(FHDFN,"N",FHI9,0)),($P(^(0),U,23)=DUZ) S FHDIC=1
.I $D(^FHPT(FHDFN,"N",FHI9,0)),($P(^(0),U,23)=DUZ),($D(^FHPT(FHDFN,"N",FHI9,"DI"))&(($P($G(^FHPT(FHDFN,"N",+FHI9,"DI")),U,6)="W")!($P($G(^FHPT(FHDFN,"N",FHI9,"DI")),U,6)=""))) S FHDIC=1
.I $D(^FHPT(FHDFN,"N",FHI9,"DI")) I ($P(^FHPT(FHDFN,"N",+FHI9,"DI"),U,6)="W")!($P(^FHPT(FHDFN,"N",FHI9,"DI"),U,6)=""),$D(^XUSEC("FHMGR",DUZ)) S FHDIC=1
Q
PRTA ;print if there is a current assessment.
S DTP=FHCASD D DTP^FH W !!,"Last Assessment on File: ",$S($G(FHCASD):$E(DTP,1,9),1:"No Assessment") S DTP=""
W:FHCAS ?40,"Status: ",$S(FHASS="C":"Completed",FHASS="S":"Signed",FHASS="W":"Work in Progress",1:"")
D DCS1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASM2 6064 printed Sep 23, 2025@19:22:48 Page 2
FHASM2 ; HISC/REL - Assessment (cont) ;5/14/93 10:03
+1 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
FRM ; Calculate Frame Size
+1 WRITE !!,"Wrist Circumference: "
if WCCM
WRITE WCCM_" cm// "
READ X:DTIME
if '$TEST!(X["^")
GOTO KIL^FHASM1
+2 IF X=""
IF $GET(WCCM)
SET X=WCCM
+3 SET WCCM=X
+4 if X=""
GOTO F1
+5 IF X'?1.2N.1".".N!(X<2)!(X>50)
WRITE *7,!,"Value should be between 2 and 50cm.; press RETURN to bypass."
GOTO FRM
+6 SET WCIR=+X
SET RAT=HGT*2.54/WCIR
+7 IF SEX="F"
SET FRM=$SELECT(RAT>11.0:"S",RAT<10.1:"L",1:"M")
+8 IF SEX="M"
SET FRM=$SELECT(RAT>10.4:"S",RAT<9.6:"L",1:"M")
+9 WRITE " ",$SELECT(FRM="S":"Small",FRM="M":"Medium",1:"Large")," Frame"
GOTO IBW
F1 IF FRM=""
SET FRM="M"
+1 SET X=""
WRITE !!,"Frame Size (SMALL,MEDIUM,LARGE) "_FRM
READ "// ",X:DTIME
+2 IF '$TEST!(X["^")
SET FHQUIT=1
GOTO KIL^FHASM1
+3 if X=""
SET X=FRM
DO TR^FHASM1
+4 IF $PIECE("SMALL",X,1)'=""
IF $PIECE("MEDIUM",X,1)'=""
IF $PIECE("LARGE",X,1)'=""
WRITE *7," Enter S, M or L"
GOTO F1
+5 SET FRM=$EXTRACT(X,1)
IBW ; Target Body Weight
+1 WRITE !!,"Calculation of Target Body Weight",!
SET METH=""
+2 IF H1'<60
WRITE !?10,"H Hamwi"
SET METH=METH_"H"
+3 IF SEX="M"
IF (H1<76)
IF (H1>60)
IF (AGE'<19)
WRITE !?10,"M Metropolitan 83"
WRITE !?10,"S Spinal Cord Injury"
SET METH=METH_"MS"
+4 IF SEX="F"
IF (H1<73)
IF (H1>57)
IF (AGE'<19)
WRITE !?10,"M Metropolitan 83"
WRITE !?10,"S Spinal Cord Injury"
SET METH=METH_"MS"
+5 IF SEX="M"
IF (H1<74)
IF (H1>60)
IF (AGE>64)
WRITE !?10,"G Geriatric"
SET METH=METH_"G"
+6 IF SEX="F"
IF (H1<70)
IF (H1>57)
IF (AGE>64)
WRITE !?10,"G Geriatric"
SET METH=METH_"G"
+7 IF AGE<10
WRITE !?10,"P Pediatric"
SET METH=METH_"P"
+8 WRITE !?10,"E Enter Manually"
SET METH=METH_"E"
SEL WRITE !!,"Method: "
if CIBW'=""
WRITE CIBW_" // "
READ X:DTIME
IF '$TEST!(X["^")
GOTO KIL^FHASM1
+1 IF X=""
IF CIBW'=""
SET X=CIBW
+2 DO TR^FHASM1
+3 IF METH'[$EXTRACT(X,1)!(X="")
WRITE *7,!," You Must Choose from the List Above"
GOTO SEL
+4 SET CIBW=X
+5 SET METH=$EXTRACT(X,1)
if METH="E"
DO E
if METH="H"
DO H^FHASM2D
if METH="M"
DO ^FHASM2A
if METH="S"
DO ^FHASM2A
if METH="G"
DO ^FHASM2B
if METH="P"
DO ^FHASM2C
if FHQUIT
GOTO KIL^FHASM1
IF IBW'>0
if IBW="^"
GOTO KIL^FHASM1
GOTO IBW
AMP SET FHAMP="NO"
IF AMP'=""
SET FHAMP="YES"
+1 if FHQUIT
GOTO KIL^FHASM1
+2 SET X=""
WRITE !!,"Does Patient have an Amputation? "_FHAMP
READ "// ",X:DTIME
+3 IF X="^"
SET FHQUIT=1
if '$TEST!(X["^")
GOTO KIL^FHASM1
+4 if X=""
SET X=FHAMP
DO TR^FHASM1
+5 SET FHAMP=X
+6 IF $PIECE("YES",FHAMP,1)'=""
IF $PIECE("NO",FHAMP,1)'=""
WRITE *7," Answer YES or NO"
GOTO AMP
+7 ;S FHAMP=$E(FHAMP,1),FHAMP=FHAMP="Y" G:'FHAMP A5
+8 IF $EXTRACT(FHAMP,1)="N"
SET AMP=""
GOTO A5
A1 WRITE !!,"Amputee Types: (may be multiple, e.g: 2,2,5)"
+1 WRITE !!?5,"1 Hand (0.7%)",?36,"2 Total Leg (16.1%)",!?5,"3 Total Arm (4.9%)",?36,"4 Foot (1.5%)"
+2 WRITE !?5,"5 Forearm and Hand (2.3%)",?36,"6 Calf and Foot (5.8%)"
A2 IF AMP'=""
WRITE !!,"Total Amputee %: ",AMP
KILL DIR
SET DIR(0)="SAO^Y:Yes;N:No"
SET DIR("A")="Do you wish to change this? "
SET DIR("B")="N"
DO ^DIR
if $DATA(DIRUT)
GOTO KIL^FHASM1
IF Y="N"
GOTO A5
+1 SET AMP=0
READ !!?2,"Amputee Types: ",X:DTIME
if '$TEST!(X["^")
GOTO KIL^FHASM1
+2 FOR K=1:1
SET Y=$PIECE(X,",",K)
if Y=""
QUIT
if Y'?1N!(Y<1)!(Y>6)
GOTO A6
SET AMP=AMP+$PIECE(".7,16.1,4.9,1.5,2.3,5.8",",",Y)
A3 WRITE !!,"Total Amputee %: ",AMP," // "
READ X:DTIME
if X=""
SET X=AMP
if '$TEST!(X["^")
GOTO KIL^FHASM1
+1 IF X<.5!(X>50)
WRITE *7,!,"Total % of amputations should be .5% to 50%"
GOTO A3
+2 SET AMP=+$JUSTIFY(X,0,1)
SET IBW=100-AMP*IBW/100
SET IBW=+$JUSTIFY(IBW,0,0)
A4 SET X1=$SELECT(FHU'="M":IBW_"#",1:+$JUSTIFY(IBW/2.2,0,1)_"kg")
+1 WRITE !!,"Select TBW after Amputee Correction: ",X1,"// "
READ X:DTIME
IF '$TEST!(X["^")
GOTO KIL^FHASM1
+2 IF X=""!(X=+X1)
GOTO A5
+3 DO WGT^FHASM1
IF Y<1
DO WGP^FHASM1
GOTO A4
+4 SET IBW=+Y
A5 SET IBW=+$JUSTIFY(IBW,0,0)
GOTO ^FHASM3
A6 WRITE *7,!!?5,"Enter a string of types (e.g: 1,1,4); no digit can exceed 6."
GOTO A2
E ; Manual Entry of Target Weight
+1 WRITE !!,"Enter Target Body Weight: "
if IBW'=""
WRITE IBW_"lbs// "
READ X:DTIME
IF '$TEST!(X["^")
SET FHQUIT=1
QUIT
+2 IF X=""
IF IBW'=""
SET X=IBW
+3 DO WGT^FHASM1
IF Y<1
DO WGP^FHASM1
GOTO E
+4 SET IBW=+Y
QUIT
+5 ;
ASK ;ask user to edit or create assessment.
+1 DO PRTA
+2 IF 'FHDIC
SET FHASK="C"
QUIT
+3 READ !!,"Do you want to Edit or Create or Delete Assessment? E// ",FHASK:DTIME
IF '$TEST!(FHASK["^")
SET FHQUIT=1
QUIT
+4 if FHASK=""
SET FHASK="E"
SET X=FHASK
DO TR^FH
SET FHASK=X
+5 SET FHASK=$EXTRACT(FHASK)
+6 IF (FHASK'="E")
IF (FHASK'="C")
IF (FHASK'="D")
WRITE *7,!?5,"Enter 'E' to Edit work in progress assessment or 'C' to Create new assessment or 'D' to Delete assessment!!"
GOTO ASK
+7 IF (FHASK="E")!(FHASK="D")
DO AAS
+8 QUIT
AAS ;ask user which assesment to edit or delete.
+1 WRITE !
+2 KILL DIC
SET DIC="^FHPT(FHDFN,""N"","
SET DIC(0)="Q"
SET DA=FHDFN
SET X="??"
+3 SET DIC("S")="D DCS^FHASM2 I FHDIC"
+4 SET DIC("W")="S FHASS=$P($D(^FHPT(FHDFN,""N"",+Y,""DI"")),U,6) W "" "",$S(FHASS=""C"":""Complete"",FHASS=""S"":""Signed"",1:""Work in Progress"")"
+5 DO ^DIC
SET DIC="^FHPT(FHDFN,""N"","
SET DIC(0)="AEQM"
+6 SET DIC("A")="SELECT Assessment Date: "
+7 WRITE !,"You can only access your own Work in Progress Assessment, unless you have an FHMGR key.",!
+8 SET DIC("W")="S FHASS=$P($D(^FHPT(FHDFN,""N"",+Y,""DI"")),U,6) W "" "",$S(FHASS=""C"":""Complete"",FHASS=""S"":""Signed"",1:""Work in Progress"")"
+9 DO ^DIC
IF "^"[X!$DATA(DTOUT)
SET FHQUIT=1
QUIT
+10 if Y<1
GOTO AAS
+11 SET FHCAS=+Y
+12 KILL DIC
+13 QUIT
DCS SET FHDIC=0
IF '$DATA(^FHPT(FHDFN,"N",Y,"DI"))
IF $DATA(^XUSEC("FHMGR",DUZ))
SET FHDIC=1
+1 IF '$DATA(^FHPT(FHDFN,"N",Y,"DI"))
IF $DATA(^FHPT(FHDFN,"N",Y,0))
IF ($PIECE(^(0),U,23)=DUZ)
SET FHDIC=1
+2 IF $DATA(^FHPT(FHDFN,"N",Y,0))
IF ($PIECE(^(0),U,23)=DUZ)
IF ($DATA(^FHPT(FHDFN,"N",Y,"DI"))&(($PIECE($GET(^FHPT(FHDFN,"N",+Y,"DI")),U,6)="W")))
SET FHDIC=1
+3 IF $DATA(^FHPT(FHDFN,"N",Y,"DI"))
IF ($PIECE($GET(^FHPT(FHDFN,"N",+Y,"DI")),U,6)="W")
IF $DATA(^XUSEC("FHMGR",DUZ))
SET FHDIC=1
+4 QUIT
+5 ;
DCS1 SET FHDIC=0
+1 FOR FHI9=0:0
SET FHI9=$ORDER(^FHPT(FHDFN,"N",FHI9))
if FHI9'>0
QUIT
Begin DoDot:1
+2 IF '$DATA(^FHPT(FHDFN,"N",FHI9,"DI"))
IF $DATA(^XUSEC("FHMGR",DUZ))
SET FHDIC=1
+3 IF '$DATA(^FHPT(FHDFN,"N",FHI9,"DI"))
IF $DATA(^FHPT(FHDFN,"N",FHI9,0))
IF ($PIECE(^(0),U,23)=DUZ)
SET FHDIC=1
+4 IF $DATA(^FHPT(FHDFN,"N",FHI9,0))
IF ($PIECE(^(0),U,23)=DUZ)
IF ($DATA(^FHPT(FHDFN,"N",FHI9,"DI"))&(($PIECE($GET(^FHPT(FHDFN,"N",+FHI9,"DI")),U,6)="W")!($PIECE($GET(^FHPT(FHDFN,"N",FHI9,"DI")),U,6)="")))
SET FHDIC=1
+5 IF $DATA(^FHPT(FHDFN,"N",FHI9,"DI"))
IF ($PIECE(^FHPT(FHDFN,"N",+FHI9,"DI"),U,6)="W")!($PIECE(^FHPT(FHDFN,"N",FHI9,"DI"),U,6)="")
IF $DATA(^XUSEC("FHMGR",DUZ))
SET FHDIC=1
End DoDot:1
+6 QUIT
PRTA ;print if there is a current assessment.
+1 SET DTP=FHCASD
DO DTP^FH
WRITE !!,"Last Assessment on File: ",$SELECT($GET(FHCASD):$EXTRACT(DTP,1,9),1:"No Assessment")
SET DTP=""
+2 if FHCAS
WRITE ?40,"Status: ",$SELECT(FHASS="C":"Completed",FHASS="S":"Signed",FHASS="W":"Work in Progress",1:"")
+3 DO DCS1
+4 QUIT
