PSBOML ;BIRMINGHAM/EFC - MEDICATION LOG ;Sep 09, 2020@14:17:51
;;3.0;BAR CODE MED ADMIN;**3,11,50,54,70,72,83,82**;Mar 2004;Build 27
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; ^DPT/10035
; SENDMSG^XMXAPI/2729
; ^XLFDT/10103
;
;*70 - Add Witness for High Risk Drug to report
; - print Clinic name with each order that occurred in a clinic
; - set psbclinord=2 for dual hdr text
; - create var for Search list and use for both IM & CO, pass to
; PSBOHDR api
; - 1489: Blended PSB*3*54 with PSB*3*70
;*83 - Add MRR meds remove times to report.
;
EN ; Begin printing
N PSBSTRT,PSBSTOP,PSBHDR,DFN,PSBSORT,PSBSRCHL,PSBTMPG,PSBAUDF,PSBGBL
S PSBSORT=$P(PSBRPT(.1),U,1) ;*70
S PSBSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)
S PSBSTOP=$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
S PSBAUDF=$P(PSBRPT(.2),U,9)
S PSBHDR(0)="Medication Log Report for "_$$FMTE^XLFDT(PSBSTRT)_" to "_$$FMTE^XLFDT(PSBSTOP) ;Add time frame for report header, PSB*3*72
S PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (Detailed Log) (VAF 10-2970 B, C, D)"
;check Clinic or Nurs Unit search list *70
S PSBSRCHL=$$SRCHLIST^PSBOHDR()
;
; Patient Report
;
D:PSBSORT="P"
.S PSBHDR(2)="Log Type: INDIVIDUAL PATIENT"
.S DFN=+$P(PSBRPT(.1),U,2)
.W $$PTHDR()
.S X=$O(^PSB(53.79,"AADT",DFN,PSBSTRT-.0000001))
.I X>PSBSTOP!(X="") W !!?10,"<<<< NO MEDICATIONS FOUND FOR THIS TIME FRAME >>>>",!! Q
.S PSBGBL=$NAME(^PSB(53.79,"AADT",DFN,PSBSTRT-.0000001))
.F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:$QS(PSBGBL,2)'="AADT"!($QS(PSBGBL,3)'=DFN)!($QS(PSBGBL,4)>PSBSTOP) D
..S PSBIEN=$QS(PSBGBL,5) Q:'$D(^PSB(53.79,PSBIEN))
..I $P(^PSB(53.79,PSBIEN,0),U,6)'=$QS(PSBGBL,4) Q
..I $Y>(IOSL-10) W $$PTFTR^PSBOHDR(),$$PTHDR()
..W $$LINE(PSBIEN)
.W $$PTFTR^PSBOHDR()
;
; Ward Output
;
D:PSBSORT="W"
.S PSBHDR(2)="LOG TYPE: WARD"
.W $$WDHDR(PSBWRD)
.S PSBTMPG=$NAME(^TMP("PSBO",$J,"B"))
.F S PSBTMPG=$Q(@PSBTMPG) Q:PSBTMPG="" Q:$QS(PSBTMPG,1)'="PSBO"!($QS(PSBTMPG,2)'=$J) D
..S DFN=$QS(PSBTMPG,5)
..I $Y>(IOSL-14) W $$WDHDR(PSBWRD)
..W !,$P(^DPT(DFN,0),U)," (",$P(^(0),U,9),")"
..W !,"Ward: ",$G(^DPT(DFN,.1),"***")," Rm-Bed: ",$G(^DPT(DFN,.101),"***"),!
..S X=$O(^PSB(53.79,"AADT",DFN,PSBSTRT-.0000001))
..I X>PSBSTOP!(X="") W !!?10,"<<<< NO MEDICATIONS FOUND FOR THIS TIME FRAME >>>>",!! Q
..S PSBGBL=$NAME(^PSB(53.79,"AADT",DFN,PSBSTRT-.0000001))
..F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:$QS(PSBGBL,2)'="AADT"!($QS(PSBGBL,3)'=DFN)!($QS(PSBGBL,4)>PSBSTOP) D
...S PSBIEN=$QS(PSBGBL,5) I $P(^PSB(53.79,PSBIEN,0),U,6)'=$QS(PSBGBL,4) Q
...W:$Y>(IOSL-10) $$WDHDR(PSBWRD)
...W $$LINE(PSBIEN)
Q
;
LINE(PSBIEN) ; Displays the med log entry in PSBIEN
N PSBX,PSBASTUS,PSBMME,PSBEXIST,PSBY,PSBZ,PSBDHIT
S X=$P($G(^PSB(53.79,PSBIEN,.1)),U)
I X="" W !,"Error: Med Log Entry ",PSBIEN," has no order reference number!" Q ""
I 'PSBAUDF,$P(^PSB(53.79,PSBIEN,0),U,9)="N" Q ""
D CLEAN^PSBVT
D PSJ1^PSBVT(DFN,X,,.PSBEXIST)
; ;[*70-1489]...start
I '$G(PSBEXIST),($G(PSBSCRT)="-1") D ;send email to BCMA UKNOWN ACTIONS group if order given in BCMA does not have a corresponding # 55 file entry
.N XMDUZ,XMSUB,XMTEXT,XMY,PSBERR,PSBPARAM,PSBMG
.S XMSUB="Order given in BCMA does not exist in Pharmacy Patient file"
.S XMDUZ=DUZ
.S XMTEXT="PSBERR"
.S PSBMG=$$GET^XPAR("DIV","PSB MG ADMIN ERROR",,"E"),PSBMG="G."_PSBMG
.S XMY(PSBMG)=""
.S PSBERR(1)="Order #"_$G(PSBIEN)_" given in BCMA no longer has"
.S PSBERR(2)="a corresponding entry in the Pharmacy Patient (#55) file."
.S PSBERR(3)="Please submit a remedy ticket for this issue."
.D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY)
.Q
; ;[*70-1489]...end
I PSBDFN="-1" W !,"Error: Inpatient Meds API Failure!" Q ""
M PSBX=^PSB(53.79,PSBIEN)
S Y=$P(PSBX(0),U,4)+.0000001
;*70 print location name per each clinic order
S PSBMME=$$MME(+$G(PSBIEN)) I $G(PSBMME),($TR($P(PSBX(0),U,2)," ","")="") S $P(PSBX(0),U,2)="MME/UNKNOWN LOCATION"
W:$P(PSBX(0),U,2)]"" !,?3,$P(PSBX(0),U,2)
W !,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
W " ",$E(Y,9,10),":",$E(Y,11,12)
S Y=$$GET1^DIQ(53.79,PSBIEN_",",.08)
S Y=Y_" ["_$G(PSBDOSE)_$G(PSBIFR)_" "_$G(PSBSCH) ;[*70-1489]
S Y=Y_" "_$G(PSBMRAB) ;[*70-1489]
I $P($G(^PSB(53.79,PSBIEN,.1)),U,8)]"" D ;Inj or Derm site info *83
.S Y=Y_" Derm Site: "_$P(^(.1),U,8)
E D
.S:$P(^(.1),U,6)]"" Y=Y_" Inj Site: "_$P(^(.1),U,6)
;
S Y=Y_"]"
W $$WRAP^PSBO(16,32,Y)
W ?50,$$GETINIT^PSBCSUTX(PSBIEN,"I") ;Get initials of who took action, PSB*3*72
S X=$P(PSBX(0),U,9)
S PSBASTUS=$S(X="G":"Given",X="H":"Held",X="R":"Refused",X="I":"Infusing",X="C":"Completed",X="S":"Stopped",X="N":"Not Given",X="RM":"Removed",X="M":"Missing dose",1:"Status Unknown")
S Y=$P(PSBX(0),U,6)+.0000001
S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$E(Y,9,10)_":"_$E(Y,11,12)
S Y=Y_" "_$G(PSBASTUS) ;[*70-1489]
W $$WRAP^PSBO(57,15,Y)
W:$G(^XTMP("PSB DEBUG",0)) " (",PSBIEN,") " ;debug write 53.79 ien
;
D:PSBASTUS["Removed" ;find Give associated with remove event *83
.N RMEV,INI,PSBDD
.S RMEV=$$FINDGIVE^PSBUTL(PSBIEN)
.S Y=$P(RMEV,U)+.0000001 ;give dt/tm
.S INI=$P(RMEV,U,2) ;give by ini
.S X=$P(RMEV,U,3) ;give sts code
.S PSBASTUS=$S(X="G":"Given",X="H":"Held",X="R":"Refused",X="I":"Infusing",X="C":"Completed",X="S":"Stopped",X="N":"Not Given",X="RM":"Removed",X="M":"Missing dose",1:"Status Unknown")
.W !,?50,INI
.S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$E(Y,9,10)_":"_$E(Y,11,12)
.S Y=Y_" "_$G(PSBASTUS)
.W $$WRAP^PSBO(57,15,Y)
;
W:$P(PSBX(.1),U)["V" ?75,"Bag ID #",$$GET1^DIQ(53.79,PSBIEN,"IV UNIQUE ID")
W:$P(PSBX(.1),U)["V" ?107,"NA",?115,"NA",?120,"NA"
W !,$TR($$FMTE^XLFDT($G(PSBOST),2),"@"," ")_">" ;[*70-1489]
F PSBZ=.5,.6,.7 S PSBDHIT=0 F PSBY=0:0 S PSBY=$O(PSBX(PSBZ,PSBY)) Q:'PSBY D
.W:$X>75 !
.S PSBDD=$S(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
.S Y=$$EXTERNAL^DILFD(PSBDD,.01,"",$P(PSBX(PSBZ,PSBY,0),U,1))
.W $$WRAP^PSBO(75,28,Y)
.I $P(PSBX(.1),U)["U" W ?105,$J($P(PSBX(PSBZ,PSBY,0),U,2),6,2),?113,$J($P(PSBX(PSBZ,PSBY,0),U,3),6,2) W $$WRAP^PSBO(120,12,$P(PSBX(PSBZ,PSBY,0),U,4)) S PSBDHIT=1
.W:$P(PSBX(.1),U)["V"&($X+3+$L($P(PSBX(PSBZ,PSBY,0),U,3))>105) !?75
.W:$P(PSBX(.1),U)["V" " - ",$P(PSBX(PSBZ,PSBY,0),U,2) ;Use units ordered field for IV's, PSB*3*72
D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
.W !?16,"PRN Reason: ",?30,$$GET1^DIQ(53.79,PSBIEN_",",.21)
.W !?16,"PRN Effectiveness: "
.I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" W "<No PRN Effectiveness Entered>" Q
.N PSBEIECMT S PSBEIECMT="" I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)'="",$P(PSBRPT(.2),U,8)=0 S PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,PSBIEN)
.W $$WRAP^PSBO(20,100,$$GET1^DIQ(53.79,PSBIEN_",",.22)_PSBEIECMT)
.W !?20,"Entered By: ",$$GET1^DIQ(53.79,PSBIEN_",",.23)
.W " Date/Time: ",$$GET1^DIQ(53.79,PSBIEN_",",.24)
.W " Minutes: ",$$GET1^DIQ(53.79,PSBIEN_",",.25)
D:$P(PSBRPT(.2),U,8)
.W !?16,"Comments: ",?30 I '$O(PSBX(.3,0)) W "<No Comments>"
.F PSBY=0:0 S PSBY=$O(PSBX(.3,PSBY)) Q:'PSBY D
..W:$X>30 !?30
..S Y=$P(PSBX(.3,PSBY,0),U,3)+.0000001
..W $E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
..W " ",$E(Y,9,10),":",$E(Y,11,12)
..W ?46,$$GET1^DIQ(53.793,PSBY_","_PSBIEN_",","ENTERED BY:INITIAL")
..W $$WRAP^PSBO(52,70,$P(PSBX(.3,PSBY,0),U,1))
.;*70 Witness new line after Comments section chosen
.N WITBY,WITDT,WITCM,WITHR,WITFL
.S WITBY=$$GET1^DIQ(53.79,PSBIEN_",",.29)
.S WITDT=$$GET1^DIQ(53.79,PSBIEN_",",.28,"I")
.S WITCM=$$GET1^DIQ(53.79,PSBIEN_",",.31)
.S WITHR=$$GET1^DIQ(53.79,PSBIEN_",",.32)
.S WITFL=$$GET1^DIQ(53.79,PSBIEN_",",.33)
.I WITBY]"" D
..W !?16,"Witnessed by:",?30,WITBY," on "
..W $P($$FMTE^XLFDT($$GET1^DIQ(53.79,PSBIEN_",",.28,"I"),2),":",1,2)
.I WITFL="NO",WITBY="" D
..W !?16,"Witnessed?:",?30,WITFL
.W:WITCM]"" !,$$WRAP^PSBO(30,102,WITCM)
.;
.W !,$TR($$FMTE^XLFDT($G(PSBOSP),2),"@"," ")_"<" ;[*70-1489]
.;
D:PSBAUDF
.W !?16,"Audits: ",?30 I '$O(PSBX(.9,0)) W "<No Audits>" Q
.F PSBY=0:0 S PSBY=$O(PSBX(.9,PSBY)) Q:'PSBY D
..W:$X>30 !?30
..S Y=$P(PSBX(.9,PSBY,0),U,1)+.0000001
..W $E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
..W " ",$E(Y,9,10),":",$E(Y,11,12)
..W ?46,$$GET1^DIQ(53.799,PSBY_","_PSBIEN_",","USER:INITIAL")
..;*83 special case to alter the how reports Action Status Give from
..;the word "deleted" to "changed" only when a Remove occurs
..;(vs an Undo Give) that triggered the deleted. "deleted" is a key
..;word that other routines test for, fixed via reporting only.
..N ALIN,NXALIN,XX
..S ALIN=$P(PSBX(.9,PSBY,0),U,3)
..S NXALIN=$O(PSBX(.9,PSBY))
..S NXALIN=$S('NXALIN:"",1:$P(PSBX(.9,NXALIN,0),U,3)) ;*82
..;if next action is RM then report Give changed instead of deleted.
..I ALIN["ACTION STATUS",ALIN["deleted",NXALIN["REMOVED" D
...S XX=$P($P(PSBX(.9,PSBY,0),U,3),"deleted"),XX=XX_"changed."
...W $$WRAP^PSBO(52,70,XX)
..E D
...W $$WRAP^PSBO(52,70,$P(PSBX(.9,PSBY,0),U,3))
W !,$TR($J("",IOM)," ","-")
Q ""
;
WDHDR(PSBWARD) ;
N PSBCLINORD S PSBCLINORD=2 ;2=both order type hdr *70
S PSBHDR(3)="",PSBHDR(4)="Ward Location: "
D WARD^PSBOHDR(PSBWARD,.PSBHDR,,,PSBSRCHL)
W $$SUB()
Q ""
;
PTHDR() ;
N PSBCLINORD S PSBCLINORD=2 ;2=both order type hdr *70
S:$G(PSBSRCHL)]"" PSBHDR(3)="",PSBHDR(4)="Ward Location: "
D PT^PSBOHDR(DFN,.PSBHDR,,,PSBSRCHL)
W $$SUB()
Q ""
;
SUB() ; Med Log Sub Header
W:$X>1 !
W "Location",!
W "Activity Date",?16,"Orderable Item",?50,"Action",?57,"Action"
W !,"Start Date>",?16,"[Dose/Sched/Route/Body Site]",?50,"By"
W ?57,"Date/Time",?75,"Drug/Additive/Solution",?105," U/Ord"
W ?113," U/Gvn",?120,"Unit",!,"Stop Date<"
W !,$TR($J("",IOM)," ","-")
Q ""
;
MME(PSBIEN) ; Administered via Manual Med Entry?
N MME,CMMT,CMMTND S MME=0
S CMMT="" F S CMMT=$O(^PSB(53.79,+PSBIEN,.3,CMMT)) Q:CMMT=""!$G(MME) D
.S CMMTND=$G(^PSB(53.79,+PSBIEN,.3,CMMT,0)) I CMMTND["Entry created with 'Manual Medication Entry'" S MME=1
Q $S($G(MME):1,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOML 10241 printed Apr 09, 2024@20:46:09 Page 2
PSBOML ;BIRMINGHAM/EFC - MEDICATION LOG ;Sep 09, 2020@14:17:51
+1 ;;3.0;BAR CODE MED ADMIN;**3,11,50,54,70,72,83,82**;Mar 2004;Build 27
+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 ; SENDMSG^XMXAPI/2729
+7 ; ^XLFDT/10103
+8 ;
+9 ;*70 - Add Witness for High Risk Drug to report
+10 ; - print Clinic name with each order that occurred in a clinic
+11 ; - set psbclinord=2 for dual hdr text
+12 ; - create var for Search list and use for both IM & CO, pass to
+13 ; PSBOHDR api
+14 ; - 1489: Blended PSB*3*54 with PSB*3*70
+15 ;*83 - Add MRR meds remove times to report.
+16 ;
EN ; Begin printing
+1 NEW PSBSTRT,PSBSTOP,PSBHDR,DFN,PSBSORT,PSBSRCHL,PSBTMPG,PSBAUDF,PSBGBL
+2 ;*70
SET PSBSORT=$PIECE(PSBRPT(.1),U,1)
+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 SET PSBAUDF=$PIECE(PSBRPT(.2),U,9)
+6 ;Add time frame for report header, PSB*3*72
SET PSBHDR(0)="Medication Log Report for "_$$FMTE^XLFDT(PSBSTRT)_" to "_$$FMTE^XLFDT(PSBSTOP)
+7 SET PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (Detailed Log) (VAF 10-2970 B, C, D)"
+8 ;check Clinic or Nurs Unit search list *70
+9 SET PSBSRCHL=$$SRCHLIST^PSBOHDR()
+10 ;
+11 ; Patient Report
+12 ;
+13 if PSBSORT="P"
Begin DoDot:1
+14 SET PSBHDR(2)="Log Type: INDIVIDUAL PATIENT"
+15 SET DFN=+$PIECE(PSBRPT(.1),U,2)
+16 WRITE $$PTHDR()
+17 SET X=$ORDER(^PSB(53.79,"AADT",DFN,PSBSTRT-.0000001))
+18 IF X>PSBSTOP!(X="")
WRITE !!?10,"<<<< NO MEDICATIONS FOUND FOR THIS TIME FRAME >>>>",!!
QUIT
+19 SET PSBGBL=$NAME(^PSB(53.79,"AADT",DFN,PSBSTRT-.0000001))
+20 FOR
SET PSBGBL=$QUERY(@PSBGBL)
if PSBGBL=""
QUIT
if $QSUBSCRIPT(PSBGBL,2)'="AADT"!($QSUBSCRIPT(PSBGBL,3)'=DFN)!($QSUBSCRIPT(PSBGBL,4)>PSBSTOP)
QUIT
Begin DoDot:2
+21 SET PSBIEN=$QSUBSCRIPT(PSBGBL,5)
if '$DATA(^PSB(53.79,PSBIEN))
QUIT
+22 IF $PIECE(^PSB(53.79,PSBIEN,0),U,6)'=$QSUBSCRIPT(PSBGBL,4)
QUIT
+23 IF $Y>(IOSL-10)
WRITE $$PTFTR^PSBOHDR(),$$PTHDR()
+24 WRITE $$LINE(PSBIEN)
End DoDot:2
+25 WRITE $$PTFTR^PSBOHDR()
End DoDot:1
+26 ;
+27 ; Ward Output
+28 ;
+29 if PSBSORT="W"
Begin DoDot:1
+30 SET PSBHDR(2)="LOG TYPE: WARD"
+31 WRITE $$WDHDR(PSBWRD)
+32 SET PSBTMPG=$NAME(^TMP("PSBO",$JOB,"B"))
+33 FOR
SET PSBTMPG=$QUERY(@PSBTMPG)
if PSBTMPG=""
QUIT
if $QSUBSCRIPT(PSBTMPG,1)'="PSBO"!($QSUBSCRIPT(PSBTMPG,2)'=$JOB)
QUIT
Begin DoDot:2
+34 SET DFN=$QSUBSCRIPT(PSBTMPG,5)
+35 IF $Y>(IOSL-14)
WRITE $$WDHDR(PSBWRD)
+36 WRITE !,$PIECE(^DPT(DFN,0),U)," (",$PIECE(^(0),U,9),")"
+37 WRITE !,"Ward: ",$GET(^DPT(DFN,.1),"***")," Rm-Bed: ",$GET(^DPT(DFN,.101),"***"),!
+38 SET X=$ORDER(^PSB(53.79,"AADT",DFN,PSBSTRT-.0000001))
+39 IF X>PSBSTOP!(X="")
WRITE !!?10,"<<<< NO MEDICATIONS FOUND FOR THIS TIME FRAME >>>>",!!
QUIT
+40 SET PSBGBL=$NAME(^PSB(53.79,"AADT",DFN,PSBSTRT-.0000001))
+41 FOR
SET PSBGBL=$QUERY(@PSBGBL)
if PSBGBL=""
QUIT
if $QSUBSCRIPT(PSBGBL,2)'="AADT"!($QSUBSCRIPT(PSBGBL,3)'=DFN)!($QSUBSCRIPT(PSBGBL,4)>PSBSTOP)
QUIT
Begin DoDot:3
+42 SET PSBIEN=$QSUBSCRIPT(PSBGBL,5)
IF $PIECE(^PSB(53.79,PSBIEN,0),U,6)'=$QSUBSCRIPT(PSBGBL,4)
QUIT
+43 if $Y>(IOSL-10)
WRITE $$WDHDR(PSBWRD)
+44 WRITE $$LINE(PSBIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
LINE(PSBIEN) ; Displays the med log entry in PSBIEN
+1 NEW PSBX,PSBASTUS,PSBMME,PSBEXIST,PSBY,PSBZ,PSBDHIT
+2 SET X=$PIECE($GET(^PSB(53.79,PSBIEN,.1)),U)
+3 IF X=""
WRITE !,"Error: Med Log Entry ",PSBIEN," has no order reference number!"
QUIT ""
+4 IF 'PSBAUDF
IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="N"
QUIT ""
+5 DO CLEAN^PSBVT
+6 DO PSJ1^PSBVT(DFN,X,,.PSBEXIST)
+7 ; ;[*70-1489]...start
+8 ;send email to BCMA UKNOWN ACTIONS group if order given in BCMA does not have a corresponding # 55 file entry
IF '$GET(PSBEXIST)
IF ($GET(PSBSCRT)="-1")
Begin DoDot:1
+9 NEW XMDUZ,XMSUB,XMTEXT,XMY,PSBERR,PSBPARAM,PSBMG
+10 SET XMSUB="Order given in BCMA does not exist in Pharmacy Patient file"
+11 SET XMDUZ=DUZ
+12 SET XMTEXT="PSBERR"
+13 SET PSBMG=$$GET^XPAR("DIV","PSB MG ADMIN ERROR",,"E")
SET PSBMG="G."_PSBMG
+14 SET XMY(PSBMG)=""
+15 SET PSBERR(1)="Order #"_$GET(PSBIEN)_" given in BCMA no longer has"
+16 SET PSBERR(2)="a corresponding entry in the Pharmacy Patient (#55) file."
+17 SET PSBERR(3)="Please submit a remedy ticket for this issue."
+18 DO SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY)
+19 QUIT
End DoDot:1
+20 ; ;[*70-1489]...end
+21 IF PSBDFN="-1"
WRITE !,"Error: Inpatient Meds API Failure!"
QUIT ""
+22 MERGE PSBX=^PSB(53.79,PSBIEN)
+23 SET Y=$PIECE(PSBX(0),U,4)+.0000001
+24 ;*70 print location name per each clinic order
+25 SET PSBMME=$$MME(+$GET(PSBIEN))
IF $GET(PSBMME)
IF ($TRANSLATE($PIECE(PSBX(0),U,2)," ","")="")
SET $PIECE(PSBX(0),U,2)="MME/UNKNOWN LOCATION"
+26 if $PIECE(PSBX(0),U,2)]""
WRITE !,?3,$PIECE(PSBX(0),U,2)
+27 WRITE !,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
+28 WRITE " ",$EXTRACT(Y,9,10),":",$EXTRACT(Y,11,12)
+29 SET Y=$$GET1^DIQ(53.79,PSBIEN_",",.08)
+30 ;[*70-1489]
SET Y=Y_" ["_$GET(PSBDOSE)_$GET(PSBIFR)_" "_$GET(PSBSCH)
+31 ;[*70-1489]
SET Y=Y_" "_$GET(PSBMRAB)
+32 ;Inj or Derm site info *83
IF $PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,8)]""
Begin DoDot:1
+33 SET Y=Y_" Derm Site: "_$PIECE(^(.1),U,8)
End DoDot:1
+34 IF '$TEST
Begin DoDot:1
+35 if $PIECE(^(.1),U,6)]""
SET Y=Y_" Inj Site: "_$PIECE(^(.1),U,6)
End DoDot:1
+36 ;
+37 SET Y=Y_"]"
+38 WRITE $$WRAP^PSBO(16,32,Y)
+39 ;Get initials of who took action, PSB*3*72
WRITE ?50,$$GETINIT^PSBCSUTX(PSBIEN,"I")
+40 SET X=$PIECE(PSBX(0),U,9)
+41 SET PSBASTUS=$SELECT(X="G":"Given",X="H":"Held",X="R":"Refused",X="I":"Infusing",X="C":"Completed",X="S":"Stopped",X="N":"Not Given",X="RM":"Removed",X="M":"Missing dose",1:"Status Unknown")
+42 SET Y=$PIECE(PSBX(0),U,6)+.0000001
+43 SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_" "_$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12)
+44 ;[*70-1489]
SET Y=Y_" "_$GET(PSBASTUS)
+45 WRITE $$WRAP^PSBO(57,15,Y)
+46 ;debug write 53.79 ien
if $GET(^XTMP("PSB DEBUG",0))
WRITE " (",PSBIEN,") "
+47 ;
+48 ;find Give associated with remove event *83
if PSBASTUS["Removed"
Begin DoDot:1
+49 NEW RMEV,INI,PSBDD
+50 SET RMEV=$$FINDGIVE^PSBUTL(PSBIEN)
+51 ;give dt/tm
SET Y=$PIECE(RMEV,U)+.0000001
+52 ;give by ini
SET INI=$PIECE(RMEV,U,2)
+53 ;give sts code
SET X=$PIECE(RMEV,U,3)
+54 SET PSBASTUS=$SELECT(X="G":"Given",X="H":"Held",X="R":"Refused",X="I":"Infusing",X="C":"Completed",X="S":"Stopped",X="N":"Not Given",X="RM":"Removed",X="M":"Missing dose",1:"Status Unknown")
+55 WRITE !,?50,INI
+56 SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_" "_$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12)
+57 SET Y=Y_" "_$GET(PSBASTUS)
+58 WRITE $$WRAP^PSBO(57,15,Y)
End DoDot:1
+59 ;
+60 if $PIECE(PSBX(.1),U)["V"
WRITE ?75,"Bag ID #",$$GET1^DIQ(53.79,PSBIEN,"IV UNIQUE ID")
+61 if $PIECE(PSBX(.1),U)["V"
WRITE ?107,"NA",?115,"NA",?120,"NA"
+62 ;[*70-1489]
WRITE !,$TRANSLATE($$FMTE^XLFDT($GET(PSBOST),2),"@"," ")_">"
+63 FOR PSBZ=.5,.6,.7
SET PSBDHIT=0
FOR PSBY=0:0
SET PSBY=$ORDER(PSBX(PSBZ,PSBY))
if 'PSBY
QUIT
Begin DoDot:1
+64 if $X>75
WRITE !
+65 SET PSBDD=$SELECT(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
+66 SET Y=$$EXTERNAL^DILFD(PSBDD,.01,"",$PIECE(PSBX(PSBZ,PSBY,0),U,1))
+67 WRITE $$WRAP^PSBO(75,28,Y)
+68 IF $PIECE(PSBX(.1),U)["U"
WRITE ?105,$JUSTIFY($PIECE(PSBX(PSBZ,PSBY,0),U,2),6,2),?113,$JUSTIFY($PIECE(PSBX(PSBZ,PSBY,0),U,3),6,2)
WRITE $$WRAP^PSBO(120,12,$PIECE(PSBX(PSBZ,PSBY,0),U,4))
SET PSBDHIT=1
+69 if $PIECE(PSBX(.1),U)["V"&($X+3+$LENGTH($PIECE(PSBX(PSBZ,PSBY,0),U,3))>105)
WRITE !?75
+70 ;Use units ordered field for IV's, PSB*3*72
if $PIECE(PSBX(.1),U)["V"
WRITE " - ",$PIECE(PSBX(PSBZ,PSBY,0),U,2)
End DoDot:1
+71 if $PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)="P"
Begin DoDot:1
+72 WRITE !?16,"PRN Reason: ",?30,$$GET1^DIQ(53.79,PSBIEN_",",.21)
+73 WRITE !?16,"PRN Effectiveness: "
+74 IF $PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,2)=""
WRITE "<No PRN Effectiveness Entered>"
QUIT
+75 NEW PSBEIECMT
SET PSBEIECMT=""
IF $PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,2)'=""
IF $PIECE(PSBRPT(.2),U,8)=0
SET PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,PSBIEN)
+76 WRITE $$WRAP^PSBO(20,100,$$GET1^DIQ(53.79,PSBIEN_",",.22)_PSBEIECMT)
+77 WRITE !?20,"Entered By: ",$$GET1^DIQ(53.79,PSBIEN_",",.23)
+78 WRITE " Date/Time: ",$$GET1^DIQ(53.79,PSBIEN_",",.24)
+79 WRITE " Minutes: ",$$GET1^DIQ(53.79,PSBIEN_",",.25)
End DoDot:1
+80 if $PIECE(PSBRPT(.2),U,8)
Begin DoDot:1
+81 WRITE !?16,"Comments: ",?30
IF '$ORDER(PSBX(.3,0))
WRITE "<No Comments>"
+82 FOR PSBY=0:0
SET PSBY=$ORDER(PSBX(.3,PSBY))
if 'PSBY
QUIT
Begin DoDot:2
+83 if $X>30
WRITE !?30
+84 SET Y=$PIECE(PSBX(.3,PSBY,0),U,3)+.0000001
+85 WRITE $EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
+86 WRITE " ",$EXTRACT(Y,9,10),":",$EXTRACT(Y,11,12)
+87 WRITE ?46,$$GET1^DIQ(53.793,PSBY_","_PSBIEN_",","ENTERED BY:INITIAL")
+88 WRITE $$WRAP^PSBO(52,70,$PIECE(PSBX(.3,PSBY,0),U,1))
End DoDot:2
+89 ;*70 Witness new line after Comments section chosen
+90 NEW WITBY,WITDT,WITCM,WITHR,WITFL
+91 SET WITBY=$$GET1^DIQ(53.79,PSBIEN_",",.29)
+92 SET WITDT=$$GET1^DIQ(53.79,PSBIEN_",",.28,"I")
+93 SET WITCM=$$GET1^DIQ(53.79,PSBIEN_",",.31)
+94 SET WITHR=$$GET1^DIQ(53.79,PSBIEN_",",.32)
+95 SET WITFL=$$GET1^DIQ(53.79,PSBIEN_",",.33)
+96 IF WITBY]""
Begin DoDot:2
+97 WRITE !?16,"Witnessed by:",?30,WITBY," on "
+98 WRITE $PIECE($$FMTE^XLFDT($$GET1^DIQ(53.79,PSBIEN_",",.28,"I"),2),":",1,2)
End DoDot:2
+99 IF WITFL="NO"
IF WITBY=""
Begin DoDot:2
+100 WRITE !?16,"Witnessed?:",?30,WITFL
End DoDot:2
+101 if WITCM]""
WRITE !,$$WRAP^PSBO(30,102,WITCM)
+102 ;
+103 ;[*70-1489]
WRITE !,$TRANSLATE($$FMTE^XLFDT($GET(PSBOSP),2),"@"," ")_"<"
+104 ;
End DoDot:1
+105 if PSBAUDF
Begin DoDot:1
+106 WRITE !?16,"Audits: ",?30
IF '$ORDER(PSBX(.9,0))
WRITE "<No Audits>"
QUIT
+107 FOR PSBY=0:0
SET PSBY=$ORDER(PSBX(.9,PSBY))
if 'PSBY
QUIT
Begin DoDot:2
+108 if $X>30
WRITE !?30
+109 SET Y=$PIECE(PSBX(.9,PSBY,0),U,1)+.0000001
+110 WRITE $EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
+111 WRITE " ",$EXTRACT(Y,9,10),":",$EXTRACT(Y,11,12)
+112 WRITE ?46,$$GET1^DIQ(53.799,PSBY_","_PSBIEN_",","USER:INITIAL")
+113 ;*83 special case to alter the how reports Action Status Give from
+114 ;the word "deleted" to "changed" only when a Remove occurs
+115 ;(vs an Undo Give) that triggered the deleted. "deleted" is a key
+116 ;word that other routines test for, fixed via reporting only.
+117 NEW ALIN,NXALIN,XX
+118 SET ALIN=$PIECE(PSBX(.9,PSBY,0),U,3)
+119 SET NXALIN=$ORDER(PSBX(.9,PSBY))
+120 ;*82
SET NXALIN=$SELECT('NXALIN:"",1:$PIECE(PSBX(.9,NXALIN,0),U,3))
+121 ;if next action is RM then report Give changed instead of deleted.
+122 IF ALIN["ACTION STATUS"
IF ALIN["deleted"
IF NXALIN["REMOVED"
Begin DoDot:3
+123 SET XX=$PIECE($PIECE(PSBX(.9,PSBY,0),U,3),"deleted")
SET XX=XX_"changed."
+124 WRITE $$WRAP^PSBO(52,70,XX)
End DoDot:3
+125 IF '$TEST
Begin DoDot:3
+126 WRITE $$WRAP^PSBO(52,70,$PIECE(PSBX(.9,PSBY,0),U,3))
End DoDot:3
End DoDot:2
End DoDot:1
+127 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+128 QUIT ""
+129 ;
WDHDR(PSBWARD) ;
+1 ;2=both order type hdr *70
NEW PSBCLINORD
SET PSBCLINORD=2
+2 SET PSBHDR(3)=""
SET PSBHDR(4)="Ward Location: "
+3 DO WARD^PSBOHDR(PSBWARD,.PSBHDR,,,PSBSRCHL)
+4 WRITE $$SUB()
+5 QUIT ""
+6 ;
PTHDR() ;
+1 ;2=both order type hdr *70
NEW PSBCLINORD
SET PSBCLINORD=2
+2 if $GET(PSBSRCHL)]""
SET PSBHDR(3)=""
SET PSBHDR(4)="Ward Location: "
+3 DO PT^PSBOHDR(DFN,.PSBHDR,,,PSBSRCHL)
+4 WRITE $$SUB()
+5 QUIT ""
+6 ;
SUB() ; Med Log Sub Header
+1 if $X>1
WRITE !
+2 WRITE "Location",!
+3 WRITE "Activity Date",?16,"Orderable Item",?50,"Action",?57,"Action"
+4 WRITE !,"Start Date>",?16,"[Dose/Sched/Route/Body Site]",?50,"By"
+5 WRITE ?57,"Date/Time",?75,"Drug/Additive/Solution",?105," U/Ord"
+6 WRITE ?113," U/Gvn",?120,"Unit",!,"Stop Date<"
+7 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+8 QUIT ""
+9 ;
MME(PSBIEN) ; Administered via Manual Med Entry?
+1 NEW MME,CMMT,CMMTND
SET MME=0
+2 SET CMMT=""
FOR
SET CMMT=$ORDER(^PSB(53.79,+PSBIEN,.3,CMMT))
if CMMT=""!$GET(MME)
QUIT
Begin DoDot:1
+3 SET CMMTND=$GET(^PSB(53.79,+PSBIEN,.3,CMMT,0))
IF CMMTND["Entry created with 'Manual Medication Entry'"
SET MME=1
End DoDot:1
+4 QUIT $SELECT($GET(MME):1,1:0)
