- 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 Jan 18, 2025@02:56:46 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