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