- FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;7/2/2007
- ;;5.5;DIETETICS;**9**;Jan 28, 2005;Build 7
- D DEV Q
- DEV ;get device and set up queue
- W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP
- I '$D(IO("Q")) U IO D DISP,^%ZISC,END Q
- S ZTRTN="DISP^FHOMPP"
- S ZTSAVE("FHDFN")=""
- S ZTDESC="Outpatient Meals Recurring Meals Display" D ^%ZTLOAD
- D ^%ZISC K %ZIS,IOP
- D END Q
- DISP ;
- S EX="" D HDR
- D ALG^FHCLN I ALG'="" W !!,"Allergies: ",ALG
- K ^TMP($J) F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D
- .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0))
- .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3)
- .Q:FHFPIEN=""
- .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4)
- .S FHMEAL=FHNORD_FHMEAL
- .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD=""
- .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM=""
- .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM
- .Q
- W !!,"Food Preferences Currently on file: "
- I $D(^TMP($J,"L")) W !!?20,"Likes"
- S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM=""!(EX=U) D
- .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0 W !!,^TMP($J,"L",FHM,FHP) I $Y>(IOSL-4) D PG I EX=U Q
- I $D(^TMP($J,"D")) W !!?20,"Dislikes"
- S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM=""!(EX=U) D
- .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0 W !!,^TMP($J,"D",FHM,FHP) I $Y>(IOSL-4) D PG I EX=U Q
- ;
- S FHIPX=$P($G(^FHPT(FHDFN,0)),U,5) I FHIPX'="" W !!,"Isolation/Precaution type is ",$P($G(^FH(119.4,FHIPX,0)),"^",1) I $Y>(IOSL-4) D PG I EX=U Q
- W !!,"Recurring Meals on File: " I $Y>(IOSL-4) D PG I EX=U Q
- W ! S STDT=DT S FHPP=1 D DISP^FHOMRR1 K FHPP
- I EX'=U,IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR
- Q
- PG ;
- I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q
- D HDR Q
- HDR ;
- W:$Y @IOF
- W !!,"OUTPATIENT NAME: " D PATNAME^FHOMUTL W FHPTNM," ",FHSSN
- W ?65,FHSEX," Age ",FHAGE Q
- END ;
- K FHM,FHP,FHT Q
- ;
- CPRS ; Call from FHWOR71 to get outpatient profile for CPRS
- ; Data is returned in ^TMP($J,"FHPROF",DFN,FHX)
- S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q "-1^Invalid outpatient"
- K ^TMP($J,"FHPROF"),^TMP($J,"L"),^TMP($J,"D") S (FHX,N)=0 D PATNAME^FHOMUTL
- S FHB="" F I=1:1:80 S FHB=FHB_" "
- S ^TMP($J,"FHPROF",DFN,FHX)="OUTPATIENT NAME: "_FHPTNM_" "_FHSSN
- S FHJ=66 D PAD^FHOMPP1 S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"FHPROF",DFN,FHX)_PAD_FHSEX_" Age "_FHAGE
- D ALG^FHCLN I ALG'="" S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Allergies: "_ALG
- F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D
- .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0))
- .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3)
- .Q:FHFPIEN=""
- .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4)
- .S FHMEAL=FHNORD_FHMEAL
- .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD=""
- .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM=""
- .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM
- .Q
- S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Food Preferences Currently on file: "
- I $D(^TMP($J,"L")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Likes"
- S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM="" D
- .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"L",FHM,FHP)
- I $D(^TMP($J,"D")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Dislikes"
- S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM="" D
- .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"D",FHM,FHP)
- ;
- S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Recurring Meals on File: "
- S STDT=DT D ^FHOMPP1
- Q
- NEWL ;New line before next line of text in ^TMP global
- I N=1 S FHX=FHX+1,^TMP($J,"FHPROF",DFN,FHX)=" "
- S FHX=FHX+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMPP 3705 printed Feb 18, 2025@23:19:11 Page 2
- FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;7/2/2007
- +1 ;;5.5;DIETETICS;**9**;Jan 28, 2005;Build 7
- +2 DO DEV
- QUIT
- DEV ;get device and set up queue
- +1 WRITE !
- KILL %ZIS,IOP
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- +2 IF '$DATA(IO("Q"))
- USE IO
- DO DISP
- DO ^%ZISC
- DO END
- QUIT
- +3 SET ZTRTN="DISP^FHOMPP"
- +4 SET ZTSAVE("FHDFN")=""
- +5 SET ZTDESC="Outpatient Meals Recurring Meals Display"
- DO ^%ZTLOAD
- +6 DO ^%ZISC
- KILL %ZIS,IOP
- +7 DO END
- QUIT
- DISP ;
- +1 SET EX=""
- DO HDR
- +2 DO ALG^FHCLN
- IF ALG'=""
- WRITE !!,"Allergies: ",ALG
- +3 KILL ^TMP($JOB)
- FOR FHFP=0:0
- SET FHFP=$ORDER(^FHPT(FHDFN,"P",FHFP))
- if FHFP'>0
- QUIT
- Begin DoDot:1
- +4 SET FHFPZN=$GET(^FHPT(FHDFN,"P",FHFP,0))
- +5 SET FHFPIEN=$PIECE(FHFPZN,U,1)
- SET FHMEAL=$PIECE(FHFPZN,U,2)
- SET FHQTY=$PIECE(FHFPZN,U,3)
- +6 if FHFPIEN=""
- QUIT
- +7 SET FHNORD=$SELECT($LENGTH(FHMEAL)=3:1,$EXTRACT(FHMEAL)="B":2,$EXTRACT(FHMEAL)="N":3,1:4)
- +8 SET FHMEAL=FHNORD_FHMEAL
- +9 SET FHFPLD=$PIECE($GET(^FH(115.2,FHFPIEN,0)),U,2)
- if FHFPLD=""
- QUIT
- +10 SET FHFPNM=$PIECE($GET(^FH(115.2,FHFPIEN,0)),U,1)
- if FHFPNM=""
- QUIT
- +11 SET ^TMP($JOB,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM
- +12 QUIT
- End DoDot:1
- +13 WRITE !!,"Food Preferences Currently on file: "
- +14 IF $DATA(^TMP($JOB,"L"))
- WRITE !!?20,"Likes"
- +15 SET FHM=""
- FOR
- SET FHM=$ORDER(^TMP($JOB,"L",FHM))
- if FHM=""!(EX=U)
- QUIT
- Begin DoDot:1
- +16 FOR FHP=0:0
- SET FHP=$ORDER(^TMP($JOB,"L",FHM,FHP))
- if FHP'>0
- QUIT
- WRITE !!,^TMP($JOB,"L",FHM,FHP)
- IF $Y>(IOSL-4)
- DO PG
- IF EX=U
- QUIT
- End DoDot:1
- +17 IF $DATA(^TMP($JOB,"D"))
- WRITE !!?20,"Dislikes"
- +18 SET FHM=""
- FOR
- SET FHM=$ORDER(^TMP($JOB,"D",FHM))
- if FHM=""!(EX=U)
- QUIT
- Begin DoDot:1
- +19 FOR FHP=0:0
- SET FHP=$ORDER(^TMP($JOB,"D",FHM,FHP))
- if FHP'>0
- QUIT
- WRITE !!,^TMP($JOB,"D",FHM,FHP)
- IF $Y>(IOSL-4)
- DO PG
- IF EX=U
- QUIT
- End DoDot:1
- +20 ;
- +21 SET FHIPX=$PIECE($GET(^FHPT(FHDFN,0)),U,5)
- IF FHIPX'=""
- WRITE !!,"Isolation/Precaution type is ",$PIECE($GET(^FH(119.4,FHIPX,0)),"^",1)
- IF $Y>(IOSL-4)
- DO PG
- IF EX=U
- QUIT
- +22 WRITE !!,"Recurring Meals on File: "
- IF $Y>(IOSL-4)
- DO PG
- IF EX=U
- QUIT
- +23 WRITE !
- SET STDT=DT
- SET FHPP=1
- DO DISP^FHOMRR1
- KILL FHPP
- +24 IF EX'=U
- IF IOST?1"C".E
- WRITE !
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- +25 QUIT
- PG ;
- +1 IF IOST?1"C".E
- WRITE !
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- IF 'Y
- SET EX=U
- QUIT
- +2 DO HDR
- QUIT
- HDR ;
- +1 if $Y
- WRITE @IOF
- +2 WRITE !!,"OUTPATIENT NAME: "
- DO PATNAME^FHOMUTL
- WRITE FHPTNM," ",FHSSN
- +3 WRITE ?65,FHSEX," Age ",FHAGE
- QUIT
- END ;
- +1 KILL FHM,FHP,FHT
- QUIT
- +2 ;
- CPRS ; Call from FHWOR71 to get outpatient profile for CPRS
- +1 ; Data is returned in ^TMP($J,"FHPROF",DFN,FHX)
- +2 SET FHZ115="P"_DFN
- DO CHECK^FHOMDPA
- IF FHDFN=""
- QUIT "-1^Invalid outpatient"
- +3 KILL ^TMP($JOB,"FHPROF"),^TMP($JOB,"L"),^TMP($JOB,"D")
- SET (FHX,N)=0
- DO PATNAME^FHOMUTL
- +4 SET FHB=""
- FOR I=1:1:80
- SET FHB=FHB_" "
- +5 SET ^TMP($JOB,"FHPROF",DFN,FHX)="OUTPATIENT NAME: "_FHPTNM_" "_FHSSN
- +6 SET FHJ=66
- DO PAD^FHOMPP1
- SET ^TMP($JOB,"FHPROF",DFN,FHX)=^TMP($JOB,"FHPROF",DFN,FHX)_PAD_FHSEX_" Age "_FHAGE
- +7 DO ALG^FHCLN
- IF ALG'=""
- SET N=1
- DO NEWL
- SET ^TMP($JOB,"FHPROF",DFN,FHX)="Allergies: "_ALG
- +8 FOR FHFP=0:0
- SET FHFP=$ORDER(^FHPT(FHDFN,"P",FHFP))
- if FHFP'>0
- QUIT
- Begin DoDot:1
- +9 SET FHFPZN=$GET(^FHPT(FHDFN,"P",FHFP,0))
- +10 SET FHFPIEN=$PIECE(FHFPZN,U,1)
- SET FHMEAL=$PIECE(FHFPZN,U,2)
- SET FHQTY=$PIECE(FHFPZN,U,3)
- +11 if FHFPIEN=""
- QUIT
- +12 SET FHNORD=$SELECT($LENGTH(FHMEAL)=3:1,$EXTRACT(FHMEAL)="B":2,$EXTRACT(FHMEAL)="N":3,1:4)
- +13 SET FHMEAL=FHNORD_FHMEAL
- +14 SET FHFPLD=$PIECE($GET(^FH(115.2,FHFPIEN,0)),U,2)
- if FHFPLD=""
- QUIT
- +15 SET FHFPNM=$PIECE($GET(^FH(115.2,FHFPIEN,0)),U,1)
- if FHFPNM=""
- QUIT
- +16 SET ^TMP($JOB,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM
- +17 QUIT
- End DoDot:1
- +18 SET N=1
- DO NEWL
- SET ^TMP($JOB,"FHPROF",DFN,FHX)="Food Preferences Currently on file: "
- +19 IF $DATA(^TMP($JOB,"L"))
- SET N=1
- DO NEWL
- SET ^TMP($JOB,"FHPROF",DFN,FHX)="Likes"
- +20 SET FHM=""
- FOR
- SET FHM=$ORDER(^TMP($JOB,"L",FHM))
- if FHM=""
- QUIT
- Begin DoDot:1
- +21 FOR FHP=0:0
- SET FHP=$ORDER(^TMP($JOB,"L",FHM,FHP))
- if FHP'>0
- QUIT
- SET N=0
- DO NEWL
- SET ^TMP($JOB,"FHPROF",DFN,FHX)=^TMP($JOB,"L",FHM,FHP)
- End DoDot:1
- +22 IF $DATA(^TMP($JOB,"D"))
- SET N=1
- DO NEWL
- SET ^TMP($JOB,"FHPROF",DFN,FHX)="Dislikes"
- +23 SET FHM=""
- FOR
- SET FHM=$ORDER(^TMP($JOB,"D",FHM))
- if FHM=""
- QUIT
- Begin DoDot:1
- +24 FOR FHP=0:0
- SET FHP=$ORDER(^TMP($JOB,"D",FHM,FHP))
- if FHP'>0
- QUIT
- SET N=0
- DO NEWL
- SET ^TMP($JOB,"FHPROF",DFN,FHX)=^TMP($JOB,"D",FHM,FHP)
- End DoDot:1
- +25 ;
- +26 SET N=1
- DO NEWL
- SET ^TMP($JOB,"FHPROF",DFN,FHX)="Recurring Meals on File: "
- +27 SET STDT=DT
- DO ^FHOMPP1
- +28 QUIT
- NEWL ;New line before next line of text in ^TMP global
- +1 IF N=1
- SET FHX=FHX+1
- SET ^TMP($JOB,"FHPROF",DFN,FHX)=" "
- +2 SET FHX=FHX+1
- +3 QUIT