- PSBOPE ;BIRMINGHAM/EFC-PRN EFFECTIVENESS WORKSHEET ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**5,23,32**;Mar 2004;Build 32
- ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
- ;
- ; Reference/IA
- ; ^DPT/10035
- ; EN^PSJBCMA/2828
- ;
- 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),?72,$$GET1^DIQ(53.79,PSBIENS,"ACTION BY")
- ..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),?77,$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY")
- ....W !?10,"PRN Reason: ",$$GET1^DIQ(53.79,PSBIEN_",",.21)
- Q
- ;
- WRDHDR() ; Ward Header
- D WARD^PSBOHDR(PSBWRD,.PSBHDR)
- W:$P(PSBRPT(.1),U,5)="B" !,"Ward Rm-Bed",?20,"Patient"
- W:$P(PSBRPT(.1),U,5)="P" !,"Patient",?32,"Ward Rm-Bed"
- W !?5,"Administration Date/Time",?35,"Medication",?77,"Administered By"
- W !,$TR($J("",IOM)," ","-")
- Q ""
- ;
- PTHDR() ; Patient Header
- D PT^PSBOHDR(DFN,.PSBHDR)
- W !,"Administration Date/Time",?30,"Medication",?72,"Administered By"
- W !,$TR($J("",IOM)," ","-")
- Q ""
- ;
- PSBOPE ;BIRMINGHAM/EFC-PRN EFFECTIVENESS WORKSHEET ;Mar 2004
- +1 ;;3.0;BAR CODE MED ADMIN;**5,23,32**;Mar 2004;Build 32
- +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 ;
- 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 WRITE !,$$GET1^DIQ(53.79,PSBIENS,.06),?30,$$GET1^DIQ(53.79,PSBIENS,.08),?72,$$GET1^DIQ(53.79,PSBIENS,"ACTION BY")
- +16 WRITE !,?5,"PRN Reason: ",$$GET1^DIQ(53.79,PSBIENS,.21)
- End DoDot:2
- +17 WRITE $$PTFTR^PSBOHDR()
- +18 QUIT
- End DoDot:1
- +19 ;
- +20 ; Print by Ward
- +21 ;
- +22 IF $PIECE(PSBRPT(.1),U,1)="W"
- Begin DoDot:1
- +23 SET PSBHDR(1)="PRN EFFECTIVENESS LIST from "_$$FMTE^XLFDT(PSBSTRT)_" thru "_$$FMTE^XLFDT(PSBSTOP)
- +24 SET PSBWARD=$PIECE(PSBRPT(.1),U,3)
- +25 WRITE $$WRDHDR()
- +26 IF '$ORDER(^TMP("PSB",$JOB,0))
- WRITE !,"No PRN Medications Found"
- QUIT
- +27 SET PSBSORT=$PIECE(PSBRPT(.1),U,5)
- +28 FOR DFN=0:0
- SET DFN=$ORDER(^TMP("PSB",$JOB,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:2
- +29 ;PSB*3*23
- SET PSBINDX=$SELECT(PSBSORT="P":$PIECE(^DPT(DFN,0),U),1:$GET(^DPT(DFN,.1))_" "_$GET(^DPT(DFN,.101)))
- +30 IF PSBINDX=""
- SET PSBINDX=$PIECE(^DPT(DFN,0),U)
- +31 SET ^TMP("PSB",$JOB,"B",PSBINDX,DFN)=""
- End DoDot:2
- +32 SET PSBINDX=""
- +33 FOR
- SET PSBINDX=$ORDER(^TMP("PSB",$JOB,"B",PSBINDX))
- IF PSBINDX=""
- QUIT
- Begin DoDot:2
- +34 FOR DFN=0:0
- SET DFN=$ORDER(^TMP("PSB",$JOB,"B",PSBINDX,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:3
- +35 ; Line Break Between Pt's
- WRITE !
- +36 IF $PIECE(PSBRPT(.1),U,5)="P"
- WRITE !,$$GET1^DIQ(2,DFN_",",.01),?32,$$GET1^DIQ(2,DFN_",",.1)," ",$$GET1^DIQ(2,DFN_",",.101)
- +37 IF $PIECE(PSBRPT(.1),U,5)="B"
- WRITE !,$$GET1^DIQ(2,DFN_",",.1)," ",$$GET1^DIQ(2,DFN_",",.101),?20,$$GET1^DIQ(2,DFN_",",.01)
- +38 ; Line Break Between Admin Times
- WRITE !
- +39 SET PSBIEN=""
- +40 FOR
- SET PSBIEN=$ORDER(^TMP("PSB",$JOB,DFN,PSBIEN))
- IF PSBIEN=""
- QUIT
- Begin DoDot:4
- +41 IF $Y>(IOSL-5)
- WRITE $$WRDHDR()
- +42 WRITE !?5,$$GET1^DIQ(53.79,PSBIEN_",",.06),?35,$$GET1^DIQ(53.79,PSBIEN_",",.08),?77,$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY")
- +43 WRITE !?10,"PRN Reason: ",$$GET1^DIQ(53.79,PSBIEN_",",.21)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +44 QUIT
- +45 ;
- WRDHDR() ; Ward Header
- +1 DO WARD^PSBOHDR(PSBWRD,.PSBHDR)
- +2 IF $PIECE(PSBRPT(.1),U,5)="B"
- WRITE !,"Ward Rm-Bed",?20,"Patient"
- +3 IF $PIECE(PSBRPT(.1),U,5)="P"
- WRITE !,"Patient",?32,"Ward Rm-Bed"
- +4 WRITE !?5,"Administration Date/Time",?35,"Medication",?77,"Administered By"
- +5 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
- +6 QUIT ""
- +7 ;
- PTHDR() ; Patient Header
- +1 DO PT^PSBOHDR(DFN,.PSBHDR)
- +2 WRITE !,"Administration Date/Time",?30,"Medication",?72,"Administered By"
- +3 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
- +4 QUIT ""
- +5 ;
