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

BWLETDQ.m

Go to the documentation of this file. 
  1. BWLETDQ ; CMI/TUCSON/LAB - PRINT QUEUED LETTERS ;03-Sep-2003 20:09;PLS
  1.  ;;2.0;WOMEN'S HEALTH;**6,8,9**;MAY 16, 1996
  1.  ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
  1.  ;;  CALLED BY OPTION: "BW PRINT QUEUED LETTERS" TO PRINT LETTERS
  1.  ;;  BY "APRT" XREF IN ^BWNOT("APRT".
  1.  ;
  1.  ;IHS/CMI/LAB - patched to allow printing of letters by case manager
  1.  ;and to reprint letters - patch 6
  1.  ;IHS/CIA/PLS - logic added to disallow printing if Status is ERROR - Patch 9
  1.  ;
  1. START ;EP
  1.  D SETUP G:BWPOP EXIT
  1.  D CASEMAN G:BWPOP EXIT ;IHS/CMI/LAB - patch 6
  1.  D DEVICE G:BWPOP EXIT
  1.  D PRINT
  1.  ;
  1. EXIT ;EP
  1.  D ^%ZISC
  1.  D KILLALL^BWUTL8
  1.  Q
  1.  ;
  1. CASEMAN ;print letters for one case manager or all
  1.  ;IHS/CMI/LAB - patch 6 added this subroutine
  1.  S BWPOP=0
  1.  S BWCASEM="",BWCASEMN=""
  1.  S DIR(0)="S^A:All Case Managers (Print ALL Queued Letters);O:One Case Manager (Letters for ONE Case Manager's Patients)",DIR("A")="Print Queued Letters for",DIR("B")="A" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S BWPOP=1 Q
  1.  S BWCASEM=Y
  1.  Q:BWCASEM="A"
  1.  K DIC,DA,DR,DD S DIC("A")="Which Case Manager:  ",DIC="^BWMGR(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DD,DR,DO
  1.  I Y=-1 G CASEMAN
  1.  S BWCASEMN=+Y
  1.  Q
  1. SETUP ;EP
  1.  D SETVARS^BWUTL5 S BWPOP=0 K DIR
  1.  S BWDUZ2=$G(DUZ(2))
  1.  D TITLE^BWUTL5("PRINT QUEUED PATIENT LETTERS")
  1.  I '$D(^BWNOT("APRT")) D  S BWPOP=1
  1.  .S BWTITLE="* There are no letters waiting to be printed. *"
  1.  .D CENTERT^BWUTL5(.BWTITLE)
  1.  .W !!!!,BWTITLE,!!
  1.  .D DIRZ^BWUTL3
  1.  Q
  1.  ;
  1. DEVICE ;EP
  1.  ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
  1.  K %ZIS,IOP
  1.  S ZTRTN="PRINT^BWLETDQ",ZTSAVE("BWDUZ2")="",ZTSAVE("BWCAS*")=""
  1.  D ZIS^BWUTL2(.BWPOP,1)
  1.  Q
  1.  ;
  1. PRINT ;EP
  1.  D SETVARS^BWUTL5
  1.  S BWCRT=$S($E(IOST)="C":1,1:0)
  1.  ;---> USE BWION TO PRESERVE ION WHEN PRINTING MULTIPLE LETTERS.
  1.  S (BWN,BWM)=0,BWION=ION
  1.  F  S BWN=$O(^BWNOT("APRT",BWN)) Q:'BWN!(BWPOP)!(BWN>DT)  D
  1.  .S BWDA=0
  1.  .F  S BWDA=$O(^BWNOT("APRT",BWN,BWDA)) Q:'BWDA!(BWPOP)  D
  1.  ..;---> QUIT IF NOT ASSOCIATED WITH THE USER'S CURRENT FACILITY.
  1.  ..N BWFACIL S BWFACIL=$P(^BWNOT(BWDA,0),U,7)
  1.  ..Q:((BWFACIL'=BWDUZ2)&(BWFACIL))
  1.  ..;IHS/CIA/PLS - patch 9 - Kill xref and quit if status = ERROR
  1.  ..I $P(^BWNOT(BWDA,0),U,14)="e" D  Q
  1.  ...D KILLXREF^BWLETPR(BWDA,BWN)
  1.  ..;IHS/CMI/LAB - patch 6 added next 3 lines to allow printing by
  1.  ..;case manager
  1.  ..;---> QUIT if BWCASEMN and BWCASEM="O" and this patients
  1.  ..;     case manager is not equal to BWCASEMN
  1.  ..I BWCASEM="O",BWCASEMN,$P(^BWP($P(^BWNOT(BWDA,0),U),0),U,10)'=BWCASEMN Q
  1.  ..;---> BWKDT=DATE USED TO KILL "APRT" XREF IN ^BWLETPR
  1.  ..S BWKDT=BWN,ION=BWION
  1.  ..D PRINT^BWLETPR
  1.  ..S BWM=BWM+1 K BWKDT
  1.  I 'BWM D
  1.  .W !!?17,"No letters are due to be printed at this time.",!!
  1.  .D:BWCRT DIRZ^BWUTL3 W:'BWCRT @IOF
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1.  ;----------
  1. REPRINT ;EP
  1.  ;---> FOR REPRINTING LETTERS,  REMAINDER OF THIS ROUTINE IS NEW.
  1.  ;---> MENU OPTION FOR THIS SHOULD BE CREATED (SYNONYM "RQ") AND
  1.  ;---> ADDED TO OPTION BW MENU-MANAGER'S FUNCTIONS.
  1.  ;---> Prototype code for menu option to reprint letters.
  1.  ;
  1.  D SETVARS^BWUTL5 S BWPOP=0 K DIR
  1.  D TITLE^BWUTL5("RE-PRINT PATIENT LETTERS"),REPRINTX
  1.  D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP)
  1.  Q:BWPOP
  1.  D CASEMANX
  1.  I BWPOP K BWCASEM,BWCASEMN Q
  1.  ;
  1.  N BWCOUNT S BWCOUNT=0
  1.  N BWIEN S BWIEN=0
  1.  F  S BWIEN=$O(^BWNOT(BWIEN)) Q:'BWIEN  D
  1.  .N BWDATE
  1.  .S BWDATE=$P(^BWNOT(BWIEN,0),U,11)
  1.  .Q:BWDATE<BWBEGDT  Q:BWDATE>(BWENDDT+.9999)
  1.  .;IHS/CIA/PLS - patch 9 - quit if status = ERROR
  1.  .Q:$P(^BWNOT(BWIEN,0),U,14)="e"
  1.  .I BWCASEM="O",BWCASEMN,$P(^BWP($P(^BWNOT(BWIEN,0),U),0),U,10)'=BWCASEMN Q
  1.  .S ^BWNOT("APRT",BWDATE,BWIEN)=""
  1.  .S BWCOUNT=BWCOUNT+1
  1.  ;
  1.  D
  1.  .I 'BWCOUNT D  Q
  1.  ..W !!?5,"No letters to re-queue for the selected date range."
  1.  .;
  1.  .W !!?5,BWCOUNT," letters re-queued for the selected date range."
  1.  .W !?5,"This may include letters that never printed the first time."
  1.  .W !?5,"In order to print these letters, you must run the"
  1.  .W !?5,"PQ  PRINT QUEUED LETTERS menu option."
  1.  ;
  1.  D DIRZ^BWUTL3
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. REPRINTX ;EP
  1.  ;;This option allows you to re-print letters for a date range.
  1.  ;;
  1.  ;;You will first be asked for a date range.  Any letter that has
  1.  ;;a Print Date that falls within the date range specified by you
  1.  ;;(first and last day inclusive) will be re-queued for printing.
  1.  ;;
  1.  ;;NOTE: This option does NOT actually print the letters; it merely
  1.  ;;re-queues them for printing.  In order to re-print the letters
  1.  ;;you must run the "PQ   PRINT QUEUED LETTERS" option.
  1.  ;;
  1.  N BWTAB,BWLINL
  1.  S BWTAB=5,BWLINL="REPRINTX" D PRINTX(BWTAB,BWLINL)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. CASEMANX ;
  1.  ;IHS/CMI/LAB - patch 6 added this subroutine
  1.  S BWPOP=0
  1.  S BWCASEM="",BWCASEMN=""
  1.  S DIR(0)="S^A:All Case Managers (Re-print ALL Letters);O:One Case Manager (Reprint Letters for ONE Case Manager)",DIR("A")="Reprint Letters for",DIR("B")="A" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S BWPOP=1 Q
  1.  S BWCASEM=Y
  1.  Q:BWCASEM="A"
  1.  K DIC,DA,DR,DD S DIC("A")="Which Case Manager:  ",DIC="^BWMGR(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DD,DR,DO
  1.  I Y=-1 G CASEMAN
  1.  S BWCASEMN=+Y
  1.  Q
  1. PRINTX(BWTAB,BWLINL) ;EP
  1.  ;---> Print text at specified line label.
  1.  ;
  1.  S:'$G(BWTAB) BWTAB=0
  1.  Q:$G(BWLINL)=""
  1.  N I,T,X S T="" F I=1:1:BWTAB S T=T_" "
  1.  F I=1:1 S X=$T(@BWLINL+I) Q:X'[";;"  W !,T,$P(X,";;",2)
  1.  Q