- FHASXR ; HISC/REL - Print Screening ;5/10/93 15:10
- ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- F0 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
- 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
- G P0:X?1"P".E,W0:X?1"W".E I X?1"A".E S (DFN,ADM,WARD)="" G W1
- D0 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
- W0 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)=""
- W1 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
- 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
- G P1
- P0 S ALL=1 D ^FHDPA G:'DFN KIL S TIM=""
- I $P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KIL
- P1 S NP=$P($G(^FH(119.9,1,3)),"^",3) I NP'="A" G P3
- P2 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
- P3 S NP=$S(NP?1"Y".E:1,1:0)
- I NP=0 S FHNUM=9999 G L0
- P4 ;ask user for how far to print encounter, 1 yr back as default.
- W ! S %DT="AEP",%DT("A")="Print Dietetics Encounter since Date: "
- S %DT("B")="T-365",%DT(0)="-T" D ^%DT K %DT Q:X["^"!$D(DTOUT)
- S FHET=Y
- D MONUM^FHOMUTL I FHNUM="" Q
- 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^FHASXR",FHLST="DFN^ADM^WARD^TIM^NP^FHNUM" D EN2^FH G KIL
- U IO D Q0 D ^%ZISC K %ZIS,IOP G KIL
- Q0 ; Process Screening
- I DFN S FHZ115="P"_DFN D CHECK^FHOMDPA Q:FHDFN="" D ^FHASXR1 Q
- G Q2:WARD<0,Q3:WARD=""
- Q1 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="^"
- Q
- Q2 S CF=-WARD,WRD=""
- 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
- Q
- Q3 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
- Q
- KIL G KILL^XUSCLEAN
- FHASXR ; HISC/REL - Print Screening ;5/10/93 15:10
- +1 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- F0 READ !!,"Print by PATIENT or COMMUNICATION OFFICE or ALL or WARD? WARD// ",X:DTIME
- IF '$TEST!(X["^")
- GOTO KIL
- IF X=""
- SET X="W"
- DO TR^FH
- +1 IF $PIECE("PATIENT",X,1)'=""
- IF $PIECE("WARD",X,1)'=""
- IF $PIECE("COMMUNICATION OFFICE",X,1)'=""
- IF $PIECE("ALL",X,1)'=""
- WRITE *7," Answer with P or C or A or W"
- GOTO F0
- +2 IF X?1"P".E
- GOTO P0
- IF X?1"W".E
- GOTO W0
- IF X?1"A".E
- SET (DFN,ADM,WARD)=""
- GOTO W1
- D0 KILL DIC
- SET DIC="^FH(119.73,"
- SET DIC("A")="Select COMMUNICATION OFFICE: "
- SET DIC(0)="AEQM"
- WRITE !
- DO ^DIC
- KILL DIC
- IF "^"[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO D0
- SET WARD=-Y
- SET (DFN,ADM)=""
- GOTO W1
- W0 KILL DIC
- SET DIC("A")="Select DIETETIC WARD: "
- SET DIC="^FH(119.6,"
- SET DIC(0)="AEQM"
- WRITE !
- DO ^DIC
- KILL DIC
- IF "^"[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO W0
- SET WARD=+Y
- SET (DFN,ADM)=""
- W1 READ !!,"Admissions since Date/Time: ",X:DTIME
- IF '$TEST!("^"[X)
- GOTO KIL
- SET %DT="EXTS"
- SET %DT(0)="-NOW"
- DO ^%DT
- KILL %DT
- IF Y<1
- GOTO W1
- SET TIM=Y
- +1 DO NOW^%DTC
- SET X1=%\1
- SET X2=-5
- DO C^%DTC
- IF TIM<X
- WRITE " [ DATE CANNOT BE MORE THAN 5 DAYS IN PAST ]"
- GOTO W1
- +2 GOTO P1
- P0 SET ALL=1
- DO ^FHDPA
- IF 'DFN
- GOTO KIL
- SET TIM=""
- +1 IF $PIECE($GET(^DPT(DFN,.35)),"^",1)
- WRITE *7,!!?5," [ Patient has expired. ]"
- GOTO KIL
- P1 SET NP=$PIECE($GET(^FH(119.9,1,3)),"^",3)
- IF NP'="A"
- GOTO P3
- P2 READ !!,"Include Nutrition Profiles? (Y/N): ",NP:DTIME
- IF '$TEST!(NP["^")
- GOTO KIL
- IF NP=""
- SET NP="^"
- SET X=NP
- DO TR^FH
- SET NP=X
- IF $PIECE("YES",NP,1)'=""
- IF $PIECE("NO",NP,1)'=""
- WRITE *7,!," Answer YES or NO"
- GOTO P2
- P3 SET NP=$SELECT(NP?1"Y".E:1,1:0)
- +1 IF NP=0
- SET FHNUM=9999
- GOTO L0
- P4 ;ask user for how far to print encounter, 1 yr back as default.
- +1 WRITE !
- SET %DT="AEP"
- SET %DT("A")="Print Dietetics Encounter since Date: "
- +2 SET %DT("B")="T-365"
- SET %DT(0)="-T"
- DO ^%DT
- KILL %DT
- IF X["^"!$DATA(DTOUT)
- QUIT
- +3 SET FHET=Y
- +4 DO MONUM^FHOMUTL
- IF FHNUM=""
- QUIT
- 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^FHASXR"
- SET FHLST="DFN^ADM^WARD^TIM^NP^FHNUM"
- DO EN2^FH
- GOTO KIL
- +2 USE IO
- DO Q0
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- Q0 ; Process Screening
- +1 IF DFN
- SET FHZ115="P"_DFN
- DO CHECK^FHOMDPA
- IF FHDFN=""
- QUIT
- DO ^FHASXR1
- QUIT
- +2 IF WARD<0
- GOTO Q2
- IF WARD=""
- GOTO Q3
- Q1 FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("AW",WARD,FHDFN))
- IF FHDFN=""
- QUIT
- SET ADM=$GET(^FHPT("AW",WARD,FHDFN))
- SET X=$PIECE($GET(^DGPM(+ADM,0)),"^",1)
- IF X'<TIM
- DO PATNAME^FHOMUTL
- DO ^FHASXR1
- IF $EXTRACT(IOST,1,2)'="C-"
- WRITE @IOF
- IF ANS="^"
- QUIT
- +1 QUIT
- Q2 SET CF=-WARD
- SET WRD=""
- +1 FOR NN=0:0
- SET WRD=$ORDER(^FH(119.6,"B",WRD))
- IF WRD=""
- QUIT
- SET WARD=$ORDER(^FH(119.6,"B",WRD,0))
- IF $PIECE($GET(^FH(119.6,+WARD,0)),"^",8)=CF
- DO Q1
- +2 QUIT
- Q3 SET WRD=""
- FOR NN=0:0
- SET WRD=$ORDER(^FH(119.6,"B",WRD))
- IF WRD=""
- QUIT
- SET WARD=$ORDER(^(WRD,0))
- IF 'WARD
- QUIT
- DO Q1
- +1 QUIT
- KIL GOTO KILL^XUSCLEAN
