- 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
- 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
