FHNO2 ; HISC/REL/NCA - Supplemental Feeding Labels ;8/26/94 12:01
;;5.5;DIETETICS;**5,13**;Jan 28, 2005;Build 1
;patch #5 - add outpatient SFs.
D0 R !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME G:'$T!("^"[XX) KIL I "sw"[XX S X=XX D TR^FH S XX=X
I XX'?1U!("SW"'[XX) W *7," Enter S or W" G D0
I XX="S" S D1=$O(^FH(119.74,0)) I D1'<1,$O(^FH(119.74,D1))<1 G D3
I XX="W" S WRD=$O(^FH(119.6,0)) I WRD'<1,$O(^FH(119.6,WRD))<1 G D3
I XX="S" G D2
D1 R !!,"Select WARD: ",X:DTIME G:'$T!("^"[X) KIL
K DIC S DIC="^FH(119.6,",DIC(0)="EMQ" D ^DIC G:Y<1 D1 S W1=+Y
S D1=$P($G(^FH(119.6,W1,0)),"^",9) G D3
D2 R !!,"Select SUPPLEMENTAL FEEDING SITE: ",X:DTIME G:'$T!("^"[X) KIL
K DIC S DIC="^FH(119.74,",DIC(0)="EMQ" D ^DIC G:Y<1 D2 S D1=+Y,W1=0
D3 R !!,"Select Supplemental Feeding Time (10,2,8,ALL): ",TIM:DTIME G KIL:'$T!(U[TIM) I TIM="all" S X=TIM D TR^FH S TIM=X
I TIM'=2,TIM'=8,TIM'=10,TIM'="ALL" W *7," Enter a time, 10,2,8, or ALL" G D3
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
D4 R !!,"Do you want Ingredient list only? N// ",D3:DTIME G:'$T!(D3="^") KIL S:D3="" D3="N" S X=D3 D TR^FH S D3=X I $P("YES",D3,1)'="",$P("NO",D3,1)'="" W *7," Answer YES or NO" G D4
S D3=$E(D3,1),D3=D3="Y" G:'D3 D6
D5 R !!,"Consolidated List only? Y// ",X:DTIME G:'$T!(X="^") KIL S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G D5
S X=$E(X,1) S:X="Y" D3=D3+1
D6 I 'D3,'D1,XX="L" W !!,"No Supplemental Feeding Site associated with this location." G KIL
W:'D3 !!,"Place Labels in Printer"
PR K IOP S %ZIS="MQ",%ZIS("A")="Select "_$S('D3:"LABEL",1:"LIST")_" Printer: " W ! D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHNO2",FHLST="XX^TIM^W1^D1^D3^LABSTART" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Process Printing Supplemental Feeding Labels
S TIMSAV=TIM
D NOW^%DTC S NOW=%,DT=%\1 G:D3=2 SUM
I 'D3 Q:'D1 S FHPAR=$G(^FH(119.74,D1,0)),LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1
S COUNT=0,LINE=1 I TIM="ALL" S TIM=10 D Q2 S TIM=2 D Q2 S TIM=8
D Q2
I $G(LAB)>2 D DPLL^FHLABEL,KIL Q
I 'D3 F L=1:1:18 W !
KIL K ^TMP($J) G KILL^XUSCLEAN
Q2 K ^TMP($J,"L"),^TMP($J,"I"),^TMP($J,"SF"),C S P1=$S(TIM=10:5,TIM=2:13,1:21),T0=$P(DT,".",1)_"."_$S(TIM=10:1,TIM=2:14,1:2),P3=7,N1=0
I XX="W" S P0=$P($G(^FH(119.6,W1,0)),"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0
I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 S P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0
D SF0
G ^FHNO21:'D3,PRT
F0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0
F1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN'>0 S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 F1
G:'$D(^FHPT(FHDFN,"A",ADM,0)) F1 S X1=^(0),NO=$P(X1,"^",7) G:'NO F1
I 'D3 S IS=$P(X1,"^",10) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS=""
D CHK G:'NO F1
S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0))
S Y=$P(Y,"^",P1,P1+7) G:Y?."^" F1 D:D3 CALC
I 'D3 D
.D PATNAME^FHOMUTL I DFN="" Q
.S $P(Y,"^",9)=IS
.S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN)
.S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"")
.S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
.S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
.S RM=$G(^DPT(DFN,.101)),PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM
.S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD Q
G F1
Q
;
CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1
I X1>1,X1'>T0 G C2
C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2
S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO=""
C1 K FHORD,A1,K,X1 Q
C2 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>T0) S A1=K
G:'A1 C1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G:FHORD'<1 C0 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G C2
SUM K C,^TMP($J,"SF") S P0=$S(TIM=2:13,TIM=8:21,1:5),P3=$S(TIM="ALL":23,1:7),N1=0
I XX="W" S X=$G(^FH(119.6,W1,0)) D S0
I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 D S0
D SF0
G PRT
S0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0
S1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 S1
G:'$D(^FHPT(FHDFN,"A",ADM,0)) S1 S X1=^(0),NO=$P(X1,"^",7) G:'NO S1
S Y=$P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3) G:Y?."^" S1 D CALC
G S1
PRT S DTP=DT D DTP^FH S DTE=DTP_" "_$S(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM")
S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:WRDN)
W @IOF W:D3=2 !?5,"**** CONSOLIDATED ****" W !?3,"**** INGREDIENTS LIST ****",! W:D3=1 ! W ?(33-$L(Y)\2),Y,!?9,DTE,!!
F L=0:0 S L=$O(^FH(118,L)) Q:L<1 S:$D(C(L)) ^TMP($J,"SF",$P($G(^FH(118,L,0)),"^",1),L)=""
S A1="" F S A1=$O(^TMP($J,"SF",A1)) Q:A1="" F L=0:0 S L=$O(^TMP($J,"SF",A1,L)) Q:L<1 W !,$E(A1,1,26),?28,$J(C(L),5,0)
W !!?4,"**** PATIENTS = ",N1," ****",! Q
CALC S N1=N1+1
F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q
Q
;
SF0 ;outpatient SFs
F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",DT,FHDFN)) Q:FHDFN'>0 F ADM=0:0 S ADM=$O(^FHPT("RM",DT,FHDFN,ADM)) Q:ADM'>0 D
.S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO)
.S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3)
.S X1=$G(^FH(119.6,FHOWARD,0))
.Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0))
.I XX="W",W1 Q:W1'=FHOWARD
.S WRDN=$P(X1,U,1)
.I XX="S" S D2=$P(X1,"^",9) Q:D1'=D2 I D1=D2 S P0=$P(X1,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
.S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5)
.I (FHMEAL="B"),(TIM'=10) Q
.I (FHMEAL="N"),(TIM'=2) Q
.I (FHMEAL="E"),(TIM'=8) Q
.I 'D3 S IS=$P($G(^FHPT(FHDFN,0)),"^",5) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS=""
.S Y=$G(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0))
.S Y=$P(Y,"^",P1,P1+7) Q:Y?."^" I D3 D CLC1
.S N1=N1+1
.S RM="",RMIEN=$P(FHODAT,U,18) I $G(RMIEN),$D(^DG(405.4,RMIEN,0)) S RM=$E($P(^DG(405.4,RMIEN,0),U,1),1,10)
.I 'D3 D
..D PATNAME^FHOMUTL
..S $P(Y,"^",9)=IS
..S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN)
..S RI="***" S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"")
..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
..S PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM
..S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD
Q
CLC1 ;
F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHNO2 6538 printed Apr 09, 2024@20:53:50 Page 2
FHNO2 ; HISC/REL/NCA - Supplemental Feeding Labels ;8/26/94 12:01
+1 ;;5.5;DIETETICS;**5,13**;Jan 28, 2005;Build 1
+2 ;patch #5 - add outpatient SFs.
D0 READ !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME
if '$TEST!("^"[XX)
GOTO KIL
IF "sw"[XX
SET X=XX
DO TR^FH
SET XX=X
+1 IF XX'?1U!("SW"'[XX)
WRITE *7," Enter S or W"
GOTO D0
+2 IF XX="S"
SET D1=$ORDER(^FH(119.74,0))
IF D1'<1
IF $ORDER(^FH(119.74,D1))<1
GOTO D3
+3 IF XX="W"
SET WRD=$ORDER(^FH(119.6,0))
IF WRD'<1
IF $ORDER(^FH(119.6,WRD))<1
GOTO D3
+4 IF XX="S"
GOTO D2
D1 READ !!,"Select WARD: ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
+1 KILL DIC
SET DIC="^FH(119.6,"
SET DIC(0)="EMQ"
DO ^DIC
if Y<1
GOTO D1
SET W1=+Y
+2 SET D1=$PIECE($GET(^FH(119.6,W1,0)),"^",9)
GOTO D3
D2 READ !!,"Select SUPPLEMENTAL FEEDING SITE: ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
+1 KILL DIC
SET DIC="^FH(119.74,"
SET DIC(0)="EMQ"
DO ^DIC
if Y<1
GOTO D2
SET D1=+Y
SET W1=0
D3 READ !!,"Select Supplemental Feeding Time (10,2,8,ALL): ",TIM:DTIME
if '$TEST!(U[TIM)
GOTO KIL
IF TIM="all"
SET X=TIM
DO TR^FH
SET TIM=X
+1 IF TIM'=2
IF TIM'=8
IF TIM'=10
IF TIM'="ALL"
WRITE *7," Enter a time, 10,2,8, or ALL"
GOTO D3
+2 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
+3 if $DATA(DIRUT)
QUIT
SET LABSTART=Y
D4 READ !!,"Do you want Ingredient list only? N// ",D3:DTIME
if '$TEST!(D3="^")
GOTO KIL
if D3=""
SET D3="N"
SET X=D3
DO TR^FH
SET D3=X
IF $PIECE("YES",D3,1)'=""
IF $PIECE("NO",D3,1)'=""
WRITE *7," Answer YES or NO"
GOTO D4
+1 SET D3=$EXTRACT(D3,1)
SET D3=D3="Y"
if 'D3
GOTO D6
D5 READ !!,"Consolidated List only? Y// ",X:DTIME
if '$TEST!(X="^")
GOTO KIL
if X=""
SET X="Y"
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7," Answer YES or NO"
GOTO D5
+1 SET X=$EXTRACT(X,1)
if X="Y"
SET D3=D3+1
D6 IF 'D3
IF 'D1
IF XX="L"
WRITE !!,"No Supplemental Feeding Site associated with this location."
GOTO KIL
+1 if 'D3
WRITE !!,"Place Labels in Printer"
PR KILL IOP
SET %ZIS="MQ"
SET %ZIS("A")="Select "_$SELECT('D3:"LABEL",1:"LIST")_" Printer: "
WRITE !
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+1 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHNO2"
SET FHLST="XX^TIM^W1^D1^D3^LABSTART"
DO EN2^FH
GOTO KIL
+2 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Process Printing Supplemental Feeding Labels
+1 SET TIMSAV=TIM
+2 DO NOW^%DTC
SET NOW=%
SET DT=%\1
if D3=2
GOTO SUM
+3 IF 'D3
if 'D1
QUIT
SET FHPAR=$GET(^FH(119.74,D1,0))
SET LAB=$PIECE($GET(^FH(119.9,1,"D",IOS,0)),"^",2)
if 'LAB
SET LAB=1
+4 SET COUNT=0
SET LINE=1
IF TIM="ALL"
SET TIM=10
DO Q2
SET TIM=2
DO Q2
SET TIM=8
+5 DO Q2
+6 IF $GET(LAB)>2
DO DPLL^FHLABEL
DO KIL
QUIT
+7 IF 'D3
FOR L=1:1:18
WRITE !
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
Q2 KILL ^TMP($JOB,"L"),^TMP($JOB,"I"),^TMP($JOB,"SF"),C
SET P1=$SELECT(TIM=10:5,TIM=2:13,1:21)
SET T0=$PIECE(DT,".",1)_"."_$SELECT(TIM=10:1,TIM=2:14,1:2)
SET P3=7
SET N1=0
+1 IF XX="W"
SET P0=$PIECE($GET(^FH(119.6,W1,0)),"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
DO F0
+2 IF XX="S"
FOR W1=0:0
SET W1=$ORDER(^FH(119.6,W1))
if W1<1
QUIT
SET X=^(W1,0)
SET D2=$PIECE(X,"^",9)
IF D1=D2
SET P0=$PIECE(X,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
DO F0
+3 DO SF0
+4 if 'D3
GOTO ^FHNO21
GOTO PRT
F0 SET WRDN=$PIECE(^FH(119.6,W1,0),"^",1)
SET FHDFN=0
F1 SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
if FHDFN'>0
QUIT
SET ADM=$GET(^FHPT("AW",W1,FHDFN))
if ADM<1
GOTO F1
+1 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
GOTO F1
SET X1=^(0)
SET NO=$PIECE(X1,"^",7)
if 'NO
GOTO F1
+2 IF 'D3
SET IS=$PIECE(X1,"^",10)
IF IS
SET IS=$PIECE($GET(^FH(119.4,IS,0)),"^",3)
if IS'="N"
SET IS=""
+3 DO CHK
if 'NO
GOTO F1
+4 SET Y=$GET(^FHPT(FHDFN,"A",ADM,"SF",NO,0))
+5 SET Y=$PIECE(Y,"^",P1,P1+7)
if Y?."^"
GOTO F1
if D3
DO CALC
+6 IF 'D3
Begin DoDot:1
+7 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+8 SET $PIECE(Y,"^",9)=IS
+9 SET LNOD=$SELECT(XX="S":D2_"~"_$PIECE($GET(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN)
+10 SET RI=$GET(^DPT(DFN,.108))
SET RE=$SELECT(RI:$ORDER(^FH(119.6,"AR",+RI,W1,0)),1:"")
+11 SET R0=$SELECT(RE:$PIECE($GET(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
+12 SET R0=$SELECT(R0<1:99,R0<10:"0"_R0,1:R0)
+13 SET RM=$GET(^DPT(DFN,.101))
SET PNOD=P0_"~"_R0_RM_"~"_FHDFN
SET WRD=P0_$EXTRACT(WRDN,1,27-$LENGTH(RM))_"/"_RM
+14 SET ^TMP($JOB,"L",LNOD,PNOD)=Y_"^"_WRD
QUIT
End DoDot:1
+15 GOTO F1
+16 QUIT
+17 ;
CHK SET FHORD=$PIECE(X1,"^",2)
SET X1=$PIECE(X1,"^",3)
if FHORD<1
GOTO C1
+1 IF X1>1
IF X1'>T0
GOTO C2
C0 IF '$DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
GOTO C2
+1 SET X1=$PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7)
IF X1'=""
IF X1'="X"
SET NO=""
C1 KILL FHORD,A1,K,X1
QUIT
C2 SET A1=0
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K))
if K<1!(K>T0)
QUIT
SET A1=K
+1 if 'A1
GOTO C1
SET FHORD=$PIECE(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2)
if FHORD'<1
GOTO C0
KILL ^FHPT(FHDFN,"A",ADM,"AC",A1)
GOTO C2
SUM KILL C,^TMP($JOB,"SF")
SET P0=$SELECT(TIM=2:13,TIM=8:21,1:5)
SET P3=$SELECT(TIM="ALL":23,1:7)
SET N1=0
+1 IF XX="W"
SET X=$GET(^FH(119.6,W1,0))
DO S0
+2 IF XX="S"
FOR W1=0:0
SET W1=$ORDER(^FH(119.6,W1))
if W1<1
QUIT
SET X=^(W1,0)
SET D2=$PIECE(X,"^",9)
IF D1=D2
DO S0
+3 DO SF0
+4 GOTO PRT
S0 SET WRDN=$PIECE(^FH(119.6,W1,0),"^",1)
SET FHDFN=0
S1 SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
if FHDFN=""
QUIT
SET ADM=$GET(^FHPT("AW",W1,FHDFN))
if ADM<1
GOTO S1
+1 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
GOTO S1
SET X1=^(0)
SET NO=$PIECE(X1,"^",7)
if 'NO
GOTO S1
+2 SET Y=$PIECE(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3)
if Y?."^"
GOTO S1
DO CALC
+3 GOTO S1
PRT SET DTP=DT
DO DTP^FH
SET DTE=DTP_" "_$SELECT(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM")
+1 SET Y=$SELECT(XX="S":$PIECE($GET(^FH(119.74,D1,0)),"^",1),1:WRDN)
+2 WRITE @IOF
if D3=2
WRITE !?5,"**** CONSOLIDATED ****"
WRITE !?3,"**** INGREDIENTS LIST ****",!
if D3=1
WRITE !
WRITE ?(33-$LENGTH(Y)\2),Y,!?9,DTE,!!
+3 FOR L=0:0
SET L=$ORDER(^FH(118,L))
if L<1
QUIT
if $DATA(C(L))
SET ^TMP($JOB,"SF",$PIECE($GET(^FH(118,L,0)),"^",1),L)=""
+4 SET A1=""
FOR
SET A1=$ORDER(^TMP($JOB,"SF",A1))
if A1=""
QUIT
FOR L=0:0
SET L=$ORDER(^TMP($JOB,"SF",A1,L))
if L<1
QUIT
WRITE !,$EXTRACT(A1,1,26),?28,$JUSTIFY(C(L),5,0)
+5 WRITE !!?4,"**** PATIENTS = ",N1," ****",!
QUIT
CALC SET N1=N1+1
+1 FOR L=1:2:P3
SET Z=$PIECE(Y,"^",L)
IF Z'=""
SET Q=$PIECE(Y,"^",L+1)
if 'Q
SET Q=1
if '$DATA(C(Z))
SET C(Z)=0
SET C(Z)=C(Z)+Q
+2 QUIT
+3 ;
SF0 ;outpatient SFs
+1 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",DT,FHDFN))
if FHDFN'>0
QUIT
FOR ADM=0:0
SET ADM=$ORDER(^FHPT("RM",DT,FHDFN,ADM))
if ADM'>0
QUIT
Begin DoDot:1
+2 SET FHODAT=$GET(^FHPT(FHDFN,"OP",ADM,0))
SET FHNO=$PIECE($GET(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3)
if '$GET(FHNO)
QUIT
+3 SET FHMEAL=$PIECE(FHODAT,U,4)
SET FHOWARD=$PIECE(FHODAT,U,3)
+4 SET X1=$GET(^FH(119.6,FHOWARD,0))
+5 if 'FHOWARD!'$DATA(^FH(119.6,FHOWARD,0))
QUIT
+6 IF XX="W"
IF W1
if W1'=FHOWARD
QUIT
+7 SET WRDN=$PIECE(X1,U,1)
+8 IF XX="S"
SET D2=$PIECE(X1,"^",9)
if D1'=D2
QUIT
IF D1=D2
SET P0=$PIECE(X1,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
+9 SET P1=$SELECT(FHMEAL="N":13,FHMEAL="E":21,1:5)
+10 IF (FHMEAL="B")
IF (TIM'=10)
QUIT
+11 IF (FHMEAL="N")
IF (TIM'=2)
QUIT
+12 IF (FHMEAL="E")
IF (TIM'=8)
QUIT
+13 IF 'D3
SET IS=$PIECE($GET(^FHPT(FHDFN,0)),"^",5)
IF IS
SET IS=$PIECE($GET(^FH(119.4,IS,0)),"^",3)
if IS'="N"
SET IS=""
+14 SET Y=$GET(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0))
+15 SET Y=$PIECE(Y,"^",P1,P1+7)
if Y?."^"
QUIT
IF D3
DO CLC1
+16 SET N1=N1+1
+17 SET RM=""
SET RMIEN=$PIECE(FHODAT,U,18)
IF $GET(RMIEN)
IF $DATA(^DG(405.4,RMIEN,0))
SET RM=$EXTRACT($PIECE(^DG(405.4,RMIEN,0),U,1),1,10)
+18 IF 'D3
Begin DoDot:2
+19 DO PATNAME^FHOMUTL
+20 SET $PIECE(Y,"^",9)=IS
+21 SET LNOD=$SELECT(XX="S":D2_"~"_$PIECE($GET(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN)
+22 SET RI="***"
SET RE=$SELECT(RI:$ORDER(^FH(119.6,"AR",+RI,W1,0)),1:"")
+23 SET R0=$SELECT(RE:$PIECE($GET(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
+24 SET R0=$SELECT(R0<1:99,R0<10:"0"_R0,1:R0)
+25 SET PNOD=P0_"~"_R0_RM_"~"_FHDFN
SET WRD=P0_$EXTRACT(WRDN,1,20-$LENGTH(RM))_"/"_RM
+26 SET ^TMP($JOB,"L",LNOD,PNOD)=Y_"^"_WRD
End DoDot:2
End DoDot:1
+27 QUIT
CLC1 ;
+1 FOR L=1:2:P3
SET Z=$PIECE(Y,"^",L)
IF Z'=""
SET Q=$PIECE(Y,"^",L+1)
if 'Q
SET Q=1
if '$DATA(C(Z))
SET C(Z)=0
SET C(Z)=C(Z)+Q
+2 QUIT
