- FHASMR ; HISC/REL/NCA - Assessment Report ;4/25/93 18:46
- ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
- S FHALL=1 D ^FHOMDPA G:'FHDFN KIL
- I '$D(^FHPT(FHDFN,"N",0)) W !!,"No Nutrition Assessments on file" G KIL
- ;K DIC S DIC="^FHPT(FHDFN,""N"",",DIC(0)="Q",DA=FHDFN,X="??" D ^DIC
- W ! F FHNIEN=0:0 S FHNIEN=$O(^FHPT(FHDFN,"N","B",FHNIEN)) Q:FHNIEN'>0 D
- .S FHNRV=$O(^FHPT(FHDFN,"N","B",FHNIEN,"")) Q:FHNRV'>0
- .S Y=$P($G(^FHPT(FHDFN,"N",FHNRV,0)),U,1) D DD^%DT W !?3,Y
- .S FHNASS=$P($G(^FHPT(FHDFN,"N",FHNRV,"DI")),U,6)
- .W ?25,$S(FHNASS="C":"Completed",FHNASS="S":"Signed",FHNASS="W":"Work in Progress",1:"")
- A0 S DIC="^FHPT(FHDFN,""N"",",DIC(0)="AEQM",DIC("A")="SELECT Assessment Date: " W ! D ^DIC G KIL:"^"[X!$D(DTOUT),A0:Y<1 S ASN=+Y
- P0 ; Select Device
- K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) S FHPGM="Q1^FHASMR",FHLST="FHDFN^DFN^PID^ASN" D EN2^FH G KIL
- U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
- Q1 ; Process Printing Assessment
- D PATNAME^FHOMUTL
- S NAM=FHPTNM
- S %DT="XT",X="NOW" D ^%DT S DT=Y\1,DTP=+Y D DTP^FH S NOW=DTP
- ;S NAM=$P(^DPT(DFN,0),"^",1)
- S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1)
- S Y=^FHPT(FHDFN,"N",ASN,0)
- F K=1:1:22 S @$P("ADT SEX AGE HGT HGP WGT WGP DWGT UWGT RIBW FRM AMP X X X KCAL PRO FLD RC XD BMI BMIP"," ",K)=$P(Y,"^",K)
- S NB=$P(Y,"^",25)
- S EXT="" I $D(^FHPT(FHDFN,"N",ASN,1)) S Y=^(1) F K=1:1:10 S @$P("TSF TSFP SCA SCAP ACIR ACIRP CCIR CCIRP BFAMA BFAMAP"," ",K)=$P(Y,"^",K)
- S APP=$G(^FHPT(FHDFN,"N",ASN,2))
- K LRTST F K=0:0 S K=$O(^FHPT(FHDFN,"N",ASN,"L",K)) Q:K<1 S LRTST(K)=^(K,0)
- S PRT=1 G ^FHASMR1
- KIL ; Final variable kill
- ;quit if calls from enter/edit assessment
- Q:$D(FHASK)
- G KILL^XUSCLEAN
- FHASMR ; HISC/REL/NCA - Assessment Report ;4/25/93 18:46
- +1 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
- +2 SET FHALL=1
- DO ^FHOMDPA
- IF 'FHDFN
- GOTO KIL
- +3 IF '$DATA(^FHPT(FHDFN,"N",0))
- WRITE !!,"No Nutrition Assessments on file"
- GOTO KIL
- +4 ;K DIC S DIC="^FHPT(FHDFN,""N"",",DIC(0)="Q",DA=FHDFN,X="??" D ^DIC
- +5 WRITE !
- FOR FHNIEN=0:0
- SET FHNIEN=$ORDER(^FHPT(FHDFN,"N","B",FHNIEN))
- IF FHNIEN'>0
- QUIT
- Begin DoDot:1
- +6 SET FHNRV=$ORDER(^FHPT(FHDFN,"N","B",FHNIEN,""))
- IF FHNRV'>0
- QUIT
- +7 SET Y=$PIECE($GET(^FHPT(FHDFN,"N",FHNRV,0)),U,1)
- DO DD^%DT
- WRITE !?3,Y
- +8 SET FHNASS=$PIECE($GET(^FHPT(FHDFN,"N",FHNRV,"DI")),U,6)
- +9 WRITE ?25,$SELECT(FHNASS="C":"Completed",FHNASS="S":"Signed",FHNASS="W":"Work in Progress",1:"")
- End DoDot:1
- A0 SET DIC="^FHPT(FHDFN,""N"","
- SET DIC(0)="AEQM"
- SET DIC("A")="SELECT Assessment Date: "
- WRITE !
- DO ^DIC
- IF "^"[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO A0
- SET ASN=+Y
- P0 ; Select Device
- +1 KILL IOP
- SET %ZIS="MQ"
- SET %ZIS("B")="HOME"
- WRITE !
- DO ^%ZIS
- KILL %ZIS,IOP
- IF POP
- GOTO KIL
- +2 IF $DATA(IO("Q"))
- SET FHPGM="Q1^FHASMR"
- SET FHLST="FHDFN^DFN^PID^ASN"
- DO EN2^FH
- GOTO KIL
- +3 USE IO
- DO Q1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- Q1 ; Process Printing Assessment
- +1 DO PATNAME^FHOMUTL
- +2 SET NAM=FHPTNM
- +3 SET %DT="XT"
- SET X="NOW"
- DO ^%DT
- SET DT=Y\1
- SET DTP=+Y
- DO DTP^FH
- SET NOW=DTP
- +4 ;S NAM=$P(^DPT(DFN,0),"^",1)
- +5 SET FHAP=$GET(^FH(119.9,1,3))
- SET FHU=$PIECE(FHAP,"^",1)
- +6 SET Y=^FHPT(FHDFN,"N",ASN,0)
- +7 FOR K=1:1:22
- SET @$PIECE("ADT SEX AGE HGT HGP WGT WGP DWGT UWGT RIBW FRM AMP X X X KCAL PRO FLD RC XD BMI BMIP"," ",K)=$PIECE(Y,"^",K)
- +8 SET NB=$PIECE(Y,"^",25)
- +9 SET EXT=""
- IF $DATA(^FHPT(FHDFN,"N",ASN,1))
- SET Y=^(1)
- FOR K=1:1:10
- SET @$PIECE("TSF TSFP SCA SCAP ACIR ACIRP CCIR CCIRP BFAMA BFAMAP"," ",K)=$PIECE(Y,"^",K)
- +10 SET APP=$GET(^FHPT(FHDFN,"N",ASN,2))
- +11 KILL LRTST
- FOR K=0:0
- SET K=$ORDER(^FHPT(FHDFN,"N",ASN,"L",K))
- IF K<1
- QUIT
- SET LRTST(K)=^(K,0)
- +12 SET PRT=1
- GOTO ^FHASMR1
- KIL ; Final variable kill
- +1 ;quit if calls from enter/edit assessment
- +2 IF $DATA(FHASK)
- QUIT
- +3 GOTO KILL^XUSCLEAN
