PSBOPE ;BIRMINGHAM/EFC-PRN EFFECTIVENESS WORKSHEET ;8/12/12 10:57pm
;;3.0;BAR CODE MED ADMIN;**5,23,32,70,78,72**;Mar 2004;Build 16
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; ^DPT/10035
; EN^PSJBCMA/2828
;
;*70 - reset PSBCLINORD = 2 to signify combined orders report
;
EN ; Called from DQ^PSBO
N PSBSTRT,PSBSTOP,DFN
K ^TMP("PSB",$J)
S PSBSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)
S PSBSTOP=$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
F DFN=0:0 S DFN=$O(^TMP("PSBO",$J,DFN)) Q:'DFN D EN1
D PRINT
K ^TMP("PSJ",$J),^TMP("PSB",$J)
Q
;
EN1 ; Expects DFN,PSBSTRT,PSBSTOP from EN
N PSBGBL,PSBHDR,PSBX,PSBADMIN,PSBDFN,PSBDT,PSBMED,PSBORD,PSBOSTRT,PSBSCHED
K ^TMP("PSJ",$J)
S PSBDT=PSBSTRT-.0000001
F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D
.S PSBIEN=0
.F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN D
..Q:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="P" ; Not a PRN Administration
..Q:$P($G(^PSB(53.79,PSBIEN,.2)),U,2)]"" ; Effectiveness entered
..Q:($P($G(^PSB(53.79,PSBIEN,0)),U,9)'="G")&($P($G(^PSB(53.79,PSBIEN,0)),U,9)'="RM") ;Allow only entries with at status of "GIVEN" and "REMOVED"
..Q:$P($G(^PSB(53.79,PSBIEN,0)),U,6)<PSBDT
..Q:$P($G(^PSB(53.79,PSBIEN,0)),U,6)>PSBSTOP
..S ^TMP("PSB",$J,DFN,PSBIEN)=""
Q
PRINT ; Print meds stored in ^TMP("PSB",$J,DFN,....
N PSBHDR,PSBDT,PSBMED,DFN
;
; Print by Patient
;
D:$P(PSBRPT(.1),U,1)="P"
.S PSBHDR(1)="PRN EFFECTIVENESS LIST for "_$$FMTE^XLFDT(PSBSTRT)_" to "_$$FMTE^XLFDT(PSBSTOP)
.S DFN=$P(PSBRPT(.1),U,2)
.W $$PTHDR()
.I '$O(^TMP("PSB",$J,DFN,0)) W !,"No PRN Medications Found",$$PTFTR^PSBOHDR() Q
.W ! ; Line Break Between Admin Times
.S PSBIEN=""
.F S PSBIEN=$O(^TMP("PSB",$J,DFN,PSBIEN)) Q:PSBIEN="" D
..S PSBIENS=PSBIEN_","
..I $Y>(IOSL-5) W $$PTFTR^PSBOHDR(),$$PTHDR()
..W !,$$GET1^DIQ(53.79,PSBIENS,.06),?30,$$GET1^DIQ(53.79,PSBIENS,.08),?64,$$GETINIT^PSBCSUTX(PSBIEN,"N") ;*70 - Get name of who took action, PSB*3*72
..W ?102,$$GET1^DIQ(53.79,PSBIENS,"PATIENT LOCATION") ;*70
..W !,?5,"PRN Reason: ",$$GET1^DIQ(53.79,PSBIENS,.21)
.W $$PTFTR^PSBOHDR()
.Q
;
; Print by Ward
;
D:$P(PSBRPT(.1),U,1)="W"
.S PSBHDR(1)="PRN EFFECTIVENESS LIST from "_$$FMTE^XLFDT(PSBSTRT)_" thru "_$$FMTE^XLFDT(PSBSTOP)
.S PSBWARD=$P(PSBRPT(.1),U,3)
.W $$WRDHDR()
.I '$O(^TMP("PSB",$J,0)) W !,"No PRN Medications Found" Q
.S PSBSORT=$P(PSBRPT(.1),U,5)
.F DFN=0:0 S DFN=$O(^TMP("PSB",$J,DFN)) Q:'DFN D
..S PSBINDX=$S(PSBSORT="P":$P(^DPT(DFN,0),U),1:$G(^DPT(DFN,.1))_" "_$G(^DPT(DFN,.101))) ;PSB*3*23
..S:PSBINDX="" PSBINDX=$P(^DPT(DFN,0),U)
..S ^TMP("PSB",$J,"B",PSBINDX,DFN)=""
.S PSBINDX=""
.F S PSBINDX=$O(^TMP("PSB",$J,"B",PSBINDX)) Q:PSBINDX="" D
..F DFN=0:0 S DFN=$O(^TMP("PSB",$J,"B",PSBINDX,DFN)) Q:'DFN D
...W ! ; Line Break Between Pt's
...W:$P(PSBRPT(.1),U,5)="P" !,$$GET1^DIQ(2,DFN_",",.01),?32,$$GET1^DIQ(2,DFN_",",.1)," ",$$GET1^DIQ(2,DFN_",",.101)
...W:$P(PSBRPT(.1),U,5)="B" !,$$GET1^DIQ(2,DFN_",",.1)," ",$$GET1^DIQ(2,DFN_",",.101),?20,$$GET1^DIQ(2,DFN_",",.01)
...W ! ; Line Break Between Admin Times
...S PSBIEN=""
...F S PSBIEN=$O(^TMP("PSB",$J,DFN,PSBIEN)) Q:PSBIEN="" D
....I $Y>(IOSL-5) W $$WRDHDR()
....W !?5,$$GET1^DIQ(53.79,PSBIEN_",",.06),?35,$$GET1^DIQ(53.79,PSBIEN_",",.08),?68,$$GETINIT^PSBCSUTX(PSBIEN,"N") ;*70 - Get name of who took action, PSB*3*72
....W ?102,$$GET1^DIQ(53.79,PSBIEN_",","PATIENT LOCATION") ;*70
....W !?10,"PRN Reason: ",$$GET1^DIQ(53.79,PSBIEN_",",.21)
Q
;
WRDHDR() ; Ward Header
N PSBSRCHL ;Add PSBSRCHL variable and additional PSBHDR array spacers for PSBOHDR call, PSB*3*78
S PSBSRCHL=$$SRCHLIST^PSBOHDR()
S PSBHDR(2)="",PSBHDR(3)="",PSBHDR(4)="Ward Location: "
N PSBCLINORD S PSBCLINORD=2 ;2 = both order types *70
D WARD^PSBOHDR(PSBWRD,.PSBHDR,,,PSBSRCHL)
W:$P(PSBRPT(.1),U,5)="B" !,"Ward Rm-Bed",?20,"Patient"
W:$P(PSBRPT(.1),U,5)="P" !,"Patient",?32,"Ward Rm-Bed"
;adjust name of headings and colums to make room for Location ;*70
W !?5,"Admin Date/Time",?35,"Medication",?68,"Administered By" ;*70
W ?102,"Location" ;*70
W !,$TR($J("",IOM)," ","-")
Q ""
;
PTHDR() ; Patient Header
N PSBCLINORD S PSBCLINORD=2 ;2 = both order types *70
D PT^PSBOHDR(DFN,.PSBHDR)
W !,"Admin Date/Time",?30,"Medication",?64,"Administered By"
W ?102,"Location"
W !,$TR($J("",IOM)," ","-")
Q ""
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOPE 4594 printed Sep 23, 2025@19:16:47 Page 2
PSBOPE ;BIRMINGHAM/EFC-PRN EFFECTIVENESS WORKSHEET ;8/12/12 10:57pm
+1 ;;3.0;BAR CODE MED ADMIN;**5,23,32,70,78,72**;Mar 2004;Build 16
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; ^DPT/10035
+6 ; EN^PSJBCMA/2828
+7 ;
+8 ;*70 - reset PSBCLINORD = 2 to signify combined orders report
+9 ;
EN ; Called from DQ^PSBO
+1 NEW PSBSTRT,PSBSTOP,DFN
+2 KILL ^TMP("PSB",$JOB)
+3 SET PSBSTRT=$PIECE(PSBRPT(.1),U,6)+$PIECE(PSBRPT(.1),U,7)
+4 SET PSBSTOP=$PIECE(PSBRPT(.1),U,8)+$PIECE(PSBRPT(.1),U,9)
+5 FOR DFN=0:0
SET DFN=$ORDER(^TMP("PSBO",$JOB,DFN))
if 'DFN
QUIT
DO EN1
+6 DO PRINT
+7 KILL ^TMP("PSJ",$JOB),^TMP("PSB",$JOB)
+8 QUIT
+9 ;
EN1 ; Expects DFN,PSBSTRT,PSBSTOP from EN
+1 NEW PSBGBL,PSBHDR,PSBX,PSBADMIN,PSBDFN,PSBDT,PSBMED,PSBORD,PSBOSTRT,PSBSCHED
+2 KILL ^TMP("PSJ",$JOB)
+3 SET PSBDT=PSBSTRT-.0000001
+4 FOR
SET PSBDT=$ORDER(^PSB(53.79,"AADT",DFN,PSBDT))
if 'PSBDT!(PSBDT>PSBSTOP)
QUIT
Begin DoDot:1
+5 SET PSBIEN=0
+6 FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN))
if 'PSBIEN
QUIT
Begin DoDot:2
+7 ; Not a PRN Administration
if $PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)'="P"
QUIT
+8 ; Effectiveness entered
if $PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,2)]""
QUIT
+9 ;Allow only entries with at status of "GIVEN" and "REMOVED"
if ($PIECE($GET(^PSB(53.79,PSBIEN,0)),U,9)'="G")&($PIECE($GET(^PSB(53.79,PSBIEN,0)),U,9)'="RM")
QUIT
+10 if $PIECE($GET(^PSB(53.79,PSBIEN,0)),U,6)<PSBDT
QUIT
+11 if $PIECE($GET(^PSB(53.79,PSBIEN,0)),U,6)>PSBSTOP
QUIT
+12 SET ^TMP("PSB",$JOB,DFN,PSBIEN)=""
End DoDot:2
End DoDot:1
+13 QUIT
PRINT ; Print meds stored in ^TMP("PSB",$J,DFN,....
+1 NEW PSBHDR,PSBDT,PSBMED,DFN
+2 ;
+3 ; Print by Patient
+4 ;
+5 if $PIECE(PSBRPT(.1),U,1)="P"
Begin DoDot:1
+6 SET PSBHDR(1)="PRN EFFECTIVENESS LIST for "_$$FMTE^XLFDT(PSBSTRT)_" to "_$$FMTE^XLFDT(PSBSTOP)
+7 SET DFN=$PIECE(PSBRPT(.1),U,2)
+8 WRITE $$PTHDR()
+9 IF '$ORDER(^TMP("PSB",$JOB,DFN,0))
WRITE !,"No PRN Medications Found",$$PTFTR^PSBOHDR()
QUIT
+10 ; Line Break Between Admin Times
WRITE !
+11 SET PSBIEN=""
+12 FOR
SET PSBIEN=$ORDER(^TMP("PSB",$JOB,DFN,PSBIEN))
if PSBIEN=""
QUIT
Begin DoDot:2
+13 SET PSBIENS=PSBIEN_","
+14 IF $Y>(IOSL-5)
WRITE $$PTFTR^PSBOHDR(),$$PTHDR()
+15 ;*70 - Get name of who took action, PSB*3*72
WRITE !,$$GET1^DIQ(53.79,PSBIENS,.06),?30,$$GET1^DIQ(53.79,PSBIENS,.08),?64,$$GETINIT^PSBCSUTX(PSBIEN,"N")
+16 ;*70
WRITE ?102,$$GET1^DIQ(53.79,PSBIENS,"PATIENT LOCATION")
+17 WRITE !,?5,"PRN Reason: ",$$GET1^DIQ(53.79,PSBIENS,.21)
End DoDot:2
+18 WRITE $$PTFTR^PSBOHDR()
+19 QUIT
End DoDot:1
+20 ;
+21 ; Print by Ward
+22 ;
+23 if $PIECE(PSBRPT(.1),U,1)="W"
Begin DoDot:1
+24 SET PSBHDR(1)="PRN EFFECTIVENESS LIST from "_$$FMTE^XLFDT(PSBSTRT)_" thru "_$$FMTE^XLFDT(PSBSTOP)
+25 SET PSBWARD=$PIECE(PSBRPT(.1),U,3)
+26 WRITE $$WRDHDR()
+27 IF '$ORDER(^TMP("PSB",$JOB,0))
WRITE !,"No PRN Medications Found"
QUIT
+28 SET PSBSORT=$PIECE(PSBRPT(.1),U,5)
+29 FOR DFN=0:0
SET DFN=$ORDER(^TMP("PSB",$JOB,DFN))
if 'DFN
QUIT
Begin DoDot:2
+30 ;PSB*3*23
SET PSBINDX=$SELECT(PSBSORT="P":$PIECE(^DPT(DFN,0),U),1:$GET(^DPT(DFN,.1))_" "_$GET(^DPT(DFN,.101)))
+31 if PSBINDX=""
SET PSBINDX=$PIECE(^DPT(DFN,0),U)
+32 SET ^TMP("PSB",$JOB,"B",PSBINDX,DFN)=""
End DoDot:2
+33 SET PSBINDX=""
+34 FOR
SET PSBINDX=$ORDER(^TMP("PSB",$JOB,"B",PSBINDX))
if PSBINDX=""
QUIT
Begin DoDot:2
+35 FOR DFN=0:0
SET DFN=$ORDER(^TMP("PSB",$JOB,"B",PSBINDX,DFN))
if 'DFN
QUIT
Begin DoDot:3
+36 ; Line Break Between Pt's
WRITE !
+37 if $PIECE(PSBRPT(.1),U,5)="P"
WRITE !,$$GET1^DIQ(2,DFN_",",.01),?32,$$GET1^DIQ(2,DFN_",",.1)," ",$$GET1^DIQ(2,DFN_",",.101)
+38 if $PIECE(PSBRPT(.1),U,5)="B"
WRITE !,$$GET1^DIQ(2,DFN_",",.1)," ",$$GET1^DIQ(2,DFN_",",.101),?20,$$GET1^DIQ(2,DFN_",",.01)
+39 ; Line Break Between Admin Times
WRITE !
+40 SET PSBIEN=""
+41 FOR
SET PSBIEN=$ORDER(^TMP("PSB",$JOB,DFN,PSBIEN))
if PSBIEN=""
QUIT
Begin DoDot:4
+42 IF $Y>(IOSL-5)
WRITE $$WRDHDR()
+43 ;*70 - Get name of who took action, PSB*3*72
WRITE !?5,$$GET1^DIQ(53.79,PSBIEN_",",.06),?35,$$GET1^DIQ(53.79,PSBIEN_",",.08),?68,$$GETINIT^PSBCSUTX(PSBIEN,"N")
+44 ;*70
WRITE ?102,$$GET1^DIQ(53.79,PSBIEN_",","PATIENT LOCATION")
+45 WRITE !?10,"PRN Reason: ",$$GET1^DIQ(53.79,PSBIEN_",",.21)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+46 QUIT
+47 ;
WRDHDR() ; Ward Header
+1 ;Add PSBSRCHL variable and additional PSBHDR array spacers for PSBOHDR call, PSB*3*78
NEW PSBSRCHL
+2 SET PSBSRCHL=$$SRCHLIST^PSBOHDR()
+3 SET PSBHDR(2)=""
SET PSBHDR(3)=""
SET PSBHDR(4)="Ward Location: "
+4 ;2 = both order types *70
NEW PSBCLINORD
SET PSBCLINORD=2
+5 DO WARD^PSBOHDR(PSBWRD,.PSBHDR,,,PSBSRCHL)
+6 if $PIECE(PSBRPT(.1),U,5)="B"
WRITE !,"Ward Rm-Bed",?20,"Patient"
+7 if $PIECE(PSBRPT(.1),U,5)="P"
WRITE !,"Patient",?32,"Ward Rm-Bed"
+8 ;adjust name of headings and colums to make room for Location ;*70
+9 ;*70
WRITE !?5,"Admin Date/Time",?35,"Medication",?68,"Administered By"
+10 ;*70
WRITE ?102,"Location"
+11 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+12 QUIT ""
+13 ;
PTHDR() ; Patient Header
+1 ;2 = both order types *70
NEW PSBCLINORD
SET PSBCLINORD=2
+2 DO PT^PSBOHDR(DFN,.PSBHDR)
+3 WRITE !,"Admin Date/Time",?30,"Medication",?64,"Administered By"
+4 WRITE ?102,"Location"
+5 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+6 QUIT ""
+7 ;
