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

PSBVDLU3.m

Go to the documentation of this file. 
  1. PSBVDLU3 ;BIRMINGHAM/TEJ-BCMA VDL UTILITIES 3 ;5/1/13 1:13pm
  1.  ;;3.0;BAR CODE MED ADMIN;**13,38,28,50,64,70**;Mar 2004;Build 101
  1.  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1.  ;
  1.  ;This routine file has been created to serve as a container
  1.  ;for Extrinsic Variables/Functions
  1.  ;
  1.  ; Reference/IA
  1.  ; EN^PSJBCMA/2828
  1.  ; EN^PSJBCMA1/2829
  1.  ; File 50/221
  1.  ; File 52.6/436
  1.  ; File 52.7/437
  1.  ;
  1.  ;*70 - Do not send UTS mailman msg for Clinic only patients.
  1.  ;
  1. IVPTAB(PSBORTYP,PSBIVTYP,PSBINTSY,PSBCHMTY,PSBPUSH)  ;
  1.  ;
  1.  ; This function will return
  1.  ; the value 1 (one) if the
  1.  ; specified order input will cause
  1.  ; the order to display on the "IVP/IVPB"
  1.  ; tab of the VDL BCMA Virtual Due List (VDL)
  1.  ; else return the value 0 (zero).
  1.  ;
  1.  ; Input Parameters:
  1.  ;
  1.  ;     PSBORTYP - Order type (e.g. "U","V")
  1.  ;     PSBIVTYP - IV Type (e.g. "P","S","C")
  1.  ;     PSBINTSY - Intermittent Syringe value
  1.  ;     PSBCHMTY - Chemo type (e.g. "P","S")
  1.  ;     PSBPUSH - IV PUSH Flag (e.g. 0 or 1, 1=IV PUSH)
  1.  ;
  1.  ; Output:
  1.  ;     1 - order will display on the "IVP/IVPB" Tab of BCMA VDL
  1.  ;     0 - order will NOT display on the "IVP/IVPB" Tab of BCMA VDL
  1.  ;    -1 - error processed
  1.  ;
  1.  Q:'$D(PSBORTYP) "-1^Missing Parameter"
  1.  I PSBORTYP="U"&(PSBPUSH) Q 1
  1.  I '(PSBORTYP="V") Q 0
  1.  I $G(PSBIVTYP)="P" Q 1
  1.  I $G(PSBIVTYP)="S",$G(PSBINTSY)=1 Q 1
  1.  I $G(PSBIVTYP)="C",$G(PSBCHMTY)="P" Q 1
  1.  I $G(PSBIVTYP)="C",$G(PSBCHMTY)="S",$G(PSBINTSY)=1 Q 1
  1.  Q 0
  1.  ;
  1. SHOVDL(DFN,BDATE,OTDATE,PSBTAB) ;
  1.  ;
  1.  ; This function will find orders such as discontinued or expired infusing IV bags 
  1.  ; or discontinued or expired "given" patches.  Recognizing these types of orders
  1.  ; will allow these orders to be displayed on the VDL and permits the user to take 
  1.  ; action on them.  This routine determines if such orders exist for patient,
  1.  ; time, and "BCMA VDL tab."  This routine is an "extention" to the API EN^PSJBCMA.
  1.  ;
  1.  ; INPUT Parameters:
  1.  ;    DFN           (req)   Patient Internal File Number.
  1.  ;    BDATE         (opt)   Start searching for "order stop" after this date. 
  1.  ;    OTDATE        (opt)   Include One-Time orders from this date.
  1.  ;    PSBTAB        (opt)   "UDTAB" or "IVTAB" - expedites process if specific tab
  1.  ;                            is given.
  1.  ;
  1.  ; OUTPUT Values
  1.  ;    0               absolutely no orders to display on VDL
  1.  ;    1               displayable orders have been located.
  1.  ;
  1.  ;
  1.  D EN^PSJBCMA(DFN,$G(BDATE),$G(OTDATE))
  1.  ; any active Patch orders to show on VDL?
  1.  S PSBFLG=0
  1.  I $G(^TMP("PSJ",$J,1,0))=-1 D
  1.  .;  
  1.  .; Check the indexice for given patches or infusing IVs
  1.  .;
  1.  .; Check APATCH
  1.  .D:($G(PSBTAB)="UDTAB")!($G(PSBTAB)="")  Q:PSBFLG
  1.  ..S PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")" Q:'$D(PSBGNODE)
  1.  ..F  S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE=""  Q:$QS(PSBGNODE,3)'=DFN  Q:PSBFLG  S PSBIEN=$QS(PSBGNODE,5),PSBFLG=$S($P(^PSB(53.79,PSBIEN,0),U,9)="G":1,1:0)
  1.  .;
  1.  .; Check AUID
  1.  .;
  1.  .D:(($G(PSBTAB)="IVTAB")!($G(PSBTAB)=""))&('PSBFLG)  Q:PSBFLG
  1.  ..S PSBGNODE="^PSB(53.79,"_"""AUID"""_","_DFN_")" Q:'$D(PSBGNODE)
  1.  ..F  S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE=""  Q:$QS(PSBGNODE,3)'=DFN  Q:PSBFLG  S PSBIEN=$QS(PSBGNODE,6),PSBFLG=$S($P(^PSB(53.79,PSBIEN,0),U,9)="I":1,1:0)
  1.  .;
  1.  .;  NOTE: Infusing bags will not display if DCed more than 3 days ago!
  1.  .;
  1.  S:$G(^TMP("PSJ",$J,1,0))'=-1 PSBFLG=1
  1.  ;
  1.  Q PSBFLG
  1.  ;
  1. FNDACTV(RESULTS,PARAMS) ;   Utility to check and order for the latest " ? (parameter #3) " order activities per patient (parameter #1)
  1.  ; #parameter= # "^"piece
  1.  ;       #1 DFN - Patient's IEN          e.g. 1234      (required)
  1.  ;       #2 Order Number_Order Type      e.g. "1V"     "" = all orders
  1.  ;       #3 Search for Activity          e.g           "" = *unknown* activity
  1.  ;       #4 Search "back"time(hours)     e.g. 12       "" = search back 3 admins
  1.  ;          NOTE:  ="FREQ"  This Function will use order's frequency.
  1.  ;          1. If the order is a PRN, On Call or One-Time
  1.  ;           the look back a default of 72 hours.
  1.  ;          2. if the order is a Continuous order key off
  1.  ;             of the frequency as follows.
  1.  ;           a.) if the frequency is <24 hours use the
  1.  ;               default of 72 hours.
  1.  ;           b.) if the frequency is >= 24 hour, look back
  1.  ;               3.5 times the frequency
  1.  ;    NOTE:  ["X#"    This Function will search back # of admins.
  1.  ;
  1.  ;  Example call: D FNDACTV^PSBVDLU3(.TEJ,"1234^1U^H^12")
  1.  ;
  1.  N PSBNOW,PSBDFN,PSBON,PSBCNT,PSBACT,PSBTMFRM,PSBX,PSBSET,PSBFRQ
  1.  K RESULTS
  1.  S PSBDFN=$P(PARAMS,U),PSBON=$P(PARAMS,U,2),PSBACT=$P(PARAMS,U,3),PSBTMFRM=$P(PARAMS,U,4)
  1.  S RESULTS(0)=1
  1.  I $G(PSBDFN)']"" S RESULTS(0)=1,RESULTS(1)="-1^ERROR - MISSING PARAMETER (DFN REQ.)" Q
  1.  I $G(PSBTMFRM)="" S PSBX=3
  1.  I $G(PSBTMFRM)["X" S PSBX=+($P(PSBTMFRM,"X",2)),PSBTMFRM=""
  1.  I $G(PSBTMFRM)]"",$G(PSBTMFRM)'["FREQ" D NOW^%DTC S PSBNOW=% S PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM),PSBSET=1 S RESULTS(1)="0^ None found after "_PSBTMFRM
  1.  I $G(PSBX)="" S PSBX=9999999
  1.  D:$G(PSBON)'=""
  1.  .K ^TMP("PSJ",$J) D EN^PSJBCMA1(PSBDFN,PSBON)
  1.  .;Maintain Time Frame and other order information
  1.  .I $G(PSBTMFRM)["FREQ" D
  1.  ..S PSBFRQ=+$P(^TMP("PSJ",$J,4),"^",11) I PSBFRQ=0 S PSBFRQ=1440
  1.  ..I "P^OC^O^"[($P(^TMP("PSJ",$J,4),"^")_"^") S PSBTMFRM=72 Q
  1.  ..I (PSBFRQ/60)<24 S PSBTMFRM=72 Q
  1.  ..I (PSBFRQ/60)'<24 S PSBTMFRM=(PSBFRQ/60)*3.5
  1.  .I '$G(PSBSET) D NOW^%DTC S PSBNOW=% S PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM) S RESULTS(1)="0^ None found after "_PSBTMFRM
  1.  .S I="",X=0 F  S I=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I),-1)  Q:(I="")!(I<$S(PSBTMFRM]"":PSBTMFRM,1:-1))  D  Q:X
  1.  ..S Z=0,J="",PSBCNT=0 F  S J=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I,J),-1)  Q:(J="")  S Z=Z+1 Q:Z>PSBX  D  Q:X
  1.  ...L +^PSB(53.79,J):DILOCKTM
  1.  ...I  L -^PSB(53.79,J)
  1.  ...E  Q
  1.  ...I ($P(^PSB(53.79,J,0),U,9)=PSBACT) S X=1 D
  1.  ....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.02)
  1.  ....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$P(^TMP("PSJ",$J,2),U,2)_"^"_($$GET1^DIQ(53.79,J_",",.11))
  1.  ....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.06,"I")
  1.  ....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.13,"I")
  1.  D:$G(PSBON)=""
  1.  .S Z="",X=0 F  S Z=$O(^PSB(53.79,"AORDX",PSBDFN,Z),-1)  Q:(Z="")  S PSBON=Z D  Q:X
  1.  ..;Maintain Time Frame and other order information
  1.  ..K ^TMP("PSJ",$J) D EN^PSJBCMA1(PSBDFN,PSBON)
  1.  ..I $G(PSBTMFRM)["FREQ" D
  1.  ...S PSBFRQ=+$P(^TMP("PSJ",$J,4),"^",11) I PSBFRQ=0 S PSBFRQ=1440
  1.  ...I "P^OC^O^"[($P(^TMP("PSJ",$J,4),"^")_"^") S PSBTMFRM=72 Q
  1.  ...I (PSBFRQ/60)<24 S PSBTMFRM=72 Q
  1.  ...I (PSBFRQ/60)'<24 S PSBTMFRM=(PSBFRQ/60)*3.5
  1.  ..I '$G(PSBSET) D NOW^%DTC S PSBNOW=% S PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM) S RESULTS(1)="0^ None found after "_PSBTMFRM
  1.  ..S I="" F  S I=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I),-1)  Q:(I="")!(I<$S(PSBTMFRM]"":PSBTMFRM,1:-1))  D  Q:X
  1.  ...S ZZ=0,J="",PSBCNT=0 F  S J=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I,J),-1)  Q:(J="")  S ZZ=ZZ+1 Q:ZZ>PSBX  D  Q:X
  1.  ....L +^PSB(53.79,J):DILOCKTM
  1.  ....I  L -^PSB(53.79,J)
  1.  ....E  Q
  1.  ....I ($P(^PSB(53.79,J,0),U,9)=PSBACT) S X=1 D
  1.  .....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.02)
  1.  .....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$P(^TMP("PSJ",$J,2),U,2)_"^"_($$GET1^DIQ(53.79,J_",",.11))
  1.  .....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.06,"I")
  1.  .....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.13,"I")
  1.  I $G(PSBCNT)>0 S RESULTS(0)=PSBCNT
  1.  K ^TMP("PSJ",$J)
  1.  Q
  1.  ;
  1. SCANFAIL(RESULTS,PSBPARAM) ;  TEJ 05/12/2006  BCMA-Managing Scanning Failures (MSF)
  1.  ;       Document Unable to Scan Event
  1.  ;               Parameters:
  1.  ;               Input (via GUI):
  1.  ;
  1.  ;        Per Wristband  (0)      -       Pat IEN ^ ^ Reason Unable to Scan ^ User's Comment ^ "W" ^ 1 (keyed entry) or 2 (scanner)
  1.  ;        Per Medication (0)      -       Pat IEN ^ Order Number ^ Reason Unable to Scan ^ User's Comment ^ "M" ^ 1 (keyed entry) or 2 (scanner)
  1.  ;                       (1)      -       tag^ unique identifier
  1.  ;               Output:
  1.  ;                 Entry into database ^PSB(53.77)
  1.  ;                 Electronic Mail - Message Data per Unable to Scan Event
  1.  ;  PSB1 - Patient IEN
  1.  ;  PSB2 - Ward Location/Room
  1.  ;  PSB3 - Reason
  1.  ;  PSB4 - Type of Scan Issue
  1.  ;  PSB5 - Event date/item
  1.  ;  PSB6 - User's Comment
  1.  ;  PSB7 - User identification
  1.  ;  PSB8 - Order Number
  1.  ;                 RESULTS(0)=1
  1.  ;                 RESULTS(1)= 1 (Success) or -1 (Nonsuccess)
  1.  ;
  1.  K RESULTS,PSBSFUID,PSBMEDOI,PSBMEDNM
  1.  S RESULTS(0)=1,RESULTS(1)="-1^Unable to Scan documentation NOT successful!"
  1.  N PSBDAT,PSBDAT1,PSBXON,PSBSCHAD,PSBFILE
  1.  S PSBDAT=PSBPARAM(0) I $D(PSBPARAM(1)) S PSBDAT1=PSBPARAM(1)
  1.  S PSBXON=$P(PSBDAT,"^",2)
  1.  S PSB8=$G(PSBXON)
  1.  S (PSB1,PSBDFN)=$P(PSBDAT,"^")
  1.  ;
  1.  ; Changed the ward+room delimiter from / to $.
  1.  S PSB2=" *UNIDENTIFIABLE PATIENT* " I +$G(PSB1)>0 S PSB2=$$GET1^DIQ(2,PSB1_",",.1)_"$"_$$GET1^DIQ(2,PSB1_",",.101)
  1.  N VAIP,DFN S DFN=PSBDFN D IN5^VADPT Q:VAIP(5)=""   ;not admitted, *70
  1.  S PSB3=$P(PSBDAT,"^",3) I PSB3="Manual Medication Entry" S PSBMMEN=1
  1.  S PSB4=$S($P(PSBDAT,"^",5)="W":"Wristband",$P(PSBDAT,"^",5)="M":"Medication",1:" *UNDEFINED* ")
  1.  I PSB4="Medication"&($D(PSBDAT1)) D
  1.  .; Determine DD/ADD/SOL
  1.  .S PSBMEDOI=$P(PSBDAT1,"^",2)
  1.  .S PSBFILE=$P(PSBDAT1,"^"),PSBFILE=$S(PSBFILE="DD":50,PSBFILE="ADD":52.6,PSBFILE="SOL":52.7,1:PSBFILE)
  1.  .I PSBFILE'="ID" S PSBMEDNM=$$GET1^DIQ(PSBFILE,PSBMEDOI_",",.01)
  1.  .K PSBSFUID I PSBFILE="ID",(PSBMEDOI]"") S PSBSFUID=PSBMEDOI
  1.  D NOW^%DTC S (Y,PSB5A)=% D DD^%DT S PSB5=Y
  1.  S PSB6=$P(PSBDAT,"^",4)
  1.  S PSB7=". *UNDEFINED* " I $G(DUZ)>0 S PSB7=$$GET1^DIQ(200,DUZ_",",.01),PSB7A="`"_DUZ
  1.  ; Send message.
  1.  I $G(PSBMMEN)'=1,$P(PSBDAT,U,6)'=1,$P(PSBDAT,U,6)'=2 D MSFMSG^PSBMLU(PSB1,PSB2,PSB3,PSB4,PSB5,PSB6,PSB7,PSB8,.RESULTS)
  1.  I RESULTS(0)=-1 S RESULTS(0)=1,RESULTS(1)="-1^Unable to Scan MAILGROUP NOT SETUP!" Q
  1.  ;File data
  1.  D CLEAN^DILF
  1.  N PSBNEW1
  1.  S PSBNEW1="+1"
  1.  D
  1.  .I $G(PSBMMEN)=1 S PSBSCTYP="MMME" Q
  1.  .I $P(PSBDAT,U,6)=2 S PSBSCTYP=$S($P(PSBPARAM(0),"^",5)="W":"WSCN",$P(PSBPARAM(0),"^",5)="M":"MSCN") Q
  1.  .I $P(PSBDAT,U,6)=1 S PSBSCTYP=$S($P(PSBPARAM(0),"^",5)="W":"WKEY",$P(PSBPARAM(0),"^",5)="M":"MKEY") Q
  1.  .I $P(PSBDAT,U,6)=0 S PSBSCTYP=$S($P(PSBPARAM(0),"^",5)="W":"WUAS",$P(PSBPARAM(0),"^",5)="M":"MUAS")
  1.  ;
  1. FILESF ; File event.
  1.  D VAL^PSBML(53.77,"+1,",.01,PSB7A)
  1.  D VAL^PSBML(53.77,"+1,",.02,"`"_PSBDFN)
  1.  D VAL^PSBML(53.77,"+1,",.03,PSB2)
  1.  D VAL^PSBML(53.77,"+1,",.04,PSB5A)
  1.  D VAL^PSBML(53.77,"+1,",.05,PSBSCTYP)
  1.  D VAL^PSBML(53.77,"+1,",.06,PSB3)
  1.  D VAL^PSBML(53.77,"+1,",.07,$S($G(XMZ)]"":"`"_XMZ,1:""))
  1.  D VAL^PSBML(53.77,"+1,",.08,PSBXON)
  1.  D VAL^PSBML(53.77,"+1,",.09,PSB6)
  1.  D:$G(PSBFILE)=50
  1.  .D VAL^PSBML(53.771,"+2,+1,",.01,"`"_PSBMEDOI)
  1.  .D VAL^PSBML(53.771,"+2,+1,",1,PSBMEDNM)
  1.  D:$G(PSBFILE)=52.6
  1.  .D VAL^PSBML(53.7711,"+2,+1,",.01,"`"_PSBMEDOI)
  1.  .D VAL^PSBML(53.7711,"+2,+1,",1,PSBMEDNM)
  1.  D:$G(PSBFILE)=52.7
  1.  .D VAL^PSBML(53.7712,"+2,+1,",.01,"`"_PSBMEDOI)
  1.  .D VAL^PSBML(53.7712,"+2,+1,",1,PSBMEDNM)
  1.  I $G(PSBFILE)="ID" D VAL^PSBML(53.77,"+1,",14,PSBOIT),VAL^PSBML(53.77,"+1,",15,PSBOITX)
  1.  I $D(PSBSFUID) D VAL^PSBML(53.77,"+1,",13,PSBSFUID)
  1.  I $G(PSBFILE)="ID" D VAL^PSBML(53.77,"+1,",13,$S(PSBMEDOI']"":"WS",1:PSBMEDOI))
  1.  D UPDATE^DIE("","PSBFDA","PSBNEW1","PSBMSG")
  1.  I $D(PSBMSG("DIERR")) S RESULTS(0)=2,RESULTS(1)="-1^MSF Filing ERROR! "_PSBMSG("DIERR","1","TEXT",1) Q
  1.  S RESULTS(0)=1,RESULTS(1)="1^Unable to Scan documentation successful!"
  1.  Q
  1.  ;
  1. CLEANMSF ;
  1.  ;  Clean-up
  1.  K PSBNEW1,PSB1,PSB2,PSB3,PSB4,PSB5,PSB6,PSB7,PSB8,XMZ
  1.  Q
  1.  ;
  1. SCANCNT(PSBTYP) ;
  1.  ;  Routine to count total scans (NO MAIL)
  1.  ;  Input: PSBTYP - "WSCN"/"MSCN"/"MMME"/"MKEY"/"WKEY"  
  1.  D CLEAN^DILF
  1.  N PSBNEW1
  1.  S PSBNEW1="+1"
  1.  D VAL^PSBML(53.77,"+1,",.01,"`"_".5")
  1.  D VAL^PSBML(53.77,"+1,",.05,PSBTYP)
  1.  D UPDATE^DIE("","PSBFDA","PSBNEW1","PSBMSG")
  1.  I $D(PSBNEW1(1)) S DIK="^PSB(53.77,",DA=PSBNEW1(1) D ^DIK
  1.  I $D(PSBMSG("DIERR")) S RESULTS(0)=2,RESULTS(1)="-1^MSF Filing ERROR! "_PSBMSG("DIERR","1","TEXT",1) Q
  1.  S RESULTS(0)=1,RESULTS(1)="1^Unable to Scan documentation successful!"
  1.  Q
  1.  ;