- 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 Jan 18, 2025@02:48:02 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