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 Dec 13, 2024@01:52:49 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
