Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBVDLUD

PSBVDLUD.m

Go to the documentation of this file. 
  1. PSBVDLUD ;BIRMINGHAM/EFC-BCMA UNIT DOSE VIRTUAL DUE LIST FUNCTIONS ;03/06/16 3:06pm
  1.  ;;3.0;BAR CODE MED ADMIN;**11,13,38,32,58,68,70,83,106**;Mar 2004;Build 43
  1.  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1.  ;
  1.  ; Reference/IA
  1.  ; $$GET^XPAR/2263
  1.  ; GETPROVL^PSGSICH1/5653
  1.  ; INTRDIC^PSGSICH1/5654
  1.  ;
  1.  ;*58 - add 29th piece to Results for Override/Intervention flag 1/0
  1.  ;*68 - add 30th piece to Results for Last Injection Site
  1.  ;*70 - add 32nd piece to Results for Clinic Order name for CO's
  1.  ;    - add 33rd piece to Results for Clinic ien ptr to file #44
  1.  ;*83 - add 34th & 35th piece to Results via ADD^PSBVDLU1
  1.  ;      add call to new routine PSBVDLRM for placing MRR meds on VDL
  1.  ;    - Clinic Orders should show up on VDL's when start order date
  1.  ;      is Today now ignores the time portion of that field.
  1.  ;*106- add Hazardous to Handle & Dispose flags 36 & 37
  1.  ;
  1. EN(DFN,PSBDT) ;
  1.  ;
  1.  ; Description:
  1.  ; Returns the current unit dose order set for today to display
  1.  ; on the client VDL
  1.  ;
  1.  N PSBDATA,PSBTBOUT
  1.  N PSBONVDL                    ;new here instead of kill in PA rtn *83
  1.  N ADM,MISSED,IEN,STUS
  1.  S PSBTBOUT=0
  1.  ;
  1.  ;This routine now re-uses the ^TMP("PSJ",$J global built in PSBVDLTB
  1.  ;
  1.  G:$G(^TMP("PSJ",$J,1,0))=-1 1
  1.  F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:('PSBX)!(PSBTBOUT)  D
  1.  .N PSBRTNOW S PSBRTNOW=$$NOW^XLFDT()
  1.  .S:(PSBTAB'="UDTAB")&($G(^TMP("PSB",$J,"UDTAB",2))>0) PSBTBOUT=1
  1.  .D CLEAN^PSBVT,PSJ^PSBVT(PSBX)
  1.  .;
  1.  .; << Standard checks for ALL orders >>
  1.  .;
  1.  .Q:PSBONX["V"              ;No IVs on UD tab
  1.  .Q:PSBONX["P"              ;No Pending Orders
  1.  .Q:PSBOST>PSBWADM          ;Order Start Date/Time > admin window
  1.  .;CO Order future start check now based on the date only Not time *83
  1.  .Q:($G(PSBCLORD)]"")&($P(PSBOST,".")>$P(PSBRTNOW,"."))
  1.  .Q:PSBOSP<PSBWBEG  ;For Non one-times Order Stop Date/Time < vdl window
  1.  .Q:PSBOSTS["D"             ;Is it DC'd
  1.  .Q:PSBNGF                  ;Is it marked DO NOT GIVE!
  1.  .Q:PSBIVPSH                ;Is it IV push
  1.  .;
  1.  .; Non One-Times with stop date/time < now
  1.  .;
  1.  .D NOW^%DTC
  1.  .Q:PSBOSP<%
  1.  .;
  1.  .; include Active, Renewed, ReInstated and On Call
  1.  .; (Is it not one time)&(Is it not active or renewed or On Call)
  1.  .I PSBSCHT'="O",PSBOSTS'="A",PSBOSTS'="H",PSBOSTS'="R",PSBOSTS'="RE",PSBOSTS'="O" Q
  1.  .;
  1.  .; Is One Time Given
  1.  .;
  1.  .I PSBSCHT="O" D  Q:PSBGVN
  1.  ..S (PSBGVN,X,Y)=""
  1.  ..F  S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X  D
  1.  ...F  S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y  D
  1.  ....I $P(^PSB(53.79,Y,.1),U)=PSBONX,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
  1.  .;
  1.  .; How long does One Time remain on VDL ??
  1.  .S PSBRMN=1
  1.  .I PSBSCHT="O",PSBOSP'=PSBOST&(%>PSBOSP) S PSBRMN=0
  1.  .Q:'PSBRMN
  1.  .; Is On-Call Given, Can it be given more than once
  1.  .;
  1.  .I PSBSCHT="OC" D  Q:PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
  1.  ..S (PSBGVN,X,Y)=""
  1.  ..F  S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X  D
  1.  ...F  S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y  D
  1.  ....I $P(^PSB(53.79,Y,.1),U)=PSBONX,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
  1.  .;
  1.  .S PSBREC=""
  1.  .S $P(PSBREC,U,1)=DFN ; dfn
  1.  .S $P(PSBREC,U,2)=PSBONX ; order
  1.  .S $P(PSBREC,U,3)=PSBON ; order ien
  1.  .S $P(PSBREC,U,4)=PSBOTYP ; iv/ud/pending
  1.  .S $P(PSBREC,U,5)=PSBSCHT ; schedule type
  1.  .S $P(PSBREC,U,6)=PSBSCH ; schedule
  1.  .S $P(PSBREC,U,7)=$S(PSBHSM:"HSM",PSBSM:"SM",1:"") ; self med
  1.  .S $P(PSBREC,U,8)=PSBOITX ; drugname
  1.  .S $P(PSBREC,U,9)=PSBDOSE_" "_PSBIFR ; dosage
  1.  .S $P(PSBREC,U,10)=PSBMR ; med route
  1.  .; Last Given from the AOIP X-Ref - not given status not excepted
  1.  .S (PSBCNT,PSBFLAG)=0,(YZ,PSBSTUS,PSBADMER)="" K PSBHSTA,PSBHSTAX
  1.  .F XZ=1:1:20 S YZ=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,YZ),-1),(PSBCNT,PSBFLAG)=0 Q:YZ=""  D
  1.  ..S:YZ>0 $P(PSBREC,U,11)=YZ
  1.  ..S X="" F  S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,YZ,X),-1) Q:X=""  D
  1.  ...K PSBLCK L +^PSB(53.79,X):1  I  L -^PSB(53.79,X) S PSBLCK=1
  1.  ...S PSBSTUS=$P(^PSB(53.79,X,0),U,9)
  1.  ...I $G(PSBSTUS)="" S:'$G(PSBLCK) PSBSTUS="X" I $G(PSBLCK) S PSBADMER=1 D
  1.  ....K PSBPARM3,PSBPARM5,PSBPARM6,PSBPARM7
  1.  ....S PSBPARM6=X,Y=$P(^PSB(53.79,X,.1),U,3) D DD^%DT S PSBPARM3=Y,Y=$P(^PSB(53.79,X,0),U,6) D DD^%DT S PSBPARM5=Y
  1.  ....S PSBPARM7=$P(^PSB(53.79,X,0),U,7) S PSBPARM7="( # "_PSBPARM7_" ) "_$$GET1^DIQ(200,PSBPARM7_",",.01)
  1.  ....K PSBXTMP S PSBXTMP=PSBONX
  1.  ....D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$$GET1^DIQ(53.79,PSBPARM6_",",.11))
  1.  ....D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,PSBPARM3_" admin's ACTION STATUS is ""UNKNOWN"".",PSBSCH,PSBPARM5,PSBPARM6,PSBPARM7) ;  SEND AN E-MAIL
  1.  ....D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBXTMP)  ;Reset Variables
  1.  ....S X=PSBPARM6 K PSBPARM3,PSBPARM5,PSBPARM6,PSBPARM7
  1.  ...K PSBLCK S:(PSBSTUS']"") PSBSTUS="U"  I PSBSTUS'="N",($G(PSBSTUS)'="X") S PSBFLAG=1,PSBHSTA(YZ,$G(PSBSTUS))="ORIG"_U_X
  1.  ...D:PSBSTUS="N"
  1.  ....S $P(PSBREC,U,11)=""
  1.  ....S Z="" F  S Z=$O(^PSB(53.79,X,.9,Z),-1) Q:'Z  Q:PSBFLAG=1  S PSBDATA=$G(^(Z,0)) D
  1.  .....I (PSBDATA["Set to 'NOT GIVEN'")!(PSBDATA["Set to 'GIVEN'")!(PSBDATA["Set to 'REFUSED'")!(PSBDATA["Set to 'HELD'")!(PSBDATA["Set to 'MISSING DOSE'")!(PSBDATA["Set to 'REMOVED'") S PSBCNT=PSBCNT+1
  1.  .....I (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'") S PSBCNT=PSBCNT+1
  1.  .....I PSBCNT#2=0,PSBDATA["'REFUSED'" S PSBSTUS="R" D LAST^PSBVDLU1
  1.  .....I PSBCNT#2=0,PSBDATA["'HELD'" S PSBSTUS="H" D LAST^PSBVDLU1
  1.  .....I PSBCNT#2=0,PSBDATA["'MISSING DOSE'" S PSBSTUS="M" D LAST^PSBVDLU1
  1.  .....I PSBFLAG=1,'$D(PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))) S PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))=Z_U_X
  1.  .I $D(PSBHSTA) S $P(PSBREC,U,11)=$O(PSBHSTA(""),-1),PSBSTUS=$O(PSBHSTA($P(PSBREC,U,11),""),-1) M PSBHSTAX(PSBOIT)=PSBHSTA K PSBHSTA  ;last action date/time
  1.  .S $P(PSBREC,U,12)=""  ;med log ien inserted below for actual date
  1.  .S $P(PSBREC,U,13)=""  ;med log status inserted below for actual date
  1.  .S $P(PSBREC,U,14)="" ; admin date inserted below
  1.  .S $P(PSBREC,U,15)=PSBOIT ; OI Pointer
  1.  .S $P(PSBREC,U,16)=PSBNJECT  ;med route injectable flag
  1.  .; Variable dosage entered as ####-####?
  1.  .I $P(PSBREC,U,9)?1.4N1"-"1.4N.E S $P(PSBREC,U,17)=1
  1.  .E  S $P(PSBREC,U,17)=0
  1.  .S:PSBDOSEF?1"CAP".E!(PSBDOSEF?1"TAB".E)!(PSBDOSEF="PATCH")!(PSBDOSEF="GUM,CHEWABLE") $P(PSBREC,U,18)=PSBDOSEF   ;dosage form, add Gum,Chewable for HD208693
  1.  .S $P(PSBREC,U,20)=$S((PSBSTUS="X")!(PSBSTUS="N"):"",1:PSBSTUS) ; last action status
  1.  .S $P(PSBREC,U,21)=PSBOST
  1.  .S $P(PSBREC,U,22)=PSBOSTS
  1.  .S $P(PSBREC,U,26)=PSBOSP
  1.  .S $P(PSBREC,U,27)=$$LASTG^PSBCSUTL(DFN,PSBOIT)
  1.  .;*58 determine if override or intervn exists, send 1/0 (true/false)
  1.  .N PSBARR D GETPROVL^PSGSICH1(DFN,PSBONX,.PSBARR)
  1.  .I $O(PSBARR(""))="" D INTRDIC^PSGSICH1(DFN,PSBONX,.PSBARR,2)
  1.  .S $P(PSBREC,U,29)=$S($O(PSBARR(""))]"":1,1:0)
  1.  .;*68 add last injection site/dermal site                         *83
  1.  .S $P(PSBREC,U,30)=$$LASTSITE^PSBINJEC(DFN,PSBOIT)   ;can be null *83
  1.  .;       piece 31 reserved by IVPB tab
  1.  .S $P(PSBREC,U,32)=$G(PSBCLORD)  ;clinic name          *70
  1.  .S $P(PSBREC,U,33)=$G(PSBCLIEN)  ;clinic ien ptr       *70
  1.  .;       piece 34-35 reserved for Remove meds and set by PSBVDLU1
  1.  .S $P(PSBREC,U,36)=$G(PSBHAZHN)  ;Hazardous to Handle    *106
  1.  .S $P(PSBREC,U,37)=$G(PSBHAZDS)  ;Hazardous to Dispose   *106
  1.  .;
  1.  .; Gather Dispense Drugs
  1.  .D NOW^%DTC
  1.  .S (PSBDDS,PSBSOLS,PSBADDS,PSBFLAG)="0"
  1.  .F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y  D
  1.  ..I $P(PSBDDA(Y),U,5)=$P(%,".") S PSBFLAG=1 ;If drug was inactivated
  1.  ..Q:$P(PSBDDA(Y),U,5)&($P(PSBDDA(Y),U,5)<%)  ; Inactive
  1.  ..S:$P(PSBDDA(Y),U,4)="" $P(PSBDDA(Y),U,4)=1
  1.  ..S PSBDDS=PSBDDS_U_$P(PSBDDA(Y),U,1,4)
  1.  ..S $P(PSBDDS,U,1)=PSBDDS+1
  1.  .;
  1.  .;** Begin admin time calculations & add to TMP for Results to GUI **
  1.  .;
  1.  .; On-Call One Time PRN orders
  1.  .S PSBQRR=0
  1.  .;*70 if Order start dates > than the day being viewed, don't show
  1.  .I "^O^OC^P^"[(U_PSBSCHT_U) D  Q
  1.  ..Q:PSBCLINORD&($P(PSBOST,".")>PSBDT)                ;*70
  1.  ..D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1,PSBDDS,PSBSOLS,PSBADDS,"UDTAB")
  1.  .;
  1.  .; Now we deal with only continuous
  1.  .; process admin times
  1.  .;
  1.  .; Display an order on the VDL based on the frequency received from IPM **PSB*2.0*3
  1.  .S (PSBYES,PSBODD,PSBYTF)=0
  1.  .I PSBSCH="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"No Schedule on this order")
  1.  .S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1
  1.  .I PSBYES,PSBADST="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH) Q
  1.  .F I=1:1 Q:$P(PSBSCH,"-",I)=""  I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBYTF=1
  1.  .I PSBSCHT="C",PSBYTF="1",PSBADST="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH) Q
  1.  .S PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
  1.  .I PSBFREQ="O" S PSBFREQ=1440
  1.  .I PSBFREQ="D" S PSBFREQ=""
  1.  .I 'PSBYES,PSBFREQ<1 D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH) Q
  1.  .I (PSBADST="")&(+PSBFREQ>0) D ODDSCH^PSBVDLU1("UDTAB") Q  ;calculate admin times based on frequency
  1.  .; No admin times, MAYDAY MAYDAY!!
  1.  .I +PSBFREQ>0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
  1.  .I PSBODD,PSBADST'="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Administration Times on ODD SCHEDULE",PSBSCH) Q
  1.  .;
  1.  .;** Process admin times against beginning and ending date
  1.  .;   build all orders for both days.
  1.  .;
  1.  .;loop through admin times string and add to Results
  1.  .F PSBY=1:1 Q:$P(PSBADST,"-",PSBY)=""  D
  1.  ..;For invalid admin times
  1.  ..I ($P(PSBADST,"-",PSBY)'?2N)&($P(PSBADST,"-",PSBY)'?4N) D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid Admin times",PSBSCH)
  1.  ..;
  1.  ..; apply this time to beginning window date
  1.  ..S PSB=+(PSBWBEG\1_"."_$P(PSBADST,"-",PSBY))
  1.  ..;
  1.  ..D:(PSB'<PSBWBEG)&(PSB'>PSBWEND)     ;Make sure in the 12hr window
  1.  ...D:(PSB'<PSBOST)&(PSB<PSBOSP)       ;Make sure this time is active
  1.  ....D:$$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS)  ; Okay on this date?
  1.  .....;*83 ADD Api now will calc & add MRR remove code & time to 34^35
  1.  .....D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"UDTAB")
  1.  ..;
  1.  ..Q:(PSBWBEG\1)=(PSBWEND\1)  ; Window only has one day rare but possible
  1.  ..;
  1.  ..; apply this time to the ending window date
  1.  ..S PSB=+(PSBWEND\1_"."_$P(PSBADST,"-",PSBY))
  1.  ..D:(PSB'<PSBWBEG)&(PSB'>PSBWEND)  ; Make sure it is in the window
  1.  ...D:(PSB'<PSBOST)&(PSB<PSBOSP)  ; Make sure this time is active
  1.  ....D:$$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS)  ; Okay on this date?
  1.  .....D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"UDTAB")
  1.  .;
  1.  .K PSBSTUS
  1.  ;
  1. 1 K PSBREC
  1.  D EN^PSBVDLPA     ;find patches Given not removed and add to VDL
  1.  D EN^PSBVDLRM     ;find MRR meds Given not removed and add to VDL *83
  1.  ;
  1.  ;add initials of verifying pharmacist/verifying nurse
  1.  D:PSBTAB="UDTAB" VNURSE^PSBVDLU1("UDTAB")
  1.  D CLEAN^PSBVT     ;kills all PSB variables
  1.  Q