FHMTKO ; HISC/NCA/FAI - List Outpats Without Diet Patterns/Ind Pattern ;02/24/04 11:00
;;5.5;DIETETICS;;Jan 28, 2005
LIS W !!,"The list requires a 132 column printer.",!
W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="L1^FHMTKO",FHLST="" D EN2^FH G KIL
U IO D L1 D ^%ZISC K %ZIS,IOP G KIL
L1 ; Process Listing Outpatients Without Diet Patterns & Inpatients
; With Individual Pattern
D NOW^%DTC S DTP=% D DTP^FH S FHDTP=DTP
K ^TMP($J,"D"),^TMP($J,"NP"),^TMP($J,"W") S ANS=""
F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 D
.S P0=$G(^FH(119.6,W1,0)),WRDN=$P(P0,"^",1),P0=$P(P0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
.S ^TMP($J,"W",P0_WRDN)=W1 Q
S NX="" F S NX=$O(^TMP($J,"W",NX)) Q:NX="" S X1=$G(^(NX)),W1=+X1 D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 D
..D PATNAME^FHOMUTL I DFN="" Q
..S ADM=$G(^FHPT("AW",W1,FHDFN)),RI=$G(^DPT(DFN,.108)),RM=$G(^DPT(DFN,.101)) S:RM="" RM="***"
..S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"")
..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
..D CUR^FHORD7 Q:"^^^^"[FHOR S:Y'="" O1=Y
..Q:$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2))'=""
..S DPAT=$O(^FH(111.1,"AB",FHOR,0))
..I 'DPAT S ^TMP($J,"NP",NX_"~"_R0_"~"_RM_"~"_FHDFN)=FHDFN_"^"_ADM_"^"_O1 Q
..S TIM=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),"^",9) D GET
..Q
.Q
S PG=0 D HDR S X9="" F S X9=$O(^TMP($J,"NP",X9)) Q:X9="" S FHDFN=$P(^(X9),"^",1),ADM=$P(^(X9),"^",2),Y=$P(^(X9),"^",3) D Q:ANS="^"
.D PATNAME^FHOMUTL I DFN="" Q
.S RM=$P(X9,"~",3),WRDN=$E($P(X9,"~",1),3,99)
.D:$Y'<(IOSL-8) HDR Q:ANS="^"
.W !,$E(WRDN,1,15)_"/"_$E(RM,1,15),?34,$E($P($G(^DPT(DFN,0)),"^",1),1,30),?66,Y Q
Q:ANS="^" S PG=0 D HDR1 S X9="" F S X9=$O(^TMP($J,"D",X9)) Q:X9="" S XX=$G(^(X9)),ZZ=$G(^(X9,1)),FHDFN=$P(XX,"^",1),ADM=$P(XX,"^",2),Y=$P(XX,"^",3) D Q:ANS="^"
.S RM=$P(X9,"~",3),WRDN=$E($P(X9,"~",1),3,99)
.D:$Y'<(IOSL-8) HDR1 Q:ANS="^"
.W !!,$E(WRDN,1,15)_"/"_$E(RM,1,15),!,$E($P($G(^DPT(DFN,0)),"^",1),1,30)
.S DTP=$P(XX,"^",4) D:DTP'="" DTP^FH W:DTP'="" ?32,DTP W ?52,"Current: ",Y,!
.S DTP=$P(ZZ,"^",2) D:DTP'="" DTP^FH W:DTP'="" ?32,DTP W ?52,"Prev. Pattern: ",$P(ZZ,"^",1),! Q
Q
GET ; Get Previous Diet Order
K ^TMP($J,"TRAV") S SK=0 F K0=0:0 S K0=$O(^FHPT(FHDFN,"A",ADM,"AC",K0)) Q:K0<1!(K0'<TIM) S K2=$G(^(K0,0)),SK=K0,^TMP($J,"TRAV",9999999-SK)=K2
S X7="" F K0=0:0 S K0=$O(^TMP($J,"TRAV",K0)) Q:K0<1 S K2=$G(^(K0)) D Q:X7'=""
.S X5=$P(K2,"^",2) Q:'X5
.S X6=$G(^FHPT(FHDFN,"A",ADM,"DI",+X5,0)) Q:X6=""
.Q:$P(X6,"^",7)'=""
.S X7=$G(^FHPT(FHDFN,"A",ADM,"DI",+X5,2))
.Q:X7=""
.S X8=$P($G(^FHPT(FHDFN,"A",ADM,"DI",+X5,0)),"^",9) D CUR
.S X8=$S($P($G(^FHPT(FHDFN,"A",ADM,"DI",+X5,3)),"^",2):$P(^FHPT(FHDFN,"A",ADM,"DI",+X5,3),"^",2),1:X8)
.S ^TMP($J,"D",NX_"~"_R0_"~"_RM_"~"_FHDFN)=FHDFN_"^"_ADM_"^"_O1_"^"_TIM
.S ^TMP($J,"D",NX_"~"_R0_"~"_RM_"~"_FHDFN,1)=Y_"^"_X8 Q
.Q
Q
CUR S Y="" Q:X6="" S FHOR=$P(X6,"^",2,6),FHLD=$P(X6,"^",7)
I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") Q:%<1 S Y=$P($E(FHDU,%,999),";",1) Q
F A1=1:1:5 S D3=$P(FHOR,"^",A1) I D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7)
Q
HDR ; Print No Diet Pattern Heading
D PAUSE Q:ANS="^" W:'($E(IOST,1,2)'="C-"&'PG) @IOF
S PG=PG+1 W !,FHDTP,?33,"I N P A T I E N T S W I T H N O D I E T P A T T E R N S",?123,"Page ",PG
W !!,"Ward/Room",?34,"Patient",?66,"Current-Diet",!
Q
HDR1 ; Print Previous Diet Pattern Heading
S PG=PG+1 D PAUSE Q:ANS="^" W:'($E(IOST,1,2)'="C-"&'PG) @IOF
W !,FHDTP,?27,"I N P A T I E N T S T H A T H A D I N D I V I D U A L P A T T E R N S",?123,"Page ",PG
W !!,"Patient",?32,"Effective",?52,"Diet"
Q
PAUSE ; Check to pause for reading
I IOST?1"C".E,PG R !!,"Press RETURN to continue. ",X:DTIME S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PAUSE
Q
KIL K ^TMP($J) G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTKO 3980 printed Sep 23, 2025@19:24:17 Page 2
FHMTKO ; HISC/NCA/FAI - List Outpats Without Diet Patterns/Ind Pattern ;02/24/04 11:00
+1 ;;5.5;DIETETICS;;Jan 28, 2005
LIS WRITE !!,"The list requires a 132 column printer.",!
+1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+2 IF $DATA(IO("Q"))
SET FHPGM="L1^FHMTKO"
SET FHLST=""
DO EN2^FH
GOTO KIL
+3 USE IO
DO L1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
L1 ; Process Listing Outpatients Without Diet Patterns & Inpatients
+1 ; With Individual Pattern
+2 DO NOW^%DTC
SET DTP=%
DO DTP^FH
SET FHDTP=DTP
+3 KILL ^TMP($JOB,"D"),^TMP($JOB,"NP"),^TMP($JOB,"W")
SET ANS=""
+4 FOR W1=0:0
SET W1=$ORDER(^FH(119.6,W1))
if W1<1
QUIT
Begin DoDot:1
+5 SET P0=$GET(^FH(119.6,W1,0))
SET WRDN=$PIECE(P0,"^",1)
SET P0=$PIECE(P0,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
+6 SET ^TMP($JOB,"W",P0_WRDN)=W1
QUIT
End DoDot:1
+7 SET NX=""
FOR
SET NX=$ORDER(^TMP($JOB,"W",NX))
if NX=""
QUIT
SET X1=$GET(^(NX))
SET W1=+X1
Begin DoDot:1
+8 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
if FHDFN<1
QUIT
Begin DoDot:2
+9 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+10 SET ADM=$GET(^FHPT("AW",W1,FHDFN))
SET RI=$GET(^DPT(DFN,.108))
SET RM=$GET(^DPT(DFN,.101))
if RM=""
SET RM="***"
+11 SET RE=$SELECT(RI:$ORDER(^FH(119.6,"AR",+RI,W1,0)),1:"")
+12 SET R0=$SELECT(RE:$PIECE($GET(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
+13 SET R0=$SELECT(R0<1:99,R0<10:"0"_R0,1:R0)
+14 DO CUR^FHORD7
if "^^^^"[FHOR
QUIT
if Y'=""
SET O1=Y
+15 if $GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2))'=""
QUIT
+16 SET DPAT=$ORDER(^FH(111.1,"AB",FHOR,0))
+17 IF 'DPAT
SET ^TMP($JOB,"NP",NX_"~"_R0_"~"_RM_"~"_FHDFN)=FHDFN_"^"_ADM_"^"_O1
QUIT
+18 SET TIM=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),"^",9)
DO GET
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 SET PG=0
DO HDR
SET X9=""
FOR
SET X9=$ORDER(^TMP($JOB,"NP",X9))
if X9=""
QUIT
SET FHDFN=$PIECE(^(X9),"^",1)
SET ADM=$PIECE(^(X9),"^",2)
SET Y=$PIECE(^(X9),"^",3)
Begin DoDot:1
+22 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+23 SET RM=$PIECE(X9,"~",3)
SET WRDN=$EXTRACT($PIECE(X9,"~",1),3,99)
+24 if $Y'<(IOSL-8)
DO HDR
if ANS="^"
QUIT
+25 WRITE !,$EXTRACT(WRDN,1,15)_"/"_$EXTRACT(RM,1,15),?34,$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^",1),1,30),?66,Y
QUIT
End DoDot:1
if ANS="^"
QUIT
+26 if ANS="^"
QUIT
SET PG=0
DO HDR1
SET X9=""
FOR
SET X9=$ORDER(^TMP($JOB,"D",X9))
if X9=""
QUIT
SET XX=$GET(^(X9))
SET ZZ=$GET(^(X9,1))
SET FHDFN=$PIECE(XX,"^",1)
SET ADM=$PIECE(XX,"^",2)
SET Y=$PIECE(XX,"^",3)
Begin DoDot:1
+27 SET RM=$PIECE(X9,"~",3)
SET WRDN=$EXTRACT($PIECE(X9,"~",1),3,99)
+28 if $Y'<(IOSL-8)
DO HDR1
if ANS="^"
QUIT
+29 WRITE !!,$EXTRACT(WRDN,1,15)_"/"_$EXTRACT(RM,1,15),!,$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^",1),1,30)
+30 SET DTP=$PIECE(XX,"^",4)
if DTP'=""
DO DTP^FH
if DTP'=""
WRITE ?32,DTP
WRITE ?52,"Current: ",Y,!
+31 SET DTP=$PIECE(ZZ,"^",2)
if DTP'=""
DO DTP^FH
if DTP'=""
WRITE ?32,DTP
WRITE ?52,"Prev. Pattern: ",$PIECE(ZZ,"^",1),!
QUIT
End DoDot:1
if ANS="^"
QUIT
+32 QUIT
GET ; Get Previous Diet Order
+1 KILL ^TMP($JOB,"TRAV")
SET SK=0
FOR K0=0:0
SET K0=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K0))
if K0<1!(K0'<TIM)
QUIT
SET K2=$GET(^(K0,0))
SET SK=K0
SET ^TMP($JOB,"TRAV",9999999-SK)=K2
+2 SET X7=""
FOR K0=0:0
SET K0=$ORDER(^TMP($JOB,"TRAV",K0))
if K0<1
QUIT
SET K2=$GET(^(K0))
Begin DoDot:1
+3 SET X5=$PIECE(K2,"^",2)
if 'X5
QUIT
+4 SET X6=$GET(^FHPT(FHDFN,"A",ADM,"DI",+X5,0))
if X6=""
QUIT
+5 if $PIECE(X6,"^",7)'=""
QUIT
+6 SET X7=$GET(^FHPT(FHDFN,"A",ADM,"DI",+X5,2))
+7 if X7=""
QUIT
+8 SET X8=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",+X5,0)),"^",9)
DO CUR
+9 SET X8=$SELECT($PIECE($GET(^FHPT(FHDFN,"A",ADM,"DI",+X5,3)),"^",2):$PIECE(^FHPT(FHDFN,"A",ADM,"DI",+X5,3),"^",2),1:X8)
+10 SET ^TMP($JOB,"D",NX_"~"_R0_"~"_RM_"~"_FHDFN)=FHDFN_"^"_ADM_"^"_O1_"^"_TIM
+11 SET ^TMP($JOB,"D",NX_"~"_R0_"~"_RM_"~"_FHDFN,1)=Y_"^"_X8
QUIT
+12 QUIT
End DoDot:1
if X7'=""
QUIT
+13 QUIT
CUR SET Y=""
if X6=""
QUIT
SET FHOR=$PIECE(X6,"^",2,6)
SET FHLD=$PIECE(X6,"^",7)
+1 IF FHLD'=""
SET FHDU=";"_$PIECE(^DD(115.02,6,0),"^",3)
SET %=$FIND(FHDU,";"_FHLD_":")
if %<1
QUIT
SET Y=$PIECE($EXTRACT(FHDU,%,999),";",1)
QUIT
+2 FOR A1=1:1:5
SET D3=$PIECE(FHOR,"^",A1)
IF D3
if Y'=""
SET Y=Y_", "
SET Y=Y_$PIECE(^FH(111,D3,0),"^",7)
+3 QUIT
HDR ; Print No Diet Pattern Heading
+1 DO PAUSE
if ANS="^"
QUIT
if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
+2 SET PG=PG+1
WRITE !,FHDTP,?33,"I N P A T I E N T S W I T H N O D I E T P A T T E R N S",?123,"Page ",PG
+3 WRITE !!,"Ward/Room",?34,"Patient",?66,"Current-Diet",!
+4 QUIT
HDR1 ; Print Previous Diet Pattern Heading
+1 SET PG=PG+1
DO PAUSE
if ANS="^"
QUIT
if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
+2 WRITE !,FHDTP,?27,"I N P A T I E N T S T H A T H A D I N D I V I D U A L P A T T E R N S",?123,"Page ",PG
+3 WRITE !!,"Patient",?32,"Effective",?52,"Diet"
+4 QUIT
PAUSE ; Check to pause for reading
+1 IF IOST?1"C".E
IF PG
READ !!,"Press RETURN to continue. ",X:DTIME
if '$TEST!(X["^")
SET ANS="^"
if ANS="^"
QUIT
IF "^"'[X
WRITE !,"Enter a RETURN to Continue."
GOTO PAUSE
+2 QUIT
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
