FHDCR1 ; HISC/REL/NCA/RVD - Diet Cards ;4/21/95 10:10
;;5.5;DIETETICS;;Jan 28, 2005
F0 R !!,"Print by PATIENT or COMMUNICATION OFFICE or LOCATION or ALL? COMM// ",X:DTIME G:'$T!(X["^") KIL S:X="" X="C" D TR^FH
I $P("PATIENT",X,1)'="",$P("LOCATION",X,1)'="",$P("COMMUNICATION OFFICE",X,1)'="",$P("ALL",X,1)'="" W *7,!," Answer with P or C or A or L" G F0
G P0:X?1"P".E,W0:X?1"L".E I X?1"A".E S (DFN,FHP,W1)="" G S0
S FHP=$O(^FH(119.73,0)) I FHP'<1,$O(^FH(119.73,FHP))<1 S (DFN,W1)="" G S0
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 FHP=+Y,(DFN,W1)="" G S0
W0 K DIC S DIC("A")="Select DIETETIC LOCATION: ",DIC="^FH(119.6,",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),W0:Y<1 S W1=+Y,(DFN,FHP)="" G S0
P0 S FHALL=1 D ^FHOMDPA G:'FHDFN KIL S (FHP,W1)="",UPD=0,SORT="R" G F1
I $G(DFN),($P($G(^DPT(DFN,.35)),"^",1)) W *7,!!?5," [ Patient has expired. ]" G KIL
S0 R !!,"Sort Patients: (A=Alphabetically R=Room-Bed) R// ",SORT:DTIME G:'$T!(SORT["^") KIL S:SORT="" SORT="R" I "ar"[SORT S X=SORT D TR^FH S SORT=X
I SORT'?1U!("AR"'[SORT) W *7," Enter A or R" G S0
F1 S %DT("A")="Select Date: ",%DT="AEFX",%DT("B")="TODAY",%DT(0)=DT W ! D ^%DT G KIL:"^"[X!$D(DTOUT),F1:Y<1 S (X1,D1)=+Y
D E1^FHPRC1 S FLG=0 I FHCY<1 S FLG=1,(FHDA,FHX1)="" G R0
I '$D(^FH(116,FHCY,"DA",FHDA,0)) S FLG=1,(FHDA,FHX1)=""
R0 R !!,"Print Three Per Page? N//",X:DTIME G:'$T!(X="^") KIL S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G R0
S TPP=$E(X,1),TPP=TPP="Y" I 'TPP S MEAL="A",FLG=1,(FHDA,FHX1)="" G P1
R1 R !!,"Select MEAL (B,N,E,or ALL): ",MEAL:DTIME G:'$T!("^"[MEAL) KIL S X=MEAL D TR^FH S MEAL=X S:$P("ALL",MEAL,1)="" MEAL="A"
I "BNEA"'[MEAL!(MEAL'?1U) W *7,!,"Select B for Breakfast, N for Noon, or E for Evening or ALL for all meals" G R1
P1 I FLG G L0:DFN,R2
S FHDA=^FH(116,FHCY,"DA",FHDA,0)
I $D(^FH(116.3,D1,0)) S X=^(0) F LL=2:1:4 I $P(X,"^",LL) S $P(FHDA,"^",LL)=$P(X,"^",LL)
S FHX1=FHDA G:DFN L0
R2 R !!,"Print Only Ones With Order Changes related to the Diet Card? N // ",X:DTIME G:'$T!(X="^") KIL S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G R2
S UPD=X?1"Y".E
L0 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="B1^FHDCR1A",FHLST="D1^MEAL^FHX1^FHP^FLG^W1^FHDFN^DFN^UPD^TPP^SORT" D EN2^FH G KIL
U IO D B1^FHDCR1A D ^%ZISC K %ZIS,IOP G KIL
KIL K ^TMP($J) G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHDCR1 2541 printed Apr 09, 2024@20:55:55 Page 2
FHDCR1 ; HISC/REL/NCA/RVD - Diet Cards ;4/21/95 10:10
+1 ;;5.5;DIETETICS;;Jan 28, 2005
F0 READ !!,"Print by PATIENT or COMMUNICATION OFFICE or LOCATION or ALL? COMM// ",X:DTIME
if '$TEST!(X["^")
GOTO KIL
if X=""
SET X="C"
DO TR^FH
+1 IF $PIECE("PATIENT",X,1)'=""
IF $PIECE("LOCATION",X,1)'=""
IF $PIECE("COMMUNICATION OFFICE",X,1)'=""
IF $PIECE("ALL",X,1)'=""
WRITE *7,!," Answer with P or C or A or L"
GOTO F0
+2 if X?1"P".E
GOTO P0
if X?1"L".E
GOTO W0
IF X?1"A".E
SET (DFN,FHP,W1)=""
GOTO S0
+3 SET FHP=$ORDER(^FH(119.73,0))
IF FHP'<1
IF $ORDER(^FH(119.73,FHP))<1
SET (DFN,W1)=""
GOTO S0
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 FHP=+Y
SET (DFN,W1)=""
GOTO S0
W0 KILL DIC
SET DIC("A")="Select DIETETIC LOCATION: "
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 W1=+Y
SET (DFN,FHP)=""
GOTO S0
P0 SET FHALL=1
DO ^FHOMDPA
if 'FHDFN
GOTO KIL
SET (FHP,W1)=""
SET UPD=0
SET SORT="R"
GOTO F1
+1 IF $GET(DFN)
IF ($PIECE($GET(^DPT(DFN,.35)),"^",1))
WRITE *7,!!?5," [ Patient has expired. ]"
GOTO KIL
S0 READ !!,"Sort Patients: (A=Alphabetically R=Room-Bed) R// ",SORT:DTIME
if '$TEST!(SORT["^")
GOTO KIL
if SORT=""
SET SORT="R"
IF "ar"[SORT
SET X=SORT
DO TR^FH
SET SORT=X
+1 IF SORT'?1U!("AR"'[SORT)
WRITE *7," Enter A or R"
GOTO S0
F1 SET %DT("A")="Select Date: "
SET %DT="AEFX"
SET %DT("B")="TODAY"
SET %DT(0)=DT
WRITE !
DO ^%DT
if "^"[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO F1
SET (X1,D1)=+Y
+1 DO E1^FHPRC1
SET FLG=0
IF FHCY<1
SET FLG=1
SET (FHDA,FHX1)=""
GOTO R0
+2 IF '$DATA(^FH(116,FHCY,"DA",FHDA,0))
SET FLG=1
SET (FHDA,FHX1)=""
R0 READ !!,"Print Three Per Page? N//",X:DTIME
if '$TEST!(X="^")
GOTO KIL
if X=""
SET X="N"
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7," Answer YES or NO"
GOTO R0
+1 SET TPP=$EXTRACT(X,1)
SET TPP=TPP="Y"
IF 'TPP
SET MEAL="A"
SET FLG=1
SET (FHDA,FHX1)=""
GOTO P1
R1 READ !!,"Select MEAL (B,N,E,or ALL): ",MEAL:DTIME
if '$TEST!("^"[MEAL)
GOTO KIL
SET X=MEAL
DO TR^FH
SET MEAL=X
if $PIECE("ALL",MEAL,1)=""
SET MEAL="A"
+1 IF "BNEA"'[MEAL!(MEAL'?1U)
WRITE *7,!,"Select B for Breakfast, N for Noon, or E for Evening or ALL for all meals"
GOTO R1
P1 IF FLG
if DFN
GOTO L0
GOTO R2
+1 SET FHDA=^FH(116,FHCY,"DA",FHDA,0)
+2 IF $DATA(^FH(116.3,D1,0))
SET X=^(0)
FOR LL=2:1:4
IF $PIECE(X,"^",LL)
SET $PIECE(FHDA,"^",LL)=$PIECE(X,"^",LL)
+3 SET FHX1=FHDA
if DFN
GOTO L0
R2 READ !!,"Print Only Ones With Order Changes related to the Diet Card? N // ",X:DTIME
if '$TEST!(X="^")
GOTO KIL
if X=""
SET X="N"
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7,!," Answer YES or NO"
GOTO R2
+1 SET UPD=X?1"Y".E
L0 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+1 IF $DATA(IO("Q"))
SET FHPGM="B1^FHDCR1A"
SET FHLST="D1^MEAL^FHX1^FHP^FLG^W1^FHDFN^DFN^UPD^TPP^SORT"
DO EN2^FH
GOTO KIL
+2 USE IO
DO B1^FHDCR1A
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
