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

FHASM2.m

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