- 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 Feb 18, 2025@23:13:47 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
