FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007
;;5.5;DIETETICS;**8,12**;Jan 28, 2005;Build 3
;
;10/16/2007 BAY/KAM FH*5.5*12 Remedy Call 210385 Do not allow
; user to change Food Preference name or
; LIKE/DISLIKE field
;
CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2
; and allow user to create the FP on the fly
D ^FHSELA2 S NUM=0,FHQUIT=0
W !!!,"The following Allergy Food Preference titles are not on file."
W !,"You may use this option to create these Food Preference entries:"
D CRLIST I NUM=0 W !,"No Food Preferences need to be mapped." D EXIT Q
I FHQUIT=1 D EXIT Q
I FHRESP=""!(FHRESP="M") D EXIT Q
S FHAFPNM=$P(FHLIST(FHRESP),"^",1)
W !,FHAFPNM," "
K DIR S DIR("A")="Add to Food Preference file",DIR(0)="Y" D ^DIR
I $D(DIRUT) D EXIT Q
I Y'=1 D CREATE Q
D ADD
W !!," ...done. ",FHAFPNM," Food Preference has been added!" H 1
D CREATE Q
D EXIT Q
CRLIST ;
W !!?5,"MISSING FOOD PREFERENCE LIST"
W !?5,"============================"
S FHSEL=0,FHK=""
F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK=""!(FHQUIT=1)!(FHSEL=1) D
.S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99)
.S FHZ1="ALLERGY - "_$P(FHFPS,";",1)
.I $D(^FH(115.2,"B",FHZ1)) Q
.S NUM=NUM+1,PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM
.W ?8,FHZ1
.S FHLIST(NUM)=FHZ1_"^"_FHFPS
.I NUM#5=0!($O(^TMP($J,"FHALG",FHK))="") D PG Q
.Q
I FHQUIT=0,FHSEL=0,NUM#5'=0 D PG Q
Q
ADD ;
S FHALGMZ=1
S X=FHAFPNM K DIC,DO
S (DIC,DIE)="^FH(115.2,",DIC(0)="L" D FILE^DICN
; 10/16/2007 BP/KAM FH*5.5*12 Default DISLIKE and prevent Food Preference name change in the next line
S (FHDA,DA)=+Y,DR="26;1////D"
D ^DIE K DA,DIE,DR
D TRAN^FHSEL1
Q
PG ;
S FHRESP="" W ! K DIR
S DIR("A")="Select Food Preference or 'M' to see more ('^' to EXIT)"
S DIR(0)="F",DIR("B")="M" D ^DIR I $D(DIRUT) S FHQUIT=1 Q
S FHRESP=Y
I FHRESP?1"M" Q
I FHRESP?1.3N,FHRESP>0,FHRESP<(NUM+1) S FHSEL=1 Q
W !!,"Select from 1 to ",NUM D PG Q
Q
MAP ; Map allergies by setting pointers in 115.2 to correct entries in 120.82
D ^FHSELA2
S FHK=""
F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
.S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99)
.S FHZ1="ALLERGY - "_$P(FHFPS,";",1)
.I '$D(^FH(115.2,"B",FHZ1)) Q ;not set-up in 115.2, can't map
.S FHFPIEN=$O(^FH(115.2,"B",FHZ1,""))
.S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q ;no allergies to map
.S FHZ=0 F S FHZ=FHZ+1 S FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D
..D LOOKUP
Q
LOOKUP ; Look-up the Allergy in 120.82 and set the pointer
S FHX=FHANAM
F FHVAL=0:0 S FHVAL=$O(^GMRD(120.82,"B",FHX,FHVAL)) Q:FHVAL'>0 D
.I $D(^FH(115.2,FHFPIEN,"ALG","B",FHVAL)) Q ;pointer already exists
.S Y=FHVAL K DIC,DO S DA(1)=FHFPIEN,DIC="^FH(115.2,"_DA(1)_",""ALG"","
.S DIC(0)="L",DIC("P")=$P(^DD(115.2,25,0),U,2),X=+Y
.D FILE^DICN
Q
DISPMAP ;
W !!,"This option can be used to display the Standard GMR Allergy"
W !,"entries and the Food Preferences they map to.",!! K DIR
S DIR("A")="Display Map by Allergies or by Food Preferences (A/F): "
S DIR(0)="SA^A:Allergies;F:Food Preferences" D ^DIR
I $D(DIRUT) D EXIT Q
S FHSEL=Y
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 LISTMAP,^%ZISC,EXIT Q
S ZTRTN="LISTMAP^FHSELA1",ZTSAVE("FHSEL")=""
S ZTDESC="GMR Allergy/Food Preference Map Display" D ^%ZTLOAD
D ^%ZISC K %ZIS,IOP
D EXIT
Q
LISTMAP ; List Map by Allergies or by Food Preferences
I FHSEL="A" D LISTAL Q
I FHSEL="F" D LISTFP Q
Q
LISTFP ; List all the Allergy-type Food Pref's and corresponding GMR Allergies
D ^FHSELA2
S FHK="" W !!,"ALLERGY TYPE FOOD PREFERENCE MAP"
W !!,"NFS Food Preference Title",?40,"GMR Standard Allergy(s)"
W !,"==================================="
W ?40,"==================================="
F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
.S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1)
.W !,"ALLERGY - ",FHZ1
.S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" W ?40,"** NONE **" Q
.S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D
..W ?40,$S(FHZ>1:",",1:"") S N=N+$L(FHANAM)+1 W:N>40 !?40 S:N>40 N=0 W FHANAM I N=0 S N=N+$L(FHANAM)+1
D EXIT Q
LISTAL ; List all the GMR Allergies and the Food Pref to map to
D ^FHSELA2
S FHK="" W !!,"GMR STANDARD FOOD ALLERGY MAP"
W !!,"GMR Allergy Name",?25,"Corresponding NFS Food Preference"
W !,"=======================",?25,"===================================="
F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
.S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1)
.S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q
.S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D
..S ^TMP($J,"FHAL",FHANAM)="ALLERGY - "_FHZ1
S FHANAMZ=""
F S FHANAMZ=$O(^TMP($J,"FHAL",FHANAMZ)) Q:FHANAMZ="" D
.W !,FHANAMZ,?25,"...maps to: ",^TMP($J,"FHAL",FHANAMZ)
D EXIT Q
MISSING ; List all Food Pref's with no pointers to 120.82
D ^FHSELA2
S FHK=""
F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
.S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1)
.I $P(FHFPS,";",2)'="" Q
.W !?5,"ALLERGY - ",FHZ1," does not have corresponding 120.82 entries"
D EXIT Q
CHECK ; Check for any missing Allergy-type FP's or one's not renamed in 115.2
D ^FHSELA2
S FHK="",FLG=0
W !,"The following Food Preferences titles were not found in file #115.2:"
F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D
.S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99)
.S FHZ1="ALLERGY - "_$P(FHFPS,";",1)
.I '$D(^FH(115.2,"B",FHZ1)) W !,FHZ1 S FLG=1
I FLG=0 W !,"ALL FOOD PREFERENCES HAVE BEEN RENAMED!"
D EXIT Q
;
UPDATE ;Update Food Preferences for all Patient's based on Allergies
D ^FHSELA2 S FHCOUNT=0,FHQT=0
W !!,"...Updating Patient Food Preferences based on Food-Type Allergies"
W "..." K FHMISS F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 D
.S FHCOUNT=FHCOUNT+1 I FHCOUNT#100=0 W "."
.D GETZN^FHOMUTL I FILE'="P" Q
.S DFN=IEN D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q
.F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP1^FHWGMR
I $G(FHPST8)=1 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT Q
D LIST
K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT,FHQT
Q
LIST ;
I '$D(^TMP($J,"FHMISS")) Q
W !!,"The following entries need to be mapped in order to automatically"
W !,"update the Patient Food Preferences:",! S FHCOUNT=0,FHQT=0
S FHMSFP="" F S FHMSFP=$O(^TMP($J,"FHMISS",FHMSFP)) Q:FHMSFP=""!(FHQT=1) D
.W !,"'ALLERGY - ",FHMSFP,"'" S FHCOUNT=FHCOUNT+1
.S FHMSPT="" F S FHMSPT=$O(^TMP($J,"FHMISS",FHMSFP,FHMSPT)) Q:FHMSPT="" D
..S FHMSAL=$P($G(^TMP($J,"FHMISS",FHMSFP,FHMSPT)),U,1)
..W !?3,"Patient: ",$E(FHMSPT,1,30),?43,"Allergy: ",FHMSAL
..S FHCOUNT=FHCOUNT+1
..I FHCOUNT>14 S FHCOUNT=0 W ! K DIR S DIR(0)="E" D ^DIR W ! I X="^" S FHQT=1
Q
EXIT ;
D MAP
K ^TMP($J,"FHALG"),^TMP($J,"FHAL")
K FHFPIEN,FHK,FHX,FHZ,FHFPS,FHZ1,FHVAL,N,FHANAM,FHANAMZ
K FHQUIT,NUM,FHRESP,FHAFPNM,FHSEL,PAD,FHLIST,FHALGMZ,FHALMP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHSELA1 7179 printed Nov 22, 2024@17:05:13 Page 2
FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007
+1 ;;5.5;DIETETICS;**8,12**;Jan 28, 2005;Build 3
+2 ;
+3 ;10/16/2007 BAY/KAM FH*5.5*12 Remedy Call 210385 Do not allow
+4 ; user to change Food Preference name or
+5 ; LIKE/DISLIKE field
+6 ;
CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2
+1 ; and allow user to create the FP on the fly
+2 DO ^FHSELA2
SET NUM=0
SET FHQUIT=0
+3 WRITE !!!,"The following Allergy Food Preference titles are not on file."
+4 WRITE !,"You may use this option to create these Food Preference entries:"
+5 DO CRLIST
IF NUM=0
WRITE !,"No Food Preferences need to be mapped."
DO EXIT
QUIT
+6 IF FHQUIT=1
DO EXIT
QUIT
+7 IF FHRESP=""!(FHRESP="M")
DO EXIT
QUIT
+8 SET FHAFPNM=$PIECE(FHLIST(FHRESP),"^",1)
+9 WRITE !,FHAFPNM," "
+10 KILL DIR
SET DIR("A")="Add to Food Preference file"
SET DIR(0)="Y"
DO ^DIR
+11 IF $DATA(DIRUT)
DO EXIT
QUIT
+12 IF Y'=1
DO CREATE
QUIT
+13 DO ADD
+14 WRITE !!," ...done. ",FHAFPNM," Food Preference has been added!"
HANG 1
+15 DO CREATE
QUIT
+16 DO EXIT
QUIT
CRLIST ;
+1 WRITE !!?5,"MISSING FOOD PREFERENCE LIST"
+2 WRITE !?5,"============================"
+3 SET FHSEL=0
SET FHK=""
+4 FOR
SET FHK=$ORDER(^TMP($JOB,"FHALG",FHK))
if FHK=""!(FHQUIT=1)!(FHSEL=1)
QUIT
Begin DoDot:1
+5 SET FHFPS=$PIECE(^TMP($JOB,"FHALG",FHK),";",1,99)
+6 SET FHZ1="ALLERGY - "_$PIECE(FHFPS,";",1)
+7 IF $DATA(^FH(115.2,"B",FHZ1))
QUIT
+8 SET NUM=NUM+1
SET PAD=$SELECT($LENGTH(NUM)=1:" ",1:"")
WRITE !,PAD,NUM
+9 WRITE ?8,FHZ1
+10 SET FHLIST(NUM)=FHZ1_"^"_FHFPS
+11 IF NUM#5=0!($ORDER(^TMP($JOB,"FHALG",FHK))="")
DO PG
QUIT
+12 QUIT
End DoDot:1
+13 IF FHQUIT=0
IF FHSEL=0
IF NUM#5'=0
DO PG
QUIT
+14 QUIT
ADD ;
+1 SET FHALGMZ=1
+2 SET X=FHAFPNM
KILL DIC,DO
+3 SET (DIC,DIE)="^FH(115.2,"
SET DIC(0)="L"
DO FILE^DICN
+4 ; 10/16/2007 BP/KAM FH*5.5*12 Default DISLIKE and prevent Food Preference name change in the next line
+5 SET (FHDA,DA)=+Y
SET DR="26;1////D"
+6 DO ^DIE
KILL DA,DIE,DR
+7 DO TRAN^FHSEL1
+8 QUIT
PG ;
+1 SET FHRESP=""
WRITE !
KILL DIR
+2 SET DIR("A")="Select Food Preference or 'M' to see more ('^' to EXIT)"
+3 SET DIR(0)="F"
SET DIR("B")="M"
DO ^DIR
IF $DATA(DIRUT)
SET FHQUIT=1
QUIT
+4 SET FHRESP=Y
+5 IF FHRESP?1"M"
QUIT
+6 IF FHRESP?1.3N
IF FHRESP>0
IF FHRESP<(NUM+1)
SET FHSEL=1
QUIT
+7 WRITE !!,"Select from 1 to ",NUM
DO PG
QUIT
+8 QUIT
MAP ; Map allergies by setting pointers in 115.2 to correct entries in 120.82
+1 DO ^FHSELA2
+2 SET FHK=""
+3 FOR
SET FHK=$ORDER(^TMP($JOB,"FHALG",FHK))
if FHK=""
QUIT
Begin DoDot:1
+4 SET FHFPS=$PIECE(^TMP($JOB,"FHALG",FHK),";",1,99)
+5 SET FHZ1="ALLERGY - "_$PIECE(FHFPS,";",1)
+6 ;not set-up in 115.2, can't map
IF '$DATA(^FH(115.2,"B",FHZ1))
QUIT
+7 SET FHFPIEN=$ORDER(^FH(115.2,"B",FHZ1,""))
+8 ;no allergies to map
SET FHALMP=$PIECE(FHFPS,";",2,99)
IF FHALMP=""
QUIT
+9 SET FHZ=0
FOR
SET FHZ=FHZ+1
SET FHANAM=$PIECE(FHALMP,";",FHZ)
if FHANAM=""
QUIT
Begin DoDot:2
+10 DO LOOKUP
End DoDot:2
End DoDot:1
+11 QUIT
LOOKUP ; Look-up the Allergy in 120.82 and set the pointer
+1 SET FHX=FHANAM
+2 FOR FHVAL=0:0
SET FHVAL=$ORDER(^GMRD(120.82,"B",FHX,FHVAL))
if FHVAL'>0
QUIT
Begin DoDot:1
+3 ;pointer already exists
IF $DATA(^FH(115.2,FHFPIEN,"ALG","B",FHVAL))
QUIT
+4 SET Y=FHVAL
KILL DIC,DO
SET DA(1)=FHFPIEN
SET DIC="^FH(115.2,"_DA(1)_",""ALG"","
+5 SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(115.2,25,0),U,2)
SET X=+Y
+6 DO FILE^DICN
End DoDot:1
+7 QUIT
DISPMAP ;
+1 WRITE !!,"This option can be used to display the Standard GMR Allergy"
+2 WRITE !,"entries and the Food Preferences they map to.",!!
KILL DIR
+3 SET DIR("A")="Display Map by Allergies or by Food Preferences (A/F): "
+4 SET DIR(0)="SA^A:Allergies;F:Food Preferences"
DO ^DIR
+5 IF $DATA(DIRUT)
DO EXIT
QUIT
+6 SET FHSEL=Y
+7 DO DEV
+8 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 LISTMAP
DO ^%ZISC
DO EXIT
QUIT
+3 SET ZTRTN="LISTMAP^FHSELA1"
SET ZTSAVE("FHSEL")=""
+4 SET ZTDESC="GMR Allergy/Food Preference Map Display"
DO ^%ZTLOAD
+5 DO ^%ZISC
KILL %ZIS,IOP
+6 DO EXIT
+7 QUIT
LISTMAP ; List Map by Allergies or by Food Preferences
+1 IF FHSEL="A"
DO LISTAL
QUIT
+2 IF FHSEL="F"
DO LISTFP
QUIT
+3 QUIT
LISTFP ; List all the Allergy-type Food Pref's and corresponding GMR Allergies
+1 DO ^FHSELA2
+2 SET FHK=""
WRITE !!,"ALLERGY TYPE FOOD PREFERENCE MAP"
+3 WRITE !!,"NFS Food Preference Title",?40,"GMR Standard Allergy(s)"
+4 WRITE !,"==================================="
+5 WRITE ?40,"==================================="
+6 FOR
SET FHK=$ORDER(^TMP($JOB,"FHALG",FHK))
if FHK=""
QUIT
Begin DoDot:1
+7 SET FHFPS=$PIECE(^TMP($JOB,"FHALG",FHK),";",1,99)
SET FHZ1=$PIECE(FHFPS,";",1)
+8 WRITE !,"ALLERGY - ",FHZ1
+9 SET FHALMP=$PIECE(FHFPS,";",2,99)
IF FHALMP=""
WRITE ?40,"** NONE **"
QUIT
+10 SET FHZ=0
SET N=0
FOR
SET FHZ=FHZ+1
SET FHANAM=$PIECE(FHALMP,";",FHZ)
if FHANAM=""
QUIT
Begin DoDot:2
+11 WRITE ?40,$SELECT(FHZ>1:",",1:"")
SET N=N+$LENGTH(FHANAM)+1
if N>40
WRITE !?40
if N>40
SET N=0
WRITE FHANAM
IF N=0
SET N=N+$LENGTH(FHANAM)+1
End DoDot:2
End DoDot:1
+12 DO EXIT
QUIT
LISTAL ; List all the GMR Allergies and the Food Pref to map to
+1 DO ^FHSELA2
+2 SET FHK=""
WRITE !!,"GMR STANDARD FOOD ALLERGY MAP"
+3 WRITE !!,"GMR Allergy Name",?25,"Corresponding NFS Food Preference"
+4 WRITE !,"=======================",?25,"===================================="
+5 FOR
SET FHK=$ORDER(^TMP($JOB,"FHALG",FHK))
if FHK=""
QUIT
Begin DoDot:1
+6 SET FHFPS=$PIECE(^TMP($JOB,"FHALG",FHK),";",1,99)
SET FHZ1=$PIECE(FHFPS,";",1)
+7 SET FHALMP=$PIECE(FHFPS,";",2,99)
IF FHALMP=""
QUIT
+8 SET FHZ=0
SET N=0
FOR
SET FHZ=FHZ+1
SET FHANAM=$PIECE(FHALMP,";",FHZ)
if FHANAM=""
QUIT
Begin DoDot:2
+9 SET ^TMP($JOB,"FHAL",FHANAM)="ALLERGY - "_FHZ1
End DoDot:2
End DoDot:1
+10 SET FHANAMZ=""
+11 FOR
SET FHANAMZ=$ORDER(^TMP($JOB,"FHAL",FHANAMZ))
if FHANAMZ=""
QUIT
Begin DoDot:1
+12 WRITE !,FHANAMZ,?25,"...maps to: ",^TMP($JOB,"FHAL",FHANAMZ)
End DoDot:1
+13 DO EXIT
QUIT
MISSING ; List all Food Pref's with no pointers to 120.82
+1 DO ^FHSELA2
+2 SET FHK=""
+3 FOR
SET FHK=$ORDER(^TMP($JOB,"FHALG",FHK))
if FHK=""
QUIT
Begin DoDot:1
+4 SET FHFPS=$PIECE(^TMP($JOB,"FHALG",FHK),";",1,99)
SET FHZ1=$PIECE(FHFPS,";",1)
+5 IF $PIECE(FHFPS,";",2)'=""
QUIT
+6 WRITE !?5,"ALLERGY - ",FHZ1," does not have corresponding 120.82 entries"
End DoDot:1
+7 DO EXIT
QUIT
CHECK ; Check for any missing Allergy-type FP's or one's not renamed in 115.2
+1 DO ^FHSELA2
+2 SET FHK=""
SET FLG=0
+3 WRITE !,"The following Food Preferences titles were not found in file #115.2:"
+4 FOR
SET FHK=$ORDER(^TMP($JOB,"FHALG",FHK))
if FHK=""
QUIT
Begin DoDot:1
+5 SET FHFPS=$PIECE(^TMP($JOB,"FHALG",FHK),";",1,99)
+6 SET FHZ1="ALLERGY - "_$PIECE(FHFPS,";",1)
+7 IF '$DATA(^FH(115.2,"B",FHZ1))
WRITE !,FHZ1
SET FLG=1
End DoDot:1
+8 IF FLG=0
WRITE !,"ALL FOOD PREFERENCES HAVE BEEN RENAMED!"
+9 DO EXIT
QUIT
+10 ;
UPDATE ;Update Food Preferences for all Patient's based on Allergies
+1 DO ^FHSELA2
SET FHCOUNT=0
SET FHQT=0
+2 WRITE !!,"...Updating Patient Food Preferences based on Food-Type Allergies"
+3 WRITE "..."
KILL FHMISS
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT(FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:1
+4 SET FHCOUNT=FHCOUNT+1
IF FHCOUNT#100=0
WRITE "."
+5 DO GETZN^FHOMUTL
IF FILE'="P"
QUIT
+6 SET DFN=IEN
DO ALG^FHCLN
IF '$ORDER(^TMP($JOB,"FHGMRAL",""))
QUIT
+7 FOR FHGMRN=0:0
SET FHGMRN=$ORDER(^TMP($JOB,"FHGMRAL",FHGMRN))
if FHGMRN=""
QUIT
DO UPDFP1^FHWGMR
End DoDot:1
+8 IF $GET(FHPST8)=1
KILL ^TMP($JOB,"FHGMRAL"),^TMP($JOB,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT
QUIT
+9 DO LIST
+10 KILL ^TMP($JOB,"FHGMRAL"),^TMP($JOB,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT,FHQT
+11 QUIT
LIST ;
+1 IF '$DATA(^TMP($JOB,"FHMISS"))
QUIT
+2 WRITE !!,"The following entries need to be mapped in order to automatically"
+3 WRITE !,"update the Patient Food Preferences:",!
SET FHCOUNT=0
SET FHQT=0
+4 SET FHMSFP=""
FOR
SET FHMSFP=$ORDER(^TMP($JOB,"FHMISS",FHMSFP))
if FHMSFP=""!(FHQT=1)
QUIT
Begin DoDot:1
+5 WRITE !,"'ALLERGY - ",FHMSFP,"'"
SET FHCOUNT=FHCOUNT+1
+6 SET FHMSPT=""
FOR
SET FHMSPT=$ORDER(^TMP($JOB,"FHMISS",FHMSFP,FHMSPT))
if FHMSPT=""
QUIT
Begin DoDot:2
+7 SET FHMSAL=$PIECE($GET(^TMP($JOB,"FHMISS",FHMSFP,FHMSPT)),U,1)
+8 WRITE !?3,"Patient: ",$EXTRACT(FHMSPT,1,30),?43,"Allergy: ",FHMSAL
+9 SET FHCOUNT=FHCOUNT+1
+10 IF FHCOUNT>14
SET FHCOUNT=0
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
WRITE !
IF X="^"
SET FHQT=1
End DoDot:2
End DoDot:1
+11 QUIT
EXIT ;
+1 DO MAP
+2 KILL ^TMP($JOB,"FHALG"),^TMP($JOB,"FHAL")
+3 KILL FHFPIEN,FHK,FHX,FHZ,FHFPS,FHZ1,FHVAL,N,FHANAM,FHANAMZ
+4 KILL FHQUIT,NUM,FHRESP,FHAFPNM,FHSEL,PAD,FHLIST,FHALGMZ,FHALMP
