PSBOCI ;BIRMINGHAM/TEJ-COVERSHEET IV OVERVIEW REPORT ;9/18/12 2:02am
;;3.0;BAR CODE MED ADMIN;**32,62,68,70**;Mar 2004;Build 101
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; File 4/10090
; GETSIOPI^PSJBCMA5/5763
;
;*68 - allow SIOPI builder to accomodate more than 1 line in SI array
;*70 - pass global var PSBCLINORD when Rpc Psbcsutl is called again.
; - add clinic name to new array PSBCLIN to track clinic name per
; order for printed output.
;
EN ;
N PSBX1X,RESULTS,RESULT,PSBFUTR,QQ,PSBCLIN,PSBSRCHL,PSBHDR
S PSBFUTR=$TR(PSBRPT(1),"~","^")
S (PSBOCRIT,PSBXFLG,PSBCFLG,PSBBGX)="" ; srch crit - "A"ctive,"D"C ed,"E"xpired"
S PSBOCRIT="DEA"
S:$P(PSBFUTR,U,11) PSBXFLG=1
S:$P(PSBFUTR,U,12) PSBBGX=PSBBGX_"I"
S:$P(PSBFUTR,U,13) PSBBGX=PSBBGX_"S"
S:$P(PSBFUTR,U,14) PSBBGX=PSBBGX_"A"
I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
;check Clinic search list *70
S PSBSRCHL=$$SRCHLIST^PSBOHDR()
D:$P(PSBRPT(4),U,2)="C"
.S:PSBSRCHL="" PSBSRCHL="All Clinics"
.S PSBSRCHL="Clinic Search List: "_PSBSRCHL
;
K PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD
S PSBSORT=1
D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=Y
D GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
S PSBB4=0 S:RESULTS(0)>0 PSBB4=+RESULTS(0)
D GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
S PSBAFT=0 S:RESULTS(0)>0 PSBAFT=+RESULTS(0)
K ^XTMP("PSBO",$J,"PSBLIST")
S (PSBPGNUM,PSBLNTOT)=""
K PSBLIST,PSBLIST2
S PSBXDFN=$P(PSBRPT(.1),U,2)
S PSBLIST(PSBXDFN)=""
S (PSBX1X,PSBTOT)=0
S PSBCLINORD=$S($P($G(PSBRPT(4)),U,2)="C":1,1:0) ;*70
F S PSBX1X=$O(PSBLIST(PSBX1X)) Q:+PSBX1X=0 D
.D RPC^PSBCSUTL(.PSBAREA,PSBX1X,,,PSBCLINORD) ;*70
.M PSBDATA=@PSBAREA
.S PSBX2X=1
.S (PSBLIST2("All Other"),PSBLIST2("Infusing"),PSBLIST2("Stopped"),PSBLIST2(" * NO * "))=0
.K PSBBSO
.F S PSBX2X=$O(PSBDATA(PSBX2X)) Q:+PSBX2X=0 D
..S PSBDATA=PSBDATA(PSBX2X)
..I $P(PSBDATA,U)="ORD" K PSBORDN,PSBDRUGN D Q
...S PSBEND=0
...S PSBTB=$P(PSBDATA,U,29) S PSBTB=$S(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
...I (PSBTB'="IV") F PSBX2X=PSBX2X:1 D Q:PSBEND>0
....S PSBEND=0 I $P(PSBDATA(PSBX2X),U)="END" S PSBEND=PSBX2X
...Q:PSBEND>0
...S PSBSTS1=$P(PSBDATA,U,23)
...S PSBSTS=$S((PSBSTS1="A")&(($P(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS1="H":"On Hold",PSBSTS1="D":"Discontinued",PSBSTS1="DE":"Discontinued (Edit)",(PSBSTS1="E")!($P(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ERROR * ")
...S V=$$FMADD^XLFDT(PSBNOWX,,,PSBB4)
...S PSBSTSX=$S($P(PSBDATA,U,27)'>PSBNOWX:"EXPIRED/DC'd",$P(PSBDATA,U,22)'>V:"ACTIVE",V:"FUTURE",1:" * ERROR * ")
...I PSBSTSX=" * ERROR * " F PSBX2X=PSBX2X:1 D Q:PSBEND>0
....S PSBEND=0 I $P(PSBDATA(PSBX2X),U)="END" S PSBEND=PSBX2X
...Q:PSBEND>0
...S PSBORDN=$P(PSBDATA,U,3)
...S PSBCLIN(PSBORDN)=$S($P(PSBDATA,U,32)]"":"Location: ",1:"")_$P(PSBDATA,U,32) ;*70
...S PSBORITX=$P(PSBDATA,U,9)
...S PSBSTS(PSBORDN,PSBSTS)=""
...S PSBOSTDT=$P(PSBDATA,U,22)
...S PSBOSTDT(PSBORDN,PSBOSTDT)=""
...S PSBOSPDT=$P(PSBDATA,U,27)
...S PSBOSPDT(PSBORDN,PSBOSPDT)=""
...S PSBDOSR=$P(PSBDATA,U,10)_", "_$P(PSBDATA,U,11)
...S PSBDOSR=$TR($E(PSBDOSR,1)," ")_$E(PSBDOSR,2,999)
...S PSBDOSR(PSBORDN,PSBDOSR)=""
...S X2="A",PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")=" "
...S PSBBSO(PSBORDN)="" S:$G(PSBSTSX)="ACTIVE" PSBBSO(PSBORDN)="AVAILABLE"
..Q:'$D(PSBORDN)
..I $P(PSBDATA,U)="ORC" D Q
...; *68
...K ^TMP("PSJBCMA5",$J)
...I PSBSIFLG D GETSIOPI^PSJBCMA5(PSBX1X,PSBORDN,1)
...F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,PSBX1X,PSBORDN,QQ)) Q:'QQ D
....S PSBSI(PSBORDN,QQ)=^TMP("PSJBCMA5",$J,PSBX1X,PSBORDN,QQ)
...; *68 end
..Q:'$D(PSBORDN)
..I "^DD^ADD^SOL"[(U_$P(PSBDATA(PSBX2X),U)) D Q
...F I=PSBX2X:1 S PSBDATA1=PSBDATA(I) D Q:$D(PSBOMDR(PSBORDN))
....I "^DD^ADD^SOL"[(U_$P(PSBDATA1,U)) S PSBX2X=I S PSBDRUGN=$G(PSBDRUGN,"")_$P(PSBDATA1,U,3)_", " Q
....S $E(PSBDRUGN,$L(PSBDRUGN)-1)="" S PSBDRUGN(PSBORDN,$E(PSBDRUGN,1,250))=PSBDRUGN
....S PSBOMDR(PSBORDN,$E((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
..Q:'$D(PSBORDN)
..I $P(PSBDATA,U)="ORF" D Q
...S:$P(PSBDATA,U,2)]"" PSBFLGD(PSBORDN,$P(PSBDATA,U,3)_" - "_$P(PSBDATA,U,4))=""
..Q:'$D(PSBORDN)
..I $P(PSBDATA,U)="ID" D Q
...F PSBX3X=PSBX2X:1 S PSBDATA=PSBDATA(PSBX3X) Q:($P(PSBDATA,U)'="ID") D
....S PSBX2X=PSBX3X
....K X2
....S X2="A",PSBLIST2("All Other",PSBORITX,PSBORDN,$P(PSBDATA,U,2))=PSBBSO(PSBORDN)
....I $D(PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")) K PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")
..Q:'$D(PSBORDN)
..I ($P(PSBDATA,U)="ADM")&($P(PSBDATA,U,4)]"") D Q
...I $P(PSBDATA,U,3)]"" D
....K X2
....S PSBBID(PSBORDN,$P(PSBDATA,U,3))=""
....I $P(^PSB(53.79,$P(PSBDATA,U,4),0),U,9)="I" D
.....S X2="I",PSBLIST2("Infusing")=PSBLIST2("Infusing")+1,PSBLIST2("Infusing",PSBORITX,PSBORDN,$P(PSBDATA,U,3))="INFUSING"
....I $P(^PSB(53.79,$P(PSBDATA,U,4),0),U,9)="S" D
.....S X2="S",PSBLIST2("Stopped")=PSBLIST2("Stopped")+1,PSBLIST2("Stopped",PSBORITX,PSBORDN,$P(PSBDATA,U,3))="STOPPED"
....N PSBORIEN,PSBADIT,PSBCMTIT ;Include initials in the Legend for all entries in the audit log and comment subfile - PSB*3*62
....S PSBORIEN=$P(PSBDATA,U,4)
....S PSBADIT=0 F S PSBADIT=$O(^PSB(53.79,PSBORIEN,.9,PSBADIT)) Q:'PSBADIT I ^PSB(53.79,PSBORIEN,.9,PSBADIT,0)["ACTION STATUS"!(^PSB(53.79,PSBORIEN,.9,PSBADIT,0)["ADMINISTRATION STATUS") D
.....I $P(^PSB(53.79,PSBORIEN,.9,PSBADIT,0),U,5)]"" S PSBLGD(PSBORDN,"INITIALS",$P(^PSB(53.79,PSBORIEN,.9,PSBADIT,0),U,5))=""
....S PSBCMTIT=0 F S PSBCMTIT=$O(^PSB(53.79,PSBORIEN,.3,PSBCMTIT)) Q:'PSBCMTIT D
.....I $P(^PSB(53.79,PSBORIEN,.3,PSBCMTIT,0),U,2)]"" S PSBLGD(PSBORDN,"INITIALS",$P(^PSB(53.79,PSBORIEN,.3,PSBCMTIT,0),U,2))=""
....S:'$D(X2) X2="A",PSBLIST2("All Other",PSBORITX,PSBORDN,$P(PSBDATA,U,3))=$$GET1^DIQ(53.79,$P(PSBDATA,U,4)_",","ACTION STATUS")
....I $D(PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")) K PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")
..Q:'$D(PSBORDN)
..I $P(PSBDATA,U,1)="END" Q
F I="All Other","Infusing","Stopped" S X="",PSBLIST2(I)=0 F S X=$O(PSBLIST2(I,X)) Q:X="" S XI="" F S XI=$O(PSBLIST2(I,X,XI),-1) Q:XI="" D
.S PSBX2X="" F S PSBX2X=$O(PSBLIST2(I,X,XI,PSBX2X),-1) Q:PSBX2X="" S PSBLIST2(I)=PSBLIST2(I)+1 I (PSBBGX[$E(I,1)) S PSBTOT=PSBTOT+1
D CREATHDR
D SUBHDR
D BLDRPT
D WRTRPT
Q
BLDRPT ; Bld RPT
K PSBL2ULN
S PSBTOPHD=PSBLNTOT-2
I '$D(PSBLIST2) D Q
.S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
S PSBMORE=5 F PSBX1X="Infusing","Stopped","All Other" D
.I PSBX1X'=" * ERROR * " S PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_"]" S PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
.Q:PSBLIST2(PSBX1X)=0
.Q:PSBBGX'[$E(PSBX1X,1)
.S:$L(PSBSUM)>$G(PSBL2ULN,0) PSBL2ULN=$L(PSBSUM)
.S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBL2ULN),"" "",""=""),!"
.S PSBOUTP($$PGTOT,PSBLNTOT)="W !"
.K PSBDATA
.S X0="",PSBTOT1=0
.F S X0=$O(PSBLIST2(PSBX1X,X0)) Q:X0="" S PSBX2X="" F S PSBX2X=$O(PSBLIST2(PSBX1X,X0,PSBX2X)) Q:PSBX2X="" S XI="" F S XI=$O(PSBLIST2(PSBX1X,X0,PSBX2X,XI)) Q:XI="" D
..K PSBDATA(1)
..S PSBDATA(1,1)=XI
..S PSBDATA(1,2)=$O(PSBSTS(PSBX2X,""))
..S PSBDATA(1,3)=PSBLIST2(PSBX1X,X0,PSBX2X,XI)
..S Y0=$O(PSBOMDR(PSBX2X,"")) I Y0]"" S PSBDATA(1,4)="("_X0_")",PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
..I "IS"[$E(PSBDATA(1,3),1) S (PSBCHG,PSBDATA(1,5))="",PSBORLST(0)=PSBX2X D RPC^PSBCHKIV(.PSBCHG,PSBXDFN,.PSBORLST)
..I $D(PSBCHG(0)) I PSBCHG(0)>0 I ($P(PSBCHG(1),U)=PSBX2X)!($P(PSBCHG(1),U,5)=PSBX2X) F X2=0:1 Q:PSBCHG(X2)="END" I $P(PSBCHG(X2),U)="CD" S PSBDATA(1,5)="Changed Order" Q
..S PSBDATA(1,6)=$$FMTDT^PSBOCE1($O(PSBOSTDT(PSBX2X,"")))
..S PSBDATA(1,7)=$$FMTDT^PSBOCE1($E($O(PSBOSPDT(PSBX2X,"")),1,12))
..K PSBSIDAT M PSBSIDAT=PSBSI(PSBX2X) ;*68
..S PSBTOT1=PSBTOT1+1
..K PSBDATA(2),PSBSILN
..D BUILDLN^PSBOCI1,SIOPI^PSBOCM(.PSBSIDAT,PSBTAB7,"Other Print Info: ")
..I $D(PSBRPLN) S PSBMORE=$O(PSBRPLN(""),-1)+6 I $D(PSBSILN) S PSBMORE=PSBMORE+$O(PSBSILN(""),-1)
..K PSB1 I $D(PSBFLGD(PSBX2X)) S PSB="" F S PSB=$O(PSBFLGD(PSBX2X,PSB)) Q:PSB="" I ($P(PSB,":")'="NOX")&($P(PSB,":")'="STAT") S PSB1=$G(PSB1,"")_PSB
..;*70 build write clinic stmt
..S PSBOUTP($$PGTOT,PSBLNTOT)="W """_$G(PSBCLIN(PSBX2X))_""""_",!"
..S PSBCNT=PSBTOT1_" "_$G(PSB1,"")
..S PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
..S I="" F S I=$O(PSBRPLN(I)) Q:+I=0 D
...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
..S I="" F S I=$O(PSBSILN(I)) Q:+I=0 D
...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
..S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB7),"" "",""-""),!"
..K PSBRPLN,PSBDATA,PSBSILN
K PSBNO S PSBNO=1 D:+PSBTOT>0 LGD^PSBOCM K PSBNO
Q
WRTRPT ; writ
I $O(PSBOUTP(""),-1)<1 D Q
.X PSBOUTP($O(PSBOUTP(""),-1),14)
.D PTFTR^PSBOCI1
S PSBPGNUM=1
S PSBZ="" F S PSBZ=$O(PSBOUTP(PSBZ)) Q:PSBZ="" D
.I PSBPGNUM'=PSBZ D PTFTR^PSBOCI1 S PSBPGNUM=PSBZ D HDR,SUBHDR
.S PSBX2X="" F S PSBX2X=$O(PSBOUTP(PSBZ,PSBX2X)) Q:PSBX2X="" D
..X PSBOUTP(PSBZ,PSBX2X)
D PTFTR^PSBOCI1
K ^XTMP("PSBO",$J,"PSBLIST"),PSBOUTP
Q
HDR ; Hder
W:$Y>1 @IOF
W:$X>1 !
S PSBRPNM="BCMA COVERSHEET IV OVERVIEW REPORT"
D:$P(PSBRPT(.1),U,1)="P"
.S PSBHDR(0)=PSBRPNM
.S PSBHDR(1)="Order Type(s): --"
.F Y=12,13,18 I $P(PSBFUTR,U,Y) S $P(PSBHDR(1),": ",2)=$P(PSBHDR(1),": ",2)_$S(PSBHDR(1)["--":"",1:"/ ")_$P("^^^^^^^^^^^Infusing Bags^Stopped Bags^^^^^All Others",U,Y)_" " S PSBHDR(1)=$TR(PSBHDR(1),"-","")
.I $P(PSBFUTR,U,11) S PSBHDR(2)="Include Action(s)"_$S(PSBCFLG:" & Comments/Reasons",1:"")
.S:$G(PSBSRCHL)]"" PSBHDR(3)="",PSBHDR(4)=PSBSRCHL ;*70
.D PT^PSBOHDR(PSBXDFN,.PSBHDR)
Q
SUBHDR ;
N PSBAL S PSBAL=$O(PSBHDR("ALERGY",""),-1) S PSBAL=$S((PSBAL/12)>(PSBAL\12):(PSBAL\12)+1,1:(PSBAL\12))
N PSBRE S PSBRE=$O(PSBHDR("REAC",""),-1) S PSBRE=$S((PSBRE/12)>(PSBRE\12):(PSBRE\12)+1,1:(PSBRE\12))
S PSBLNTOT=$O(PSBHDR(""),-1)+9+PSBAL+PSBRE+1
I $G(PSBPGNUM,0)=1 W !,?(PSBTAB7-($L("Total Items reported: "_+PSBTOT))),"Total Items reported: "_+PSBTOT,! S PSBLNTOT=PSBLNTOT+2
W !,$TR($J("",PSBTAB7)," ","_") S PSBLNTOT=PSBLNTOT+1
W !,$G(PSBHD1,"") S PSBLNTOT=PSBLNTOT+1
W !,$G(PSBHD2,"") S PSBLNTOT=PSBLNTOT+1
W !,$TR($J("",PSBTAB7)," ","="),! S PSBLNTOT=PSBLNTOT+2
I $D(NOTE(PSBPGNUM)) W NOTE(PSBPGNUM),!! S PSBLNTOT=PSBLNTOT+2
Q
PGTOT(X) ;PG Nmbr
I (PSBLNTOT+PSBMORE)>(IOSL) D PGC^PSBOCE1
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 PSBHD1=$P($T(HD132A),"~",2),PSBHD2=$P($T(HD132B),";",2),PSBBLANK=$P($T(C132BLK),";",2)
E S PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY" K PSBLIST2 Q
; 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 ;~ Bag ID | Order | Bag | Medication; Infusion Rate, Route | Bag Info | Order Start | Order Stop |
Q
HD132B ; | Status | Status | | | Date | Date |
Q
C132BLK ;; | | | | | | |
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOCI 11456 printed Oct 16, 2024@17:41:16 Page 2
PSBOCI ;BIRMINGHAM/TEJ-COVERSHEET IV OVERVIEW REPORT ;9/18/12 2:02am
+1 ;;3.0;BAR CODE MED ADMIN;**32,62,68,70**;Mar 2004;Build 101
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; File 4/10090
+6 ; GETSIOPI^PSJBCMA5/5763
+7 ;
+8 ;*68 - allow SIOPI builder to accomodate more than 1 line in SI array
+9 ;*70 - pass global var PSBCLINORD when Rpc Psbcsutl is called again.
+10 ; - add clinic name to new array PSBCLIN to track clinic name per
+11 ; order for printed output.
+12 ;
EN ;
+1 NEW PSBX1X,RESULTS,RESULT,PSBFUTR,QQ,PSBCLIN,PSBSRCHL,PSBHDR
+2 SET PSBFUTR=$TRANSLATE(PSBRPT(1),"~","^")
+3 ; srch crit - "A"ctive,"D"C ed,"E"xpired"
SET (PSBOCRIT,PSBXFLG,PSBCFLG,PSBBGX)=""
+4 SET PSBOCRIT="DEA"
+5 if $PIECE(PSBFUTR,U,11)
SET PSBXFLG=1
+6 if $PIECE(PSBFUTR,U,12)
SET PSBBGX=PSBBGX_"I"
+7 if $PIECE(PSBFUTR,U,13)
SET PSBBGX=PSBBGX_"S"
+8 if $PIECE(PSBFUTR,U,14)
SET PSBBGX=PSBBGX_"A"
+9 IF $DATA(PSBRPT(.2))
IF $PIECE(PSBRPT(.2),U,8)
SET PSBCFLG=1
+10 ;check Clinic search list *70
+11 SET PSBSRCHL=$$SRCHLIST^PSBOHDR()
+12 if $PIECE(PSBRPT(4),U,2)="C"
Begin DoDot:1
+13 if PSBSRCHL=""
SET PSBSRCHL="All Clinics"
+14 SET PSBSRCHL="Clinic Search List: "_PSBSRCHL
End DoDot:1
+15 ;
+16 KILL PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD
+17 SET PSBSORT=1
+18 DO NOW^%DTC
SET (Y,PSBNOWX)=%
DO DD^%DT
SET PSBDTTM=Y
+19 DO GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
+20 SET PSBB4=0
if RESULTS(0)>0
SET PSBB4=+RESULTS(0)
+21 DO GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
+22 SET PSBAFT=0
if RESULTS(0)>0
SET PSBAFT=+RESULTS(0)
+23 KILL ^XTMP("PSBO",$JOB,"PSBLIST")
+24 SET (PSBPGNUM,PSBLNTOT)=""
+25 KILL PSBLIST,PSBLIST2
+26 SET PSBXDFN=$PIECE(PSBRPT(.1),U,2)
+27 SET PSBLIST(PSBXDFN)=""
+28 SET (PSBX1X,PSBTOT)=0
+29 ;*70
SET PSBCLINORD=$SELECT($PIECE($GET(PSBRPT(4)),U,2)="C":1,1:0)
+30 FOR
SET PSBX1X=$ORDER(PSBLIST(PSBX1X))
if +PSBX1X=0
QUIT
Begin DoDot:1
+31 ;*70
DO RPC^PSBCSUTL(.PSBAREA,PSBX1X,,,PSBCLINORD)
+32 MERGE PSBDATA=@PSBAREA
+33 SET PSBX2X=1
+34 SET (PSBLIST2("All Other"),PSBLIST2("Infusing"),PSBLIST2("Stopped"),PSBLIST2(" * NO * "))=0
+35 KILL PSBBSO
+36 FOR
SET PSBX2X=$ORDER(PSBDATA(PSBX2X))
if +PSBX2X=0
QUIT
Begin DoDot:2
+37 SET PSBDATA=PSBDATA(PSBX2X)
+38 IF $PIECE(PSBDATA,U)="ORD"
KILL PSBORDN,PSBDRUGN
Begin DoDot:3
+39 SET PSBEND=0
+40 SET PSBTB=$PIECE(PSBDATA,U,29)
SET PSBTB=$SELECT(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
+41 IF (PSBTB'="IV")
FOR PSBX2X=PSBX2X:1
Begin DoDot:4
+42 SET PSBEND=0
IF $PIECE(PSBDATA(PSBX2X),U)="END"
SET PSBEND=PSBX2X
End DoDot:4
if PSBEND>0
QUIT
+43 if PSBEND>0
QUIT
+44 SET PSBSTS1=$PIECE(PSBDATA,U,23)
+45 SET PSBSTS=$SELECT((PSBSTS1="A")&(($PIECE(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS1="H":"On Hold",PSBSTS1="D":"Discontinued",PSBSTS1="DE":"Discontinued (Edit)",(PSBSTS1="E")!($PIECE(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" *
ERROR * ")
+46 SET V=$$FMADD^XLFDT(PSBNOWX,,,PSBB4)
+47 SET PSBSTSX=$SELECT($PIECE(PSBDATA,U,27)'>PSBNOWX:"EXPIRED/DC'd",$PIECE(PSBDATA,U,22)'>V:"ACTIVE",V:"FUTURE",1:" * ERROR * ")
+48 IF PSBSTSX=" * ERROR * "
FOR PSBX2X=PSBX2X:1
Begin DoDot:4
+49 SET PSBEND=0
IF $PIECE(PSBDATA(PSBX2X),U)="END"
SET PSBEND=PSBX2X
End DoDot:4
if PSBEND>0
QUIT
+50 if PSBEND>0
QUIT
+51 SET PSBORDN=$PIECE(PSBDATA,U,3)
+52 ;*70
SET PSBCLIN(PSBORDN)=$SELECT($PIECE(PSBDATA,U,32)]"":"Location: ",1:"")_$PIECE(PSBDATA,U,32)
+53 SET PSBORITX=$PIECE(PSBDATA,U,9)
+54 SET PSBSTS(PSBORDN,PSBSTS)=""
+55 SET PSBOSTDT=$PIECE(PSBDATA,U,22)
+56 SET PSBOSTDT(PSBORDN,PSBOSTDT)=""
+57 SET PSBOSPDT=$PIECE(PSBDATA,U,27)
+58 SET PSBOSPDT(PSBORDN,PSBOSPDT)=""
+59 SET PSBDOSR=$PIECE(PSBDATA,U,10)_", "_$PIECE(PSBDATA,U,11)
+60 SET PSBDOSR=$TRANSLATE($EXTRACT(PSBDOSR,1)," ")_$EXTRACT(PSBDOSR,2,999)
+61 SET PSBDOSR(PSBORDN,PSBDOSR)=""
+62 SET X2="A"
SET PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")=" "
+63 SET PSBBSO(PSBORDN)=""
if $GET(PSBSTSX)="ACTIVE"
SET PSBBSO(PSBORDN)="AVAILABLE"
End DoDot:3
QUIT
+64 if '$DATA(PSBORDN)
QUIT
+65 IF $PIECE(PSBDATA,U)="ORC"
Begin DoDot:3
+66 ; *68
+67 KILL ^TMP("PSJBCMA5",$JOB)
+68 IF PSBSIFLG
DO GETSIOPI^PSJBCMA5(PSBX1X,PSBORDN,1)
+69 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,PSBX1X,PSBORDN,QQ))
if 'QQ
QUIT
Begin DoDot:4
+70 SET PSBSI(PSBORDN,QQ)=^TMP("PSJBCMA5",$JOB,PSBX1X,PSBORDN,QQ)
End DoDot:4
+71 ; *68 end
End DoDot:3
QUIT
+72 if '$DATA(PSBORDN)
QUIT
+73 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA(PSBX2X),U))
Begin DoDot:3
+74 FOR I=PSBX2X:1
SET PSBDATA1=PSBDATA(I)
Begin DoDot:4
+75 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA1,U))
SET PSBX2X=I
SET PSBDRUGN=$GET(PSBDRUGN,"")_$PIECE(PSBDATA1,U,3)_", "
QUIT
+76 SET $EXTRACT(PSBDRUGN,$LENGTH(PSBDRUGN)-1)=""
SET PSBDRUGN(PSBORDN,$EXTRACT(PSBDRUGN,1,250))=PSBDRUGN
+77 SET PSBOMDR(PSBORDN,$EXTRACT((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
End DoDot:4
if $DATA(PSBOMDR(PSBORDN))
QUIT
End DoDot:3
QUIT
+78 if '$DATA(PSBORDN)
QUIT
+79 IF $PIECE(PSBDATA,U)="ORF"
Begin DoDot:3
+80 if $PIECE(PSBDATA,U,2)]""
SET PSBFLGD(PSBORDN,$PIECE(PSBDATA,U,3)_" - "_$PIECE(PSBDATA,U,4))=""
End DoDot:3
QUIT
+81 if '$DATA(PSBORDN)
QUIT
+82 IF $PIECE(PSBDATA,U)="ID"
Begin DoDot:3
+83 FOR PSBX3X=PSBX2X:1
SET PSBDATA=PSBDATA(PSBX3X)
if ($PIECE(PSBDATA,U)'="ID")
QUIT
Begin DoDot:4
+84 SET PSBX2X=PSBX3X
+85 KILL X2
+86 SET X2="A"
SET PSBLIST2("All Other",PSBORITX,PSBORDN,$PIECE(PSBDATA,U,2))=PSBBSO(PSBORDN)
+87 IF $DATA(PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*"))
KILL PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")
End DoDot:4
End DoDot:3
QUIT
+88 if '$DATA(PSBORDN)
QUIT
+89 IF ($PIECE(PSBDATA,U)="ADM")&($PIECE(PSBDATA,U,4)]"")
Begin DoDot:3
+90 IF $PIECE(PSBDATA,U,3)]""
Begin DoDot:4
+91 KILL X2
+92 SET PSBBID(PSBORDN,$PIECE(PSBDATA,U,3))=""
+93 IF $PIECE(^PSB(53.79,$PIECE(PSBDATA,U,4),0),U,9)="I"
Begin DoDot:5
+94 SET X2="I"
SET PSBLIST2("Infusing")=PSBLIST2("Infusing")+1
SET PSBLIST2("Infusing",PSBORITX,PSBORDN,$PIECE(PSBDATA,U,3))="INFUSING"
End DoDot:5
+95 IF $PIECE(^PSB(53.79,$PIECE(PSBDATA,U,4),0),U,9)="S"
Begin DoDot:5
+96 SET X2="S"
SET PSBLIST2("Stopped")=PSBLIST2("Stopped")+1
SET PSBLIST2("Stopped",PSBORITX,PSBORDN,$PIECE(PSBDATA,U,3))="STOPPED"
End DoDot:5
+97 ;Include initials in the Legend for all entries in the audit log and comment subfile - PSB*3*62
NEW PSBORIEN,PSBADIT,PSBCMTIT
+98 SET PSBORIEN=$PIECE(PSBDATA,U,4)
+99 SET PSBADIT=0
FOR
SET PSBADIT=$ORDER(^PSB(53.79,PSBORIEN,.9,PSBADIT))
if 'PSBADIT
QUIT
IF ^PSB(53.79,PSBORIEN,.9,PSBADIT,0)["ACTION STATUS"!(^PSB(53.79,PSBORIEN,.9,PSBADIT,0)["ADMINISTRATION STATUS")
Begin DoDot:5
+100 IF $PIECE(^PSB(53.79,PSBORIEN,.9,PSBADIT,0),U,5)]""
SET PSBLGD(PSBORDN,"INITIALS",$PIECE(^PSB(53.79,PSBORIEN,.9,PSBADIT,0),U,5))=""
End DoDot:5
+101 SET PSBCMTIT=0
FOR
SET PSBCMTIT=$ORDER(^PSB(53.79,PSBORIEN,.3,PSBCMTIT))
if 'PSBCMTIT
QUIT
Begin DoDot:5
+102 IF $PIECE(^PSB(53.79,PSBORIEN,.3,PSBCMTIT,0),U,2)]""
SET PSBLGD(PSBORDN,"INITIALS",$PIECE(^PSB(53.79,PSBORIEN,.3,PSBCMTIT,0),U,2))=""
End DoDot:5
+103 if '$DATA(X2)
SET X2="A"
SET PSBLIST2("All Other",PSBORITX,PSBORDN,$PIECE(PSBDATA,U,3))=$$GET1^DIQ(53.79,$PIECE(PSBDATA,U,4)_",","ACTION STATUS")
+104 IF $DATA(PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*"))
KILL PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")
End DoDot:4
End DoDot:3
QUIT
+105 if '$DATA(PSBORDN)
QUIT
+106 IF $PIECE(PSBDATA,U,1)="END"
QUIT
End DoDot:2
End DoDot:1
+107 FOR I="All Other","Infusing","Stopped"
SET X=""
SET PSBLIST2(I)=0
FOR
SET X=$ORDER(PSBLIST2(I,X))
if X=""
QUIT
SET XI=""
FOR
SET XI=$ORDER(PSBLIST2(I,X,XI),-1)
if XI=""
QUIT
Begin DoDot:1
+108 SET PSBX2X=""
FOR
SET PSBX2X=$ORDER(PSBLIST2(I,X,XI,PSBX2X),-1)
if PSBX2X=""
QUIT
SET PSBLIST2(I)=PSBLIST2(I)+1
IF (PSBBGX[$EXTRACT(I,1))
SET PSBTOT=PSBTOT+1
End DoDot:1
+109 DO CREATHDR
+110 DO SUBHDR
+111 DO BLDRPT
+112 DO WRTRPT
+113 QUIT
BLDRPT ; Bld RPT
+1 KILL PSBL2ULN
+2 SET PSBTOPHD=PSBLNTOT-2
+3 IF '$DATA(PSBLIST2)
Begin DoDot:1
+4 SET PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
End DoDot:1
QUIT
+5 SET PSBMORE=5
FOR PSBX1X="Infusing","Stopped","All Other"
Begin DoDot:1
+6 IF PSBX1X'=" * ERROR * "
SET PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_"]"
SET PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
+7 if PSBLIST2(PSBX1X)=0
QUIT
+8 if PSBBGX'[$EXTRACT(PSBX1X,1)
QUIT
+9 if $LENGTH(PSBSUM)>$GET(PSBL2ULN,0)
SET PSBL2ULN=$LENGTH(PSBSUM)
+10 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBL2ULN),"" "",""=""),!"
+11 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !"
+12 KILL PSBDATA
+13 SET X0=""
SET PSBTOT1=0
+14 FOR
SET X0=$ORDER(PSBLIST2(PSBX1X,X0))
if X0=""
QUIT
SET PSBX2X=""
FOR
SET PSBX2X=$ORDER(PSBLIST2(PSBX1X,X0,PSBX2X))
if PSBX2X=""
QUIT
SET XI=""
FOR
SET XI=$ORDER(PSBLIST2(PSBX1X,X0,PSBX2X,XI))
if XI=""
QUIT
Begin DoDot:2
+15 KILL PSBDATA(1)
+16 SET PSBDATA(1,1)=XI
+17 SET PSBDATA(1,2)=$ORDER(PSBSTS(PSBX2X,""))
+18 SET PSBDATA(1,3)=PSBLIST2(PSBX1X,X0,PSBX2X,XI)
+19 SET Y0=$ORDER(PSBOMDR(PSBX2X,""))
IF Y0]""
SET PSBDATA(1,4)="("_X0_")"
SET PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
+20 IF "IS"[$EXTRACT(PSBDATA(1,3),1)
SET (PSBCHG,PSBDATA(1,5))=""
SET PSBORLST(0)=PSBX2X
DO RPC^PSBCHKIV(.PSBCHG,PSBXDFN,.PSBORLST)
+21 IF $DATA(PSBCHG(0))
IF PSBCHG(0)>0
IF ($PIECE(PSBCHG(1),U)=PSBX2X)!($PIECE(PSBCHG(1),U,5)=PSBX2X)
FOR X2=0:1
if PSBCHG(X2)="END"
QUIT
IF $PIECE(PSBCHG(X2),U)="CD"
SET PSBDATA(1,5)="Changed Order"
QUIT
+22 SET PSBDATA(1,6)=$$FMTDT^PSBOCE1($ORDER(PSBOSTDT(PSBX2X,"")))
+23 SET PSBDATA(1,7)=$$FMTDT^PSBOCE1($EXTRACT($ORDER(PSBOSPDT(PSBX2X,"")),1,12))
+24 ;*68
KILL PSBSIDAT
MERGE PSBSIDAT=PSBSI(PSBX2X)
+25 SET PSBTOT1=PSBTOT1+1
+26 KILL PSBDATA(2),PSBSILN
+27 DO BUILDLN^PSBOCI1
DO SIOPI^PSBOCM(.PSBSIDAT,PSBTAB7,"Other Print Info: ")
+28 IF $DATA(PSBRPLN)
SET PSBMORE=$ORDER(PSBRPLN(""),-1)+6
IF $DATA(PSBSILN)
SET PSBMORE=PSBMORE+$ORDER(PSBSILN(""),-1)
+29 KILL PSB1
IF $DATA(PSBFLGD(PSBX2X))
SET PSB=""
FOR
SET PSB=$ORDER(PSBFLGD(PSBX2X,PSB))
if PSB=""
QUIT
IF ($PIECE(PSB,":")'="NOX")&($PIECE(PSB,":")'="STAT")
SET PSB1=$GET(PSB1,"")_PSB
+30 ;*70 build write clinic stmt
+31 SET PSBOUTP($$PGTOT,PSBLNTOT)="W """_$GET(PSBCLIN(PSBX2X))_""""_",!"
+32 SET PSBCNT=PSBTOT1_" "_$GET(PSB1,"")
+33 SET PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
+34 SET I=""
FOR
SET I=$ORDER(PSBRPLN(I))
if +I=0
QUIT
Begin DoDot:3
+35 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
End DoDot:3
+36 SET I=""
FOR
SET I=$ORDER(PSBSILN(I))
if +I=0
QUIT
Begin DoDot:3
+37 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
End DoDot:3
+38 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB7),"" "",""-""),!"
+39 KILL PSBRPLN,PSBDATA,PSBSILN
End DoDot:2
End DoDot:1
+40 KILL PSBNO
SET PSBNO=1
if +PSBTOT>0
DO LGD^PSBOCM
KILL PSBNO
+41 QUIT
WRTRPT ; writ
+1 IF $ORDER(PSBOUTP(""),-1)<1
Begin DoDot:1
+2 XECUTE PSBOUTP($ORDER(PSBOUTP(""),-1),14)
+3 DO PTFTR^PSBOCI1
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 PTFTR^PSBOCI1
SET PSBPGNUM=PSBZ
DO HDR
DO SUBHDR
+7 SET PSBX2X=""
FOR
SET PSBX2X=$ORDER(PSBOUTP(PSBZ,PSBX2X))
if PSBX2X=""
QUIT
Begin DoDot:2
+8 XECUTE PSBOUTP(PSBZ,PSBX2X)
End DoDot:2
End DoDot:1
+9 DO PTFTR^PSBOCI1
+10 KILL ^XTMP("PSBO",$JOB,"PSBLIST"),PSBOUTP
+11 QUIT
HDR ; Hder
+1 if $Y>1
WRITE @IOF
+2 if $X>1
WRITE !
+3 SET PSBRPNM="BCMA COVERSHEET IV OVERVIEW REPORT"
+4 if $PIECE(PSBRPT(.1),U,1)="P"
Begin DoDot:1
+5 SET PSBHDR(0)=PSBRPNM
+6 SET PSBHDR(1)="Order Type(s): --"
+7 FOR Y=12,13,18
IF $PIECE(PSBFUTR,U,Y)
SET $PIECE(PSBHDR(1),": ",2)=$PIECE(PSBHDR(1),": ",2)_$SELECT(PSBHDR(1)["--":"",1:"/ ")_$PIECE("^^^^^^^^^^^Infusing Bags^Stopped Bags^^^^^All Others",U,Y)_" "
SET PSBHDR(1)=$TRANSLATE(PSBHDR(1),"-","")
+8 IF $PIECE(PSBFUTR,U,11)
SET PSBHDR(2)="Include Action(s)"_$SELECT(PSBCFLG:" & Comments/Reasons",1:"")
+9 ;*70
if $GET(PSBSRCHL)]""
SET PSBHDR(3)=""
SET PSBHDR(4)=PSBSRCHL
+10 DO PT^PSBOHDR(PSBXDFN,.PSBHDR)
End DoDot:1
+11 QUIT
SUBHDR ;
+1 NEW PSBAL
SET PSBAL=$ORDER(PSBHDR("ALERGY",""),-1)
SET PSBAL=$SELECT((PSBAL/12)>(PSBAL\12):(PSBAL\12)+1,1:(PSBAL\12))
+2 NEW PSBRE
SET PSBRE=$ORDER(PSBHDR("REAC",""),-1)
SET PSBRE=$SELECT((PSBRE/12)>(PSBRE\12):(PSBRE\12)+1,1:(PSBRE\12))
+3 SET PSBLNTOT=$ORDER(PSBHDR(""),-1)+9+PSBAL+PSBRE+1
+4 IF $GET(PSBPGNUM,0)=1
WRITE !,?(PSBTAB7-($LENGTH("Total Items reported: "_+PSBTOT))),"Total Items reported: "_+PSBTOT,!
SET PSBLNTOT=PSBLNTOT+2
+5 WRITE !,$TRANSLATE($JUSTIFY("",PSBTAB7)," ","_")
SET PSBLNTOT=PSBLNTOT+1
+6 WRITE !,$GET(PSBHD1,"")
SET PSBLNTOT=PSBLNTOT+1
+7 WRITE !,$GET(PSBHD2,"")
SET PSBLNTOT=PSBLNTOT+1
+8 WRITE !,$TRANSLATE($JUSTIFY("",PSBTAB7)," ","="),!
SET PSBLNTOT=PSBLNTOT+2
+9 IF $DATA(NOTE(PSBPGNUM))
WRITE NOTE(PSBPGNUM),!!
SET PSBLNTOT=PSBLNTOT+2
+10 QUIT
PGTOT(X) ;PG Nmbr
+1 IF (PSBLNTOT+PSBMORE)>(IOSL)
DO PGC^PSBOCE1
+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 PSBHD1=$PIECE($TEXT(HD132A),"~",2)
SET PSBHD2=$PIECE($TEXT(HD132B),";",2)
SET PSBBLANK=$PIECE($TEXT(C132BLK),";",2)
+3 IF '$TEST
SET PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY"
KILL PSBLIST2
QUIT
+4 ; 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 ;~ Bag ID | Order | Bag | Medication; Infusion Rate, Route | Bag Info | Order Start | Order Stop |
+1 QUIT
HD132B ; | Status | Status | | | Date | Date |
+1 QUIT
C132BLK ;; | | | | | | |
+1 QUIT
