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

PSBPRN.m

Go to the documentation of this file. 
  1. PSBPRN ;BIRMINGHAM/EFC-BCMA PRN FUNCTIONS ;12/14/12 12:22pm
  1.  ;;3.0;BAR CODE MED ADMIN;**5,3,13,61,68,70,80,86,99**;Mar 2004;Build 9
  1.  ;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;Reference/IA
  1.  ;DEM^VADPT/10061
  1.  ;INP^VADPT/10061
  1.  ;$$GET1^DIQ/2056
  1.  ;GETSIOPI^PSJBCMA5/5763
  1.  ;
  1.  ;*68 - add call to add special instructions (SI) entries to the
  1.  ;      ^TMP("PSB")  global that ends up in the RESULTS ARRAY of
  1.  ;      RPC PSB GETPRNS.
  1.  ;      and add new parameter to GETPRNS tag to use new SI/OPI word
  1.  ;      processing fields.
  1.  ;*70 - remove discharged status from the api and rename DECEASED
  1.  ;      see below, in tag Getprns, for searchng back rules and dates
  1.  ;      of CO vs IM orders.
  1.  ;
  1.  ; ** Warning: PSBSIOPI will be used as a global variable for all down
  1.  ;    streams calls from this RPC tag call.
  1.  ;
  1. EN ;
  1.  Q
  1.  ;
  1. EDIT ; Edit Medication Log PRN Effectiveness
  1.  NEW DFN ;* Undef DFN at EDIT+7^PSBPRN (NOIS: HUN-0699-21494)
  1.  W !! S DA=""
  1.  S DIC="^DPT(",DIC(0)="AEQM",DIC("A")="Select Patient Name: "
  1.  D ^DIC K DIC Q:+Y<1
  1.  S DFN=+Y
  1.  D EDIT1
  1.  K DFN,DA
  1.  G EDIT
  1.  ;
  1. EDIT1 ;
  1.  S %DT="AEQ",%DT("A")="Select Date to Begin Searching Back From: "
  1.  S %DT("B")="Today"
  1.  W !! D ^%DT Q:+Y<1  S PSBDT=Y
  1.  F  D  Q:'PSBDT
  1.  .W @IOF,!,"Searching Date " S Y=PSBDT D D^DIQ W Y
  1.  .W !," #  Medication",?45,"St",?50,"D/T Given",?75,"Int"
  1.  .W !,$TR($J("",IOM)," ","-")
  1.  .S PSBSRCH=PSBDT+.9,PSBCNT=0
  1.  .K PSBTMP
  1.  .F  S PSBSRCH=$O(^PSB(53.79,"APRN",DFN,PSBSRCH),-1) Q:'PSBSRCH!(PSBSRCH<PSBDT)  D
  1.  ..S PSBIEN=""
  1.  ..F  S PSBIEN=$O(^PSB(53.79,"APRN",DFN,PSBSRCH,PSBIEN),-1) Q:'PSBIEN  D
  1.  ...Q:$P($G(^PSB(53.79,PSBIEN,.2)),U,2)]""
  1.  ...Q:$P($G(^PSB(53.79,PSBIEN,0)),U,9)'="G"
  1.  ...S PSBCNT=PSBCNT+1,PSBTMP(PSBCNT)=PSBIEN
  1.  ...I $Y>19 W ! S DIR(0)="E" D ^DIR W @IOF,!,"Searching Date " S Y=PSBDT D D^DIQ W Y,!," #  Medication",?45,"St",?50,"D/T Given",?75,"Int",!,$TR($J("",IOM)," ","-")
  1.  ...W !,$J(PSBCNT,2),". "
  1.  ...W ?5,$$GET1^DIQ(53.79,PSBIEN_",",.08)
  1.  ...W ?45,$P(^PSB(53.79,PSBIEN,0),U,9)
  1.  ...W ?50,$$GET1^DIQ(53.79,PSBIEN_",",.06)
  1.  ...W ?75,$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
  1.  .I PSBCNT W ! S DIR(0)="NO^1:"_PSBCNT_":0" D ^DIR S:Y DA=PSBTMP(Y),PSBDT="" Q:Y
  1.  .I 'PSBCNT W !!?5,"No Meds Found!"
  1.  .S X1=PSBDT,X2=-1 D C^%DTC S (PSBDT,Y)=X D D^DIQ
  1.  .W !!,"Continue With ",Y
  1.  .S %=1 D YN^DICN I %'=1 S PSBDT=0
  1.  I DA S DDSFILE=53.79,DR="[PSB PRN EFFECTIVENESS]" D ^DDS S %=2 W !,"Edit another entry" D YN^DICN G:%=1 EDIT1
  1.  K PSBCNT,PSBDT,PSBIEN,PSBSRCH,PSBTMP,DA,DR,DDSFILE
  1.  Q
  1.  ;
  1. GETPRNS(RESULTS,DFN,PSBORD,PSBSIOPI) ; Get the PRN's for a pt needing effectiveness
  1.  ;
  1.  ; RPC PSB GETPRNS
  1.  ;
  1.  ; Description:
  1.  ; Returns all administrations of a PRN order that have NOT had
  1.  ; the PRN Effectiveness documented BASED ON THE TRANSFER DATE AND SITE PARAM
  1.  ;
  1.  N PSBADMDT,PSBHOUR,PSBPRNDT,PSBIEN,PSBSTOP,PSBIMHR,PSBIMPRNDT,PSBCODY,PSBCOPRNDT,PSBSTRT,PSBIMMAX   ;Add PSBSTRT to list of newed variables, PSB*3*86
  1.  K ^TMP("PSB",$J),RESULTS
  1.  S PSBSIOPI=+$G(PSBSIOPI)   ;*68 init to 0 if not present or 1 if sent
  1.  ;
  1.  Q:$$DECEASED(DFN)                                                ;*70
  1.  ;
  1.  D INP^VADPT S PSBADMDT=+VAIN(7)                   ;get admit date *70
  1.  ;get IM site param then build IM & CO PRN dates                   *70
  1.  S PSBIMHR=$$GET^XPAR("DIV","PSB PRN DOCUMENTATION")  ;IM hours
  1.  S:'PSBIMHR PSBIMHR=72                ;IM def=72 hrs if param null *70
  1.  S PSBCODY=1                          ;CO def = 1 day, no time     *70
  1.  ;
  1.  ;*70
  1.  ; BUILD IM & CO prn date limit from Site param and/or defaults,
  1.  ; then use the oldest of the 2 PRN dates for the loop quit value.
  1.  ; If an admit date exists and is older than the IM date, then use
  1.  ; it for the loop. Also if admit date is present, then CO orders
  1.  ; should use IM rules and dates.
  1.  ;
  1.  ; CO date, for non-admitted patient, will be a whole day, no time.
  1.  ;
  1.  D NOW^%DTC S PSBSTRT=%
  1.  S PSBIMMAX=$$GET^XPAR("ALL","PSB MED HIST DAYS BACK"),PSBIMMAX=$S(PSBIMMAX<35:35,1:PSBIMMAX) ;Set PSBIMMIX to Med Hist Days Back parameter or 35 days, whichever is longer 
  1.  S PSBIMMAX=$$FMADD^XLFDT(PSBSTRT,-PSBIMMAX) ;Limit days for PRN Effectiveness, PSB*3*86 
  1.  ;create IM & CO past date limit to include these order types     *70
  1.  S PSBIMPRNDT=$$FMADD^XLFDT(PSBSTRT,"",-PSBIMHR)
  1.  S PSBCOPRNDT=$$FMADD^XLFDT($P(PSBSTRT,"."),-PSBCODY)
  1.  S PSBPRNDT=$S(PSBCOPRNDT<PSBIMPRNDT:PSBCOPRNDT,1:PSBIMPRNDT)
  1.  ;use older of PSBPRNDT & PSBADMDT(admission) for loop quit value
  1.  I PSBADMDT,PSBADMDT<PSBPRNDT S (PSBPRNDT,PSBIMPRNDT,PSBCOPRNDT)=$S(PSBIMMAX<PSBADMDT:PSBADMDT,1:PSBIMMAX) ;Use max days back parameter PSBIMMAX, PSB*3*86
  1.  I PSBADMDT<$G(DT),PSBPRNDT<PSBIMPRNDT S PSBIMPRNDT=PSBADMDT ;Preserve admission for IM when prior to today's date, PSB*3*99
  1.  ;end dates                                                       *70
  1.  ;
  1.  ;begin loop of PRN records
  1.  S PSBSTRT="" F  S PSBSTRT=$O(^PSB(53.79,"APRN",DFN,PSBSTRT),-1) Q:(PSBSTRT<PSBPRNDT)  D
  1.  .S PSBIEN=""
  1.  .F  S PSBIEN=$O(^PSB(53.79,"APRN",DFN,PSBSTRT,PSBIEN),-1) Q:'PSBIEN  D
  1.  ..Q:(PSBORD'="")&($P(^PSB(53.79,PSBIEN,.1),U)'=PSBORD)  ;  Not the right order
  1.  ..I ($P(^PSB(53.79,PSBIEN,0),U,9)'="G")&($P(^PSB(53.79,PSBIEN,0),U,9)'="RM") Q    ; Med was never given
  1.  ..Q:$P($G(^PSB(53.79,PSBIEN,.2)),U,2)]""  ; Already entered
  1.  ..S PSBX=PSBIEN_U_DFN,PSBIENS=PSBIEN_","
  1.  ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.02)
  1.  ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.06,"I")
  1.  ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.07)
  1.  ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.08)
  1.  ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.21)
  1.  ..D PSJ1^PSBVT(DFN,$$GET1^DIQ(53.79,PSBIENS,.11))
  1.  ..;admit date exists, force CO order to look like an IM           *70
  1.  ..I PSBADMDT S PSBCLORD=""
  1.  ..;skip CO order admins that are older than CO PRN date           *70
  1.  ..Q:($G(PSBCLORD)]"")&($P(PSBSTRT,".")<$P(PSBCOPRNDT,"."))
  1.  ..;skip IM order admins that are older than IM PRN date           *70
  1.  ..Q:($G(PSBCLORD)="")&(PSBSTRT<PSBIMPRNDT)
  1.  ..S PSBX=PSBX_U_PSBOIT_U_PSBONX
  1.  ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.27)
  1.  ..S Y=$O(^TMP("PSB",$J,""),-1)+1
  1.  ..S ^TMP("PSB",$J,Y)=PSBX
  1.  ..;Special instructions
  1.  ..S Y=Y+1,^TMP("PSB",$J,Y)=PSBOTXT
  1.  ..F PSBZ=.5,.6,.7 F PSBY=0:0 S PSBY=$O(^PSB(53.79,PSBIEN,PSBZ,PSBY)) Q:'PSBY  D
  1.  ...S PSBDD=$S(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
  1.  ...S PSBSOL=$S(PSBZ=.5:"DD",PSBZ=.6:"ADD",1:"SOL")
  1.  ...Q:'$D(^PSB(53.79,PSBIEN,PSBZ,PSBY))
  1.  ...S PSBUNIT=$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.03)
  1.  ...S PSBUNFR=$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.04)
  1.  ...I PSBUNIT>0&(PSBUNIT<1) S PSBUNIT="0"_+PSBUNIT ;add leading 0 for a decimal value less than 1 - PSB*3*61
  1.  ...S Y=Y+1
  1.  ...S ^TMP("PSB",$J,Y)=PSBSOL_U_$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.01)_U_PSBUNIT_U_PSBUNFR
  1.  ..D:PSBSIOPI GETSI(DFN,PSBONX,.Y)     ;*68 get spec inst/oth prt info
  1.  ..S Y=Y+1,^TMP("PSB",$J,Y)="END"
  1.  S ^TMP("PSB",$J,0)=+$O(^TMP("PSB",$J,""),-1)
  1.  S RESULTS=$NAME(^TMP("PSB",$J))
  1.  D CLEAN^PSBVT
  1.  Q
  1.  ;
  1. DECEASED(DFN) ; Patient Deceased?                                        *70
  1.  ;
  1.  S DECEASED=0
  1.  ;
  1.  D DEM^VADPT ;check for date of death entry
  1.  I VADM(6)]"" S DECEASED=1,^TMP("PSB",$J,0)=0 K VADM
  1.  ;
  1.  I DECEASED D  ;setup results and clean up
  1.  .S RESULTS=$NAME(^TMP("PSB",$J))
  1.  .D CLEAN^PSBVT
  1.  ;
  1.  Q DECEASED
  1.  ;
  1. GETSI(DFN,ORD,PSB) ;Get Special Instructions/Other Print Info from IM   ;*68
  1.  ;
  1.  ; This Tag will load the SIOPI WP text into the TMP global used by
  1.  ; the PSB GETPRNS RPC, which ends up in the RESULTS array passed
  1.  ; back to the BCMA GUI.
  1.  ;
  1.  N QQ
  1.  K ^TMP("PSJBCMA5",$J,DFN,ORD)
  1.  D GETSIOPI^PSJBCMA5(DFN,ORD,1)
  1.  Q:'$D(^TMP("PSJBCMA5",$J,DFN,ORD))
  1.  F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,DFN,ORD,QQ)) Q:'QQ  D
  1.  .S PSB=PSB+1
  1.  .S ^TMP("PSB",$J,PSB)="SI^"_^TMP("PSJBCMA5",$J,DFN,ORD,QQ)
  1.  K ^TMP("PSJBCMA5",$J,DFN,ORD)
  1.  Q