source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m@ 1489

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

revised back to 6/30/08 version
File size: 10.1 KB
Line 
1PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM 30 Jan 2008
2 ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;Modified from FOIA VISTA,
6 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
7 ;General Public License See attached copy of the License.
8 ;
9 ;This program is free software; you can redistribute it and/or modify
10 ;it under the terms of the GNU General Public License as published by
11 ;the Free Software Foundation; either version 2 of the License, or
12 ;(at your option) any later version.
13 ;
14 ;This program is distributed in the hope that it will be useful,
15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;GNU General Public License for more details.
18 ;
19 ;You should have received a copy of the GNU General Public License along
20 ;with this program; if not, write to the Free Software Foundation, Inc.,
21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
22 ;
23 ; Reference/IA
24 ; ^DILF/2054
25 ; File 200/10060
26 ;
27EN ;
28 ; Load administrations
29 S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
30 K PSBTSA
31 F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D
32 .F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D L -^PSB(53.79,PSBIEN)
33 ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6) ; Bad IEN -no evnt dt
34 ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N" ;NGiven
35 ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
36 ..; Continuous
37 ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
38 ...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1))
39 ...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH) D D CLEAN^PSBVT Q ;chck IV audit
40 ....S PSBSIEN=PSBIEN
41 ....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1))
42 ....S PSBIEN=PSBSIEN K PSBSIEN
43 ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
44 ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" Q:$P(PSBAUD(X),U,1)=PSBDT
45 ....I X="" K PSBAUD Q
46 ....I '$D(PSBAUD(X)) K PSBAUD Q
47 ....S PSBS=$P(PSBAUD(X),U,3)
48 ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
49 ....I PSBS="NOT GIVEN" Q
50 ....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
51 ....D PSBSTIV^PSBOMH2
52 ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
53 ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
54 ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
55 ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
56 ....D PSBOUT($P((X),"^",1),$P((X),"^",2))
57 ....K PSBAUD
58 ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
59 ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
60 ...I PSBINIT="" S PSBINIT=99
61 ...;get instrc info - audt log
62 ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
63 ....D INSTR^PSBOMH
64 ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
65 ...I PSBINIT[99 S PSBINIT=""
66 ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("A")
67 ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("B")
68 ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
69 ....D DDAUD
70 ....S I="" F S I=$O(PSBTAR(I),-1) Q:I="" I $P(PSBTAR(I),U,1)=PSBDT D
71 .....S PSBS=$P(PSBTAR(I),U,3)
72 .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q ; canceled - not given
73 .....I PSBS="NOT GIVEN" Q
74 .....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
75 .....D PSBCTAR^PSBOMH2
76 .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
77 ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
78 ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
79 ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
80 ...D PSBOUT($P((X),"^",1),$P((X),"^",2))
81 ...Q
82 ..; 1-Time On Call or PRN
83 ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
84 ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
85 ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
86 ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
87 ...I PSBINIT="" S PSBINIT=99
88 ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
89 ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED" D
90 ....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA="" I PSBXA?1.3N S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
91 ....F S=1:1 Q:PSBM<1 S PSBM=PSBZ-S I (PSBM>0) I (PSBT(PSBM)["GIVEN") S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q
92 ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
93 ....D INSTR^PSBOMH
94 ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
95 ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D PSBOUT(PSBDT,PSBINIT)
96 ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
97 ...I PSBINIT[99 S PSBINIT=""
98 ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
99 ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2=" Results: <No PRN Results On File>"
100 ....E D
101 .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
102 .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
103 .....I PSBINIT="" S PSBINIT=99
104 .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
105 ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
106 ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
107 .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
108 ......D:$D(^PSB(53.79,PSBIEN,.9,0))
109 .......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0 D Q:PSBFG=1
110 ........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2))
111 .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
112 .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
113 .....S PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
114 .....S PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
115 .....I PSBINIT[99 S PSBINIT=""
116 ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
117 ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
118 ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
119 ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
120 ...I $G(PSBLINE2)]"" D
121 ....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW
122 ....I $L(PSBLINE2)>90 D
123 .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
124 .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_$E(PSBLINE2,91,161)
125 .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW
126 .....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW
127 Q
128 ;
129DDAUD ; audits for dispen drugs
130 ;
131 M PSBMLA=^PSB(53.79,PSBIEN)
132 S PSBGA="" I $D(PSBMLA(.9,0)) D
133 .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
134 ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
135 ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
136 ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
137 ..S PSBGA=1
138 .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
139 ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
140 ..S PSBGA=1
141 I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
142 S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
143 .;
144 .;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
145 .;
146 .;S PSBPQRY=$Q(@PSBQRY,-1)
147 .S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1)
148 .;
149 .;END CHANGE
150 .;
151 .I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no prev action
152 .I $QS(PSBPQRY,2)="C" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; prev line = comment
153 .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) D Q
154 ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
155 .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
156 Q
157 ;
158PSBOUT(PSBTET,PSBOT1) ;
159 I '$D(^PSB(53.79,PSBIEN,.9,0)) D PSBENT^PSBOMH2(PSBOT1)
160 S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
161 S PSBXA1=0
162 F S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0 I PSBXA1'=0 D Q:$G(PSBOT1)["*"
163 .I $L(PSBXA1)<4 D
164 ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET D
165 ...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
166 ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct" D
167 ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
168 ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
169 I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
170 .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
171 I $G(PSBNAME)="" D
172 . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
173 S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
174 Q
175 ;
Note: See TracBrowser for help on using the repository browser.