source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHASXR.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.3 KB
Line 
1FHASXR ; HISC/REL - Print Screening ;5/10/93 15:10
2 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
3F0 R !!,"Print by PATIENT or COMMUNICATION OFFICE or ALL or WARD? WARD// ",X:DTIME G:'$T!(X["^") KIL S:X="" X="W" D TR^FH
4 I $P("PATIENT",X,1)'="",$P("WARD",X,1)'="",$P("COMMUNICATION OFFICE",X,1)'="",$P("ALL",X,1)'="" W *7," Answer with P or C or A or W" G F0
5 G P0:X?1"P".E,W0:X?1"W".E I X?1"A".E S (DFN,ADM,WARD)="" G W1
6D0 K DIC S DIC="^FH(119.73,",DIC("A")="Select COMMUNICATION OFFICE: ",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),D0:Y<1 S WARD=-Y,(DFN,ADM)="" G W1
7W0 K DIC S DIC("A")="Select DIETETIC WARD: ",DIC="^FH(119.6,",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),W0:Y<1 S WARD=+Y,(DFN,ADM)=""
8W1 R !!,"Admissions since Date/Time: ",X:DTIME G:'$T!("^"[X) KIL S %DT="EXTS",%DT(0)="-NOW" D ^%DT K %DT G:Y<1 W1 S TIM=Y
9 D NOW^%DTC S X1=%\1,X2=-5 D C^%DTC I TIM<X W " [ DATE CANNOT BE MORE THAN 5 DAYS IN PAST ]" G W1
10 G P1
11P0 S ALL=1 D ^FHDPA G:'DFN KIL S TIM=""
12 I $P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KIL
13P1 S NP=$P($G(^FH(119.9,1,3)),"^",3) I NP'="A" G P3
14P2 R !!,"Include Nutrition Profiles? (Y/N): ",NP:DTIME G:'$T!(NP["^") KIL S:NP="" NP="^" S X=NP D TR^FH S NP=X I $P("YES",NP,1)'="",$P("NO",NP,1)'="" W *7,!," Answer YES or NO" G P2
15P3 S NP=$S(NP?1"Y".E:1,1:0)
16 I NP=0 S FHNUM=9999 G L0
17P4 ;ask user for how far to print encounter, 1 yr back as default.
18 W ! S %DT="AEP",%DT("A")="Print Dietetics Encounter since Date: "
19 S %DT("B")="T-365",%DT(0)="-T" D ^%DT K %DT Q:X["^"!$D(DTOUT)
20 S FHET=Y
21 D MONUM^FHOMUTL I FHNUM="" Q
22L0 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
23 I $D(IO("Q")) S FHPGM="Q0^FHASXR",FHLST="DFN^ADM^WARD^TIM^NP^FHNUM" D EN2^FH G KIL
24 U IO D Q0 D ^%ZISC K %ZIS,IOP G KIL
25Q0 ; Process Screening
26 I DFN S FHZ115="P"_DFN D CHECK^FHOMDPA Q:FHDFN="" D ^FHASXR1 Q
27 G Q2:WARD<0,Q3:WARD=""
28Q1 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",WARD,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",WARD,FHDFN)),X=$P($G(^DGPM(+ADM,0)),"^",1) I X'<TIM D PATNAME^FHOMUTL,^FHASXR1 W:$E(IOST,1,2)'="C-" @IOF Q:ANS="^"
29 Q
30Q2 S CF=-WARD,WRD=""
31 F NN=0:0 S WRD=$O(^FH(119.6,"B",WRD)) Q:WRD="" S WARD=$O(^FH(119.6,"B",WRD,0)) I $P($G(^FH(119.6,+WARD,0)),"^",8)=CF D Q1
32 Q
33Q3 S WRD="" F NN=0:0 S WRD=$O(^FH(119.6,"B",WRD)) Q:WRD="" S WARD=$O(^(WRD,0)) Q:'WARD D Q1
34 Q
35KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.