FHASMR.m

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