source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBCSUTL.m@ 1726

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

initial load of FOIAVistA 6/30/08 version
File size: 9.6 KB
Line 
1PSBCSUTL ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**16,13,38,32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; EN^PSJBCMA/2828
7 ; IN5^VADPT/10061
8 ; $$GET^XPAR/2263
9 ; ^%DTC/10000
10 ; $$FMADD^XLFDT/10103
11 ; $$GET1^DIQ/2056
12RPC(RESULTS,DFN,EXPWIN) ;
13 K RESULTS,^TMP("PSB",$J),^TMP("PSJ",$J)
14 S PSBXWIN=$G(EXPWIN,24)
15 S PSBTAB="CVRSHT"
16 N PSBCNT S PSBTRFL=0,PSBDFNX=DFN
17 S RESULTS=$NAME(^TMP("PSB",$J,PSBTAB))
18 K ^TMP("PSB",$J,PSBTAB) S ^TMP("PSB",$J,PSBTAB,0)=1 D LIGHTS(PSBDFNX)
19 S ^TMP("PSB",$J,PSBTAB,0)=1,^TMP("PSB",$J,PSBTAB,1)=^TMP("PSB",$J,PSBTAB,1)
20 Q:$P(^TMP("PSB",$J,PSBTAB,1),U,4)=-1
21 D NOW^%DTC S PSBNOW=+$E(%,1,10),PSBDT=$P(%,".",1)
22 ;set range
23 S PSBWBEG=$$FMADD^XLFDT(PSBNOW,"",-PSBXWIN),PSBWEND=$$FMADD^XLFDT(PSBNOW,"",PSBXWIN)
24 S PSBTBEG=$$FMADD^XLFDT(PSBNOW,"",-12),PSBTEND=$$FMADD^XLFDT(PSBNOW,"",12)
25 S PSBWADM=$$GET^XPAR("DIV","PSB ADMIN BEFORE"),PSBMHBCK=$$GET^XPAR("ALL","PSB MED HIST DAYS BACK",,"B") I +PSBMHBCK=0 S PSBMHBCK=30
26 D NOW^%DTC S PSBWADM=$$FMADD^XLFDT(%,"","",+PSBWADM),PSBMHBCK=$$FMADD^XLFDT(%,-1*(PSBMHBCK))
27 ;use lst movemnt for API
28 S VAIP("D")="LAST" D IN5^VADPT S PSBTRDT=+VAIP(3),PSBTRTYP=$P(VAIP(2),U,2),PSBMVTYP=$P(VAIP(4),U,2) K VAIP
29 S PSBPTTR=$$GET^XPAR("DIV","PSB PATIENT TRANSFER") I PSBPTTR="" S PSBPTTR=72
30 D NOW^%DTC S PSBNTDT=$$FMADD^XLFDT(%,"",-PSBPTTR) I PSBNTDT'>PSBTRDT S PSBTRFL=1
31 S X1=$P(PSBNOW,"."),X2=-3 D C^%DTC
32 D EN^PSJBCMA(PSBDFNX,X,$S(PSBMHBCK<PSBWBEG:PSBMHBCK,PSBWBEG<PSBMHBCK:PSBWBEG,1:PSBMHBCK))
33 ;Devlop Outp
34 S PSBTBOUT=0
35 I ^TMP("PSJ",$J,1,0)>0 F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:('PSBX)!(PSBTBOUT) D
36 .S:(PSBTAB'="CVRSHT")&($G(^TMP("PSB",$J,"CVRSHT",2))>0) PSBTBOUT=1
37 .D CLEAN^PSBVT,PSJ^PSBVT(PSBX),NOW^%DTC
38 .Q:PSBONX["P" Q:(PSBOSP<PSBWBEG)&'(PSBONX["V") ;in rnge?
39 .S (PSBREC,PSBONTAB)=""
40 .S $P(PSBREC,U,1)=PSBDFN ;Dfn
41 .S $P(PSBREC,U,2)=PSBONX ;OrdX
42 .S $P(PSBREC,U,3)=PSBON ;Ord#
43 .S $P(PSBREC,U,4)=PSBOTYP ;v/u/p
44 .S $P(PSBREC,U,5)=PSBSCHT ;Schtyp
45 .S $P(PSBREC,U,6)=PSBSCH ;Sch
46 .S $P(PSBREC,U,7)=$S(PSBHSM:"HSM",PSBSM:"SM",1:"") ; slfmed
47 .S $P(PSBREC,U,8)=PSBOITX ;Drgnm
48 .S $P(PSBREC,U,9)=PSBDOSE_" "_PSBIFR ;Dose
49 .S $P(PSBREC,U,10)=PSBMR ;med route
50 .;Lst Gvn -AOIP xRef
51 .S (PSBCNT,PSBFLAG)=0,(Y,PSBSTUS)="" K PSBHSTA,PSBHSTAX
52 .F XZ=1:1:20 S Y=$O(^PSB(53.79,"AOIP",PSBDFN,PSBOIT,Y),-1),(PSBCNT,PSBFLAG)=0 Q:Y="" D
53 ..S:Y>0 $P(PSBREC,U,11)=Y
54 ..S X="" F S X=$O(^PSB(53.79,"AOIP",PSBDFN,PSBOIT,Y,X),-1) Q:X="" D
55 ...S PSBSTUS=$P(^PSB(53.79,X,0),U,9) S:$G(PSBSTUS)="" PSBSTUS="X" I (PSBSTUS'="N") S PSBFLAG=1,PSBHSTA(Y,$G(PSBSTUS))="ORIG"_U_X
56 ...D:PSBSTUS="N"
57 ....S ($P(PSBREC,U,11),Z)=""
58 ....F S Z=$O(^PSB(53.79,X,.9,Z),-1) Q:'Z Q:PSBFLAG=1 S PSBDATA=$G(^(Z,0)) D
59 .....I (PSBDATA["Set to 'NOT GIVEN'")!(PSBDATA["Set to 'GIVEN'")!(PSBDATA["Set to 'REFUSED'")!(PSBDATA["Set to 'HELD'")!(PSBDATA["Set to 'MISSING DOSE'")!(PSBDATA["Set to 'REMOVED'") S PSBCNT=PSBCNT+1
60 .....I (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'") S PSBCNT=PSBCNT+1
61 .....I PSBCNT#2=0,PSBDATA["'REFUSED'" S PSBSTUS="R" D LAST^PSBVDLU1
62 .....I PSBCNT#2=0,PSBDATA["'HELD'" S PSBSTUS="H" D LAST^PSBVDLU1
63 .....I PSBCNT#2=0,PSBDATA["'MISSING DOSE'" S PSBSTUS="M" D LAST^PSBVDLU1
64 .....I PSBCNT#2=0,PSBDATA["'REMOVED'" S PSBSTUS="RM" D LAST^PSBVDLU1
65 .....I PSBFLAG=1,'$D(PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))) S PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))=Z_U_X
66 .I $D(PSBHSTA) S $P(PSBREC,U,11)=$O(PSBHSTA(""),-1),PSBSTUS=$O(PSBHSTA($P(PSBREC,U,11),""),-1) M PSBHSTAX(PSBOIT)=PSBHSTA K PSBHSTA ;last action date/time
67 .S $P(PSBREC,U,12)="" ;ien - below
68 .S $P(PSBREC,U,13)="" ;sttus - below
69 .S $P(PSBREC,U,14)="" ;admn dte - below
70 .S $P(PSBREC,U,15)=PSBOIT ;OI Pointer
71 .S $P(PSBREC,U,16)=PSBNJECT ;njctble med route flag
72 .;Var dosg
73 .I $P(PSBREC,U,9)?1.4N1"-"1.4N.E S $P(PSBREC,U,17)=1
74 .E S $P(PSBREC,U,17)=0
75 .S:PSBDOSEF?1"CAP".E!(PSBDOSEF?1"TAB".E)!(PSBDOSEF="PATCH") $P(PSBREC,U,18)=PSBDOSEF ;DosgFrm
76 .D PSJ1^PSBVT(PSBDFN,PSBONX)
77 .S PSBPB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$G(PSBIVPSH)),PSBLVIV=0
78 .Q:PSBPB&(PSBOSP<PSBWBEG)
79 .S:(PSBONX["V"&'PSBPB) PSBLVIV=1
80 .S $P(PSBREC,U,19)=$S(PSBVNI]"":PSBVNI,PSBVNI']"":"***") ;VerfNrsInts
81 .S $P(PSBREC,U,20)=PSBSTUS S:$P(PSBREC,U,11)="" $P(PSBREC,U,20)="" ;LstActn
82 .S $P(PSBREC,U,21)=PSBOST
83 .S $P(PSBREC,U,22)=PSBOSTS
84 .S $P(PSBREC,U,25)=0 I $G(PSBTRFL),$P(PSBREC,U,11)]"",$P(PSBREC,U,11)'<$G(PSBNTDT),$P(PSBREC,U,11)'>$G(PSBTRDT) S $P(PSBREC,U,25)=1
85 .S $P(PSBREC,U,26)=PSBOSP ;OrdStpDt/Tm
86 .S $P(PSBREC,U,27)=$$LASTG($P(PSBREC,U,1),$P(PSBREC,U,15))
87 .S $P(PSBREC,U,28)=$S((PSBONX["U")&('PSBPB):1,PSBPB:2,(PSBONX["V")&'PSBPB:3,1:"")
88 .;get all Admn(s) - DD info.
89 .S (PSBDDS,PSBSOLS,PSBADDS,PSBFLAG)="0"
90 .I PSBLVIV D XFERBAGS^PSBCSUTY,LVIV^PSBCSUTY I $G(PSBEXPRD) S X1=$O(^TMP("PSB",$J,PSBTAB,""),-1) S:^TMP("PSB",$J,PSBTAB,X1)'="END" ^TMP("PSB",$J,PSBTAB,X1+1)="END" Q
91 .D GETADMX^PSBCSUTY
92 .F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y D
93 ..I $P(PSBDDA(Y),U,5)=$P(%,".") S PSBFLAG=1 ;drug nactvt
94 ..Q:$P(PSBDDA(Y),U,5)&($P(PSBDDA(Y),U,5)<%) ;nactv
95 ..S:$P(PSBDDA(Y),U,4)="" $P(PSBDDA(Y),U,4)=1
96 ..S PSBDDS=PSBDDS_U_$P(PSBDDA(Y),U,1,4),$P(PSBDDS,U,1)=PSBDDS+1
97 .;OnCa O PRN
98 .I ("^O^OC^P^"[(U_PSBSCHT_U))!(PSBLVIV) D S ($P(PSBREC,U,12),$P(PSBREC,U,14))="" Q
99 ..S (PSBIENX,PSBGOT1)="",PSBADMTM="" F S PSBADMTM=$O(^PSB(53.79,"AORDX",PSBDFNX,PSBONX,PSBADMTM)) Q:(PSBADMTM="") D
100 ...Q:(PSBADMTM<PSBMHBCK)&'PSBLVIV
101 ...F S PSBIENX=$O(^PSB(53.79,"AORDX",PSBDFNX,PSBONX,PSBADMTM,PSBIENX)) Q:PSBIENX="" D
102 ....S $P(PSBREC,U,12)=PSBIENX,$P(PSBREC,U,14)=PSBADMTM,$P(PSBREC,U,23)=$$GET1^DIQ(53.79,PSBIENX_",","IV UNIQUE ID")
103 ....S PSBQRR=1 D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBADMTM,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1
104 ..I ('+PSBGOT1)&(PSBOSP'<PSBWBEG) D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1
105 ..I ('+PSBGOT1)&($D(PSBADMX(PSBONX))) D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
106 ..S PSBGLBX=$O(^TMP("PSB",$J,PSBTAB,""),-1) S:^TMP("PSB",$J,PSBTAB,PSBGLBX)'="END" ^TMP("PSB",$J,PSBTAB,PSBGLBX+1)="END"
107 .;cont - proces AdmnTm
108 .S (PSBYES,PSBODD,PSBYTF)=0 S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1
109 .I PSBYES,PSBADST="" Q
110 .F I=1:1 Q:$P(PSBSCH,"-",I)="" I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBYTF=1
111 .I PSBSCHT="C",PSBYTF="1",PSBADST="" Q
112 .S PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
113 .I PSBFREQ="O" S PSBFREQ=1440
114 .I PSBFREQ="D" S PSBFREQ=""
115 .S:PSBLVIV PSBYES=1
116 .I 'PSBYES,PSBFREQ<1 Q
117 .I (PSBADST="")&(+PSBFREQ>0) D ODDSCH^PSBVDLU1(PSBTAB) Q
118 .I +PSBFREQ>0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
119 .I PSBODD,PSBADST'="" Q
120 .S PSBDTX=PSBWBEG\1,PSBGOT1=0
121 .F PSBXX=1:1:2 D S PSBDTX=$$FMADD^XLFDT(PSBDTX,"",24) ;incrmnt 1 day!
122 ..F PSBY=1:1:$L(PSBADST,"-") Q:$P(PSBADST,"-",PSBY)="" D
123 ...S PSB=+(PSBDTX_"."_$P(PSBADST,"-",PSBY))
124 ...I (PSB'<PSBWBEG)&(PSB'>PSBWEND) D ;wndow?
125 ....D:(PSB'<PSBOST)&(PSB<PSBOSP) ;actv?
126 .....D:$$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS) ;dt?
127 ......D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1
128 ...S PSB=+(PSBWEND\1_"."_$P(PSBADST,"-",PSBY))
129 ...I (PSB'<PSBWBEG)&(PSB'>PSBWEND) D ;wndow?
130 ....D:(PSB'<PSBOST)&(PSB<PSBOSP) ;actv?
131 .....D:$$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS) ;dt?
132 ......D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1
133 .I ('PSBGOT1)&(PSBOSP'<PSBWBEG) D ADD^PSBVDLU1(PSBREC,PSBOTXT,+(PSBWEND\1_"."_$P(PSBADST,"-")),PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
134 .K PSBSTUS
135 D EN^PSBVDLPA
136 I $G(^TMP("PSB",$J,PSBTAB,2))]"" S PSBI1=$O(^TMP("PSB",$J,PSBTAB,""),-1) I ^TMP("PSB",$J,PSBTAB,PSBI1)'="END" S ^TMP("PSB",$J,PSBTAB,PSBI1+1)="END"
137 S ^TMP("PSB",$J,PSBTAB,0)=$O(^TMP("PSB",$J,PSBTAB,""),-1)
138 I $G(^TMP("PSB",$J,PSBTAB,2))']"" S $P(^TMP("PSB",$J,PSBTAB,1),U,4)="-1^No orders To display on Coversheet"
139 I $G(^TMP("PSB",$J,PSBTAB,2))]"" S $P(^TMP("PSB",$J,PSBTAB,1),U,4)="1^COVERSHEET DATA FOLLOWS" D ADD^PSBCSUTX
140 D CLEAN
141 Q
142LASTG(PSBPATPT,PSBOIPT) ;LstGvn-(inpt: DFN,OrItm IEN)
143 K PSBHSTG S Y="",LASTG="" F XZ=1:1:20 S Y=$O(^PSB(53.79,"AOIP",PSBPATPT,PSBOIPT,Y),-1),(PSBCNT,PSBFLAG)=0 Q:Y="" D
144 .S:Y>0 LASTG="",X="" F S X=$O(^PSB(53.79,"AOIP",PSBPATPT,PSBOIPT,Y,X),-1) Q:X="" D
145 ..S PSBSTX=$P(^PSB(53.79,X,0),U,9) S:PSBSTX']"" PSBHSTG(Y)=-1 I PSBSTX="G" S PSBHSTG(Y)="G"
146 ..Q:PSBSTX="N"
147 ..D:(PSBSTX'="G")
148 ...S Z="" F S Z=$O(^PSB(53.79,X,.9,Z),-1) Q:'Z Q:PSBFLAG=1 S PSBDATA=$G(^(Z,0)) D
149 ....I (PSBDATA["Set to 'GIVEN'") S PSBCNT=PSBCNT+1
150 ....I (PSBDATA["STATUS 'GIVEN'") S PSBCNT=PSBCNT+1
151 ....I PSBCNT#2=0,PSBDATA'["'GIVEN'" Q
152 ....I '$D(PSBHSTG($P(PSBDATA,U))) S PSBFLAG=1,PSBHSTG($P(PSBDATA,U))=""
153 I $D(PSBHSTG) S LASTG="" F S LASTG=$O(PSBHSTG(LASTG),-1) Q:+LASTG=0 Q:PSBHSTG(LASTG)="G" I PSBHSTG(LASTG)=-1 S LASTG="" Q
154 Q LASTG
155LIGHTS(PSBDFN) ;
156 D RPC^PSBVDLTB(,PSBDFN,"NO TAB",) S PSBTAB="CVRSHT"
157 M ^TMP("PSB",$J,PSBTAB,1)=^TMP("PSB",$J,"NO TAB",1) K ^TMP("PSB",$J,"NO TAB")
158 Q
159CLEAN ;
160 D CLEAN^PSBVT
161 K PSBACT,PSBACTBY,PSBACTDT,PSBACTPT,PSBADDS,PSBBAGID,PSBCHDT,PSBCHKV,PSBCNT1,PSBCNT2,PSBDDS,PSBDFNX,PSBWEND
162 K PSBDT,PSBFLAG,PSBHSTAX,PSBI1,PSBIEN,PSBIENX,PSBLSTS,PSBMAUD,PSBMVTYP,PSBMWC,PSBNOW,PSBNTDT,PSBONMBR,PSBY,PSBXX
163 K PSBONXS,PSBORREC,PSBPDT,PSBPRNRE,PSBPTTR,PSBQR,PSBRDOW,PSBREC,PSBRECHD,PSBSCHBR,PSBSCHTM,PSBSOLS,PSBTAB,PSBADMTM,PSBDTX
164 K PSBTBOUT,PSBTRDT,PSBTRFL,PSBTRTYP,PSBUID,PSBUIDS,PSBX,PSBXIEN,PSBX2,PSBYEA,PSBYEA1,PSBYTF,PSBYES,VAIP,PSBWADM,PSBWBEG
165 K PSBXREC,PSBGOT1,PSBCDT,PSBQUIT,PSBUSED,PSBLST4X,PSBADMX,PSBI2,PSBXXX,PSBI,PSBPB,PSBSHWTB,PSBONTAB,PSBDONE,^TMP("PSJ",$J)
166 K PSBNXTDU,LASTG,LSTTIME,PSBMHBCK,PSBHSTG,PSBNXTDT,NEXTADM,PSBLVIV
167 Q
Note: See TracBrowser for help on using the repository browser.