Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHOMPP

FHOMPP.m

Go to the documentation of this file.
  1. FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;7/2/2007
  1. ;;5.5;DIETETICS;**9**;Jan 28, 2005;Build 7
  1. D DEV Q
  1. DEV ;get device and set up queue
  1. W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP
  1. I '$D(IO("Q")) U IO D DISP,^%ZISC,END Q
  1. S ZTRTN="DISP^FHOMPP"
  1. S ZTSAVE("FHDFN")=""
  1. S ZTDESC="Outpatient Meals Recurring Meals Display" D ^%ZTLOAD
  1. D ^%ZISC K %ZIS,IOP
  1. D END Q
  1. DISP ;
  1. S EX="" D HDR
  1. D ALG^FHCLN I ALG'="" W !!,"Allergies: ",ALG
  1. K ^TMP($J) F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D
  1. .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0))
  1. .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3)
  1. .Q:FHFPIEN=""
  1. .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4)
  1. .S FHMEAL=FHNORD_FHMEAL
  1. .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD=""
  1. .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM=""
  1. .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM
  1. .Q
  1. W !!,"Food Preferences Currently on file: "
  1. I $D(^TMP($J,"L")) W !!?20,"Likes"
  1. S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM=""!(EX=U) D
  1. .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
  1. I $D(^TMP($J,"D")) W !!?20,"Dislikes"
  1. S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM=""!(EX=U) D
  1. .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
  1. ;
  1. 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
  1. W !!,"Recurring Meals on File: " I $Y>(IOSL-4) D PG I EX=U Q
  1. W ! S STDT=DT S FHPP=1 D DISP^FHOMRR1 K FHPP
  1. I EX'=U,IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR
  1. Q
  1. PG ;
  1. I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q
  1. D HDR Q
  1. HDR ;
  1. W:$Y @IOF
  1. W !!,"OUTPATIENT NAME: " D PATNAME^FHOMUTL W FHPTNM," ",FHSSN
  1. W ?65,FHSEX," Age ",FHAGE Q
  1. END ;
  1. K FHM,FHP,FHT Q
  1. ;
  1. CPRS ; Call from FHWOR71 to get outpatient profile for CPRS
  1. ; Data is returned in ^TMP($J,"FHPROF",DFN,FHX)
  1. S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q "-1^Invalid outpatient"
  1. K ^TMP($J,"FHPROF"),^TMP($J,"L"),^TMP($J,"D") S (FHX,N)=0 D PATNAME^FHOMUTL
  1. S FHB="" F I=1:1:80 S FHB=FHB_" "
  1. S ^TMP($J,"FHPROF",DFN,FHX)="OUTPATIENT NAME: "_FHPTNM_" "_FHSSN
  1. S FHJ=66 D PAD^FHOMPP1 S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"FHPROF",DFN,FHX)_PAD_FHSEX_" Age "_FHAGE
  1. D ALG^FHCLN I ALG'="" S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Allergies: "_ALG
  1. F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D
  1. .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0))
  1. .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3)
  1. .Q:FHFPIEN=""
  1. .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4)
  1. .S FHMEAL=FHNORD_FHMEAL
  1. .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD=""
  1. .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM=""
  1. .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM
  1. .Q
  1. S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Food Preferences Currently on file: "
  1. I $D(^TMP($J,"L")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Likes"
  1. S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM="" D
  1. .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)
  1. I $D(^TMP($J,"D")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Dislikes"
  1. S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM="" D
  1. .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)
  1. ;
  1. S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Recurring Meals on File: "
  1. S STDT=DT D ^FHOMPP1
  1. Q
  1. NEWL ;New line before next line of text in ^TMP global
  1. I N=1 S FHX=FHX+1,^TMP($J,"FHPROF",DFN,FHX)=" "
  1. S FHX=FHX+1
  1. Q