PSBPRN ;BIRMINGHAM/EFC-BCMA PRN FUNCTIONS ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**5,3,13**;Mar 2004
;
;Reference/IA
;DEM^VADPT/10061
;INP^VADPT/10061
;$$GET1^DIQ/2056
EN ;
Q
;
EDIT ; Edit Medication Log PRN Effectiveness
NEW DFN ;* Undef DFN at EDIT+7^PSBPRN (NOIS: HUN-0699-21494)
W !! S DA=""
S DIC="^DPT(",DIC(0)="AEQM",DIC("A")="Select Patient Name: "
D ^DIC K DIC Q:+Y<1
S DFN=+Y
D EDIT1
K DFN,DA
G EDIT
;
EDIT1 ;
S %DT="AEQ",%DT("A")="Select Date to Begin Searching Back From: "
S %DT("B")="Today"
W !! D ^%DT Q:+Y<1 S PSBDT=Y
F D Q:'PSBDT
.W @IOF,!,"Searching Date " S Y=PSBDT D D^DIQ W Y
.W !," # Medication",?45,"St",?50,"D/T Given",?75,"Int"
.W !,$TR($J("",IOM)," ","-")
.S PSBSRCH=PSBDT+.9,PSBCNT=0
.K PSBTMP
.F S PSBSRCH=$O(^PSB(53.79,"APRN",DFN,PSBSRCH),-1) Q:'PSBSRCH!(PSBSRCH<PSBDT) D
..S PSBIEN=""
..F S PSBIEN=$O(^PSB(53.79,"APRN",DFN,PSBSRCH,PSBIEN),-1) Q:'PSBIEN D
...Q:$P($G(^PSB(53.79,PSBIEN,.2)),U,2)]""
...Q:$P($G(^PSB(53.79,PSBIEN,0)),U,9)'="G"
...S PSBCNT=PSBCNT+1,PSBTMP(PSBCNT)=PSBIEN
...I $Y>19 W ! S DIR(0)="E" D ^DIR W @IOF,!,"Searching Date " S Y=PSBDT D D^DIQ W Y,!," # Medication",?45,"St",?50,"D/T Given",?75,"Int",!,$TR($J("",IOM)," ","-")
...W !,$J(PSBCNT,2),". "
...W ?5,$$GET1^DIQ(53.79,PSBIEN_",",.08)
...W ?45,$P(^PSB(53.79,PSBIEN,0),U,9)
...W ?50,$$GET1^DIQ(53.79,PSBIEN_",",.06)
...W ?75,$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
.I PSBCNT W ! S DIR(0)="NO^1:"_PSBCNT_":0" D ^DIR S:Y DA=PSBTMP(Y),PSBDT="" Q:Y
.I 'PSBCNT W !!?5,"No Meds Found!"
.S X1=PSBDT,X2=-1 D C^%DTC S (PSBDT,Y)=X D D^DIQ
.W !!,"Continue With ",Y
.S %=1 D YN^DICN I %'=1 S PSBDT=0
I DA S DDSFILE=53.79,DR="[PSB PRN EFFECTIVENESS]" D ^DDS S %=2 W !,"Edit another entry" D YN^DICN G:%=1 EDIT1
K PSBCNT,PSBDT,PSBIEN,PSBSRCH,PSBTMP,DA,DR,DDSFILE
Q
;
GETPRNS(RESULTS,DFN,PSBORD) ; Get the PRN's for a pt needing effectness
;
; RPC PSB GETPRNS
;
; Description:
; Returns all administrations of a PRN order that have NOT had
; the PRN Effectiveness documented BASED ON THE TRANSFER DATE AND SITE PARAM
;
N PSBIEN,PSBSTOP
K ^TMP("PSB",$J),RESULTS
;
Q:$$DISCHRGD(DFN)
;
D INP^VADPT S PSBTRDT=+VAIN(7)
S PSBHOUR=$$GET^XPAR("DIV","PSB PRN DOCUMENTATION") I PSBHOUR="" S PSBHOUR=72
D NOW^%DTC S PSBSTRT=%,PSBPRNDT=$$FMADD^XLFDT(PSBSTRT,"",-PSBHOUR)
;
;Use the (OLDER) value of PSBPRNDT(site param) or PSBTRDT(admission)
I PSBPRNDT>PSBTRDT S PSBPRNDT=PSBTRDT
S PSBSTRT="" F S PSBSTRT=$O(^PSB(53.79,"APRN",DFN,PSBSTRT),-1) Q:(PSBSTRT<PSBPRNDT) D
.S PSBIEN=""
.F S PSBIEN=$O(^PSB(53.79,"APRN",DFN,PSBSTRT,PSBIEN),-1) Q:'PSBIEN D
..Q:(PSBORD'="")&($P(^PSB(53.79,PSBIEN,.1),U)'=PSBORD) ; Not the right order
..I ($P(^PSB(53.79,PSBIEN,0),U,9)'="G")&($P(^PSB(53.79,PSBIEN,0),U,9)'="RM") Q ; Med was never given
..Q:$P($G(^PSB(53.79,PSBIEN,.2)),U,2)]"" ; Already entered
..S PSBX=PSBIEN_U_DFN,PSBIENS=PSBIEN_","
..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.02)
..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.06,"I")
..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.07)
..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.08)
..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.21)
..D PSJ1^PSBVT(DFN,$$GET1^DIQ(53.79,PSBIENS,.11))
..S PSBX=PSBX_U_PSBOIT_U_PSBONX
..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.27)
..S Y=$O(^TMP("PSB",$J,""),-1)+1
..S ^TMP("PSB",$J,Y)=PSBX
..;Special instructions
..S Y=Y+1,^TMP("PSB",$J,Y)=PSBOTXT
..F PSBZ=.5,.6,.7 F PSBY=0:0 S PSBY=$O(^PSB(53.79,PSBIEN,PSBZ,PSBY)) Q:'PSBY D
...S PSBDD=$S(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
...S PSBSOL=$S(PSBZ=.5:"DD",PSBZ=.6:"ADD",1:"SOL")
...Q:'$D(^PSB(53.79,PSBIEN,PSBZ,PSBY))
...S PSBUNIT=$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.03)
...S PSBUNFR=$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.04)
...S Y=Y+1
...S ^TMP("PSB",$J,Y)=PSBSOL_U_$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.01)_U_PSBUNIT_U_PSBUNFR
..S Y=Y+1,^TMP("PSB",$J,Y)="END"
S ^TMP("PSB",$J,0)=+$O(^TMP("PSB",$J,""),-1)
S RESULTS=$NAME(^TMP("PSB",$J))
K PSBTRDT,PSBHOUR,PSBPRNDT
D CLEAN^PSBVT
Q
;
DISCHRGD(DFN) ; Patient Discharged OR Deceased?
;
S DISCHRGD=0
;
D DEM^VADPT ;check for date of death entry
I VADM(6)]"" S DISCHRGD=1,^TMP("PSB",$J,0)=0 K VADM
;
I DISCHRGD=0 D ;check for discharge if they're not dead
.D INP^VADPT
.I VAIN(1)']"" S DISCHRGD=1,^TMP("PSB",$J,0)=0 K VAIN
;
I DISCHRGD D ;setup results and clean up
.S RESULTS=$NAME(^TMP("PSB",$J))
.K PSBTRDT,PSBHOUR,PSBPRNDT
.D CLEAN^PSBVT
;
Q DISCHRGD
;
PSBPRN ;BIRMINGHAM/EFC-BCMA PRN FUNCTIONS ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**5,3,13**;Mar 2004
+2 ;
+3 ;Reference/IA
+4 ;DEM^VADPT/10061
+5 ;INP^VADPT/10061
+6 ;$$GET1^DIQ/2056
EN ;
+1 QUIT
+2 ;
EDIT ; Edit Medication Log PRN Effectiveness
+1 ;* Undef DFN at EDIT+7^PSBPRN (NOIS: HUN-0699-21494)
NEW DFN
+2 WRITE !!
SET DA=""
+3 SET DIC="^DPT("
SET DIC(0)="AEQM"
SET DIC("A")="Select Patient Name: "
+4 DO ^DIC
KILL DIC
IF +Y<1
QUIT
+5 SET DFN=+Y
+6 DO EDIT1
+7 KILL DFN,DA
+8 GOTO EDIT
+9 ;
EDIT1 ;
+1 SET %DT="AEQ"
SET %DT("A")="Select Date to Begin Searching Back From: "
+2 SET %DT("B")="Today"
+3 WRITE !!
DO ^%DT
IF +Y<1
QUIT
SET PSBDT=Y
+4 FOR
Begin DoDot:1
+5 WRITE @IOF,!,"Searching Date "
SET Y=PSBDT
DO D^DIQ
WRITE Y
+6 WRITE !," # Medication",?45,"St",?50,"D/T Given",?75,"Int"
+7 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+8 SET PSBSRCH=PSBDT+.9
SET PSBCNT=0
+9 KILL PSBTMP
+10 FOR
SET PSBSRCH=$ORDER(^PSB(53.79,"APRN",DFN,PSBSRCH),-1)
IF 'PSBSRCH!(PSBSRCH<PSBDT)
QUIT
Begin DoDot:2
+11 SET PSBIEN=""
+12 FOR
SET PSBIEN=$ORDER(^PSB(53.79,"APRN",DFN,PSBSRCH,PSBIEN),-1)
IF 'PSBIEN
QUIT
Begin DoDot:3
+13 IF $PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,2)]""
QUIT
+14 IF $PIECE($GET(^PSB(53.79,PSBIEN,0)),U,9)'="G"
QUIT
+15 SET PSBCNT=PSBCNT+1
SET PSBTMP(PSBCNT)=PSBIEN
+16 IF $Y>19
WRITE !
SET DIR(0)="E"
DO ^DIR
WRITE @IOF,!,"Searching Date "
SET Y=PSBDT
DO D^DIQ
WRITE Y,!," # Medication",?45,"St",?50,"D/T Given",?75,"Int",!,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+17 WRITE !,$JUSTIFY(PSBCNT,2),". "
+18 WRITE ?5,$$GET1^DIQ(53.79,PSBIEN_",",.08)
+19 WRITE ?45,$PIECE(^PSB(53.79,PSBIEN,0),U,9)
+20 WRITE ?50,$$GET1^DIQ(53.79,PSBIEN_",",.06)
+21 WRITE ?75,$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
End DoDot:3
End DoDot:2
+22 IF PSBCNT
WRITE !
SET DIR(0)="NO^1:"_PSBCNT_":0"
DO ^DIR
IF Y
SET DA=PSBTMP(Y)
SET PSBDT=""
IF Y
QUIT
+23 IF 'PSBCNT
WRITE !!?5,"No Meds Found!"
+24 SET X1=PSBDT
SET X2=-1
DO C^%DTC
SET (PSBDT,Y)=X
DO D^DIQ
+25 WRITE !!,"Continue With ",Y
+26 SET %=1
DO YN^DICN
IF %'=1
SET PSBDT=0
End DoDot:1
IF 'PSBDT
QUIT
+27 IF DA
SET DDSFILE=53.79
SET DR="[PSB PRN EFFECTIVENESS]"
DO ^DDS
SET %=2
WRITE !,"Edit another entry"
DO YN^DICN
IF %=1
GOTO EDIT1
+28 KILL PSBCNT,PSBDT,PSBIEN,PSBSRCH,PSBTMP,DA,DR,DDSFILE
+29 QUIT
+30 ;
GETPRNS(RESULTS,DFN,PSBORD) ; Get the PRN's for a pt needing effectness
+1 ;
+2 ; RPC PSB GETPRNS
+3 ;
+4 ; Description:
+5 ; Returns all administrations of a PRN order that have NOT had
+6 ; the PRN Effectiveness documented BASED ON THE TRANSFER DATE AND SITE PARAM
+7 ;
+8 NEW PSBIEN,PSBSTOP
+9 KILL ^TMP("PSB",$JOB),RESULTS
+10 ;
+11 IF $$DISCHRGD(DFN)
QUIT
+12 ;
+13 DO INP^VADPT
SET PSBTRDT=+VAIN(7)
+14 SET PSBHOUR=$$GET^XPAR("DIV","PSB PRN DOCUMENTATION")
IF PSBHOUR=""
SET PSBHOUR=72
+15 DO NOW^%DTC
SET PSBSTRT=%
SET PSBPRNDT=$$FMADD^XLFDT(PSBSTRT,"",-PSBHOUR)
+16 ;
+17 ;Use the (OLDER) value of PSBPRNDT(site param) or PSBTRDT(admission)
+18 IF PSBPRNDT>PSBTRDT
SET PSBPRNDT=PSBTRDT
+19 SET PSBSTRT=""
FOR
SET PSBSTRT=$ORDER(^PSB(53.79,"APRN",DFN,PSBSTRT),-1)
IF (PSBSTRT<PSBPRNDT)
QUIT
Begin DoDot:1
+20 SET PSBIEN=""
+21 FOR
SET PSBIEN=$ORDER(^PSB(53.79,"APRN",DFN,PSBSTRT,PSBIEN),-1)
IF 'PSBIEN
QUIT
Begin DoDot:2
+22 ; Not the right order
IF (PSBORD'="")&($PIECE(^PSB(53.79,PSBIEN,.1),U)'=PSBORD)
QUIT
+23 ; Med was never given
IF ($PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G")&($PIECE(^PSB(53.79,PSBIEN,0),U,9)'="RM")
QUIT
+24 ; Already entered
IF $PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,2)]""
QUIT
+25 SET PSBX=PSBIEN_U_DFN
SET PSBIENS=PSBIEN_","
+26 SET PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.02)
+27 SET PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.06,"I")
+28 SET PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.07)
+29 SET PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.08)
+30 SET PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.21)
+31 DO PSJ1^PSBVT(DFN,$$GET1^DIQ(53.79,PSBIENS,.11))
+32 SET PSBX=PSBX_U_PSBOIT_U_PSBONX
+33 SET PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.27)
+34 SET Y=$ORDER(^TMP("PSB",$JOB,""),-1)+1
+35 SET ^TMP("PSB",$JOB,Y)=PSBX
+36 ;Special instructions
+37 SET Y=Y+1
SET ^TMP("PSB",$JOB,Y)=PSBOTXT
+38 FOR PSBZ=.5,.6,.7
FOR PSBY=0:0
SET PSBY=$ORDER(^PSB(53.79,PSBIEN,PSBZ,PSBY))
IF 'PSBY
QUIT
Begin DoDot:3
+39 SET PSBDD=$SELECT(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
+40 SET PSBSOL=$SELECT(PSBZ=.5:"DD",PSBZ=.6:"ADD",1:"SOL")
+41 IF '$DATA(^PSB(53.79,PSBIEN,PSBZ,PSBY))
QUIT
+42 SET PSBUNIT=$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.03)
+43 SET PSBUNFR=$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.04)
+44 SET Y=Y+1
+45 SET ^TMP("PSB",$JOB,Y)=PSBSOL_U_$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.01)_U_PSBUNIT_U_PSBUNFR
End DoDot:3
+46 SET Y=Y+1
SET ^TMP("PSB",$JOB,Y)="END"
End DoDot:2
End DoDot:1
+47 SET ^TMP("PSB",$JOB,0)=+$ORDER(^TMP("PSB",$JOB,""),-1)
+48 SET RESULTS=$NAME(^TMP("PSB",$JOB))
+49 KILL PSBTRDT,PSBHOUR,PSBPRNDT
+50 DO CLEAN^PSBVT
+51 QUIT
+52 ;
DISCHRGD(DFN) ; Patient Discharged OR Deceased?
+1 ;
+2 SET DISCHRGD=0
+3 ;
+4 ;check for date of death entry
DO DEM^VADPT
+5 IF VADM(6)]""
SET DISCHRGD=1
SET ^TMP("PSB",$JOB,0)=0
KILL VADM
+6 ;
+7 ;check for discharge if they're not dead
IF DISCHRGD=0
Begin DoDot:1
+8 DO INP^VADPT
+9 IF VAIN(1)']""
SET DISCHRGD=1
SET ^TMP("PSB",$JOB,0)=0
KILL VAIN
End DoDot:1
+10 ;
+11 ;setup results and clean up
IF DISCHRGD
Begin DoDot:1
+12 SET RESULTS=$NAME(^TMP("PSB",$JOB))
+13 KILL PSBTRDT,PSBHOUR,PSBPRNDT
+14 DO CLEAN^PSBVT
End DoDot:1
+15 ;
+16 QUIT DISCHRGD
+17 ;
