FHWOR8 ; HISC/NCA - Dietetics Order Parameter ;2/24/95 07:56 ;
;;5.5;DIETETICS;;Jan 28, 2005;
EN(DFN,FHPAR) ; Get the Order Parameter by passing the DFN and Variable
; array FHPAR(1)-FHPAR(3) is returned.
N WARD,ADM,DP,FHWRD
S FHPAR="",WARD=$G(^DPT(DFN,.1)) G:WARD="" EXIT
S ADM=$G(^DPT("CN",WARD,DFN)) G:ADM<1 EXIT
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
S FHWRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8),DP=$P($G(^FH(119.6,+FHWRD,0)),"^",8)
S FHPAR(1)=$G(^FH(119.73,+DP,1)),FHPAR(2)=$G(^FH(119.73,+DP,2))
S FHPAR(3)=$P($G(^FH(119.6,+FHWRD,0)),"^",10)
EXIT Q
;
EN1(LOC,FHPAR) ; Get the Order Parameters by passing the WARD/HOSP LOCATION
; array FHPAR(1)-FHPAR(3) is returned.
K FHPAR N DP,FHVPTR,FHLOC
S FHVPTR=$P(LOC,";",1)
I LOC["SC" S FHLOC=$O(^FH(119.6,"AL",FHVPTR,"")) I FHLOC="" D
.S FHVPTR=$G(^SC(FHVPTR,42)) Q:FHVPTR="" S FHLOC=$O(^FH(119.6,"AW",FHVPTR,""))
I LOC'["SC" S FHLOC=$O(^FH(119.6,"AW",FHVPTR,"")) I FHLOC="" D
.S FHVPTR=$G(^DIC(42,FHVPTR,44)) Q:FHVPTR="" S FHLOC=$O(^FH(119.6,"AL",FHVPTR,""))
I FHLOC="" Q
S DP=$P($G(^FH(119.6,+FHLOC,0)),"^",8) I DP="" Q
S FHPAR(1)=$G(^FH(119.73,+DP,1)),FHPAR(2)=$G(^FH(119.73,+DP,2))
S FHPAR(3)=$P($G(^FH(119.6,+FHLOC,0)),"^",10)
Q
EN2(DFN,FHM,FHPAR) ; Get the list of meal dates by passing the DFN/MEAL
; array FHPAR() is returned.
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
K FHPAR S FHINDX=0
D NOW^%DTC S FHNOW=X,X1=FHNOW,X2=-1 D C^%DTC S FHNOW=X
I '$O(^FHPT(FHDFN,"OP","B",FHNOW)) Q
F FHRM=FHNOW:0 S FHRM=$O(^FHPT(FHDFN,"OP","B",FHRM)) Q:FHRM'>0 D
.F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHRM,FHRNUM)) Q:FHRNUM'>0 D
..I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C" Q
..S FHMEAL1=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)
..I FHM'="",FHM'=FHMEAL1 Q
..S FHINDX=FHINDX+1
..S FHPAR(FHINDX)=FHRM_"^"_FHMEAL1 Q
Q
EN3(DFN,FHPAR) ; Get the list of recurring meal dates by passing the DFN
; array FHPAR() is returned.
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
K FHPAR S FHINDX=0
D NOW^%DTC S FHNOW=X,X1=FHNOW,X2=-1 D C^%DTC S FHNOW=X
I '$O(^FHPT(FHDFN,"OP","B",FHNOW)) Q
F FHRM=FHNOW:0 S FHRM=$O(^FHPT(FHDFN,"OP","B",FHRM)) Q:FHRM'>0 D
.F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHRM,FHRNUM)) Q:FHRNUM'>0 D
..I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C" Q
..S FHMEAL1=$P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)
..S FHINDX=FHINDX+1
..S FHPAR(FHINDX)=FHRM_"^"_FHMEAL1 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHWOR8 2439 printed Dec 13, 2024@01:55:33 Page 2
FHWOR8 ; HISC/NCA - Dietetics Order Parameter ;2/24/95 07:56 ;
+1 ;;5.5;DIETETICS;;Jan 28, 2005;
EN(DFN,FHPAR) ; Get the Order Parameter by passing the DFN and Variable
+1 ; array FHPAR(1)-FHPAR(3) is returned.
+2 NEW WARD,ADM,DP,FHWRD
+3 SET FHPAR=""
SET WARD=$GET(^DPT(DFN,.1))
if WARD=""
GOTO EXIT
+4 SET ADM=$GET(^DPT("CN",WARD,DFN))
if ADM<1
GOTO EXIT
+5 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+6 SET FHWRD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
SET DP=$PIECE($GET(^FH(119.6,+FHWRD,0)),"^",8)
+7 SET FHPAR(1)=$GET(^FH(119.73,+DP,1))
SET FHPAR(2)=$GET(^FH(119.73,+DP,2))
+8 SET FHPAR(3)=$PIECE($GET(^FH(119.6,+FHWRD,0)),"^",10)
EXIT QUIT
+1 ;
EN1(LOC,FHPAR) ; Get the Order Parameters by passing the WARD/HOSP LOCATION
+1 ; array FHPAR(1)-FHPAR(3) is returned.
+2 KILL FHPAR
NEW DP,FHVPTR,FHLOC
+3 SET FHVPTR=$PIECE(LOC,";",1)
+4 IF LOC["SC"
SET FHLOC=$ORDER(^FH(119.6,"AL",FHVPTR,""))
IF FHLOC=""
Begin DoDot:1
+5 SET FHVPTR=$GET(^SC(FHVPTR,42))
if FHVPTR=""
QUIT
SET FHLOC=$ORDER(^FH(119.6,"AW",FHVPTR,""))
End DoDot:1
+6 IF LOC'["SC"
SET FHLOC=$ORDER(^FH(119.6,"AW",FHVPTR,""))
IF FHLOC=""
Begin DoDot:1
+7 SET FHVPTR=$GET(^DIC(42,FHVPTR,44))
if FHVPTR=""
QUIT
SET FHLOC=$ORDER(^FH(119.6,"AL",FHVPTR,""))
End DoDot:1
+8 IF FHLOC=""
QUIT
+9 SET DP=$PIECE($GET(^FH(119.6,+FHLOC,0)),"^",8)
IF DP=""
QUIT
+10 SET FHPAR(1)=$GET(^FH(119.73,+DP,1))
SET FHPAR(2)=$GET(^FH(119.73,+DP,2))
+11 SET FHPAR(3)=$PIECE($GET(^FH(119.6,+FHLOC,0)),"^",10)
+12 QUIT
EN2(DFN,FHM,FHPAR) ; Get the list of meal dates by passing the DFN/MEAL
+1 ; array FHPAR() is returned.
+2 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+3 KILL FHPAR
SET FHINDX=0
+4 DO NOW^%DTC
SET FHNOW=X
SET X1=FHNOW
SET X2=-1
DO C^%DTC
SET FHNOW=X
+5 IF '$ORDER(^FHPT(FHDFN,"OP","B",FHNOW))
QUIT
+6 FOR FHRM=FHNOW:0
SET FHRM=$ORDER(^FHPT(FHDFN,"OP","B",FHRM))
if FHRM'>0
QUIT
Begin DoDot:1
+7 FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","B",FHRM,FHRNUM))
if FHRNUM'>0
QUIT
Begin DoDot:2
+8 IF $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C"
QUIT
+9 SET FHMEAL1=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)
+10 IF FHM'=""
IF FHM'=FHMEAL1
QUIT
+11 SET FHINDX=FHINDX+1
+12 SET FHPAR(FHINDX)=FHRM_"^"_FHMEAL1
QUIT
End DoDot:2
End DoDot:1
+13 QUIT
EN3(DFN,FHPAR) ; Get the list of recurring meal dates by passing the DFN
+1 ; array FHPAR() is returned.
+2 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+3 KILL FHPAR
SET FHINDX=0
+4 DO NOW^%DTC
SET FHNOW=X
SET X1=FHNOW
SET X2=-1
DO C^%DTC
SET FHNOW=X
+5 IF '$ORDER(^FHPT(FHDFN,"OP","B",FHNOW))
QUIT
+6 FOR FHRM=FHNOW:0
SET FHRM=$ORDER(^FHPT(FHDFN,"OP","B",FHRM))
if FHRM'>0
QUIT
Begin DoDot:1
+7 FOR FHRNUM=0:0
SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","B",FHRM,FHRNUM))
if FHRNUM'>0
QUIT
Begin DoDot:2
+8 IF $PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C"
QUIT
+9 SET FHMEAL1=$PIECE($GET(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)
+10 SET FHINDX=FHINDX+1
+11 SET FHPAR(FHINDX)=FHRM_"^"_FHMEAL1
QUIT
End DoDot:2
End DoDot:1
+12 QUIT
