FHORD13 ; HISC/REL/NCA/RVD - Reprint Diet Label ;2/26/96 11:57
;;5.5;DIETETICS;**1,5,8**;Jan 28, 2005;Build 28
W @IOF,!!?21,"R E P R I N T D I E T L A B E L S"
F0 R !!,"Reprint by COMMUNICATION OFFICE, PATIENT, LOCATION or ALL? PATIENT// ",X:DTIME G:'$T!(X["^") KIL S:X="" X="P" D TR^FH
I $P("COMMUNICATION OFFICE",X,1)'="",$P("PATIENT",X,1)'="",$P("LOCATION",X,1)'="",$P("ALL",X,1)'="" W *7,!!," Answer with C, L, P or A" G F0
S FHPR=$E(X,1),ALL=0,(FHX1,FHX2)="" G P0:FHPR?1"P",D2:FHPR?1"C",P1:FHPR?1"A"
W0 K DIC S DIC("A")="Select LOCATION: ",DIC="^FH(119.6,",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),W0:Y<1 S FHX1=-Y G P1
D2 K DIC S DIC("A")="Select COMMUNICATION OFFICE: ",DIC="^FH(119.73,",DIC(0)="AEMQ" W ! D ^DIC G KIL:"^"[X!$D(DTOUT),D2:Y<1 S FHX1=-Y G P1
P0 S FHALL=1 D ^FHOMDPA I '$G(FHDFN),FHX1'="" G P1
Q:'FHDFN
S ADM="*"
I 'DFN,$G(FHDFN) G PPT
I $D(^DPT(DFN,.1)) S WARD=$G(^DPT(DFN,.1)) D
.I $G(^DPT("CN",WARD,DFN)) S ADM=$G(^DPT("CN",WARD,DFN))
PPT S FHX1=$G(FHX1)_FHDFN_"^",FHX2=$G(FHX2)_ADM_"^" I $L(FHX1)<231,$L(FHX2)<231 G P0
G:FHX1="" KIL
P1 ;
W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If using laser label sheets, what row do you want to begin printing at? ",DIR("B")=1 D ^DIR
Q:$D(DIRUT) S LABSTART=Y
W ! K IOP,%ZIS S %ZIS("A")="Select LABEL Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHORD13",FHLST="FHX1^FHX2^FHPR^LABSTART" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Reprint the Diet Labels
S LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1 S S2=LAB=2*5+36 D NOW^%DTC S NOW=%
S COUNT=0,LINE=1
S DTP=NOW D DTP^FH,^FHDEV G:FHX1>0 Q2
S WRD=-FHX1 K ^TMP($J)
F K1=0:0 S K1=$O(^FH(119.6,K1)) Q:K1<1 S X=^(K1,0) D F1
S RM="" F S RM=$O(^TMP($J,"DL",RM)) Q:RM="" F DFN=0:0 S DFN=$O(^TMP($J,"DL",RM,DFN)) Q:DFN<1 S ADM=^(DFN) S FHZ115="P"_DFN D CHECK^FHOMDPA Q:FHDFN="" D:ADM LST
;process outpatient
D OUTP
D PROUT
I LAB>2 D DPLL^FHLABEL G KIL
I LAB<3 F K7=1:1:18 W !
G KIL
;
F1 I FHPR="C" S KK=$P(X,"^",8) I WRD,KK'=WRD Q
I FHPR="L" S KK=$P(X,"^",1) I WRD,K1'=WRD Q
S P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",K1,FHDFN)) Q:FHDFN<1 D
.D PATNAME^FHOMUTL Q:DFN=""
.S ADM=$G(^FHPT("AW",K1,FHDFN))
.S RM=$G(^DPT(DFN,.101))
.S:RM="" RM="***"
.S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,K1,0)),1:"")
.S R0=$S(RE:$P($G(^FH(119.6,K1,"R",+RE,0)),"^",2),1:"")
.S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
.S ^TMP($J,"DL",P0_"~"_R0_"~"_RM,DFN)=ADM Q
Q
;
Q2 F K7=1:1 S FHDFN=$P(FHX1,"^",K7) Q:FHDFN<1 D PATNAME^FHOMUTL S ADM=$P(FHX2,"^",K7) D:$G(ADM) LST I '$G(ADM) S FHDFNSAV(FHDFN)=FHDFN
;process outpatient
D OUTP
D PROUT
I LAB>2 D DPLL^FHLABEL G KIL
Q3 I LAB<3 F K7=1:1:18 W !
G KIL
;
LST ;
Q:'$D(^FHPT(FHDFN,"A",ADM,0)) S X0=^(0)
S FHORD=$P(X0,"^",2),X1=$P(X0,"^",5) Q:FHORD<1
S W1=$P(X0,"^",8),W1=$P($G(^FH(119.6,+W1,0)),"^",1),R1=$G(^DPT(DFN,.101))
Q:'$D(^DPT(DFN,0)) S Y0=^(0) D PID^FHDPA
S W1=$E(W1,1,15),N1=$E($P(Y0,"^",1),1,22)
S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
S (Y,X1)="" G:X="" L1 S FHOR=$P(X,"^",2,6),FHLD=$P(X,"^",7)
I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") G:%<1 L1 S Y=$P($E(FHDU,%,999),";",1) G L1
F A1=1:1:5 S D3=$P(FHOR,"^",A1) I D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7)
S IS=$P(X0,"^",10),X1=$P(X,"^",8) I IS S IS=^FH(119.4,IS,0),X1=X1_"-"_$P(IS,"^",2)_$P(IS,"^",3)
;
L1 S ALG="" D ALG^FHCLN
I LAB>2 D LL Q
W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W @FHIO("EON") W ?(S2-3\2),X1 W @FHIO("EOF") W ?(S2-3-$L(R1)),R1 W @FHIO("EON") I $L(Y)<S2 W:LAB=2 ! W !,$S(ALG="":"",1:"*ALG"),!,Y,!!
E S L=$S($L($P(Y,",",1,3))<S2:3,1:2) W !!,$P(Y,",",1,L) W:LAB=2 ! W !,$E($P(Y,",",L+1,5),2,99),!
W @FHIO("EOF") W:LAB=2 ?(S2-20),DTP,!! Q
;
OUTP ;process outpatient dat
S (R1,FHW1SAV,FHFHPSAV)=""
I FHPR="L" S FHW1SAV=-FHX1
I FHPR="C" S FHFHPSAV=-FHX1
S FHD1=DT-.00001,FHD2=DT+.99999
;next recurring
F FHK1=FHD1:0 S FHK1=$O(^FHPT("RM",FHK1)) Q:(FHK1'>0)!(FHK1>FHD2) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHK1,FHDFN)) Q:FHDFN'>0 D
..F FHKD=0:0 S FHKD=$O(^FHPT("RM",FHK1,FHDFN,FHKD)) Q:FHKD'>0 D
...S FHKDAT=^FHPT(FHDFN,"OP",FHKD,0)
...S (W1,FHW1)=$P(FHKDAT,U,3)
...S FHDIET=$P(FHKDAT,U,2),FHMEAL=$P(FHKDAT,U,4),FHSTAT=$P(FHKDAT,U,15)
...I FHSTAT="C" Q
...S FHDIET1=$P(FHKDAT,U,7)
...S FHDIET2=$P(FHKDAT,U,8)
...S FHDIET3=$P(FHKDAT,U,9)
...S FHDIET4=$P(FHKDAT,U,10)
...S FHDIET5=$P(FHKDAT,U,11)
...I FHPR="P",'$D(FHDFNSAV(FHDFN)) Q
...I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
...I $D(FHDFNSAV(FHDFN)),(FHDFN'=FHDFNSAV(FHDFN)) Q
...S FHLOC="",FHRGS="OP"
...S:$D(^FH(119.6,FHW1,0)) FHLOC=$P(^FH(119.6,FHW1,0),U,8)
...I $G(FHFHPSAV),$G(FHLOC),(FHFHPSAV'=FHLOC) Q
...S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
...S FHRMB=$P(FHKDAT,U,18)
...D OUTW
;next guest
K FHDIET1,FHDIET2,FHDIET3,FHDIET4,FHDIET5
F FHKD=FHD1:0 S FHKD=$O(^FHPT("GM",FHKD)) Q:(FHKD'>0)!(FHKD>FHD2) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHKD,FHDFN)) Q:FHDFN'>0 D
..I FHPR="P",'$D(FHDFNSAV(FHDFN)) Q
..S FHKDAT=^FHPT(FHDFN,"GM",FHKD,0)
..I $P(FHKDAT,U,9)="C" Q
..S (W1,FHW1)=$P(FHKDAT,U,5)
..S FHDIET=$P(FHKDAT,U,6),FHMEAL=$P(FHKDAT,U,3)
..I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
..I $D(FHDFNSAV(FHDFN)),(FHDFN'=FHDFNSAV(FHDFN)) Q
..S FHLOC=""
..S:$D(^FH(119.6,FHW1,0)) FHLOC=$P(^FH(119.6,FHW1,0),U,8)
..I $G(FHFHPSAV),$G(FHLOC),(FHFHPSAV'=FHLOC) Q
..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
..S FHRMB=$P(FHKDAT,U,11)
..D OUTW
;next SPECIAL
F FHKD=FHD1:0 S FHKD=$O(^FHPT("SM",FHKD)) Q:(FHKD'>0)!(FHKD>FHD2) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHKD,FHDFN)) Q:FHDFN'>0 D
..I FHPR="P",'$D(FHDFNSAV(FHDFN)) Q
..S FHKDAT=^FHPT(FHDFN,"SM",FHKD,0)
..S (W1,FHW1)=$P(FHKDAT,U,3)
..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
..S FHDIET=$P(FHKDAT,U,4),FHMEAL=$P(FHKDAT,U,9),FHSTAT=$P(FHKDAT,U,2)
..I (FHSTAT="C")!(FHSTAT="D") Q
..I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
..I $D(FHDFNSAV(FHDFN)),(FHDFN'=FHDFNSAV(FHDFN)) Q
..S FHLOC=""
..S:$D(^FH(119.6,FHW1,0)) FHLOC=$P(^FH(119.6,FHW1,0),U,8)
..I $G(FHFHPSAV),$G(FHLOC),(FHFHPSAV'=FHLOC) Q
..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
..S FHRMB=$P(FHKDAT,U,13)
..D OUTW
Q
;
OUTW ;set all outpt data for printing
D PATNAME^FHOMUTL
S FHTC=""
Q:'$D(^FH(119.6,FHW1,0))
S P0=$P(^FH(119.6,FHW1,0),U,4)
S P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
S FHW1N=$P(^FH(119.6,FHW1,0),U,1)
S FHTC5=$P(^FH(119.6,FHW1,0),U,5)
S FHTC6=$P(^FH(119.6,FHW1,0),U,6)
I $G(FHTC5),$D(^FH(119.72,FHTC5,0)) S FHTC=FHTC_$P(^FH(119.72,FHTC5,0),U,2)
I $G(FHTC6),$D(^FH(119.72,FHTC6,0)) S FHTC=FHTC_$P(^FH(119.72,FHTC6,0),U,2)
S:$G(FHDIET) FHDIET=$P(^FH(111,FHDIET,0),U,7)
I $G(FHDIET1) S FHDIET1=$P(^FH(111,FHDIET1,0),U,7) D
.I FHDIET="" S FHDIET=FHDIET_FHDIET1 Q
.I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET1
I $G(FHDIET2) S FHDIET2=$P(^FH(111,FHDIET2,0),U,7) D
.I FHDIET="" S FHDIET=FHDIET_FHDIET2 Q
.I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET2
I $G(FHDIET3) S FHDIET3=$P(^FH(111,FHDIET3,0),U,7) D
.I FHDIET="" S FHDIET=FHDIET_FHDIET3 Q
.I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET3
I $G(FHDIET4) S FHDIET4=$P(^FH(111,FHDIET4,0),U,7) D
.I FHDIET="" S FHDIET=FHDIET_FHDIET4 Q
.I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET4
I $G(FHDIET5) S FHDIET5=$P(^FH(111,FHDIET5,0),U,7) D
.I FHDIET="" S FHDIET=FHDIET_FHDIET5 Q
.I FHDIET'="" S FHDIET=FHDIET_", "_FHDIET5
S FHRM=""
I $G(FHRMB),$D(^DG(405.4,FHRMB,0)) S FHRM=$P(^DG(405.4,FHRMB,0),U,1)
S:FHRM'="" FHRM=$E(FHRM,1,12)
S ^TMP($J,"OUT",P0_"~"_$E(FHW1N,1,20)_"~"_$E(FHPTNM,1,26),FHDFN)=FHPTNM_"^"_FHW1N_"^"_FHBID_"^"_FHDIET_"^"_FHTC_"^"_FHRM
Q
;
PROUT ;print outptlabels
S (X1,RM)=""
F S RM=$O(^TMP($J,"OUT",RM)) Q:RM="" D
.F FHDFN=0:0 S FHDFN=$O(^TMP($J,"OUT",RM,FHDFN)) Q:FHDFN'>0 D
..S FHOU=^TMP($J,"OUT",RM,FHDFN)
..S N1=$P(FHOU,U,1)
..S W1=$E($P(FHOU,U,2),1,12)
..S BID=$P(FHOU,U,3)
..S (Y,FHDIET)=$P(FHOU,U,4)
..S X1=$P(FHOU,U,5)
..S R1=$P(FHOU,U,6)
..D L1
Q
;
KIL K ^TMP($J) G KILL^XUSCLEAN
Q
LL D LAB^FHLABEL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD13 8107 printed Sep 23, 2025@19:29:25 Page 2
FHORD13 ; HISC/REL/NCA/RVD - Reprint Diet Label ;2/26/96 11:57
+1 ;;5.5;DIETETICS;**1,5,8**;Jan 28, 2005;Build 28
+2 WRITE @IOF,!!?21,"R E P R I N T D I E T L A B E L S"
F0 READ !!,"Reprint by COMMUNICATION OFFICE, PATIENT, LOCATION or ALL? PATIENT// ",X:DTIME
if '$TEST!(X["^")
GOTO KIL
if X=""
SET X="P"
DO TR^FH
+1 IF $PIECE("COMMUNICATION OFFICE",X,1)'=""
IF $PIECE("PATIENT",X,1)'=""
IF $PIECE("LOCATION",X,1)'=""
IF $PIECE("ALL",X,1)'=""
WRITE *7,!!," Answer with C, L, P or A"
GOTO F0
+2 SET FHPR=$EXTRACT(X,1)
SET ALL=0
SET (FHX1,FHX2)=""
if FHPR?1"P"
GOTO P0
if FHPR?1"C"
GOTO D2
if FHPR?1"A"
GOTO P1
W0 KILL DIC
SET DIC("A")="Select 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 FHX1=-Y
GOTO P1
D2 KILL DIC
SET DIC("A")="Select COMMUNICATION OFFICE: "
SET DIC="^FH(119.73,"
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
if "^"[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO D2
SET FHX1=-Y
GOTO P1
P0 SET FHALL=1
DO ^FHOMDPA
IF '$GET(FHDFN)
IF FHX1'=""
GOTO P1
+1 if 'FHDFN
QUIT
+2 SET ADM="*"
+3 IF 'DFN
IF $GET(FHDFN)
GOTO PPT
+4 IF $DATA(^DPT(DFN,.1))
SET WARD=$GET(^DPT(DFN,.1))
Begin DoDot:1
+5 IF $GET(^DPT("CN",WARD,DFN))
SET ADM=$GET(^DPT("CN",WARD,DFN))
End DoDot:1
PPT SET FHX1=$GET(FHX1)_FHDFN_"^"
SET FHX2=$GET(FHX2)_ADM_"^"
IF $LENGTH(FHX1)<231
IF $LENGTH(FHX2)<231
GOTO P0
+1 if FHX1=""
GOTO KIL
P1 ;
+1 WRITE !
KILL DIR,LABSTART
SET DIR(0)="NA^1:10"
SET DIR("A")="If using laser label sheets, what row do you want to begin printing at? "
SET DIR("B")=1
DO ^DIR
+2 if $DATA(DIRUT)
QUIT
SET LABSTART=Y
+3 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LABEL Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+4 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHORD13"
SET FHLST="FHX1^FHX2^FHPR^LABSTART"
DO EN2^FH
GOTO KIL
+5 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Reprint the Diet Labels
+1 SET LAB=$PIECE($GET(^FH(119.9,1,"D",IOS,0)),"^",2)
if 'LAB
SET LAB=1
SET S2=LAB=2*5+36
DO NOW^%DTC
SET NOW=%
+2 SET COUNT=0
SET LINE=1
+3 SET DTP=NOW
DO DTP^FH
DO ^FHDEV
if FHX1>0
GOTO Q2
+4 SET WRD=-FHX1
KILL ^TMP($JOB)
+5 FOR K1=0:0
SET K1=$ORDER(^FH(119.6,K1))
if K1<1
QUIT
SET X=^(K1,0)
DO F1
+6 SET RM=""
FOR
SET RM=$ORDER(^TMP($JOB,"DL",RM))
if RM=""
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,"DL",RM,DFN))
if DFN<1
QUIT
SET ADM=^(DFN)
SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
if FHDFN=""
QUIT
if ADM
DO LST
+7 ;process outpatient
+8 DO OUTP
+9 DO PROUT
+10 IF LAB>2
DO DPLL^FHLABEL
GOTO KIL
+11 IF LAB<3
FOR K7=1:1:18
WRITE !
+12 GOTO KIL
+13 ;
F1 IF FHPR="C"
SET KK=$PIECE(X,"^",8)
IF WRD
IF KK'=WRD
QUIT
+1 IF FHPR="L"
SET KK=$PIECE(X,"^",1)
IF WRD
IF K1'=WRD
QUIT
+2 SET P0=$PIECE(X,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
+3 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",K1,FHDFN))
if FHDFN<1
QUIT
Begin DoDot:1
+4 DO PATNAME^FHOMUTL
if DFN=""
QUIT
+5 SET ADM=$GET(^FHPT("AW",K1,FHDFN))
+6 SET RM=$GET(^DPT(DFN,.101))
+7 if RM=""
SET RM="***"
+8 SET RI=$GET(^DPT(DFN,.108))
SET RE=$SELECT(RI:$ORDER(^FH(119.6,"AR",+RI,K1,0)),1:"")
+9 SET R0=$SELECT(RE:$PIECE($GET(^FH(119.6,K1,"R",+RE,0)),"^",2),1:"")
+10 SET R0=$SELECT(R0<1:99,R0<10:"0"_R0,1:R0)
+11 SET ^TMP($JOB,"DL",P0_"~"_R0_"~"_RM,DFN)=ADM
QUIT
End DoDot:1
+12 QUIT
+13 ;
Q2 FOR K7=1:1
SET FHDFN=$PIECE(FHX1,"^",K7)
if FHDFN<1
QUIT
DO PATNAME^FHOMUTL
SET ADM=$PIECE(FHX2,"^",K7)
if $GET(ADM)
DO LST
IF '$GET(ADM)
SET FHDFNSAV(FHDFN)=FHDFN
+1 ;process outpatient
+2 DO OUTP
+3 DO PROUT
+4 IF LAB>2
DO DPLL^FHLABEL
GOTO KIL
Q3 IF LAB<3
FOR K7=1:1:18
WRITE !
+1 GOTO KIL
+2 ;
LST ;
+1 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
SET X0=^(0)
+2 SET FHORD=$PIECE(X0,"^",2)
SET X1=$PIECE(X0,"^",5)
if FHORD<1
QUIT
+3 SET W1=$PIECE(X0,"^",8)
SET W1=$PIECE($GET(^FH(119.6,+W1,0)),"^",1)
SET R1=$GET(^DPT(DFN,.101))
+4 if '$DATA(^DPT(DFN,0))
QUIT
SET Y0=^(0)
DO PID^FHDPA
+5 SET W1=$EXTRACT(W1,1,15)
SET N1=$EXTRACT($PIECE(Y0,"^",1),1,22)
+6 SET X=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
+7 SET (Y,X1)=""
if X=""
GOTO L1
SET FHOR=$PIECE(X,"^",2,6)
SET FHLD=$PIECE(X,"^",7)
+8 IF FHLD'=""
SET FHDU=";"_$PIECE(^DD(115.02,6,0),"^",3)
SET %=$FIND(FHDU,";"_FHLD_":")
if %<1
GOTO L1
SET Y=$PIECE($EXTRACT(FHDU,%,999),";",1)
GOTO L1
+9 FOR A1=1:1:5
SET D3=$PIECE(FHOR,"^",A1)
IF D3
if Y'=""
SET Y=Y_", "
SET Y=Y_$PIECE(^FH(111,D3,0),"^",7)
+10 SET IS=$PIECE(X0,"^",10)
SET X1=$PIECE(X,"^",8)
IF IS
SET IS=^FH(119.4,IS,0)
SET X1=X1_"-"_$PIECE(IS,"^",2)_$PIECE(IS,"^",3)
+11 ;
L1 SET ALG=""
DO ALG^FHCLN
+1 IF LAB>2
DO LL
QUIT
+2 WRITE !,$EXTRACT(N1,1,S2-5-$LENGTH(W1)),?(S2-3-$LENGTH(W1)),W1,!,BID
WRITE @FHIO("EON")
WRITE ?(S2-3\2),X1
WRITE @FHIO("EOF")
WRITE ?(S2-3-$LENGTH(R1)),R1
WRITE @FHIO("EON")
IF $LENGTH(Y)<S2
if LAB=2
WRITE !
WRITE !,$SELECT(ALG="":"",1:"*ALG"),!,Y,!!
+3 IF '$TEST
SET L=$SELECT($LENGTH($PIECE(Y,",",1,3))<S2:3,1:2)
WRITE !!,$PIECE(Y,",",1,L)
if LAB=2
WRITE !
WRITE !,$EXTRACT($PIECE(Y,",",L+1,5),2,99),!
+4 WRITE @FHIO("EOF")
if LAB=2
WRITE ?(S2-20),DTP,!!
QUIT
+5 ;
OUTP ;process outpatient dat
+1 SET (R1,FHW1SAV,FHFHPSAV)=""
+2 IF FHPR="L"
SET FHW1SAV=-FHX1
+3 IF FHPR="C"
SET FHFHPSAV=-FHX1
+4 SET FHD1=DT-.00001
SET FHD2=DT+.99999
+5 ;next recurring
+6 FOR FHK1=FHD1:0
SET FHK1=$ORDER(^FHPT("RM",FHK1))
if (FHK1'>0)!(FHK1>FHD2)
QUIT
Begin DoDot:1
+7 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",FHK1,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+8 FOR FHKD=0:0
SET FHKD=$ORDER(^FHPT("RM",FHK1,FHDFN,FHKD))
if FHKD'>0
QUIT
Begin DoDot:3
+9 SET FHKDAT=^FHPT(FHDFN,"OP",FHKD,0)
+10 SET (W1,FHW1)=$PIECE(FHKDAT,U,3)
+11 SET FHDIET=$PIECE(FHKDAT,U,2)
SET FHMEAL=$PIECE(FHKDAT,U,4)
SET FHSTAT=$PIECE(FHKDAT,U,15)
+12 IF FHSTAT="C"
QUIT
+13 SET FHDIET1=$PIECE(FHKDAT,U,7)
+14 SET FHDIET2=$PIECE(FHKDAT,U,8)
+15 SET FHDIET3=$PIECE(FHKDAT,U,9)
+16 SET FHDIET4=$PIECE(FHKDAT,U,10)
+17 SET FHDIET5=$PIECE(FHKDAT,U,11)
+18 IF FHPR="P"
IF '$DATA(FHDFNSAV(FHDFN))
QUIT
+19 IF $GET(FHW1SAV)
IF (FHW1'=FHW1SAV)
QUIT
+20 IF $DATA(FHDFNSAV(FHDFN))
IF (FHDFN'=FHDFNSAV(FHDFN))
QUIT
+21 SET FHLOC=""
SET FHRGS="OP"
+22 if $DATA(^FH(119.6,FHW1,0))
SET FHLOC=$PIECE(^FH(119.6,FHW1,0),U,8)
+23 IF $GET(FHFHPSAV)
IF $GET(FHLOC)
IF (FHFHPSAV'=FHLOC)
QUIT
+24 SET FHDFN1=$PIECE(^FHPT(FHDFN,0),U,1)
+25 SET FHRMB=$PIECE(FHKDAT,U,18)
+26 DO OUTW
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;next guest
+28 KILL FHDIET1,FHDIET2,FHDIET3,FHDIET4,FHDIET5
+29 FOR FHKD=FHD1:0
SET FHKD=$ORDER(^FHPT("GM",FHKD))
if (FHKD'>0)!(FHKD>FHD2)
QUIT
Begin DoDot:1
+30 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("GM",FHKD,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+31 IF FHPR="P"
IF '$DATA(FHDFNSAV(FHDFN))
QUIT
+32 SET FHKDAT=^FHPT(FHDFN,"GM",FHKD,0)
+33 IF $PIECE(FHKDAT,U,9)="C"
QUIT
+34 SET (W1,FHW1)=$PIECE(FHKDAT,U,5)
+35 SET FHDIET=$PIECE(FHKDAT,U,6)
SET FHMEAL=$PIECE(FHKDAT,U,3)
+36 IF $GET(FHW1SAV)
IF (FHW1'=FHW1SAV)
QUIT
+37 IF $DATA(FHDFNSAV(FHDFN))
IF (FHDFN'=FHDFNSAV(FHDFN))
QUIT
+38 SET FHLOC=""
+39 if $DATA(^FH(119.6,FHW1,0))
SET FHLOC=$PIECE(^FH(119.6,FHW1,0),U,8)
+40 IF $GET(FHFHPSAV)
IF $GET(FHLOC)
IF (FHFHPSAV'=FHLOC)
QUIT
+41 SET FHDFN1=$PIECE(^FHPT(FHDFN,0),U,1)
+42 SET FHRMB=$PIECE(FHKDAT,U,11)
+43 DO OUTW
End DoDot:2
End DoDot:1
+44 ;next SPECIAL
+45 FOR FHKD=FHD1:0
SET FHKD=$ORDER(^FHPT("SM",FHKD))
if (FHKD'>0)!(FHKD>FHD2)
QUIT
Begin DoDot:1
+46 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("SM",FHKD,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+47 IF FHPR="P"
IF '$DATA(FHDFNSAV(FHDFN))
QUIT
+48 SET FHKDAT=^FHPT(FHDFN,"SM",FHKD,0)
+49 SET (W1,FHW1)=$PIECE(FHKDAT,U,3)
+50 SET FHDFN1=$PIECE(^FHPT(FHDFN,0),U,1)
+51 SET FHDIET=$PIECE(FHKDAT,U,4)
SET FHMEAL=$PIECE(FHKDAT,U,9)
SET FHSTAT=$PIECE(FHKDAT,U,2)
+52 IF (FHSTAT="C")!(FHSTAT="D")
QUIT
+53 IF $GET(FHW1SAV)
IF (FHW1'=FHW1SAV)
QUIT
+54 IF $DATA(FHDFNSAV(FHDFN))
IF (FHDFN'=FHDFNSAV(FHDFN))
QUIT
+55 SET FHLOC=""
+56 if $DATA(^FH(119.6,FHW1,0))
SET FHLOC=$PIECE(^FH(119.6,FHW1,0),U,8)
+57 IF $GET(FHFHPSAV)
IF $GET(FHLOC)
IF (FHFHPSAV'=FHLOC)
QUIT
+58 SET FHDFN1=$PIECE(^FHPT(FHDFN,0),U,1)
+59 SET FHRMB=$PIECE(FHKDAT,U,13)
+60 DO OUTW
End DoDot:2
End DoDot:1
+61 QUIT
+62 ;
OUTW ;set all outpt data for printing
+1 DO PATNAME^FHOMUTL
+2 SET FHTC=""
+3 if '$DATA(^FH(119.6,FHW1,0))
QUIT
+4 SET P0=$PIECE(^FH(119.6,FHW1,0),U,4)
+5 SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
+6 SET FHW1N=$PIECE(^FH(119.6,FHW1,0),U,1)
+7 SET FHTC5=$PIECE(^FH(119.6,FHW1,0),U,5)
+8 SET FHTC6=$PIECE(^FH(119.6,FHW1,0),U,6)
+9 IF $GET(FHTC5)
IF $DATA(^FH(119.72,FHTC5,0))
SET FHTC=FHTC_$PIECE(^FH(119.72,FHTC5,0),U,2)
+10 IF $GET(FHTC6)
IF $DATA(^FH(119.72,FHTC6,0))
SET FHTC=FHTC_$PIECE(^FH(119.72,FHTC6,0),U,2)
+11 if $GET(FHDIET)
SET FHDIET=$PIECE(^FH(111,FHDIET,0),U,7)
+12 IF $GET(FHDIET1)
SET FHDIET1=$PIECE(^FH(111,FHDIET1,0),U,7)
Begin DoDot:1
+13 IF FHDIET=""
SET FHDIET=FHDIET_FHDIET1
QUIT
+14 IF FHDIET'=""
SET FHDIET=FHDIET_", "_FHDIET1
End DoDot:1
+15 IF $GET(FHDIET2)
SET FHDIET2=$PIECE(^FH(111,FHDIET2,0),U,7)
Begin DoDot:1
+16 IF FHDIET=""
SET FHDIET=FHDIET_FHDIET2
QUIT
+17 IF FHDIET'=""
SET FHDIET=FHDIET_", "_FHDIET2
End DoDot:1
+18 IF $GET(FHDIET3)
SET FHDIET3=$PIECE(^FH(111,FHDIET3,0),U,7)
Begin DoDot:1
+19 IF FHDIET=""
SET FHDIET=FHDIET_FHDIET3
QUIT
+20 IF FHDIET'=""
SET FHDIET=FHDIET_", "_FHDIET3
End DoDot:1
+21 IF $GET(FHDIET4)
SET FHDIET4=$PIECE(^FH(111,FHDIET4,0),U,7)
Begin DoDot:1
+22 IF FHDIET=""
SET FHDIET=FHDIET_FHDIET4
QUIT
+23 IF FHDIET'=""
SET FHDIET=FHDIET_", "_FHDIET4
End DoDot:1
+24 IF $GET(FHDIET5)
SET FHDIET5=$PIECE(^FH(111,FHDIET5,0),U,7)
Begin DoDot:1
+25 IF FHDIET=""
SET FHDIET=FHDIET_FHDIET5
QUIT
+26 IF FHDIET'=""
SET FHDIET=FHDIET_", "_FHDIET5
End DoDot:1
+27 SET FHRM=""
+28 IF $GET(FHRMB)
IF $DATA(^DG(405.4,FHRMB,0))
SET FHRM=$PIECE(^DG(405.4,FHRMB,0),U,1)
+29 if FHRM'=""
SET FHRM=$EXTRACT(FHRM,1,12)
+30 SET ^TMP($JOB,"OUT",P0_"~"_$EXTRACT(FHW1N,1,20)_"~"_$EXTRACT(FHPTNM,1,26),FHDFN)=FHPTNM_"^"_FHW1N_"^"_FHBID_"^"_FHDIET_"^"_FHTC_"^"_FHRM
+31 QUIT
+32 ;
PROUT ;print outptlabels
+1 SET (X1,RM)=""
+2 FOR
SET RM=$ORDER(^TMP($JOB,"OUT",RM))
if RM=""
QUIT
Begin DoDot:1
+3 FOR FHDFN=0:0
SET FHDFN=$ORDER(^TMP($JOB,"OUT",RM,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+4 SET FHOU=^TMP($JOB,"OUT",RM,FHDFN)
+5 SET N1=$PIECE(FHOU,U,1)
+6 SET W1=$EXTRACT($PIECE(FHOU,U,2),1,12)
+7 SET BID=$PIECE(FHOU,U,3)
+8 SET (Y,FHDIET)=$PIECE(FHOU,U,4)
+9 SET X1=$PIECE(FHOU,U,5)
+10 SET R1=$PIECE(FHOU,U,6)
+11 DO L1
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
+1 QUIT
LL DO LAB^FHLABEL
QUIT
