- FHASN6 ; HISC/NCA - List Inpats By Nutrition Status Level ;3/1/95 10:58
- ;;5.5;DIETETICS;**27**;Jan 28, 2005;Build 9
- EN2 ; Select Status to print
- K DIR S DIR(0)="SO^1:NORMAL;2:MILDLY COMPROMISED;3:MODERATELY COMPROMISED;4:SEVERELY COMPROMISED;5:UNCLASSIFIED",DIR("A")="Choose a Nutrition Status Level" D ^DIR G:$D(DIRUT)!($D(DIROUT)) KIL S STS=+Y
- F0 R !!,"Print by CLINICIAN or WARD? WARD// ",X:DTIME G:'$T!(X["^") KIL S:X="" X="W" D TR^FH I $P("CLINICIAN",X,1)'="",$P("WARD",X,1)'="" W *7," Answer with C or W" G F0
- S SRT=$E(X,1)
- L0 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) S FHPGM="Q0^FHASN6",FHLST="STS^SRT" D EN2^FH G KIL
- U IO D Q0 D ^%ZISC K %ZIS,IOP G FHASN6
- Q0 ; Process Screening
- K ^TMP($J)
- S TIT="Current Inpatients At Nutrition Status: ",ANS=""
- S TIT=TIT_$P("I,II,III,IV,V",",",+STS)_" "_$S(STS<5:$P($G(^FH(115.4,+STS,0)),"^",2),1:"Unclassified")
- F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1'>0 D W1 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",W1,FHDFN)) Q:ADM<1 D Q1
- D P0
- KIL K ^TMP($J) G KILL^XUSCLEAN
- Q1 ; Tabulate status
- S DTE="",X5=$O(^FHPT(FHDFN,"S",0)) G:X5="" Q2 S X5=^(X5,0)
- I $P(X5,"^",1)<$S($D(^FHPT(FHDFN,"A",ADM,0)):$P(^(0),"^",1),1:9999999) G Q2
- S S1=$P(X5,"^",2),D1=$P(X5,"^",3),DTE=$P(X5,"^",1) I S1,S1<5 G Q3
- Q2 ; Unclassified
- S S1=5,D1=WD
- Q3 ; Set Classification
- S XX=$S(SRT="W":W1,1:D1)
- Q4 ; Store Status
- I S1'=STS Q
- D PATNAME^FHOMUTL I DFN="" Q
- S X2=$G(^FHPT(FHDFN,"A",ADM,0)),RM=$P(X2,"^",9),RM=$P($G(^DG(405.4,+RM,0)),"^",1),X3=$G(^DPT(DFN,0)),PAT=$E($P(X3,"^",1),1,23) D PID^FHDPA
- D P1
- Q
- P0 ; Print summary
- D NOW^%DTC S DTP=% D DTP^FH S NOW=DTP,PG=0,LN="",$P(LN,"-",80)="" D HDR
- I '$D(^TMP($J)) W !!,"There are No current inpatients with ",$S(STS<5:$P($G(^FH(115.4,+STS,0)),"^",2),1:"Unclassified")," nutrition status.",!! Q
- W ! S NAM="" F W1=0:0 S NAM=$O(^TMP($J,NAM)) Q:NAM=""!(ANS="^") W NAM F W2=0:0 S W2=$O(^TMP($J,NAM,W2)) Q:W2<1!(ANS="^") S PAT="" D P2
- W ! Q
- P1 I SRT="W" S NAM=$E($P($G(^FH(119.6,+XX,0)),"^",1),1,15) D P15
- E D
- . F X1=0:0 S X1=$O(^FH(119.6,W1,2,X1)) Q:'X1>0 D
- .. S X2=$G(^FH(119.6,W1,2,X1,0)) Q:X2=""
- ..S NAM=$E($P($G(^VA(200,+X2,0)),"^",1),1,26)
- .. D P15
- . K X1,X2
- Q
- P15 Q:NAM="" S:DTE="" DTE=$P(^FHPT(FHDFN,"A",ADM,0),"^",1) S ^TMP($J,NAM,DTE,PAT)=BID_"^"_$E(RM,1,10) Q
- P2 S PAT=$O(^TMP($J,NAM,W2,PAT)) Q:PAT="" S D1=$G(^(PAT))
- D:$Y'<(IOSL-3) HD Q:ANS="^"
- S BID=$P(D1,"^",1),RM=$P(D1,"^",2)
- W:SRT="W" ?15,RM W ?28,PAT,?53,BID,?62 S DTP=W2 D DTP^FH W DTP,!!
- G P2
- W1 ; Get ward parameters
- S WD=$P($G(^FH(119.6,W1,0)),"^",2) S:'WD WD=0 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 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !,NOW,?72,"Page ",PG,!!?(80-$L(TIT)\2),TIT
- W !!,$S(SRT="W":"Ward Room",1:"Clinician"),?28,"Patient",?53,"ID#",?62,"Date Entered",!,LN,! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASN6 2956 printed Feb 18, 2025@23:13:29 Page 2
- FHASN6 ; HISC/NCA - List Inpats By Nutrition Status Level ;3/1/95 10:58
- +1 ;;5.5;DIETETICS;**27**;Jan 28, 2005;Build 9
- EN2 ; Select Status to print
- +1 KILL DIR
- SET DIR(0)="SO^1:NORMAL;2:MILDLY COMPROMISED;3:MODERATELY COMPROMISED;4:SEVERELY COMPROMISED;5:UNCLASSIFIED"
- SET DIR("A")="Choose a Nutrition Status Level"
- DO ^DIR
- if $DATA(DIRUT)!($DATA(DIROUT))
- GOTO KIL
- SET STS=+Y
- F0 READ !!,"Print by CLINICIAN or WARD? WARD// ",X:DTIME
- if '$TEST!(X["^")
- GOTO KIL
- if X=""
- SET X="W"
- DO TR^FH
- IF $PIECE("CLINICIAN",X,1)'=""
- IF $PIECE("WARD",X,1)'=""
- WRITE *7," Answer with C or W"
- GOTO F0
- +1 SET SRT=$EXTRACT(X,1)
- L0 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^FHASN6"
- SET FHLST="STS^SRT"
- DO EN2^FH
- GOTO KIL
- +2 USE IO
- DO Q0
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO FHASN6
- Q0 ; Process Screening
- +1 KILL ^TMP($JOB)
- +2 SET TIT="Current Inpatients At Nutrition Status: "
- SET ANS=""
- +3 SET TIT=TIT_$PIECE("I,II,III,IV,V",",",+STS)_" "_$SELECT(STS<5:$PIECE($GET(^FH(115.4,+STS,0)),"^",2),1:"Unclassified")
- +4 FOR W1=0:0
- SET W1=$ORDER(^FH(119.6,W1))
- if W1'>0
- QUIT
- DO W1
- FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
- if FHDFN<1
- QUIT
- SET ADM=$GET(^FHPT("AW",W1,FHDFN))
- if ADM<1
- QUIT
- DO Q1
- +5 DO P0
- KIL KILL ^TMP($JOB)
- GOTO KILL^XUSCLEAN
- Q1 ; Tabulate status
- +1 SET DTE=""
- SET X5=$ORDER(^FHPT(FHDFN,"S",0))
- if X5=""
- GOTO Q2
- SET X5=^(X5,0)
- +2 IF $PIECE(X5,"^",1)<$SELECT($DATA(^FHPT(FHDFN,"A",ADM,0)):$PIECE(^(0),"^",1),1:9999999)
- GOTO Q2
- +3 SET S1=$PIECE(X5,"^",2)
- SET D1=$PIECE(X5,"^",3)
- SET DTE=$PIECE(X5,"^",1)
- IF S1
- IF S1<5
- GOTO Q3
- Q2 ; Unclassified
- +1 SET S1=5
- SET D1=WD
- Q3 ; Set Classification
- +1 SET XX=$SELECT(SRT="W":W1,1:D1)
- Q4 ; Store Status
- +1 IF S1'=STS
- QUIT
- +2 DO PATNAME^FHOMUTL
- IF DFN=""
- QUIT
- +3 SET X2=$GET(^FHPT(FHDFN,"A",ADM,0))
- SET RM=$PIECE(X2,"^",9)
- SET RM=$PIECE($GET(^DG(405.4,+RM,0)),"^",1)
- SET X3=$GET(^DPT(DFN,0))
- SET PAT=$EXTRACT($PIECE(X3,"^",1),1,23)
- DO PID^FHDPA
- +4 DO P1
- +5 QUIT
- P0 ; Print summary
- +1 DO NOW^%DTC
- SET DTP=%
- DO DTP^FH
- SET NOW=DTP
- SET PG=0
- SET LN=""
- SET $PIECE(LN,"-",80)=""
- DO HDR
- +2 IF '$DATA(^TMP($JOB))
- WRITE !!,"There are No current inpatients with ",$SELECT(STS<5:$PIECE($GET(^FH(115.4,+STS,0)),"^",2),1:"Unclassified")," nutrition status.",!!
- QUIT
- +3 WRITE !
- SET NAM=""
- FOR W1=0:0
- SET NAM=$ORDER(^TMP($JOB,NAM))
- if NAM=""!(ANS="^")
- QUIT
- WRITE NAM
- FOR W2=0:0
- SET W2=$ORDER(^TMP($JOB,NAM,W2))
- if W2<1!(ANS="^")
- QUIT
- SET PAT=""
- DO P2
- +4 WRITE !
- QUIT
- P1 IF SRT="W"
- SET NAM=$EXTRACT($PIECE($GET(^FH(119.6,+XX,0)),"^",1),1,15)
- DO P15
- +1 IF '$TEST
- Begin DoDot:1
- +2 FOR X1=0:0
- SET X1=$ORDER(^FH(119.6,W1,2,X1))
- if 'X1>0
- QUIT
- Begin DoDot:2
- +3 SET X2=$GET(^FH(119.6,W1,2,X1,0))
- if X2=""
- QUIT
- +4 SET NAM=$EXTRACT($PIECE($GET(^VA(200,+X2,0)),"^",1),1,26)
- +5 DO P15
- End DoDot:2
- +6 KILL X1,X2
- End DoDot:1
- +7 QUIT
- P15 if NAM=""
- QUIT
- if DTE=""
- SET DTE=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",1)
- SET ^TMP($JOB,NAM,DTE,PAT)=BID_"^"_$EXTRACT(RM,1,10)
- QUIT
- P2 SET PAT=$ORDER(^TMP($JOB,NAM,W2,PAT))
- if PAT=""
- QUIT
- SET D1=$GET(^(PAT))
- +1 if $Y'<(IOSL-3)
- DO HD
- if ANS="^"
- QUIT
- +2 SET BID=$PIECE(D1,"^",1)
- SET RM=$PIECE(D1,"^",2)
- +3 if SRT="W"
- WRITE ?15,RM
- WRITE ?28,PAT,?53,BID,?62
- SET DTP=W2
- DO DTP^FH
- WRITE DTP,!!
- +4 GOTO P2
- W1 ; Get ward parameters
- +1 SET WD=$PIECE($GET(^FH(119.6,W1,0)),"^",2)
- if 'WD
- SET WD=0
- 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 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- WRITE !,NOW,?72,"Page ",PG,!!?(80-$LENGTH(TIT)\2),TIT
- +1 WRITE !!,$SELECT(SRT="W":"Ward Room",1:"Clinician"),?28,"Patient",?53,"ID#",?62,"Date Entered",!,LN,!
- QUIT