FHMTK4 ; HISC/NCA - Patient Diet Pattern Utility ;4/25/95 10:01
;;5.5;DIETETICS;;Jan 28, 2005
LIS ; List Diet Pattern of Diet Order
S ANS="" D SO Q:ANS="^" S STR=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2))
W !!!?33,"Diet Pattern"
W !! F CTR=1:1:3 W ?$S(CTR=1:9,CTR=2:35,1:61),$S(CTR=1:"Breakfast",CTR=2:"Noon",1:"Evening")
I STR'="" D DECOD G L1
F MEAL="B","N","E" D L3^FHMTK21
K MM,P S M1=0 F MEAL="B","N","E" S N1=0,M1=M1+1 D
.S NX="" F S NX=$O(^TMP($J,"FHMP",MP,MEAL,NX)) Q:NX="" S S1=$G(^(NX)),QTY=$S(S1="":1,1:+S1),N1=N1+1,PAD=$E(" ",1,4-$L(QTY)),MM(N1,M1)=PAD_QTY_" "_$P(NX,"~",2),P(M1,$P(S1,"^",2))=QTY
.;S NX="" F S NX=$O(^TMP($J,"FHMP",MP,MEAL,NX)) Q:NX="" S S1=$G(^(NX)),QTY=$S(S1="":1,1:+S1),N1=N1+1,MM(N1,M1)=$S(QTY#1>0:$J(QTY,3,2),1:QTY_" ")_" "_$P(NX,"~",2),P(M1,$P(S1,"^",2))=QTY
.Q
L1 W ! F N1=1:1 W ! Q:'$D(MM(N1)) F M1=1:1:3 I $D(MM(N1,M1)) W ?$S(M1=1:2,M1=2:28,1:54),MM(N1,M1)
Q
LIST ; List Recipe Category of a selected meal
W ! F NO=1:1 Q:'$D(MM(NO,MEAL)) W !,MM(NO,MEAL)
Q
SO ; List Standing Orders
W !?16,"Standing Orders",!
K N F K=0:0 S K=$O(^FHPT("ASP",FHDFN,ADM,K)) Q:K<1 S X=$G(^FHPT(FHDFN,"A",ADM,"SP",K,0)),M=$P(X,"^",3),M=$S(M="BNE":"A",1:$E(M,1)),N(M,K)=$P(X,"^",2,3)_"^"_$P(X,"^",8,9)
S LN=0 F M="A","B","N","E" D Q:ANS="^"
.F K=0:0 S K=$O(N(M,K)) Q:K<1 S Z=+N(M,K) I Z D Q:ANS="^"
..D L1^FHSPED W ! S NUM=$P(N(M,K),"^",3),LN=LN+1
..W ?5,M2,?18,$S(NUM:NUM,1:1)," ",$P(^FH(118.3,Z,0),"^",1),$S($P(N(M,K),"^",4)'="Y":" (I)",1:"")
..I LN>15 D PSE S LN=0
..Q
.Q
Q
SORT ; Sort Recipe Category in print order
F L1=1:1 Q:'$D(MM(L1,MEAL)) K MM(L1,MEAL)
S N1=0,M3=$S(MEAL=1:"B",MEAL=2:"N",1:"E"),NX=""
F S NX=$O(^TMP($J,"FHMP",MP,M3,NX)) Q:NX="" S S1=$G(^(NX)),Z=$P(S1,"^",2) I $D(P(MEAL,+Z)) S N1=N1+1,QTY=$S($G(P(MEAL,+Z))="":1,1:+$G(P(MEAL,+Z))),PAD=$E(" ",1,4-$L(QTY)),MM(N1,MEAL)=PAD_QTY_" "_$P(NX,"~",2)
;F S NX=$O(^TMP($J,"FHMP",MP,M3,NX)) Q:NX="" S S1=$G(^(NX)),Z=$P(S1,"^",2) I $D(P(MEAL,+Z)) S N1=N1+1,QTY=$S($G(P(MEAL,+Z))="":1,1:+$G(P(MEAL,+Z))),MM(N1,MEAL)=$S(QTY#1>0:$J(QTY,3,2),1:QTY_" ")_" "_$P(NX,"~",2)
Q
DECOD ; Decode code string
K MM,P F M1=1:1:3 S S1=$P(STR,";",M1),M3=$S(M1=1:"B",M1=2:"N",1:"E") D
.F X4=1:1 Q:$P(S1," ",X4,99)="" D
..S X1=$P(S1," ",X4),NAM=$P($G(^FH(114.1,+X1,0)),"^",1),$P(X1,",",2)=$S($P(X1,",",2)'="":$P(X1,",",2),1:1)
..S PAD=$E(" ",1,4-$L($P(X1,",",2)))
..S MM(X4,M1)=PAD_$P(X1,",",2)_" "_NAM,P(M1,+X1)=$P(X1,",",2)
..;S MM(X4,M1)=$S($P(X1,",",2)#1>0:$J($P(X1,",",2),3,2),1:$P(X1,",",2)_" ")_" "_NAM,P(M1,+X1)=$P(X1,",",2)
..S K1=$P($G(^FH(114.1,+X1,0)),"^",3),K1=$S('K1:99,K1<10:"0"_K1,1:K1)_"~"_NAM
..S ^TMP($J,"FHMP",MP,M3,K1)=$P(X1,",",2)_"^"_+X1 Q
.Q
Q
PSE I IOST?1"C-".E R !!,"Press RETURN to Continue ",X:DTIME W ! S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PSE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTK4 2888 printed Dec 13, 2024@01:48:12 Page 2
FHMTK4 ; HISC/NCA - Patient Diet Pattern Utility ;4/25/95 10:01
+1 ;;5.5;DIETETICS;;Jan 28, 2005
LIS ; List Diet Pattern of Diet Order
+1 SET ANS=""
DO SO
if ANS="^"
QUIT
SET STR=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2))
+2 WRITE !!!?33,"Diet Pattern"
+3 WRITE !!
FOR CTR=1:1:3
WRITE ?$SELECT(CTR=1:9,CTR=2:35,1:61),$SELECT(CTR=1:"Breakfast",CTR=2:"Noon",1:"Evening")
+4 IF STR'=""
DO DECOD
GOTO L1
+5 FOR MEAL="B","N","E"
DO L3^FHMTK21
+6 KILL MM,P
SET M1=0
FOR MEAL="B","N","E"
SET N1=0
SET M1=M1+1
Begin DoDot:1
+7 SET NX=""
FOR
SET NX=$ORDER(^TMP($JOB,"FHMP",MP,MEAL,NX))
if NX=""
QUIT
SET S1=$GET(^(NX))
SET QTY=$SELECT(S1="":1,1:+S1)
SET N1=N1+1
SET PAD=$EXTRACT(" ",1,4-$LENGTH(QTY))
SET MM(N1,M1)=PAD_QTY_" "_$PIECE(NX,"~",2)
SET P(M1,$PIECE(S1,"^",2))=QTY
+8 ;S NX="" F S NX=$O(^TMP($J,"FHMP",MP,MEAL,NX)) Q:NX="" S S1=$G(^(NX)),QTY=$S(S1="":1,1:+S1),N1=N1+1,MM(N1,M1)=$S(QTY#1>0:$J(QTY,3,2),1:QTY_" ")_" "_$P(NX,"~",2),P(M1,$P(S1,"^",2))=QTY
+9 QUIT
End DoDot:1
L1 WRITE !
FOR N1=1:1
WRITE !
if '$DATA(MM(N1))
QUIT
FOR M1=1:1:3
IF $DATA(MM(N1,M1))
WRITE ?$SELECT(M1=1:2,M1=2:28,1:54),MM(N1,M1)
+1 QUIT
LIST ; List Recipe Category of a selected meal
+1 WRITE !
FOR NO=1:1
if '$DATA(MM(NO,MEAL))
QUIT
WRITE !,MM(NO,MEAL)
+2 QUIT
SO ; List Standing Orders
+1 WRITE !?16,"Standing Orders",!
+2 KILL N
FOR K=0:0
SET K=$ORDER(^FHPT("ASP",FHDFN,ADM,K))
if K<1
QUIT
SET X=$GET(^FHPT(FHDFN,"A",ADM,"SP",K,0))
SET M=$PIECE(X,"^",3)
SET M=$SELECT(M="BNE":"A",1:$EXTRACT(M,1))
SET N(M,K)=$PIECE(X,"^",2,3)_"^"_$PIECE(X,"^",8,9)
+3 SET LN=0
FOR M="A","B","N","E"
Begin DoDot:1
+4 FOR K=0:0
SET K=$ORDER(N(M,K))
if K<1
QUIT
SET Z=+N(M,K)
IF Z
Begin DoDot:2
+5 DO L1^FHSPED
WRITE !
SET NUM=$PIECE(N(M,K),"^",3)
SET LN=LN+1
+6 WRITE ?5,M2,?18,$SELECT(NUM:NUM,1:1)," ",$PIECE(^FH(118.3,Z,0),"^",1),$SELECT($PIECE(N(M,K),"^",4)'="Y":" (I)",1:"")
+7 IF LN>15
DO PSE
SET LN=0
+8 QUIT
End DoDot:2
if ANS="^"
QUIT
+9 QUIT
End DoDot:1
if ANS="^"
QUIT
+10 QUIT
SORT ; Sort Recipe Category in print order
+1 FOR L1=1:1
if '$DATA(MM(L1,MEAL))
QUIT
KILL MM(L1,MEAL)
+2 SET N1=0
SET M3=$SELECT(MEAL=1:"B",MEAL=2:"N",1:"E")
SET NX=""
+3 FOR
SET NX=$ORDER(^TMP($JOB,"FHMP",MP,M3,NX))
if NX=""
QUIT
SET S1=$GET(^(NX))
SET Z=$PIECE(S1,"^",2)
IF $DATA(P(MEAL,+Z))
SET N1=N1+1
SET QTY=$SELECT($GET(P(MEAL,+Z))="":1,1:+$GET(P(MEAL,+Z)))
SET PAD=$EXTRACT(" ",1,4-$LENGTH(QTY))
SET MM(N1,MEAL)=PAD_QTY_" "_$PIECE(NX,"~",2)
+4 ;F S NX=$O(^TMP($J,"FHMP",MP,M3,NX)) Q:NX="" S S1=$G(^(NX)),Z=$P(S1,"^",2) I $D(P(MEAL,+Z)) S N1=N1+1,QTY=$S($G(P(MEAL,+Z))="":1,1:+$G(P(MEAL,+Z))),MM(N1,MEAL)=$S(QTY#1>0:$J(QTY,3,2),1:QTY_" ")_" "_$P(NX,"~",2)
+5 QUIT
DECOD ; Decode code string
+1 KILL MM,P
FOR M1=1:1:3
SET S1=$PIECE(STR,";",M1)
SET M3=$SELECT(M1=1:"B",M1=2:"N",1:"E")
Begin DoDot:1
+2 FOR X4=1:1
if $PIECE(S1," ",X4,99)=""
QUIT
Begin DoDot:2
+3 SET X1=$PIECE(S1," ",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 PAD=$EXTRACT(" ",1,4-$LENGTH($PIECE(X1,",",2)))
+5 SET MM(X4,M1)=PAD_$PIECE(X1,",",2)_" "_NAM
SET P(M1,+X1)=$PIECE(X1,",",2)
+6 ;S MM(X4,M1)=$S($P(X1,",",2)#1>0:$J($P(X1,",",2),3,2),1:$P(X1,",",2)_" ")_" "_NAM,P(M1,+X1)=$P(X1,",",2)
+7 SET K1=$PIECE($GET(^FH(114.1,+X1,0)),"^",3)
SET K1=$SELECT('K1:99,K1<10:"0"_K1,1:K1)_"~"_NAM
+8 SET ^TMP($JOB,"FHMP",MP,M3,K1)=$PIECE(X1,",",2)_"^"_+X1
QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
PSE IF IOST?1"C-".E
READ !!,"Press RETURN to Continue ",X:DTIME
WRITE !
if '$TEST!(X["^")
SET ANS="^"
if ANS="^"
QUIT
IF "^"'[X
WRITE !,"Enter a RETURN to Continue."
GOTO PSE
+1 QUIT
