PSBOCP ;BIRMINGHAM/TEJ-COVERSHEET PRN OVERVIEW REPORT ;3/19/13 19:13pm
;;3.0;BAR CODE MED ADMIN;**32,50,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. set CO admin window to 7 days +/-.
;
EN ; Entry Point
N PSBX1X,RESULTS,RESULT,PSBFUTR,QQ,PSBSRCHL,PSBHDR,STRTDT,STOPDT,EXPIREHDG,PSBCLIN ;*70
S PSBFUTR=$TR(PSBRPT(1),"~","^")
S (PSBOCRIT,PSBXFLG,PSBCFLG)="" ; Order Status search criteria - "A"ctive, "D"C ed, "E"xpired"
S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_"D" S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_"E" S:$P(PSBFUTR,U,5) PSBOCRIT=PSBOCRIT_"A"
S:$P(PSBFUTR,U,4) PSBOCRIT=PSBOCRIT_"F"
S:$P(PSBFUTR,U,11) PSBXFLG=1
I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
S PSBCLINORD=$S($P($G(PSBRPT(4)),U,2)="C":1,1:0) ;*70
;add ability to use a different heading for expired IM/CO meds ;*70
S EXPIREHDG=$S(PSBCLINORD:"EXPIRED/DC'd within last 7 days",1:"EXPIRED/DC'd")
;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)
;change admin window times to 7 days for CO ;*70
I PSBCLINORD S (PSBB4,PSBAFT)=7
K ^XTMP("PSBO",$J,"PSBLIST")
S (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
K PSBLIST,PSBLIST2
S PSBXDFN=$P(PSBRPT(.1),U,2)
S PSBLIST(PSBXDFN)=""
S (PSBX1X,PSBTOT)=0
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("ACTIVE"),PSBLIST2("FUTURE"),PSBLIST2(EXPIREHDG),PSBLIST2(" * ERROR * "))=0
.F S PSBX2X=$O(PSBDATA(PSBX2X)) Q:+PSBX2X=0 D
..S PSBDATA=PSBDATA(PSBX2X)
..I ($P(PSBDATA,U)="ORD") I $P(PSBDATA,U,6)'="P" F S PSBX2X=$O(PSBDATA(PSBX2X)) S PSBDATA=PSBDATA(PSBX2X) Q:$P(PSBDATA,U)="END"
..I ($P(PSBDATA,U)="ORD") K PSBORDN D Q
...K PSBDRUGN
...S PSBSCHTY="P"
...S PSBORDN=$P(PSBDATA,U,3)
...S PSBCLIN(PSBORDN)=$S($P(PSBDATA,U,32)]"":"Location: ",1:"")_$P(PSBDATA,U,32) ;*70
...S PSBTB=$P(PSBDATA,U,29) S PSBTB=$S(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
...S PSBTB(PSBORDN,PSBTB)=""
...S PSBSTS1=$P(PSBDATA,U,23)
...S STRTDT=$P(PSBDATA,U,22),STOPDT=$P(PSBDATA,U,27) ;*70
...S PSBSTS=$S((PSBSTS1="A")&(STOPDT>PSBNOWX):"Active",PSBSTS1="H":"Hold",PSBSTS1="D":"Discontinued",PSBSTS1="DE":"Discontinued (Edit)",(PSBSTS1="E")!(STOPDT'>PSBNOWX):"Expired",1:" * ERROR * ")
...S PSBSTS(PSBORDN,PSBSTS)=""
...S V=$$FMADD^XLFDT(PSBNOWX,,,PSBB4)
...S PSBSTSX=$S(STOPDT'>PSBNOWX:EXPIREHDG,STRTDT'>V:"ACTIVE",V:"FUTURE",1:" * ERROR * ")
...S PSBLIST2(PSBSTSX,$P(PSBDATA,U,9),PSBORDN)=$P(PSBDATA,U,32) S PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1 ;*70 clin name
...S:PSBOCRIT[$E(PSBSTSX,1) PSBTOT=PSBTOT+1
...S PSBSCHTY(PSBORDN,PSBSCHTY)=""
...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 PSBLSTG=$P(PSBDATA,U,28)
...I PSBLSTG]"" S PSBLSTG(PSBORDN,$$FMTDT^PSBOCE1($E(PSBLSTG,1,12)))=""
...S PSBLSTX=$S(PSBLSTG]"":$$LSTX(PSBLSTG,PSBNOWX),1:" ")
...S PSBLSTX(PSBORDN,PSBLSTX)=""
...; ** SPECIAL INSTRUCTIONS **
...S PSBX2X=PSBX2X+1
...; *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
...S PSBOSTDT=$P(PSBDATA,U,22)
...S PSBOSTDT(PSBORDN,PSBOSTDT)=""
...S PSBOSPDT=$P(PSBDATA,U,27)
...S PSBOSPDT(PSBORDN,PSBOSPDT)=""
..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
..I $P(PSBDATA,U)="END" Q
..Q:'$D(PSBORDN)
..I $P(PSBDATA(PSBX2X),U)="ORF" D Q
...S PSBDATA=PSBDATA(PSBX2X)
...S:$P(PSBDATA,U,2)]"" PSBFLGD(PSBORDN,$P(PSBDATA,U,3)_" - "_$P(PSBDATA,U,4))=""
..Q:'$D(PSBORDN)
..I ($P(PSBDATA,U)="ADM")&($P(PSBDATA,U,4)]"") D Q
...S PSBXID=$P(PSBDATA,U,6)_U_$P(PSBDATA,U,4),PSBADM(PSBORDN,(-1*($P(PSBDATA,U,6))),PSBXID)=PSBDATA
...I $O(PSBSCHTY(PSBORDN,""))="P" S PSBPRNR(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,9)
...I $P(PSBDATA,U,3)]"" S PSBBID(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,3)
...S:PSBXFLG PSBLGD(PSBORDN,"X","INITIALS",$P(PSBDATA,U,8))=""
...I $P(PSBDATA(PSBX2X+1),U)="CMT" S PSBX2X=PSBX2X+1 F PSBX3X=PSBX2X:1 S PSBDATA=PSBDATA(PSBX3X) Q:($P(PSBDATA,U)'="CMT") D
....S PSBX2X=PSBX3X
....I $P(PSBDATA,U,3)]"" S PSBPRNEF(PSBORDN,$P(PSBXID,U,2))=$P(PSBDATA,U,3)
....I PSBCFLG I $P(PSBDATA,U,2)'="" S PSBLGD(PSBORDN,"C","INITIALS",$P(PSBDATA,U,4))="",PSBCMT(PSBORDN,$P(PSBXID,U,2),(-1*$P(PSBDATA,U,6)),PSBX2X)=PSBDATA
I +PSBTOT=0 K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
D CREATHDR^PSBOCP1
D SUBHDR^PSBOCE
D BLDRPT
D WRTRPT^PSBOCP1
Q
BLDRPT ; Buld REPORT DATA
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="ACTIVE","FUTURE",EXPIREHDG," * ERROR * " D
.I PSBX1X'=" * ERROR * " S PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_$S(PSBLIST2(PSBX1X)=1:" Order",1:" Orders")_"]" S PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
.Q:PSBLIST2(PSBX1X)=0
.Q:PSBOCRIT'[$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="" D
..M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"X","INITIALS") M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"C","INITIALS")
..S PSBDATA(1,1)=$O(PSBTB(PSBX2X,""))
..S PSBDATA(1,2)=$O(PSBSTS(PSBX2X,""))
..S PSBDATA(1,3)=$O(PSBSCHTY(PSBX2X,""))
..S Y0=$O(PSBOMDR(PSBX2X,"")) I Y0]"" S PSBDATA(1,4)="("_X0_")",PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
..S PSBDATA(1,5)=$O(PSBLSTG(PSBX2X,""))
..S PSBDATA(1,6)=$O(PSBLSTX(PSBX2X,""))
..S PSBDATA(1,7)=$$FMTDT^PSBOCE1($O(PSBOSTDT(PSBX2X,"")))
..S PSBDATA(1,8)=$$FMTDT^PSBOCE1($E($O(PSBOSPDT(PSBX2X,"")),1,12))
..K PSBSIDAT M PSBSIDAT=PSBSI(PSBX2X) ;*68
..S PSBTOT1=PSBTOT1+1
..K PSBDATA(2),PSBDATA(3),PSBSILN
..D BUILDLN,SIOPI^PSBOCM(.PSBSIDAT,PSBTAB8,$S(PSBX2X["V":"Other Print Info:",1:""))
..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
..;build write clinic stmt ;*70
..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("""",PSBTAB8),"" "",""-""),!"
..K PSBRPLN,PSBDATA
D:+PSBTOT>0 LGD^PSBOCM
Q
BUILDLN ; Constr recs
K J S J(0)="" F PSBFLD=1:1:8 S J=1 D FORMDAT(PSBFLD) S J($O(PSBRPLN(""),-1))=""
; Write administration info...
Q:'PSBXFLG
S J=($O(J(""),-1)+1),PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
S (N,Y)=""
F S Y=$O(PSBADM(PSBX2X,Y)) Q:Y']"" D
.F S N=$O(PSBADM(PSBX2X,Y,N)) Q:N']"" D
..N PSBEIECMT S PSBEIECMT="" I $D(PSBPRNEF(PSBX2X,$P(N,U,2))),$P($G(PSBRPT(.2)),U,8)=0 S PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,$P(N,U,2))
..I $D(PSBBID(PSBX2X,$P(N,U,2))) S PSBDATA(2,0)="BAG ID: "_PSBBID(PSBX2X,$P(N,U,2))
..S $E(PSBDATA(2,0),25)="ACTION BY: "_$P(PSBADM(PSBX2X,Y,N),U,7)_" "_$$FMTDT^PSBOCE1($E($P(PSBADM(PSBX2X,Y,N),U,6),1,12))
..S X=$P(PSBADM(PSBX2X,Y,N),U,5) S $E(PSBDATA(2,0),56)="ACTION: "_$S(X="G":"GIVEN",X="R":"REFUSED",X="RM":"REMOVED",X="H":"HELD",X="S":"STOPPED",X="I":"INFUSING",X="C":"COMPLETED",X="M":"MISSING DOSE",X=" ":"*UNKNOWN*",1:" ")
..I $D(PSBPRNR(PSBX2X)) S $E(PSBDATA(2,0),72)="PRN REASON: "_PSBPRNR(PSBX2X,$P(N,U,2))
..I $G(PSBDATA(2,0))]" " D WRAPPER(1,132-1,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
..I $D(PSBPRNEF(PSBX2X,$P(N,U,2))) S PSBDATA(2,0)="PRN EFFECTIVENESS: "_PSBPRNEF(PSBX2X,$P(N,U,2))_PSBEIECMT
..I $G(PSBDATA(2,0))]" " D WRAPPER(30,132-30,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
..I ('PSBCFLG)!('$D(PSBCMT(PSBX2X,$P(N,U,2)))) S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1 Q
..S X="" F S X=$O(PSBCMT(PSBX2X,$P(N,U,2),X)) Q:X']"" D
...N PSBDAT S PSBDAT="" F S PSBDAT=$O(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT)) Q:PSBDAT']"" D
....S PSBDATA(2,0)="COMMENT BY: "_$S($P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,5)]"":$P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,5)_" "_$$FMTDT^PSBOCE1($E($P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,6),1,12)),1:" n/a ")
....S PSBDATA(2,0)=PSBDATA(2,0)_" COMMENT: "_$S($P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,2)]"":$P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,2),1:" ")
....I $G(PSBDATA(2,0))]" " D WRAPPER(30,132-30,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
..S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
Q
FORMDAT(FLD) ;
K PSBVAL
Q:'$D(PSBDATA(1,FLD))
S PSBVAL=PSBDATA(1,FLD)
D WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
I FLD=4 S J=$O(J(""),-1)+1,PSBVAL=PSBDATA(1,4,0) D WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
Q
PGTOT(X) ;mnt PAGE Number
I (PSBLNTOT+PSBMORE)>(IOSL) D PGC^PSBOCE1
I $G(X,1) S PSBLNTOT=PSBLNTOT+$G(X,1),PSBMORE=PSBMORE-$G(X,1)
Q PSBPGNUM
WRAPPER(X,Y,Z) ; Text WRAP
N PSB
I ($L(Z)>0),$F(Z,"""")>1 F Q:$F(Z,"""")'>1 S Z=$TR(Z,"""","^")
F Q:'$L(Z) D
.I $L(Z)<Y S $E(PSBRPLN(J),X)=Z S Z="" Q
.F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
.S:PSB<1 PSB=Y
.S $E(PSBRPLN(J),X)=$E(Z,1,PSB)
.I $L(PSBRPLN(J),"^")>1 F X=1:1:$L(PSBRPLN(J),"^")-1 S $P(PSBRPLN(J),"^",X)=$P(PSBRPLN(J),"^",X)_""""
.S PSBRPLN(J)=$TR(PSBRPLN(J),"^","""")
.S Z=$E(Z,PSB+1,250),J=J+1,J(J)=""
Q ""
LSTX(P,O) ;
S DT=$$FMDIFF^XLFDT(O,P,2)
I ((DT\60)<1) Q "0d 0h 1m"
S D=(DT\(60*60*24)) S DT=DT-(D*(60*60*24))
S H=(DT\(60*60)) S DT=DT-(H*(60*60))
S M=((DT+30)\(60)) S DT=DT-(M*(60))
Q D_"d "_H_"h "_M_"m"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOCP 11278 printed Nov 22, 2024@16:50:41 Page 2
PSBOCP ;BIRMINGHAM/TEJ-COVERSHEET PRN OVERVIEW REPORT ;3/19/13 19:13pm
+1 ;;3.0;BAR CODE MED ADMIN;**32,50,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. set CO admin window to 7 days +/-.
+12 ;
EN ; Entry Point
+1 ;*70
NEW PSBX1X,RESULTS,RESULT,PSBFUTR,QQ,PSBSRCHL,PSBHDR,STRTDT,STOPDT,EXPIREHDG,PSBCLIN
+2 SET PSBFUTR=$TRANSLATE(PSBRPT(1),"~","^")
+3 ; Order Status search criteria - "A"ctive, "D"C ed, "E"xpired"
SET (PSBOCRIT,PSBXFLG,PSBCFLG)=""
+4 if $PIECE(PSBFUTR,U,7)
SET PSBOCRIT=PSBOCRIT_"D"
if $PIECE(PSBFUTR,U,8)
SET PSBOCRIT=PSBOCRIT_"E"
if $PIECE(PSBFUTR,U,5)
SET PSBOCRIT=PSBOCRIT_"A"
+5 if $PIECE(PSBFUTR,U,4)
SET PSBOCRIT=PSBOCRIT_"F"
+6 if $PIECE(PSBFUTR,U,11)
SET PSBXFLG=1
+7 IF $DATA(PSBRPT(.2))
IF $PIECE(PSBRPT(.2),U,8)
SET PSBCFLG=1
+8 ;*70
SET PSBCLINORD=$SELECT($PIECE($GET(PSBRPT(4)),U,2)="C":1,1:0)
+9 ;add ability to use a different heading for expired IM/CO meds ;*70
+10 SET EXPIREHDG=$SELECT(PSBCLINORD:"EXPIRED/DC'd within last 7 days",1:"EXPIRED/DC'd")
+11 ;check Clinic search list ;*70
+12 SET PSBSRCHL=$$SRCHLIST^PSBOHDR()
+13 if $PIECE(PSBRPT(4),U,2)="C"
Begin DoDot:1
+14 if PSBSRCHL=""
SET PSBSRCHL="All Clinics"
+15 SET PSBSRCHL="Clinic Search List: "_PSBSRCHL
End DoDot:1
+16 ;
+17 KILL PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD
+18 SET PSBSORT=1
+19 DO NOW^%DTC
SET (Y,PSBNOWX)=%
DO DD^%DT
SET PSBDTTM=Y
+20 DO GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
+21 SET PSBB4=0
if RESULTS(0)>0
SET PSBB4=+RESULTS(0)
+22 DO GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
+23 SET PSBAFT=0
if RESULTS(0)>0
SET PSBAFT=+RESULTS(0)
+24 ;change admin window times to 7 days for CO ;*70
+25 IF PSBCLINORD
SET (PSBB4,PSBAFT)=7
+26 KILL ^XTMP("PSBO",$JOB,"PSBLIST")
+27 SET (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
+28 KILL PSBLIST,PSBLIST2
+29 SET PSBXDFN=$PIECE(PSBRPT(.1),U,2)
+30 SET PSBLIST(PSBXDFN)=""
+31 SET (PSBX1X,PSBTOT)=0
+32 FOR
SET PSBX1X=$ORDER(PSBLIST(PSBX1X))
if +PSBX1X=0
QUIT
Begin DoDot:1
+33 ;*70
DO RPC^PSBCSUTL(.PSBAREA,PSBX1X,,,PSBCLINORD)
+34 MERGE PSBDATA=@PSBAREA
+35 SET PSBX2X=1
+36 SET (PSBLIST2("ACTIVE"),PSBLIST2("FUTURE"),PSBLIST2(EXPIREHDG),PSBLIST2(" * ERROR * "))=0
+37 FOR
SET PSBX2X=$ORDER(PSBDATA(PSBX2X))
if +PSBX2X=0
QUIT
Begin DoDot:2
+38 SET PSBDATA=PSBDATA(PSBX2X)
+39 IF ($PIECE(PSBDATA,U)="ORD")
IF $PIECE(PSBDATA,U,6)'="P"
FOR
SET PSBX2X=$ORDER(PSBDATA(PSBX2X))
SET PSBDATA=PSBDATA(PSBX2X)
if $PIECE(PSBDATA,U)="END"
QUIT
+40 IF ($PIECE(PSBDATA,U)="ORD")
KILL PSBORDN
Begin DoDot:3
+41 KILL PSBDRUGN
+42 SET PSBSCHTY="P"
+43 SET PSBORDN=$PIECE(PSBDATA,U,3)
+44 ;*70
SET PSBCLIN(PSBORDN)=$SELECT($PIECE(PSBDATA,U,32)]"":"Location: ",1:"")_$PIECE(PSBDATA,U,32)
+45 SET PSBTB=$PIECE(PSBDATA,U,29)
SET PSBTB=$SELECT(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
+46 SET PSBTB(PSBORDN,PSBTB)=""
+47 SET PSBSTS1=$PIECE(PSBDATA,U,23)
+48 ;*70
SET STRTDT=$PIECE(PSBDATA,U,22)
SET STOPDT=$PIECE(PSBDATA,U,27)
+49 SET PSBSTS=$SELECT((PSBSTS1="A")&(STOPDT>PSBNOWX):"Active",PSBSTS1="H":"Hold",PSBSTS1="D":"Discontinued",PSBSTS1="DE":"Discontinued (Edit)",(PSBSTS1="E")!(STOPDT'>PSBNOWX):"Expired",1:" * ERROR * ")
+50 SET PSBSTS(PSBORDN,PSBSTS)=""
+51 SET V=$$FMADD^XLFDT(PSBNOWX,,,PSBB4)
+52 SET PSBSTSX=$SELECT(STOPDT'>PSBNOWX:EXPIREHDG,STRTDT'>V:"ACTIVE",V:"FUTURE",1:" * ERROR * ")
+53 ;*70 clin name
SET PSBLIST2(PSBSTSX,$PIECE(PSBDATA,U,9),PSBORDN)=$PIECE(PSBDATA,U,32)
SET PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
+54 if PSBOCRIT[$EXTRACT(PSBSTSX,1)
SET PSBTOT=PSBTOT+1
+55 SET PSBSCHTY(PSBORDN,PSBSCHTY)=""
+56 SET PSBDOSR=$PIECE(PSBDATA,U,10)_", "_$PIECE(PSBDATA,U,11)
+57 SET PSBDOSR=$TRANSLATE($EXTRACT(PSBDOSR,1)," ")_$EXTRACT(PSBDOSR,2,999)
+58 SET PSBDOSR(PSBORDN,PSBDOSR)=""
+59 SET PSBLSTG=$PIECE(PSBDATA,U,28)
+60 IF PSBLSTG]""
SET PSBLSTG(PSBORDN,$$FMTDT^PSBOCE1($EXTRACT(PSBLSTG,1,12)))=""
+61 SET PSBLSTX=$SELECT(PSBLSTG]"":$$LSTX(PSBLSTG,PSBNOWX),1:" ")
+62 SET PSBLSTX(PSBORDN,PSBLSTX)=""
+63 ; ** SPECIAL INSTRUCTIONS **
+64 SET PSBX2X=PSBX2X+1
+65 ; *68
+66 KILL ^TMP("PSJBCMA5",$JOB)
+67 IF PSBSIFLG
DO GETSIOPI^PSJBCMA5(PSBX1X,PSBORDN,1)
+68 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,PSBX1X,PSBORDN,QQ))
if 'QQ
QUIT
Begin DoDot:4
+69 SET PSBSI(PSBORDN,QQ)=^TMP("PSJBCMA5",$JOB,PSBX1X,PSBORDN,QQ)
End DoDot:4
+70 ; *68 end
+71 SET PSBOSTDT=$PIECE(PSBDATA,U,22)
+72 SET PSBOSTDT(PSBORDN,PSBOSTDT)=""
+73 SET PSBOSPDT=$PIECE(PSBDATA,U,27)
+74 SET PSBOSPDT(PSBORDN,PSBOSPDT)=""
End DoDot:3
QUIT
+75 if '$DATA(PSBORDN)
QUIT
+76 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA(PSBX2X),U))
Begin DoDot:3
+77 FOR I=PSBX2X:1
SET PSBDATA1=PSBDATA(I)
Begin DoDot:4
+78 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA1,U))
SET PSBX2X=I
SET PSBDRUGN=$GET(PSBDRUGN,"")_$PIECE(PSBDATA1,U,3)_", "
QUIT
+79 SET $EXTRACT(PSBDRUGN,$LENGTH(PSBDRUGN)-1)=""
SET PSBDRUGN(PSBORDN,$EXTRACT(PSBDRUGN,1,250))=PSBDRUGN
+80 SET PSBOMDR(PSBORDN,$EXTRACT((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
End DoDot:4
if $DATA(PSBOMDR(PSBORDN))
QUIT
End DoDot:3
QUIT
+81 IF $PIECE(PSBDATA,U)="END"
QUIT
+82 if '$DATA(PSBORDN)
QUIT
+83 IF $PIECE(PSBDATA(PSBX2X),U)="ORF"
Begin DoDot:3
+84 SET PSBDATA=PSBDATA(PSBX2X)
+85 if $PIECE(PSBDATA,U,2)]""
SET PSBFLGD(PSBORDN,$PIECE(PSBDATA,U,3)_" - "_$PIECE(PSBDATA,U,4))=""
End DoDot:3
QUIT
+86 if '$DATA(PSBORDN)
QUIT
+87 IF ($PIECE(PSBDATA,U)="ADM")&($PIECE(PSBDATA,U,4)]"")
Begin DoDot:3
+88 SET PSBXID=$PIECE(PSBDATA,U,6)_U_$PIECE(PSBDATA,U,4)
SET PSBADM(PSBORDN,(-1*($PIECE(PSBDATA,U,6))),PSBXID)=PSBDATA
+89 IF $ORDER(PSBSCHTY(PSBORDN,""))="P"
SET PSBPRNR(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,9)
+90 IF $PIECE(PSBDATA,U,3)]""
SET PSBBID(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,3)
+91 if PSBXFLG
SET PSBLGD(PSBORDN,"X","INITIALS",$PIECE(PSBDATA,U,8))=""
+92 IF $PIECE(PSBDATA(PSBX2X+1),U)="CMT"
SET PSBX2X=PSBX2X+1
FOR PSBX3X=PSBX2X:1
SET PSBDATA=PSBDATA(PSBX3X)
if ($PIECE(PSBDATA,U)'="CMT")
QUIT
Begin DoDot:4
+93 SET PSBX2X=PSBX3X
+94 IF $PIECE(PSBDATA,U,3)]""
SET PSBPRNEF(PSBORDN,$PIECE(PSBXID,U,2))=$PIECE(PSBDATA,U,3)
+95 IF PSBCFLG
IF $PIECE(PSBDATA,U,2)'=""
SET PSBLGD(PSBORDN,"C","INITIALS",$PIECE(PSBDATA,U,4))=""
SET PSBCMT(PSBORDN,$PIECE(PSBXID,U,2),(-1*$PIECE(PSBDATA,U,6)),PSBX2X)=PSBDATA
End DoDot:4
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+96 IF +PSBTOT=0
KILL PSBLIST,^XTMP("PSBO",$JOB,"PSBLIST")
+97 DO CREATHDR^PSBOCP1
+98 DO SUBHDR^PSBOCE
+99 DO BLDRPT
+100 DO WRTRPT^PSBOCP1
+101 QUIT
BLDRPT ; Buld REPORT DATA
+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="ACTIVE","FUTURE",EXPIREHDG," * ERROR * "
Begin DoDot:1
+6 IF PSBX1X'=" * ERROR * "
SET PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_$SELECT(PSBLIST2(PSBX1X)=1:" Order",1:" Orders")_"]"
SET PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
+7 if PSBLIST2(PSBX1X)=0
QUIT
+8 if PSBOCRIT'[$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
Begin DoDot:2
+15 MERGE PSBLGD("INITIALS")=PSBLGD(PSBX2X,"X","INITIALS")
MERGE PSBLGD("INITIALS")=PSBLGD(PSBX2X,"C","INITIALS")
+16 SET PSBDATA(1,1)=$ORDER(PSBTB(PSBX2X,""))
+17 SET PSBDATA(1,2)=$ORDER(PSBSTS(PSBX2X,""))
+18 SET PSBDATA(1,3)=$ORDER(PSBSCHTY(PSBX2X,""))
+19 SET Y0=$ORDER(PSBOMDR(PSBX2X,""))
IF Y0]""
SET PSBDATA(1,4)="("_X0_")"
SET PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
+20 SET PSBDATA(1,5)=$ORDER(PSBLSTG(PSBX2X,""))
+21 SET PSBDATA(1,6)=$ORDER(PSBLSTX(PSBX2X,""))
+22 SET PSBDATA(1,7)=$$FMTDT^PSBOCE1($ORDER(PSBOSTDT(PSBX2X,"")))
+23 SET PSBDATA(1,8)=$$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),PSBDATA(3),PSBSILN
+27 DO BUILDLN
DO SIOPI^PSBOCM(.PSBSIDAT,PSBTAB8,$SELECT(PSBX2X["V":"Other Print Info:",1:""))
+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 ;build write clinic stmt ;*70
+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("""",PSBTAB8),"" "",""-""),!"
+39 KILL PSBRPLN,PSBDATA
End DoDot:2
End DoDot:1
+40 if +PSBTOT>0
DO LGD^PSBOCM
+41 QUIT
BUILDLN ; Constr recs
+1 KILL J
SET J(0)=""
FOR PSBFLD=1:1:8
SET J=1
DO FORMDAT(PSBFLD)
SET J($ORDER(PSBRPLN(""),-1))=""
+2 ; Write administration info...
+3 if 'PSBXFLG
QUIT
+4 SET J=($ORDER(J(""),-1)+1)
SET PSBRPLN(J)=PSBBLANK
SET J(J)=""
SET J=J+1
+5 SET (N,Y)=""
+6 FOR
SET Y=$ORDER(PSBADM(PSBX2X,Y))
if Y']""
QUIT
Begin DoDot:1
+7 FOR
SET N=$ORDER(PSBADM(PSBX2X,Y,N))
if N']""
QUIT
Begin DoDot:2
+8 NEW PSBEIECMT
SET PSBEIECMT=""
IF $DATA(PSBPRNEF(PSBX2X,$PIECE(N,U,2)))
IF $PIECE($GET(PSBRPT(.2)),U,8)=0
SET PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,$PIECE(N,U,2))
+9 IF $DATA(PSBBID(PSBX2X,$PIECE(N,U,2)))
SET PSBDATA(2,0)="BAG ID: "_PSBBID(PSBX2X,$PIECE(N,U,2))
+10 SET $EXTRACT(PSBDATA(2,0),25)="ACTION BY: "_$PIECE(PSBADM(PSBX2X,Y,N),U,7)_" "_$$FMTDT^PSBOCE1($EXTRACT($PIECE(PSBADM(PSBX2X,Y,N),U,6),1,12))
+11 SET X=$PIECE(PSBADM(PSBX2X,Y,N),U,5)
SET $EXTRACT(PSBDATA(2,0),56)="ACTION: "_$SELECT(X="G":"GIVEN",X="R":"REFUSED",X="RM":"REMOVED",X="H":"HELD",X="S":"STOPPED",X="I":"INFUSING",X="C":"COMPLETED",X="M":"MISSING DOSE",X=" ":"*UNKNOWN*",1:" ")
+12 IF $DATA(PSBPRNR(PSBX2X))
SET $EXTRACT(PSBDATA(2,0),72)="PRN REASON: "_PSBPRNR(PSBX2X,$PIECE(N,U,2))
+13 IF $GET(PSBDATA(2,0))]" "
DO WRAPPER(1,132-1,PSBDATA(2,0))
KILL PSBDATA(2)
SET J=J+1
+14 IF $DATA(PSBPRNEF(PSBX2X,$PIECE(N,U,2)))
SET PSBDATA(2,0)="PRN EFFECTIVENESS: "_PSBPRNEF(PSBX2X,$PIECE(N,U,2))_PSBEIECMT
+15 IF $GET(PSBDATA(2,0))]" "
DO WRAPPER(30,132-30,PSBDATA(2,0))
KILL PSBDATA(2)
SET J=J+1
+16 IF ('PSBCFLG)!('$DATA(PSBCMT(PSBX2X,$PIECE(N,U,2))))
SET PSBRPLN(J)=PSBBLANK
SET J(J)=""
SET J=J+1
QUIT
+17 SET X=""
FOR
SET X=$ORDER(PSBCMT(PSBX2X,$PIECE(N,U,2),X))
if X']""
QUIT
Begin DoDot:3
+18 NEW PSBDAT
SET PSBDAT=""
FOR
SET PSBDAT=$ORDER(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT))
if PSBDAT']""
QUIT
Begin DoDot:4
+19 SET PSBDATA(2,0)="COMMENT BY: "_$SELECT($PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,5)]"":$PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,5)_" "_$$FMTDT^PSBOCE1($EXTRACT($PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSB
DAT),U,6),1,12)),1:" n/a ")
+20 SET PSBDATA(2,0)=PSBDATA(2,0)_" COMMENT: "_$SELECT($PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,2)]"":$PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,2),1:" ")
+21 IF $GET(PSBDATA(2,0))]" "
DO WRAPPER(30,132-30,PSBDATA(2,0))
KILL PSBDATA(2)
SET J=J+1
End DoDot:4
End DoDot:3
+22 SET PSBRPLN(J)=PSBBLANK
SET J(J)=""
SET J=J+1
End DoDot:2
End DoDot:1
+23 QUIT
FORMDAT(FLD) ;
+1 KILL PSBVAL
+2 if '$DATA(PSBDATA(1,FLD))
QUIT
+3 SET PSBVAL=PSBDATA(1,FLD)
+4 DO WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
+5 IF FLD=4
SET J=$ORDER(J(""),-1)+1
SET PSBVAL=PSBDATA(1,4,0)
DO WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
+6 QUIT
PGTOT(X) ;mnt PAGE Number
+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
WRAPPER(X,Y,Z) ; Text WRAP
+1 NEW PSB
+2 IF ($LENGTH(Z)>0)
IF $FIND(Z,"""")>1
FOR
if $FIND(Z,"""")'>1
QUIT
SET Z=$TRANSLATE(Z,"""","^")
+3 FOR
if '$LENGTH(Z)
QUIT
Begin DoDot:1
+4 IF $LENGTH(Z)<Y
SET $EXTRACT(PSBRPLN(J),X)=Z
SET Z=""
QUIT
+5 FOR PSB=Y:-1:0
if $EXTRACT(Z,PSB)=" "
QUIT
+6 if PSB<1
SET PSB=Y
+7 SET $EXTRACT(PSBRPLN(J),X)=$EXTRACT(Z,1,PSB)
+8 IF $LENGTH(PSBRPLN(J),"^")>1
FOR X=1:1:$LENGTH(PSBRPLN(J),"^")-1
SET $PIECE(PSBRPLN(J),"^",X)=$PIECE(PSBRPLN(J),"^",X)_""""
+9 SET PSBRPLN(J)=$TRANSLATE(PSBRPLN(J),"^","""")
+10 SET Z=$EXTRACT(Z,PSB+1,250)
SET J=J+1
SET J(J)=""
End DoDot:1
+11 QUIT ""
LSTX(P,O) ;
+1 SET DT=$$FMDIFF^XLFDT(O,P,2)
+2 IF ((DT\60)<1)
QUIT "0d 0h 1m"
+3 SET D=(DT\(60*60*24))
SET DT=DT-(D*(60*60*24))
+4 SET H=(DT\(60*60))
SET DT=DT-(H*(60*60))
+5 SET M=((DT+30)\(60))
SET DT=DT-(M*(60))
+6 QUIT D_"d "_H_"h "_M_"m"
