PSBOIV ;BIRMINGHAM/TEJ-IV BAG STATUS REPORT ;2/6/21 16:54
;;3.0;BAR CODE MED ADMIN;**32,68,70,106**;Mar 2004;Build 43
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; File 52.6/436
; File 52.7/437
; File 4/10090
; File 2/10035
; GETSIOPI^PSJBCMA5/5763
;
;*68 - change to accomodate unlimited lines for SIOPI array
;*70 - reset PSBCLINORD = 2 to signify combined orders report
;*106- add Hazardous Handle & Dispose flags
;
EN ; Entry
N PSB1,PSBFUTR,PSBSI,QQ,PSBHDR ;*70 add psbhdr
K PSBSRTBY,PSBOCRIT,PSBACRIT,NO S PSBCFLG=0
S PSBFUTR=$TR(PSBRPT(1),"~","^")
I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
S PSBDTST=+$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)
S PSBDTSP=+$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
S PSBOCRIT="" ; Ord Sttus "A"ctive, "D"C ed, "E"xprd"
S:$P(PSBFUTR,U,5) PSBOCRIT=PSBOCRIT_"A"
S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_"D"
S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_"E"
S PSBACRIT="" ; Actn Sttus "C"ompl, "I"nfusi, "M"issng, "S"tpped, "H"ld, "R"efsd", "N"o Actn
S:$P(PSBFUTR,U,12) PSBACRIT=PSBACRIT_"I"
S:$P(PSBFUTR,U,13) PSBACRIT=PSBACRIT_"S"
S:$P(PSBFUTR,U,14) PSBACRIT=PSBACRIT_"C"
S:$P(PSBFUTR,U,15) PSBACRIT=PSBACRIT_"N"
S:$P(PSBFUTR,U,16) PSBACRIT=PSBACRIT_"M"
S:$P(PSBFUTR,U,17) PSBACRIT=PSBACRIT_"H"
S:$P(PSBFUTR,U,18) PSBACRIT=PSBACRIT_"R"
D NOW^%DTC S (Y,PSBXNOW)=% D DD^%DT S:PSBDTSP=0 PSBDTSP=Y S PSBDTTM=Y
I +PSBDTST=0 S PSBDTST=X S PSBDTST=$$FMADD^XLFDT(PSBDTST,-3)_".0000"
S (PSBPGNUM,PSBLNTOT,PSBTOT,PSB1)=""
K PSBLIST,PSBLIST2,PSBBGS,PSBNOX
S PSBXDFN=$P(PSBRPT(.1),U,2)
S PSBLIST(PSBXDFN)=""
S PSB1=$O(PSBLIST("")) I +PSB1'=0 K ^TMP("PSJ",$J) D EN^PSJBCMA(PSB1,PSBDTST,PSBDTST)
I ^TMP("PSJ",$J,1,0)'=-1 D
.S PINX=0 F S PINX=$O(^TMP("PSJ",$J,PINX)) Q:+PINX'>0 D
..S PSB2=$P(^TMP("PSJ",$J,PINX,0),U,3)
..I PSB2["V" D Q
...; flter critri
...D CLEAN^PSBVT,PSJ1^PSBVT(PSB1,PSB2)
...Q:$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,$G(PSBIVPSH,0))
...Q:PSBOST>PSBDTSP
...I "DE"'[PSBOSTS I PSBOSP'>PSBXNOW S PSBOSTS="E"
...Q:PSBOCRIT'[PSBOSTS ;incl ord stat crit
...Q:(PSBOSP<PSBXNOW)&(PSBOCRIT'["E")&(PSBOSTS'="D")
...S PSBLIST2(PSB2,"OStart")=PSBOST
...S PSBLIST2(PSB2,"OStop")=PSBOSP
...S PSBLIST2(PSB2,"OStatus")=$S((PSBOSTS="D"):"Discontinued",(PSBOSTS="DE"):"Discontinued (Edit)",PSBXNOW>PSBOSP:"Expired",PSBOSTS="A":"Active",PSBOSTS="H":"On Hold",1:PSBOSTS)
...; *68
...K ^TMP("PSJBCMA5",$J)
...I PSBSIFLG D GETSIOPI^PSJBCMA5(PSB1,PSB2,1)
...F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,PSB1,PSB2,QQ)) Q:'QQ D
....S PSBSI(PSB2,QQ)=^TMP("PSJBCMA5",$J,PSB1,PSB2,QQ)
...; *68 end
...M PSBLIST2(PSB2,"ADD")=PSBADA
...M PSBLIST2(PSB2,"SOL")=PSBSOLA
...;*106 adds the hazardous handle/dispose notices-bg
...I PSBHAZHN!PSBHAZDS S PSBLIST2(PSB2,"HAZ")=$S(PSBHAZHN:"<<HAZ Handle>> ",1:"")_$S(PSBHAZDS:"<<HAZ Dispose>>",1:"") ;*106 new array item HAZ
...D EN^PSBPOIV(PSB1,PSB2)
...I +$O(^TMP("PSBAR",$J,""))>0 S X="" F S X=$O(^TMP("PSBAR",$J,X)) Q:+X=0 S PSBBGS(PSB2,X)=$P(^TMP("PSBAR",$J,X),U,2)
...D:PSBACRIT["N"
....S NO=1
....I $D(PSBBGS(PSB2)) S X="" F S X=$O(PSBBGS(PSB2,X)) Q:+X=0 I PSBBGS(PSB2,X)'="" S NO=0 Q
....I $D(^PSB(53.79,"AORDX",PSB1,PSB2)) S NO=0 Q
...I $G(NO,0) I PSBOSTS="A" S PSBNOX(PSB2)="",PSBTOT=PSBTOT+1 Q
...I $D(^PSB(53.79,"AUID",PSB1,PSB2)) M PSBBGS(PSB2)=^PSB(53.79,"AUID",PSB1,PSB2)
...; Get X - "ASSOC BAGS"
...S X="" F S X=$O(PSBBGS(PSB2,X)) Q:+X=0 I $G(PSBBGS(PSB2,X),"")'="" D
....S Y="" F S Y=$O(^PSB(53.79,"AUID",PSB1,Y)) Q:Y="" D Q:Y="DONE"
.....I $D(^PSB(53.79,"AUID",PSB1,Y,X)) S PSBBGS(PSB2,X,$O(^PSB(53.79,"AUID",PSB1,Y,X,"")))="" S Y="DONE"
...S X="" F S X=$O(PSBBGS(PSB2,X)) Q:+X=0 I $O(PSBBGS(PSB2,X,""))="" K PSBBGS(PSB2,X)
...S PSB3="" F S PSB3=$O(PSBBGS(PSB2,PSB3)) Q:PSB3="" D
....S PSB4="" F S PSB4=$O(PSBBGS(PSB2,PSB3,PSB4)) Q:+PSB4=0 D
.....I ($$GET1^DIQ(53.79,PSB4_",",.06,"I")'>PSBDTST)!($$GET1^DIQ(53.79,PSB4_",",.06,"I")'<PSBDTSP) K PSBBGS(PSB2,PSB3) Q
.....I PSBACRIT'[$$GET1^DIQ(53.79,PSB4_",",.09,"I") K PSBBGS(PSB2,PSB3) Q
.....S PSBBSTS(PSB2,PSB3,$$GET1^DIQ(53.79,PSB4_",",.09))=$$GET1^DIQ(53.79,PSB4_",",.06,"I"),PSBTOT=PSBTOT+1
.....I "SI"[$$GET1^DIQ(53.79,PSB4_",",.09,"I") I PSBXNOW>$$FMADD^XLFDT($$GET1^DIQ(53.79,PSB4_",",.06,"I"),,24) S PSB24HR(PSB2,PSB3)=""
.....I PSBCFLG S PSB5=0 F S PSB5=$O(^PSB(53.79,PSB4,.3,PSB5)) Q:+PSB5=0 D
......I $P(^PSB(53.79,PSB4,.3,PSB5,0),U,3)=$$GET1^DIQ(53.79,PSB4_",",.06,"I") S PSBCMNT(PSB2,PSB3)="Comment: "_$P(^PSB(53.79,PSB4,.3,PSB5,0),U)
S INX="" F S INX=$O(PSBLIST2(INX)) Q:INX="" I '$D(PSBBGS(INX))&'$D(PSBNOX(INX)) K PSBLIST2(INX)
I +PSBTOT=0 K PSBLIST
S Y=PSBDTST D DD^%DT S Y1=Y S Y=PSBDTSP D DD^%DT S Y2=Y
D CREATHDR
D SUBHDR^PSBOIV1
D BLDRPT
D WRTRPT
K PSBSILN,PSBOUTP,PSBLIST2,PSBCMNT,PSBNOX
D CLEAN^PSBVT ;*106
Q
BLDRPT ; Buld Reprt
S (PSB2,PSB3,PSB4)=""
S PSBTOPHD=PSBLNTOT
I '$D(PSBLIST2) D Q
.S PSBOUTP(0,14)="W !!,""<<<< NO DATA TO DISPLAY >>>>"",!!"
S PSBTOT1=0
K PSBDATA
K J S J=1 F S PSB2=$O(PSBLIST2(PSB2)) Q:+PSB2=0 D
.S PSBORDX="" S PSBORDX=PSB2
.S PSBDATA(1)=$$FMTDT^PSBOIV1($E(PSBLIST2(PSB2,"OStart"),1,12))
.S PSBDATA(2)=$$FMTDT^PSBOIV1($E(PSBLIST2(PSB2,"OStop"),1,12))
.S PSBDATA(3)=PSBLIST2(PSB2,"OStatus")
.M PSBDATA(4,"ADD")=PSBLIST2(PSB2,"ADD") I $D(PSBDATA(4,"ADD",1)) S PSBDATA(4)="MED"
.M PSBDATA(4,"SOL")=PSBLIST2(PSB2,"SOL") I $D(PSBDATA(4,"SOL",1)) S PSBDATA(4)="MED"
.; Bag(s)
.I $D(PSBNOX(PSB2)) S PSBFLGD(PSB2," * No Action Taken On Order * ")=""
.I '$D(PSBNOX(PSB2))!(PSBACRIT["N") F S PSB3=$O(PSBBGS(PSB2,PSB3)) Q:+PSB3=0 D
..S PSBDATA(5,PSB3)=PSB3
..S PSBDATA(6,PSB3)=$O(PSBBSTS(PSB2,PSB3,""))
..I $D(PSB24HR(PSB2,PSB3)) S PSBDATA(7,PSB3)=">24h"
..I '$D(PSBNOX(PSB2)) S PSBDATA(8,PSB3)=$$FMTDT^PSBOIV1($E(PSBBSTS(PSB2,PSB3,PSBDATA(6,PSB3)),1,12))
..E S PSBDATA(8,PSB3)="No Action On Order"
.K PSBOPDAT M PSBOPDAT=PSBSI(PSB2) ;*68
.S PSBTOT1=PSBTOT1+1
.K PSBRPLN,PSBSILN
.D BUILDLN,SIOPI^PSBOCM(.PSBOPDAT,PSBTAB8,"Other Print Info: ")
.I $D(PSBRPLN) S PSBMORE=$O(PSBRPLN(""),-1)+4 I $D(PSBSILN) S PSBMORE=PSBMORE+$O(PSBSILN(""),-1)
.S (PSB1,PSB)="" I $D(PSBFLGD(PSB2)) F S PSB=$O(PSBFLGD(PSB2,PSB)) Q:PSB="" I ($P(PSB,":")'="STAT") S PSB1=$G(PSB1,"")_PSB
.S PSBCNT=PSBTOT1_" ("_PSB2_") "_PSB1,$E(PSBCNT,IOM)="|"
.S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBCNT_""""
.F N=$O(PSBRPLN("")):1:$O(PSBRPLN(""),-1) D
..S PSB1X=0 S PSB1X=(($L(PSBRPLN(N),"""")-1)\2) I ($E(PSBRPLN(N),(PSBTAB8)+PSB1X)']" ") S $E(PSBRPLN(N),(PSBTAB8)+PSB1X)="|"
..S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(N)_""""
.S:$G(PSBLIST2(PSB2,"HAZ"))]"" PSBOUTP($$PGTOT,PSBLNTOT)="W !?"_PSBTAB3_","_"PSBLIST2("""_PSB2_""",""HAZ"")" ;*106
.;
.K PSBRPLN,PSBDATA
.;
.S I="" F S I=$O(PSBSILN(I)) Q:+I=0 D
..S PSB1X=0 S PSB1X=(($L(PSBSILN(I),"""")-1)\2)
..I ($E(PSBSILN(I),(PSBTAB8)+PSB1X)']" ") S $E(PSBSILN(I),(PSBTAB8)+PSB1X)="|"
..S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
.S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
Q
BUILDLN ; Constr recs
K J,LN S J(0)="" F PSBFLD=1:1:3 I $G(PSBDATA(PSBFLD))]"" S J=1 D FORMDAT^PSBOIV1(PSBFLD) S J=1
F X=1:1 Q:'$D(PSBDATA(4,"ADD",X)) D
.S PSBDATA(4)=$P(PSBDATA(4,"ADD",X),U,3)
.D FORMDAT^PSBOIV1(4)
.S J=$O(J(""),-1)+1
F X=1:1 Q:'$D(PSBDATA(4,"SOL",X)) D
.S PSBDATA(4)=$P(PSBDATA(4,"SOL",X),U,3)
.D FORMDAT^PSBOIV1(4)
.S J=$O(J(""),-1)+1
F PSBFLD=5:1:8 I $D(PSBDATA(PSBFLD)) K J S J=1 D
.S X="" F S X=$O(PSBDATA(PSBFLD,X)) Q:+X=0 D
..S PSBDATA(PSBFLD)=PSBDATA(PSBFLD,X)
..I PSBFLD=5 S LN(X,J)=""
..D:PSBFLD'=8 FORMDAT^PSBOIV1(PSBFLD)
..S J=$O(J(""),-1)+1
..I (PSBCFLG&(PSBFLD=5)),($D(PSBCMNT(PSB2,X))) D WRAPPER^PSBOIV1(PSBTAB4+1,(PSBTAB8-PSBTAB4)-1,PSBCMNT(PSB2,X)),WRAPPER^PSBOIV1(PSBTAB4+1,PSBTAB8-PSBTAB4," ")
.I PSBFLD=5 F J=1:1:$O(J(""),-1) S PREVLN(J)=$G(PSBRPLN(J),"")
.I PSBFLD'=5 I $D(PREVLN) S X="" F S X=$O(LN(X)) Q:X="" S J=$O(LN(X,"")) D:$D(PSBDATA(PSBFLD,X))
..S $E(PREVLN(J),@("PSBTAB"_(PSBFLD-1))+1,@("PSBTAB"_(PSBFLD)))=PSBDATA(PSBFLD,X)
I $D(PREVLN) F J=1:1:$O(PREVLN(""),-1) S PSBRPLN(J)=PREVLN(J)
K PREVLN,LN
Q
WRTRPT ;
I $O(PSBOUTP(""),-1)<1 D Q
.X PSBOUTP($O(PSBOUTP(""),-1),14)
.D FTR
S PSBPGNUM=1
S PSBZ="" F S PSBZ=$O(PSBOUTP(PSBZ)) Q:PSBZ="" D
.I PSBPGNUM'=PSBZ D FTR S PSBPGNUM=PSBZ D HDR,SUBHDR^PSBOIV1
.S PSB2="" F S PSB2=$O(PSBOUTP(PSBZ,PSB2)) Q:PSB2="" D
..X PSBOUTP(PSBZ,PSB2)
D FTR
Q
HDR ;
W:$Y>1 @IOF
W:$X>1 !
S PSBRPNM="BCMA IV BAG STATUS REPORT"
S LN=0
D:$P(PSBRPT(.1),U,1)="P"
.S LN=LN+1,PSBHDR(LN)=PSBRPNM_" for "_$$FMTE^XLFDT($P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7))_" to "_$$FMTE^XLFDT($P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9))
.S LN=LN+1,PSBHDR(LN)="Order Status(es): --"
.F Y=5,7,8 I $P(PSBFUTR,U,Y) S $P(PSBHDR(LN),": ",2)=$P(PSBHDR(LN),": ",2)_$S(PSBHDR(2)["--":"",1:"/ ")_$P("^^^^Active^^DC'd^Expired^^^^^^^^^^",U,Y)_" " S PSBHDR(LN)=$TR(PSBHDR(LN),"-","")
.S LN=LN+1,PSBHDR(LN)="Bag Status(es): --"
.F Y=12:1:18 I $P(PSBFUTR,U,Y) S $P(PSBHDR(LN),": ",2)=$P(PSBHDR(LN),": ",2)_$S(PSBHDR(LN)["--":"",1:"/ ")_$P("^^^^^^^^^^^Infusing^Stopped^Completed^No Action Taken^Missing Dose^Held^Refused",U,Y)_" " S PSBHDR(LN)=$TR(PSBHDR(LN),"-","")
.I PSBCFLG S LN=LN+1,PSBHDR(LN)="Include Comments/Reasons"
.N PSBCLINORD S PSBCLINORD=2 ;set psbclinord to both ord type *70
.D PT^PSBOHDR(PSBXDFN,.PSBHDR) W !
Q
FTR ;
I (IOSL<100) F Q:$Y>(IOSL-5) W !,?(IOM-1),"|"
S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
S PSBPGRM=PSBTAB8-($L(PSBPG))
D PTFTR^PSBOHDR()
W !,PSBRPNM," ",?(PSBPGRM-($L(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
Q
PGTOT(X) ;mnt PAGE Number
I (PSBLNTOT+PSBMORE)>(IOSL) S PSBPGNUM=PSBPGNUM+1,PSBLNTOT=PSBTOPHD S PSBMORE=$S(PSBMORE>(IOSL-(PSBTOPHD)):(IOSL-(PSBTOPHD)),1:PSBMORE)
I $G(X,1) S PSBLNTOT=PSBLNTOT+$G(X,1),PSBMORE=PSBMORE-$G(X,1)
Q PSBPGNUM
CREATHDR ;
K PSBHD1,PSBHD2
I IOM'<132 S PSBMORE=4,PSBHD1=$P($T(HD132A),";",2),PSBHD2=$P($T(HD132B),";",2),PSBBLANK=$P($T(H132BLK),";",2)
E S PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY" K PSBLIST2 Q
; reset tabs
S PSBTAB0=1 F PSBI=0:1:($L(PSBHD1,"|")-1) S:PSBI>0 @("PSBTAB"_PSBI)=($F(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
S PSBPGNUM=1
D HDR
Q
HD132A ; Order | Order | Order | Medication | Bag UID | Bag | | Action Date/Time |
Q
HD132B ; Start Date | Stop Date | Status | | | Status | | |
Q
H132BLK ;;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOIV 10803 printed Oct 16, 2024@17:41:27 Page 2
PSBOIV ;BIRMINGHAM/TEJ-IV BAG STATUS REPORT ;2/6/21 16:54
+1 ;;3.0;BAR CODE MED ADMIN;**32,68,70,106**;Mar 2004;Build 43
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; File 52.6/436
+6 ; File 52.7/437
+7 ; File 4/10090
+8 ; File 2/10035
+9 ; GETSIOPI^PSJBCMA5/5763
+10 ;
+11 ;*68 - change to accomodate unlimited lines for SIOPI array
+12 ;*70 - reset PSBCLINORD = 2 to signify combined orders report
+13 ;*106- add Hazardous Handle & Dispose flags
+14 ;
EN ; Entry
+1 ;*70 add psbhdr
NEW PSB1,PSBFUTR,PSBSI,QQ,PSBHDR
+2 KILL PSBSRTBY,PSBOCRIT,PSBACRIT,NO
SET PSBCFLG=0
+3 SET PSBFUTR=$TRANSLATE(PSBRPT(1),"~","^")
+4 IF $DATA(PSBRPT(.2))
IF $PIECE(PSBRPT(.2),U,8)
SET PSBCFLG=1
+5 SET PSBDTST=+$PIECE(PSBRPT(.1),U,6)+$PIECE(PSBRPT(.1),U,7)
+6 SET PSBDTSP=+$PIECE(PSBRPT(.1),U,8)+$PIECE(PSBRPT(.1),U,9)
+7 ; Ord Sttus "A"ctive, "D"C ed, "E"xprd"
SET PSBOCRIT=""
+8 if $PIECE(PSBFUTR,U,5)
SET PSBOCRIT=PSBOCRIT_"A"
+9 if $PIECE(PSBFUTR,U,7)
SET PSBOCRIT=PSBOCRIT_"D"
+10 if $PIECE(PSBFUTR,U,8)
SET PSBOCRIT=PSBOCRIT_"E"
+11 ; Actn Sttus "C"ompl, "I"nfusi, "M"issng, "S"tpped, "H"ld, "R"efsd", "N"o Actn
SET PSBACRIT=""
+12 if $PIECE(PSBFUTR,U,12)
SET PSBACRIT=PSBACRIT_"I"
+13 if $PIECE(PSBFUTR,U,13)
SET PSBACRIT=PSBACRIT_"S"
+14 if $PIECE(PSBFUTR,U,14)
SET PSBACRIT=PSBACRIT_"C"
+15 if $PIECE(PSBFUTR,U,15)
SET PSBACRIT=PSBACRIT_"N"
+16 if $PIECE(PSBFUTR,U,16)
SET PSBACRIT=PSBACRIT_"M"
+17 if $PIECE(PSBFUTR,U,17)
SET PSBACRIT=PSBACRIT_"H"
+18 if $PIECE(PSBFUTR,U,18)
SET PSBACRIT=PSBACRIT_"R"
+19 DO NOW^%DTC
SET (Y,PSBXNOW)=%
DO DD^%DT
if PSBDTSP=0
SET PSBDTSP=Y
SET PSBDTTM=Y
+20 IF +PSBDTST=0
SET PSBDTST=X
SET PSBDTST=$$FMADD^XLFDT(PSBDTST,-3)_".0000"
+21 SET (PSBPGNUM,PSBLNTOT,PSBTOT,PSB1)=""
+22 KILL PSBLIST,PSBLIST2,PSBBGS,PSBNOX
+23 SET PSBXDFN=$PIECE(PSBRPT(.1),U,2)
+24 SET PSBLIST(PSBXDFN)=""
+25 SET PSB1=$ORDER(PSBLIST(""))
IF +PSB1'=0
KILL ^TMP("PSJ",$JOB)
DO EN^PSJBCMA(PSB1,PSBDTST,PSBDTST)
+26 IF ^TMP("PSJ",$JOB,1,0)'=-1
Begin DoDot:1
+27 SET PINX=0
FOR
SET PINX=$ORDER(^TMP("PSJ",$JOB,PINX))
if +PINX'>0
QUIT
Begin DoDot:2
+28 SET PSB2=$PIECE(^TMP("PSJ",$JOB,PINX,0),U,3)
+29 IF PSB2["V"
Begin DoDot:3
+30 ; flter critri
+31 DO CLEAN^PSBVT
DO PSJ1^PSBVT(PSB1,PSB2)
+32 if $$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,$GET(PSBIVPSH,0))
QUIT
+33 if PSBOST>PSBDTSP
QUIT
+34 IF "DE"'[PSBOSTS
IF PSBOSP'>PSBXNOW
SET PSBOSTS="E"
+35 ;incl ord stat crit
if PSBOCRIT'[PSBOSTS
QUIT
+36 if (PSBOSP<PSBXNOW)&(PSBOCRIT'["E")&(PSBOSTS'="D")
QUIT
+37 SET PSBLIST2(PSB2,"OStart")=PSBOST
+38 SET PSBLIST2(PSB2,"OStop")=PSBOSP
+39 SET PSBLIST2(PSB2,"OStatus")=$SELECT((PSBOSTS="D"):"Discontinued",(PSBOSTS="DE"):"Discontinued (Edit)",PSBXNOW>PSBOSP:"Expired",PSBOSTS="A":"Active",PSBOSTS="H":"On Hold",1:PSBOSTS)
+40 ; *68
+41 KILL ^TMP("PSJBCMA5",$JOB)
+42 IF PSBSIFLG
DO GETSIOPI^PSJBCMA5(PSB1,PSB2,1)
+43 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,PSB1,PSB2,QQ))
if 'QQ
QUIT
Begin DoDot:4
+44 SET PSBSI(PSB2,QQ)=^TMP("PSJBCMA5",$JOB,PSB1,PSB2,QQ)
End DoDot:4
+45 ; *68 end
+46 MERGE PSBLIST2(PSB2,"ADD")=PSBADA
+47 MERGE PSBLIST2(PSB2,"SOL")=PSBSOLA
+48 ;*106 adds the hazardous handle/dispose notices-bg
+49 ;*106 new array item HAZ
IF PSBHAZHN!PSBHAZDS
SET PSBLIST2(PSB2,"HAZ")=$SELECT(PSBHAZHN:"<<HAZ Handle>> ",1:"")_$SELECT(PSBHAZDS:"<<HAZ Dispose>>",1:"")
+50 DO EN^PSBPOIV(PSB1,PSB2)
+51 IF +$ORDER(^TMP("PSBAR",$JOB,""))>0
SET X=""
FOR
SET X=$ORDER(^TMP("PSBAR",$JOB,X))
if +X=0
QUIT
SET PSBBGS(PSB2,X)=$PIECE(^TMP("PSBAR",$JOB,X),U,2)
+52 if PSBACRIT["N"
Begin DoDot:4
+53 SET NO=1
+54 IF $DATA(PSBBGS(PSB2))
SET X=""
FOR
SET X=$ORDER(PSBBGS(PSB2,X))
if +X=0
QUIT
IF PSBBGS(PSB2,X)'=""
SET NO=0
QUIT
+55 IF $DATA(^PSB(53.79,"AORDX",PSB1,PSB2))
SET NO=0
QUIT
End DoDot:4
+56 IF $GET(NO,0)
IF PSBOSTS="A"
SET PSBNOX(PSB2)=""
SET PSBTOT=PSBTOT+1
QUIT
+57 IF $DATA(^PSB(53.79,"AUID",PSB1,PSB2))
MERGE PSBBGS(PSB2)=^PSB(53.79,"AUID",PSB1,PSB2)
+58 ; Get X - "ASSOC BAGS"
+59 SET X=""
FOR
SET X=$ORDER(PSBBGS(PSB2,X))
if +X=0
QUIT
IF $GET(PSBBGS(PSB2,X),"")'=""
Begin DoDot:4
+60 SET Y=""
FOR
SET Y=$ORDER(^PSB(53.79,"AUID",PSB1,Y))
if Y=""
QUIT
Begin DoDot:5
+61 IF $DATA(^PSB(53.79,"AUID",PSB1,Y,X))
SET PSBBGS(PSB2,X,$ORDER(^PSB(53.79,"AUID",PSB1,Y,X,"")))=""
SET Y="DONE"
End DoDot:5
if Y="DONE"
QUIT
End DoDot:4
+62 SET X=""
FOR
SET X=$ORDER(PSBBGS(PSB2,X))
if +X=0
QUIT
IF $ORDER(PSBBGS(PSB2,X,""))=""
KILL PSBBGS(PSB2,X)
+63 SET PSB3=""
FOR
SET PSB3=$ORDER(PSBBGS(PSB2,PSB3))
if PSB3=""
QUIT
Begin DoDot:4
+64 SET PSB4=""
FOR
SET PSB4=$ORDER(PSBBGS(PSB2,PSB3,PSB4))
if +PSB4=0
QUIT
Begin DoDot:5
+65 IF ($$GET1^DIQ(53.79,PSB4_",",.06,"I")'>PSBDTST)!($$GET1^DIQ(53.79,PSB4_",",.06,"I")'<PSBDTSP)
KILL PSBBGS(PSB2,PSB3)
QUIT
+66 IF PSBACRIT'[$$GET1^DIQ(53.79,PSB4_",",.09,"I")
KILL PSBBGS(PSB2,PSB3)
QUIT
+67 SET PSBBSTS(PSB2,PSB3,$$GET1^DIQ(53.79,PSB4_",",.09))=$$GET1^DIQ(53.79,PSB4_",",.06,"I")
SET PSBTOT=PSBTOT+1
+68 IF "SI"[$$GET1^DIQ(53.79,PSB4_",",.09,"I")
IF PSBXNOW>$$FMADD^XLFDT($$GET1^DIQ(53.79,PSB4_",",.06,"I"),,24)
SET PSB24HR(PSB2,PSB3)=""
+69 IF PSBCFLG
SET PSB5=0
FOR
SET PSB5=$ORDER(^PSB(53.79,PSB4,.3,PSB5))
if +PSB5=0
QUIT
Begin DoDot:6
+70 IF $PIECE(^PSB(53.79,PSB4,.3,PSB5,0),U,3)=$$GET1^DIQ(53.79,PSB4_",",.06,"I")
SET PSBCMNT(PSB2,PSB3)="Comment: "_$PIECE(^PSB(53.79,PSB4,.3,PSB5,0),U)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+71 SET INX=""
FOR
SET INX=$ORDER(PSBLIST2(INX))
if INX=""
QUIT
IF '$DATA(PSBBGS(INX))&'$DATA(PSBNOX(INX))
KILL PSBLIST2(INX)
+72 IF +PSBTOT=0
KILL PSBLIST
+73 SET Y=PSBDTST
DO DD^%DT
SET Y1=Y
SET Y=PSBDTSP
DO DD^%DT
SET Y2=Y
+74 DO CREATHDR
+75 DO SUBHDR^PSBOIV1
+76 DO BLDRPT
+77 DO WRTRPT
+78 KILL PSBSILN,PSBOUTP,PSBLIST2,PSBCMNT,PSBNOX
+79 ;*106
DO CLEAN^PSBVT
+80 QUIT
BLDRPT ; Buld Reprt
+1 SET (PSB2,PSB3,PSB4)=""
+2 SET PSBTOPHD=PSBLNTOT
+3 IF '$DATA(PSBLIST2)
Begin DoDot:1
+4 SET PSBOUTP(0,14)="W !!,""<<<< NO DATA TO DISPLAY >>>>"",!!"
End DoDot:1
QUIT
+5 SET PSBTOT1=0
+6 KILL PSBDATA
+7 KILL J
SET J=1
FOR
SET PSB2=$ORDER(PSBLIST2(PSB2))
if +PSB2=0
QUIT
Begin DoDot:1
+8 SET PSBORDX=""
SET PSBORDX=PSB2
+9 SET PSBDATA(1)=$$FMTDT^PSBOIV1($EXTRACT(PSBLIST2(PSB2,"OStart"),1,12))
+10 SET PSBDATA(2)=$$FMTDT^PSBOIV1($EXTRACT(PSBLIST2(PSB2,"OStop"),1,12))
+11 SET PSBDATA(3)=PSBLIST2(PSB2,"OStatus")
+12 MERGE PSBDATA(4,"ADD")=PSBLIST2(PSB2,"ADD")
IF $DATA(PSBDATA(4,"ADD",1))
SET PSBDATA(4)="MED"
+13 MERGE PSBDATA(4,"SOL")=PSBLIST2(PSB2,"SOL")
IF $DATA(PSBDATA(4,"SOL",1))
SET PSBDATA(4)="MED"
+14 ; Bag(s)
+15 IF $DATA(PSBNOX(PSB2))
SET PSBFLGD(PSB2," * No Action Taken On Order * ")=""
+16 IF '$DATA(PSBNOX(PSB2))!(PSBACRIT["N")
FOR
SET PSB3=$ORDER(PSBBGS(PSB2,PSB3))
if +PSB3=0
QUIT
Begin DoDot:2
+17 SET PSBDATA(5,PSB3)=PSB3
+18 SET PSBDATA(6,PSB3)=$ORDER(PSBBSTS(PSB2,PSB3,""))
+19 IF $DATA(PSB24HR(PSB2,PSB3))
SET PSBDATA(7,PSB3)=">24h"
+20 IF '$DATA(PSBNOX(PSB2))
SET PSBDATA(8,PSB3)=$$FMTDT^PSBOIV1($EXTRACT(PSBBSTS(PSB2,PSB3,PSBDATA(6,PSB3)),1,12))
+21 IF '$TEST
SET PSBDATA(8,PSB3)="No Action On Order"
End DoDot:2
+22 ;*68
KILL PSBOPDAT
MERGE PSBOPDAT=PSBSI(PSB2)
+23 SET PSBTOT1=PSBTOT1+1
+24 KILL PSBRPLN,PSBSILN
+25 DO BUILDLN
DO SIOPI^PSBOCM(.PSBOPDAT,PSBTAB8,"Other Print Info: ")
+26 IF $DATA(PSBRPLN)
SET PSBMORE=$ORDER(PSBRPLN(""),-1)+4
IF $DATA(PSBSILN)
SET PSBMORE=PSBMORE+$ORDER(PSBSILN(""),-1)
+27 SET (PSB1,PSB)=""
IF $DATA(PSBFLGD(PSB2))
FOR
SET PSB=$ORDER(PSBFLGD(PSB2,PSB))
if PSB=""
QUIT
IF ($PIECE(PSB,":")'="STAT")
SET PSB1=$GET(PSB1,"")_PSB
+28 SET PSBCNT=PSBTOT1_" ("_PSB2_") "_PSB1
SET $EXTRACT(PSBCNT,IOM)="|"
+29 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBCNT_""""
+30 FOR N=$ORDER(PSBRPLN("")):1:$ORDER(PSBRPLN(""),-1)
Begin DoDot:2
+31 SET PSB1X=0
SET PSB1X=(($LENGTH(PSBRPLN(N),"""")-1)\2)
IF ($EXTRACT(PSBRPLN(N),(PSBTAB8)+PSB1X)']" ")
SET $EXTRACT(PSBRPLN(N),(PSBTAB8)+PSB1X)="|"
+32 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(N)_""""
End DoDot:2
+33 ;*106
if $GET(PSBLIST2(PSB2,"HAZ"))]""
SET PSBOUTP($$PGTOT,PSBLNTOT)="W !?"_PSBTAB3_","_"PSBLIST2("""_PSB2_""",""HAZ"")"
+34 ;
+35 KILL PSBRPLN,PSBDATA
+36 ;
+37 SET I=""
FOR
SET I=$ORDER(PSBSILN(I))
if +I=0
QUIT
Begin DoDot:2
+38 SET PSB1X=0
SET PSB1X=(($LENGTH(PSBSILN(I),"""")-1)\2)
+39 IF ($EXTRACT(PSBSILN(I),(PSBTAB8)+PSB1X)']" ")
SET $EXTRACT(PSBSILN(I),(PSBTAB8)+PSB1X)="|"
+40 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
End DoDot:2
+41 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
End DoDot:1
+42 QUIT
BUILDLN ; Constr recs
+1 KILL J,LN
SET J(0)=""
FOR PSBFLD=1:1:3
IF $GET(PSBDATA(PSBFLD))]""
SET J=1
DO FORMDAT^PSBOIV1(PSBFLD)
SET J=1
+2 FOR X=1:1
if '$DATA(PSBDATA(4,"ADD",X))
QUIT
Begin DoDot:1
+3 SET PSBDATA(4)=$PIECE(PSBDATA(4,"ADD",X),U,3)
+4 DO FORMDAT^PSBOIV1(4)
+5 SET J=$ORDER(J(""),-1)+1
End DoDot:1
+6 FOR X=1:1
if '$DATA(PSBDATA(4,"SOL",X))
QUIT
Begin DoDot:1
+7 SET PSBDATA(4)=$PIECE(PSBDATA(4,"SOL",X),U,3)
+8 DO FORMDAT^PSBOIV1(4)
+9 SET J=$ORDER(J(""),-1)+1
End DoDot:1
+10 FOR PSBFLD=5:1:8
IF $DATA(PSBDATA(PSBFLD))
KILL J
SET J=1
Begin DoDot:1
+11 SET X=""
FOR
SET X=$ORDER(PSBDATA(PSBFLD,X))
if +X=0
QUIT
Begin DoDot:2
+12 SET PSBDATA(PSBFLD)=PSBDATA(PSBFLD,X)
+13 IF PSBFLD=5
SET LN(X,J)=""
+14 if PSBFLD'=8
DO FORMDAT^PSBOIV1(PSBFLD)
+15 SET J=$ORDER(J(""),-1)+1
+16 IF (PSBCFLG&(PSBFLD=5))
IF ($DATA(PSBCMNT(PSB2,X)))
DO WRAPPER^PSBOIV1(PSBTAB4+1,(PSBTAB8-PSBTAB4)-1,PSBCMNT(PSB2,X))
DO WRAPPER^PSBOIV1(PSBTAB4+1,PSBTAB8-PSBTAB4," ")
End DoDot:2
+17 IF PSBFLD=5
FOR J=1:1:$ORDER(J(""),-1)
SET PREVLN(J)=$GET(PSBRPLN(J),"")
+18 IF PSBFLD'=5
IF $DATA(PREVLN)
SET X=""
FOR
SET X=$ORDER(LN(X))
if X=""
QUIT
SET J=$ORDER(LN(X,""))
if $DATA(PSBDATA(PSBFLD,X))
Begin DoDot:2
+19 SET $EXTRACT(PREVLN(J),@("PSBTAB"_(PSBFLD-1))+1,@("PSBTAB"_(PSBFLD)))=PSBDATA(PSBFLD,X)
End DoDot:2
End DoDot:1
+20 IF $DATA(PREVLN)
FOR J=1:1:$ORDER(PREVLN(""),-1)
SET PSBRPLN(J)=PREVLN(J)
+21 KILL PREVLN,LN
+22 QUIT
WRTRPT ;
+1 IF $ORDER(PSBOUTP(""),-1)<1
Begin DoDot:1
+2 XECUTE PSBOUTP($ORDER(PSBOUTP(""),-1),14)
+3 DO FTR
End DoDot:1
QUIT
+4 SET PSBPGNUM=1
+5 SET PSBZ=""
FOR
SET PSBZ=$ORDER(PSBOUTP(PSBZ))
if PSBZ=""
QUIT
Begin DoDot:1
+6 IF PSBPGNUM'=PSBZ
DO FTR
SET PSBPGNUM=PSBZ
DO HDR
DO SUBHDR^PSBOIV1
+7 SET PSB2=""
FOR
SET PSB2=$ORDER(PSBOUTP(PSBZ,PSB2))
if PSB2=""
QUIT
Begin DoDot:2
+8 XECUTE PSBOUTP(PSBZ,PSB2)
End DoDot:2
End DoDot:1
+9 DO FTR
+10 QUIT
HDR ;
+1 if $Y>1
WRITE @IOF
+2 if $X>1
WRITE !
+3 SET PSBRPNM="BCMA IV BAG STATUS REPORT"
+4 SET LN=0
+5 if $PIECE(PSBRPT(.1),U,1)="P"
Begin DoDot:1
+6 SET LN=LN+1
SET PSBHDR(LN)=PSBRPNM_" for "_$$FMTE^XLFDT($PIECE(PSBRPT(.1),U,6)+$PIECE(PSBRPT(.1),U,7))_" to "_$$FMTE^XLFDT($PIECE(PSBRPT(.1),U,8)+$PIECE(PSBRPT(.1),U,9))
+7 SET LN=LN+1
SET PSBHDR(LN)="Order Status(es): --"
+8 FOR Y=5,7,8
IF $PIECE(PSBFUTR,U,Y)
SET $PIECE(PSBHDR(LN),": ",2)=$PIECE(PSBHDR(LN),": ",2)_$SELECT(PSBHDR(2)["--":"",1:"/ ")_$PIECE("^^^^Active^^DC'd^Expired^^^^^^^^^^",U,Y)_" "
SET PSBHDR(LN)=$TRANSLATE(PSBHDR(LN),"-","")
+9 SET LN=LN+1
SET PSBHDR(LN)="Bag Status(es): --"
+10 FOR Y=12:1:18
IF $PIECE(PSBFUTR,U,Y)
SET $PIECE(PSBHDR(LN),": ",2)=$PIECE(PSBHDR(LN),": ",2)_$SELECT(PSBHDR(LN)["--":"",1:"/ ")_$PIECE("^^^^^^^^^^^Infusing^Stopped^Completed^No Action Taken^Missing Dose^Held^Refused",U,Y)_" "
SET PSBHDR(LN)=$TRANSLATE(PSBHDR(LN),"-","")
+11 IF PSBCFLG
SET LN=LN+1
SET PSBHDR(LN)="Include Comments/Reasons"
+12 ;set psbclinord to both ord type *70
NEW PSBCLINORD
SET PSBCLINORD=2
+13 DO PT^PSBOHDR(PSBXDFN,.PSBHDR)
WRITE !
End DoDot:1
+14 QUIT
FTR ;
+1 IF (IOSL<100)
FOR
if $Y>(IOSL-5)
QUIT
WRITE !,?(IOM-1),"|"
+2 SET PSBPG="Page: "_PSBPGNUM_" of "_$SELECT($ORDER(PSBOUTP(""),-1)=0:1,1:$ORDER(PSBOUTP(""),-1))
+3 SET PSBPGRM=PSBTAB8-($LENGTH(PSBPG))
+4 DO PTFTR^PSBOHDR()
+5 WRITE !,PSBRPNM," ",?(PSBPGRM-($LENGTH(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
+6 QUIT
PGTOT(X) ;mnt PAGE Number
+1 IF (PSBLNTOT+PSBMORE)>(IOSL)
SET PSBPGNUM=PSBPGNUM+1
SET PSBLNTOT=PSBTOPHD
SET PSBMORE=$SELECT(PSBMORE>(IOSL-(PSBTOPHD)):(IOSL-(PSBTOPHD)),1:PSBMORE)
+2 IF $GET(X,1)
SET PSBLNTOT=PSBLNTOT+$GET(X,1)
SET PSBMORE=PSBMORE-$GET(X,1)
+3 QUIT PSBPGNUM
CREATHDR ;
+1 KILL PSBHD1,PSBHD2
+2 IF IOM'<132
SET PSBMORE=4
SET PSBHD1=$PIECE($TEXT(HD132A),";",2)
SET PSBHD2=$PIECE($TEXT(HD132B),";",2)
SET PSBBLANK=$PIECE($TEXT(H132BLK),";",2)
+3 IF '$TEST
SET PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY"
KILL PSBLIST2
QUIT
+4 ; reset tabs
+5 SET PSBTAB0=1
FOR PSBI=0:1:($LENGTH(PSBHD1,"|")-1)
if PSBI>0
SET @("PSBTAB"_PSBI)=($FIND(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
+6 SET PSBPGNUM=1
+7 DO HDR
+8 QUIT
HD132A ; Order | Order | Order | Medication | Bag UID | Bag | | Action Date/Time |
+1 QUIT
HD132B ; Start Date | Stop Date | Status | | | Status | | |
+1 QUIT
H132BLK ;;
+1 QUIT
