- 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
- 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