FHASN5 ; HISC/NCA - Print Patient's Nutrition Status History ;12/13/93 12:58
;;5.5;DIETETICS;;Jan 28, 2005
EN2 ; Select Patient to print
S ALL=1 D ^FHDPA G:'DFN KIL S:WARD="" (ADM,ADTE,DSCH)=""
I $P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5,"Patient has expired." G EN2
S X5=$O(^FHPT(FHDFN,"S",0)) I X5="" W *7,!!?5,"No status on file for this patient." G EN2
I $O(^FHPT(FHDFN,"A",0))<1 G D1
S DIC="^FHPT(FHDFN,""A"",",DIC(0)="Q",DA=FHDFN,X="??" D ^DIC
S WARD=$G(^DPT(DFN,.1))
A0 W !!,"Select ADMISSION",$S(WARD'="":" (or C for CURRENT)",1:""),": " R X:DTIME G:'$T!(X["^") KIL D:X="c" TR^FH I X="" G D1:WARD="",KIL
I WARD'="",X="C" S ADM=$G(^DPT("CN",WARD,DFN)) G A1:ADM,KIL
S DIC="^FHPT(FHDFN,""A"",",DIC(0)="EQM" D ^DIC G:Y<1 A0 S ADM=+Y
A1 S ADTE=$P($G(^DGPM(ADM,0)),"^",1),DSCH=$P($G(^DGPM(ADM,0)),"^",17) I DSCH S Z1=$G(^DGPM(DSCH,0)),MV=$P(Z1,"^",18),DSCH=$S("^13^42^43^45^46^"[("^"_MV_"^"):$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",14),1:$P(Z1,"^",1))
D1 S %DT="AEPTX",%DT("A")="Starting Date: FIRST// " W ! D ^%DT S:$D(DTOUT) X="^" G:X[U KIL S:X="" Y=ADTE G:Y<0 D1 S SDT=+Y
I SDT\1'<DT W *7," [Must Start before Today!] " G D1
I SDT,SDT<ADTE W *7," [Must not be before Admission!]" G D1
D2 S %DT="AEPTX",%DT("A")="Ending Date: LAST// " D ^%DT S:$D(DTOUT) X="^" G:X[U KIL S:X="" Y=DSCH G:Y<0 D2 S EDT=+Y
I EDT\1>DT W *7," [Greater than Today?] " G D1
I EDT,EDT<SDT W *7," [Must not be before Starting Date!] " G D1
I EDT,DSCH,EDT>DSCH W *7,!?24," [Must not exceed the length of stay of this admission!] " G D1
P0 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q0^FHASN5",FHLST="FHDFN^DFN^PID^ADM^EDT^SDT^ADTE^WARD^DSCH" D EN2^FH G KIL
U IO D Q0 D ^%ZISC K %ZIS,IOP G FHASN5
Q0 D NOW^%DTC S NOW=% S PG=0,Y=$G(^DPT(DFN,0)),NAM=$P(Y,"^",1)
K ^TMP($J,"SH") S (ANS,LN,RM)="",$P(LN,"-",80)="",SDT=9999999-SDT,ZZ=EDT#1,EDT=$S(EDT:9999999-$S(ZZ:EDT,1:(EDT+.3)),1:EDT)
I ADM S Y=$G(^FHPT(FHDFN,"A",ADM,0)),WARD=$P(Y,"^",8),WARD=$P($G(^FH(119.6,+WARD,0)),"^",1),RM=$P(Y,"^",9),RM=$P($G(^DG(405.4,+RM,0)),"^",1)
D HDR F X5=EDT:0 S X5=$O(^FHPT(FHDFN,"S",X5)) Q:X5<1!(X5>SDT) S X4=$G(^(X5,0)) I X4'="" S X2=9999999-X5,^TMP($J,"SH",X2,0)=X4
I $O(^TMP($J,"SH",0))<1 W *7,!,"No Status on file on this Admission." G KIL
F X5=0:0 S X5=$O(^TMP($J,"SH",X5)) Q:X5<1 S X4=$G(^(X5,0)) D LP Q:ANS="^"
KIL K ^TMP($J,"SH") G KILL^XUSCLEAN
LP ; Print History list
D:$Y'<(IOSL-3) HD Q:ANS="^"
S STS=$P(X4,"^",2),TIT=$S(STS=1:"I ",STS=2:"II ",STS=3:"III",STS=4:"IV ",1:"V ")_" "_$S(STS<5:$P($G(^FH(115.4,+STS,0)),"^",3),1:"UNCLASSIFIED") W !?2,TIT
W ?35 S DTP=$P(X4,"^",1) D DTP^FH W DTP
S Y=$P(X4,"^",3) W ?55,$E($P($G(^VA(200,+Y,0)),"^",1),1,25)
Q
HD ; Check for end of page
I IOST?1"C".E W:$X>1 ! W *7 K DIR S DIR(0)="E" D ^DIR I 'Y S ANS="^" Q
HDR ; Heading for the Nutrition Status History
W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
W ! W:PID'="" PID W ?17,NAM S DTP=NOW D DTP^FH W ?53,DTP,?72,"Page ",PG,!
I ADM W:WARD'="" ?17,"WARD ",WARD W:RM'="" ?53,"RM ",RM
W !,LN,!?15,"N U T R I T I O N S T A T U S H I S T O R Y",!!
W ?2,"Status Level",?35,"Date Entered",?55,"Clinician Who Entered",! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASN5 3197 printed Sep 23, 2025@19:23:05 Page 2
FHASN5 ; HISC/NCA - Print Patient's Nutrition Status History ;12/13/93 12:58
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN2 ; Select Patient to print
+1 SET ALL=1
DO ^FHDPA
if 'DFN
GOTO KIL
if WARD=""
SET (ADM,ADTE,DSCH)=""
+2 IF $PIECE($GET(^DPT(DFN,.35)),"^",1)
WRITE *7,!!?5,"Patient has expired."
GOTO EN2
+3 SET X5=$ORDER(^FHPT(FHDFN,"S",0))
IF X5=""
WRITE *7,!!?5,"No status on file for this patient."
GOTO EN2
+4 IF $ORDER(^FHPT(FHDFN,"A",0))<1
GOTO D1
+5 SET DIC="^FHPT(FHDFN,""A"","
SET DIC(0)="Q"
SET DA=FHDFN
SET X="??"
DO ^DIC
+6 SET WARD=$GET(^DPT(DFN,.1))
A0 WRITE !!,"Select ADMISSION",$SELECT(WARD'="":" (or C for CURRENT)",1:""),": "
READ X:DTIME
if '$TEST!(X["^")
GOTO KIL
if X="c"
DO TR^FH
IF X=""
if WARD=""
GOTO D1
GOTO KIL
+1 IF WARD'=""
IF X="C"
SET ADM=$GET(^DPT("CN",WARD,DFN))
if ADM
GOTO A1
GOTO KIL
+2 SET DIC="^FHPT(FHDFN,""A"","
SET DIC(0)="EQM"
DO ^DIC
if Y<1
GOTO A0
SET ADM=+Y
A1 SET ADTE=$PIECE($GET(^DGPM(ADM,0)),"^",1)
SET DSCH=$PIECE($GET(^DGPM(ADM,0)),"^",17)
IF DSCH
SET Z1=$GET(^DGPM(DSCH,0))
SET MV=$PIECE(Z1,"^",18)
SET DSCH=$SELECT("^13^42^43^45^46^"[("^"_MV_"^"):$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",14),1:$PIECE(Z1,"^",1))
D1 SET %DT="AEPTX"
SET %DT("A")="Starting Date: FIRST// "
WRITE !
DO ^%DT
if $DATA(DTOUT)
SET X="^"
if X[U
GOTO KIL
if X=""
SET Y=ADTE
if Y<0
GOTO D1
SET SDT=+Y
+1 IF SDT\1'<DT
WRITE *7," [Must Start before Today!] "
GOTO D1
+2 IF SDT
IF SDT<ADTE
WRITE *7," [Must not be before Admission!]"
GOTO D1
D2 SET %DT="AEPTX"
SET %DT("A")="Ending Date: LAST// "
DO ^%DT
if $DATA(DTOUT)
SET X="^"
if X[U
GOTO KIL
if X=""
SET Y=DSCH
if Y<0
GOTO D2
SET EDT=+Y
+1 IF EDT\1>DT
WRITE *7," [Greater than Today?] "
GOTO D1
+2 IF EDT
IF EDT<SDT
WRITE *7," [Must not be before Starting Date!] "
GOTO D1
+3 IF EDT
IF DSCH
IF EDT>DSCH
WRITE *7,!?24," [Must not exceed the length of stay of this admission!] "
GOTO D1
P0 KILL IOP
SET %ZIS="MQ"
SET %ZIS("B")="HOME"
WRITE !
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+1 IF $DATA(IO("Q"))
SET FHPGM="Q0^FHASN5"
SET FHLST="FHDFN^DFN^PID^ADM^EDT^SDT^ADTE^WARD^DSCH"
DO EN2^FH
GOTO KIL
+2 USE IO
DO Q0
DO ^%ZISC
KILL %ZIS,IOP
GOTO FHASN5
Q0 DO NOW^%DTC
SET NOW=%
SET PG=0
SET Y=$GET(^DPT(DFN,0))
SET NAM=$PIECE(Y,"^",1)
+1 KILL ^TMP($JOB,"SH")
SET (ANS,LN,RM)=""
SET $PIECE(LN,"-",80)=""
SET SDT=9999999-SDT
SET ZZ=EDT#1
SET EDT=$SELECT(EDT:9999999-$SELECT(ZZ:EDT,1:(EDT+.3)),1:EDT)
+2 IF ADM
SET Y=$GET(^FHPT(FHDFN,"A",ADM,0))
SET WARD=$PIECE(Y,"^",8)
SET WARD=$PIECE($GET(^FH(119.6,+WARD,0)),"^",1)
SET RM=$PIECE(Y,"^",9)
SET RM=$PIECE($GET(^DG(405.4,+RM,0)),"^",1)
+3 DO HDR
FOR X5=EDT:0
SET X5=$ORDER(^FHPT(FHDFN,"S",X5))
if X5<1!(X5>SDT)
QUIT
SET X4=$GET(^(X5,0))
IF X4'=""
SET X2=9999999-X5
SET ^TMP($JOB,"SH",X2,0)=X4
+4 IF $ORDER(^TMP($JOB,"SH",0))<1
WRITE *7,!,"No Status on file on this Admission."
GOTO KIL
+5 FOR X5=0:0
SET X5=$ORDER(^TMP($JOB,"SH",X5))
if X5<1
QUIT
SET X4=$GET(^(X5,0))
DO LP
if ANS="^"
QUIT
KIL KILL ^TMP($JOB,"SH")
GOTO KILL^XUSCLEAN
LP ; Print History list
+1 if $Y'<(IOSL-3)
DO HD
if ANS="^"
QUIT
+2 SET STS=$PIECE(X4,"^",2)
SET TIT=$SELECT(STS=1:"I ",STS=2:"II ",STS=3:"III",STS=4:"IV ",1:"V ")_" "_$SELECT(STS<5:$PIECE($GET(^FH(115.4,+STS,0)),"^",3),1:"UNCLASSIFIED")
WRITE !?2,TIT
+3 WRITE ?35
SET DTP=$PIECE(X4,"^",1)
DO DTP^FH
WRITE DTP
+4 SET Y=$PIECE(X4,"^",3)
WRITE ?55,$EXTRACT($PIECE($GET(^VA(200,+Y,0)),"^",1),1,25)
+5 QUIT
HD ; Check for end of page
+1 IF IOST?1"C".E
if $X>1
WRITE !
WRITE *7
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET ANS="^"
QUIT
HDR ; Heading for the Nutrition Status History
+1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
+2 WRITE !
if PID'=""
WRITE PID
WRITE ?17,NAM
SET DTP=NOW
DO DTP^FH
WRITE ?53,DTP,?72,"Page ",PG,!
+3 IF ADM
if WARD'=""
WRITE ?17,"WARD ",WARD
if RM'=""
WRITE ?53,"RM ",RM
+4 WRITE !,LN,!?15,"N U T R I T I O N S T A T U S H I S T O R Y",!!
+5 WRITE ?2,"Status Level",?35,"Date Entered",?55,"Clinician Who Entered",!
QUIT
