FHDCR1A ; HISC/REL/NCA/RVD - Build Diet Cards ;1/21/99 14:04
;;5.5;DIETETICS;**1,5,15**;Jan 28, 2005;Build 2
;patch #5 - added the screen for cancelled Guest meal.
;patch #15 - added the screen to prevent reprint of outpatient meal diet cards
B1 ; Store wards
K ^TMP($J),NN,N,P S MFLG=0 D Q1^FHDCR1B D NOW^%DTC S (DTP,TIM)=% D DTP^FH S HD=DTP S:MEAL="A" MFLG=1
S DTP=D1 D DTP^FH S (MDT,MEALDT)=DTP,MEALDT=$J("",62-$L(MEALDT)\2)_MEALDT
S FHBOT=$P($G(^FH(119.9,1,4)),"^",1)
S FHD1=D1-.00001,FHD2=D1+.99999
S FHDFNSAV="",FHW1SAV=W1,FHFHPSAV=FHP,FHMEALSA=MEAL
S:$G(FHDFN) FHDFNSAV=FHDFN
I $G(DFN),'$D(^DPT(DFN,.1)) G OUTALL
I '$G(DFN),$G(FHDFN) G OUTALL
;next process inpatient data
DFN I $G(DFN),$G(FHDFN) D Q
.S ADM=+$G(^DPT(DFN,.105)),W1=+$P($G(^FHPT(FHDFN,"A",+ADM,0)),"^",8)
.S K1=$G(^FH(119.6,+W1,0)),WRDN=$P(K1,"^",1),SP=$P(K1,"^",5),SP1=$P(K1,"^",6),FHPAR=$P(K1,"^",24),RM=$G(^DPT(DFN,.101))
.I 'SP Q:FHPAR'="Y" S SP=SP1 Q:'SP
.K PP,S,MM S NBR=0
.I 'TPP D BLD^FHDCR11 D:NBR UPD,PRT^FHDCR1C Q
.I 'MFLG D BLD^FHDCR1D D:NBR UPD,PRT^FHMTK1C Q
.F MEAL="B","N","E" D BLD^FHDCR1D
.D UPD
.D:NBR PRT^FHMTK1C
;if ward, do specific ward/location;otherwise, do all entry for all
;wards/locations and all communication offices.
WARD I W1 S ^TMP($J,"W","01"_$P($G(^FH(119.6,+W1,0)),"^",1))=W1_"^"_$P($G(^FH(119.6,+W1,0)),"^",5,6)_"^"_$P($G(^FH(119.6,+W1,0)),"^",24)
E F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 D
.S P0=$G(^FH(119.6,W1,0)),WRDN=$P(P0,"^",1),SP=$P(P0,"^",5,6),D2=$P(P0,"^",8),FHPAR=$P(P0,"^",24),P0=$P(P0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
.I FHP,D2'=FHP Q
.S ^TMP($J,"W",P0_WRDN)=W1_"^"_SP_"^"_FHPAR Q
S NX="" F S NX=$O(^TMP($J,"W",NX)) Q:NX="" S X1=$G(^(NX)),W1=+X1,FHS=$P(X1,"^",2),SP1=$P(X1,"^",3),FHPAR=$P(X1,"^",4),WRDN=$E(NX,3,99) S:'FHS&(FHPAR="Y") FHS=SP1 I FHS K ^TMP($J,"D") D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 D
..D PATNAME^FHOMUTL Q:'$G(DFN)
..S ADM=$G(^FHPT("AW",W1,FHDFN))
..I SORT="A" S RM=$P($G(^DPT(DFN,0)),"^",1),DL=0,RMB=$G(^DPT(DFN,.101)) S:RMB="" RMB="***"
..E S RI=$G(^DPT(DFN,.108)),RM=$G(^DPT(DFN,.101)) S:RM="" RM="***" S:RI RE=$O(^FH(119.6,"AR",+RI,W1,0)) S:'RI RE="" S DL=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:""),RMB=""
..S DL=$S(DL<1:99,DL<10:"0"_DL,1:DL)
..S ^TMP($J,"D",DL_"~"_RM_"~"_$S(SORT="R":DFN,1:RMB))=DFN_"^"_ADM_"^"_FHDFN Q
.;
.K ^TMP($J,"MP"),^TMP($J,0),MM,PP,S S X9="",NBR=0 F S X9=$O(^TMP($J,"D",X9)) Q:X9="" S FHX6=$G(^(X9)) S DFN=$P(FHX6,"^",1),ADM=$P(FHX6,"^",2) D
..S FHDFN=$P(FHX6,"^",3)
..S RM=$S(SORT="R":$P(X9,"~",2),1:$P(X9,"~",3)) S SP=FHS
..I TPP D Q
...I 'MFLG D BLD^FHDCR1D,UPD Q
...F MEAL="B","N","E" D BLD^FHDCR1D
...D UPD
...Q
..I 'TPP D BLD^FHDCR11 D UPD Q
.I NBR,TPP D PRT^FHMTK1C Q
.D:NBR PRT^FHDCR1C
;
OUTALL K ^TMP($J,"D") ;reset/clean-up tmp global outpatient process.
;process outpatient data
;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 FHRMB=$P(FHKDAT,U,18)
...S FHDIET=$P(FHKDAT,U,2),FHMEAL=$P(FHKDAT,U,4),FHDCLP=$P(FHKDAT,U,14),FHSTAT=$P(FHKDAT,U,15),FHDRMLE=$P(FHKDAT,U,16)
...S:FHDIET="" FHDIET=$E(FHKDAT,7,11)
...I (FHMEALSA'="A"),(FHMEAL'=FHMEALSA) Q
...I FHSTAT="C" Q
...I UPD,FHDCLP'="",FHDRMLE="" Q
...I UPD,FHDCLP'="",FHDRMLE'="",FHDCLP>FHDRMLE Q
...I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
...I $G(FHDFNSAV),(FHDFN'=FHDFNSAV) Q
...S FHLOC="",FHRGS="OP"
...Q:'$G(FHW1)
...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)
...I $G(FHW1SAV)!($G(FHFHPSAV)) D OUTW Q
...I $G(FHDFNSAV) D OUTP Q
...D OUTW
;next guest
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
..S FHKDAT=^FHPT(FHDFN,"GM",FHKD,0)
..S (W1,FHW1)=$P(FHKDAT,U,5)
..S FHSTAT=$P(FHKDAT,U,9),FHDCLP=$P(FHKDAT,U,8)
..Q:FHSTAT="C"
..I UPD,FHDCLP'="" Q
..S FHRMB=$P(FHKDAT,U,11)
..S FHDIET=$P(FHKDAT,U,6),FHMEAL=$P(FHKDAT,U,3)
..I (FHMEALSA'="A"),(FHMEAL'=FHMEALSA) Q
..I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
..I $G(FHDFNSAV),(FHDFN'=FHDFNSAV) Q
..S FHLOC="",FHRGS="GM"
..Q:'$G(FHW1)
..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)
..I $G(FHW1SAV)!($G(FHFHPSAV)) D OUTW Q
..I $G(FHDFNSAV) D OUTP Q
..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
..S FHKDAT=^FHPT(FHDFN,"SM",FHKD,0)
..S (W1,FHW1)=$P(FHKDAT,U,3)
..S FHRMB=$P(FHKDAT,U,13)
..S FHDFN1=$P(^FHPT(FHDFN,0),U,1)
..S FHDIET=$P(FHKDAT,U,4),FHMEAL=$P(FHKDAT,U,9),FHSTAT=$P(FHKDAT,U,2),FHDCLP=$P(FHKDAT,U,11)
..I (FHMEALSA'="A"),(FHMEAL'=FHMEALSA) Q
..I (FHSTAT="C")!(FHSTAT="D") Q
..I UPD,FHDCLP'="" Q
..I $G(FHW1SAV),(FHW1'=FHW1SAV) Q
..I $G(FHDFNSAV),(FHDFN'=FHDFNSAV) Q
..S FHLOC="",FHRGS="SM"
..Q:'$G(FHW1)
..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)
..I $G(FHW1SAV)!($G(FHFHPSAV)) D OUTW Q
..I $G(FHDFNSAV) D OUTP Q
..D OUTW
;
K ^TMP($J,"MP"),^TMP($J,0),MM,PP,S S X9="",NBR=0 F S X9=$O(^TMP($J,"D",X9)) Q:X9="" S FHX6=$G(^(X9)) S FHDFN=$P(FHX6,"^",1),ADM=$P(FHX6,"^",2) D
.S RM=$S(SORT="R":$P(X9,"~",2),1:$P(X9,"~",3)) S SP=FHS
.S FHDFN=$P(FHX6,"^",1),FHRGS=$P(FHX6,"^",2)
.D PATNAME^FHOMUTL
.S FHKD=$P(FHX6,"^",3),W1=$P(FHX6,"^",4)
.Q:$G(FHRGS)!('$G(FHKD))
.S FHSTAT="",FHADM=FHKD
.S FHKDAT=$G(^FHPT(FHDFN,""_FHRGS_"",FHKD,0))
.I FHRGS="GM" S W1=$P(FHKDAT,U,5),FHDIET=$P(FHKDAT,U,6),FHMEAL=$P(FHKDAT,U,3)
.I FHRGS="OP" S W1=$P(FHKDAT,U,3),FHDIET=$P(FHKDAT,U,2),FHMEAL=$P(FHKDAT,U,4),FHSTAT=$P(FHKDAT,U,15)
.I FHRGS="SM" S W1=$P(FHKDAT,U,3),FHDIET=$P(FHKDAT,U,4),FHMEAL=$P(FHKDAT,U,9),FHSTAT=$P(FHKDAT,U,2)
.;don't process IF STATUS IS cancelled or denied
.I (FHSTAT="C")!(FHSTAT="D") Q
.S K1=$G(^FH(119.6,+W1,0)),WRDN=$P(K1,"^",1),SP=$P(K1,"^",5),SP1=$P(K1,"^",6),FHPAR=$P(K1,"^",24)
.I 'SP Q:FHPAR'="Y" S SP=SP1 Q:'SP
.I TPP D Q
..I 'MFLG,'ADM D OUT^FHDCR1D,@FHRGS Q
..F MEAL="B","N","E" D:'ADM OUT^FHDCR1D
..D:'ADM @FHRGS
.I 'TPP,'ADM D OUT^FHDCR11 D @FHRGS Q
I NBR,TPP D PRT^FHMTK1C Q
D:NBR PRT^FHDCR1C
Q
;
UPD ; Update Date/Time Diet Card was Printed
S $P(^FHPT(FHDFN,"A",ADM,0),"^",16)=TIM Q
OUTP ;process outpatient using patient
S RM="***"
S K1=$G(^FH(119.6,+W1,0)),WRDN=$P(K1,"^",1),SP=$P(K1,"^",5),SP1=$P(K1,"^",6),FHPAR=$P(K1,"^",24)
I 'SP Q:FHPAR'="Y" S SP=SP1 Q:'SP
K PP,S,MM S NBR=0,FHADM=FHKD I $G(FHRMB),$D(^DG(405.4,FHRMB,0)) S RM=$P(^DG(405.4,FHRMB,0),U,1)
I 'TPP D OUT^FHDCR11 D:NBR @FHRGS,PRT^FHDCR1C K ^TMP($J,"MP"),^TMP($J,0),PP,S,TT,SRT Q
I 'MFLG D OUT^FHDCR1D D:NBR @FHRGS,PRT^FHMTK1C Q
F MEAL="B","N","E" D OUT^FHDCR1D
D @FHRGS
D:NBR PRT^FHMTK1C
Q
OP S $P(^FHPT(FHDFN,"OP",FHKD,0),"^",14)=TIM Q
GM S $P(^FHPT(FHDFN,"GM",FHKD,0),"^",8)=TIM Q
SM S $P(^FHPT(FHDFN,"SM",FHKD,0),"^",11)=TIM Q
;
OUTW ;process outpatient using all and ward.
;F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 D
D PATNAME^FHOMUTL
S (RM,RMB)="***"
I $G(FHRMB),$D(^DG(405.4,FHRMB,0)) S RMB=$P(^DG(405.4,FHRMB,0),U,1)
I SORT="A" S RM=FHPTNM,DL=0
E S (RI,RE,DL)="***",RM=RMB
S ^TMP($J,"D",DL_"~"_RM_"~"_$S(SORT="R":FHDFN,1:RMB)_FHMEAL)=FHDFN_"^"_FHRGS_"^"_FHKD_"^"_W1
Q
FHDCR1A ; HISC/REL/NCA/RVD - Build Diet Cards ;1/21/99 14:04
+1 ;;5.5;DIETETICS;**1,5,15**;Jan 28, 2005;Build 2
+2 ;patch #5 - added the screen for cancelled Guest meal.
+3 ;patch #15 - added the screen to prevent reprint of outpatient meal diet cards
B1 ; Store wards
+1 KILL ^TMP($JOB),NN,N,P
SET MFLG=0
DO Q1^FHDCR1B
DO NOW^%DTC
SET (DTP,TIM)=%
DO DTP^FH
SET HD=DTP
IF MEAL="A"
SET MFLG=1
+2 SET DTP=D1
DO DTP^FH
SET (MDT,MEALDT)=DTP
SET MEALDT=$JUSTIFY("",62-$LENGTH(MEALDT)\2)_MEALDT
+3 SET FHBOT=$PIECE($GET(^FH(119.9,1,4)),"^",1)
+4 SET FHD1=D1-.00001
SET FHD2=D1+.99999
+5 SET FHDFNSAV=""
SET FHW1SAV=W1
SET FHFHPSAV=FHP
SET FHMEALSA=MEAL
+6 IF $GET(FHDFN)
SET FHDFNSAV=FHDFN
+7 IF $GET(DFN)
IF '$DATA(^DPT(DFN,.1))
GOTO OUTALL
+8 IF '$GET(DFN)
IF $GET(FHDFN)
GOTO OUTALL
+9 ;next process inpatient data
DFN IF $GET(DFN)
IF $GET(FHDFN)
Begin DoDot:1
+1 SET ADM=+$GET(^DPT(DFN,.105))
SET W1=+$PIECE($GET(^FHPT(FHDFN,"A",+ADM,0)),"^",8)
+2 SET K1=$GET(^FH(119.6,+W1,0))
SET WRDN=$PIECE(K1,"^",1)
SET SP=$PIECE(K1,"^",5)
SET SP1=$PIECE(K1,"^",6)
SET FHPAR=$PIECE(K1,"^",24)
SET RM=$GET(^DPT(DFN,.101))
+3 IF 'SP
IF FHPAR'="Y"
QUIT
SET SP=SP1
IF 'SP
QUIT
+4 KILL PP,S,MM
SET NBR=0
+5 IF 'TPP
DO BLD^FHDCR11
IF NBR
DO UPD
DO PRT^FHDCR1C
QUIT
+6 IF 'MFLG
DO BLD^FHDCR1D
IF NBR
DO UPD
DO PRT^FHMTK1C
QUIT
+7 FOR MEAL="B","N","E"
DO BLD^FHDCR1D
+8 DO UPD
+9 IF NBR
DO PRT^FHMTK1C
End DoDot:1
QUIT
+10 ;if ward, do specific ward/location;otherwise, do all entry for all
+11 ;wards/locations and all communication offices.
WARD IF W1
SET ^TMP($JOB,"W","01"_$PIECE($GET(^FH(119.6,+W1,0)),"^",1))=W1_"^"_$PIECE($GET(^FH(119.6,+W1,0)),"^",5,6)_"^"_$PIECE($GET(^FH(119.6,+W1,0)),"^",24)
+1 IF '$TEST
FOR W1=0:0
SET W1=$ORDER(^FH(119.6,W1))
IF W1<1
QUIT
Begin DoDot:1
+2 SET P0=$GET(^FH(119.6,W1,0))
SET WRDN=$PIECE(P0,"^",1)
SET SP=$PIECE(P0,"^",5,6)
SET D2=$PIECE(P0,"^",8)
SET FHPAR=$PIECE(P0,"^",24)
SET P0=$PIECE(P0,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
+3 IF FHP
IF D2'=FHP
QUIT
+4 SET ^TMP($JOB,"W",P0_WRDN)=W1_"^"_SP_"^"_FHPAR
QUIT
End DoDot:1
+5 SET NX=""
FOR
SET NX=$ORDER(^TMP($JOB,"W",NX))
IF NX=""
QUIT
SET X1=$GET(^(NX))
SET W1=+X1
SET FHS=$PIECE(X1,"^",2)
SET SP1=$PIECE(X1,"^",3)
SET FHPAR=$PIECE(X1,"^",4)
SET WRDN=$EXTRACT(NX,3,99)
IF 'FHS&(FHPAR="Y")
SET FHS=SP1
IF FHS
KILL ^TMP($JOB,"D")
Begin DoDot:1
+6 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
IF FHDFN<1
QUIT
Begin DoDot:2
+7 DO PATNAME^FHOMUTL
IF '$GET(DFN)
QUIT
+8 SET ADM=$GET(^FHPT("AW",W1,FHDFN))
+9 IF SORT="A"
SET RM=$PIECE($GET(^DPT(DFN,0)),"^",1)
SET DL=0
SET RMB=$GET(^DPT(DFN,.101))
IF RMB=""
SET RMB="***"
+10 IF '$TEST
SET RI=$GET(^DPT(DFN,.108))
SET RM=$GET(^DPT(DFN,.101))
IF RM=""
SET RM="***"
IF RI
SET RE=$ORDER(^FH(119.6,"AR",+RI,W1,0))
IF 'RI
SET RE=""
SET DL=$SELECT(RE:$PIECE($GET(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
SET RMB=""
+11 SET DL=$SELECT(DL<1:99,DL<10:"0"_DL,1:DL)
+12 SET ^TMP($JOB,"D",DL_"~"_RM_"~"_$SELECT(SORT="R":DFN,1:RMB))=DFN_"^"_ADM_"^"_FHDFN
QUIT
End DoDot:2
+13 ;
+14 KILL ^TMP($JOB,"MP"),^TMP($JOB,0),MM,PP,S
SET X9=""
SET NBR=0
FOR
SET X9=$ORDER(^TMP($JOB,"D",X9))
IF X9=""
QUIT
SET FHX6=$GET(^(X9))
SET DFN=$PIECE(FHX6,"^",1)
SET ADM=$PIECE(FHX6,"^",2)
Begin DoDot:2
+15 SET FHDFN=$PIECE(FHX6,"^",3)
+16 SET RM=$SELECT(SORT="R":$PIECE(X9,"~",2),1:$PIECE(X9,"~",3))
SET SP=FHS
+17 IF TPP
Begin DoDot:3
+18 IF 'MFLG
DO BLD^FHDCR1D
DO UPD
QUIT
+19 FOR MEAL="B","N","E"
DO BLD^FHDCR1D
+20 DO UPD
+21 QUIT
End DoDot:3
QUIT
+22 IF 'TPP
DO BLD^FHDCR11
DO UPD
QUIT
End DoDot:2
+23 IF NBR
IF TPP
DO PRT^FHMTK1C
QUIT
+24 IF NBR
DO PRT^FHDCR1C
End DoDot:1
+25 ;
OUTALL ;reset/clean-up tmp global outpatient process.
KILL ^TMP($JOB,"D")
+1 ;process outpatient data
+2 ;next recurring
+3 FOR FHK1=FHD1:0
SET FHK1=$ORDER(^FHPT("RM",FHK1))
IF (FHK1'>0)!(FHK1>FHD2)
QUIT
Begin DoDot:1
+4 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",FHK1,FHDFN))
IF FHDFN'>0
QUIT
Begin DoDot:2
+5 FOR FHKD=0:0
SET FHKD=$ORDER(^FHPT("RM",FHK1,FHDFN,FHKD))
IF FHKD'>0
QUIT
Begin DoDot:3
+6 SET FHKDAT=^FHPT(FHDFN,"OP",FHKD,0)
+7 SET (W1,FHW1)=$PIECE(FHKDAT,U,3)
+8 SET FHRMB=$PIECE(FHKDAT,U,18)
+9 SET FHDIET=$PIECE(FHKDAT,U,2)
SET FHMEAL=$PIECE(FHKDAT,U,4)
SET FHDCLP=$PIECE(FHKDAT,U,14)
SET FHSTAT=$PIECE(FHKDAT,U,15)
SET FHDRMLE=$PIECE(FHKDAT,U,16)
+10 IF FHDIET=""
SET FHDIET=$EXTRACT(FHKDAT,7,11)
+11 IF (FHMEALSA'="A")
IF (FHMEAL'=FHMEALSA)
QUIT
+12 IF FHSTAT="C"
QUIT
+13 IF UPD
IF FHDCLP'=""
IF FHDRMLE=""
QUIT
+14 IF UPD
IF FHDCLP'=""
IF FHDRMLE'=""
IF FHDCLP>FHDRMLE
QUIT
+15 IF $GET(FHW1SAV)
IF (FHW1'=FHW1SAV)
QUIT
+16 IF $GET(FHDFNSAV)
IF (FHDFN'=FHDFNSAV)
QUIT
+17 SET FHLOC=""
SET FHRGS="OP"
+18 IF '$GET(FHW1)
QUIT
+19 IF $DATA(^FH(119.6,FHW1,0))
SET FHLOC=$PIECE(^FH(119.6,FHW1,0),U,8)
+20 IF $GET(FHFHPSAV)
IF $GET(FHLOC)
IF (FHFHPSAV'=FHLOC)
QUIT
+21 SET FHDFN1=$PIECE(^FHPT(FHDFN,0),U,1)
+22 IF $GET(FHW1SAV)!($GET(FHFHPSAV))
DO OUTW
QUIT
+23 IF $GET(FHDFNSAV)
DO OUTP
QUIT
+24 DO OUTW
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;next guest
+26 FOR FHKD=FHD1:0
SET FHKD=$ORDER(^FHPT("GM",FHKD))
IF (FHKD'>0)!(FHKD>FHD2)
QUIT
Begin DoDot:1
+27 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("GM",FHKD,FHDFN))
IF FHDFN'>0
QUIT
Begin DoDot:2
+28 SET FHKDAT=^FHPT(FHDFN,"GM",FHKD,0)
+29 SET (W1,FHW1)=$PIECE(FHKDAT,U,5)
+30 SET FHSTAT=$PIECE(FHKDAT,U,9)
SET FHDCLP=$PIECE(FHKDAT,U,8)
+31 IF FHSTAT="C"
QUIT
+32 IF UPD
IF FHDCLP'=""
QUIT
+33 SET FHRMB=$PIECE(FHKDAT,U,11)
+34 SET FHDIET=$PIECE(FHKDAT,U,6)
SET FHMEAL=$PIECE(FHKDAT,U,3)
+35 IF (FHMEALSA'="A")
IF (FHMEAL'=FHMEALSA)
QUIT
+36 IF $GET(FHW1SAV)
IF (FHW1'=FHW1SAV)
QUIT
+37 IF $GET(FHDFNSAV)
IF (FHDFN'=FHDFNSAV)
QUIT
+38 SET FHLOC=""
SET FHRGS="GM"
+39 IF '$GET(FHW1)
QUIT
+40 IF $DATA(^FH(119.6,FHW1,0))
SET FHLOC=$PIECE(^FH(119.6,FHW1,0),U,8)
+41 IF $GET(FHFHPSAV)
IF $GET(FHLOC)
IF (FHFHPSAV'=FHLOC)
QUIT
+42 SET FHDFN1=$PIECE(^FHPT(FHDFN,0),U,1)
+43 IF $GET(FHW1SAV)!($GET(FHFHPSAV))
DO OUTW
QUIT
+44 IF $GET(FHDFNSAV)
DO OUTP
QUIT
+45 DO OUTW
End DoDot:2
End DoDot:1
+46 ;next SPECIAL
+47 FOR FHKD=FHD1:0
SET FHKD=$ORDER(^FHPT("SM",FHKD))
IF (FHKD'>0)!(FHKD>FHD2)
QUIT
Begin DoDot:1
+48 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("SM",FHKD,FHDFN))
IF FHDFN'>0
QUIT
Begin DoDot:2
+49 SET FHKDAT=^FHPT(FHDFN,"SM",FHKD,0)
+50 SET (W1,FHW1)=$PIECE(FHKDAT,U,3)
+51 SET FHRMB=$PIECE(FHKDAT,U,13)
+52 SET FHDFN1=$PIECE(^FHPT(FHDFN,0),U,1)
+53 SET FHDIET=$PIECE(FHKDAT,U,4)
SET FHMEAL=$PIECE(FHKDAT,U,9)
SET FHSTAT=$PIECE(FHKDAT,U,2)
SET FHDCLP=$PIECE(FHKDAT,U,11)
+54 IF (FHMEALSA'="A")
IF (FHMEAL'=FHMEALSA)
QUIT
+55 IF (FHSTAT="C")!(FHSTAT="D")
QUIT
+56 IF UPD
IF FHDCLP'=""
QUIT
+57 IF $GET(FHW1SAV)
IF (FHW1'=FHW1SAV)
QUIT
+58 IF $GET(FHDFNSAV)
IF (FHDFN'=FHDFNSAV)
QUIT
+59 SET FHLOC=""
SET FHRGS="SM"
+60 IF '$GET(FHW1)
QUIT
+61 IF $DATA(^FH(119.6,FHW1,0))
SET FHLOC=$PIECE(^FH(119.6,FHW1,0),U,8)
+62 IF $GET(FHFHPSAV)
IF $GET(FHLOC)
IF (FHFHPSAV'=FHLOC)
QUIT
+63 SET FHDFN1=$PIECE(^FHPT(FHDFN,0),U,1)
+64 IF $GET(FHW1SAV)!($GET(FHFHPSAV))
DO OUTW
QUIT
+65 IF $GET(FHDFNSAV)
DO OUTP
QUIT
+66 DO OUTW
End DoDot:2
End DoDot:1
+67 ;
+68 KILL ^TMP($JOB,"MP"),^TMP($JOB,0),MM,PP,S
SET X9=""
SET NBR=0
FOR
SET X9=$ORDER(^TMP($JOB,"D",X9))
IF X9=""
QUIT
SET FHX6=$GET(^(X9))
SET FHDFN=$PIECE(FHX6,"^",1)
SET ADM=$PIECE(FHX6,"^",2)
Begin DoDot:1
+69 SET RM=$SELECT(SORT="R":$PIECE(X9,"~",2),1:$PIECE(X9,"~",3))
SET SP=FHS
+70 SET FHDFN=$PIECE(FHX6,"^",1)
SET FHRGS=$PIECE(FHX6,"^",2)
+71 DO PATNAME^FHOMUTL
+72 SET FHKD=$PIECE(FHX6,"^",3)
SET W1=$PIECE(FHX6,"^",4)
+73 IF $GET(FHRGS)!('$GET(FHKD))
QUIT
+74 SET FHSTAT=""
SET FHADM=FHKD
+75 SET FHKDAT=$GET(^FHPT(FHDFN,""_FHRGS_"",FHKD,0))
+76 IF FHRGS="GM"
SET W1=$PIECE(FHKDAT,U,5)
SET FHDIET=$PIECE(FHKDAT,U,6)
SET FHMEAL=$PIECE(FHKDAT,U,3)
+77 IF FHRGS="OP"
SET W1=$PIECE(FHKDAT,U,3)
SET FHDIET=$PIECE(FHKDAT,U,2)
SET FHMEAL=$PIECE(FHKDAT,U,4)
SET FHSTAT=$PIECE(FHKDAT,U,15)
+78 IF FHRGS="SM"
SET W1=$PIECE(FHKDAT,U,3)
SET FHDIET=$PIECE(FHKDAT,U,4)
SET FHMEAL=$PIECE(FHKDAT,U,9)
SET FHSTAT=$PIECE(FHKDAT,U,2)
+79 ;don't process IF STATUS IS cancelled or denied
+80 IF (FHSTAT="C")!(FHSTAT="D")
QUIT
+81 SET K1=$GET(^FH(119.6,+W1,0))
SET WRDN=$PIECE(K1,"^",1)
SET SP=$PIECE(K1,"^",5)
SET SP1=$PIECE(K1,"^",6)
SET FHPAR=$PIECE(K1,"^",24)
+82 IF 'SP
IF FHPAR'="Y"
QUIT
SET SP=SP1
IF 'SP
QUIT
+83 IF TPP
Begin DoDot:2
+84 IF 'MFLG
IF 'ADM
DO OUT^FHDCR1D
DO @FHRGS
QUIT
+85 FOR MEAL="B","N","E"
IF 'ADM
DO OUT^FHDCR1D
+86 IF 'ADM
DO @FHRGS
End DoDot:2
QUIT
+87 IF 'TPP
IF 'ADM
DO OUT^FHDCR11
DO @FHRGS
QUIT
End DoDot:1
+88 IF NBR
IF TPP
DO PRT^FHMTK1C
QUIT
+89 IF NBR
DO PRT^FHDCR1C
+90 QUIT
+91 ;
UPD ; Update Date/Time Diet Card was Printed
+1 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",16)=TIM
QUIT
OUTP ;process outpatient using patient
+1 SET RM="***"
+2 SET K1=$GET(^FH(119.6,+W1,0))
SET WRDN=$PIECE(K1,"^",1)
SET SP=$PIECE(K1,"^",5)
SET SP1=$PIECE(K1,"^",6)
SET FHPAR=$PIECE(K1,"^",24)
+3 IF 'SP
IF FHPAR'="Y"
QUIT
SET SP=SP1
IF 'SP
QUIT
+4 KILL PP,S,MM
SET NBR=0
SET FHADM=FHKD
IF $GET(FHRMB)
IF $DATA(^DG(405.4,FHRMB,0))
SET RM=$PIECE(^DG(405.4,FHRMB,0),U,1)
+5 IF 'TPP
DO OUT^FHDCR11
IF NBR
DO @FHRGS
DO PRT^FHDCR1C
KILL ^TMP($JOB,"MP"),^TMP($JOB,0),PP,S,TT,SRT
QUIT
+6 IF 'MFLG
DO OUT^FHDCR1D
IF NBR
DO @FHRGS
DO PRT^FHMTK1C
QUIT
+7 FOR MEAL="B","N","E"
DO OUT^FHDCR1D
+8 DO @FHRGS
+9 IF NBR
DO PRT^FHMTK1C
+10 QUIT
OP SET $PIECE(^FHPT(FHDFN,"OP",FHKD,0),"^",14)=TIM
QUIT
GM SET $PIECE(^FHPT(FHDFN,"GM",FHKD,0),"^",8)=TIM
QUIT
SM SET $PIECE(^FHPT(FHDFN,"SM",FHKD,0),"^",11)=TIM
QUIT
+1 ;
OUTW ;process outpatient using all and ward.
+1 ;F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 D
+2 DO PATNAME^FHOMUTL
+3 SET (RM,RMB)="***"
+4 IF $GET(FHRMB)
IF $DATA(^DG(405.4,FHRMB,0))
SET RMB=$PIECE(^DG(405.4,FHRMB,0),U,1)
+5 IF SORT="A"
SET RM=FHPTNM
SET DL=0
+6 IF '$TEST
SET (RI,RE,DL)="***"
SET RM=RMB
+7 SET ^TMP($JOB,"D",DL_"~"_RM_"~"_$SELECT(SORT="R":FHDFN,1:RMB)_FHMEAL)=FHDFN_"^"_FHRGS_"^"_FHKD_"^"_W1
+8 QUIT
