PSBOCP1 ;BIRMINGHAM/TEJ-COVERSHEET PRN OVERVIEW REPORT ;8/16/12 2:57pm
;;3.0;BAR CODE MED ADMIN;**32,70**;Mar 2004;Build 101
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
;*70 - add new header line for clinic search list
;
WRTRPT ; writ
I $O(PSBOUTP(""),-1)<1 D Q
.X PSBOUTP($O(PSBOUTP(""),-1),14)
.D FTR
S PSBPGNUM=1
S PSBZ="" F S PSBZ=$O(PSBOUTP(PSBZ)) Q:PSBZ="" D
.I PSBPGNUM'=PSBZ D FTR S PSBPGNUM=PSBZ D HDR,SUBHDR^PSBOCE
.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
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" Q
; reset tabs
S PSBTAB0=1 F PSBI=0:1:($L(PSBHD1,"|")-1) S:PSBI>0 @("PSBTAB"_PSBI)=($F(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
S PSBPGNUM=1
D HDR
Q
HD132A ;~ VDL | Status |Type| Medication; Dosage, Route | Last Given | Since | Order Start | Order Stop |
Q
HD132B ; Tab | | | | | Last Given | Date | Date |
Q
C132BLK ;; | | | | | | | |
Q
HDR ; Header
W:$Y>1 @IOF
W:$X>1 !
S PSBRPNM="BCMA COVERSHEET PRN OVERVIEW REPORT"
D:$P(PSBRPT(.1),U,1)="P"
.S PSBHDR(0)=PSBRPNM
.S PSBHDR(1)="Order Status(es): --"
.F Y=4,5,7,8 I $P(PSBFUTR,U,Y) S $P(PSBHDR(1),": ",2)=$P(PSBHDR(1),": ",2)_$S(PSBHDR(1)["--":"",1:"/ ")_$P("^^^Future^Active^^Expired^DC'd^^^^^^^^^^",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
FTR ; Fter
S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
S PSBPGRM=PSBTAB8-($L(PSBPG))
D PTFTR^PSBOHDR()
W !,PSBRPNM," ",?(PSBPGRM-($L(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOCP1 2251 printed Nov 22, 2024@16:50:42 Page 2
PSBOCP1 ;BIRMINGHAM/TEJ-COVERSHEET PRN OVERVIEW REPORT ;8/16/12 2:57pm
+1 ;;3.0;BAR CODE MED ADMIN;**32,70**;Mar 2004;Build 101
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ;*70 - add new header line for clinic search list
+5 ;
WRTRPT ; writ
+1 IF $ORDER(PSBOUTP(""),-1)<1
Begin DoDot:1
+2 XECUTE PSBOUTP($ORDER(PSBOUTP(""),-1),14)
+3 DO FTR
End DoDot:1
QUIT
+4 SET PSBPGNUM=1
+5 SET PSBZ=""
FOR
SET PSBZ=$ORDER(PSBOUTP(PSBZ))
if PSBZ=""
QUIT
Begin DoDot:1
+6 IF PSBPGNUM'=PSBZ
DO FTR
SET PSBPGNUM=PSBZ
DO HDR
DO SUBHDR^PSBOCE
+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
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"
QUIT
+4 ; reset tabs
+5 SET PSBTAB0=1
FOR PSBI=0:1:($LENGTH(PSBHD1,"|")-1)
if PSBI>0
SET @("PSBTAB"_PSBI)=($FIND(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
+6 SET PSBPGNUM=1
+7 DO HDR
+8 QUIT
HD132A ;~ VDL | Status |Type| Medication; Dosage, Route | Last Given | Since | Order Start | Order Stop |
+1 QUIT
HD132B ; Tab | | | | | Last Given | Date | Date |
+1 QUIT
C132BLK ;; | | | | | | | |
+1 QUIT
HDR ; Header
+1 if $Y>1
WRITE @IOF
+2 if $X>1
WRITE !
+3 SET PSBRPNM="BCMA COVERSHEET PRN OVERVIEW 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=4,5,7,8
IF $PIECE(PSBFUTR,U,Y)
SET $PIECE(PSBHDR(1),": ",2)=$PIECE(PSBHDR(1),": ",2)_$SELECT(PSBHDR(1)["--":"",1:"/ ")_$PIECE("^^^Future^Active^^Expired^DC'd^^^^^^^^^^",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
FTR ; Fter
+1 SET PSBPG="Page: "_PSBPGNUM_" of "_$SELECT($ORDER(PSBOUTP(""),-1)=0:1,1:$ORDER(PSBOUTP(""),-1))
+2 SET PSBPGRM=PSBTAB8-($LENGTH(PSBPG))
+3 DO PTFTR^PSBOHDR()
+4 WRITE !,PSBRPNM," ",?(PSBPGRM-($LENGTH(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
+5 QUIT
