source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBCHKIV.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1PSBCHKIV ;BIRMINGHAM/TEJ-BCMA CHECK IV ROUTINE ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**16**;Mar 2004
3 ;
4 ;This routine will provide "change" details for infus or stopped IV bags.
5 ;
6 ; Reference/IA
7 ; EN^PSJBCMA1/2829
8 ; EN^PSJBCMA2/2830
9 ;
10RPC(RESULTS,DFN,ORDIV) ;
11 I '$D(ORDIV) S RESULTS(0)=0 Q
12 N PSBGNODE,PSBPIN,PSBXX,PSBX,PSBBUIDS,PSBBUID K PSBBAGD,PSBADDS,PSBSOLS,RESULTS
13 D NOW^%DTC S X1=X,X2=-3 D C^%DTC S PSBDT=X
14 S PSBPIN=DFN
15 S Z="" F S Z=$O(ORDIV(Z)) Q:Z="" D
16 .D GETORD^PSBCHIVH(ORDIV(Z))
17 .F S=1:1 Q:$P(PSBONXSB,"^",S)="" D
18 ..S PSBORD=$P(PSBONXSB,"^",S)
19 ..S PSBGNODE="^PSB(53.79,"_"""AUID"""_","_DFN_")"
20 ..F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE="" Q:$QS(PSBGNODE,3)'=DFN D
21 ...I $QS(PSBGNODE,4)=PSBORD D
22 ....S PSBBIEN=$QS(PSBGNODE,6)
23 ....S PSBSTATS=$P(^PSB(53.79,PSBBIEN,0),U,9) D:(PSBSTATS="I")!(PSBSTATS="S") Q
24 .....S PSBBUID=$QS(PSBGNODE,5),PSBOR=$$FNDLBLO^PSBVDLU2(PSBPIN,$QS(PSBGNODE,4),PSBBUID),(PSBXOR,PSBLOR)=PSBOR
25 .....; G IV bag
26 .....; IS ORD is "live"
27 .....S PSBNXOR=PSBOR
28 .....S PSBSTOP=0 F K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBNXOR,1) S:($P(^TMP("PSJ1",$J,0),U,5)']"")&($P($G(^TMP("PSJ1",$J,4)),U,7)<PSBDT) PSBSTOP=1 Q:PSBNXOR=$P(^TMP("PSJ1",$J,0),U,5) S PSBNXOR=$P(^TMP("PSJ1",$J,0),U,5) Q:PSBNXOR']""
29 .....I 'PSBSTOP F PSBXX=1:1 D K ^TMP("PSJ1",$J) S:PSBOR="" PSBCO(PSBXOR)=PSBLOR Q:PSBOR="" ;
30 ......K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBOR,1)
31 ......S PSBDX="" F S PSBDX=$O(^TMP("PSJ1",$J,PSBDX)) Q:PSBDX="" I $D(^TMP("PSJ1",$J,PSBDX,1000,PSBBUID)) S PSBLABDT=$P(^TMP("PSJ1",$J,PSBDX,1000,PSBBUID,0),U) Q
32 ......K ^TMP("PSJ2",$J) D EN^PSJBCMA2(DFN,PSBOR,1) D:$D(^TMP("PSJ2",$J))
33 .......S PSBX=0 F S PSBX=$O(^TMP("PSJ2",$J,PSBX)) Q:PSBX="" D:$P(^TMP("PSJ2",$J,PSBX,1),U,3)]""
34 ........S PSBCHGDT=$P(^TMP("PSJ2",$J,PSBX,1),U),PSBPARAM=$P(^TMP("PSJ2",$J,PSBX,1),U,3)
35 ........I ($P(^TMP("PSJ2",$J,PSBX,1),U)'<$G(PSBLABDT)) S PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)=" changed to ",PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)=PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)_$$NEWDATA(PSBPARAM)
36 ......M PSBBAGD(PSBXOR,PSBXX,0)=^TMP("PSJ1",$J,0),PSBBAGD(PSBXOR,PSBXX,4)=^TMP("PSJ1",$J,4),PSBBAGD(PSBXOR,PSBXX,2)=^TMP("PSJ1",$J,2)
37 ......F PSBX=800,850,900,950,1000 D
38 .......I "800900"[PSBX M PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$J,PSBX,PSBBUID)
39 .......I ("850950"[PSBX),'$D(PSBBAGD(PSBXOR,PSBXX,(PSBX-50),PSBBUID)) M PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$J,PSBX)
40 .......S:PSBXX=1 PSBBUIDS(PSBXOR,PSBBUID)=PSBXOR_U_PSBBUID_U_($P(PSBBAGD(PSBXOR,PSBXX,2),U,2))_U_PSBSTATS
41 .......D:(PSBXX=1)
42 ........I (PSBX=800) F PSBXY=0 S PSBXY=$O(PSBBAGD(PSBXOR,1,800,PSBBUID,PSBXY)) Q:PSBXY="" S PSBBUIDS(PSBXOR,PSBBUID,"ADD",PSBXY)="ADD"_U_PSBBAGD(PSBXOR,1,800,PSBBUID,PSBXY)
43 ........I (PSBX=900) F PSBXY=0 S PSBXY=$O(PSBBAGD(PSBXOR,1,900,PSBBUID,PSBXY)) Q:PSBXY="" S PSBBUIDS(PSBXOR,PSBBUID,"SOL",PSBXY)="SOL"_U_PSBBAGD(PSBXOR,1,900,PSBBUID,PSBXY)
44 ........I (PSBX=850) F PSBXY=0 S PSBXY=$O(PSBBAGD(PSBXOR,1,850,PSBBUID,PSBXY)) Q:PSBXY="" S PSBBUIDS(PSBXOR,PSBBUID,"ADD",PSBXY)="ADD"_U_PSBBAGD(PSBXOR,1,850,PSBBUID,PSBXY,0)
45 ........I (PSBX=950) F PSBXY=0 S PSBXY=$O(PSBBAGD(PSBXOR,1,950,PSBBUID,PSBXY)) Q:PSBXY="" S PSBBUIDS(PSBXOR,PSBBUID,"SOL",PSBXY)="SOL"_U_PSBBAGD(PSBXOR,1,950,PSBBUID,PSBXY,0)
46 ......S PSBLOR=$P(^TMP("PSJ1",$J,0),U,3),PSBOR=$P(^TMP("PSJ1",$J,0),U,5) K ^TMP("PSJ1",$J)
47 ......I PSBOR["P" S PSBOR=$$PSBNXACT(PSBPIN,PSBOR)
48 S (PSBLINES,RESULTS(0))=0
49 Q:$G(PSBGNODE)=""
50 I $D(PSBBAGD) S PSBXOR="" F S PSBXOR=$O(PSBBAGD(PSBXOR)) Q:PSBXOR="" D
51 .S PSBXX=$O(PSBBAGD(PSBXOR,""),-1)
52 .I $P(PSBBAGD(PSBXOR,PSBXX,4),U,7)<PSBDT S PSBLINES=0 Q ; "Whole of" order exp 3 dAYS ago proc nxt
53 .F PSBXX=1:1:($O(PSBBAGD(PSBXOR,""),-1)-1) S PSBXY=PSBXX+1 D:$D(PSBBAGD(PSBXOR,PSBXY))
54 ..D CLEAN^PSBVT,PSJ1^PSBVT(PSBPIN,$P(PSBBAGD(PSBXOR,PSBXX,0),U,3))
55 ..K PSBOTMP
56 ..I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E S PSBOTMP("ADD")=""
57 ..I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E S PSBOTMP("SOL")="" ;solut,vol
58 ..K PSBADA,PSBSOLA
59 ..S PSBOTMP("INFUSION RATE")=$G(PSBIFR)
60 ..S PSBOTMP("MED ROUTE")=$G(PSBMR)
61 ..S PSBOTMP("REMARKS")=$G(PSBRMRK)
62 ..S PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
63 ..S PSBOTMP("PROVIDER")=PSBMD
64 ..S PSBOTMP("START DATE/TIME")=PSBOST
65 ..S PSBOTMP("STOP DATE/TIME")=PSBOSP
66 ..D CLEAN^PSBVT,PSJ1^PSBVT(PSBPIN,$P(PSBBAGD(PSBXOR,PSBXY,0),U,3))
67 ..D EN^PSJBCMA2(PSBPIN,$P(PSBBAGD(PSBXOR,PSBXY,0),U,3),1) S:$P(^TMP("PSJ2",$J,1,1),U)]"" PSBCHGDT=$P(^TMP("PSJ2",$J,1,1),U)
68 ..I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD
69 ..I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL
70 ..I PSBIFR'=PSBOTMP("INFUSION RATE") S:PSBOTMP("INFUSION RATE")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"INFUSION RATE")=" changed to "_PSBIFR
71 ..I PSBMR'=PSBOTMP("MED ROUTE") S:PSBMR'=PSBOTMP("MED ROUTE")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"MED ROUTE")=" changed to "_PSBMR
72 ..I PSBRMRK'=PSBOTMP("REMARKS") S:PSBOTMP("REMARKS")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"REMARKS")=" changed to "_PSBRMRK
73 ..I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") S:PSBOTMP("OTHER PRINT INFO")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"OTHER PRINT INFO")=" changed to "_PSBOTXT
74 ..I PSBMD'=PSBOTMP("PROVIDER") S:PSBOTMP("PROVIDER")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"PROVIDER")=" changed to "_PSBMDX
75 ..I $E(PSBOST,1,12)'=$E(PSBOTMP("START DATE/TIME"),1,12) S PSBIVCHG(PSBXOR,PSBCHGDT,"START DATE/TIME")=" changed to "_PSBOSTX
76 ..I $E(PSBOSP,1,12)'=$E(PSBOTMP("STOP DATE/TIME"),1,12) S PSBIVCHG(PSBXOR,PSBCHGDT,"STOP DATE/TIME")=" changed to "_PSBOSPX
77 ..D CLEAN^PSBVT
78 ; Get RESULTS
79 D:$D(PSBIVCHG)
80 .S PSBXX="" F S PSBXX=$O(PSBIVCHG(PSBXX)) S:PSBLINES>0 PSBLINES=PSBLINES+1,RESULTS(PSBLINES)="END",RESULTS(0)=PSBLINES Q:PSBXX="" D
81 ..S PSBXY="" F S PSBXY=$O(PSBBUIDS(PSBXX,PSBXY)) Q:PSBXY="" D
82 ...S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY)_U_PSBCO(PSBXX)
83 ...S PSBXZ=0 F S PSBXZ=$O(PSBBUIDS(PSBXX,PSBXY,"ADD",PSBXZ)) Q:PSBXZ="" S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY,"ADD",PSBXZ)
84 ...S PSBXZ=0 F S PSBXZ=$O(PSBBUIDS(PSBXX,PSBXY,"SOL",PSBXZ)) Q:PSBXZ="" S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY,"SOL",PSBXZ)
85 ..S PSBXY="" F S PSBXY=$O(PSBIVCHG(PSBXX,PSBXY),-1) Q:PSBXY="" D
86 ...S PSBXZ="" F S PSBXZ=$O(PSBIVCHG(PSBXX,PSBXY,PSBXZ)) Q:PSBXZ="" D
87 ....I '("ADDITIVE STRENGTH SOLUTION VOLUME "[PSBXZ) S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)="CD"_U_PSBXY_U_PSBXZ_PSBIVCHG(PSBXX,PSBXY,PSBXZ)
88 ....I "ADDITIVE STRENGTH SOLUTION VOLUME "[PSBXZ S PSBZX="" F S PSBZX=$O(PSBIVCHG(PSBXX,PSBXY,PSBXZ,PSBZX)) Q:PSBZX="" S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)="CD"_U_PSBXY_U_PSBXZ_PSBIVCHG(PSBXX,PSBXY,PSBXZ,PSBZX)
89 K PSBIVCHG,PSBLINES,PSBBAGD,PSBAD,PSBSOL
90 Q
91CHKADD N X,PSBADDS ; Check addit(s)
92 I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q ; no adds
93 S X="" F S X=$O(PSBOTMP("ADD",X)) Q:X="" K PSBAD,PSBSTR S PSBAD=$P(PSBOTMP("ADD",X),U,2),PSBSTR=$P(PSBOTMP("ADD",X),U,4),PSBADDS(PSBAD,PSBSTR)=PSBOTMP("ADD",X)
94 S X="" F S X=$O(PSBADA(X)) Q:X="" D
95 .K PSBAD,PSBSTR S PSBAD=$P(PSBADA(X),U,2),PSBSTR=$P(PSBADA(X),U,4)
96 .I $D(PSBADDS(PSBAD,PSBSTR)) K PSBADDS(PSBAD,PSBSTR) Q
97 .I '$D(PSBADDS(PSBAD)) S PSBTXT=PSBADA(X),$P(PSBTXT,U,1)="",$P(PSBTXT,U,2)="",PSBIVCHG(PSBXOR,PSBCHGDT,"ADDITIVE",PSBAD)=" added"_$TR(PSBTXT,U," ")
98 .E K PSBADDS(PSBAD) S PSBIVCHG(PSBXOR,PSBCHGDT,"STRENGTH ",PSBAD)=$P(PSBADA(X),U,3)_" changed to "_$P(PSBADA(X),U,4)
99 S X="" F S X=$O(PSBADDS(X)) Q:X="" I '$D(PSBIVCHG(PSBXOR,PSBCHGDT,"ADDITIVE",X)) S PSBTXT=PSBADDS(X,($O(PSBADDS(X,"")))),$P(PSBTXT,U,1)="",$P(PSBTXT,U,2)="",PSBIVCHG(PSBXOR,PSBOST,"ADDITIVE",X)=" deleted"_$TR(PSBTXT,U," ")
100 Q
101CHKSOL N Y,PSBSOLS ; Check solut(s)
102 I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q ; no sols
103 S Y="" F S Y=$O(PSBOTMP("SOL",Y)) Q:Y="" K PSBSOL,PSBVOL S PSBSOL=$P(PSBOTMP("SOL",Y),U,2),PSBVOL=$P(PSBOTMP("SOL",Y),U,4),PSBSOLS(PSBSOL,PSBVOL)=PSBOTMP("SOL",Y)
104 S Y="" F S Y=$O(PSBSOLA(Y)) Q:Y="" D
105 .K PSBSOL,PSBVOL S PSBSOL=$P(PSBSOLA(Y),U,2),PSBVOL=$P(PSBSOLA(Y),U,4)
106 .I $D(PSBSOLS(PSBSOL,PSBVOL)) K PSBSOLS(PSBSOL,PSBVOL) Q
107 .I '$D(PSBSOLS(PSBSOL)) S PSBTXT=PSBSOLA(Y),$P(PSBTXT,U,1)="",$P(PSBTXT,U,2)="",PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",PSBSOL)=" added"_$TR(PSBTXT,U," ")
108 .E K PSBSOLS(PSBSOL) S PSBIVCHG(PSBXOR,PSBCHGDT,"VOLUME ",PSBSOL)=$P(PSBSOLA(Y),U,3)_" changed to "_$P(PSBSOLA(Y),U,4)
109 S Y="" F S Y=$O(PSBSOLS(Y)) Q:Y="" S:'$D(PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",Y)) PSBTXT=PSBSOLS(Y,($O(PSBSOLS(Y,"")))),$P(PSBTXT,U,1)="",$P(PSBTXT,U,2)="",PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",Y)=" deleted"_$TR(PSBTXT,U," ")
110 Q
111PSBNXACT(DFN,PORDN) ;
112 N PSBDFN,PSBOR S PSBDFN=DFN,PSBOR=PORDN K PSBDID
113 S PSBNXACT="" I (PSBDFN="")!(PSBOR="")!(PSBOR'["P") Q PSBNXACT
114 F Q:PSBOR="" Q:$D(PSBDID(PSBOR)) D
115 .K ^TMP("PSJ1",$J) D EN^PSJBCMA1(PSBDFN,PSBOR,1) S PSBOR=$P(^TMP("PSJ1",$J,0),U,5) K ^TMP("PSJ1",$J)
116 .I $G(PSBOR)]"",$G(PSBOR)'["P" S PSBNXACT=PSBOR S PSBOR=""
117 .E S:$G(PSBOR)]"" (PSBNXACT,PSBDID($G(PSBOR)))=""
118 .K ^TMP("PSJ1",$J)
119 I PSBNXACT="" D EN^PSJBCMA1(PSBDFN,PSBLOR,1) I $P(^TMP("PSJ1",$J,4),U,7)<PSBDT K PSBBAGD(PSBXOR),PSBBUIDS(PSBXOR),PSBIVCHG(PSBXOR)
120 Q PSBNXACT
121NEWDATA(PSBPARM) ;
122 S NEWDATA="" N PSBDX S PSBDX="",PSBDX=$O(PSBIVCHG(PSBXOR,PSBDX),-1)
123 F S PSBDX=$O(PSBIVCHG(PSBXOR,PSBDX),-1) Q:PSBDX="" D:$D(PSBIVCHG(PSBXOR,PSBDX,PSBPARM)) Q:PSBDX=""
124 .S PSBIVCHG(PSBXOR,PSBDX,PSBPARM)=" changed to "_$G(^TMP("PSJ2",$J,PSBX,2)),PSBDX=""
125 I $G(PSBPARM)="INFUSION RATE" Q $P(^TMP("PSJ1",$J,2),U,4)
126 I $G(PSBPARM)="MED ROUTE" Q $P(^TMP("PSJ1",$J,1),U,13)
127 I $G(PSBPARM)="PROVIDER" Q $P(^TMP("PSJ1",$J,1),U,2)
128 I $G(PSBPARM)="REMARKS" Q $G(^TMP("PSJ1",$J,6))
129 I $G(PSBPARM)="OTHER PRINT INFO" Q $G(^TMP("PSJ1",$J,3))
130 I $G(PSBPARM)="STOP DATE/TIME" Q $P(^TMP("PSJ1",$J,4),U,8)
131 I $G(PSBPARM)="START DATE/TIME" Q $P(^TMP("PSJ1",$J,4),U,6)
132 Q NEWDATA
Note: See TracBrowser for help on using the repository browser.