PSBVDLRM ;BIRMINGHAM/EFC-BCMA UNIT DOSE VIRTUAL DUE LIST REMOVE MEDS ;2/6/21 18:24
;;3.0;BAR CODE MED ADMIN;**83,114,106**;Mar 2004;Build 43
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; called by PSBVDLUD to find Medications needing removal (MRR) then
; add to Results for VDL display.
;
; Reference/IA
; $$GET^XPAR/2263
; $$FMADD^XLFDT/10103
; GETPROVL^PSGSICH1/5653
; INTRDIC^PSGSICH1/5654
;
;*83 - Read Medlog for remove medications types MRR, other than form
; of PATCH, and add 34th & 35th piece to Results.
; Remove flag & Remove time
;*106- add Hazardous to Handle & Dispose flags 36 & 37
;
EN ;Search the Medlog file for MRR meds (not patches) that were Given
; and not Removed. Place these meds into the return Results array.
;
N PSBGNODE,PSBIEN,PSBXDTI,PSBXXDTI,PSBZON,X,Y,PSBPBK,DSPDRG
S PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="AMRR")!($QS(PSBGNODE,3)'=DFN) D
.S PSBIEN=$QS(PSBGNODE,5),DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
.I '$D(^PSB(53.79,PSBIEN,.5,DSPDRG)) Q
.I "G"'[$P(^PSB(53.79,PSBIEN,0),U,9)!($D(PSBONVDL(PSBIEN))) Q
.;
.S PSBZON=$P(^PSB(53.79,PSBIEN,.1),"^")
.D CLEAN^PSBVT
.D PSJ1^PSBVT(DFN,PSBZON) Q:$G(PSBSCRT)=-1
.S PSBPBK=+($$GET^XPAR("DIV","PSB VDL PATCH DAYS"))
.I PSBPBK D NOW^%DTC I ($$FMADD^XLFDT($P(PSBOSP,"."),(PSBPBK))<X) Q
.;
.S $P(PSBREC,U,1)=DFN ; dfn
.S $P(PSBREC,U,2)=PSBONX ; order numer
.S $P(PSBREC,U,3)=PSBON ; order ien
.S $P(PSBREC,U,4)="U" ; order type U unit dose
.S $P(PSBREC,U,5)=PSBSCHT
.S $P(PSBREC,U,6)=PSBSCH
.S $P(PSBREC,U,7)=$S(PSBHSM:"HSM",PSBSM:"SM",1:"")
.S $P(PSBREC,U,8)=PSBOITX
.S $P(PSBREC,U,9)=PSBDOSE
.S $P(PSBREC,U,10)=PSBMR
.S:$D(PSBHSTAX(PSBOIT)) $P(PSBREC,U,11)=$O(PSBHSTAX(PSBOIT,""),-1),$P(PSBREC,U,20)=$O(PSBHSTAX(PSBOIT,$P(PSBREC,U,11),""),-1)
.D:'$D(PSBHSTAX(PSBOIT))
..N PSBX,PSBY,PSBDONE S PSBDONE=0,PSBX="" F S PSBX=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,PSBX),-1) Q:PSBX="" D:'PSBDONE
...S PSBY="" F S PSBY=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,PSBX,PSBY),-1) Q:PSBY="" D:'PSBDONE
....S:$P(^PSB(53.79,PSBY,0),U,9)'="N" $P(PSBREC,U,20)=$P(^PSB(53.79,PSBY,0),U,9) S:($P(PSBREC,U,20)'="N")&($P(PSBREC,U,20)]"") $P(PSBREC,U,11)=PSBX,PSBDONE=1
.S $P(PSBREC,U,12)=PSBIEN
.S $P(PSBREC,U,13)="G"
.S $P(PSBREC,U,14)=$P(^PSB(53.79,PSBIEN,.1),U,3)
.I $P(PSBREC,U,14)="" S $P(PSBREC,U,14)=PSBNOW\1
.S $P(PSBREC,U,15)=PSBOIT
.D:($G(PSBTAB)="CVRSHT")!($G(PSBTAB)="UDTAB")
..S $P(PSBREC,U,16)=PSBNJECT ;always send this flag *70
..I $P(PSBREC,U,9)?1.4N1"-"1.4N.E S $P(PSBREC,U,17)=1
..E S $P(PSBREC,U,17)=0
..S $P(PSBREC,U,19)=$S(PSBVNI]"":PSBVNI,PSBVNI']"":"***")
..S $P(PSBREC,U,23)=""
..S $P(PSBREC,U,26)=PSBOSP
..S $P(PSBREC,U,27)=$$LASTG^PSBCSUTL($P(PSBREC,U),$P(PSBREC,U,15))
..S $P(PSBREC,U,28)=0
..I ($G(PSBTAB)="CVRSHT") S $P(PSBREC,U,28)=1
..I ($G(PSBTAB)="UDTAB") I PSBSCHT'="O" S:(PSBOSTS="E")!(PSBOSTS["D") $P(PSBREC,U,28)=1
..;*58 determine if override or intervn exists, send 1/0 (true/false)
..N PSBARR D GETPROVL^PSGSICH1(DFN,PSBONX,.PSBARR)
..I $O(PSBARR(""))="" D INTRDIC^PSGSICH1(DFN,PSBONX,.PSBARR,2)
..S $P(PSBREC,U,29)=$S($O(PSBARR(""))]"":1,1:0)
..;add last site *70/*83
..S $P(PSBREC,U,30)=$$LASTSITE^PSBINJEC(DFN,PSBOIT) ;*83
..; piece 31 special IVPB use in vdl's not for coversheet
..I $G(PSBTAB)="CVRSHT" D ;If from coversheet use offset -1 *70
...S $P(PSBREC,U,31)=$G(PSBCLORD) ;clinic name
...S $P(PSBREC,U,32)=$G(PSBCLIEN) ;clinic ien ptr
..I $G(PSBTAB)="UDTAB" D ;Else must be Unit does VDL calling
...S $P(PSBREC,U,32)=$G(PSBCLORD) ;clinic name
...S $P(PSBREC,U,33)=$G(PSBCLIEN) ;clinic ien ptr
...S $P(PSBREC,U,35)=$P(^PSB(53.79,PSBIEN,.1),U,7) ;existing RM time
..; piece 34-35 reserved for Remove meds and set by PSBVDLU1
..S $P(PSBREC,U,36)=$G(PSBHAZHN) ;Hazardous to Handle *106
..S $P(PSBREC,U,37)=$G(PSBHAZDS) ;Hazardous to Dispose *106
..; Place into Coversheet activity ARRAY
..S PSBDIDX="" I $D(^PSB(53.79,"AORD",DFN,PSBONX)) D
...S PSBXDTI="",PSBXDTI=$O(^PSB(53.79,"AORD",DFN,PSBONX,PSBXDTI),-1)
...Q:'$D(^PSB(53.79,"AORD",DFN,PSBONX,PSBXDTI,PSBIEN))
...S PSBADMX(PSBONX,PSBXDTI,PSBIEN)="",PSBDIDX=1
..I ('PSBDIDX)&$D(^PSB(53.79,"AORDX",DFN,PSBONX)) D
...S PSBXXDTI="",PSBXXDTI=$O(^PSB(53.79,"AORDX",DFN,PSBONX,PSBXXDTI),-1)
...Q:'$D(^PSB(53.79,"AORDX",DFN,PSBONX,PSBXXDTI,PSBIEN))
...S PSBADMX(PSBONX,PSBXXDTI,PSBIEN)=""
.S $P(PSBREC,U,18)="PATCH"
.S $P(PSBREC,U,21)=PSBOST
.S $P(PSBREC,U,22)=PSBOSTS
.S PSBDDS="" F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y S:$P(PSBDDA(Y),U,4)="" $P(PSBDDA(Y),U,4)=1 S PSBDDS=PSBDDS_U_$P(PSBDDA(Y),U,1,4),$P(PSBDDS,U,1)=PSBDDS+1
.S PSBQRR=1
.; *83 Api below calcs & adds MRR code & Remove time to (34,35)
.D ADD^PSBVDLU1(PSBREC,PSBOTXT,$P(PSBREC,U,14),PSBDDS,"","",$S($G(PSBTAB)="CVRSHT":"CVRSHT",1:"UDTAB"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBVDLRM 5136 printed Oct 16, 2024@17:42:10 Page 2
PSBVDLRM ;BIRMINGHAM/EFC-BCMA UNIT DOSE VIRTUAL DUE LIST REMOVE MEDS ;2/6/21 18:24
+1 ;;3.0;BAR CODE MED ADMIN;**83,114,106**;Mar 2004;Build 43
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; called by PSBVDLUD to find Medications needing removal (MRR) then
+5 ; add to Results for VDL display.
+6 ;
+7 ; Reference/IA
+8 ; $$GET^XPAR/2263
+9 ; $$FMADD^XLFDT/10103
+10 ; GETPROVL^PSGSICH1/5653
+11 ; INTRDIC^PSGSICH1/5654
+12 ;
+13 ;*83 - Read Medlog for remove medications types MRR, other than form
+14 ; of PATCH, and add 34th & 35th piece to Results.
+15 ; Remove flag & Remove time
+16 ;*106- add Hazardous to Handle & Dispose flags 36 & 37
+17 ;
EN ;Search the Medlog file for MRR meds (not patches) that were Given
+1 ; and not Removed. Place these meds into the return Results array.
+2 ;
+3 NEW PSBGNODE,PSBIEN,PSBXDTI,PSBXXDTI,PSBZON,X,Y,PSBPBK,DSPDRG
+4 SET PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
+5 FOR
SET PSBGNODE=$QUERY(@PSBGNODE)
if PSBGNODE']""
QUIT
if ($QSUBSCRIPT(PSBGNODE,2)'="AMRR")!($QSUBSCRIPT(PSBGNODE,3)'=DFN)
QUIT
Begin DoDot:1
+6 SET PSBIEN=$QSUBSCRIPT(PSBGNODE,5)
SET DSPDRG=$ORDER(^PSB(53.79,PSBIEN,.5,0))
IF 'DSPDRG
QUIT
+7 IF '$DATA(^PSB(53.79,PSBIEN,.5,DSPDRG))
QUIT
+8 IF "G"'[$PIECE(^PSB(53.79,PSBIEN,0),U,9)!($DATA(PSBONVDL(PSBIEN)))
QUIT
+9 ;
+10 SET PSBZON=$PIECE(^PSB(53.79,PSBIEN,.1),"^")
+11 DO CLEAN^PSBVT
+12 DO PSJ1^PSBVT(DFN,PSBZON)
if $GET(PSBSCRT)=-1
QUIT
+13 SET PSBPBK=+($$GET^XPAR("DIV","PSB VDL PATCH DAYS"))
+14 IF PSBPBK
DO NOW^%DTC
IF ($$FMADD^XLFDT($PIECE(PSBOSP,"."),(PSBPBK))<X)
QUIT
+15 ;
+16 ; dfn
SET $PIECE(PSBREC,U,1)=DFN
+17 ; order numer
SET $PIECE(PSBREC,U,2)=PSBONX
+18 ; order ien
SET $PIECE(PSBREC,U,3)=PSBON
+19 ; order type U unit dose
SET $PIECE(PSBREC,U,4)="U"
+20 SET $PIECE(PSBREC,U,5)=PSBSCHT
+21 SET $PIECE(PSBREC,U,6)=PSBSCH
+22 SET $PIECE(PSBREC,U,7)=$SELECT(PSBHSM:"HSM",PSBSM:"SM",1:"")
+23 SET $PIECE(PSBREC,U,8)=PSBOITX
+24 SET $PIECE(PSBREC,U,9)=PSBDOSE
+25 SET $PIECE(PSBREC,U,10)=PSBMR
+26 if $DATA(PSBHSTAX(PSBOIT))
SET $PIECE(PSBREC,U,11)=$ORDER(PSBHSTAX(PSBOIT,""),-1)
SET $PIECE(PSBREC,U,20)=$ORDER(PSBHSTAX(PSBOIT,$PIECE(PSBREC,U,11),""),-1)
+27 if '$DATA(PSBHSTAX(PSBOIT))
Begin DoDot:2
+28 NEW PSBX,PSBY,PSBDONE
SET PSBDONE=0
SET PSBX=""
FOR
SET PSBX=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,PSBX),-1)
if PSBX=""
QUIT
if 'PSBDONE
Begin DoDot:3
+29 SET PSBY=""
FOR
SET PSBY=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,PSBX,PSBY),-1)
if PSBY=""
QUIT
if 'PSBDONE
Begin DoDot:4
+30 if $PIECE(^PSB(53.79,PSBY,0),U,9)'="N"
SET $PIECE(PSBREC,U,20)=$PIECE(^PSB(53.79,PSBY,0),U,9)
if ($PIECE(PSBREC,U,20)'="N")&($PIECE(PSBREC,U,20)]"")
SET $PIECE(PSBREC,U,11)=PSBX
SET PSBDONE=1
End DoDot:4
End DoDot:3
End DoDot:2
+31 SET $PIECE(PSBREC,U,12)=PSBIEN
+32 SET $PIECE(PSBREC,U,13)="G"
+33 SET $PIECE(PSBREC,U,14)=$PIECE(^PSB(53.79,PSBIEN,.1),U,3)
+34 IF $PIECE(PSBREC,U,14)=""
SET $PIECE(PSBREC,U,14)=PSBNOW\1
+35 SET $PIECE(PSBREC,U,15)=PSBOIT
+36 if ($GET(PSBTAB)="CVRSHT")!($GET(PSBTAB)="UDTAB")
Begin DoDot:2
+37 ;always send this flag *70
SET $PIECE(PSBREC,U,16)=PSBNJECT
+38 IF $PIECE(PSBREC,U,9)?1.4N1"-"1.4N.E
SET $PIECE(PSBREC,U,17)=1
+39 IF '$TEST
SET $PIECE(PSBREC,U,17)=0
+40 SET $PIECE(PSBREC,U,19)=$SELECT(PSBVNI]"":PSBVNI,PSBVNI']"":"***")
+41 SET $PIECE(PSBREC,U,23)=""
+42 SET $PIECE(PSBREC,U,26)=PSBOSP
+43 SET $PIECE(PSBREC,U,27)=$$LASTG^PSBCSUTL($PIECE(PSBREC,U),$PIECE(PSBREC,U,15))
+44 SET $PIECE(PSBREC,U,28)=0
+45 IF ($GET(PSBTAB)="CVRSHT")
SET $PIECE(PSBREC,U,28)=1
+46 IF ($GET(PSBTAB)="UDTAB")
IF PSBSCHT'="O"
if (PSBOSTS="E")!(PSBOSTS["D")
SET $PIECE(PSBREC,U,28)=1
+47 ;*58 determine if override or intervn exists, send 1/0 (true/false)
+48 NEW PSBARR
DO GETPROVL^PSGSICH1(DFN,PSBONX,.PSBARR)
+49 IF $ORDER(PSBARR(""))=""
DO INTRDIC^PSGSICH1(DFN,PSBONX,.PSBARR,2)
+50 SET $PIECE(PSBREC,U,29)=$SELECT($ORDER(PSBARR(""))]"":1,1:0)
+51 ;add last site *70/*83
+52 ;*83
SET $PIECE(PSBREC,U,30)=$$LASTSITE^PSBINJEC(DFN,PSBOIT)
+53 ; piece 31 special IVPB use in vdl's not for coversheet
+54 ;If from coversheet use offset -1 *70
IF $GET(PSBTAB)="CVRSHT"
Begin DoDot:3
+55 ;clinic name
SET $PIECE(PSBREC,U,31)=$GET(PSBCLORD)
+56 ;clinic ien ptr
SET $PIECE(PSBREC,U,32)=$GET(PSBCLIEN)
End DoDot:3
+57 ;Else must be Unit does VDL calling
IF $GET(PSBTAB)="UDTAB"
Begin DoDot:3
+58 ;clinic name
SET $PIECE(PSBREC,U,32)=$GET(PSBCLORD)
+59 ;clinic ien ptr
SET $PIECE(PSBREC,U,33)=$GET(PSBCLIEN)
+60 ;existing RM time
SET $PIECE(PSBREC,U,35)=$PIECE(^PSB(53.79,PSBIEN,.1),U,7)
End DoDot:3
+61 ; piece 34-35 reserved for Remove meds and set by PSBVDLU1
+62 ;Hazardous to Handle *106
SET $PIECE(PSBREC,U,36)=$GET(PSBHAZHN)
+63 ;Hazardous to Dispose *106
SET $PIECE(PSBREC,U,37)=$GET(PSBHAZDS)
+64 ; Place into Coversheet activity ARRAY
+65 SET PSBDIDX=""
IF $DATA(^PSB(53.79,"AORD",DFN,PSBONX))
Begin DoDot:3
+66 SET PSBXDTI=""
SET PSBXDTI=$ORDER(^PSB(53.79,"AORD",DFN,PSBONX,PSBXDTI),-1)
+67 if '$DATA(^PSB(53.79,"AORD",DFN,PSBONX,PSBXDTI,PSBIEN))
QUIT
+68 SET PSBADMX(PSBONX,PSBXDTI,PSBIEN)=""
SET PSBDIDX=1
End DoDot:3
+69 IF ('PSBDIDX)&$DATA(^PSB(53.79,"AORDX",DFN,PSBONX))
Begin DoDot:3
+70 SET PSBXXDTI=""
SET PSBXXDTI=$ORDER(^PSB(53.79,"AORDX",DFN,PSBONX,PSBXXDTI),-1)
+71 if '$DATA(^PSB(53.79,"AORDX",DFN,PSBONX,PSBXXDTI,PSBIEN))
QUIT
+72 SET PSBADMX(PSBONX,PSBXXDTI,PSBIEN)=""
End DoDot:3
End DoDot:2
+73 SET $PIECE(PSBREC,U,18)="PATCH"
+74 SET $PIECE(PSBREC,U,21)=PSBOST
+75 SET $PIECE(PSBREC,U,22)=PSBOSTS
+76 SET PSBDDS=""
FOR Y=0:0
SET Y=$ORDER(PSBDDA(Y))
if 'Y
QUIT
if $PIECE(PSBDDA(Y),U,4)=""
SET $PIECE(PSBDDA(Y),U,4)=1
SET PSBDDS=PSBDDS_U_$PIECE(PSBDDA(Y),U,1,4)
SET $PIECE(PSBDDS,U,1)=PSBDDS+1
+77 SET PSBQRR=1
+78 ; *83 Api below calcs & adds MRR code & Remove time to (34,35)
+79 DO ADD^PSBVDLU1(PSBREC,PSBOTXT,$PIECE(PSBREC,U,14),PSBDDS,"","",$SELECT($GET(PSBTAB)="CVRSHT":"CVRSHT",1:"UDTAB"))
End DoDot:1
+80 QUIT
