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

PSBIHS4.m

Go to the documentation of this file. 
  1. PSBIHS4 ;KF/VAOIT BCMA Meds Admin date range ;MAR 2014
  1.  ;;1.0;PSB BCMA CPS FOXK;**1018**;;Build 27
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ; Reference/I
  1.  S DIC="^DPT(",DIC(0)="AEMQMZ" D ^DIC Q:Y'>0
  1.  Q:'+Y
  1.  S PSBDFN=$P(Y,"^",1)
  1.  K DIC,DIC(0),X,Y
  1. ST2 ;START AND END DATES
  1.  S %DT("A")="Enter a Start Date: "
  1.  S %DT="AE" D ^%DT I X="^"!(X="") D STOP Q
  1.  S PSBBDATE=Y K %DT,Y
  1.  I PSBBDATE<3030801 S Y=PSBBDATE D DD^%DT W !,"You entered "_Y_" Start Date must be After 'August 1, 2003" D ST2 Q
  1.  K %DT,Y
  1. END      K X
  1.  S %DT("A")="Enter a End Date: ",PSBEDATE=""
  1.  S %DT="AE" D ^%DT I X=""!(X="^") D STOP Q
  1.  S PSBEDATE=Y K %DT,Y
  1.  S X1=PSBEDATE,X2=1 D C^%DTC S PSBEDATE=X K X1,X2
  1.  I PSBEDATE<PSBBDATE W !,"End Date must be after the start !" D END Q
  1.  W !,"Include Order Details" S %=2 D YN^DICN S PSBORDET=% I %=-1 G STOP
  1.  W !,"NDC Daily Summary" S %=1 D YN^DICN S PSBRTNDC=% I %=-1 G STOP
  1.  I PSBORDET=2&(PSBRTNDC=2)  W !,"Eixting now nothing selected to print" G STOP
  1. TAS      ;TASK IT OR NOT
  1.  S %ZIS="Q"
  1.  W ! D ^%ZIS K %ZIS
  1.  I POP D  Q
  1.  .W $C(7)
  1.  .K VISN,PSBEDATE,PSBBDATE,PSBDV
  1.  ; output not queued...
  1.  I '$D(IO("Q")) D
  1.  .D WAIT^DICD U IO D NEW
  1.  .I IO'=IO(0) D ^%ZISC
  1.  ; set up the Task...
  1.  I $D(IO("Q")) D
  1.  .S ZTRTN="NEW^PSBIHS4"
  1.  .S ZTDESC="PSB Meds Admin by Date Range"
  1.  .S ZTSAVE("PSBBDATE")="",ZTSAVE("PSBEDATE")="",ZTSAVE("PSBDFN")="",ZTSAVE("PSBORDET")="",ZTSAVE("PSBRTNDC")=""
  1.  .S ZTIO=ION
  1.  .D ^%ZTLOAD,HOME^%ZIS
  1.  .W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
  1.  .K IO("Q"),ZTSK,ZTIO,ZTSAVE,ZTRTN,ZTDESC
  1.  Q
  1. NEW      ;Collect data
  1.  N PG,PSBNAME,PSBDOB,PSBIEN,PSBSTATUS,PSBLASTACT,PSBOITEM,PSBDSIEN,PSBDATE,PSBNDC,PSBOIEN,PSBDRUG,DFN,PSBDATEE,PSBPID,PSBDU,PSBDIEN ;HEAD,HEAD1
  1.  ;GET PT DEM
  1.  S DFN=PSBDFN
  1.  D DEM^VADPT,PID^VADPT
  1.  S PSBPID=$S(DUZ("AG")="I":(VA("PID")),1:$E(VA("PID"),$L(VA("PID"))-3,999)),PSBNAME=VADM(1),PSBDOB=$P(VADM(3),U,2)
  1.  K VA,VADM
  1.  D NOW^%DTC S Y=% D DD^%DT S PSBNOW=Y
  1.  S HEAD="W @IOF S:'$D(PG) PG=0 S PG=PG+1 W !,""Medications Administrated in BCMA "" S Y=PSBBDATE D DD^%DT W Y_"" Through "" S Y=PSBEDATE D DD^%DT W Y,"" Run Date: ""_PSBNOW,?100,"" Page "",PG"
  1.  S HEAD1="W !,PSBNAME,"" HRN: "",PSBPID,"" DOB: "",PSBDOB"
  1.  ;X HEAD,HEAD1
  1.  K ^TMP($J,"BCMA")
  1.  S PSBDATE=PSBBDATE F   S PSBDATE=$O(^PSB(53.79,"AADT",PSBDFN,PSBDATE)) Q:PSBDATE'>0  I PSBDATE>PSBBDATE&(PSBDATE<PSBEDATE) D
  1.  .S PSBIEN="" F  S PSBIEN=$O(^PSB(53.79,"AADT",PSBDFN,PSBDATE,PSBIEN)) Q:PSBIEN'>0  D
  1.  ..S PSBSTATUS=$P($G(^PSB(53.79,PSBIEN,0)),U,9)
  1.  ..S PSBLASTACT=$P($G(^PSB(53.79,PSBIEN,0)),U,6) ;GET LAST ACTION DT, THE XFER HAS MULTPE ACTION DT FOR SAME IEN, BY DESIGN FOR SOME REASON.
  1.  ..; NO HELD, REFUSED, NOT GIVEN, MISSING ON THE REPORT
  1.  ..Q:PSBSTATUS="H"!(PSBSTATUS="N")!(PSBSTATUS="R")!(PSBSTATUS="M")
  1.  ..S PSBOITEM=$P($G(^PSB(53.79,PSBIEN,0)),U,8)
  1.  ..S ^TMP($J,"BCMA",PSBLASTACT,PSBIEN)=PSBOITEM
  1.  ..F J=1:1:$P($G(^PSB(53.79,PSBIEN,.5,0)),U,4) D
  1.  ...S PSBDSIEN=$P($G(^PSB(53.79,PSBIEN,.5,J,0)),U,1),^TMP($J,"BCMA","OI",PSBLASTACT,PSBIEN,PSBDSIEN)=$P($G(^PSB(53.79,PSBIEN,.5,J,0)),U,3)_U_$P($G(^PSB(53.79,PSBIEN,.5,J,0)),U,4)
  1.  ...;COUNT DAILY PER NDC UD
  1.  ...S PSBDNDC=$P($G(^PSDRUG(PSBDSIEN,2)),U,4) I PSBDNDC="" S PSBDNDC="NO NDC"
  1.  ...I '$D(^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDC1",$P($G(^PSDRUG(PSBDSIEN,0)),U,1),PSBDSIEN,PSBDNDC)) S ^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDC1",$P($G(^PSDRUG(PSBDSIEN,0)),U,1),PSBDSIEN,PSBDNDC)=0
  1.  ...S ^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDC1",$P($G(^PSDRUG(PSBDSIEN,0)),U,1),PSBDSIEN,PSBDNDC)=^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDC1",$P($G(^PSDRUG(PSBDSIEN,0)),U,1),PSBDSIEN,PSBDNDC)+1
  1.  ..;COUNT NDC PER DAY IV ADD
  1.  ..I $D(^PSB(53.79,PSBIEN,.6,0)) F J=1:1:$P(^PSB(53.79,PSBIEN,.6,0),"^",4) D
  1.  ...S ^TMP($J,"BCMA","ADD",PSBIEN,PSBLASTACT,$P(^PSB(53.79,PSBIEN,.6,J,0),U,1))=$P(^PSB(53.79,PSBIEN,.6,J,0),"^",3)
  1.  ...;COUNT NDC PER DAY UD
  1.  ...S PSBOIEN=$P(^PSB(53.79,PSBIEN,.6,J,0),U,1),PSBDIEN=$P($G(^PS(52.6,PSBOIEN,0)),U,2),PSBDNDC=$P($G(^PSDRUG(PSBDIEN,2)),U,4) I PSBDNDC="" S PSBDNDC="NO NDC"
  1.  ...I '$D(^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDCA",$P($G(^PSDRUG(PSBDIEN,0)),U,1),PSBDIEN,PSBDNDC)) S ^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDCA",$P($G(^PSDRUG(PSBDIEN,0)),U,1),PSBDIEN,PSBDNDC)=0
  1.  ...S ^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDCA",$P($G(^PSDRUG(PSBDIEN,0)),U,1),PSBDIEN,PSBDNDC)=^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDCA",$P($G(^PSDRUG(PSBDIEN,0)),U,1),PSBDIEN,PSBDNDC)+1
  1.  ..;COUNT NDC PER DAY IV SOL
  1.  ..I $D(^PSB(53.79,PSBIEN,.7,0)) F J=1:1:$P(^PSB(53.79,PSBIEN,.7,0),"^",4) D
  1.  ...S ^TMP($J,"BCMA","SOL",PSBIEN,PSBLASTACT,$P(^PSB(53.79,PSBIEN,.7,J,0),U,1))=$P(^PSB(53.79,PSBIEN,.7,J,0),"^",3)
  1.  ...S PSBOIEN=$P(^PSB(53.79,PSBIEN,.7,J,0),U,1),PSBDIEN=$P($G(^PS(52.7,PSBOIEN,0)),U,2),PSBDNDC=$P($G(^PSDRUG(PSBDIEN,2)),U,4) I PSBDNDC="" S PSBDNDC="NO NDC"
  1.  ...I '$D(^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDCS",$P($G(^PSDRUG(PSBDIEN,0)),U,1),PSBDIEN,PSBDNDC)) S ^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDCS",$P($G(^PSDRUG(PSBDIEN,0)),U,1),PSBDIEN,PSBDNDC)=0
  1.  ...S ^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDCS",$P($G(^PSDRUG(PSBDIEN,0)),U,1),PSBDIEN,PSBDNDC)=^TMP($J,"BCMA1",$P(PSBDATE,".",1),"NDCS",$P($G(^PSDRUG(PSBDIEN,0)),U,1),PSBDIEN,PSBDNDC)+1
  1.  I '$D(^TMP($J,"BCMA")) D
  1.  .X HEAD,HEAD1 W ! F J=1:1:IOM W "-"
  1.  .W !,"Nothing to Report"
  1.  I $D(^TMP($J,"BCMA")) D
  1.  .D:PSBRTNDC=1 SUMNDC
  1.  .D:PSBORDET=1 DETPRT
  1.  D STOP
  1.  Q
  1.  ;LOOP DATA and Print                       
  1. DETPRT ; PRINT ORDER DETAILS
  1.  X HEAD,HEAD1 W !,"Action Date/Time",?30,"Medication Given",! F J=1:1:IOM W "-"
  1.  S PSBDATE="" F  S PSBDATE=$O(^TMP($J,"BCMA",PSBDATE)) Q:'+PSBDATE  D
  1.  .S PSBIEN="" F  S PSBIEN=$O(^TMP($J,"BCMA",PSBDATE,PSBIEN)) Q:'+PSBIEN  D
  1.  ..S Y=PSBDATE  D DD^%DT S PSBDATEE=Y
  1.  ..S PSBOIEN=$G(^TMP($J,"BCMA",PSBDATE,PSBIEN)),PSBDIEN=$O(^PSDRUG("ASP",PSBOIEN,"")),PSBNDC=$P($G(^PSDRUG(PSBDIEN,2)),U,4)
  1.  ..I $Y>(IOSL-2) X HEAD,HEAD1 W !,"Action Date/Time",?30,"Medication Given",! F J=1:1:IOM W "-"
  1.  ..W !,Y,?23,"Pharmacy Orderable Item: ",$E($P($G(^PS(50.7,PSBOIEN,0)),"^",1),1,35)_$S($P($G(^PSB(53.79,PSBIEN,.1)),"^",5)'="":" Dose Ordered:"_$P($G(^PSB(53.79,PSBIEN,.1)),"^",5),1:"")
  1.  ..S PSBDSIEN="" F  S PSBDSIEN=$O(^TMP($J,"BCMA","OI",PSBDATE,PSBIEN,PSBDSIEN)) Q:$G(PSBDSIEN)=""  D
  1.  ...S PSBDU=$P($G(^TMP($J,"BCMA","OI",PSBDATE,PSBIEN,PSBDSIEN)),U,2)
  1.  ...W !,?5,$P($G(^PSDRUG(PSBDSIEN,0)),U,1)_" Dose Given: "_$P($G(^TMP($J,"BCMA","OI",PSBDATE,PSBIEN,PSBDSIEN)),U,1)_$S(PSBDU'["TAB"&(PSBDU'["CAP")&(PSBDU'["PATCH"):" Unit of Administration: "_PSBDU,1:"")_" NDC: "_$P($G(^PSDRUG(PSBDSIEN,2)),U,4)
  1.  ..I $D(^TMP($J,"BCMA","ADD",PSBIEN,PSBDATE)) D
  1.  ...W !,?5,"Additives: " S PSBOIEN="" S PSBOIEN=$O(^TMP($J,"BCMA","ADD",PSBIEN,PSBDATE,PSBOIEN)) Q:'+PSBOIEN  D
  1.  ....S PSBDIEN=$P($G(^PS(52.6,PSBOIEN,0)),U,2),PSBNDC=$P($G(^PSDRUG(PSBDIEN,2)),U,4) I PSBNDC="" S PSBNDC="NO NDC"
  1.  ....W !,?10,$P($G(^PS(52.6,PSBOIEN,0)),U,1)," Dose: ",$G(^TMP($J,"BCMA","ADD",PSBIEN,PSBDATE,PSBOIEN))," NDC: ",PSBNDC
  1.  ..I $D(^TMP($J,"BCMA","SOL",PSBIEN,PSBDATE)) D
  1.  ...W !,?5,"Solutions: " S PSBOIEN="" S PSBOIEN=$O(^TMP($J,"BCMA","SOL",PSBIEN,PSBDATE,PSBOIEN)) Q:'+PSBOIEN  D
  1.  ....S PSBDIEN=$P($G(^PS(52.7,PSBOIEN,0)),U,2),PSBNDC=$P($G(^PSDRUG(PSBDIEN,2)),U,4) I PSBNDC="" S PSBNDC="NO NDC"
  1.  ....W !,?10,$P($G(^PS(52.7,PSBOIEN,0)),U,1)," Dose: ",$G(^TMP($J,"BCMA","SOL",PSBIEN,PSBDATE,PSBOIEN))," NDC: ",PSBNDC
  1.  ..W !,"Location: "_$$GET1^DIQ(53.79,PSBIEN,.02),! ;SPACE BETWEEN MED LOGS
  1.  Q
  1. SUMNDC ; DAILY SUMMARY 
  1.  K PSBCNT S PSBCNT=0
  1.  N PSBLDT,PSBTYP,PSBDNAME,PSBDIEN,PSBNDC,PSBIEN,HEAD2
  1.  S HEAD2="W !,""Medication "",?55,""NDC"",?80,""Number Medications Given"",! F J=1:1:IOM W ""-"""
  1.  X HEAD,HEAD1,HEAD2
  1.  S PSBDT=0 F  S PSBDT=$O(^TMP($J,"BCMA1",PSBDT)) Q:PSBDT'>0  D
  1.  .I $G(PSBLDT)=""!(PSBDT'=$G(PSBLDT)) S Y=PSBDT D DD^%DT W !,Y
  1.  .S PSBTYP="" F  S PSBTYP=$O(^TMP($J,"BCMA1",PSBDT,PSBTYP)) Q:PSBTYP=""  D
  1.  ..W !,$S(PSBTYP="NDC1":"Unit Dose:",PSBTYP="NDCA":"Additives:",PSBTYP="NDCS":"Solutions:",1:"")
  1.  ..S PSBDNAME="" F  S PSBDNAME=$O(^TMP($J,"BCMA1",PSBDT,PSBTYP,PSBDNAME)) Q:PSBDNAME=""  D
  1.  ...S PSBDIEN=0  F  S PSBDIEN=$O(^TMP($J,"BCMA1",PSBDT,PSBTYP,PSBDNAME,PSBDIEN)) Q:PSBDIEN'>0  D
  1.  ....S PSBNDC="" F  S PSBNDC=$O(^TMP($J,"BCMA1",PSBDT,PSBTYP,PSBDNAME,PSBDIEN,PSBNDC)) Q:PSBNDC=""  D
  1.  .....I $Y>(IOSL-2) X HEAD,HEAD1,HEAD2 S Y=PSBDT D DD^%DT W !,Y,!,$S(PSBTYP="NDC1":"Unit Dose:",PSBTYP="NDCA":"Additives:",PSBTYP="NDCS":"Solutions:",1:"")
  1.  .....S PSBLDT=PSBDT W !,PSBDNAME,?55,PSBNDC,?80,$G(^TMP($J,"BCMA1",PSBDT,PSBTYP,PSBDNAME,PSBDIEN,PSBNDC))
  1.  .....;DAILY CNT
  1.  .....I '$D(PSBCNT(PSBDT)) S PSBCNT(PSBDT)=0
  1.  .....S PSBCNT(PSBDT)=PSBCNT(PSBDT)+$G(^TMP($J,"BCMA1",PSBDT,PSBTYP,PSBDNAME,PSBDIEN,PSBNDC))
  1.  .....S PSBCNT=PSBCNT+$G(^TMP($J,"BCMA1",PSBDT,PSBTYP,PSBDNAME,PSBDIEN,PSBNDC))
  1.  .W ! F J=1:1:IOM W "-"
  1.  .W !,?55,"Daily Totals: ",?80,$G(PSBCNT(PSBDT))
  1.  W !,?55,"Report Totals: ",?80,PSBCNT
  1.  Q
  1. STOP ;FINAL CLEAN UP
  1.  K ^TMP($J,"BCMA"),^TMP($J,"BCMA1"),PSBDFN,PSBEDATE,PSBBDATE,J,JJ,POP,HEAD,HEAD1,PSBNOW,PSBCNT,PSBORDET,PSBRTNDC,PSBDT,PSBDNDC
  1.  Q