PSBMLU ;BIRMINGHAM/EFC - BCMA MEDICATION LOG FUNCTIONS ;6/25/10 6:44am
;;3.0;BAR CODE MED ADMIN;**6,11,13,28,42**;Mar 2004;Build 23
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; DEM^VADPT/10061
EN ;
Q
;
AUDIT(IEN,TXT,PSBTRN) ; Append and Audit
D NOW^%DTC
S RDAT=%
D:PSBTRN="ADD COMMENT"
. N XA
. S XA=$O(^PSB(53.79,IEN,.3,"A"),-1)
. S RDAT=$P(^PSB(53.79,IEN,.3,XA,0),U,3)
D:PSBTRN="PRN EFFECTIVENESS"
. S RDAT=$P(^PSB(53.79,IEN,.2),U,4)
D:PSBTRN="UPDATE STATUS"
. S RDAT=$P(^PSB(53.79,IEN,0),U,6)
D:PSBTRN="MEDPASS"
. S RDAT=$P(^PSB(53.79,IEN,0),U,6)
S:'$D(^PSB(53.79,IEN,.9,0)) ^(0)="^53.799D^^"
S PSBAD1=""
S PSBAD1=$O(^PSB(53.79,IEN,.9,"A"),-1)+1
S ^PSB(53.79,IEN,.9,PSBAD1,0)=RDAT_U_DUZ_U_TXT
Q
;
ERROR(PSB1,PSB2,DFN,PSB3,PSB4,PSB5,PSB6,PSB7) ;
; PSB1 = order #
; PSB2 = orderable item
; PSB3 = message to be sent
; PSB4 = schedule
; PSB5 = action date/time
; PSB6 = med log ien #
; PSB7 = user identification
; Send Error Msg about problems
K PSBMG S PSBMG=$$GET^XPAR("DIV",$S($G(PSBADMER):"PSB MG ADMIN ERROR",1:"PSB MG DUE LIST ERROR"),,"E")
Q:PSBMG=""
S PSBMSG(1)=" The following "_$S($G(PSBADMER):"administration",1:"order")_" was NOT displayed"
S PSBMSG(2)=" on the Virtual Due List"
S PSBMSG(3)=" "
S PSBMSG(4)=" Order Number....: "_PSB1
S PSBMSG(5)=" Orderable Item..: "_PSB2
N VA,VADM D DEM^VADPT
S PSBMSG(6)=" Patient.........: "_VADM(1)_" ("_$TR(VA("PID"),"-")_")"
S PSBMSG(7)=" Ward/Bed........: "_$$GET1^DIQ(2,DFN_",",.1)_"/"_$$GET1^DIQ(2,DFN_",",.101)
S PSBMSG(8)=" Reason..........: "_PSB3
S PSBMSG(9)=" Schedule........: "_PSB4
I $D(PSB5) S PSBMSG(10)=" Action Dt/Tm....: "_PSB5
I $D(PSB6) S PSBMSG(11)=" BCMA Med Log IEN: "_PSB6
I $D(PSB7) S PSBMSG(12)=" User............: "_PSB7
S XMY("G."_PSBMG)="",XMTEXT="PSBMSG(",XMSUB="BCMA - "_$S($G(PSBADMER):"Admin "_$G(PSB6),1:"Order")_" Problem"
K PSBADMER
D ^XMD
K PSB1,PSB2,PSB3,PSB4,PSBMSG,PSBMG,XMY,XMSUB,XMTEXT
Q
;
MSFMSG(PSB1,PSB2,PSB3,PSB4,PSB5,PSB6,PSB7,PSB8,XFLG) ;
; PSB1 = Patient IEN
; PSB2 = Ward Location/Room
; PSB3 = Reason
; PSB4 = Type of Scan Issue
; PSB5 = Event date/time
; PSB6 = User's Comment
; PSB7 = User identification
; PSB8 = Order Number
; XFLG = -1 IF UNSUCCESSFU
;
S PSBMG=$$GET^XPAR("DIV","PSB MG SCANNING FAILURES",,"E"),PSBX1=9
I PSBMG="" S XFLG(0)=-1 Q
I PSB2["$" S PSB2=$TR(PSB2,"$","/")
K PSBDROP
;
; Dynamic - Add the 'user' to Group if not a member!
I '$$MEMBER^XMXAPIG(DUZ,PSBMG) S XMY(DUZ)="",X=$$MG^XMBGRP(PSBMG,"","","",.XMY,"","") S:X>0 PSBDROP(0)=DUZ K XMY
;
S PSBMSG(1)=" The following BCMA Unable to Scan event has occurred:"
S PSBMSG(2)=" "
S PSBMSG(3)=" User.....................: "_PSB7
S PSBMSG(4)=" Date/Time of Event.......: "_PSB5
N PSBDPT S PSBDPT="" I +$G(PSB1)>0 S DFN=PSB1 D DEM^VADPT S PSBDPT=VADM(1)_" ("_VA("BID")_")"
S PSBMSG(5)=" Patient..................: "_PSBDPT
S PSBMSG(6)=" Order Number.............: "_$S(PSB8]"":PSB8,1:"N/A")
S PSBMSG(7)=" Ward Location/Room.......: "_PSB2
S PSBMSG(8)=" Type of Barcode Issue....: "_PSB4
I PSB4="Medication" D
.I PSB8]"" D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSB8)
.I $D(PSBSFUID),$G(PSBSFUID)]"" D Q
..D ;Set the Unique ID value
...I PSB6["Verify 5 Rights Override" S PSBSFUID="WARD STOCK" Q
...I PSBSFUID="WS" S PSBSFUID="WARD STOCK" Q
...I PSBSFUID["WS" S PSBSFUID="WARD STOCK ("_PSBSFUID_")"
..S PSBMSG(PSBX1)=" Unique ID................: "_PSBSFUID,PSBX1=PSBX1+1
..S PSBMSG(PSBX1)=" Orderable Item...........: "_PSBOITX,PSBX1=PSBX1+1
.I '$D(PSBSFUID),$G(PSBMEDNM)]"" D Q
..I $D(PSBMEDNM) S PSBMSG(PSBX1)=" Dispense Drug............: "_PSBMEDNM_$S($G(PSBMEDOI)]"":" ("_PSBMEDOI_")",1:""),PSBX1=PSBX1+1
..I $G(PSBDOSE)]"" S PSBMSG(PSBX1)=" Dosage Ordered...........: "_PSBDOSE,PSBX1=PSBX1+1 Q
.I '$D(PSBSFUID),$G(PSBMEDNM)="" D Q
..S PSBMSG(PSBX1)=" Unique ID................: WARD STOCK",PSBX1=PSBX1+1
..S PSBMSG(PSBX1)=" Orderable Item...........: "_PSBOITX,PSBX1=PSBX1+1
S PSBMSG(PSBX1)=" Reason Unable to Scan....: "_PSB3,PSBX1=PSBX1+1
S PSB6=$S($E(PSB6,1,2)="!~":$TR(PSB6,"!~",""),1:$TR(PSB6,"!~"," ")) I $E(PSB6,1)=" " S PSB6=$E(PSB6,2,999)
S PSBX2=" User's Comment...........: "_PSB6
D ;Wrap user comment if neccesary
.N FL S FL=PSBX1
.I $L(PSBX2)'>75 S PSBMSG(PSBX1)=PSBX2 Q
.F PSBX3=1:1:$L(PSBX2," ") D
..I $L($P(PSBX2," ",1,PSBX3))>75 S PSBMSG(PSBX1)=$S(PSBX1=FL:"",1:" ")_$P(PSBX2," ",1,PSBX3-1),PSBX2=$P(PSBX2," ",PSBX3,999),PSBX1=PSBX1+1,PSBX3=1
.I $L(PSBX2)>0 S PSBMSG(PSBX1+1)=" "_PSBX2
S XMY("G."_PSBMG)="",XMTEXT="PSBMSG(",XMSUB="BCMA - Unable to Scan "_PSB4_": "_PSB2
D ^XMD ; Send Message
;
; Clean-up
K PSBMSG,XMY,XMSUB,XMTEXT,PSBX1,PSBX2,PSBX3
;
; Dynamic - Remove the user from Group if not a member originally!
I $D(PSBDROP(0)) S XMY(PSBDROP(0))="",X=$$DM^XMBGRP(PSBMG,.XMY)
F XX=1:1 Q:'$D(PSBDROP(XX)) S XMY(PSBDROP(XX))="",X=$$DM^XMBGRP(PSBMG,.XMY)
CLEANMSF K PSBDROP,PSBMG,XMY
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBMLU 5137 printed Dec 13, 2024@01:40:14 Page 2
PSBMLU ;BIRMINGHAM/EFC - BCMA MEDICATION LOG FUNCTIONS ;6/25/10 6:44am
+1 ;;3.0;BAR CODE MED ADMIN;**6,11,13,28,42**;Mar 2004;Build 23
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; DEM^VADPT/10061
EN ;
+1 QUIT
+2 ;
AUDIT(IEN,TXT,PSBTRN) ; Append and Audit
+1 DO NOW^%DTC
+2 SET RDAT=%
+3 if PSBTRN="ADD COMMENT"
Begin DoDot:1
+4 NEW XA
+5 SET XA=$ORDER(^PSB(53.79,IEN,.3,"A"),-1)
+6 SET RDAT=$PIECE(^PSB(53.79,IEN,.3,XA,0),U,3)
End DoDot:1
+7 if PSBTRN="PRN EFFECTIVENESS"
Begin DoDot:1
+8 SET RDAT=$PIECE(^PSB(53.79,IEN,.2),U,4)
End DoDot:1
+9 if PSBTRN="UPDATE STATUS"
Begin DoDot:1
+10 SET RDAT=$PIECE(^PSB(53.79,IEN,0),U,6)
End DoDot:1
+11 if PSBTRN="MEDPASS"
Begin DoDot:1
+12 SET RDAT=$PIECE(^PSB(53.79,IEN,0),U,6)
End DoDot:1
+13 if '$DATA(^PSB(53.79,IEN,.9,0))
SET ^(0)="^53.799D^^"
+14 SET PSBAD1=""
+15 SET PSBAD1=$ORDER(^PSB(53.79,IEN,.9,"A"),-1)+1
+16 SET ^PSB(53.79,IEN,.9,PSBAD1,0)=RDAT_U_DUZ_U_TXT
+17 QUIT
+18 ;
ERROR(PSB1,PSB2,DFN,PSB3,PSB4,PSB5,PSB6,PSB7) ;
+1 ; PSB1 = order #
+2 ; PSB2 = orderable item
+3 ; PSB3 = message to be sent
+4 ; PSB4 = schedule
+5 ; PSB5 = action date/time
+6 ; PSB6 = med log ien #
+7 ; PSB7 = user identification
+8 ; Send Error Msg about problems
+9 KILL PSBMG
SET PSBMG=$$GET^XPAR("DIV",$SELECT($GET(PSBADMER):"PSB MG ADMIN ERROR",1:"PSB MG DUE LIST ERROR"),,"E")
+10 if PSBMG=""
QUIT
+11 SET PSBMSG(1)=" The following "_$SELECT($GET(PSBADMER):"administration",1:"order")_" was NOT displayed"
+12 SET PSBMSG(2)=" on the Virtual Due List"
+13 SET PSBMSG(3)=" "
+14 SET PSBMSG(4)=" Order Number....: "_PSB1
+15 SET PSBMSG(5)=" Orderable Item..: "_PSB2
+16 NEW VA,VADM
DO DEM^VADPT
+17 SET PSBMSG(6)=" Patient.........: "_VADM(1)_" ("_$TRANSLATE(VA("PID"),"-")_")"
+18 SET PSBMSG(7)=" Ward/Bed........: "_$$GET1^DIQ(2,DFN_",",.1)_"/"_$$GET1^DIQ(2,DFN_",",.101)
+19 SET PSBMSG(8)=" Reason..........: "_PSB3
+20 SET PSBMSG(9)=" Schedule........: "_PSB4
+21 IF $DATA(PSB5)
SET PSBMSG(10)=" Action Dt/Tm....: "_PSB5
+22 IF $DATA(PSB6)
SET PSBMSG(11)=" BCMA Med Log IEN: "_PSB6
+23 IF $DATA(PSB7)
SET PSBMSG(12)=" User............: "_PSB7
+24 SET XMY("G."_PSBMG)=""
SET XMTEXT="PSBMSG("
SET XMSUB="BCMA - "_$SELECT($GET(PSBADMER):"Admin "_$GET(PSB6),1:"Order")_" Problem"
+25 KILL PSBADMER
+26 DO ^XMD
+27 KILL PSB1,PSB2,PSB3,PSB4,PSBMSG,PSBMG,XMY,XMSUB,XMTEXT
+28 QUIT
+29 ;
MSFMSG(PSB1,PSB2,PSB3,PSB4,PSB5,PSB6,PSB7,PSB8,XFLG) ;
+1 ; PSB1 = Patient IEN
+2 ; PSB2 = Ward Location/Room
+3 ; PSB3 = Reason
+4 ; PSB4 = Type of Scan Issue
+5 ; PSB5 = Event date/time
+6 ; PSB6 = User's Comment
+7 ; PSB7 = User identification
+8 ; PSB8 = Order Number
+9 ; XFLG = -1 IF UNSUCCESSFU
+10 ;
+11 SET PSBMG=$$GET^XPAR("DIV","PSB MG SCANNING FAILURES",,"E")
SET PSBX1=9
+12 IF PSBMG=""
SET XFLG(0)=-1
QUIT
+13 IF PSB2["$"
SET PSB2=$TRANSLATE(PSB2,"$","/")
+14 KILL PSBDROP
+15 ;
+16 ; Dynamic - Add the 'user' to Group if not a member!
+17 IF '$$MEMBER^XMXAPIG(DUZ,PSBMG)
SET XMY(DUZ)=""
SET X=$$MG^XMBGRP(PSBMG,"","","",.XMY,"","")
if X>0
SET PSBDROP(0)=DUZ
KILL XMY
+18 ;
+19 SET PSBMSG(1)=" The following BCMA Unable to Scan event has occurred:"
+20 SET PSBMSG(2)=" "
+21 SET PSBMSG(3)=" User.....................: "_PSB7
+22 SET PSBMSG(4)=" Date/Time of Event.......: "_PSB5
+23 NEW PSBDPT
SET PSBDPT=""
IF +$GET(PSB1)>0
SET DFN=PSB1
DO DEM^VADPT
SET PSBDPT=VADM(1)_" ("_VA("BID")_")"
+24 SET PSBMSG(5)=" Patient..................: "_PSBDPT
+25 SET PSBMSG(6)=" Order Number.............: "_$SELECT(PSB8]"":PSB8,1:"N/A")
+26 SET PSBMSG(7)=" Ward Location/Room.......: "_PSB2
+27 SET PSBMSG(8)=" Type of Barcode Issue....: "_PSB4
+28 IF PSB4="Medication"
Begin DoDot:1
+29 IF PSB8]""
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,PSB8)
+30 IF $DATA(PSBSFUID)
IF $GET(PSBSFUID)]""
Begin DoDot:2
+31 ;Set the Unique ID value
Begin DoDot:3
+32 IF PSB6["Verify 5 Rights Override"
SET PSBSFUID="WARD STOCK"
QUIT
+33 IF PSBSFUID="WS"
SET PSBSFUID="WARD STOCK"
QUIT
+34 IF PSBSFUID["WS"
SET PSBSFUID="WARD STOCK ("_PSBSFUID_")"
End DoDot:3
+35 SET PSBMSG(PSBX1)=" Unique ID................: "_PSBSFUID
SET PSBX1=PSBX1+1
+36 SET PSBMSG(PSBX1)=" Orderable Item...........: "_PSBOITX
SET PSBX1=PSBX1+1
End DoDot:2
QUIT
+37 IF '$DATA(PSBSFUID)
IF $GET(PSBMEDNM)]""
Begin DoDot:2
+38 IF $DATA(PSBMEDNM)
SET PSBMSG(PSBX1)=" Dispense Drug............: "_PSBMEDNM_$SELECT($GET(PSBMEDOI)]"":" ("_PSBMEDOI_")",1:"")
SET PSBX1=PSBX1+1
+39 IF $GET(PSBDOSE)]""
SET PSBMSG(PSBX1)=" Dosage Ordered...........: "_PSBDOSE
SET PSBX1=PSBX1+1
QUIT
End DoDot:2
QUIT
+40 IF '$DATA(PSBSFUID)
IF $GET(PSBMEDNM)=""
Begin DoDot:2
+41 SET PSBMSG(PSBX1)=" Unique ID................: WARD STOCK"
SET PSBX1=PSBX1+1
+42 SET PSBMSG(PSBX1)=" Orderable Item...........: "_PSBOITX
SET PSBX1=PSBX1+1
End DoDot:2
QUIT
End DoDot:1
+43 SET PSBMSG(PSBX1)=" Reason Unable to Scan....: "_PSB3
SET PSBX1=PSBX1+1
+44 SET PSB6=$SELECT($EXTRACT(PSB6,1,2)="!~":$TRANSLATE(PSB6,"!~",""),1:$TRANSLATE(PSB6,"!~"," "))
IF $EXTRACT(PSB6,1)=" "
SET PSB6=$EXTRACT(PSB6,2,999)
+45 SET PSBX2=" User's Comment...........: "_PSB6
+46 ;Wrap user comment if neccesary
Begin DoDot:1
+47 NEW FL
SET FL=PSBX1
+48 IF $LENGTH(PSBX2)'>75
SET PSBMSG(PSBX1)=PSBX2
QUIT
+49 FOR PSBX3=1:1:$LENGTH(PSBX2," ")
Begin DoDot:2
+50 IF $LENGTH($PIECE(PSBX2," ",1,PSBX3))>75
SET PSBMSG(PSBX1)=$SELECT(PSBX1=FL:"",1:" ")_$PIECE(PSBX2," ",1,PSBX3-1)
SET PSBX2=$PIECE(PSBX2," ",PSBX3,999)
SET PSBX1=PSBX1+1
SET PSBX3=1
End DoDot:2
+51 IF $LENGTH(PSBX2)>0
SET PSBMSG(PSBX1+1)=" "_PSBX2
End DoDot:1
+52 SET XMY("G."_PSBMG)=""
SET XMTEXT="PSBMSG("
SET XMSUB="BCMA - Unable to Scan "_PSB4_": "_PSB2
+53 ; Send Message
DO ^XMD
+54 ;
+55 ; Clean-up
+56 KILL PSBMSG,XMY,XMSUB,XMTEXT,PSBX1,PSBX2,PSBX3
+57 ;
+58 ; Dynamic - Remove the user from Group if not a member originally!
+59 IF $DATA(PSBDROP(0))
SET XMY(PSBDROP(0))=""
SET X=$$DM^XMBGRP(PSBMG,.XMY)
+60 FOR XX=1:1
if '$DATA(PSBDROP(XX))
QUIT
SET XMY(PSBDROP(XX))=""
SET X=$$DM^XMBGRP(PSBMG,.XMY)
CLEANMSF KILL PSBDROP,PSBMG,XMY
+1 QUIT
+2 ;
