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

ALPBPWRD.m

Go to the documentation of this file. 
  1. ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
  1.  ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ; 
  1.  ; NOTE: this routine is designed for hard-copy output.
  1.  ;      Output is formatted for 132-column printing.
  1.  ; 
  1.  F  D  Q:$D(DIRUT)
  1.  .W !,"Inpatient Pharmacy Orders for a selected ward"
  1.  .S DIR(0)="FAO^2:10"
  1.  .S DIR("A")="Select WARD: "
  1.  .S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
  1.  .D ^DIR K DIR
  1.  .I $D(DIRUT) Q
  1.  .D WARDSEL^ALPBUTL(Y,.ALPBSEL)
  1.  .I +$G(ALPBSEL(0))=0 D  Q
  1.  ..W $C(7)
  1.  ..W "  ??"
  1.  ..D WARDLIST^ALPBUTL("C")
  1.  ..K ALPBSEL
  1.  .I +$G(ALPBSEL(0))=1 D
  1.  ..S ALPBWARD=ALPBSEL(1)
  1.  ..W "   ",ALPBWARD
  1.  ..K ALPBSEL
  1.  .I +$G(ALPBSEL(0))>1 D  I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
  1.  ..S ALPBX=0
  1.  ..F  S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX  W !?2,$J(ALPBX,2),"  ",ALPBSEL(ALPBX)
  1.  ..K ALPBX
  1.  ..S DIR(0)="NA^1:"_ALPBSEL(0)
  1.  ..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
  1.  ..W ! D ^DIR K DIR
  1.  ..I $D(DIRUT) K ALPBSEL Q
  1.  ..S ALPBWARD=ALPBSEL(+Y)
  1.  ..K ALPBSEL
  1.  .;
  1.  .; get all or just current orders?...
  1.  .S DIR(0)="SA^A:ALL;C:CURRENT"
  1.  .S DIR("A")="Report [A]LL or [C]URRENT orders? "
  1.  .S DIR("B")="CURRENT"
  1.  .S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
  1.  .W ! D ^DIR K DIR
  1.  .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
  1.  .S ALPBOTYP=Y
  1.  .;
  1.  .;SORT BY NAME OR ROOM/BED     added 6/23/05
  1.  .S DIR(0)="SA^N:Name;R:Room/Bed"
  1.  .S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
  1.  .S DIR("B")="Room/bed"
  1.  .S DIR("?")="Sort by [N]ame or [R]oom Bed"
  1.  .W ! D ^DIR K DIR
  1.  .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
  1.  .S ALPBSORT=Y
  1.  .;
  1.  .; print how many days MAR?...
  1.  .S DIR(0)="NA^1:7"
  1.  .S DIR("A")="Print how many days MAR? "
  1.  .S DIR("B")=$$DEFDAYS^ALPBUTL()
  1.  .S DIR("?")="The default is shown; you may enter 3 or 7."
  1.  .W ! D ^DIR K DIR
  1.  .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
  1.  .S ALPBDAYS=+Y
  1.  .;
  1.  .; BCMA Med Log info for how many ?...
  1.  .S DIR(0)="NA^1:99"
  1.  .S DIR("B")=$$DEFML^ALPBUTL3()
  1.  .S DIR("A")="Select how many BCMA Medication Log history: "
  1.  .S DIR("A",1)=" "
  1.  .S DIR("?",1)="Select a number of BCMA Medication log entries"
  1.  .S DIR("?",2)="for each of the patient's orders"
  1.  .S DIR("?")="They are listed by the most current entry first"
  1.  .D ^DIR K DIR
  1.  .I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q
  1.  .S ALPBMLOG=Y
  1.  .;
  1.  .S %ZIS="Q"
  1.  .S %ZIS("B")=$$DEFPRT^ALPBUTL()
  1.  .I %ZIS("B")="" K %ZIS("B")
  1.  .W ! D ^%ZIS K %ZIS
  1.  .I POP D  Q
  1.  ..W $C(7)
  1.  ..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP
  1.  .;
  1.  .; output not queued...
  1.  .I '$D(IO("Q")) D
  1.  ..U IO
  1.  ..D DQ
  1.  ..I IO'=IO(0) D ^%ZISC
  1.  .;
  1.  .; set up the Task...
  1.  .I $D(IO("Q")) D
  1.  ..S ZTRTN="DQ^ALPBPWRD"
  1.  ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
  1.  ..S ZTSAVE("ALPBDAYS")=""
  1.  ..S ZTSAVE("ALPBWARD")=""
  1.  ..S ZTSAVE("ALPBMLOG")=""
  1.  ..S ZTSAVE("ALPBOTYP")=""
  1.  ..S ZTSAVE("ALPBSORT")=""
  1.  ..S ZTIO=ION
  1.  ..D ^%ZTLOAD
  1.  ..D HOME^%ZIS
  1.  ..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
  1.  ..K IO("Q"),ZTSK
  1.  .K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
  1.  K DIRUT,DTOUT,X,Y
  1.  Q
  1.  ;
  1. DQ ; output entry point...
  1.  K ^TMP($J)
  1.  ;
  1.  ; set report date...  SED 11/4/03
  1.  S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
  1.  ;
  1.  ; loop through ward cross reference in 53.7...
  1.  S ALPBPTN=""
  1.  F  S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN=""  D
  1.  .S ALPBIEN=0
  1.  .F  S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
  1.  ..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
  1.  ..I +ALPBORDS(0)'>0 K ALPBORDS Q
  1.  ..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
  1.  ..S ALPBOIEN=0
  1.  ..F  S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN  D
  1.  ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
  1.  ...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
  1.  ...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P"
  1.  ...; if report is for "C"urrent, check stop date and quit if
  1.  ...; stop date is less than report date...
  1.  ...I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
  1.  ...S ALPBORDN=ALPBORDS(ALPBOIEN)
  1.  ...S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
  1.  ...I '$D(^TMP($J,ALPBPTN)) S ^TMP($J,ALPBPTN)=ALPBIEN
  1.  ...S ^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
  1.  ...K ALPBDATA,ALPBORDN,ALPBOST
  1.  ..K ALPBOIEN,ALPBORDS,ALPBPDAT
  1.  .K ALPBIEN
  1.  K ALPBPTN
  1.  ;
  1.  ; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
  1.  S ALPBPG=0
  1.  S ALPBPTN=""
  1.  I ALPBSORT="N" D
  1.  .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  S ALPBIEN=^TMP($J,ALPBPTN) D PRT
  1.  ;SORT BY ROOM/BED
  1.  I ALPBSORT="R" D
  1.  .S ALPBD="",ALPRM=""
  1.  .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  D  Q:ALPBPTN=""
  1.  ..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
  1.  ..I ALPBPTN="" Q  ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
  1.  ..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
  1.  ..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
  1.  ..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
  1.  .S ALPRM1="" F  S ALPRM1=$O(^TMP($J,"BCBU",ALPRM1)) Q:ALPRM1=""  D
  1.  ..S ALPRM="" F  S ALPRM=$O(^TMP($J,"BCBU",ALPRM1,ALPRM)) Q:ALPRM=""  D
  1.  ...S ALPBD="" F  S ALPBD=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD)) Q:ALPBD=""  D
  1.  ....S ALPBPTN="" F  S ALPBPTN=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) Q:ALPBPTN=""  D
  1.  .....S ALPBIEN=$G(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN))  D PRT
  1.  D DONE
  1.  Q
  1. PRT S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
  1.  M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
  1.  I ALPBPG=0 D PAGE
  1.  S ALPBOCT=""
  1.  F  S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBOCT)) Q:ALPBOCT=""  D
  1.  .S ALPBOST=""
  1.  .F  S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST=""  D
  1.  ..S ALPBORDN=""
  1.  ..F  S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN=""  D
  1.  ...S ALPBOIEN=^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
  1.  ...; get and print this order's data...
  1.  ...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
  1.  ...D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
  1.  ...;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
  1.  ...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D PAGE
  1.  ...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX)
  1.  ...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
  1.  ..K ALPBORDN
  1.  .K ALPBOST
  1.  K ALPBOCT
  1.  ; print footer at end of this patient's record...
  1.  I $Y+10>IOSL D PAGE
  1.  W !!
  1.  D FOOT^ALPBFRMU
  1.  ;Print a blank page between patient
  1.  W @IOF
  1.  S ALPBPG=0
  1.  K ALPBPDAT
  1.  Q
  1.  ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
  1.  ;
  1. DONE ;   
  1.  K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  Q
  1.  ;
  1. PAGE ; print page header for patient...
  1.  W @IOF
  1.  S ALPBPG=ALPBPG+1
  1.  D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
  1.  F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX)
  1.  K ALPBHDR,ALPBX
  1.  Q