- FHMTK1B ; HISC/NCA - Tray Ticket Utilities ;2/23/00 09:53
- ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- ;patch #5 - added outpatient SO.
- Q1 ; Store Service Point, Bread/Beverage default, Food Preference,
- ; and Recipes of meal
- S LN=$S(IOST?1"C".E:IOSL-2,1:IOSL-6),SL=40 F SP=0:0 S SP=$O(^FH(119.72,SP)) Q:SP<1 S Z=$G(^(SP,0)),^TMP($J,"SRP",SP)=$P(Z,"^",1,4)
- I MEAL'="A" S M1=MEAL D GET Q
- F M1="B","N","E" S FHX1=$P(FHDA,"^",$F("BNE",M1)) D GET
- Q
- GET S LS(M1)=40 F LL=0:0 S LL=$O(^FH(115.2,LL)) Q:LL<1 S L2=$G(^(LL,0)) D
- .I $P(L2,"^",2)="D" D Q
- ..F KK=0:0 S KK=$O(^FH(115.2,LL,"X",KK)) Q:KK<1 S REC=$P($G(^(KK,0)),"^",1),^TMP($J,"X",M1,LL,KK)=+REC,KKNUM=KK D
- ...I $P($G(^FH(115.2,LL,0)),U,7)'="Y" Q ;must be set to excl emb recps
- ...I REC'="" F FHKK=0:0 S FHKK=$O(^FH(114,"AB",REC,FHKK)) Q:FHKK'>0 S FHEMB(FHKK)=FHKK
- ..F FHKK=0:0 S FHKK=$O(FHEMB(FHKK)) Q:FHKK'>0 S KKNUM=KKNUM+1,^TMP($J,"X",M1,LL,KKNUM)=FHKK ;exclude EMBEDDED RECIPES
- ..K FHEMB Q
- .S REC=$P(L2,"^",4) Q:'REC S Y=$G(^FH(114,+REC,0)),NAM=$P(Y,"^",1),K3=$P(Y,"^",7) I $P(L2,"^",5),$P(L2,"^",6)[M1 D
- ..S:'$D(^TMP($J,"FHDEF",M1,+REC)) ^TMP($J,"FHDEF",M1,+REC)=K3_"^"_+REC_"^"_NAM
- ..Q
- .Q
- F LL=0:0 S LL=$O(^TMP($J,"X",M1,LL)) Q:LL<1 F KK=0:0 S KK=$O(^TMP($J,"X",M1,LL,KK)) Q:KK<1 S X1=+$G(^(KK)),X2=$O(^FH(116.1,FHX1,"RE","B",X1,0)) I X2<1 K ^TMP($J,"X",M1,LL,KK)
- F P1=0:0 S P1=$O(^FH(116.1,FHX1,"RE",P1)) Q:P1<1 S L1=$G(^(P1,0)),Y=$G(^FH(114,+L1,0)),NAM=$P(Y,"^",1) D
- .F CAT=0:0 S CAT=$O(^FH(116.1,FHX1,"RE",P1,"R",CAT)) Q:CAT<1 S MCA=$G(^(CAT,0)) D
- ..S FHPD=$P(MCA,"^",2),K3=+MCA S:'K3 K3=$P(Y,"^",7)
- ..S CODE=$P($G(^FH(114.1,+K3,0)),"^",2),ZZ1=CODE
- ..I $E(CODE,$L(CODE))="X" S K3=$O(^FH(114.1,"C",$E(CODE,1,$L(CODE)-1),0)) S:'K3 K3=$P(Y,"^",7)
- ..S K4=$P($G(^FH(114.1,+K3,0)),"^",3),K4=$S('K4:99,K4<10:"0"_K4,1:K4)
- ..F P2=1:1 S FHX2=$P(FHPD," ",P2) Q:FHX2="" S PD=$P(FHX2,";",1),P4="~" I PD'="" D
- ...F SP=0:0 S SP=$O(^TMP($J,"SRP",SP)) Q:SP<1 S SRP=$G(^TMP($J,"SRP",SP)),Z1=$G(^FH(116.1,FHX1,"RE",P1,"D",SP,0)),Z1=$P(Z1,"^",2),Z1=$S(Z1="":1,1:Z1) D SRP^FHDCR1B
- ...D STOR Q
- ..Q
- .Q
- Q
- STOR ; Store Alternate recipes and default recipes
- N CODE S DBX="",CODE=ZZ1 I $E(CODE,$L(CODE))?1"X" D
- .S CODE=$E(CODE,1,$L(CODE)-1),DBX="*** Omit ",LC=0
- .F NX=0:0 S NX=$O(^FH(114,+L1,"DBX",NX)) Q:NX<1 S Z3=^(NX,0),QTY=$S($P(Z3,"^",2):$P(Z3,"^",2),1:1),ZZ=QTY_" "_$P($G(^FH(114.1,+Z3,0)),"^",1)_", " D:$L(DBX)+$L(ZZ)>28 SET S DBX=DBX_ZZ
- .D SET Q
- I $E(CODE,$L(CODE))?1N,$E(CODE,$L(CODE))>1 S ^TMP($J,"ALT",M1,PD,CODE,+L1)=K4_"~"_K3_"~"_NAM_P4
- S ^TMP($J,M1,PD,K4_"~"_K3_"~"_NAM)=+L1_"^"_CODE_"^"_P4
- S:'$D(^TMP($J,"FHPO",NAM)) ^TMP($J,"FHPO",NAM)=K4_"~"_K3_"~"_NAM
- I $D(^TMP($J,"FHDEF",M1,+L1)) S ^TMP($J,"DEF",M1,PD,K3_"~"_NAM)=+L1_"~"_K3_"~"_NAM Q
- Q
- SET I $L(DBX)>9 S LC=LC+1,^TMP($J,"DBX",M1,PD,+L1,LC)=$E(DBX,1,$L(DBX)-2),DBX="*** Omit "
- Q
- ALT ; Exchange dislike recipe with an alternate recipe
- S R1=$P($G(^TMP($J,MEAL,PD,X8)),"^",2),R2=R1 Q:R1=""
- F S R2=$O(^TMP($J,"ALT",MEAL,PD,R2)) Q:R2=""!($E(R1,1,$L(R1)-1)'=$E(R2,1,$L(R2)-1)) D A1 Q:X6
- I 'X6 D
- .I $E(R1,1,$L(R1)-1)="E" S MSG=" ** NO ENTREE **",EVT="M^O^^No Entree" D ^FHORX Q
- .S MSG=" ** NO "_$P($G(^FH(114.1,Z1,0)),"^",1)_" - FP" Q
- Q
- A1 S R3=0
- A2 S R3=$O(^TMP($J,"ALT",MEAL,PD,R2,R3)) Q:R3<1
- S Z=$G(^TMP($J,"ALT",MEAL,PD,R2,R3)),P4="~"_$P(Z,"~",4,$L(Z,"~")) I $F(P4,"~"_SP_"~"),'$D(FP(R3)) S X6=R3 Q
- G A2
- DECOD ; Decode code string
- S M1=$S(MEAL="B":1,MEAL="N":2,1:3),STR=$P(STR,";",M1)
- F X4=1:1 Q:$P(STR," ",X4,99)="" D
- .S X1=$P(STR," ",X4),NAM=$P($G(^FH(114.1,+X1,0)),"^",1),$P(X1,",",2)=$S($P(X1,",",2)'="":$P(X1,",",2),1:1)
- .S MP(+X1)=$P(X1,",",2) Q
- Q
- CHK ; Check for Patient dislike on meal
- F LL=0:0 S LL=$O(^TMP($J,"X",MEAL,LL)) Q:LL<1 F KK=0:0 S KK=$O(^TMP($J,"X",MEAL,LL,KK)) Q:KK<1 S X1=+$G(^TMP($J,"X",MEAL,LL,KK)) D
- .S X6=$O(^FHPT(FHDFN,"P","B",LL,0)) Q:X6<1
- .S X2=$G(^FHPT(FHDFN,"P",X6,0)) Q:$P(X2,"^",2)'[MEAL
- .S FP(X1)=""
- .Q
- Q
- SO ; Store Standing Orders
- K ALPHA,SONAME S INDX=1 F K=0:0 S K=$O(^FHPT("ASP",FHDFN,ADM,K)) Q:K<1 D
- .S X=$G(^FHPT(FHDFN,"A",ADM,"SP",K,0)),Z=$P(X,"^",2)
- .S SONAME=$P($G(^FH(118.3,+Z,0)),U,1) I SONAME="" Q
- .I $D(ALPHA(SONAME)) S SONAME=SONAME_INDX,INDX=INDX+1
- .S ALPHA(SONAME)=K_"^"_Z
- .Q
- S SONAME="" F S SONAME=$O(ALPHA(SONAME)) Q:SONAME="" D
- .S K=$P(ALPHA(SONAME),U,1)
- .S X=$G(^FHPT(FHDFN,"A",ADM,"SP",K,0)),Z=$P(X,U,2),M=$P(X,U,3) Q:'Z
- .I M[MEAL S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=$S($P(X,"^",8):$P(X,"^",8),1:1)_" "_$P(^FH(118.3,+Z,0),"^",1) Q
- Q
- ;
- SOUT ; Store Outpatient Standing Orders.
- Q:'$G(ADM)
- S FHOPDAT0=$G(^FHPT(FHDFN,"OP",ADM,0)) Q:$P(FHOPDAT0,U,15)="C"
- K ALPHA,SONAME S INDX=1 F K=0:0 S K=$O(^FHPT("ASPO",FHDFN,ADM,K)) Q:K<1 D
- .S X=$G(^FHPT(FHDFN,"OP",ADM,"SP",K,0)),Z=$P(X,"^",2)
- .S SONAME=$P($G(^FH(118.3,+Z,0)),U,1) I SONAME="" Q
- .I $D(ALPHA(SONAME)) S SONAME=SONAME_INDX,INDX=INDX+1
- .S ALPHA(SONAME)=K_"^"_Z
- .Q
- S SONAME="" F S SONAME=$O(ALPHA(SONAME)) Q:SONAME="" D
- .S K=$P(ALPHA(SONAME),U,1)
- .S X=$G(^FHPT(FHDFN,"OP",ADM,"SP",K,0)),Z=$P(X,U,2),M=$P(X,U,3) Q:'Z
- .I M[MEAL S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=$S($P(X,"^",8):$P(X,"^",8),1:1)_" "_$P(^FH(118.3,+Z,0),"^",1) Q
- Q
- ;
- BRK ; Break the line if allergies' length > 35 chars
- I J>2 S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=$S($L(ALG)<36:ALG,1:$J("",8)_"OTHERS") Q
- I $L(ALG)<36 S S(NBR)=S(NBR)+1,J=J+1,MM(S(NBR),NBR)=ALG Q
- F L=37:-1:8 Q:$E(ALG,L-1,L)=", "
- I L=8 S L=35 S S(NBR)=S(NBR)+1,J=J+1,MM(S(NBR),NBR)=$E(ALG,1,35)
- E S S(NBR)=S(NBR)+1,J=J+1,MM(S(NBR),NBR)=$E(ALG,1,L-1)
- S ALG=$J("",8)_$E(ALG,L+1,999)
- G BRK
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTK1B 5641 printed Mar 13, 2025@20:52:46 Page 2
- FHMTK1B ; HISC/NCA - Tray Ticket Utilities ;2/23/00 09:53
- +1 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- +2 ;patch #5 - added outpatient SO.
- Q1 ; Store Service Point, Bread/Beverage default, Food Preference,
- +1 ; and Recipes of meal
- +2 SET LN=$SELECT(IOST?1"C".E:IOSL-2,1:IOSL-6)
- SET SL=40
- FOR SP=0:0
- SET SP=$ORDER(^FH(119.72,SP))
- if SP<1
- QUIT
- SET Z=$GET(^(SP,0))
- SET ^TMP($JOB,"SRP",SP)=$PIECE(Z,"^",1,4)
- +3 IF MEAL'="A"
- SET M1=MEAL
- DO GET
- QUIT
- +4 FOR M1="B","N","E"
- SET FHX1=$PIECE(FHDA,"^",$FIND("BNE",M1))
- DO GET
- +5 QUIT
- GET SET LS(M1)=40
- FOR LL=0:0
- SET LL=$ORDER(^FH(115.2,LL))
- if LL<1
- QUIT
- SET L2=$GET(^(LL,0))
- Begin DoDot:1
- +1 IF $PIECE(L2,"^",2)="D"
- Begin DoDot:2
- +2 FOR KK=0:0
- SET KK=$ORDER(^FH(115.2,LL,"X",KK))
- if KK<1
- QUIT
- SET REC=$PIECE($GET(^(KK,0)),"^",1)
- SET ^TMP($JOB,"X",M1,LL,KK)=+REC
- SET KKNUM=KK
- Begin DoDot:3
- +3 ;must be set to excl emb recps
- IF $PIECE($GET(^FH(115.2,LL,0)),U,7)'="Y"
- QUIT
- +4 IF REC'=""
- FOR FHKK=0:0
- SET FHKK=$ORDER(^FH(114,"AB",REC,FHKK))
- if FHKK'>0
- QUIT
- SET FHEMB(FHKK)=FHKK
- End DoDot:3
- +5 ;exclude EMBEDDED RECIPES
- FOR FHKK=0:0
- SET FHKK=$ORDER(FHEMB(FHKK))
- if FHKK'>0
- QUIT
- SET KKNUM=KKNUM+1
- SET ^TMP($JOB,"X",M1,LL,KKNUM)=FHKK
- +6 KILL FHEMB
- QUIT
- End DoDot:2
- QUIT
- +7 SET REC=$PIECE(L2,"^",4)
- if 'REC
- QUIT
- SET Y=$GET(^FH(114,+REC,0))
- SET NAM=$PIECE(Y,"^",1)
- SET K3=$PIECE(Y,"^",7)
- IF $PIECE(L2,"^",5)
- IF $PIECE(L2,"^",6)[M1
- Begin DoDot:2
- +8 if '$DATA(^TMP($JOB,"FHDEF",M1,+REC))
- SET ^TMP($JOB,"FHDEF",M1,+REC)=K3_"^"_+REC_"^"_NAM
- +9 QUIT
- End DoDot:2
- +10 QUIT
- End DoDot:1
- +11 FOR LL=0:0
- SET LL=$ORDER(^TMP($JOB,"X",M1,LL))
- if LL<1
- QUIT
- FOR KK=0:0
- SET KK=$ORDER(^TMP($JOB,"X",M1,LL,KK))
- if KK<1
- QUIT
- SET X1=+$GET(^(KK))
- SET X2=$ORDER(^FH(116.1,FHX1,"RE","B",X1,0))
- IF X2<1
- KILL ^TMP($JOB,"X",M1,LL,KK)
- +12 FOR P1=0:0
- SET P1=$ORDER(^FH(116.1,FHX1,"RE",P1))
- if P1<1
- QUIT
- SET L1=$GET(^(P1,0))
- SET Y=$GET(^FH(114,+L1,0))
- SET NAM=$PIECE(Y,"^",1)
- Begin DoDot:1
- +13 FOR CAT=0:0
- SET CAT=$ORDER(^FH(116.1,FHX1,"RE",P1,"R",CAT))
- if CAT<1
- QUIT
- SET MCA=$GET(^(CAT,0))
- Begin DoDot:2
- +14 SET FHPD=$PIECE(MCA,"^",2)
- SET K3=+MCA
- if 'K3
- SET K3=$PIECE(Y,"^",7)
- +15 SET CODE=$PIECE($GET(^FH(114.1,+K3,0)),"^",2)
- SET ZZ1=CODE
- +16 IF $EXTRACT(CODE,$LENGTH(CODE))="X"
- SET K3=$ORDER(^FH(114.1,"C",$EXTRACT(CODE,1,$LENGTH(CODE)-1),0))
- if 'K3
- SET K3=$PIECE(Y,"^",7)
- +17 SET K4=$PIECE($GET(^FH(114.1,+K3,0)),"^",3)
- SET K4=$SELECT('K4:99,K4<10:"0"_K4,1:K4)
- +18 FOR P2=1:1
- SET FHX2=$PIECE(FHPD," ",P2)
- if FHX2=""
- QUIT
- SET PD=$PIECE(FHX2,";",1)
- SET P4="~"
- IF PD'=""
- Begin DoDot:3
- +19 FOR SP=0:0
- SET SP=$ORDER(^TMP($JOB,"SRP",SP))
- if SP<1
- QUIT
- SET SRP=$GET(^TMP($JOB,"SRP",SP))
- SET Z1=$GET(^FH(116.1,FHX1,"RE",P1,"D",SP,0))
- SET Z1=$PIECE(Z1,"^",2)
- SET Z1=$SELECT(Z1="":1,1:Z1)
- DO SRP^FHDCR1B
- +20 DO STOR
- QUIT
- End DoDot:3
- +21 QUIT
- End DoDot:2
- +22 QUIT
- End DoDot:1
- +23 QUIT
- STOR ; Store Alternate recipes and default recipes
- +1 NEW CODE
- SET DBX=""
- SET CODE=ZZ1
- IF $EXTRACT(CODE,$LENGTH(CODE))?1"X"
- Begin DoDot:1
- +2 SET CODE=$EXTRACT(CODE,1,$LENGTH(CODE)-1)
- SET DBX="*** Omit "
- SET LC=0
- +3 FOR NX=0:0
- SET NX=$ORDER(^FH(114,+L1,"DBX",NX))
- if NX<1
- QUIT
- SET Z3=^(NX,0)
- SET QTY=$SELECT($PIECE(Z3,"^",2):$PIECE(Z3,"^",2),1:1)
- SET ZZ=QTY_" "_$PIECE($GET(^FH(114.1,+Z3,0)),"^",1)_", "
- if $LENGTH(DBX)+$LENGTH(ZZ)>28
- DO SET
- SET DBX=DBX_ZZ
- +4 DO SET
- QUIT
- End DoDot:1
- +5 IF $EXTRACT(CODE,$LENGTH(CODE))?1N
- IF $EXTRACT(CODE,$LENGTH(CODE))>1
- SET ^TMP($JOB,"ALT",M1,PD,CODE,+L1)=K4_"~"_K3_"~"_NAM_P4
- +6 SET ^TMP($JOB,M1,PD,K4_"~"_K3_"~"_NAM)=+L1_"^"_CODE_"^"_P4
- +7 if '$DATA(^TMP($JOB,"FHPO",NAM))
- SET ^TMP($JOB,"FHPO",NAM)=K4_"~"_K3_"~"_NAM
- +8 IF $DATA(^TMP($JOB,"FHDEF",M1,+L1))
- SET ^TMP($JOB,"DEF",M1,PD,K3_"~"_NAM)=+L1_"~"_K3_"~"_NAM
- QUIT
- +9 QUIT
- SET IF $LENGTH(DBX)>9
- SET LC=LC+1
- SET ^TMP($JOB,"DBX",M1,PD,+L1,LC)=$EXTRACT(DBX,1,$LENGTH(DBX)-2)
- SET DBX="*** Omit "
- +1 QUIT
- ALT ; Exchange dislike recipe with an alternate recipe
- +1 SET R1=$PIECE($GET(^TMP($JOB,MEAL,PD,X8)),"^",2)
- SET R2=R1
- if R1=""
- QUIT
- +2 FOR
- SET R2=$ORDER(^TMP($JOB,"ALT",MEAL,PD,R2))
- if R2=""!($EXTRACT(R1,1,$LENGTH(R1)-1)'=$EXTRACT(R2,1,$LENGTH(R2)-1))
- QUIT
- DO A1
- if X6
- QUIT
- +3 IF 'X6
- Begin DoDot:1
- +4 IF $EXTRACT(R1,1,$LENGTH(R1)-1)="E"
- SET MSG=" ** NO ENTREE **"
- SET EVT="M^O^^No Entree"
- DO ^FHORX
- QUIT
- +5 SET MSG=" ** NO "_$PIECE($GET(^FH(114.1,Z1,0)),"^",1)_" - FP"
- QUIT
- End DoDot:1
- +6 QUIT
- A1 SET R3=0
- A2 SET R3=$ORDER(^TMP($JOB,"ALT",MEAL,PD,R2,R3))
- if R3<1
- QUIT
- +1 SET Z=$GET(^TMP($JOB,"ALT",MEAL,PD,R2,R3))
- SET P4="~"_$PIECE(Z,"~",4,$LENGTH(Z,"~"))
- IF $FIND(P4,"~"_SP_"~")
- IF '$DATA(FP(R3))
- SET X6=R3
- QUIT
- +2 GOTO A2
- DECOD ; Decode code string
- +1 SET M1=$SELECT(MEAL="B":1,MEAL="N":2,1:3)
- SET STR=$PIECE(STR,";",M1)
- +2 FOR X4=1:1
- if $PIECE(STR," ",X4,99)=""
- QUIT
- Begin DoDot:1
- +3 SET X1=$PIECE(STR," ",X4)
- SET NAM=$PIECE($GET(^FH(114.1,+X1,0)),"^",1)
- SET $PIECE(X1,",",2)=$SELECT($PIECE(X1,",",2)'="":$PIECE(X1,",",2),1:1)
- +4 SET MP(+X1)=$PIECE(X1,",",2)
- QUIT
- End DoDot:1
- +5 QUIT
- CHK ; Check for Patient dislike on meal
- +1 FOR LL=0:0
- SET LL=$ORDER(^TMP($JOB,"X",MEAL,LL))
- if LL<1
- QUIT
- FOR KK=0:0
- SET KK=$ORDER(^TMP($JOB,"X",MEAL,LL,KK))
- if KK<1
- QUIT
- SET X1=+$GET(^TMP($JOB,"X",MEAL,LL,KK))
- Begin DoDot:1
- +2 SET X6=$ORDER(^FHPT(FHDFN,"P","B",LL,0))
- if X6<1
- QUIT
- +3 SET X2=$GET(^FHPT(FHDFN,"P",X6,0))
- if $PIECE(X2,"^",2)'[MEAL
- QUIT
- +4 SET FP(X1)=""
- +5 QUIT
- End DoDot:1
- +6 QUIT
- SO ; Store Standing Orders
- +1 KILL ALPHA,SONAME
- SET INDX=1
- FOR K=0:0
- SET K=$ORDER(^FHPT("ASP",FHDFN,ADM,K))
- if K<1
- QUIT
- Begin DoDot:1
- +2 SET X=$GET(^FHPT(FHDFN,"A",ADM,"SP",K,0))
- SET Z=$PIECE(X,"^",2)
- +3 SET SONAME=$PIECE($GET(^FH(118.3,+Z,0)),U,1)
- IF SONAME=""
- QUIT
- +4 IF $DATA(ALPHA(SONAME))
- SET SONAME=SONAME_INDX
- SET INDX=INDX+1
- +5 SET ALPHA(SONAME)=K_"^"_Z
- +6 QUIT
- End DoDot:1
- +7 SET SONAME=""
- FOR
- SET SONAME=$ORDER(ALPHA(SONAME))
- if SONAME=""
- QUIT
- Begin DoDot:1
- +8 SET K=$PIECE(ALPHA(SONAME),U,1)
- +9 SET X=$GET(^FHPT(FHDFN,"A",ADM,"SP",K,0))
- SET Z=$PIECE(X,U,2)
- SET M=$PIECE(X,U,3)
- if 'Z
- QUIT
- +10 IF M[MEAL
- SET S(NBR)=S(NBR)+1
- SET MM(S(NBR),NBR)=$SELECT($PIECE(X,"^",8):$PIECE(X,"^",8),1:1)_" "_$PIECE(^FH(118.3,+Z,0),"^",1)
- QUIT
- End DoDot:1
- +11 QUIT
- +12 ;
- SOUT ; Store Outpatient Standing Orders.
- +1 if '$GET(ADM)
- QUIT
- +2 SET FHOPDAT0=$GET(^FHPT(FHDFN,"OP",ADM,0))
- if $PIECE(FHOPDAT0,U,15)="C"
- QUIT
- +3 KILL ALPHA,SONAME
- SET INDX=1
- FOR K=0:0
- SET K=$ORDER(^FHPT("ASPO",FHDFN,ADM,K))
- if K<1
- QUIT
- Begin DoDot:1
- +4 SET X=$GET(^FHPT(FHDFN,"OP",ADM,"SP",K,0))
- SET Z=$PIECE(X,"^",2)
- +5 SET SONAME=$PIECE($GET(^FH(118.3,+Z,0)),U,1)
- IF SONAME=""
- QUIT
- +6 IF $DATA(ALPHA(SONAME))
- SET SONAME=SONAME_INDX
- SET INDX=INDX+1
- +7 SET ALPHA(SONAME)=K_"^"_Z
- +8 QUIT
- End DoDot:1
- +9 SET SONAME=""
- FOR
- SET SONAME=$ORDER(ALPHA(SONAME))
- if SONAME=""
- QUIT
- Begin DoDot:1
- +10 SET K=$PIECE(ALPHA(SONAME),U,1)
- +11 SET X=$GET(^FHPT(FHDFN,"OP",ADM,"SP",K,0))
- SET Z=$PIECE(X,U,2)
- SET M=$PIECE(X,U,3)
- if 'Z
- QUIT
- +12 IF M[MEAL
- SET S(NBR)=S(NBR)+1
- SET MM(S(NBR),NBR)=$SELECT($PIECE(X,"^",8):$PIECE(X,"^",8),1:1)_" "_$PIECE(^FH(118.3,+Z,0),"^",1)
- QUIT
- End DoDot:1
- +13 QUIT
- +14 ;
- BRK ; Break the line if allergies' length > 35 chars
- +1 IF J>2
- SET S(NBR)=S(NBR)+1
- SET MM(S(NBR),NBR)=$SELECT($LENGTH(ALG)<36:ALG,1:$JUSTIFY("",8)_"OTHERS")
- QUIT
- +2 IF $LENGTH(ALG)<36
- SET S(NBR)=S(NBR)+1
- SET J=J+1
- SET MM(S(NBR),NBR)=ALG
- QUIT
- +3 FOR L=37:-1:8
- if $EXTRACT(ALG,L-1,L)=", "
- QUIT
- +4 IF L=8
- SET L=35
- SET S(NBR)=S(NBR)+1
- SET J=J+1
- SET MM(S(NBR),NBR)=$EXTRACT(ALG,1,35)
- +5 IF '$TEST
- SET S(NBR)=S(NBR)+1
- SET J=J+1
- SET MM(S(NBR),NBR)=$EXTRACT(ALG,1,L-1)
- +6 SET ALG=$JUSTIFY("",8)_$EXTRACT(ALG,L+1,999)
- +7 GOTO BRK
