- FHASN1 ; HISC/REL - Print Status Summary ;5/14/93 10:12
- ;;5.5;DIETETICS;;Jan 28, 2005
- 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^FHASN1",FHLST="SRT" D EN2^FH G KIL
- U IO D Q0 D ^%ZISC K %ZIS,IOP G KIL
- Q0 ; Process Screening
- K S
- 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
- G P0
- Q1 ; Tabulate status
- S 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) I S1,S1<5 G Q3
- Q2 ; Unclassified
- S S1=5,D1=WD
- Q3 ; Set Classification
- S X=$S(SRT="W":W1,1:D1) S:'$D(S(X)) S(X)="" S $P(S(X),"^",S1)=$P(S(X),"^",S1)+1 Q
- P0 ; Print summary
- D NOW^%DTC S (NOW,DTP)=% D DTP^FH S PG=0,LN="",$P(LN,"-",66)="" D HDR
- K ^TMP($J) F W1=0:0 S W1=$O(S(W1)) Q:W1="" D P1
- S NAM="" F W1=0:0 S NAM=$O(^TMP($J,NAM)) Q:NAM="" S D1=^(NAM) D P2
- W ! Q
- P1 I SRT="W" S NAM=$P($G(^FH(119.6,W1,0)),"^",1)
- E S NAM=$P($G(^VA(200,W1,0)),"^",1)
- Q:NAM="" S ^TMP($J,NAM_"~"_W1)=S(W1) Q
- P2 D:$Y>(IOSL-8) HDR W !?7,$P(NAM,"~",1),?37 F K=1:1:5 S X=$P(D1,"^",K) W $J(X,7)
- Q
- W1 ; Get ward parameters
- S WD=$P($G(^FH(119.6,W1,0)),"^",2) S:'WD WD=0 Q
- HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?16,"N U T R I T I O N S T A T U S S U M M A R Y",?73,"Page ",PG
- W !!?(80-$L(DTP)\2),DTP
- W !!?7,$S(SRT="C":"CLINICIAN",1:"WARD"),?43,"I II III IV UNC",!?7,LN,! Q
- KIL K ^TMP($J) G KILL^XUSCLEAN
- FHASN1 ; HISC/REL - Print Status Summary ;5/14/93 10:12
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- 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^FHASN1"
- SET FHLST="SRT"
- DO EN2^FH
- GOTO KIL
- +2 USE IO
- DO Q0
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- Q0 ; Process Screening
- +1 KILL S
- +2 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
- +3 GOTO P0
- Q1 ; Tabulate status
- +1 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)
- IF S1
- IF S1<5
- GOTO Q3
- Q2 ; Unclassified
- +1 SET S1=5
- SET D1=WD
- Q3 ; Set Classification
- +1 SET X=$SELECT(SRT="W":W1,1:D1)
- IF '$DATA(S(X))
- SET S(X)=""
- SET $PIECE(S(X),"^",S1)=$PIECE(S(X),"^",S1)+1
- QUIT
- P0 ; Print summary
- +1 DO NOW^%DTC
- SET (NOW,DTP)=%
- DO DTP^FH
- SET PG=0
- SET LN=""
- SET $PIECE(LN,"-",66)=""
- DO HDR
- +2 KILL ^TMP($JOB)
- FOR W1=0:0
- SET W1=$ORDER(S(W1))
- IF W1=""
- QUIT
- DO P1
- +3 SET NAM=""
- FOR W1=0:0
- SET NAM=$ORDER(^TMP($JOB,NAM))
- IF NAM=""
- QUIT
- SET D1=^(NAM)
- DO P2
- +4 WRITE !
- QUIT
- P1 IF SRT="W"
- SET NAM=$PIECE($GET(^FH(119.6,W1,0)),"^",1)
- +1 IF '$TEST
- SET NAM=$PIECE($GET(^VA(200,W1,0)),"^",1)
- +2 IF NAM=""
- QUIT
- SET ^TMP($JOB,NAM_"~"_W1)=S(W1)
- QUIT
- P2 IF $Y>(IOSL-8)
- DO HDR
- WRITE !?7,$PIECE(NAM,"~",1),?37
- FOR K=1:1:5
- SET X=$PIECE(D1,"^",K)
- WRITE $JUSTIFY(X,7)
- +1 QUIT
- W1 ; Get ward parameters
- +1 SET WD=$PIECE($GET(^FH(119.6,W1,0)),"^",2)
- IF 'WD
- SET WD=0
- QUIT
- HDR IF '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- WRITE !?16,"N U T R I T I O N S T A T U S S U M M A R Y",?73,"Page ",PG
- +1 WRITE !!?(80-$LENGTH(DTP)\2),DTP
- +2 WRITE !!?7,$SELECT(SRT="C":"CLINICIAN",1:"WARD"),?43,"I II III IV UNC",!?7,LN,!
- QUIT
- KIL KILL ^TMP($JOB)
- GOTO KILL^XUSCLEAN
