FHMTK11 ; HISC/REL/NCA - Build Tray Tickets (Cont.) ;2/23/00 09:53
;;5.5;DIETETICS;;Jan 28, 2005
BLD ; Build Tray Ticket list for a patient
S X1=$G(^FHPT(+FHDFN,"A",+ADM,0)),FHORD=$P(X1,"^",2),SVC=$P(X1,"^",5),SF=$P(X1,"^",7),IS=$P(X1,"^",10),FHD=$P(X1,"^",15),(FHOR,X)=""
I FHPAR'="Y" Q:SVC="C"
I SVC="C" S:SP'=SP1 SP=SP1 Q:'SP
Q:'FHORD S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
S PD=$P(X,"^",13),FHOR=$P(X,"^",2,6) Q:"^^^^"[FHOR
I IS S IS=$G(^FH(119.4,+IS,0)) S:IS'="" SVC=SVC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
S:SF SVC=SVC_" "_"SF"_"("_$S($P($G(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",34)="Y":"M",1:"I")_")"
I UPD D OLD I OLD=FHOR S FLG2=0 D EVT^FHDCR2 Q:'FLG2
S STR=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2)) K FP,MP,N2,NN,P4,PS D:STR'="" DECOD^FHMTK1B
S DPAT=$O(^FH(111.1,"AB",FHOR,0))
I DPAT S PD=$P($G(^FH(111.1,DPAT,0)),"^",7) I STR="",$O(MP(""))="" F X8=0:0 S X8=$O(^FH(111.1,DPAT,MEAL,X8)) Q:X8<1 S Z1=$G(^(X8,0)),MP(+Z1)=$P(Z1,"^",2)
Q:PD="" S PD=$P($G(^FH(116.2,PD,0)),"^",2) Q:PD="" D CHK^FHMTK1B
I NBR=3 D PRT^FHMTK1C K MM,PP,S S NBR=0
S NBR=NBR+1 D PID^FHDPA
F X6=0:0 S X6=$O(^FHPT(FHDFN,"P","B",X6)) Q:X6<1 F X7=0:0 S X7=$O(^FHPT(FHDFN,"P","B",X6,X7)) Q:X7<1 S PS=$P($G(^FH(115.2,+X6,0)),"^",4) I PS S P4=$G(^FH(114,+PS,0)),P1=$P(P4,"^",7)_"^"_+PS_"^"_$P(P4,"^",1) I +P1 D
.S CHK="" F S CHK=$O(^TMP($J,"DEF",MEAL,PD,CHK)) Q:CHK="" S C1=$G(^(CHK)) I $D(^TMP($J,"FHDEF",MEAL,+C1)),+^TMP($J,"FHDEF",MEAL,+C1)=+P1 D Q
..S C2=$G(^FHPT(FHDFN,"P",+X7,0)) Q:$P(C2,"^",2)'[MEAL
..S P2=+CHK,P3=$P(P1,"^",3) S:'$D(N2(P2,+C1,P3)) N2(P2,+C1,P3)=+$P(P1,"^",2)_"^"_P3 Q
.Q
S Y0=$P($G(^DPT(DFN,0)),"^",1)_" ("_BID_")"_" "_SVC,S(NBR)=0,N1=0
D CUR^FHORD7 S N1=N1+1 I $L(Y)<40 S PP(N1,NBR)=Y
E S L=$S($L($P(Y,",",1,3))<40:3,1:2) S PP(N1,NBR)=$P(Y,",",1,L),N1=N1+1,PP(N1,NBR)=$E($P(Y,",",L+1,5),2,99)
S MM(0,NBR)=Y0_"^"_WRDN_"^"_RM
I $G(DFN) D ALG^FHCLN S ALG="ALLGS.: "_$S(ALG="":"NONE ON FILE",1:ALG) S J=0 D BRK^FHMTK1B
S X8="" F S X8=$O(^TMP($J,MEAL,PD,X8)) Q:X8="" S (P4,X1)=^(X8),X1=+X1,P4=$P(P4,"^",3) D
.S Z1=+$P(X8,"~",2) Q:'$F(P4,"~"_SP_"~")
.S (MSG,X6)="",CTR=1
.S QTY="" Q:'$D(MP(Z1)) Q:MP(Z1)=0 S PAD=$E(" ",1,5-$L(MP(Z1))),QTY=MP(Z1)_PAD,CTR=$J(MP(Z1),0,2)
.S:$G(^TMP($J,"FHPO",$P(X8,"~",3)))="" ^TMP($J,"FHPO",$P(X8,"~",3))=X8 S C2=$G(^TMP($J,"FHPO",$P(X8,"~",3)))
.I $D(N2(Z1,X1)) D BRD Q
.I $D(FP(+X1)) D SUB Q
.S NN(X8)=QTY_$P(X8,"~",3) D CNT
.I $D(^TMP($J,"DBX",MEAL,PD,+X1)) F LL=0:0 S LL=$O(^TMP($J,"DBX",MEAL,PD,+X1,LL)) Q:LL<1 S NN(X8_" "_LL)=$G(^(LL))
.Q
S X8="" F S X8=$O(NN(X8)) Q:X8="" D
.S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=$G(NN(X8)) Q
S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=""
D SO^FHMTK1B
Q
SUB ; Get Substitutes
D ALT^FHMTK1B S:MSG'="" NN(X8)=MSG Q:'X6
S X1=+X6,XX=Z,Z1=$P(XX,"~",2) I $D(N2(Z1,X1)) D BRD Q
S:$D(^TMP($J,"FHPO",$P(XX,"~",3))) XX=$G(^TMP($J,"FHPO",$P(XX,"~",3)))
S NN(XX)=QTY_$P(XX,"~",3)
S CT=$G(^TMP($J,"CTR",MEAL,XX,SP))
S CT=CT+CTR,^TMP($J,"CTR",MEAL,XX,SP)=CT D C1
I SUM S TOT=$G(^TMP($J,"TOT",XX,SP)),TOT=TOT+CTR,^TMP($J,"TOT",XX,SP)=TOT
I $D(^TMP($J,"DBX",MEAL,PD,+X1)) F LL=0:0 S LL=$O(^TMP($J,"DBX",MEAL,PD,+X1,LL)) Q:LL<1 S NN(XX_" "_LL)=$G(^(LL))
Q
BRD ; Get Bread/Beverage
S (X7,XX)="" F S X7=$O(N2(Z1,X1,X7)) Q:X7="" D
.S L1=+N2(Z1,X1,X7),XX=$P(X8,"~",1,2)_"~"_X7
.I '$D(NN(XX)) S NN(XX)=QTY_X7 S CT=$G(^TMP($J,"CTR",MEAL,XX,SP)),CT=CT+CTR,^TMP($J,"CTR",MEAL,XX,SP)=CT D C1 I SUM S TOT=$G(^TMP($J,"TOT",XX,SP)),TOT=TOT+CTR,^TMP($J,"TOT",XX,SP)=TOT
.Q
Q
CNT ; Count Recipe items for Service Points
S CT=$G(^TMP($J,"CTR",MEAL,C2,SP)),CT=CT+CTR,^TMP($J,"CTR",MEAL,C2,SP)=CT
I SUM S TOT=$G(^TMP($J,"TOT",C2,SP)),TOT=TOT+CTR,^TMP($J,"TOT",C2,SP)=TOT
C1 ; Setup Service Points Array
S M1=$G(^TMP($J,"SRP",SP)),M2=$P(M1,"^",1),M3=$P(M1,"^",4)
S:M3="" M3=$E(M2,1,8) I '$D(DP(MEAL,M3,SP)) S DP(MEAL,M3,SP)=$J(M3,10),LS(MEAL)=LS(MEAL)+10,P(MEAL,M3,SP)=""
I SUM,'$D(TP(M3,SP)) S TP(M3,SP)=$J(M3,10),SL=SL+10,T1(M3,SP)=""
Q
OLD ; Get Previous Diet Order
S:'FHD FHD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",1)
S E1="" F NXT=0:0 S NXT=$O(^FHPT(FHDFN,"A",ADM,"AC",NXT)) Q:NXT<1!(NXT>FHD) S E1=NXT
I 'E1 S OLD="^^^^" Q
S KK=$P($G(^FHPT(FHDFN,"A",ADM,"AC",E1,0)),"^",2) I 'KK S OLD="^^^^" Q
S NNXX="" I NXT'="" S NNXX=$P($G(^FHPT(FHDFN,"A",ADM,"AC",NXT,0)),"^",2)
I NNXX'="",$P($G(^FHPT(FHDFN,"A",ADM,"DI",NNXX,0)),U,10)=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),U,9),$P($G(^FHPT(FHDFN,"A",ADM,"DI",NNXX,0)),U,7)="N" S OLD="^^^^" Q
S OLD=$P($G(^FHPT(FHDFN,"A",ADM,"DI",KK,0)),"^",2,6) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTK11 4565 printed Dec 13, 2024@01:48:05 Page 2
FHMTK11 ; HISC/REL/NCA - Build Tray Tickets (Cont.) ;2/23/00 09:53
+1 ;;5.5;DIETETICS;;Jan 28, 2005
BLD ; Build Tray Ticket list for a patient
+1 SET X1=$GET(^FHPT(+FHDFN,"A",+ADM,0))
SET FHORD=$PIECE(X1,"^",2)
SET SVC=$PIECE(X1,"^",5)
SET SF=$PIECE(X1,"^",7)
SET IS=$PIECE(X1,"^",10)
SET FHD=$PIECE(X1,"^",15)
SET (FHOR,X)=""
+2 IF FHPAR'="Y"
if SVC="C"
QUIT
+3 IF SVC="C"
if SP'=SP1
SET SP=SP1
if 'SP
QUIT
+4 if 'FHORD
QUIT
SET X=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
+5 SET PD=$PIECE(X,"^",13)
SET FHOR=$PIECE(X,"^",2,6)
if "^^^^"[FHOR
QUIT
+6 IF IS
SET IS=$GET(^FH(119.4,+IS,0))
if IS'=""
SET SVC=SVC_"-"_$PIECE(IS,"^",2)_$PIECE(IS,"^",3)
+7 if SF
SET SVC=SVC_" "_"SF"_"("_$SELECT($PIECE($GET(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",34)="Y":"M",1:"I")_")"
+8 IF UPD
DO OLD
IF OLD=FHOR
SET FLG2=0
DO EVT^FHDCR2
if 'FLG2
QUIT
+9 SET STR=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2))
KILL FP,MP,N2,NN,P4,PS
if STR'=""
DO DECOD^FHMTK1B
+10 SET DPAT=$ORDER(^FH(111.1,"AB",FHOR,0))
+11 IF DPAT
SET PD=$PIECE($GET(^FH(111.1,DPAT,0)),"^",7)
IF STR=""
IF $ORDER(MP(""))=""
FOR X8=0:0
SET X8=$ORDER(^FH(111.1,DPAT,MEAL,X8))
if X8<1
QUIT
SET Z1=$GET(^(X8,0))
SET MP(+Z1)=$PIECE(Z1,"^",2)
+12 if PD=""
QUIT
SET PD=$PIECE($GET(^FH(116.2,PD,0)),"^",2)
if PD=""
QUIT
DO CHK^FHMTK1B
+13 IF NBR=3
DO PRT^FHMTK1C
KILL MM,PP,S
SET NBR=0
+14 SET NBR=NBR+1
DO PID^FHDPA
+15 FOR X6=0:0
SET X6=$ORDER(^FHPT(FHDFN,"P","B",X6))
if X6<1
QUIT
FOR X7=0:0
SET X7=$ORDER(^FHPT(FHDFN,"P","B",X6,X7))
if X7<1
QUIT
SET PS=$PIECE($GET(^FH(115.2,+X6,0)),"^",4)
IF PS
SET P4=$GET(^FH(114,+PS,0))
SET P1=$PIECE(P4,"^",7)_"^"_+PS_"^"_$PIECE(P4,"^",1)
IF +P1
Begin DoDot:1
+16 SET CHK=""
FOR
SET CHK=$ORDER(^TMP($JOB,"DEF",MEAL,PD,CHK))
if CHK=""
QUIT
SET C1=$GET(^(CHK))
IF $DATA(^TMP($JOB,"FHDEF",MEAL,+C1))
IF +^TMP($JOB,"FHDEF",MEAL,+C1)=+P1
Begin DoDot:2
+17 SET C2=$GET(^FHPT(FHDFN,"P",+X7,0))
if $PIECE(C2,"^",2)'[MEAL
QUIT
+18 SET P2=+CHK
SET P3=$PIECE(P1,"^",3)
if '$DATA(N2(P2,+C1,P3))
SET N2(P2,+C1,P3)=+$PIECE(P1,"^",2)_"^"_P3
QUIT
End DoDot:2
QUIT
+19 QUIT
End DoDot:1
+20 SET Y0=$PIECE($GET(^DPT(DFN,0)),"^",1)_" ("_BID_")"_" "_SVC
SET S(NBR)=0
SET N1=0
+21 DO CUR^FHORD7
SET N1=N1+1
IF $LENGTH(Y)<40
SET PP(N1,NBR)=Y
+22 IF '$TEST
SET L=$SELECT($LENGTH($PIECE(Y,",",1,3))<40:3,1:2)
SET PP(N1,NBR)=$PIECE(Y,",",1,L)
SET N1=N1+1
SET PP(N1,NBR)=$EXTRACT($PIECE(Y,",",L+1,5),2,99)
+23 SET MM(0,NBR)=Y0_"^"_WRDN_"^"_RM
+24 IF $GET(DFN)
DO ALG^FHCLN
SET ALG="ALLGS.: "_$SELECT(ALG="":"NONE ON FILE",1:ALG)
SET J=0
DO BRK^FHMTK1B
+25 SET X8=""
FOR
SET X8=$ORDER(^TMP($JOB,MEAL,PD,X8))
if X8=""
QUIT
SET (P4,X1)=^(X8)
SET X1=+X1
SET P4=$PIECE(P4,"^",3)
Begin DoDot:1
+26 SET Z1=+$PIECE(X8,"~",2)
if '$FIND(P4,"~"_SP_"~")
QUIT
+27 SET (MSG,X6)=""
SET CTR=1
+28 SET QTY=""
if '$DATA(MP(Z1))
QUIT
if MP(Z1)=0
QUIT
SET PAD=$EXTRACT(" ",1,5-$LENGTH(MP(Z1)))
SET QTY=MP(Z1)_PAD
SET CTR=$JUSTIFY(MP(Z1),0,2)
+29 if $GET(^TMP($JOB,"FHPO",$PIECE(X8,"~",3)))=""
SET ^TMP($JOB,"FHPO",$PIECE(X8,"~",3))=X8
SET C2=$GET(^TMP($JOB,"FHPO",$PIECE(X8,"~",3)))
+30 IF $DATA(N2(Z1,X1))
DO BRD
QUIT
+31 IF $DATA(FP(+X1))
DO SUB
QUIT
+32 SET NN(X8)=QTY_$PIECE(X8,"~",3)
DO CNT
+33 IF $DATA(^TMP($JOB,"DBX",MEAL,PD,+X1))
FOR LL=0:0
SET LL=$ORDER(^TMP($JOB,"DBX",MEAL,PD,+X1,LL))
if LL<1
QUIT
SET NN(X8_" "_LL)=$GET(^(LL))
+34 QUIT
End DoDot:1
+35 SET X8=""
FOR
SET X8=$ORDER(NN(X8))
if X8=""
QUIT
Begin DoDot:1
+36 SET S(NBR)=S(NBR)+1
SET MM(S(NBR),NBR)=$GET(NN(X8))
QUIT
End DoDot:1
+37 SET S(NBR)=S(NBR)+1
SET MM(S(NBR),NBR)=""
+38 DO SO^FHMTK1B
+39 QUIT
SUB ; Get Substitutes
+1 DO ALT^FHMTK1B
if MSG'=""
SET NN(X8)=MSG
if 'X6
QUIT
+2 SET X1=+X6
SET XX=Z
SET Z1=$PIECE(XX,"~",2)
IF $DATA(N2(Z1,X1))
DO BRD
QUIT
+3 if $DATA(^TMP($JOB,"FHPO",$PIECE(XX,"~",3)))
SET XX=$GET(^TMP($JOB,"FHPO",$PIECE(XX,"~",3)))
+4 SET NN(XX)=QTY_$PIECE(XX,"~",3)
+5 SET CT=$GET(^TMP($JOB,"CTR",MEAL,XX,SP))
+6 SET CT=CT+CTR
SET ^TMP($JOB,"CTR",MEAL,XX,SP)=CT
DO C1
+7 IF SUM
SET TOT=$GET(^TMP($JOB,"TOT",XX,SP))
SET TOT=TOT+CTR
SET ^TMP($JOB,"TOT",XX,SP)=TOT
+8 IF $DATA(^TMP($JOB,"DBX",MEAL,PD,+X1))
FOR LL=0:0
SET LL=$ORDER(^TMP($JOB,"DBX",MEAL,PD,+X1,LL))
if LL<1
QUIT
SET NN(XX_" "_LL)=$GET(^(LL))
+9 QUIT
BRD ; Get Bread/Beverage
+1 SET (X7,XX)=""
FOR
SET X7=$ORDER(N2(Z1,X1,X7))
if X7=""
QUIT
Begin DoDot:1
+2 SET L1=+N2(Z1,X1,X7)
SET XX=$PIECE(X8,"~",1,2)_"~"_X7
+3 IF '$DATA(NN(XX))
SET NN(XX)=QTY_X7
SET CT=$GET(^TMP($JOB,"CTR",MEAL,XX,SP))
SET CT=CT+CTR
SET ^TMP($JOB,"CTR",MEAL,XX,SP)=CT
DO C1
IF SUM
SET TOT=$GET(^TMP($JOB,"TOT",XX,SP))
SET TOT=TOT+CTR
SET ^TMP($JOB,"TOT",XX,SP)=TOT
+4 QUIT
End DoDot:1
+5 QUIT
CNT ; Count Recipe items for Service Points
+1 SET CT=$GET(^TMP($JOB,"CTR",MEAL,C2,SP))
SET CT=CT+CTR
SET ^TMP($JOB,"CTR",MEAL,C2,SP)=CT
+2 IF SUM
SET TOT=$GET(^TMP($JOB,"TOT",C2,SP))
SET TOT=TOT+CTR
SET ^TMP($JOB,"TOT",C2,SP)=TOT
C1 ; Setup Service Points Array
+1 SET M1=$GET(^TMP($JOB,"SRP",SP))
SET M2=$PIECE(M1,"^",1)
SET M3=$PIECE(M1,"^",4)
+2 if M3=""
SET M3=$EXTRACT(M2,1,8)
IF '$DATA(DP(MEAL,M3,SP))
SET DP(MEAL,M3,SP)=$JUSTIFY(M3,10)
SET LS(MEAL)=LS(MEAL)+10
SET P(MEAL,M3,SP)=""
+3 IF SUM
IF '$DATA(TP(M3,SP))
SET TP(M3,SP)=$JUSTIFY(M3,10)
SET SL=SL+10
SET T1(M3,SP)=""
+4 QUIT
OLD ; Get Previous Diet Order
+1 if 'FHD
SET FHD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",1)
+2 SET E1=""
FOR NXT=0:0
SET NXT=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",NXT))
if NXT<1!(NXT>FHD)
QUIT
SET E1=NXT
+3 IF 'E1
SET OLD="^^^^"
QUIT
+4 SET KK=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"AC",E1,0)),"^",2)
IF 'KK
SET OLD="^^^^"
QUIT
+5 SET NNXX=""
IF NXT'=""
SET NNXX=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"AC",NXT,0)),"^",2)
+6 IF NNXX'=""
IF $PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",NNXX,0)),U,10)=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),U,9)
IF $PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",NNXX,0)),U,7)="N"
SET OLD="^^^^"
QUIT
+7 SET OLD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",KK,0)),"^",2,6)
QUIT
