source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH2.m@ 789

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

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1PSBOMH2 ;BIRMINGHAM/EFC-MAH ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**6,20,27,26**;Mar 2004
3 ;
4 ; Reference/IA
5 ; EN^PSJBCMA/2828
6 ;
7EN ;
8 ; Okay, let's print this puppy
9 S PSBWEEK=0
10 F S PSBWEEK=$O(^TMP("PSB",$J,PSBWEEK)) Q:'PSBWEEK D
11 .D:$D(^TMP("PSB",$J,PSBWEEK,"SORT","C"))
12 ..D CONT
13 ;
14 ; Now the PRN/One Time/On-Call Sheets
15 S PSBWEEK=0
16 F S PSBWEEK=$O(^TMP("PSB",$J,PSBWEEK)) Q:'PSBWEEK D
17 .D:$D(^TMP("PSB",$J,PSBWEEK,"SORT","P"))
18 ..D PRN
19 ;
20 D LEGEND
21 Q
22CONT ;
23 S PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (VAF 10-2970 B, C, D)"
24 W $$HDR()
25 S PSBDRUG=""
26 F S PSBDRUG=$O(^TMP("PSB",$J,PSBWEEK,"SORT","C",PSBDRUG)) Q:PSBDRUG="" D
27 .S PSBORD=""
28 .F S PSBORD=$O(^TMP("PSB",$J,PSBWEEK,"SORT","C",PSBDRUG,PSBORD)) Q:'PSBORD D
29 ..;S X="",PSBNAF=0 F S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,X)) Q:X="" I ^TMP("PSB",$J,PSBWEEK,PSBORD,X,0)'=0 S PSBNAF=1 ; check for data
30 ..;D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
31 ..;S X=PSBOST D H^%DTC S PSBOSTH=%H
32 ..;S X=PSBOSP D H^%DTC S PSBOSPH=%H
33 ..;I PSBNAF=0 Q
34 ..;I PSBNAF=0,$G(PSBAR(PSBOSTH))'=PSBWEEK,$G(PSBAR(PSBOSPH))'=PSBWEEK Q ; no data for this week and neither start or stop date is this week
35 ..S PSBCNT=8
36 ..S:$O(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",""),-1)>PSBCNT PSBCNT=$O(^(""),-1)
37 ..S:$O(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",""),-1)>PSBCNT PSBCNT=$O(^(""),-1)
38 ..W:$Y>(IOSL-PSBCNT-4) $$HDR()
39 ..F PSBLINE=1:1:PSBCNT D
40 ...I IOSL>24,$Y>$S(PSBCNT<13:(IOSL-PSBCNT-4),(PSBCNT-PSBLINE=12):(IOSL-12),1:(IOSL-12)) D
41 ....W !?(IOM-35\2),"*** CONTINUED ON NEXT PAGE ***"
42 ....W $$HDR()
43 ....W !?(IOM-35\2),"*** CONTINUED FROM PREVIOUS PAGE ***"
44 ...W !,$G(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",PSBLINE))
45 ...W ?32,"| ",$G(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",PSBLINE))
46 ...S PSBDAY=0,PSBCOL=0
47 ...F S PSBDAY=$O(^TMP("PSB",$J,PSBWEEK,"HDR",PSBDAY)) Q:'PSBDAY D
48 ....W ?(40+(PSBCOL*13)),"| "
49 ....S Y=$G(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDAY,PSBLINE))
50 ....W $P(Y,U,3)
51 ....W $E($P($P(Y,U,1)_"0000",".",2),1,4)," "
52 ....W $P(Y,U,2)
53 ....I $D(^TMP("PSB",$J,"ORDERS",PSBORD,"HOLD",PSBDAY)),(PSBLINE=PSBCNT) W "HOLD" ;output hold status
54 ....I '$D(^TMP("PSB",$J,"ORDERS",PSBORD,"DISC",PSBDAY))&'$D(^TMP("PSB",$J,"ORDERS",PSBORD,"HOLD",PSBDAY)) D
55 .....I $D(^TMP("PSB",$J,"ORDERS",PSBORD,"NTDUE",PSBDAY)),(PSBLINE=PSBCNT) W "***" ;write *** when day no due
56 ....I $D(^TMP("PSB",$J,"ORDERS",PSBORD,"DISC",PSBDAY)),(PSBLINE=PSBCNT) W "***" ;output discontinued status
57 ....S PSBCOL=PSBCOL+1
58 ..W !,$TR($J("",IOM)," ","-")
59 Q
60 ;
61PRN ;
62 S PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (VAF 10-2970 B, C, D)"
63 W $$HDR(1)
64 S PSBDRUG=""
65 F S PSBDRUG=$O(^TMP("PSB",$J,PSBWEEK,"SORT","P",PSBDRUG)) Q:PSBDRUG="" D
66 .S PSBORD=""
67 .F S PSBORD=$O(^TMP("PSB",$J,PSBWEEK,"SORT","P",PSBDRUG,PSBORD)) Q:'PSBORD D
68 ..S PSBCNT=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)
69 ..D:PSBCNT<$O(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",""),-1)
70 ...S PSBCNT=$O(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",""),-1)
71 ..S:PSBCNT<8 PSBCNT=8 ; Minimum space for order
72 ..W:$Y>(IOSL-PSBCNT-4) $$HDR(1)
73 ..F PSBLINE=1:1:PSBCNT D
74 ...I IOSL>24,$Y>$S(PSBCNT<13:(IOSL-PSBCNT-4),(PSBCNT-PSBLINE=12):(IOSL-12),1:(IOSL-12)) D
75 ....W !?(IOM-35\2),"*** CONTINUED ON NEXT PAGE ***"
76 ....W $$HDR(1)
77 ....W !?(IOM-35\2),"*** CONTINUED FROM PREVIOUS PAGE ***"
78 ...W !,$G(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",PSBLINE))
79 ...W ?32,"| ",$G(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",PSBLINE))
80 ..W !,$TR($J("",IOM)," ","-")
81 Q
82 ;
83LEGEND ;
84 ;print the initials - name legend as an extra page ;
85 ;I '$D(^TMP("PSB",$J,"LEGEND")) K ^TMP("PSJ",$J),^TMP("PSB",$J) Q ;
86 D PT^PSBOHDR(DFN,.PSBHDR) ;
87 W !!,"Initial - Name Legend",! ;
88 I $D(^TMP("PSB",$J,"LEGEND")) D
89 .S X=$Q(^TMP("PSB",$J,"LEGEND",""))
90 .F W $S($QS(X,4)[99:"",1:$QS(X,4)),?10,$QS(X,5),! S X=$Q(@X) Q:$QS(X,3)'="LEGEND" ;
91 W !!,"Status Codes",!,"C - Completed",!,"G - Given",!,"H - Held",!,"I - Infusing",!,"M - Missing Dose Requested",!,"R - Refused",!,"RM - Removed",!,"S - Stopped",!,"*** - Medication Not Due",! ;
92 K ^TMP("PSJ",$J),^TMP("PSB",$J)
93 Q
94 ;
95HDR(PRN) ;
96 ; PRN = TRUE IF DISPLAYING PRN MED (OPTIONAL)
97 D PT^PSBOHDR(DFN,.PSBHDR)
98 W !,"Start Date",?20,"Stop Date",?32,"| ",$S('$G(PRN):"Admin",1:"Action Status")
99 I '$G(PRN) F X=0:1:6 W ?(40+(X*13)),"|"
100 W !,"and Time",?20,"and Time",?32,"| ",$S('$G(PRN):"Times",1:"Action Date/Times")
101 D:'$G(PRN)
102 .S PSBCOL=0,X=0 F S X=$O(^TMP("PSB",$J,PSBWEEK,"HDR",X)) Q:'X D
103 ..W ?(40+(PSBCOL*13)),"| ",$E(X,4,5),"/",$E(X,6,7),"/",(1700+$E(X,1,3))
104 ..S PSBCOL=PSBCOL+1
105 D:$G(PRN)
106 .W ?76,"PRN Reason"
107 W !,$TR($J("",IOM)," ","-")
108 Q ""
109 ;
110PSBCK1(PSBCHK) ;
111 I PSBCHK="A" D
112 .S TEST=$P(^PSB(53.79,PSBIEN,0),U,6)
113 .D PSBOUT^PSBOMH1(TEST,PSBINIT)
114 .S X=$P(^PSB(53.79,PSBIEN,0),U,6)_U_PSBINIT_U_"G"_U_PSBIEN
115 I PSBCHK="B" D
116 .S TESTB=$P(^PSB(53.79,PSBIEN,0),U,6)
117 .D PSBOUT^PSBOMH1(TESTB,PSBINIT)
118 .S X=$P(^PSB(53.79,PSBIEN,0),U,6)_U_PSBINIT_U_$P(^(0),U,9)_U_PSBIEN
119 S PSBCHK=""
120 Q
121 ;
122PSBENT(PSBTIS) ;
123 S PSBNAME="",PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
124 S ^TMP("PSB",$J,"LEGEND",$S($G(PSBTIS)="":99,1:PSBTIS),PSBNAME)=""
125 Q
126 ;
127PSBSTIV ;
128 S YB="" F S YB=$O(PSBAUD(YB)) Q:YB="" D
129 .S Z="" F S Z=$O(^PSB(53.79,PSBIEN,.9,Z)) Q:Z="" I Z'=0 D
130 ..I $P(PSBAUD(YB),U,1)=$P(^PSB(53.79,PSBIEN,.9,Z,0),"^",1) D
131 ...I $P(^PSB(53.79,PSBIEN,.9,Z,0),"^",3)["Instruct" D
132 ....I $P(PSBAUD(YB),U,2)'["*" S $P(PSBAUD(YB),U,2)=$P(PSBAUD(YB),U,2)_"*"
133 ....D PSBOUT^PSBOMH1($P(PSBAUD(YB),U,1),$P(PSBAUD(YB),U,2))
134 Q
135 ;
136PSBCTAR ;
137 S YC="" F S YC=$O(PSBTAR(YC)) Q:YC="" D
138 .S Z="" F S Z=$O(^PSB(53.79,PSBIEN,.9,Z)) Q:Z="" I Z'=0 D
139 ..I $P(PSBTAR(YC),U,1)=$P(^PSB(53.79,PSBIEN,.9,Z,0),"^",1) D
140 ...I $P(^PSB(53.79,PSBIEN,.9,Z,0),"^",3)["Instruct" D
141 ....S $P(PSBTAR(YC),U,2)=$P(PSBTAR(YC),U,2)_"*"
142 ....D PSBOUT^PSBOMH1($P(^PSB(53.79,PSBIEN,.9,Z,0),"^",1),$P(PSBTAR(YC),U,2))
143 Q
144 ;
Note: See TracBrowser for help on using the repository browser.