Released FH*5.5*22 SEQ #20
Extracted from mail message
**KIDS**:FH*5.5*22^
**INSTALL NAME**
FH*5.5*22
"BLD",8225,0)
FH*5.5*22^DIETETICS^0^3090825^y
"BLD",8225,1,0)
^^1^1^3090821^
"BLD",8225,1,1,0)
FIXES A DIVIDE BY ZERO ERROR
"BLD",8225,4,0)
^9.64PA^^
"BLD",8225,6.3)
1
"BLD",8225,"ABPKG")
n
"BLD",8225,"KRN",0)
^9.67PA^779.2^20
"BLD",8225,"KRN",.4,0)
.4
"BLD",8225,"KRN",.401,0)
.401
"BLD",8225,"KRN",.402,0)
.402
"BLD",8225,"KRN",.403,0)
.403
"BLD",8225,"KRN",.5,0)
.5
"BLD",8225,"KRN",.84,0)
.84
"BLD",8225,"KRN",3.6,0)
3.6
"BLD",8225,"KRN",3.8,0)
3.8
"BLD",8225,"KRN",9.2,0)
9.2
"BLD",8225,"KRN",9.8,0)
9.8
"BLD",8225,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",8225,"KRN",9.8,"NM",1,0)
FHASM1^^0^B65722753
"BLD",8225,"KRN",9.8,"NM","B","FHASM1",1)
"BLD",8225,"KRN",19,0)
19
"BLD",8225,"KRN",19.1,0)
19.1
"BLD",8225,"KRN",101,0)
101
"BLD",8225,"KRN",409.61,0)
409.61
"BLD",8225,"KRN",771,0)
771
"BLD",8225,"KRN",779.2,0)
779.2
"BLD",8225,"KRN",870,0)
870
"BLD",8225,"KRN",8989.51,0)
8989.51
"BLD",8225,"KRN",8989.52,0)
8989.52
"BLD",8225,"KRN",8994,0)
8994
"BLD",8225,"KRN","B",.4,.4)
"BLD",8225,"KRN","B",.401,.401)
"BLD",8225,"KRN","B",.402,.402)
"BLD",8225,"KRN","B",.403,.403)
"BLD",8225,"KRN","B",.5,.5)
"BLD",8225,"KRN","B",.84,.84)
"BLD",8225,"KRN","B",3.6,3.6)
"BLD",8225,"KRN","B",3.8,3.8)
"BLD",8225,"KRN","B",9.2,9.2)
"BLD",8225,"KRN","B",9.8,9.8)
"BLD",8225,"KRN","B",19,19)
"BLD",8225,"KRN","B",19.1,19.1)
"BLD",8225,"KRN","B",101,101)
"BLD",8225,"KRN","B",409.61,409.61)
"BLD",8225,"KRN","B",771,771)
"BLD",8225,"KRN","B",779.2,779.2)
"BLD",8225,"KRN","B",870,870)
"BLD",8225,"KRN","B",8989.51,8989.51)
"BLD",8225,"KRN","B",8989.52,8989.52)
"BLD",8225,"KRN","B",8994,8994)
"BLD",8225,"QUES",0)
^9.62^^
"BLD",8225,"REQB",0)
^9.611^1^1
"BLD",8225,"REQB",1,0)
FH*5.5*14^2
"BLD",8225,"REQB","B","FH*5.5*14",1)
"MBREQ")
0
"PKG",122,-1)
1^1
"PKG",122,0)
DIETETICS^FH^Dietetics System
"PKG",122,20,0)
^9.402P^^
"PKG",122,22,0)
^9.49I^1^1
"PKG",122,22,1,0)
5.5^3050202^3050308^33227
"PKG",122,22,1,"PAH",1,0)
22^3090825
"PKG",122,22,1,"PAH",1,1,0)
^^1^1^3090825
"PKG",122,22,1,"PAH",1,1,1,0)
FIXES A DIVIDE BY ZERO ERROR
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")
"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
1
"RTN","FHASM1")
0^1^B65722753^B65620026
"RTN","FHASM1",1,0)
FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08
"RTN","FHASM1",2,0)
;;5.5;DIETETICS;**8,14,22**;Jan 28, 2005;Build 1
"RTN","FHASM1",3,0)
W @IOF,!!?20,"N U T R I T I O N A S S E S S M E N T",!! S X="T",%DT="X" D ^%DT S DT=+Y
"RTN","FHASM1",4,0)
F1 ; Select Patient
"RTN","FHASM1",5,0)
S FHALL=1 D ^FHOMDPA G KILL^XUSCLEAN:'FHDFN
"RTN","FHASM1",6,0)
S:DFN'>0 DFN=""
"RTN","FHASM1",7,0)
I $G(DFN),$P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KILL^XUSCLEAN
"RTN","FHASM1",8,0)
S (ADM,ASN,FHASK,KNEE,EXT,DTP,FHCAS,FHCASD,FHASS,FHFFC,FHFEC,FHFPC,FHCFRBO,FHCM,FHEF,FHKCAL,FHLOC)="",(FHHWF,FHQUIT)=0
"RTN","FHASM1",9,0)
S (ADT,SEX,AGE,HGT,HGP,WGT,WGP,DWGT,UWGT,IBW,FRM,AMP,KCAL,PRO,FLD,RC,XD,BMI,BMIP,FHCLI,FHPLXSV)=""
"RTN","FHASM1",10,0)
S (NOW,NB,TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,FHAPP,FHEDU,DEWGT,WARD,FHSPC)=""
"RTN","FHASM1",11,0)
S (FHDIPL,FHDIPLD,FHAST,FHDINF,FHDINFD,FHFUD,FHDIST,FHDIDI,FHDITF,FHDIDI,FHDITF,FHDITFDT,FHDITFCM,FHDITFML,FHDITFKC,FHVHGT,FHDVHGT)=""
"RTN","FHASM1",12,0)
S (TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,BMI,BMIP,X1,X2,FHFUDS,EKKG,FHFDC,FHFDCSV)=""
"RTN","FHASM1",13,0)
S (WCCM,CIBW,CERBO,CENB,PCTB,SEF,CFRB,CFRBO,CPRBO,NWGT,DNWGT,FHYN,FHDINA,FHVWGT,FHDVWGT,FHPL)=""
"RTN","FHASM1",14,0)
S FHCLI=DUZ
"RTN","FHASM1",15,0)
K ^TMP("FH",$J) S FHQTALL=0
"RTN","FHASM1",16,0)
;get current diet and tf
"RTN","FHASM1",17,0)
S Y=""
"RTN","FHASM1",18,0)
I DFN D
"RTN","FHASM1",19,0)
.F I=0:0 S I=$O(^FHPT("AW",I)) Q:I'>0 I $D(^FHPT("AW",I,FHDFN)) S FHLOC=I Q
"RTN","FHASM1",20,0)
.I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHCLI=$P($G(^FH(119.6,FHLOC,0)),U,2)
"RTN","FHASM1",21,0)
.S WARD=$G(^DPT(DFN,.1)) I WARD'="" S ADM=$G(^DPT("CN",WARD,DFN))
"RTN","FHASM1",22,0)
.I ADM D CUR^FHORD7 S X1=""
"RTN","FHASM1",23,0)
.S FHDIDI=$S(Y'="":Y,1:"No Order")
"RTN","FHASM1",24,0)
.W !,"Current Diet: ",FHDIDI
"RTN","FHASM1",25,0)
.Q:'ADM
"RTN","FHASM1",26,0)
.S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4)
"RTN","FHASM1",27,0)
.Q:'TF
"RTN","FHASM1",28,0)
.S FHDITFDT=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,1)
"RTN","FHASM1",29,0)
.S FHDITFCM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,5)
"RTN","FHASM1",30,0)
.S FHDITFML=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,6)
"RTN","FHASM1",31,0)
.S FHDITFKC=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,7)
"RTN","FHASM1",32,0)
.F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 D
"RTN","FHASM1",33,0)
..S Y=^(TF2,0),TUN=$P(Y,"^",1)
"RTN","FHASM1",34,0)
..I TUN,$D(^FH(118.2,TUN,0)) S FHDITFPR(TUN)=Y
"RTN","FHASM1",35,0)
.W ?30,"Tubefeeding: " I $D(FHDITFPR) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 W $P($G(^FH(118.2,FHTUN,0)),"^",1) I $O(FHDITFPR(FHTUN))'="" W ", "
"RTN","FHASM1",36,0)
K Y
"RTN","FHASM1",37,0)
STA ;if pt has Work in Progress assessment, ask user to Edit or Create or Delete Assessment.
"RTN","FHASM1",38,0)
D PATNAME^FHOMUTL
"RTN","FHASM1",39,0)
S AGE=FHAGE
"RTN","FHASM1",40,0)
I $D(^FHPT(FHDFN,"N",0)) D
"RTN","FHASM1",41,0)
.S FHCAS=$P(^FHPT(FHDFN,"N",0),U,3)
"RTN","FHASM1",42,0)
.Q:'FHCAS
"RTN","FHASM1",43,0)
.S FHCASD=$P(^FHPT(FHDFN,"N",FHCAS,0),U,1)
"RTN","FHASM1",44,0)
.I $D(^FHPT(FHDFN,"N",FHCAS,"DI")) S FHASS=$P($G(^FHPT(FHDFN,"N",FHCAS,"DI")),U,6)
"RTN","FHASM1",45,0)
.S FHAST=0
"RTN","FHASM1",46,0)
.F FHA=0:0 S FHA=$O(^FHPT(FHDFN,"N",FHA)) Q:'FHA D
"RTN","FHASM1",47,0)
..S FHASSD=$P($G(^FHPT(FHDFN,"N",FHA,"DI")),U,6)
"RTN","FHASM1",48,0)
..I (FHASSD="W")!(FHASS="") S FHAST=1
"RTN","FHASM1",49,0)
..I $D(^FHPT(FHDFN,"N",FHA,0)),'$D(^FHPT(FHDFN,"N",FHA,"DI")) S FHAST=1
"RTN","FHASM1",50,0)
I 'FHCAS!(FHAST=0) G CRE
"RTN","FHASM1",51,0)
D ASK^FHASM2 G:FHQUIT KILL^XUSCLEAN
"RTN","FHASM1",52,0)
I FHASK="D" S DIK="^FHPT("_FHDFN_",""N"",",DA(1)=FHDFN,DA=FHCAS D ^DIK W ?65,"Deleted..." G F1
"RTN","FHASM1",53,0)
I FHASK="E" S ADT=FHCAS D SVAR G:SEX=""!(AGE="") P1 G F3A
"RTN","FHASM1",54,0)
CRE ;create new assessment
"RTN","FHASM1",55,0)
;D:FHCAS PRTA^FHASM2
"RTN","FHASM1",56,0)
S FHASK="C"
"RTN","FHASM1",57,0)
W !!,"Creating new Assessment...",!
"RTN","FHASM1",58,0)
I (FHSEX="")!(FHAGE="") G P1
"RTN","FHASM1",59,0)
E S NAM=FHPTNM,SEX=FHSEX,AGE=FHAGE
"RTN","FHASM1",60,0)
S X="NOW",%DT="XT" D ^%DT S ADT=Y
"RTN","FHASM1",61,0)
I SEX=""!(AGE="") G P1
"RTN","FHASM1",62,0)
F2 S X="NOW",%DT="XT" D ^%DT S ADT=Y
"RTN","FHASM1",63,0)
F3 I DFN,$D(^FHPT(FHDFN,"N",9999999-ADT)) S ADT=$$FMADD^XLFDT(ADT,,,1) G F3
"RTN","FHASM1",64,0)
F3A ;start here if edit
"RTN","FHASM1",65,0)
S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1),NAM=FHPTNM
"RTN","FHASM1",66,0)
G:'FHDFN F4 S XX=$O(^FHPT(FHDFN,"N",0)) G:XX="" F4 S XX=$G(^(XX,0)),HGT=$P(XX,"^",4),HGP=$P(XX,"^",5)
"RTN","FHASM1",67,0)
I HGP'="S" S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_"CM",X1=$S(FHU'="M":X1,1:X2)
"RTN","FHASM1",68,0)
F4 ; If Multidivisional site Select Communications Office
"RTN","FHASM1",69,0)
S FHCOMM="" I $P($G(^FH(119.9,1,0)),U,20)'="N" D I FHCOMM="" Q
"RTN","FHASM1",70,0)
.K DIC S DIC="^FH(119.73," S DIC(0)="AEMQ" D ^DIC
"RTN","FHASM1",71,0)
.I Y=-1 Q
"RTN","FHASM1",72,0)
.S FHCOMM=+Y
"RTN","FHASM1",73,0)
;get ht and wt from vitals.
"RTN","FHASM1",74,0)
I DFN S GMRVSTR="WT" D EN6^GMRVUTL S FHDVWGT=$P(X,"^",1),FHVWGT=$P(X,"^",8),GMRVSTR="HT" D EN6^GMRVUTL S FHVHGT=$P(X,"^",8)
"RTN","FHASM1",75,0)
I X1="" S (X1,HGT)=FHVHGT
"RTN","FHASM1",76,0)
F4A W !!,"Height: " W:X1'="" X1,"// " R X:DTIME G:'$T!(X["^") KIL I X="",X1'="" S Y0=$J(HGT,0,0),H1=Y0 G F5
"RTN","FHASM1",77,0)
D TR,HGT I Y<1 D HGP G F4A
"RTN","FHASM1",78,0)
S:X1'=Y FHHWF=1
"RTN","FHASM1",79,0)
S HGT=Y,H1=Y0,HGP=Y1
"RTN","FHASM1",80,0)
F5 I FHVWGT'="" S WGT=FHVWGT
"RTN","FHASM1",81,0)
W !!,"Weight: " W:WGT'="" WGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="",WGT S X=WGT_"#"
"RTN","FHASM1",82,0)
S:X="a" X="A"
"RTN","FHASM1",83,0)
I X="A",AGE>39 D A^FHASM2D G:Y<1 F5 S:WGT'=Y FHHWF=1 S WGT=Y,WGP="A" G F6
"RTN","FHASM1",84,0)
D WGT I Y<1 D WGP W:AGE>39 !,"You may enter an A to calculate weight anthropometrically." G F5
"RTN","FHASM1",85,0)
S:WGT'=Y FHHWF=1
"RTN","FHASM1",86,0)
S WGT=Y,WGP=Y1 I FHDVWGT'="" S DWGT=$P(FHDVWGT,".",1)
"RTN","FHASM1",87,0)
F6 G:'FHHWF F7
"RTN","FHASM1",88,0)
S %DT="AEP",%DT("A")="Date Weight Taken: "
"RTN","FHASM1",89,0)
I 'DWGT,FHDVWGT S DTP=$E(FHDVWGT,4,5)_"/"_$E(FHDVWGT,6,7)_"/"_$E(FHDVWGT,2,3)
"RTN","FHASM1",90,0)
I DWGT S DTP=$E(DWGT,4,5)_"/"_$E(DWGT,6,7)_"/"_$E(DWGT,2,3)
"RTN","FHASM1",91,0)
S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY"
"RTN","FHASM1",92,0)
S %DT(0)="-T" W ! D ^%DT K %DT G KIL:X["^"!$D(DTOUT),F6:Y<1
"RTN","FHASM1",93,0)
S DWGT=Y
"RTN","FHASM1",94,0)
;
"RTN","FHASM1",95,0)
F7 S:UWGT X=UWGT W !!,"Usual Weight: " W:UWGT'="" UWGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="" G F8
"RTN","FHASM1",96,0)
D WGT I Y<1 D WGP G F7
"RTN","FHASM1",97,0)
S UWGT=Y
"RTN","FHASM1",98,0)
F8 K %DT,A1,K,X,Y G ^FHASM2
"RTN","FHASM1",99,0)
HGT ; Convert Height to inches
"RTN","FHASM1",100,0)
S A1=+X I 'A1 S Y=-1 Q
"RTN","FHASM1",101,0)
S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SMK"[$E(X,1) S Y=A1 S:FHU="M" Y=Y/2.54 G H1
"RTN","FHASM1",102,0)
I """I"[$E(X,1) S Y=A1 G H1
"RTN","FHASM1",103,0)
I $E(X,1)="C" S Y=A1/2.54 G H1
"RTN","FHASM1",104,0)
I "'F"'[$E(X,1) S Y=-1 G H2
"RTN","FHASM1",105,0)
S Y=A1*12 F K=1:1 Q:$E(X,K)?.N
"RTN","FHASM1",106,0)
I $E(X,K,99)="" G H1
"RTN","FHASM1",107,0)
S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99)
"RTN","FHASM1",108,0)
I """I"'[$E(X,1) S Y=-1 G H2
"RTN","FHASM1",109,0)
S Y=Y+A1
"RTN","FHASM1",110,0)
H1 I X["K" D K^FHASM2D
"RTN","FHASM1",111,0)
H2 I Y<12!(Y>96) S Y=-1
"RTN","FHASM1",112,0)
S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1=$S(X["K":"K",X["S":"S",1:"") Q
"RTN","FHASM1",113,0)
HGP ; Height Help
"RTN","FHASM1",114,0)
W !!,"Enter height as: 6' 2"" or 74"" or 74IN or 6FT 2 IN or 30CM"
"RTN","FHASM1",115,0)
W !,"Add an S if height is stated rather than measured."
"RTN","FHASM1",116,0)
W !,"Add a K if value is a Knee Height measurement."
"RTN","FHASM1",117,0)
W !,"Height should be between 12"" and 96"" (8')." Q
"RTN","FHASM1",118,0)
WGT ; Convert Weight to lbs.
"RTN","FHASM1",119,0)
D TR S A1=+X I 'A1 S Y=-1 Q
"RTN","FHASM1",120,0)
S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SM"[$E(X,1) S Y=A1 S:FHU="M" Y=Y*2.2 G W1
"RTN","FHASM1",121,0)
I $E(X,1)="O" S Y=A1/16 G W1
"RTN","FHASM1",122,0)
I $E(X,1)="G" S Y=A1/1000*2.2 G W1
"RTN","FHASM1",123,0)
I $E(X,1)="K" S Y=A1*2.2 G W1
"RTN","FHASM1",124,0)
I "L#"'[$E(X,1) S Y=-1 G W1
"RTN","FHASM1",125,0)
S Y=A1 F K=1:1 Q:$E(X,K)?.N
"RTN","FHASM1",126,0)
I $E(X,K,99)="" G W1
"RTN","FHASM1",127,0)
S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99)
"RTN","FHASM1",128,0)
I $E(X,1)'="O" S Y=-1 G W1
"RTN","FHASM1",129,0)
S Y=A1/16+Y
"RTN","FHASM1",130,0)
W1 I Y<0!(Y>750) S Y=-1
"RTN","FHASM1",131,0)
S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1="" S:X["S" Y1="S" Q
"RTN","FHASM1",132,0)
WGP ; Weight help
"RTN","FHASM1",133,0)
W !!,"Enter Weight as 150# or 150# 6OZ or 800G or 70KG"
"RTN","FHASM1",134,0)
W !,"Add an S if weight is stated rather than measured."
"RTN","FHASM1",135,0)
W !,"Enter an A to determine weight anthropometrically."
"RTN","FHASM1",136,0)
W !,"Weight should be between 0 Lbs and 750 Lbs." Q
"RTN","FHASM1",137,0)
TR ; Translate Lower to Upper Case
"RTN","FHASM1",138,0)
D TR^FH
"RTN","FHASM1",139,0)
Q
"RTN","FHASM1",140,0)
KIL ; Final variable kill
"RTN","FHASM1",141,0)
;if X not equal ^, update or create nutrition assessment
"RTN","FHASM1",142,0)
G:$G(FHQUIT) ASKUS
"RTN","FHASM1",143,0)
I $D(X),X=U G KILL^XUSCLEAN
"RTN","FHASM1",144,0)
D SDAT^FHASM7
"RTN","FHASM1",145,0)
;
"RTN","FHASM1",146,0)
G KILL^XUSCLEAN
"RTN","FHASM1",147,0)
PAT S (FHDFN,DFN,SEX,AGE,PID)="" R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!(NAM["^") KILL^XUSCLEAN
"RTN","FHASM1",148,0)
I NAM["?"!(NAM'?.ANP)!(NAM="") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT
"RTN","FHASM1",149,0)
P1 I SEX="" R !,"Sex: ",SEX:DTIME S:SEX="" SEX="?" G:'$T!(SEX["^") KILL^XUSCLEAN S X=SEX D TR S SEX=X I $P("FEMALE",SEX,1)'="",$P("MALE",SEX,1)'="" W *7," Enter M or F" S SEX="" G P1
"RTN","FHASM1",150,0)
S SEX=$E(SEX,1)
"RTN","FHASM1",151,0)
P2 I AGE="" R !,"Age: ",AGE:DTIME S:AGE="" AGE="?" G:'$T!(AGE["^") KILL^XUSCLEAN S X=AGE D TR S AGE=X
"RTN","FHASM1",152,0)
S:AGE["M" AGE=+$J($P(AGE,"M",1)/12,0,2) I AGE'>0!(AGE>124) W !?5,"Enter Age Less Than 124 in Years or Months (followed by M) but Not Both" S AGE="" G P2
"RTN","FHASM1",153,0)
G F2
"RTN","FHASM1",154,0)
SVAR ;set variables of incomplete assessment.
"RTN","FHASM1",155,0)
Q:'$D(^FHPT(FHDFN,"N",0))
"RTN","FHASM1",156,0)
S FHA0=$G(^FHPT(FHDFN,"N",FHCAS,0))
"RTN","FHASM1",157,0)
S ADT=$P(FHA0,U,1),SEX=$P(FHA0,U,2),AGE=$P(FHA0,U,3),HGT=$P(FHA0,U,4)
"RTN","FHASM1",158,0)
S HGP=$P(FHA0,U,5),WGT=$P(FHA0,U,6),WGP=$P(FHA0,U,7),DWGT=$P(FHA0,U,8)
"RTN","FHASM1",159,0)
S UWGT=$P(FHA0,U,9),IBW=$P(FHA0,U,10),FRM=$P(FHA0,U,11),AMP=$P(FHA0,U,12)
"RTN","FHASM1",160,0)
S KCAL=$P(FHA0,U,16),PRO=$P(FHA0,U,17),FLD=$P(FHA0,U,18),RC=$P(FHA0,U,19)
"RTN","FHASM1",161,0)
S XD=$P(FHA0,U,20),BMI=$P(FHA0,U,21),BMIP=$P(FHA0,U,22)
"RTN","FHASM1",162,0)
S NOW=$P(FHA0,U,24),NB=$P(FHA0,U,25)
"RTN","FHASM1",163,0)
S FHA1=$G(^FHPT(FHDFN,"N",FHCAS,1))
"RTN","FHASM1",164,0)
S TSF=$P(FHA1,U,1),TSFP=$P(FHA1,U,2),SCA=$P(FHA1,U,3),SCAP=$P(FHA1,U,4),ACIR=$P(FHA1,U,5)
"RTN","FHASM1",165,0)
S ACIRP=$P(FHA1,U,6),CCIR=$P(FHA1,U,7),CCIRP=$P(FHA1,U,8),BFAMA=$P(FHA1,U,9),BFAMAP=$P(FHA1,U,10)
"RTN","FHASM1",166,0)
S WCCM=$P(FHA1,U,11),CIBW=$P(FHA1,U,12),CERBO=$P(FHA1,U,13),CENB=$P(FHA1,U,14),PCTB=$P(FHA1,U,15)
"RTN","FHASM1",167,0)
S SEF=$P(FHA1,U,16),CFRB=$P(FHA1,U,17),CFRBO=$P(FHA1,U,18),CPRBO=$P(FHA1,U,19),EKKG=$P(FHA1,U,20)
"RTN","FHASM1",168,0)
S FHAPP=$G(^FHPT(FHDFN,"N",FHCAS,2))
"RTN","FHASM1",169,0)
S FHA3=$G(^FHPT(FHDFN,"N",FHCAS,3))
"RTN","FHASM1",170,0)
S FHYN=$P(FHA3,U,1),FHFEC=$P(FHA3,U,2),FHFPC=$P(FHA3,U,3),FHDINA=$P(FHA3,U,4),FHEDU=$P(FHA3,U,5)
"RTN","FHASM1",171,0)
S FHFDCSV=$P(FHA3,U,6),FHPL=$P(FHA3,U,7),FHSPC=$P(FHA3,U,8)
"RTN","FHASM1",172,0)
S FHADI=$G(^FHPT(FHDFN,"N",FHCAS,"DI"))
"RTN","FHASM1",173,0)
S FHDIPL=$P(FHADI,U,1),FHDIPLD=$P(FHADI,U,2),FHDINF=$P(FHADI,U,3),FHDINFD=$P(FHADI,U,4)
"RTN","FHASM1",174,0)
S (FHFUD,FHFUDS)=$P(FHADI,U,5),FHDIST=$P(FHADI,U,6),FHDIDI=$P(FHADI,U,7),FHDITF=$P(FHADI,U,8)
"RTN","FHASM1",175,0)
Q
"RTN","FHASM1",176,0)
ASKUS R !!,"Do you wish to SAVE this Assessment Y// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN
"RTN","FHASM1",177,0)
S:X="" X="Y" D TR I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G ASKUS
"RTN","FHASM1",178,0)
I X'?1"Y".E G KILL^XUSCLEAN
"RTN","FHASM1",179,0)
D SDAT^FHASM7 G KILL^XUSCLEAN
"VER")
8.0^22.0
"BLD",8225,6)
^20
**END**
**END**