source: FOIAVistA/trunk/r/DIETETICS-FH/FHMTKO.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1FHMTKO ; HISC/NCA/FAI - List Outpats Without Diet Patterns/Ind Pattern ;02/24/04 11:00
2 ;;5.5;DIETETICS;;Jan 28, 2005
3LIS W !!,"The list requires a 132 column printer.",!
4 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
5 I $D(IO("Q")) S FHPGM="L1^FHMTKO",FHLST="" D EN2^FH G KIL
6 U IO D L1 D ^%ZISC K %ZIS,IOP G KIL
7L1 ; Process Listing Outpatients Without Diet Patterns & Inpatients
8 ; With Individual Pattern
9 D NOW^%DTC S DTP=% D DTP^FH S FHDTP=DTP
10 K ^TMP($J,"D"),^TMP($J,"NP"),^TMP($J,"W") S ANS=""
11 F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 D
12 .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)
13 .S ^TMP($J,"W",P0_WRDN)=W1 Q
14 S NX="" F S NX=$O(^TMP($J,"W",NX)) Q:NX="" S X1=$G(^(NX)),W1=+X1 D
15 .F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 D
16 ..D PATNAME^FHOMUTL I DFN="" Q
17 ..S ADM=$G(^FHPT("AW",W1,FHDFN)),RI=$G(^DPT(DFN,.108)),RM=$G(^DPT(DFN,.101)) S:RM="" RM="***"
18 ..S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"")
19 ..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
20 ..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
21 ..D CUR^FHORD7 Q:"^^^^"[FHOR S:Y'="" O1=Y
22 ..Q:$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2))'=""
23 ..S DPAT=$O(^FH(111.1,"AB",FHOR,0))
24 ..I 'DPAT S ^TMP($J,"NP",NX_"~"_R0_"~"_RM_"~"_FHDFN)=FHDFN_"^"_ADM_"^"_O1 Q
25 ..S TIM=$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),"^",9) D GET
26 ..Q
27 .Q
28 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="^"
29 .D PATNAME^FHOMUTL I DFN="" Q
30 .S RM=$P(X9,"~",3),WRDN=$E($P(X9,"~",1),3,99)
31 .D:$Y'<(IOSL-8) HDR Q:ANS="^"
32 .W !,$E(WRDN,1,15)_"/"_$E(RM,1,15),?34,$E($P($G(^DPT(DFN,0)),"^",1),1,30),?66,Y Q
33 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="^"
34 .S RM=$P(X9,"~",3),WRDN=$E($P(X9,"~",1),3,99)
35 .D:$Y'<(IOSL-8) HDR1 Q:ANS="^"
36 .W !!,$E(WRDN,1,15)_"/"_$E(RM,1,15),!,$E($P($G(^DPT(DFN,0)),"^",1),1,30)
37 .S DTP=$P(XX,"^",4) D:DTP'="" DTP^FH W:DTP'="" ?32,DTP W ?52,"Current: ",Y,!
38 .S DTP=$P(ZZ,"^",2) D:DTP'="" DTP^FH W:DTP'="" ?32,DTP W ?52,"Prev. Pattern: ",$P(ZZ,"^",1),! Q
39 Q
40GET ; Get Previous Diet Order
41 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
42 S X7="" F K0=0:0 S K0=$O(^TMP($J,"TRAV",K0)) Q:K0<1 S K2=$G(^(K0)) D Q:X7'=""
43 .S X5=$P(K2,"^",2) Q:'X5
44 .S X6=$G(^FHPT(FHDFN,"A",ADM,"DI",+X5,0)) Q:X6=""
45 .Q:$P(X6,"^",7)'=""
46 .S X7=$G(^FHPT(FHDFN,"A",ADM,"DI",+X5,2))
47 .Q:X7=""
48 .S X8=$P($G(^FHPT(FHDFN,"A",ADM,"DI",+X5,0)),"^",9) D CUR
49 .S X8=$S($P($G(^FHPT(FHDFN,"A",ADM,"DI",+X5,3)),"^",2):$P(^FHPT(FHDFN,"A",ADM,"DI",+X5,3),"^",2),1:X8)
50 .S ^TMP($J,"D",NX_"~"_R0_"~"_RM_"~"_FHDFN)=FHDFN_"^"_ADM_"^"_O1_"^"_TIM
51 .S ^TMP($J,"D",NX_"~"_R0_"~"_RM_"~"_FHDFN,1)=Y_"^"_X8 Q
52 .Q
53 Q
54CUR S Y="" Q:X6="" S FHOR=$P(X6,"^",2,6),FHLD=$P(X6,"^",7)
55 I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") Q:%<1 S Y=$P($E(FHDU,%,999),";",1) Q
56 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)
57 Q
58HDR ; Print No Diet Pattern Heading
59 D PAUSE Q:ANS="^" W:'($E(IOST,1,2)'="C-"&'PG) @IOF
60 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
61 W !!,"Ward/Room",?34,"Patient",?66,"Current-Diet",!
62 Q
63HDR1 ; Print Previous Diet Pattern Heading
64 S PG=PG+1 D PAUSE Q:ANS="^" W:'($E(IOST,1,2)'="C-"&'PG) @IOF
65 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
66 W !!,"Patient",?32,"Effective",?52,"Diet"
67 Q
68PAUSE ; Check to pause for reading
69 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
70 Q
71KIL K ^TMP($J) G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.