PSBOCM ;BIRMINGHAM/TEJ-COVERSHEET MEDICATION OVERVIEW REPORT ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**32,50**;Mar 2004;Build 78
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; File 4/10090
; File 200/10060
EN ;
N PSBX1X,RESULTS,RESULT,PSBFUTR
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
K PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD,PSBHDR,PSBSTS
S PSBSORT=1
D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=$E(Y,1,18)
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,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)
.M PSBDATA=@PSBAREA
.S PSBX2X=1
.S PSBLIST2("ACTIVE")=0,PSBLIST2("FUTURE")=0,PSBLIST2("EXPIRED/DC'd")=0,PSBLIST2(" * ERROR * ")=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 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 PSBSTSX=$S($P(PSBDATA,U,27)'>PSBNOWX:"EXPIRED/DC'd",$$FMADD^XLFDT($P(PSBDATA,U,22),,,-PSBB4)'>PSBNOWX:"ACTIVE",$P(PSBDATA,U,22)>$$FMADD^XLFDT(PSBNOWX,,,PSBB4):"FUTURE",1:" * ERROR * ")
...S PSBLIST2(PSBSTSX,$P(PSBDATA,U,9),PSBORDN)="" S PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
...S:PSBOCRIT[$E(PSBSTSX,1) PSBTOT=PSBTOT+1
...S PSBSCHTY=$P(PSBDATA,U,6)
...I PSBTB="IV" S PSBSCHTY=" "
...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)="" K PSBOMDR(PSBORDN)
...S PSBSCHD=$P(PSBDATA,U,7) I PSBSCHD="" S PSBSCHD=" "
...S PSBSCHD(PSBORDN,PSBSCHD)=""
...S PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
...I PSBSTS["Hold" S PSBNXTX2="Provider Hold"
...I PSBSTS'["Hold",(PSBNXTX1]"") D
....I PSBNOWX>$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT) S PSBNXTX2="MISSED "_PSBNXTX1
....E S:+PSBNXTX1>0 PSBNXTX2="DUE "_PSBNXTX1
...S PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
...I ("^P^OC^O"[("^"_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired") S:PSBSTS'["Hold" PSBNXTX2=" "
...S PSBNXTX(PSBORDN,$G(PSBNXTX2," "))=""
...; ** SPECIAL INSTRUCTIONS **
...S PSBX2X=PSBX2X+1
...S PSBSI=$P(PSBDATA(PSBX2X),U,2)
...I PSBSI]" " S PSBSI(PSBORDN,PSBSI)=""
...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(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
..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))=""
..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
...S PSBTEST="" F S PSBTEST=$O(PSBFLGD(PSBORDN,PSBTEST)) Q:PSBTEST="" I $P(PSBTEST,":")="NOX" K PSBFLGD(PSBORDN,PSBTEST) Q
...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
I +PSBTOT=0 K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
D CREATHDR^PSBOCM1
D SUBHDR^PSBOCE
D BLDRPT
D WRTRPT^PSBOCM1
Q
BLDRPT ; Buld REPORT DATA
S PSBTOPHD=PSBLNTOT-2
K PSBL2ULN
I '$D(PSBLIST2) D Q
.S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
S PSBMORE=5 F PSBX1X="ACTIVE","FUTURE","EXPIRED/DC'd"," * 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(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))
..S PSBSIDAT(1)=$O(PSBSI(PSBX2X,""))
..S PSBTOT1=PSBTOT1+1
..K PSBDATA(2),PSBDATA(3),PSBSILN
..D BUILDLN^PSBOCM1,SIOPI(.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,X 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
..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
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
SIOPI(PSBXSI,TAB,Y) ;
Q:$G(PSBXSI(1))']""
I $G(Y,"")']"" S Y="Special Instructions: "
S PSBXSI(1)=" "_Y_PSBXSI(1)
N X
K J,TXT1,TXT2 S J(0)=""
S J=($O(J(""),-1)+1) S PSBSILN(J)="",J(J)="" S J=($O(J(""),-1)+1)
F X=1:1 Q:'$D(PSBXSI(X)) D
.S TXT1=PSBXSI(X)
.I ($L(TXT1)>0),$F(TXT1,"""")>1 D
..S TXT1=$TR(TXT1,"""","^")
..I $L(TXT1)+5'<TAB S TXT2=$E(TXT1,TAB-9,999),TXT1=$E(TXT1,1,TAB-10)
..I $L(TXT1,"^")>1 F Y=1:1:$L(TXT1,"^")-1 S $P(TXT1,"^",Y)=$P(TXT1,"^",Y)_""""
..I $D(TXT2) I $L(TXT2,"^")>1 F X=1:1:$L(TXT2,"^")-1 S $P(TXT2,"^",X)=$P(TXT2,"^",X)_""""
..S TXT1=$TR(TXT1,"^","""") I $D(TXT2) S TXT2=$TR(TXT2,"^","""")
.S $E(PSBSILN(J),5,999)=TXT1,J(J)="",J=J+1
.I $D(TXT2) S $E(PSBSILN(J),5,999)=TXT2,J(J)="",J=J+1
S $E(PSBSILN(J),3,999)=" ",J(J)="",J=J+1
Q
LGD ; Create Report's Legend
K PSBLGDO
S PSBLGD("ORDER TYPES","C")="Continuous"
S PSBLGD("ORDER TYPES","O")="One Time"
S PSBLGD("ORDER TYPES","OC")="On Call"
S PSBLGD("ORDER TYPES","P")="PRN"
S PSB=0 F S PSB=$O(PSBLGD("INITIALS",PSB)) Q:+PSB=0 D
.S PSBINIT=$$GET1^DIQ(200,PSB_",","INITIAL"),PSBLGD("INITIALS",$S(PSBINIT']" ":"*n/a*",1:PSBINIT))=$$GET1^DIQ(200,PSB_",","NAME")
.K PSBLGD("INITIALS",PSB)
S PSBPGNUM=$O(PSBOUTP(""),-1),PSBLGDO(0)="REPORT LEGEND"
S PSBLGDO(1)=""
S PSBLGDO(2)=$S($G(PSBNO,0):"",1:"SCHEDULE TYPES")
S PSBLGDO(3)=""
I '$G(PSBNO,0) S X1="",X2=3 F S X1=$O(PSBLGD("ORDER TYPES",X1)) Q:X1="" S X2=X2+1,PSBLGDO(X2)=X1,$E(PSBLGDO(X2),5)="- "_PSBLGD("ORDER TYPES",X1)
I $D(PSBLGD("INITIALS")) S $E(PSBLGDO(2),35)="INITIALS" S X1="",X2=3 F S X1=$O(PSBLGD("INITIALS",X1)) Q:X1="" S X2=X2+1,$E(PSBLGDO(X2),35)=X1,$E(PSBLGDO(X2),40)="- "_PSBLGD("INITIALS",X1)
S (PSBMORE,X0)=10+($O(PSBLGDO(""),-1))
I (PSBLNTOT+PSBMORE)'<IOSL S PSBLNTOT=PSBTOPHD-2,PSBPGNUM=PSBPGNUM+1
I IOSL<1000 S X2=PSBLNTOT F Q:X2'<(IOSL-(X0+3)) S PSBOUTP($$PGTOT,PSBLNTOT)="W !",X2=X2+1
S PSBMORE=X0
S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TR($J("",IOM)," ","=")_""",!"
F X1=0:1 Q:'$D(PSBLGDO(X1)) S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_$G(PSBLGDO(X1)," ")_""""
S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TR($J("",IOM)," ","=")_""",!"
Q
PSBOCM ;BIRMINGHAM/TEJ-COVERSHEET MEDICATION OVERVIEW REPORT ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**32,50**;Mar 2004;Build 78
+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 ; File 200/10060
EN ;
+1 NEW PSBX1X,RESULTS,RESULT,PSBFUTR
+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 KILL PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD,PSBHDR,PSBSTS
+9 SET PSBSORT=1
+10 DO NOW^%DTC
SET (Y,PSBNOWX)=%
DO DD^%DT
SET PSBDTTM=$EXTRACT(Y,1,18)
+11 DO GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
+12 SET PSBB4=0
IF RESULTS(0)>0
SET PSBB4=+RESULTS(0)
+13 DO GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
+14 SET PSBAFT=0
IF RESULTS(0)>0
SET PSBAFT=+RESULTS(0)
+15 KILL ^XTMP("PSBO",$JOB,"PSBLIST")
+16 SET (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
+17 KILL PSBLIST,PSBLIST2
+18 SET PSBXDFN=$PIECE(PSBRPT(.1),U,2)
+19 SET PSBLIST(PSBXDFN)=""
+20 SET (PSBX1X,PSBTOT)=0
+21 FOR
SET PSBX1X=$ORDER(PSBLIST(PSBX1X))
IF +PSBX1X=0
QUIT
Begin DoDot:1
+22 DO RPC^PSBCSUTL(.PSBAREA,PSBX1X)
+23 MERGE PSBDATA=@PSBAREA
+24 SET PSBX2X=1
+25 SET PSBLIST2("ACTIVE")=0
SET PSBLIST2("FUTURE")=0
SET PSBLIST2("EXPIRED/DC'd")=0
SET PSBLIST2(" * ERROR * ")=0
+26 FOR
SET PSBX2X=$ORDER(PSBDATA(PSBX2X))
IF +PSBX2X=0
QUIT
Begin DoDot:2
+27 SET PSBDATA=PSBDATA(PSBX2X)
+28 IF $PIECE(PSBDATA,U)="ORD"
Begin DoDot:3
+29 KILL PSBDRUGN
+30 SET PSBORDN=$PIECE(PSBDATA,U,3)
+31 SET PSBTB=$PIECE(PSBDATA,U,29)
SET PSBTB=$SELECT(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
+32 SET PSBTB(PSBORDN,PSBTB)=""
+33 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 * ")
+34 SET PSBSTS(PSBORDN,PSBSTS)=""
+35 SET PSBSTSX=$SELECT($PIECE(PSBDATA,U,27)'>PSBNOWX:"EXPIRED/DC'd",$$FMADD^XLFDT($PIECE(PSBDATA,U,22),,,-PSBB4)'>PSBNOWX:"ACTIVE",$PIECE(PSBDATA,U,22)>$$FMADD^XLFDT(PSBNOWX,,,PSBB4):"FUTURE",1:" * ERROR * ")
+36 SET PSBLIST2(PSBSTSX,$PIECE(PSBDATA,U,9),PSBORDN)=""
SET PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
+37 IF PSBOCRIT[$EXTRACT(PSBSTSX,1)
SET PSBTOT=PSBTOT+1
+38 SET PSBSCHTY=$PIECE(PSBDATA,U,6)
+39 IF PSBTB="IV"
SET PSBSCHTY=" "
+40 SET PSBSCHTY(PSBORDN,PSBSCHTY)=""
+41 SET PSBDOSR=$PIECE(PSBDATA,U,10)_", "_$PIECE(PSBDATA,U,11)
+42 SET PSBDOSR=$TRANSLATE($EXTRACT(PSBDOSR,1)," ")_$EXTRACT(PSBDOSR,2,999)
+43 SET PSBDOSR(PSBORDN,PSBDOSR)=""
KILL PSBOMDR(PSBORDN)
+44 SET PSBSCHD=$PIECE(PSBDATA,U,7)
IF PSBSCHD=""
SET PSBSCHD=" "
+45 SET PSBSCHD(PSBORDN,PSBSCHD)=""
+46 SET PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
+47 IF PSBSTS["Hold"
SET PSBNXTX2="Provider Hold"
+48 IF PSBSTS'["Hold"
IF (PSBNXTX1]"")
Begin DoDot:4
+49 IF PSBNOWX>$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT)
SET PSBNXTX2="MISSED "_PSBNXTX1
+50 IF '$TEST
IF +PSBNXTX1>0
SET PSBNXTX2="DUE "_PSBNXTX1
End DoDot:4
+51 SET PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
+52 IF ("^P^OC^O"[("^"_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired")
IF PSBSTS'["Hold"
SET PSBNXTX2=" "
+53 SET PSBNXTX(PSBORDN,$GET(PSBNXTX2," "))=""
+54 ; ** SPECIAL INSTRUCTIONS **
+55 SET PSBX2X=PSBX2X+1
+56 SET PSBSI=$PIECE(PSBDATA(PSBX2X),U,2)
+57 IF PSBSI]" "
SET PSBSI(PSBORDN,PSBSI)=""
+58 SET PSBOSTDT=$PIECE(PSBDATA,U,22)
+59 SET PSBOSTDT(PSBORDN,PSBOSTDT)=""
+60 SET PSBOSPDT=$PIECE(PSBDATA,U,27)
+61 SET PSBOSPDT(PSBORDN,PSBOSPDT)=""
End DoDot:3
QUIT
+62 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA(PSBX2X),U))
Begin DoDot:3
+63 FOR I=PSBX2X:1
SET PSBDATA1=PSBDATA(I)
Begin DoDot:4
+64 IF "^DD^ADD^SOL"[(U_$PIECE(PSBDATA1,U))
SET PSBX2X=I
SET PSBDRUGN=$GET(PSBDRUGN,"")_$PIECE(PSBDATA1,U,3)_", "
QUIT
+65 SET $EXTRACT(PSBDRUGN,$LENGTH(PSBDRUGN)-1)=""
SET PSBDRUGN(PSBORDN,$EXTRACT(PSBDRUGN,1,250))=PSBDRUGN
+66 SET PSBOMDR(PSBORDN,$EXTRACT((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
End DoDot:4
IF $DATA(PSBOMDR(PSBORDN))
QUIT
End DoDot:3
QUIT
+67 IF $PIECE(PSBDATA,U)="END"
QUIT
+68 IF $PIECE(PSBDATA(PSBX2X),U)="ORF"
Begin DoDot:3
+69 SET PSBDATA=PSBDATA(PSBX2X)
+70 IF $PIECE(PSBDATA,U,2)]""
SET PSBFLGD(PSBORDN,$PIECE(PSBDATA,U,3)_" - "_$PIECE(PSBDATA,U,4))=""
End DoDot:3
QUIT
+71 IF ($PIECE(PSBDATA,U)="ADM")&($PIECE(PSBDATA,U,4)]"")
Begin DoDot:3
+72 SET PSBXID=$PIECE(PSBDATA,U,6)_U_$PIECE(PSBDATA,U,4)
SET PSBADM(PSBORDN,(-1*($PIECE(PSBDATA,U,6))),PSBXID)=PSBDATA
+73 SET PSBTEST=""
FOR
SET PSBTEST=$ORDER(PSBFLGD(PSBORDN,PSBTEST))
IF PSBTEST=""
QUIT
IF $PIECE(PSBTEST,":")="NOX"
KILL PSBFLGD(PSBORDN,PSBTEST)
QUIT
+74 IF $ORDER(PSBSCHTY(PSBORDN,""))="P"
SET PSBPRNR(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,9)
+75 IF $PIECE(PSBDATA,U,3)]""
SET PSBBID(PSBORDN,$PIECE(PSBDATA,U,4))=$PIECE(PSBDATA,U,3)
+76 IF PSBXFLG
SET PSBLGD(PSBORDN,"X","INITIALS",$PIECE(PSBDATA,U,8))=""
+77 KILL PSBDATA(PSBX2X)
+78 IF ($PIECE(PSBDATA(PSBX2X+1),U)="CMT")
FOR
SET PSBDATA=PSBDATA(PSBX2X+1)
IF ($PIECE(PSBDATA,U)'="CMT")
QUIT
Begin DoDot:4
+79 SET PSBX2X=PSBX2X+1
+80 SET PSBDATA=PSBDATA(PSBX2X)
+81 KILL PSBDATA(PSBX2X)
+82 IF $PIECE(PSBDATA,U,3)]""
SET PSBPRNEF(PSBORDN,$PIECE(PSBXID,U,2))=$PIECE(PSBDATA,U,3)
+83 IF 'PSBCFLG
SET PSBDATA=PSBDATA(PSBX2X+1)
QUIT
+84 IF $PIECE(PSBDATA,U,2)'=""
Begin DoDot:5
+85 SET PSBLGD(PSBORDN,"C","INITIALS",$PIECE(PSBDATA,U,4))=""
+86 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
+87 IF +PSBTOT=0
KILL PSBLIST,^XTMP("PSBO",$JOB,"PSBLIST")
+88 DO CREATHDR^PSBOCM1
+89 DO SUBHDR^PSBOCE
+90 DO BLDRPT
+91 DO WRTRPT^PSBOCM1
+92 QUIT
BLDRPT ; Buld REPORT DATA
+1 SET PSBTOPHD=PSBLNTOT-2
+2 KILL PSBL2ULN
+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","EXPIRED/DC'd"," * 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(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 SET PSBSIDAT(1)=$ORDER(PSBSI(PSBX2X,""))
+26 SET PSBTOT1=PSBTOT1+1
+27 KILL PSBDATA(2),PSBDATA(3),PSBSILN
+28 DO BUILDLN^PSBOCM1
DO SIOPI(.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,X
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 SET PSBCNT=PSBTOT1_" "_$GET(PSB1,"")
+32 SET PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
+33 SET I=""
FOR
SET I=$ORDER(PSBRPLN(I))
IF +I=0
QUIT
Begin DoDot:3
+34 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
End DoDot:3
+35 SET I=""
FOR
SET I=$ORDER(PSBSILN(I))
IF +I=0
QUIT
Begin DoDot:3
+36 SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
End DoDot:3
+37 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
+38 KILL PSBRPLN,PSBDATA,PSBSILN
End DoDot:2
End DoDot:1
+39 IF +PSBTOT>0
DO LGD
+40 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
SIOPI(PSBXSI,TAB,Y) ;
+1 IF $GET(PSBXSI(1))']""
QUIT
+2 IF $GET(Y,"")']""
SET Y="Special Instructions: "
+3 SET PSBXSI(1)=" "_Y_PSBXSI(1)
+4 NEW X
+5 KILL J,TXT1,TXT2
SET J(0)=""
+6 SET J=($ORDER(J(""),-1)+1)
SET PSBSILN(J)=""
SET J(J)=""
SET J=($ORDER(J(""),-1)+1)
+7 FOR X=1:1
IF '$DATA(PSBXSI(X))
QUIT
Begin DoDot:1
+8 SET TXT1=PSBXSI(X)
+9 IF ($LENGTH(TXT1)>0)
IF $FIND(TXT1,"""")>1
Begin DoDot:2
+10 SET TXT1=$TRANSLATE(TXT1,"""","^")
+11 IF $LENGTH(TXT1)+5'<TAB
SET TXT2=$EXTRACT(TXT1,TAB-9,999)
SET TXT1=$EXTRACT(TXT1,1,TAB-10)
+12 IF $LENGTH(TXT1,"^")>1
FOR Y=1:1:$LENGTH(TXT1,"^")-1
SET $PIECE(TXT1,"^",Y)=$PIECE(TXT1,"^",Y)_""""
+13 IF $DATA(TXT2)
IF $LENGTH(TXT2,"^")>1
FOR X=1:1:$LENGTH(TXT2,"^")-1
SET $PIECE(TXT2,"^",X)=$PIECE(TXT2,"^",X)_""""
+14 SET TXT1=$TRANSLATE(TXT1,"^","""")
IF $DATA(TXT2)
SET TXT2=$TRANSLATE(TXT2,"^","""")
End DoDot:2
+15 SET $EXTRACT(PSBSILN(J),5,999)=TXT1
SET J(J)=""
SET J=J+1
+16 IF $DATA(TXT2)
SET $EXTRACT(PSBSILN(J),5,999)=TXT2
SET J(J)=""
SET J=J+1
End DoDot:1
+17 SET $EXTRACT(PSBSILN(J),3,999)=" "
SET J(J)=""
SET J=J+1
+18 QUIT
LGD ; Create Report's Legend
+1 KILL PSBLGDO
+2 SET PSBLGD("ORDER TYPES","C")="Continuous"
+3 SET PSBLGD("ORDER TYPES","O")="One Time"
+4 SET PSBLGD("ORDER TYPES","OC")="On Call"
+5 SET PSBLGD("ORDER TYPES","P")="PRN"
+6 SET PSB=0
FOR
SET PSB=$ORDER(PSBLGD("INITIALS",PSB))
IF +PSB=0
QUIT
Begin DoDot:1
+7 SET PSBINIT=$$GET1^DIQ(200,PSB_",","INITIAL")
SET PSBLGD("INITIALS",$SELECT(PSBINIT']" ":"*n/a*",1:PSBINIT))=$$GET1^DIQ(200,PSB_",","NAME")
+8 KILL PSBLGD("INITIALS",PSB)
End DoDot:1
+9 SET PSBPGNUM=$ORDER(PSBOUTP(""),-1)
SET PSBLGDO(0)="REPORT LEGEND"
+10 SET PSBLGDO(1)=""
+11 SET PSBLGDO(2)=$SELECT($GET(PSBNO,0):"",1:"SCHEDULE TYPES")
+12 SET PSBLGDO(3)=""
+13 IF '$GET(PSBNO,0)
SET X1=""
SET X2=3
FOR
SET X1=$ORDER(PSBLGD("ORDER TYPES",X1))
IF X1=""
QUIT
SET X2=X2+1
SET PSBLGDO(X2)=X1
SET $EXTRACT(PSBLGDO(X2),5)="- "_PSBLGD("ORDER TYPES",X1)
+14 IF $DATA(PSBLGD("INITIALS"))
SET $EXTRACT(PSBLGDO(2),35)="INITIALS"
SET X1=""
SET X2=3
FOR
SET X1=$ORDER(PSBLGD("INITIALS",X1))
IF X1=""
QUIT
SET X2=X2+1
SET $EXTRACT(PSBLGDO(X2),35)=X1
SET $EXTRACT(PSBLGDO(X2),40)="- "_PSBLGD("INITIALS",X1)
+15 SET (PSBMORE,X0)=10+($ORDER(PSBLGDO(""),-1))
+16 IF (PSBLNTOT+PSBMORE)'<IOSL
SET PSBLNTOT=PSBTOPHD-2
SET PSBPGNUM=PSBPGNUM+1
+17 IF IOSL<1000
SET X2=PSBLNTOT
FOR
IF X2'<(IOSL-(X0+3))
QUIT
SET PSBOUTP($$PGTOT,PSBLNTOT)="W !"
SET X2=X2+1
+18 SET PSBMORE=X0
+19 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TRANSLATE($JUSTIFY("",IOM)," ","=")_""",!"
+20 FOR X1=0:1
IF '$DATA(PSBLGDO(X1))
QUIT
SET PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_$GET(PSBLGDO(X1)," ")_""""
+21 SET PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TRANSLATE($JUSTIFY("",IOM)," ","=")_""",!"
+22 QUIT
