PSBPRND ;BIRMINGHAM/EFC-BCMA PRN DOCUMENTING ;May 2002
;;2.0;BAR CODE MED ADMIN;**32**;May 2002
;
;Queue the routine
ENV(PSBPRNDT,PSBSTRT,PSBDUZ,PRNMSG) ;
I $G(DUZ)="" W !,"Your DUZ is not defined. It must be defined." Q
K ZTSAVE,ZTSK S ZTRTN="PROCESS^PSBPRND(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM)",ZTDESC="BCMA PRN DOCUMENTATION",ZTIO=""
W !!
S ZTSAVE("PSBPRNDT")=""
S ZTSAVE("PSBSTRTE")=""
S ZTSAVE("PSBDUZ")=""
S ZTSAVE("PSBPRNM")=""
D ^%ZTLOAD
I $D(ZTSK) D
.W !!,"The PRN effectiveness documenting process was ",$S($G(ZTSK):"",1:"NOT"),"queued",!
.W !," TASK#: "_$G(ZTSK)
Q
PSBPRNS ;Document all administrations of a PRN order that have NOT had
; the PRN Effectiveness documented for dates user provided
;
N PSBIEN
I $G(DUZ)="" W !,"Your DUZ is not defined. It must be defined." Q
S PSBDUZ=$G(DUZ)
D HEADER
;get start date
S %DT="AEQ",%DT("A")="Select Date to Process From: "
S %DT("B")=""
W ! D ^%DT Q:+Y<1 S PSBDT=Y
S PSBPRNDT=PSBDT D D^DIQ
;Get stop date
S %DT="AEQ",%DT("A")="Select Date to Process Up to: "
S %DT("B")=""
W ! D ^%DT Q:+Y<1 S PSBDTA=Y
S PSBSTRTE=PSBDTA D D^DIQ
I PSBPRNDT>PSBSTRTE W !,"Start date cannot be greater than end date" Q
;Write user running routine
S PSBNAME=$P(^VA(200,PSBDUZ,0),"^",1)
W !!,"PRN effectiveness entered by: ",PSBNAME,!
D HEADER
;COMMIT OR QUIT
S Y=PSBDTA D DD^%DT S PSBRDT=Y
S Y=PSBPRNDT D DD^%DT S PSBRDTA=Y
W !!!,?10,"**PRN DOCUMENTATION WILL BE FILED FOR THE FOLLOWING**"
W !!,?5,"PRN START DATE...........: ",PSBRDTA
W !,?5,"PRN END DATE.............: ",PSBRDT
W !,?5,"PRN ENTERED BY...........: ",PSBNAME
W !,?5,"PRN DOCUMENTATION STATEMENT: "
;Set mesage to be used
S PSBPRNM="Administrative Closure"
I $L(PSBPRNM)>0 D
.W ?9,$E(PSBPRNM,1,52)
R !!,"Would you like to CONTINUE ? (Y/N):",PSBANS:30
S PSBFLAG=""
I (PSBANS["Y")!(PSBANS="y") S PSBFLAG=1
I PSBFLAG'=1 D Q
.W !!,"You have chosen not to continue! Application ending!!"
D HEADER
D ENV(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM)
Q
;
PROCESS(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM) ;
;Gather Patient DFN
S PSBSRTD=PSBSTRTE+1
S PSBPRTA=PSBPRNDT-1
S PSBCNT="0"
S DFN="" F S DFN=$O(^PSB(53.79,"APRN",DFN)) Q:DFN="" D
.S PSBSTRT="" F S PSBSTRT=$O(^PSB(53.79,"APRN",DFN,PSBSTRT)) Q:PSBSTRT="" D
..I PSBSTRT>PSBPRTA,PSBSTRT<PSBSRTD D
...S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"APRN",DFN,PSBSTRT,PSBIEN)) Q:'PSBIEN D
....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)]"" ;PRN already entered
....D FILEIT(PSBIEN,PSBPRNM)
....;increment counter
....S PSBCNT=PSBCNT+1
;Email the results
D PSBEMAIL(PSBCNT,PSBPRNM,PSBSTRTE,PSBPRNDT,PSBDUZ)
K PSBCNT,PSBPRNM,PSBDTA,PSBPRNDT,PSBDUZ,PSBPRMG,PSBSTRTE
K PSBSRTD,PSBPRTA
Q
;File PRN
FILEIT(PSBIEN,PSBPRNM) ;
;
S PSBREC(0)=PSBPRNM
S PSBIEN=PSBIEN_","
D VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))
D FILEIT^PSBML
Q
;
;
W #
W !,$TR($J("",IOM)," ","-")
W !,?23,"PRN EFFECTIVENESS DOCUMENTATION ROUTINE"
W !,$TR($J("",IOM)," ","-")
Q
;
;
PSBEMAIL(PSB1,PSB2,PSB3,PSB4,PSB5) ;
; PSB1 = PRN Count
; PSB2 = PRN message to file
; PSB3 = START date for search
; PSB4 = FINISH date for search
; PSB5 = DUZ for PRN entered by
; Send PRN documentation changes to user
S Y=PSB3 D DD^%DT S PSB3X=Y
S Y=PSB4 D DD^%DT S PSB4X=Y
S PSB5=$P(^VA(200,PSB5,0),"^",1)
S PSBMG=DUZ ;
Q:PSBMG=""
S PSBMSG(1)=" "
S PSBMSG(2)=" PRN effectiveness not documented have been fixed. "
S PSBMSG(3)=" "
S PSBMSG(4)=" PRN effectiveness entered by.: "_PSB5
S PSBMSG(5)=" Number of PRNs documented....: "_PSB1
S PSBMSG(6)=" Start Date.......: "_PSB4X
S PSBMSG(7)=" Finish Date......: "_PSB3X
S PSBMSG(8)=" Message documented for PRNs..: "_PSB2
S PSBMSG(9)=" "
S PSBMSG(10)=" "
S PSBMSG(11)=" "
S PSBMSG(12)=""
S PSBMSG(13)=" "
S PSBMSG(14)=" "
S PSBMSG(15)=" "
S XMY(DUZ)="",XMTEXT="PSBMSG(",XMSUB="BCMA PRN DOCUMENTATION Notification."
D ^XMD
K PSB1,PSB2,PSB3,PSB4,PSB5,PSB4X,PSB3X
K PSBMSG,PSBMG,XMY,XMSUB,XMTEXT
Q
;
;
;
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBPRND 4310 printed Nov 22, 2024@16:51:16 Page 2
PSBPRND ;BIRMINGHAM/EFC-BCMA PRN DOCUMENTING ;May 2002
+1 ;;2.0;BAR CODE MED ADMIN;**32**;May 2002
+2 ;
+3 ;Queue the routine
ENV(PSBPRNDT,PSBSTRT,PSBDUZ,PRNMSG) ;
+1 IF $GET(DUZ)=""
WRITE !,"Your DUZ is not defined. It must be defined."
QUIT
+2 KILL ZTSAVE,ZTSK
SET ZTRTN="PROCESS^PSBPRND(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM)"
SET ZTDESC="BCMA PRN DOCUMENTATION"
SET ZTIO=""
+3 WRITE !!
+4 SET ZTSAVE("PSBPRNDT")=""
+5 SET ZTSAVE("PSBSTRTE")=""
+6 SET ZTSAVE("PSBDUZ")=""
+7 SET ZTSAVE("PSBPRNM")=""
+8 DO ^%ZTLOAD
+9 IF $DATA(ZTSK)
Begin DoDot:1
+10 WRITE !!,"The PRN effectiveness documenting process was ",$SELECT($GET(ZTSK):"",1:"NOT"),"queued",!
+11 WRITE !," TASK#: "_$GET(ZTSK)
End DoDot:1
+12 QUIT
PSBPRNS ;Document all administrations of a PRN order that have NOT had
+1 ; the PRN Effectiveness documented for dates user provided
+2 ;
+3 NEW PSBIEN
+4 IF $GET(DUZ)=""
WRITE !,"Your DUZ is not defined. It must be defined."
QUIT
+5 SET PSBDUZ=$GET(DUZ)
+6 DO HEADER
+7 ;get start date
+8 SET %DT="AEQ"
SET %DT("A")="Select Date to Process From: "
+9 SET %DT("B")=""
+10 WRITE !
DO ^%DT
if +Y<1
QUIT
SET PSBDT=Y
+11 SET PSBPRNDT=PSBDT
DO D^DIQ
+12 ;Get stop date
+13 SET %DT="AEQ"
SET %DT("A")="Select Date to Process Up to: "
+14 SET %DT("B")=""
+15 WRITE !
DO ^%DT
if +Y<1
QUIT
SET PSBDTA=Y
+16 SET PSBSTRTE=PSBDTA
DO D^DIQ
+17 IF PSBPRNDT>PSBSTRTE
WRITE !,"Start date cannot be greater than end date"
QUIT
+18 ;Write user running routine
+19 SET PSBNAME=$PIECE(^VA(200,PSBDUZ,0),"^",1)
+20 WRITE !!,"PRN effectiveness entered by: ",PSBNAME,!
+21 DO HEADER
+22 ;COMMIT OR QUIT
+23 SET Y=PSBDTA
DO DD^%DT
SET PSBRDT=Y
+24 SET Y=PSBPRNDT
DO DD^%DT
SET PSBRDTA=Y
+25 WRITE !!!,?10,"**PRN DOCUMENTATION WILL BE FILED FOR THE FOLLOWING**"
+26 WRITE !!,?5,"PRN START DATE...........: ",PSBRDTA
+27 WRITE !,?5,"PRN END DATE.............: ",PSBRDT
+28 WRITE !,?5,"PRN ENTERED BY...........: ",PSBNAME
+29 WRITE !,?5,"PRN DOCUMENTATION STATEMENT: "
+30 ;Set mesage to be used
+31 SET PSBPRNM="Administrative Closure"
+32 IF $LENGTH(PSBPRNM)>0
Begin DoDot:1
+33 WRITE ?9,$EXTRACT(PSBPRNM,1,52)
End DoDot:1
+34 READ !!,"Would you like to CONTINUE ? (Y/N):",PSBANS:30
+35 SET PSBFLAG=""
+36 IF (PSBANS["Y")!(PSBANS="y")
SET PSBFLAG=1
+37 IF PSBFLAG'=1
Begin DoDot:1
+38 WRITE !!,"You have chosen not to continue! Application ending!!"
End DoDot:1
QUIT
+39 DO HEADER
+40 DO ENV(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM)
+41 QUIT
+42 ;
PROCESS(PSBPRNDT,PSBSTRTE,PSBDUZ,PSBPRNM) ;
+1 ;Gather Patient DFN
+2 SET PSBSRTD=PSBSTRTE+1
+3 SET PSBPRTA=PSBPRNDT-1
+4 SET PSBCNT="0"
+5 SET DFN=""
FOR
SET DFN=$ORDER(^PSB(53.79,"APRN",DFN))
if DFN=""
QUIT
Begin DoDot:1
+6 SET PSBSTRT=""
FOR
SET PSBSTRT=$ORDER(^PSB(53.79,"APRN",DFN,PSBSTRT))
if PSBSTRT=""
QUIT
Begin DoDot:2
+7 IF PSBSTRT>PSBPRTA
IF PSBSTRT<PSBSRTD
Begin DoDot:3
+8 SET PSBIEN=""
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"APRN",DFN,PSBSTRT,PSBIEN))
if 'PSBIEN
QUIT
Begin DoDot:4
+9 ;Med was never given
IF ($PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G")&($PIECE(^PSB(53.79,PSBIEN,0),U,9)'="RM")
QUIT
+10 ;PRN already entered
if $PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,2)]""
QUIT
+11 DO FILEIT(PSBIEN,PSBPRNM)
+12 ;increment counter
+13 SET PSBCNT=PSBCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;Email the results
+15 DO PSBEMAIL(PSBCNT,PSBPRNM,PSBSTRTE,PSBPRNDT,PSBDUZ)
+16 KILL PSBCNT,PSBPRNM,PSBDTA,PSBPRNDT,PSBDUZ,PSBPRMG,PSBSTRTE
+17 KILL PSBSRTD,PSBPRTA
+18 QUIT
+19 ;File PRN
FILEIT(PSBIEN,PSBPRNM) ;
+1 ;
+2 SET PSBREC(0)=PSBPRNM
+3 SET PSBIEN=PSBIEN_","
+4 DO VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))
+5 DO FILEIT^PSBML
+6 QUIT
+7 ;
+8 ;
+1 WRITE #
+2 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+3 WRITE !,?23,"PRN EFFECTIVENESS DOCUMENTATION ROUTINE"
+4 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+5 QUIT
+6 ;
+7 ;
PSBEMAIL(PSB1,PSB2,PSB3,PSB4,PSB5) ;
+1 ; PSB1 = PRN Count
+2 ; PSB2 = PRN message to file
+3 ; PSB3 = START date for search
+4 ; PSB4 = FINISH date for search
+5 ; PSB5 = DUZ for PRN entered by
+6 ; Send PRN documentation changes to user
+7 SET Y=PSB3
DO DD^%DT
SET PSB3X=Y
+8 SET Y=PSB4
DO DD^%DT
SET PSB4X=Y
+9 SET PSB5=$PIECE(^VA(200,PSB5,0),"^",1)
+10 ;
SET PSBMG=DUZ
+11 if PSBMG=""
QUIT
+12 SET PSBMSG(1)=" "
+13 SET PSBMSG(2)=" PRN effectiveness not documented have been fixed. "
+14 SET PSBMSG(3)=" "
+15 SET PSBMSG(4)=" PRN effectiveness entered by.: "_PSB5
+16 SET PSBMSG(5)=" Number of PRNs documented....: "_PSB1
+17 SET PSBMSG(6)=" Start Date.......: "_PSB4X
+18 SET PSBMSG(7)=" Finish Date......: "_PSB3X
+19 SET PSBMSG(8)=" Message documented for PRNs..: "_PSB2
+20 SET PSBMSG(9)=" "
+21 SET PSBMSG(10)=" "
+22 SET PSBMSG(11)=" "
+23 SET PSBMSG(12)=""
+24 SET PSBMSG(13)=" "
+25 SET PSBMSG(14)=" "
+26 SET PSBMSG(15)=" "
+27 SET XMY(DUZ)=""
SET XMTEXT="PSBMSG("
SET XMSUB="BCMA PRN DOCUMENTATION Notification."
+28 DO ^XMD
+29 KILL PSB1,PSB2,PSB3,PSB4,PSB5,PSB4X,PSB3X
+30 KILL PSBMSG,PSBMG,XMY,XMSUB,XMTEXT
+31 QUIT
+32 ;
+33 ;
+34 ;
+35 ;
+36 ;
