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 ;Mar 2004
  1.  ;;3.0;BAR CODE MED ADMIN;**5,3,13**;Mar 2004
  1.  ;
  1.  ;Reference/IA
  1.  ;DEM^VADPT/10061
  1.  ;INP^VADPT/10061
  1.  ;$$GET1^DIQ/2056
  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) ; Get the PRN's for a pt needing effectness
  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 PSBIEN,PSBSTOP
  1.  K ^TMP("PSB",$J),RESULTS
  1.  ;
  1.  Q:$$DISCHRGD(DFN)
  1.  ;
  1.  D INP^VADPT S PSBTRDT=+VAIN(7)
  1.  S PSBHOUR=$$GET^XPAR("DIV","PSB PRN DOCUMENTATION") I PSBHOUR="" S PSBHOUR=72
  1.  D NOW^%DTC S PSBSTRT=%,PSBPRNDT=$$FMADD^XLFDT(PSBSTRT,"",-PSBHOUR)
  1.  ;
  1.  ;Use the (OLDER) value of PSBPRNDT(site param) or PSBTRDT(admission)
  1.  I PSBPRNDT>PSBTRDT S PSBPRNDT=PSBTRDT
  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.  ..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.  ...S Y=Y+1
  1.  ...S ^TMP("PSB",$J,Y)=PSBSOL_U_$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.01)_U_PSBUNIT_U_PSBUNFR
  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.  K PSBTRDT,PSBHOUR,PSBPRNDT
  1.  D CLEAN^PSBVT
  1.  Q
  1.  ;
  1. DISCHRGD(DFN) ; Patient Discharged OR Deceased?
  1.  ;
  1.  S DISCHRGD=0
  1.  ;
  1.  D DEM^VADPT ;check for date of death entry
  1.  I VADM(6)]"" S DISCHRGD=1,^TMP("PSB",$J,0)=0 K VADM
  1.  ;
  1.  I DISCHRGD=0 D  ;check for discharge if they're not dead
  1.  .D INP^VADPT
  1.  .I VAIN(1)']"" S DISCHRGD=1,^TMP("PSB",$J,0)=0 K VAIN
  1.  ;
  1.  I DISCHRGD D  ;setup results and clean up
  1.  .S RESULTS=$NAME(^TMP("PSB",$J))
  1.  .K PSBTRDT,PSBHOUR,PSBPRNDT
  1.  .D CLEAN^PSBVT
  1.  ;
  1.  Q DISCHRGD
  1.  ;