PSBCHKIV ;BIRMINGHAM/TEJ-BCMA CHECK IV ROUTINE ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**16**;Mar 2004
;
;This routine will provide "change" details for infus or stopped IV bags.
;
; Reference/IA
; EN^PSJBCMA1/2829
; EN^PSJBCMA2/2830
;
RPC(RESULTS,DFN,ORDIV) ;
I '$D(ORDIV) S RESULTS(0)=0 Q
N PSBGNODE,PSBPIN,PSBXX,PSBX,PSBBUIDS,PSBBUID K PSBBAGD,PSBADDS,PSBSOLS,RESULTS
D NOW^%DTC S X1=X,X2=-3 D C^%DTC S PSBDT=X
S PSBPIN=DFN
S Z="" F S Z=$O(ORDIV(Z)) Q:Z="" D
.D GETORD^PSBCHIVH(ORDIV(Z))
.F S=1:1 Q:$P(PSBONXSB,"^",S)="" D
..S PSBORD=$P(PSBONXSB,"^",S)
..S PSBGNODE="^PSB(53.79,"_"""AUID"""_","_DFN_")"
..F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE="" Q:$QS(PSBGNODE,3)'=DFN D
...I $QS(PSBGNODE,4)=PSBORD D
....S PSBBIEN=$QS(PSBGNODE,6)
....S PSBSTATS=$P(^PSB(53.79,PSBBIEN,0),U,9) D:(PSBSTATS="I")!(PSBSTATS="S") Q
.....S PSBBUID=$QS(PSBGNODE,5),PSBOR=$$FNDLBLO^PSBVDLU2(PSBPIN,$QS(PSBGNODE,4),PSBBUID),(PSBXOR,PSBLOR)=PSBOR
.....; G IV bag
.....; IS ORD is "live"
.....S PSBNXOR=PSBOR
.....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']""
.....I 'PSBSTOP F PSBXX=1:1 D K ^TMP("PSJ1",$J) S:PSBOR="" PSBCO(PSBXOR)=PSBLOR Q:PSBOR="" ;
......K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBOR,1)
......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
......K ^TMP("PSJ2",$J) D EN^PSJBCMA2(DFN,PSBOR,1) D:$D(^TMP("PSJ2",$J))
.......S PSBX=0 F S PSBX=$O(^TMP("PSJ2",$J,PSBX)) Q:PSBX="" D:$P(^TMP("PSJ2",$J,PSBX,1),U,3)]""
........S PSBCHGDT=$P(^TMP("PSJ2",$J,PSBX,1),U),PSBPARAM=$P(^TMP("PSJ2",$J,PSBX,1),U,3)
........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)
......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)
......F PSBX=800,850,900,950,1000 D
.......I "800900"[PSBX M PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$J,PSBX,PSBBUID)
.......I ("850950"[PSBX),'$D(PSBBAGD(PSBXOR,PSBXX,(PSBX-50),PSBBUID)) M PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$J,PSBX)
.......S:PSBXX=1 PSBBUIDS(PSBXOR,PSBBUID)=PSBXOR_U_PSBBUID_U_($P(PSBBAGD(PSBXOR,PSBXX,2),U,2))_U_PSBSTATS
.......D:(PSBXX=1)
........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)
........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)
........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)
........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)
......S PSBLOR=$P(^TMP("PSJ1",$J,0),U,3),PSBOR=$P(^TMP("PSJ1",$J,0),U,5) K ^TMP("PSJ1",$J)
......I PSBOR["P" S PSBOR=$$PSBNXACT(PSBPIN,PSBOR)
S (PSBLINES,RESULTS(0))=0
Q:$G(PSBGNODE)=""
I $D(PSBBAGD) S PSBXOR="" F S PSBXOR=$O(PSBBAGD(PSBXOR)) Q:PSBXOR="" D
.S PSBXX=$O(PSBBAGD(PSBXOR,""),-1)
.I $P(PSBBAGD(PSBXOR,PSBXX,4),U,7)<PSBDT S PSBLINES=0 Q ; "Whole of" order exp 3 dAYS ago proc nxt
.F PSBXX=1:1:($O(PSBBAGD(PSBXOR,""),-1)-1) S PSBXY=PSBXX+1 D:$D(PSBBAGD(PSBXOR,PSBXY))
..D CLEAN^PSBVT,PSJ1^PSBVT(PSBPIN,$P(PSBBAGD(PSBXOR,PSBXX,0),U,3))
..K PSBOTMP
..I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E S PSBOTMP("ADD")=""
..I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E S PSBOTMP("SOL")="" ;solut,vol
..K PSBADA,PSBSOLA
..S PSBOTMP("INFUSION RATE")=$G(PSBIFR)
..S PSBOTMP("MED ROUTE")=$G(PSBMR)
..S PSBOTMP("REMARKS")=$G(PSBRMRK)
..S PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
..S PSBOTMP("PROVIDER")=PSBMD
..S PSBOTMP("START DATE/TIME")=PSBOST
..S PSBOTMP("STOP DATE/TIME")=PSBOSP
..D CLEAN^PSBVT,PSJ1^PSBVT(PSBPIN,$P(PSBBAGD(PSBXOR,PSBXY,0),U,3))
..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)
..I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD
..I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL
..I PSBIFR'=PSBOTMP("INFUSION RATE") S:PSBOTMP("INFUSION RATE")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"INFUSION RATE")=" changed to "_PSBIFR
..I PSBMR'=PSBOTMP("MED ROUTE") S:PSBMR'=PSBOTMP("MED ROUTE")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"MED ROUTE")=" changed to "_PSBMR
..I PSBRMRK'=PSBOTMP("REMARKS") S:PSBOTMP("REMARKS")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"REMARKS")=" changed to "_PSBRMRK
..I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") S:PSBOTMP("OTHER PRINT INFO")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"OTHER PRINT INFO")=" changed to "_PSBOTXT
..I PSBMD'=PSBOTMP("PROVIDER") S:PSBOTMP("PROVIDER")]"" PSBIVCHG(PSBXOR,PSBCHGDT,"PROVIDER")=" changed to "_PSBMDX
..I $E(PSBOST,1,12)'=$E(PSBOTMP("START DATE/TIME"),1,12) S PSBIVCHG(PSBXOR,PSBCHGDT,"START DATE/TIME")=" changed to "_PSBOSTX
..I $E(PSBOSP,1,12)'=$E(PSBOTMP("STOP DATE/TIME"),1,12) S PSBIVCHG(PSBXOR,PSBCHGDT,"STOP DATE/TIME")=" changed to "_PSBOSPX
..D CLEAN^PSBVT
; Get RESULTS
D:$D(PSBIVCHG)
.S PSBXX="" F S PSBXX=$O(PSBIVCHG(PSBXX)) S:PSBLINES>0 PSBLINES=PSBLINES+1,RESULTS(PSBLINES)="END",RESULTS(0)=PSBLINES Q:PSBXX="" D
..S PSBXY="" F S PSBXY=$O(PSBBUIDS(PSBXX,PSBXY)) Q:PSBXY="" D
...S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY)_U_PSBCO(PSBXX)
...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)
...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)
..S PSBXY="" F S PSBXY=$O(PSBIVCHG(PSBXX,PSBXY),-1) Q:PSBXY="" D
...S PSBXZ="" F S PSBXZ=$O(PSBIVCHG(PSBXX,PSBXY,PSBXZ)) Q:PSBXZ="" D
....I '("ADDITIVE STRENGTH SOLUTION VOLUME "[PSBXZ) S PSBLINES=PSBLINES+1,RESULTS(PSBLINES)="CD"_U_PSBXY_U_PSBXZ_PSBIVCHG(PSBXX,PSBXY,PSBXZ)
....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)
K PSBIVCHG,PSBLINES,PSBBAGD,PSBAD,PSBSOL
Q
CHKADD N X,PSBADDS ; Check addit(s)
I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q ; no adds
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)
S X="" F S X=$O(PSBADA(X)) Q:X="" D
.K PSBAD,PSBSTR S PSBAD=$P(PSBADA(X),U,2),PSBSTR=$P(PSBADA(X),U,4)
.I $D(PSBADDS(PSBAD,PSBSTR)) K PSBADDS(PSBAD,PSBSTR) Q
.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," ")
.E K PSBADDS(PSBAD) S PSBIVCHG(PSBXOR,PSBCHGDT,"STRENGTH ",PSBAD)=$P(PSBADA(X),U,3)_" changed to "_$P(PSBADA(X),U,4)
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," ")
Q
CHKSOL N Y,PSBSOLS ; Check solut(s)
I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q ; no sols
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)
S Y="" F S Y=$O(PSBSOLA(Y)) Q:Y="" D
.K PSBSOL,PSBVOL S PSBSOL=$P(PSBSOLA(Y),U,2),PSBVOL=$P(PSBSOLA(Y),U,4)
.I $D(PSBSOLS(PSBSOL,PSBVOL)) K PSBSOLS(PSBSOL,PSBVOL) Q
.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," ")
.E K PSBSOLS(PSBSOL) S PSBIVCHG(PSBXOR,PSBCHGDT,"VOLUME ",PSBSOL)=$P(PSBSOLA(Y),U,3)_" changed to "_$P(PSBSOLA(Y),U,4)
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," ")
Q
PSBNXACT(DFN,PORDN) ;
N PSBDFN,PSBOR S PSBDFN=DFN,PSBOR=PORDN K PSBDID
S PSBNXACT="" I (PSBDFN="")!(PSBOR="")!(PSBOR'["P") Q PSBNXACT
F Q:PSBOR="" Q:$D(PSBDID(PSBOR)) D
.K ^TMP("PSJ1",$J) D EN^PSJBCMA1(PSBDFN,PSBOR,1) S PSBOR=$P(^TMP("PSJ1",$J,0),U,5) K ^TMP("PSJ1",$J)
.I $G(PSBOR)]"",$G(PSBOR)'["P" S PSBNXACT=PSBOR S PSBOR=""
.E S:$G(PSBOR)]"" (PSBNXACT,PSBDID($G(PSBOR)))=""
.K ^TMP("PSJ1",$J)
I PSBNXACT="" D EN^PSJBCMA1(PSBDFN,PSBLOR,1) I $P(^TMP("PSJ1",$J,4),U,7)<PSBDT K PSBBAGD(PSBXOR),PSBBUIDS(PSBXOR),PSBIVCHG(PSBXOR)
Q PSBNXACT
NEWDATA(PSBPARM) ;
S NEWDATA="" N PSBDX S PSBDX="",PSBDX=$O(PSBIVCHG(PSBXOR,PSBDX),-1)
F S PSBDX=$O(PSBIVCHG(PSBXOR,PSBDX),-1) Q:PSBDX="" D:$D(PSBIVCHG(PSBXOR,PSBDX,PSBPARM)) Q:PSBDX=""
.S PSBIVCHG(PSBXOR,PSBDX,PSBPARM)=" changed to "_$G(^TMP("PSJ2",$J,PSBX,2)),PSBDX=""
I $G(PSBPARM)="INFUSION RATE" Q $P(^TMP("PSJ1",$J,2),U,4)
I $G(PSBPARM)="MED ROUTE" Q $P(^TMP("PSJ1",$J,1),U,13)
I $G(PSBPARM)="PROVIDER" Q $P(^TMP("PSJ1",$J,1),U,2)
I $G(PSBPARM)="REMARKS" Q $G(^TMP("PSJ1",$J,6))
I $G(PSBPARM)="OTHER PRINT INFO" Q $G(^TMP("PSJ1",$J,3))
I $G(PSBPARM)="STOP DATE/TIME" Q $P(^TMP("PSJ1",$J,4),U,8)
I $G(PSBPARM)="START DATE/TIME" Q $P(^TMP("PSJ1",$J,4),U,6)
Q NEWDATA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBCHKIV 9782 printed Apr 09, 2024@20:45:16 Page 2
PSBCHKIV ;BIRMINGHAM/TEJ-BCMA CHECK IV ROUTINE ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**16**;Mar 2004
+2 ;
+3 ;This routine will provide "change" details for infus or stopped IV bags.
+4 ;
+5 ; Reference/IA
+6 ; EN^PSJBCMA1/2829
+7 ; EN^PSJBCMA2/2830
+8 ;
RPC(RESULTS,DFN,ORDIV) ;
+1 IF '$DATA(ORDIV)
SET RESULTS(0)=0
QUIT
+2 NEW PSBGNODE,PSBPIN,PSBXX,PSBX,PSBBUIDS,PSBBUID
KILL PSBBAGD,PSBADDS,PSBSOLS,RESULTS
+3 DO NOW^%DTC
SET X1=X
SET X2=-3
DO C^%DTC
SET PSBDT=X
+4 SET PSBPIN=DFN
+5 SET Z=""
FOR
SET Z=$ORDER(ORDIV(Z))
if Z=""
QUIT
Begin DoDot:1
+6 DO GETORD^PSBCHIVH(ORDIV(Z))
+7 FOR S=1:1
if $PIECE(PSBONXSB,"^",S)=""
QUIT
Begin DoDot:2
+8 SET PSBORD=$PIECE(PSBONXSB,"^",S)
+9 SET PSBGNODE="^PSB(53.79,"_"""AUID"""_","_DFN_")"
+10 FOR
SET PSBGNODE=$QUERY(@PSBGNODE)
if PSBGNODE=""
QUIT
if $QSUBSCRIPT(PSBGNODE,3)'=DFN
QUIT
Begin DoDot:3
+11 IF $QSUBSCRIPT(PSBGNODE,4)=PSBORD
Begin DoDot:4
+12 SET PSBBIEN=$QSUBSCRIPT(PSBGNODE,6)
+13 SET PSBSTATS=$PIECE(^PSB(53.79,PSBBIEN,0),U,9)
if (PSBSTATS="I")!(PSBSTATS="S")
Begin DoDot:5
+14 SET PSBBUID=$QSUBSCRIPT(PSBGNODE,5)
SET PSBOR=$$FNDLBLO^PSBVDLU2(PSBPIN,$QSUBSCRIPT(PSBGNODE,4),PSBBUID)
SET (PSBXOR,PSBLOR)=PSBOR
+15 ; G IV bag
+16 ; IS ORD is "live"
+17 SET PSBNXOR=PSBOR
+18 SET PSBSTOP=0
FOR
KILL ^TMP("PSJ1",$JOB)
DO EN^PSJBCMA1(DFN,PSBNXOR,1)
if ($PIECE(^TMP("PSJ1",$JOB,0),U,5)']"")&($PIECE($GET(^TMP("PSJ1",$JOB,4)),U,7)<PSBDT)
SET PSBSTOP=1
if PSBNXOR=$PIECE(^TMP("PSJ1",$JOB,0),U,5)
QUIT
SET PSBNXOR=$PIECE(^TMP("PSJ1",$JOB,0),U,5)
if PSBNXOR']""
QUIT
+19 ;
IF 'PSBSTOP
FOR PSBXX=1:1
Begin DoDot:6
+20 KILL ^TMP("PSJ1",$JOB)
DO EN^PSJBCMA1(DFN,PSBOR,1)
+21 SET PSBDX=""
FOR
SET PSBDX=$ORDER(^TMP("PSJ1",$JOB,PSBDX))
if PSBDX=""
QUIT
IF $DATA(^TMP("PSJ1",$JOB,PSBDX,1000,PSBBUID))
SET PSBLABDT=$PIECE(^TMP("PSJ1",$JOB,PSBDX,1000,PSBBUID,0),U)
QUIT
+22 KILL ^TMP("PSJ2",$JOB)
DO EN^PSJBCMA2(DFN,PSBOR,1)
if $DATA(^TMP("PSJ2",$JOB))
Begin DoDot:7
+23 SET PSBX=0
FOR
SET PSBX=$ORDER(^TMP("PSJ2",$JOB,PSBX))
if PSBX=""
QUIT
if $PIECE(^TMP("PSJ2",$JOB,PSBX,1),U,3)]""
Begin DoDot:8
+24 SET PSBCHGDT=$PIECE(^TMP("PSJ2",$JOB,PSBX,1),U)
SET PSBPARAM=$PIECE(^TMP("PSJ2",$JOB,PSBX,1),U,3)
+25 IF ($PIECE(^TMP("PSJ2",$JOB,PSBX,1),U)'<$GET(PSBLABDT))
SET PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)=" changed to "
SET PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)=PSBIVCHG(PSBXOR,PSBCHGDT,PSBPARAM)_$$NEWDATA(PSBPARAM)
End DoDot:8
End DoDot:7
+26 MERGE PSBBAGD(PSBXOR,PSBXX,0)=^TMP("PSJ1",$JOB,0),PSBBAGD(PSBXOR,PSBXX,4)=^TMP("PSJ1",$JOB,4),PSBBAGD(PSBXOR,PSBXX,2)=^TMP("PSJ1",$JOB,2)
+27 FOR PSBX=800,850,900,950,1000
Begin DoDot:7
+28 IF "800900"[PSBX
MERGE PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$JOB,PSBX,PSBBUID)
+29 IF ("850950"[PSBX)
IF '$DATA(PSBBAGD(PSBXOR,PSBXX,(PSBX-50),PSBBUID))
MERGE PSBBAGD(PSBXOR,PSBXX,PSBX,PSBBUID)=^TMP("PSJ1",$JOB,PSBX)
+30 if PSBXX=1
SET PSBBUIDS(PSBXOR,PSBBUID)=PSBXOR_U_PSBBUID_U_($PIECE(PSBBAGD(PSBXOR,PSBXX,2),U,2))_U_PSBSTATS
+31 if (PSBXX=1)
Begin DoDot:8
+32 IF (PSBX=800)
FOR PSBXY=0
SET PSBXY=$ORDER(PSBBAGD(PSBXOR,1,800,PSBBUID,PSBXY))
if PSBXY=""
QUIT
SET PSBBUIDS(PSBXOR,PSBBUID,"ADD",PSBXY)="ADD"_U_PSBBAGD(PSBXOR,1,800,PSBBUID,PSBXY)
+33 IF (PSBX=900)
FOR PSBXY=0
SET PSBXY=$ORDER(PSBBAGD(PSBXOR,1,900,PSBBUID,PSBXY))
if PSBXY=""
QUIT
SET PSBBUIDS(PSBXOR,PSBBUID,"SOL",PSBXY)="SOL"_U_PSBBAGD(PSBXOR,1,900,PSBBUID,PSBXY)
+34 IF (PSBX=850)
FOR PSBXY=0
SET PSBXY=$ORDER(PSBBAGD(PSBXOR,1,850,PSBBUID,PSBXY))
if PSBXY=""
QUIT
SET PSBBUIDS(PSBXOR,PSBBUID,"ADD",PSBXY)="ADD"_U_PSBBAGD(PSBXOR,1,850,PSBBUID,PSBXY,0)
+35 IF (PSBX=950)
FOR PSBXY=0
SET PSBXY=$ORDER(PSBBAGD(PSBXOR,1,950,PSBBUID,PSBXY))
if PSBXY=""
QUIT
SET PSBBUIDS(PSBXOR,PSBBUID,"SOL",PSBXY)="SOL"_U_PSBBAGD(PSBXOR,1,950,PSBBUID,PSBXY,0)
End DoDot:8
End DoDot:7
+36 SET PSBLOR=$PIECE(^TMP("PSJ1",$JOB,0),U,3)
SET PSBOR=$PIECE(^TMP("PSJ1",$JOB,0),U,5)
KILL ^TMP("PSJ1",$JOB)
+37 IF PSBOR["P"
SET PSBOR=$$PSBNXACT(PSBPIN,PSBOR)
End DoDot:6
KILL ^TMP("PSJ1",$JOB)
if PSBOR=""
SET PSBCO(PSBXOR)=PSBLOR
if PSBOR=""
QUIT
End DoDot:5
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+38 SET (PSBLINES,RESULTS(0))=0
+39 if $GET(PSBGNODE)=""
QUIT
+40 IF $DATA(PSBBAGD)
SET PSBXOR=""
FOR
SET PSBXOR=$ORDER(PSBBAGD(PSBXOR))
if PSBXOR=""
QUIT
Begin DoDot:1
+41 SET PSBXX=$ORDER(PSBBAGD(PSBXOR,""),-1)
+42 ; "Whole of" order exp 3 dAYS ago proc nxt
IF $PIECE(PSBBAGD(PSBXOR,PSBXX,4),U,7)<PSBDT
SET PSBLINES=0
QUIT
+43 FOR PSBXX=1:1:($ORDER(PSBBAGD(PSBXOR,""),-1)-1)
SET PSBXY=PSBXX+1
if $DATA(PSBBAGD(PSBXOR,PSBXY))
Begin DoDot:2
+44 DO CLEAN^PSBVT
DO PSJ1^PSBVT(PSBPIN,$PIECE(PSBBAGD(PSBXOR,PSBXX,0),U,3))
+45 KILL PSBOTMP
+46 IF $DATA(PSBADA)
MERGE PSBOTMP("ADD")=PSBADA
IF '$TEST
SET PSBOTMP("ADD")=""
+47 ;solut,vol
IF $DATA(PSBSOLA)
MERGE PSBOTMP("SOL")=PSBSOLA
IF '$TEST
SET PSBOTMP("SOL")=""
+48 KILL PSBADA,PSBSOLA
+49 SET PSBOTMP("INFUSION RATE")=$GET(PSBIFR)
+50 SET PSBOTMP("MED ROUTE")=$GET(PSBMR)
+51 SET PSBOTMP("REMARKS")=$GET(PSBRMRK)
+52 SET PSBOTMP("OTHER PRINT INFO")=$GET(PSBOTXT)
+53 SET PSBOTMP("PROVIDER")=PSBMD
+54 SET PSBOTMP("START DATE/TIME")=PSBOST
+55 SET PSBOTMP("STOP DATE/TIME")=PSBOSP
+56 DO CLEAN^PSBVT
DO PSJ1^PSBVT(PSBPIN,$PIECE(PSBBAGD(PSBXOR,PSBXY,0),U,3))
+57 DO EN^PSJBCMA2(PSBPIN,$PIECE(PSBBAGD(PSBXOR,PSBXY,0),U,3),1)
if $PIECE(^TMP("PSJ2",$JOB,1,1),U)]""
SET PSBCHGDT=$PIECE(^TMP("PSJ2",$JOB,1,1),U)
+58 IF $DATA(PSBADA)!($DATA(PSBOTMP("ADD")))
DO CHKADD
+59 IF $DATA(PSBSOLA)!($DATA(PSBOTMP("SOL")))
DO CHKSOL
+60 IF PSBIFR'=PSBOTMP("INFUSION RATE")
if PSBOTMP("INFUSION RATE")]""
SET PSBIVCHG(PSBXOR,PSBCHGDT,"INFUSION RATE")=" changed to "_PSBIFR
+61 IF PSBMR'=PSBOTMP("MED ROUTE")
if PSBMR'=PSBOTMP("MED ROUTE")]""
SET PSBIVCHG(PSBXOR,PSBCHGDT,"MED ROUTE")=" changed to "_PSBMR
+62 IF PSBRMRK'=PSBOTMP("REMARKS")
if PSBOTMP("REMARKS")]""
SET PSBIVCHG(PSBXOR,PSBCHGDT,"REMARKS")=" changed to "_PSBRMRK
+63 IF PSBOTXT'=PSBOTMP("OTHER PRINT INFO")
if PSBOTMP("OTHER PRINT INFO")]""
SET PSBIVCHG(PSBXOR,PSBCHGDT,"OTHER PRINT INFO")=" changed to "_PSBOTXT
+64 IF PSBMD'=PSBOTMP("PROVIDER")
if PSBOTMP("PROVIDER")]""
SET PSBIVCHG(PSBXOR,PSBCHGDT,"PROVIDER")=" changed to "_PSBMDX
+65 IF $EXTRACT(PSBOST,1,12)'=$EXTRACT(PSBOTMP("START DATE/TIME"),1,12)
SET PSBIVCHG(PSBXOR,PSBCHGDT,"START DATE/TIME")=" changed to "_PSBOSTX
+66 IF $EXTRACT(PSBOSP,1,12)'=$EXTRACT(PSBOTMP("STOP DATE/TIME"),1,12)
SET PSBIVCHG(PSBXOR,PSBCHGDT,"STOP DATE/TIME")=" changed to "_PSBOSPX
+67 DO CLEAN^PSBVT
End DoDot:2
End DoDot:1
+68 ; Get RESULTS
+69 if $DATA(PSBIVCHG)
Begin DoDot:1
+70 SET PSBXX=""
FOR
SET PSBXX=$ORDER(PSBIVCHG(PSBXX))
if PSBLINES>0
SET PSBLINES=PSBLINES+1
SET RESULTS(PSBLINES)="END"
SET RESULTS(0)=PSBLINES
if PSBXX=""
QUIT
Begin DoDot:2
+71 SET PSBXY=""
FOR
SET PSBXY=$ORDER(PSBBUIDS(PSBXX,PSBXY))
if PSBXY=""
QUIT
Begin DoDot:3
+72 SET PSBLINES=PSBLINES+1
SET RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY)_U_PSBCO(PSBXX)
+73 SET PSBXZ=0
FOR
SET PSBXZ=$ORDER(PSBBUIDS(PSBXX,PSBXY,"ADD",PSBXZ))
if PSBXZ=""
QUIT
SET PSBLINES=PSBLINES+1
SET RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY,"ADD",PSBXZ)
+74 SET PSBXZ=0
FOR
SET PSBXZ=$ORDER(PSBBUIDS(PSBXX,PSBXY,"SOL",PSBXZ))
if PSBXZ=""
QUIT
SET PSBLINES=PSBLINES+1
SET RESULTS(PSBLINES)=PSBBUIDS(PSBXX,PSBXY,"SOL",PSBXZ)
End DoDot:3
+75 SET PSBXY=""
FOR
SET PSBXY=$ORDER(PSBIVCHG(PSBXX,PSBXY),-1)
if PSBXY=""
QUIT
Begin DoDot:3
+76 SET PSBXZ=""
FOR
SET PSBXZ=$ORDER(PSBIVCHG(PSBXX,PSBXY,PSBXZ))
if PSBXZ=""
QUIT
Begin DoDot:4
+77 IF '("ADDITIVE STRENGTH SOLUTION VOLUME "[PSBXZ)
SET PSBLINES=PSBLINES+1
SET RESULTS(PSBLINES)="CD"_U_PSBXY_U_PSBXZ_PSBIVCHG(PSBXX,PSBXY,PSBXZ)
+78 IF "ADDITIVE STRENGTH SOLUTION VOLUME "[PSBXZ
SET PSBZX=""
FOR
SET PSBZX=$ORDER(PSBIVCHG(PSBXX,PSBXY,PSBXZ,PSBZX))
if PSBZX=""
QUIT
SET PSBLINES=PSBLINES+1
SET RESULTS(PSBLINES)="CD"_U_PSBXY_U_PSBXZ_PSBIVCHG(PSBXX,PSBXY,PSBXZ,PSBZX)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+79 KILL PSBIVCHG,PSBLINES,PSBBAGD,PSBAD,PSBSOL
+80 QUIT
CHKADD ; Check addit(s)
NEW X,PSBADDS
+1 ; no adds
IF '$DATA(PSBADA)
IF '$DATA(PSBOTMP("ADD"))
QUIT
+2 SET X=""
FOR
SET X=$ORDER(PSBOTMP("ADD",X))
if X=""
QUIT
KILL PSBAD,PSBSTR
SET PSBAD=$PIECE(PSBOTMP("ADD",X),U,2)
SET PSBSTR=$PIECE(PSBOTMP("ADD",X),U,4)
SET PSBADDS(PSBAD,PSBSTR)=PSBOTMP("ADD",X)
+3 SET X=""
FOR
SET X=$ORDER(PSBADA(X))
if X=""
QUIT
Begin DoDot:1
+4 KILL PSBAD,PSBSTR
SET PSBAD=$PIECE(PSBADA(X),U,2)
SET PSBSTR=$PIECE(PSBADA(X),U,4)
+5 IF $DATA(PSBADDS(PSBAD,PSBSTR))
KILL PSBADDS(PSBAD,PSBSTR)
QUIT
+6 IF '$DATA(PSBADDS(PSBAD))
SET PSBTXT=PSBADA(X)
SET $PIECE(PSBTXT,U,1)=""
SET $PIECE(PSBTXT,U,2)=""
SET PSBIVCHG(PSBXOR,PSBCHGDT,"ADDITIVE",PSBAD)=" added"_$TRANSLATE(PSBTXT,U," ")
+7 IF '$TEST
KILL PSBADDS(PSBAD)
SET PSBIVCHG(PSBXOR,PSBCHGDT,"STRENGTH ",PSBAD)=$PIECE(PSBADA(X),U,3)_" changed to "_$PIECE(PSBADA(X),U,4)
End DoDot:1
+8 SET X=""
FOR
SET X=$ORDER(PSBADDS(X))
if X=""
QUIT
IF '$DATA(PSBIVCHG(PSBXOR,PSBCHGDT,"ADDITIVE",X))
SET PSBTXT=PSBADDS(X,($ORDER(PSBADDS(X,""))))
SET $PIECE(PSBTXT,U,1)=""
SET $PIECE(PSBTXT,U,2)=""
SET PSBIVCHG(PSBXOR,PSBOST,"ADDITIVE",X)=" deleted"_$TRANSLATE(PSBTXT,U," ")
+9 QUIT
CHKSOL ; Check solut(s)
NEW Y,PSBSOLS
+1 ; no sols
IF '$DATA(PSBSOLA)
IF '$DATA(PSBOTMP("SOL"))
QUIT
+2 SET Y=""
FOR
SET Y=$ORDER(PSBOTMP("SOL",Y))
if Y=""
QUIT
KILL PSBSOL,PSBVOL
SET PSBSOL=$PIECE(PSBOTMP("SOL",Y),U,2)
SET PSBVOL=$PIECE(PSBOTMP("SOL",Y),U,4)
SET PSBSOLS(PSBSOL,PSBVOL)=PSBOTMP("SOL",Y)
+3 SET Y=""
FOR
SET Y=$ORDER(PSBSOLA(Y))
if Y=""
QUIT
Begin DoDot:1
+4 KILL PSBSOL,PSBVOL
SET PSBSOL=$PIECE(PSBSOLA(Y),U,2)
SET PSBVOL=$PIECE(PSBSOLA(Y),U,4)
+5 IF $DATA(PSBSOLS(PSBSOL,PSBVOL))
KILL PSBSOLS(PSBSOL,PSBVOL)
QUIT
+6 IF '$DATA(PSBSOLS(PSBSOL))
SET PSBTXT=PSBSOLA(Y)
SET $PIECE(PSBTXT,U,1)=""
SET $PIECE(PSBTXT,U,2)=""
SET PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",PSBSOL)=" added"_$TRANSLATE(PSBTXT,U," ")
+7 IF '$TEST
KILL PSBSOLS(PSBSOL)
SET PSBIVCHG(PSBXOR,PSBCHGDT,"VOLUME ",PSBSOL)=$PIECE(PSBSOLA(Y),U,3)_" changed to "_$PIECE(PSBSOLA(Y),U,4)
End DoDot:1
+8 SET Y=""
FOR
SET Y=$ORDER(PSBSOLS(Y))
if Y=""
QUIT
if '$DATA(PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",Y))
SET PSBTXT=PSBSOLS(Y,($ORDER(PSBSOLS(Y,""))))
SET $PIECE(PSBTXT,U,1)=""
SET $PIECE(PSBTXT,U,2)=""
SET PSBIVCHG(PSBXOR,PSBCHGDT,"SOLUTION",Y)=" deleted"_$TRANSLATE(PSBTXT,U," ")
+9 QUIT
PSBNXACT(DFN,PORDN) ;
+1 NEW PSBDFN,PSBOR
SET PSBDFN=DFN
SET PSBOR=PORDN
KILL PSBDID
+2 SET PSBNXACT=""
IF (PSBDFN="")!(PSBOR="")!(PSBOR'["P")
QUIT PSBNXACT
+3 FOR
if PSBOR=""
QUIT
if $DATA(PSBDID(PSBOR))
QUIT
Begin DoDot:1
+4 KILL ^TMP("PSJ1",$JOB)
DO EN^PSJBCMA1(PSBDFN,PSBOR,1)
SET PSBOR=$PIECE(^TMP("PSJ1",$JOB,0),U,5)
KILL ^TMP("PSJ1",$JOB)
+5 IF $GET(PSBOR)]""
IF $GET(PSBOR)'["P"
SET PSBNXACT=PSBOR
SET PSBOR=""
+6 IF '$TEST
if $GET(PSBOR)]""
SET (PSBNXACT,PSBDID($GET(PSBOR)))=""
+7 KILL ^TMP("PSJ1",$JOB)
End DoDot:1
+8 IF PSBNXACT=""
DO EN^PSJBCMA1(PSBDFN,PSBLOR,1)
IF $PIECE(^TMP("PSJ1",$JOB,4),U,7)<PSBDT
KILL PSBBAGD(PSBXOR),PSBBUIDS(PSBXOR),PSBIVCHG(PSBXOR)
+9 QUIT PSBNXACT
NEWDATA(PSBPARM) ;
+1 SET NEWDATA=""
NEW PSBDX
SET PSBDX=""
SET PSBDX=$ORDER(PSBIVCHG(PSBXOR,PSBDX),-1)
+2 FOR
SET PSBDX=$ORDER(PSBIVCHG(PSBXOR,PSBDX),-1)
if PSBDX=""
QUIT
if $DATA(PSBIVCHG(PSBXOR,PSBDX,PSBPARM))
Begin DoDot:1
+3 SET PSBIVCHG(PSBXOR,PSBDX,PSBPARM)=" changed to "_$GET(^TMP("PSJ2",$JOB,PSBX,2))
SET PSBDX=""
End DoDot:1
if PSBDX=""
QUIT
+4 IF $GET(PSBPARM)="INFUSION RATE"
QUIT $PIECE(^TMP("PSJ1",$JOB,2),U,4)
+5 IF $GET(PSBPARM)="MED ROUTE"
QUIT $PIECE(^TMP("PSJ1",$JOB,1),U,13)
+6 IF $GET(PSBPARM)="PROVIDER"
QUIT $PIECE(^TMP("PSJ1",$JOB,1),U,2)
+7 IF $GET(PSBPARM)="REMARKS"
QUIT $GET(^TMP("PSJ1",$JOB,6))
+8 IF $GET(PSBPARM)="OTHER PRINT INFO"
QUIT $GET(^TMP("PSJ1",$JOB,3))
+9 IF $GET(PSBPARM)="STOP DATE/TIME"
QUIT $PIECE(^TMP("PSJ1",$JOB,4),U,8)
+10 IF $GET(PSBPARM)="START DATE/TIME"
QUIT $PIECE(^TMP("PSJ1",$JOB,4),U,6)
+11 QUIT NEWDATA
