FHORD13.m

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 ---FHORD13   8107     printed  Mar 13, 2025@20:58:04                                                                                                                                                                                                     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)