PSBOCE ;BIRMINGHAM/TEJ-Expired/DC'd/EXPIRING ORDERS REPORT ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**32,50,68,70,83,134**;Mar 2004;Build 1
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; 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.
; - pass global var PSBCLINORD when RPC psbcsutl is called again
; - convert date/time fields to date only for CO and admin window
; to 7 days +/-.
;*83 - add Removes as new event for Next Action column:
; Remove date@time
;
EN ;
N PSBX1X,RESULTS,RESULT,PSBFUTR,X2,X3,QQ,PSBCLIN,PSBSRCHL,PSBHDR,EXPIREHDG,FUTUREHDG,FUTUREX,REMOV,PSBNXTX,PSBNXTX1,PSBNXTX2 ;*83
S PSBCLINORD=$S($P($G(PSBRPT(4)),U,2)="C":1,1:0) ;*70
S EXPIREHDG=$S(PSBCLINORD:"Expired/DC'd within last 7 days",1:"Expired/DC'd")
S FUTUREHDG=$S(PSBCLINORD:"Expiring within next 7 days",1:"Expiring Tomorrow")
S PSBFUTR=$TR(PSBRPT(1),"~",U)
S (PSBOCRIT,PSBXFLG,PSBCFLG)="" ; Ord Status srch crit - "A"ctve, "D"C ed, "E"xpred"
S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_EXPIREHDG S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_EXPIREHDG S:$P(PSBFUTR,U,9) PSBOCRIT=PSBOCRIT_"Expiring Today"
S:$P(PSBFUTR,U,10) PSBOCRIT=PSBOCRIT_FUTUREHDG
S:$P(PSBFUTR,U,11) PSBXFLG=1
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)
I PSBCLINORD S (PSBB4,PSBAFT)=7 ;*70
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
.D GETREMOV^PSBO1(PSBXDFN) ;get all removes for this patient *83
.S PSBX2X=1
.S (PSBLIST2(FUTUREHDG),PSBLIST2("Expiring Today"),PSBLIST2(EXPIREHDG),PSBLIST2(" * NO * "))=0
.F S PSBX2X=$O(PSBDATA(PSBX2X)) Q:+PSBX2X=0 D
..S PSBDATA=PSBDATA(PSBX2X)
..I $P(PSBDATA,U)="ORD" D Q
...K PSBDRUGN
...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 PSBSTS=$P(PSBDATA,U,23) S PSBSTS=$S((PSBSTS="A")&(($P(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS="H":"On Hold",PSBSTS="D":"Discontinued",PSBSTS="DE":"Discontinued (Edit)",(PSBSTS="E")!($P(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ERROR * ")
...S PSBSTS(PSBORDN,PSBSTS)=""
...S X2=$P(PSBDATA,U,27),X3=$P(PSBNOWX,".")
...;add ability to use a different calculation and heading for future
...;expired IM and CO meds
...S FUTUREX=$S(PSBCLINORD:8,1:2)
...S PSBSTSX=$S((X2<PSBNOWX):EXPIREHDG,(X3'>X2)&($$FMADD^XLFDT(X3,1)>X2):"Expiring Today",($$FMADD^XLFDT(X3,1)'>X2)&(X2'>$$FMADD^XLFDT(X3,FUTUREX)):FUTUREHDG,1:" * NO * ") ;*70
...;
...I PSBSTS["Discontinued" S PSBSTSX=EXPIREHDG
...S PSBLIST2(PSBSTSX,$P(PSBDATA,U,9),PSBORDN)=$P(PSBDATA,U,32) S PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1 ;*70 clin name
...S:PSBOCRIT[PSBSTSX PSBTOT=PSBTOT+1
...S PSBSCHTY=$P(PSBDATA,U,6)
...S PSBSCHTY(PSBORDN,PSBSCHTY)=""
...S PSBSCHD=$P(PSBDATA,U,7) I PSBSCHD="" S PSBSCHD=" "
...S PSBSCHD(PSBORDN,PSBSCHD)=""
...S PSBDOSR=$P(PSBDATA,U,10)_", "_$P(PSBDATA,U,11)
...S PSBDOSR=$TR($E(PSBDOSR,1)," ")_$E(PSBDOSR,2,999)
...S PSBDOSR(PSBORDN,PSBDOSR)="" K PSBOMDR(PSBORDN)
...S PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
...S PSBNXTX2="" ;init *83
...I PSBSTS["Hold" S PSBNXTX2="Provider Hold"
...I PSBSTS'["Hold" D
...;
...;Next admin date triggers data for Next Action col, and also *83
...; if a remove action is pending use that text for NA col. *83
...S REMOV=$O(^TMP("PSB",$J,"RM","B",PSBORDN,0))
...I PSBSTS'["Hold",((PSBNXTX1)!(REMOV)) D
....;build Admin Next Action text
....D:PSBNXTX1
.....S NXTADM=$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT)
.....S PSBNXTX2=$S(PSBNOWX>NXTADM:"MISSED ",1:"DUE ")_PSBNXTX1
....;Removal tests and Next Action text build *83
....S REMOV=$O(^TMP("PSB",$J,"RM","B",PSBORDN,0))
....D:REMOV
.....S MRR=$P(PSBDATA(PSBX2X),U,35)
.....S RMVTIM=$P(^TMP("PSB",$J,"RM",REMOV),U)
.....;Sched types below have no admin nor removal times, but do know
.....; this MRR was given and next is Removal
.....I ("^P^OC^"[("^"_PSBSCHTY_"^")) S:PSBSTS'["Hold" PSBNXTX2="(Removal)" Q
.....;sys err tst, sched rmv dt/tm empty, if null use nxt adm for rmv
.....I MRR=1,'RMVTIM S RMVTIM=PSBNXTX1
.....I PSBNOWX>$$FMADD^XLFDT(RMVTIM,,,PSBAFT) D ;missed rm
......S PSBNXTX2="MISSED "_RMVTIM_" (Removal)"
......S:'RMVTIM PSBNXTX2="REMOVE" ;err, rmv empty
.....E D ;due rm
......S PSBNXTX2="REMOVE "_RMVTIM
.....K MRR,NXTADM,RMVTIM
...;
...S PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
...;don't do if Expired Next action is a Removal *83
...I PSBNXTX2'["Removal",PSBNXTX2'["REMOVE" D
....I ("^P^OC^O"[(U_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired") S:PSBSTS'["Hold" PSBNXTX2=" "
....I PSBNXTX2="" S PSBNXTX2=" " ;P134
...S PSBNXTX(PSBORDN,PSBNXTX2)=""
...; ** SPC INSTR **
...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)=""
..I "^DD^ADD^SOL"[(U_$P(PSBDATA,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
..I $P(PSBDATA(PSBX2X+1),U)="ORF" D Q
...S PSBX2X=PSBX2X+1 S PSBDATA=PSBDATA(PSBX2X)
...S:$P(PSBDATA,U,2)]"" PSBFLGD(PSBORDN,$P(PSBDATA,U,3)_" - "_$P(PSBDATA,U,4))=""
..I ($P(PSBDATA,U)="ADM")&($P(PSBDATA,U,4)]"") D
...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))=""
...K PSBDATA(PSBX2X)
...I ($P(PSBDATA(PSBX2X+1),U)="CMT") F S PSBDATA=PSBDATA(PSBX2X+1) Q:($P(PSBDATA,U)'="CMT") D
....S PSBX2X=PSBX2X+1
....S PSBDATA=PSBDATA(PSBX2X)
....K PSBDATA(PSBX2X)
....S:$P(PSBDATA,U,3)]"" PSBPRNEF(PSBORDN,$P(PSBXID,U,2))=$P(PSBDATA,U,3)
....I 'PSBCFLG S PSBDATA=PSBDATA(PSBX2X+1) Q
....I $P(PSBDATA,U,2)'="" D
.....S PSBLGD(PSBORDN,"C","INITIALS",$P(PSBDATA,U,4))=""
.....S PSBCMT(PSBORDN,$P(PSBXID,U,2),(-1*$P(PSBDATA,U,6)),PSBX2X)=PSBDATA
STOP I '$D(PSBLIST2) K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
D CREATHDR
D SUBHDR
D BLDRPT
D WRTRPT
Q
BLDRPT ; Buld RPT DATA
S X0="" K PSBLIST2(" * NO * "),PSBL2ULN
S PSBTOPHD=PSBLNTOT-2
I '$D(PSBLIST2) D Q
.S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
S PSBMORE=5 F PSBX1X=EXPIREHDG,"Expiring Today",FUTUREHDG 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'[PSBX1X
.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="" 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(PSBSCHD(PSBX2X,""))
..S PSBDATA(1,6)=$O(PSBNXTX(PSBX2X,""))
..S:PSBDATA(1,6)'["Hold" $P(PSBDATA(1,6)," ",2)=$$FMTDT^PSBOCE1($P(PSBDATA(1,6)," ",2))
..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^PSBOCE1,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
..;*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("""",PSBTAB8),"" "",""-""),!"
..K PSBRPLN,PSBDATA,PSBSILN
D:+PSBTOT>0 LGD^PSBOCM
Q
WRTRPT ; writ
I $O(PSBOUTP(""),-1)<1 D Q
.X PSBOUTP($O(PSBOUTP(""),-1),21)
.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
.S PSBX2X="" F S PSBX2X=$O(PSBOUTP(PSBZ,PSBX2X)) Q:PSBX2X="" D
..X PSBOUTP(PSBZ,PSBX2X)
D FTR
K ^XTMP("PSBO",$J,"PSBLIST"),PSBOUTP
Q
HDR ; Hder
W:$Y>1 @IOF
W:$X>1 !
S PSBRPNM="BCMA COVERSHEET EXPIRED/DC'd/EXPIRING ORDERS REPORT"
D:$P(PSBRPT(.1),U,1)="P"
.S PSBHDR(0)=PSBRPNM
.S PSBHDR(1)="Order Status(es): --"
.F Y=7,8,9,10 I $P(PSBFUTR,U,Y) S $P(PSBHDR(1),": ",2)=$P(PSBHDR(1),": ",2)_$S(PSBHDR(1)["--":"",1:"/ ")_$P("^^^^^^Expired^DC'd^Expiring Today^"_FUTUREHDG_"^^^^^^^^",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 !,?(PSBTAB8-($L("Total Orders reported: "_+PSBTOT))),"Total Orders reported: "_+PSBTOT,! S PSBLNTOT=PSBLNTOT+2
W !,$TR($J("",PSBTAB8)," ","_") S PSBLNTOT=PSBLNTOT+1
W !,$G(PSBHD1,"") S PSBLNTOT=PSBLNTOT+1
W !,$G(PSBHD2,"") S PSBLNTOT=PSBLNTOT+1
W !,$TR($J("",PSBTAB8)," ","="),! S PSBLNTOT=PSBLNTOT+2
I $D(NOTE(PSBPGNUM)) W NOTE(PSBPGNUM),!! S PSBLNTOT=PSBLNTOT+2
Q
FTR ; Footr
D PTFTR^PSBOHDR()
S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
S PSBPGRM=PSBTAB8-($L(PSBPG))
W !,PSBRPNM," ",?(PSBPGRM-($L(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
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
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
; 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 ;~ VDL | Status |Type| Medication; Dosage, Route | Schedule | Next | Order Start | Order Stop |
Q
HD132B ; Tab | | | | | Action | Date | Date |
Q
H132BLK ;; | | | | | | | |
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOCE 13227 printed Apr 09, 2024@20:46:18 Page 2
PSBOCE ;BIRMINGHAM/TEJ-Expired/DC'd/EXPIRING ORDERS REPORT ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**32,50,68,70,83,134**;Mar 2004;Build 1
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; GETSIOPI^PSJBCMA5/5763
+6 ;
+7 ;*68 - allow SIOPI builder to accomodate more than 1 line in SI array
+8 ;*70 - pass global var PSBCLINORD when Rpc Psbcsutl is called again
+9 ; - add clinic name to new array PSBCLIN to track clinic name per
+10 ; order for printed output.
+11 ; - pass global var PSBCLINORD when RPC psbcsutl is called again
+12 ; - convert date/time fields to date only for CO and admin window
+13 ; to 7 days +/-.
+14 ;*83 - add Removes as new event for Next Action column:
+15 ; Remove date@time
+16 ;
EN ;
+1 ;*83
NEW PSBX1X,RESULTS,RESULT,PSBFUTR,X2,X3,QQ,PSBCLIN,PSBSRCHL,PSBHDR,EXPIREHDG,FUTUREHDG,FUTUREX,REMOV,PSBNXTX,PSBNXTX1,PSBNXTX2
+2 ;*70
SET PSBCLINORD=$SELECT($PIECE($GET(PSBRPT(4)),U,2)="C":1,1:0)
+3 SET EXPIREHDG=$SELECT(PSBCLINORD:"Expired/DC'd within last 7 days",1:"Expired/DC'd")
+4 SET FUTUREHDG=$SELECT(PSBCLINORD:"Expiring within next 7 days",1:"Expiring Tomorrow")
+5 SET PSBFUTR=$TRANSLATE(PSBRPT(1),"~",U)
+6 ; Ord Status srch crit - "A"ctve, "D"C ed, "E"xpred"
SET (PSBOCRIT,PSBXFLG,PSBCFLG)=""
+7 if $PIECE(PSBFUTR,U,7)
SET PSBOCRIT=PSBOCRIT_EXPIREHDG
if $PIECE(PSBFUTR,U,8)
SET PSBOCRIT=PSBOCRIT_EXPIREHDG
if $PIECE(PSBFUTR,U,9)
SET PSBOCRIT=PSBOCRIT_"Expiring Today"
+8 if $PIECE(PSBFUTR,U,10)
SET PSBOCRIT=PSBOCRIT_FUTUREHDG
+9 if $PIECE(PSBFUTR,U,11)
SET PSBXFLG=1
+10 IF $DATA(PSBRPT(.2))
IF $PIECE(PSBRPT(.2),U,8)
SET PSBCFLG=1
+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 ;*70
IF PSBCLINORD
SET (PSBB4,PSBAFT)=7
+25 KILL ^XTMP("PSBO",$JOB,"PSBLIST")
+26 SET (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
+27 KILL PSBLIST,PSBLIST2
+28 SET PSBXDFN=$PIECE(PSBRPT(.1),U,2)
+29 SET PSBLIST(PSBXDFN)=""
+30 SET (PSBX1X,PSBTOT)=0
+31 FOR
SET PSBX1X=$ORDER(PSBLIST(PSBX1X))
if +PSBX1X=0
QUIT
Begin DoDot:1
+32 ;*70
DO RPC^PSBCSUTL(.PSBAREA,PSBX1X,,,PSBCLINORD)
+33 MERGE PSBDATA=@PSBAREA
+34 ;get all removes for this patient *83
DO GETREMOV^PSBO1(PSBXDFN)
+35 SET PSBX2X=1
+36 SET (PSBLIST2(FUTUREHDG),PSBLIST2("Expiring Today"),PSBLIST2(EXPIREHDG),PSBLIST2(" * NO * "))=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"
Begin DoDot:3
+40 KILL PSBDRUGN
+41 SET PSBORDN=$PIECE(PSBDATA,U,3)
+42 ;*70
SET PSBCLIN(PSBORDN)=$SELECT($PIECE(PSBDATA,U,32)]"":"Location: ",1:"")_$PIECE(PSBDATA,U,32)
+43 SET PSBTB=$PIECE(PSBDATA,U,29)
SET PSBTB=$SELECT(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
+44 SET PSBTB(PSBORDN,PSBTB)=""
+45 SET PSBSTS=$PIECE(PSBDATA,U,23)
SET PSBSTS=$SELECT((PSBSTS="A")&(($PIECE(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS="H":"On Hold",PSBSTS="D":"Discontinued",PSBSTS="DE":"Discontinued (Edit)",(PSBSTS="E")!($PIECE(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ERRO
R * ")
+46 SET PSBSTS(PSBORDN,PSBSTS)=""
+47 SET X2=$PIECE(PSBDATA,U,27)
SET X3=$PIECE(PSBNOWX,".")
+48 ;add ability to use a different calculation and heading for future
+49 ;expired IM and CO meds
+50 SET FUTUREX=$SELECT(PSBCLINORD:8,1:2)
+51 ;*70
SET PSBSTSX=$SELECT((X2<PSBNOWX):EXPIREHDG,(X3'>X2)&($$FMADD^XLFDT(X3,1)>X2):"Expiring Today",($$FMADD^XLFDT(X3,1)'>X2)&(X2'>$$FMADD^XLFDT(X3,FUTUREX)):FUTUREHDG,1:" * NO * ")
+52 ;
+53 IF PSBSTS["Discontinued"
SET PSBSTSX=EXPIREHDG
+54 ;*70 clin name
SET PSBLIST2(PSBSTSX,$PIECE(PSBDATA,U,9),PSBORDN)=$PIECE(PSBDATA,U,32)
SET PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
+55 if PSBOCRIT[PSBSTSX
SET PSBTOT=PSBTOT+1
+56 SET PSBSCHTY=$PIECE(PSBDATA,U,6)
+57 SET PSBSCHTY(PSBORDN,PSBSCHTY)=""
+58 SET PSBSCHD=$PIECE(PSBDATA,U,7)
IF PSBSCHD=""
SET PSBSCHD=" "
+59 SET PSBSCHD(PSBORDN,PSBSCHD)=""
+60 SET PSBDOSR=$PIECE(PSBDATA,U,10)_", "_$PIECE(PSBDATA,U,11)
+61 SET PSBDOSR=$TRANSLATE($EXTRACT(PSBDOSR,1)," ")_$EXTRACT(PSBDOSR,2,999)
+62 SET PSBDOSR(PSBORDN,PSBDOSR)=""
KILL PSBOMDR(PSBORDN)
+63 SET PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
+64 ;init *83
SET PSBNXTX2=""
+65 IF PSBSTS["Hold"
SET PSBNXTX2="Provider Hold"
+66 IF PSBSTS'["Hold"
Begin DoDot:4
End DoDot:4
+67 ;
+68 ;Next admin date triggers data for Next Action col, and also *83
+69 ; if a remove action is pending use that text for NA col. *83
+70 SET REMOV=$ORDER(^TMP("PSB",$JOB,"RM","B",PSBORDN,0))
+71 IF PSBSTS'["Hold"
IF ((PSBNXTX1)!(REMOV))
Begin DoDot:4
+72 ;build Admin Next Action text
+73 if PSBNXTX1
Begin DoDot:5
+74 SET NXTADM=$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT)
+75 SET PSBNXTX2=$SELECT(PSBNOWX>NXTADM:"MISSED ",1:"DUE ")_PSBNXTX1
End DoDot:5
+76 ;Removal tests and Next Action text build *83
+77 SET REMOV=$ORDER(^TMP("PSB",$JOB,"RM","B",PSBORDN,0))
+78 if REMOV
Begin DoDot:5
+79 SET MRR=$PIECE(PSBDATA(PSBX2X),U,35)
+80 SET RMVTIM=$PIECE(^TMP("PSB",$JOB,"RM",REMOV),U)
+81 ;Sched types below have no admin nor removal times, but do know
+82 ; this MRR was given and next is Removal
+83 IF ("^P^OC^"[("^"_PSBSCHTY_"^"))
if PSBSTS'["Hold"
SET PSBNXTX2="(Removal)"
QUIT
+84 ;sys err tst, sched rmv dt/tm empty, if null use nxt adm for rmv
+85 IF MRR=1
IF 'RMVTIM
SET RMVTIM=PSBNXTX1
+86 ;missed rm
IF PSBNOWX>$$FMADD^XLFDT(RMVTIM,,,PSBAFT)
Begin DoDot:6
+87 SET PSBNXTX2="MISSED "_RMVTIM_" (Removal)"
+88 ;err, rmv empty
if 'RMVTIM
SET PSBNXTX2="REMOVE"
End DoDot:6
+89 ;due rm
IF '$TEST
Begin DoDot:6
+90 SET PSBNXTX2="REMOVE "_RMVTIM
End DoDot:6
+91 KILL MRR,NXTADM,RMVTIM
End DoDot:5
End DoDot:4
+92 ;
+93 SET PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
+94 ;don't do if Expired Next action is a Removal *83
+95 IF PSBNXTX2'["Removal"
IF PSBNXTX2'["REMOVE"
Begin DoDot:4
+96 IF ("^P^OC^O"[(U_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired")
if PSBSTS'["Hold"
SET PSBNXTX2=" "
+97 ;P134
IF PSBNXTX2=""
SET PSBNXTX2=" "
End DoDot:4
+98 SET PSBNXTX(PSBORDN,PSBNXTX2)=""
+99 ; ** SPC INSTR **
+100 SET PSBX2X=PSBX2X+1
+101 ; *68
+102 KILL ^TMP("PSJBCMA5",$JOB)
+103 IF PSBSIFLG
DO GETSIOPI^PSJBCMA5(PSBX1X,PSBORDN,1)
+104 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,PSBX1X,PSBORDN,QQ))
if 'QQ
QUIT
Begin DoDot:4
+105 SET PSBSI(PSBORDN,QQ)=^TMP("PSJBCMA5",$JOB,PSBX1X,PSBORDN,QQ)
End DoDot:4
+106 ; *68 end
+107 SET PSBOSTDT=$PIECE(PSBDATA,U,22)
+108 SET PSBOSTDT(PSBORDN,PSBOSTDT)=""
+109 SET PSBOSPDT=$PIECE(PSBDATA,U,27)
+110 SET PSBOSPDT(PSBORDN,PSBOSPDT)=""
End DoDot:3
QUIT
+111 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA,U))
Begin DoDot:3
+112 FOR I=PSBX2X:1
SET PSBDATA1=PSBDATA(I)
Begin DoDot:4
+113 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA1,U))
SET PSBX2X=I
SET PSBDRUGN=$GET(PSBDRUGN,"")_$PIECE(PSBDATA1,U,3)_", "
QUIT
+114 SET $EXTRACT(PSBDRUGN,$LENGTH(PSBDRUGN)-1)=""
SET PSBDRUGN(PSBORDN,$EXTRACT(PSBDRUGN,1,250))=PSBDRUGN
+115 SET PSBOMDR(PSBORDN,$EXTRACT((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
End DoDot:4
if $DATA(PSBOMDR(PSBORDN))
QUIT
End DoDot:3
QUIT
+116 IF $PIECE(PSBDATA,U)="END"
QUIT
+117 IF $PIECE(PSBDATA(PSBX2X+1),U)="ORF"
Begin DoDot:3
+118 SET PSBX2X=PSBX2X+1
SET PSBDATA=PSBDATA(PSBX2X)
+119 if $PIECE(PSBDATA,U,2)]""
SET PSBFLGD(PSBORDN,$PIECE(PSBDATA,U,3)_" - "_$PIECE(PSBDATA,U,4))=""
End DoDot:3
QUIT
+120 IF ($PIECE(PSBDATA,U)="ADM")&($PIECE(PSBDATA,U,4)]"")
Begin DoDot:3
+121 SET PSBXID=$PIECE(PSBDATA,U,6)_U_$PIECE(PSBDATA,U,4)
SET PSBADM(PSBORDN,(-1*($PIECE(PSBDATA,U,6))),PSBXID)=PSBDATA
+122 IF $ORDER(PSBSCHTY(PSBORDN,""))="P"
SET PSBPRNR(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,9)
+123 IF $PIECE(PSBDATA,U,3)]""
SET PSBBID(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,3)
+124 if PSBXFLG
SET PSBLGD(PSBORDN,"X","INITIALS",$PIECE(PSBDATA,U,8))=""
+125 KILL PSBDATA(PSBX2X)
+126 IF ($PIECE(PSBDATA(PSBX2X+1),U)="CMT")
FOR
SET PSBDATA=PSBDATA(PSBX2X+1)
if ($PIECE(PSBDATA,U)'="CMT")
QUIT
Begin DoDot:4
+127 SET PSBX2X=PSBX2X+1
+128 SET PSBDATA=PSBDATA(PSBX2X)
+129 KILL PSBDATA(PSBX2X)
+130 if $PIECE(PSBDATA,U,3)]""
SET PSBPRNEF(PSBORDN,$PIECE(PSBXID,U,2))=$PIECE(PSBDATA,U,3)
+131 IF 'PSBCFLG
SET PSBDATA=PSBDATA(PSBX2X+1)
QUIT
+132 IF $PIECE(PSBDATA,U,2)'=""
Begin DoDot:5
+133 SET PSBLGD(PSBORDN,"C","INITIALS",$PIECE(PSBDATA,U,4))=""
+134 SET PSBCMT(PSBORDN,$PIECE(PSBXID,U,2),(-1*$PIECE(PSBDATA,U,6)),PSBX2X)=PSBDATA
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
STOP IF '$DATA(PSBLIST2)
KILL PSBLIST,^XTMP("PSBO",$JOB,"PSBLIST")
+1 DO CREATHDR
+2 DO SUBHDR
+3 DO BLDRPT
+4 DO WRTRPT
+5 QUIT
BLDRPT ; Buld RPT DATA
+1 SET X0=""
KILL PSBLIST2(" * NO * "),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=EXPIREHDG,"Expiring Today",FUTUREHDG
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'[PSBX1X
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
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(PSBSCHD(PSBX2X,""))
+21 SET PSBDATA(1,6)=$ORDER(PSBNXTX(PSBX2X,""))
+22 if PSBDATA(1,6)'["Hold"
SET $PIECE(PSBDATA(1,6)," ",2)=$$FMTDT^PSBOCE1($PIECE(PSBDATA(1,6)," ",2))
+23 SET PSBDATA(1,7)=$$FMTDT^PSBOCE1($ORDER(PSBOSTDT(PSBX2X,"")))
+24 SET PSBDATA(1,8)=$$FMTDT^PSBOCE1($EXTRACT($ORDER(PSBOSPDT(PSBX2X,"")),1,12))
+25 ;*68
KILL PSBSIDAT
MERGE PSBSIDAT=PSBSI(PSBX2X)
+26 SET PSBTOT1=PSBTOT1+1
+27 KILL PSBDATA(2),PSBDATA(3),PSBSILN
+28 DO BUILDLN^PSBOCE1
DO SIOPI^PSBOCM(.PSBSIDAT,PSBTAB8,$SELECT(PSBX2X["V":"Other Print Info: ",1:""))
+29 IF $DATA(PSBRPLN)
SET PSBMORE=$ORDER(PSBRPLN(""),-1)+6
IF $DATA(PSBSILN)
SET PSBMORE=PSBMORE+$ORDER(PSBSILN(""),-1)
+30 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
+31 ;*70 build write clinic stmt
+32 SET PSBOUTP($$PGTOT,PSBLNTOT)="W """_$GET(PSBCLIN(PSBX2X))_""""_",!"
+33 SET PSBCNT=PSBTOT1_" "_$GET(PSB1,"")
+34 SET PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
+35 SET I=""
FOR
SET I=$ORDER(PSBRPLN(I))
if +I=0
QUIT
Begin DoDot:3
+36 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
End DoDot:3
+37 SET I=""
FOR
SET I=$ORDER(PSBSILN(I))
if +I=0
QUIT
Begin DoDot:3
+38 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
End DoDot:3
+39 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
+40 KILL PSBRPLN,PSBDATA,PSBSILN
End DoDot:2
End DoDot:1
+41 if +PSBTOT>0
DO LGD^PSBOCM
+42 QUIT
WRTRPT ; writ
+1 IF $ORDER(PSBOUTP(""),-1)<1
Begin DoDot:1
+2 XECUTE PSBOUTP($ORDER(PSBOUTP(""),-1),21)
+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
+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 FTR
+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 EXPIRED/DC'd/EXPIRING ORDERS REPORT"
+4 if $PIECE(PSBRPT(.1),U,1)="P"
Begin DoDot:1
+5 SET PSBHDR(0)=PSBRPNM
+6 SET PSBHDR(1)="Order Status(es): --"
+7 FOR Y=7,8,9,10
IF $PIECE(PSBFUTR,U,Y)
SET $PIECE(PSBHDR(1),": ",2)=$PIECE(PSBHDR(1),": ",2)_$SELECT(PSBHDR(1)["--":"",1:"/ ")_$PIECE("^^^^^^Expired^DC'd^Expiring Today^"_FUTUREHDG_"^^^^^^^^",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 !,?(PSBTAB8-($LENGTH("Total Orders reported: "_+PSBTOT))),"Total Orders reported: "_+PSBTOT,!
SET PSBLNTOT=PSBLNTOT+2
+5 WRITE !,$TRANSLATE($JUSTIFY("",PSBTAB8)," ","_")
SET PSBLNTOT=PSBLNTOT+1
+6 WRITE !,$GET(PSBHD1,"")
SET PSBLNTOT=PSBLNTOT+1
+7 WRITE !,$GET(PSBHD2,"")
SET PSBLNTOT=PSBLNTOT+1
+8 WRITE !,$TRANSLATE($JUSTIFY("",PSBTAB8)," ","="),!
SET PSBLNTOT=PSBLNTOT+2
+9 IF $DATA(NOTE(PSBPGNUM))
WRITE NOTE(PSBPGNUM),!!
SET PSBLNTOT=PSBLNTOT+2
+10 QUIT
FTR ; Footr
+1 DO PTFTR^PSBOHDR()
+2 SET PSBPG="Page: "_PSBPGNUM_" of "_$SELECT($ORDER(PSBOUTP(""),-1)=0:1,1:$ORDER(PSBOUTP(""),-1))
+3 SET PSBPGRM=PSBTAB8-($LENGTH(PSBPG))
+4 WRITE !,PSBRPNM," ",?(PSBPGRM-($LENGTH(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
+5 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
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 ; 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 ;~ VDL | Status |Type| Medication; Dosage, Route | Schedule | Next | Order Start | Order Stop |
+1 QUIT
HD132B ; Tab | | | | | Action | Date | Date |
+1 QUIT
H132BLK ;; | | | | | | | |
+1 QUIT
