- FHMTK5 ; HISC/NCA - List Patients Without Diet Patterns/Ind Pattern ;3/09/04 12:35
- ;;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^FHMTK5",FHLST="" D EN2^FH G KIL
- U IO D L1 D ^%ZISC K %ZIS,IOP G KIL
- L1 ; Process Listing Patients Without Diet Patterns & Patients
- ; 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="^"
- .D PATNAME^FHOMUTL I DFN="" Q
- .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,"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[HFHMTK5 3999 printed Feb 18, 2025@23:14:36 Page 2
- FHMTK5 ; HISC/NCA - List Patients Without Diet Patterns/Ind Pattern ;3/09/04 12:35
- +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^FHMTK5"
- SET FHLST=""
- DO EN2^FH
- GOTO KIL
- +3 USE IO
- DO L1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- L1 ; Process Listing Patients Without Diet Patterns & Patients
- +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 DO PATNAME^FHOMUTL
- IF DFN=""
- QUIT
- +28 SET RM=$PIECE(X9,"~",3)
- SET WRDN=$EXTRACT($PIECE(X9,"~",1),3,99)
- +29 if $Y'<(IOSL-8)
- DO HDR1
- if ANS="^"
- QUIT
- +30 WRITE !!,$EXTRACT(WRDN,1,15)_"/"_$EXTRACT(RM,1,15),!,$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^",1),1,30)
- +31 SET DTP=$PIECE(XX,"^",4)
- if DTP'=""
- DO DTP^FH
- if DTP'=""
- WRITE ?32,DTP
- WRITE ?52,"Current: ",Y,!
- +32 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
- +33 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,"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