- FHDCR1B ; HISC/NCA - Diet Card Utilities ;2/23/00 09:51
- ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
- ;patch#5 - added outpatient SO.
- Q1 ; Store Bread/Beverage default, Food Preference, and Recipes of meal
- S LN=$S(IOST?1"C".E:IOSL-2,1:IOSL-6),FHX4=FHX1 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" D GET
- Q
- GET F LL=0:0 S LL=$O(^FH(115.2,LL)) Q:LL<1 D
- .S L2=$G(^(LL,0))
- .I $P(L2,"^",2)="D" D Q
- ..I FLG S ^TMP($J,"X",M1,LL,0)=""
- ..F KK=0:0 S KK=$O(^FH(115.2,LL,"X",KK)) Q:KK<1 S REC=$P($G(^(KK,0)),"^",1) S ^TMP($J,"X",M1,LL,KK)=+REC
- ..Q
- .S REC=$P(L2,"^",4) Q:'REC S Y=$G(^FH(114,+REC,0)),NAM=$P(Y,"^",1),K3=$P(Y,"^",7) Q:'K3 I $P(L2,"^",5) D
- ..I $P(L2,"^",6)[M1 S:'$D(^TMP($J,"FHDEF",M1,K3,+REC)) ^TMP($J,"FHDEF",M1,K3,+REC)=+REC_"^"_NAM
- ..Q
- .Q
- I FLG D Q
- .S P1="" F S P1=$O(^FH(116.2,"C",P1)) Q:P1="" F P2=0:0 S P2=$O(^FH(116.2,"C",P1,P2)) Q:P2<1 S NN(P1)=+P2
- .F LL=0:0 S LL=$O(^TMP($J,"FHDEF",M1,LL)) Q:LL<1 F NX=0:0 S NX=$O(^TMP($J,"FHDEF",M1,LL,NX)) Q:NX<1 S L1=$G(^TMP($J,"FHDEF",M1,LL,NX)) D
- ..S NAM=$P(L1,"^",2)
- ..S PD="" F S PD=$O(NN(PD)) Q:PD="" D
- ...S P4="~" F SP=0:0 S SP=$O(^TMP($J,"SRP",SP)) Q:SP<1 S P4=P4_SP_"~"
- ...S ^TMP($J,"DEF",M1,PD,LL_"~"_NAM)=+L1_"~"_LL_"~"_NAM_P4
- ...Q
- ..Q
- .Q
- S FHX1=$P(FHX4,"^",$F("BNE",M1)) Q:'FHX1
- 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 K4=$P($G(^FH(114.1,+K3,0)),"^",3)
- ..Q:'$D(^TMP($J,"FHDEF",M1,K3))
- ..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
- ...S ^TMP($J,"DEF",M1,PD,K3_"~"_NAM)=+L1_"~"_K3_"~"_NAM_P4 Q
- ..Q
- .Q
- Q
- DECOD ; Decode code string
- S M1=$S(MEAL="B":1,MEAL="N":2,1:3),ST=$P(STR,";",M1)
- F X4=1:1 Q:$P(ST," ",X4,99)="" D
- .S X1=$P(ST," ",X4),ZZ=$G(^FH(114.1,+X1,0)),NAM=$P(ZZ,"^",1)
- .S K4=$P(ZZ,"^",3),K4=$S('K4:99,K4<10:"0"_K4,1:K4)
- .S $P(X1,",",2)=$S($P(X1,",",2)'="":$P(X1,",",2),1:1)
- .S MP(MEAL,K4_"~"_+X1_"~"_NAM)=$P(X1,",",2) Q
- Q
- DISL ; Store patient dislikes
- F LL=0:0 S LL=$O(^TMP($J,"X",MEAL,LL)) Q:LL<1 D DL1 F KK=0:0 S KK=$O(^TMP($J,"X",MEAL,LL,KK)) Q:KK<1
- Q
- DL1 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 TT(MEAL)=TT(MEAL)+1
- S SRT(TT(MEAL),MEAL)=" "_$E($P($G(^FH(115.2,+X2,0)),"^",1),1,15)
- 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(MEAL,X1)=""
- .Q
- Q
- SO ; Store Standing Orders
- 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),M=$P(X,"^",3) Q:'Z
- .I M[MEAL S TT(MEAL)=TT(MEAL)+1,SRT(TT(MEAL),MEAL)=$S($P(X,"^",8):$P(X,"^",8),1:1)_" "_$E($P($G(^FH(118.3,+Z,0)),"^",1),1,15) Q
- Q
- ;
- SOUT ; Store Outpatient Standing Orders.
- Q:'$G(FHKD)
- S FHOPDAT0=$G(^FHPT(FHDFN,"OP",FHKD,0)) Q:$P(FHOPDAT0,U,15)="C"
- F K=0:0 S K=$O(^FHPT("ASPO",FHDFN,FHKD,K)) Q:K<1 D
- .S X=$G(^FHPT(FHDFN,"OP",FHKD,"SP",K,0)),Z=$P(X,"^",2),M=$P(X,"^",3) Q:'Z
- .I M[MEAL S TT(MEAL)=TT(MEAL)+1,SRT(TT(MEAL),MEAL)=$S($P(X,"^",8):$P(X,"^",8),1:1)_" "_$E($P($G(^FH(118.3,+Z,0)),"^",1),1,15) Q
- Q
- ;
- SRP ; Store service point for each Production Diet of recipe
- I Z1 S:'$F(P4,"~"_SP_"~") P4=P4_SP_"~"
- S FHX3=$P(FHX2,";",2),SC=$S(FHX3'="":$E(FHX3,1),1:""),NUM=$S(SC'="":$P(FHX3,SC,2),1:"")
- I SC=$P(SRP,"^",2),NUM S:'$F(P4,"~"_SP_"~") P4=P4_SP_"~"
- S FHX3=$P(FHX2,";",3),SC=$S(FHX3'="":$E(FHX3,1),1:""),NUM=$S(SC'="":$P(FHX3,SC,2),1:"")
- I SC=$P(SRP,"^",2),NUM S:'$F(P4,"~"_SP_"~") P4=P4_SP_"~"
- Q
- BRK ; Break the line if allergies' length >50 chars
- I J>2 S S(NBR)=S(NBR)+1,^TMP($J,"MP",S(NBR),NBR)=$S($L(ALG)<51:ALG,1:$J("",8)_"OTHERS") Q
- I $L(ALG)<51 S S(NBR)=S(NBR)+1,J=J+1,^TMP($J,"MP",S(NBR),NBR)=ALG Q
- F L=52:-1:8 Q:$E(ALG,L-1,L)=", "
- I L=8 S L=50 S S(NBR)=S(NBR)+1,J=J+1,^TMP($J,"MP",S(NBR),NBR)=$E(ALG,1,50)
- E S S(NBR)=S(NBR)+1,J=J+1,^TMP($J,"MP",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[HFHDCR1B 4727 printed Feb 18, 2025@23:13:50 Page 2
- FHDCR1B ; HISC/NCA - Diet Card Utilities ;2/23/00 09:51
- +1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
- +2 ;patch#5 - added outpatient SO.
- Q1 ; Store Bread/Beverage default, Food Preference, and Recipes of meal
- +1 SET LN=$SELECT(IOST?1"C".E:IOSL-2,1:IOSL-6)
- SET FHX4=FHX1
- 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)
- +2 IF MEAL'="A"
- SET M1=MEAL
- DO GET
- QUIT
- +3 FOR M1="B","N","E"
- DO GET
- +4 QUIT
- GET FOR LL=0:0
- SET LL=$ORDER(^FH(115.2,LL))
- if LL<1
- QUIT
- Begin DoDot:1
- +1 SET L2=$GET(^(LL,0))
- +2 IF $PIECE(L2,"^",2)="D"
- Begin DoDot:2
- +3 IF FLG
- SET ^TMP($JOB,"X",M1,LL,0)=""
- +4 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
- +5 QUIT
- End DoDot:2
- QUIT
- +6 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 'K3
- QUIT
- IF $PIECE(L2,"^",5)
- Begin DoDot:2
- +7 IF $PIECE(L2,"^",6)[M1
- if '$DATA(^TMP($JOB,"FHDEF",M1,K3,+REC))
- SET ^TMP($JOB,"FHDEF",M1,K3,+REC)=+REC_"^"_NAM
- +8 QUIT
- End DoDot:2
- +9 QUIT
- End DoDot:1
- +10 IF FLG
- Begin DoDot:1
- +11 SET P1=""
- FOR
- SET P1=$ORDER(^FH(116.2,"C",P1))
- if P1=""
- QUIT
- FOR P2=0:0
- SET P2=$ORDER(^FH(116.2,"C",P1,P2))
- if P2<1
- QUIT
- SET NN(P1)=+P2
- +12 FOR LL=0:0
- SET LL=$ORDER(^TMP($JOB,"FHDEF",M1,LL))
- if LL<1
- QUIT
- FOR NX=0:0
- SET NX=$ORDER(^TMP($JOB,"FHDEF",M1,LL,NX))
- if NX<1
- QUIT
- SET L1=$GET(^TMP($JOB,"FHDEF",M1,LL,NX))
- Begin DoDot:2
- +13 SET NAM=$PIECE(L1,"^",2)
- +14 SET PD=""
- FOR
- SET PD=$ORDER(NN(PD))
- if PD=""
- QUIT
- Begin DoDot:3
- +15 SET P4="~"
- FOR SP=0:0
- SET SP=$ORDER(^TMP($JOB,"SRP",SP))
- if SP<1
- QUIT
- SET P4=P4_SP_"~"
- +16 SET ^TMP($JOB,"DEF",M1,PD,LL_"~"_NAM)=+L1_"~"_LL_"~"_NAM_P4
- +17 QUIT
- End DoDot:3
- +18 QUIT
- End DoDot:2
- +19 QUIT
- End DoDot:1
- QUIT
- +20 SET FHX1=$PIECE(FHX4,"^",$FIND("BNE",M1))
- if 'FHX1
- QUIT
- +21 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)
- +22 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
- +23 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
- +24 SET FHPD=$PIECE(MCA,"^",2)
- SET K3=+MCA
- if 'K3
- SET K3=$PIECE(Y,"^",7)
- SET K4=$PIECE($GET(^FH(114.1,+K3,0)),"^",3)
- +25 if '$DATA(^TMP($JOB,"FHDEF",M1,K3))
- QUIT
- +26 FOR P2=1:1
- SET FHX2=$PIECE(FHPD," ",P2)
- if FHX2=""
- QUIT
- SET PD=$PIECE(FHX2,";",1)
- SET P4="~"
- IF PD'=""
- Begin DoDot:3
- +27 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
- +28 SET ^TMP($JOB,"DEF",M1,PD,K3_"~"_NAM)=+L1_"~"_K3_"~"_NAM_P4
- QUIT
- End DoDot:3
- +29 QUIT
- End DoDot:2
- +30 QUIT
- End DoDot:1
- +31 QUIT
- DECOD ; Decode code string
- +1 SET M1=$SELECT(MEAL="B":1,MEAL="N":2,1:3)
- SET ST=$PIECE(STR,";",M1)
- +2 FOR X4=1:1
- if $PIECE(ST," ",X4,99)=""
- QUIT
- Begin DoDot:1
- +3 SET X1=$PIECE(ST," ",X4)
- SET ZZ=$GET(^FH(114.1,+X1,0))
- SET NAM=$PIECE(ZZ,"^",1)
- +4 SET K4=$PIECE(ZZ,"^",3)
- SET K4=$SELECT('K4:99,K4<10:"0"_K4,1:K4)
- +5 SET $PIECE(X1,",",2)=$SELECT($PIECE(X1,",",2)'="":$PIECE(X1,",",2),1:1)
- +6 SET MP(MEAL,K4_"~"_+X1_"~"_NAM)=$PIECE(X1,",",2)
- QUIT
- End DoDot:1
- +7 QUIT
- DISL ; Store patient dislikes
- +1 FOR LL=0:0
- SET LL=$ORDER(^TMP($JOB,"X",MEAL,LL))
- if LL<1
- QUIT
- DO DL1
- FOR KK=0:0
- SET KK=$ORDER(^TMP($JOB,"X",MEAL,LL,KK))
- if KK<1
- QUIT
- +2 QUIT
- DL1 SET X6=$ORDER(^FHPT(FHDFN,"P","B",LL,0))
- if X6<1
- QUIT
- +1 SET X2=$GET(^FHPT(FHDFN,"P",X6,0))
- if $PIECE(X2,"^",2)'[MEAL
- QUIT
- +2 SET TT(MEAL)=TT(MEAL)+1
- +3 SET SRT(TT(MEAL),MEAL)=" "_$EXTRACT($PIECE($GET(^FH(115.2,+X2,0)),"^",1),1,15)
- +4 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(MEAL,X1)=""
- +5 QUIT
- End DoDot:1
- +6 QUIT
- SO ; Store Standing Orders
- +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)
- SET M=$PIECE(X,"^",3)
- if 'Z
- QUIT
- +3 IF M[MEAL
- SET TT(MEAL)=TT(MEAL)+1
- SET SRT(TT(MEAL),MEAL)=$SELECT($PIECE(X,"^",8):$PIECE(X,"^",8),1:1)_" "_$EXTRACT($PIECE($GET(^FH(118.3,+Z,0)),"^",1),1,15)
- QUIT
- End DoDot:1
- +4 QUIT
- +5 ;
- SOUT ; Store Outpatient Standing Orders.
- +1 if '$GET(FHKD)
- QUIT
- +2 SET FHOPDAT0=$GET(^FHPT(FHDFN,"OP",FHKD,0))
- if $PIECE(FHOPDAT0,U,15)="C"
- QUIT
- +3 FOR K=0:0
- SET K=$ORDER(^FHPT("ASPO",FHDFN,FHKD,K))
- if K<1
- QUIT
- Begin DoDot:1
- +4 SET X=$GET(^FHPT(FHDFN,"OP",FHKD,"SP",K,0))
- SET Z=$PIECE(X,"^",2)
- SET M=$PIECE(X,"^",3)
- if 'Z
- QUIT
- +5 IF M[MEAL
- SET TT(MEAL)=TT(MEAL)+1
- SET SRT(TT(MEAL),MEAL)=$SELECT($PIECE(X,"^",8):$PIECE(X,"^",8),1:1)_" "_$EXTRACT($PIECE($GET(^FH(118.3,+Z,0)),"^",1),1,15)
- QUIT
- End DoDot:1
- +6 QUIT
- +7 ;
- SRP ; Store service point for each Production Diet of recipe
- +1 IF Z1
- if '$FIND(P4,"~"_SP_"~")
- SET P4=P4_SP_"~"
- +2 SET FHX3=$PIECE(FHX2,";",2)
- SET SC=$SELECT(FHX3'="":$EXTRACT(FHX3,1),1:"")
- SET NUM=$SELECT(SC'="":$PIECE(FHX3,SC,2),1:"")
- +3 IF SC=$PIECE(SRP,"^",2)
- IF NUM
- if '$FIND(P4,"~"_SP_"~")
- SET P4=P4_SP_"~"
- +4 SET FHX3=$PIECE(FHX2,";",3)
- SET SC=$SELECT(FHX3'="":$EXTRACT(FHX3,1),1:"")
- SET NUM=$SELECT(SC'="":$PIECE(FHX3,SC,2),1:"")
- +5 IF SC=$PIECE(SRP,"^",2)
- IF NUM
- if '$FIND(P4,"~"_SP_"~")
- SET P4=P4_SP_"~"
- +6 QUIT
- BRK ; Break the line if allergies' length >50 chars
- +1 IF J>2
- SET S(NBR)=S(NBR)+1
- SET ^TMP($JOB,"MP",S(NBR),NBR)=$SELECT($LENGTH(ALG)<51:ALG,1:$JUSTIFY("",8)_"OTHERS")
- QUIT
- +2 IF $LENGTH(ALG)<51
- SET S(NBR)=S(NBR)+1
- SET J=J+1
- SET ^TMP($JOB,"MP",S(NBR),NBR)=ALG
- QUIT
- +3 FOR L=52:-1:8
- if $EXTRACT(ALG,L-1,L)=", "
- QUIT
- +4 IF L=8
- SET L=50
- SET S(NBR)=S(NBR)+1
- SET J=J+1
- SET ^TMP($JOB,"MP",S(NBR),NBR)=$EXTRACT(ALG,1,50)
- +5 IF '$TEST
- SET S(NBR)=S(NBR)+1
- SET J=J+1
- SET ^TMP($JOB,"MP",S(NBR),NBR)=$EXTRACT(ALG,1,L-1)
- +6 SET ALG=$JUSTIFY("",8)_$EXTRACT(ALG,L+1,999)
- +7 GOTO BRK
