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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASXR 2400 printed Nov 22, 2024@16:57:23 Page 2
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
