BRNMLB ; IHS/OIT/LJF - ROI MAILING LABELS
;;2.0;RELEASE OF INFO SYSTEM;*1*;APR 10, 2003
;IHS/OIT/LJF 01/24/2008 PATCH 1 Added routine; smae label spacing as Pat Reg
;
;
NEW IEN,IEN2,PARTY,NAME,DATE,METH,COUNT,N,BRNCOP,X,Y,ARRAY,BRNJOB
S BRNJOB=$J
K ^TMP("BRNMLB",BRNJOB)
;
; loop through and collect disclosures
S IEN=0 F S IEN=+$$READ^BRNU("PO^90264:AEMQZ","Select Disclosure") Q:IEN<1 D
. K PARTY S COUNT=0
. ;
. ; now find receiving parties for labels
. S IEN2=0 F S IEN2=$O(^BRNREC(IEN,23,IEN2)) Q:'IEN2 D
. . S NAME=$$GET1^DIQ(90264.023,IEN2_","_IEN,.01) ;receiving party name
. . S DATE=$$GET1^DIQ(90264.023,IEN2_","_IEN,.02) Q:DATE="" ;no label needed if no disclosure date
. . S METH=$$GET1^DIQ(90264.023,IEN2_","_IEN,.03) ;dissemination method
. . S COUNT=COUNT+1,PARTY(COUNT)=IEN2_U_NAME_U_DATE_U_METH
. ;
. I COUNT=0 W !?5,"No receiving party found for labels; Not added to list",! Q
. ;
. I COUNT=1 S ^TMP("BRNMLB",BRNJOB,IEN,$P(PARTY(1),U))=PARTY(1) W !?5,$P(PARTY(1),U,2)," added to list",! Q
. ;
. ; if more than one found, see if all need labels
. E K ARRAY D
. . S N=0 F S N=$O(PARTY(N)) Q:'N D
. . . S ARRAY(N)=$J(N,2)_": "_$$PAD($P(PARTY(N),U,2),30)_$$PAD($P(PARTY(N),U,3),20)_$P(PARTY(N),U,4)
. . S Y=$$READ^BRNU("L^1:"_COUNT_":0"," Select ALL Receiving Parties for Labels",,,,.ARRAY) I Y<1 Q
. . F S X=$P(Y,",") Q:X="" D
. . . S ^TMP("BRNMLB",BRNJOB,IEN,$P(PARTY(X),U))=PARTY(X)
. . . S Y=$P(Y,",",2,99)
;
; quit if none found or selected
I '$D(^TMP("BRNMLB",BRNJOB)) Q
;
; ask how many copies
S BRNCOP=$$READ^BRNU("N^1:5","How many COPIES of each label",1) Q:BRNCOP<1
;
;ask for device
W !!?15,"(NOTE: Mailing Labels need to be loaded in the printer.)"
D ZIS^BRNU("PQ","START^BRNMLB","ROI MAILING LABELS","BRNCOP;BRNJOB")
Q
;
START ;EP; entry from queuing; start of print process
U IO
NEW IEN,IEN2,NAME,X,STREET,CITY,DFN,COPY
;
; loop through temp global for receiving parties
S IEN=0 F S IEN=$O(^TMP("BRNMLB",BRNJOB,IEN)) Q:'IEN D
. S IEN2=0 F S IEN2=$O(^TMP("BRNMLB",BRNJOB,IEN,IEN2)) Q:'IEN2 D
. . S NAME=$P(^TMP("BRNMLB",BRNJOB,IEN,IEN2),U,2)
. . ;
. . ; if party'=PATIENT then find address in ROI REQ PARTY file
. . I NAME'="PATIENT" D Q
. . . S X=+$G(^BRNREC(IEN,23,IEN2,0)) Q:'X
. . . S STREET=$$GET1^DIQ(90264.1,X,.03)
. . . S CITY=$$GET1^DIQ(90264.1,X,.04)_", "_$$GET1^DIQ(90264.1,X,.05)_" "_$$GET1^DIQ(90264.1,X,.06)
. . . F COPY=1:1:BRNCOP W NAME,!,STREET,!,CITY,!!!!
. . ;
. . ; for PATIENT, reset printable name
. . S DFN=$$GET1^DIQ(90264,IEN,.03,"I") Q:'DFN
. . S NAME=$$NAMEPRT^BRNU(DFN)
. . ;
. . ; for PATIENT, look for mailing address in ROI file
. . S STREET=$$GET1^DIQ(90264,IEN,2801) I STREET]"" D Q
. . . S CITY=$$GET1^DIQ(90264,IEN,2802)_", "_$$GET1^DIQ(90264,IEN,2803)_" "_$$GET1^DIQ(90264,IEN,2804)
. . . F COPY=1:1:BRNCOP W NAME,!,STREET,!,CITY,!!!!
. . ;
. . ; else look in Patient Registration
. . S STREET=$$GET1^DIQ(9000001,DFN,1602.2)
. . S CITY=$$GET1^DIQ(9000001,DFN,1603.2)_", "_$$GET1^DIQ(9000001,DFN,1604.2)_" "_$$GET1^DIQ(9000001,DFN,1605.2)
. . F COPY=1:1:BRNCOP W NAME,!,STREET,!,CITY,!!!!
;
;close device
D ^%ZISC
K ^TMP("BRNMLB",BRNJOB)
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ;EP -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
BRNMLB ; IHS/OIT/LJF - ROI MAILING LABELS
+1 ;;2.0;RELEASE OF INFO SYSTEM;*1*;APR 10, 2003
+2 ;IHS/OIT/LJF 01/24/2008 PATCH 1 Added routine; smae label spacing as Pat Reg
+3 ;
+4 ;
+5 NEW IEN,IEN2,PARTY,NAME,DATE,METH,COUNT,N,BRNCOP,X,Y,ARRAY,BRNJOB
+6 SET BRNJOB=$JOB
+7 KILL ^TMP("BRNMLB",BRNJOB)
+8 ;
+9 ; loop through and collect disclosures
+10 SET IEN=0
FOR
SET IEN=+$$READ^BRNU("PO^90264:AEMQZ","Select Disclosure")
IF IEN<1
QUIT
Begin DoDot:1
+11 KILL PARTY
SET COUNT=0
+12 ;
+13 ; now find receiving parties for labels
+14 SET IEN2=0
FOR
SET IEN2=$ORDER(^BRNREC(IEN,23,IEN2))
IF 'IEN2
QUIT
Begin DoDot:2
+15 ;receiving party name
SET NAME=$$GET1^DIQ(90264.023,IEN2_","_IEN,.01)
+16 ;no label needed if no disclosure date
SET DATE=$$GET1^DIQ(90264.023,IEN2_","_IEN,.02)
IF DATE=""
QUIT
+17 ;dissemination method
SET METH=$$GET1^DIQ(90264.023,IEN2_","_IEN,.03)
+18 SET COUNT=COUNT+1
SET PARTY(COUNT)=IEN2_U_NAME_U_DATE_U_METH
End DoDot:2
+19 ;
+20 IF COUNT=0
WRITE !?5,"No receiving party found for labels; Not added to list",!
QUIT
+21 ;
+22 IF COUNT=1
SET ^TMP("BRNMLB",BRNJOB,IEN,$PIECE(PARTY(1),U))=PARTY(1)
WRITE !?5,$PIECE(PARTY(1),U,2)," added to list",!
QUIT
+23 ;
+24 ; if more than one found, see if all need labels
+25 IF '$TEST
KILL ARRAY
Begin DoDot:2
+26 SET N=0
FOR
SET N=$ORDER(PARTY(N))
IF 'N
QUIT
Begin DoDot:3
+27 SET ARRAY(N)=$JUSTIFY(N,2)_": "_$$PAD($PIECE(PARTY(N),U,2),30)_$$PAD($PIECE(PARTY(N),U,3),20)_$PIECE(PARTY(N),U,4)
End DoDot:3
+28 SET Y=$$READ^BRNU("L^1:"_COUNT_":0"," Select ALL Receiving Parties for Labels",,,,.ARRAY)
IF Y<1
QUIT
+29 FOR
SET X=$PIECE(Y,",")
IF X=""
QUIT
Begin DoDot:3
+30 SET ^TMP("BRNMLB",BRNJOB,IEN,$PIECE(PARTY(X),U))=PARTY(X)
+31 SET Y=$PIECE(Y,",",2,99)
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 ; quit if none found or selected
+34 IF '$DATA(^TMP("BRNMLB",BRNJOB))
QUIT
+35 ;
+36 ; ask how many copies
+37 SET BRNCOP=$$READ^BRNU("N^1:5","How many COPIES of each label",1)
IF BRNCOP<1
QUIT
+38 ;
+39 ;ask for device
+40 WRITE !!?15,"(NOTE: Mailing Labels need to be loaded in the printer.)"
+41 DO ZIS^BRNU("PQ","START^BRNMLB","ROI MAILING LABELS","BRNCOP;BRNJOB")
+42 QUIT
+43 ;
START ;EP; entry from queuing; start of print process
+1 USE IO
+2 NEW IEN,IEN2,NAME,X,STREET,CITY,DFN,COPY
+3 ;
+4 ; loop through temp global for receiving parties
+5 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("BRNMLB",BRNJOB,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+6 SET IEN2=0
FOR
SET IEN2=$ORDER(^TMP("BRNMLB",BRNJOB,IEN,IEN2))
IF 'IEN2
QUIT
Begin DoDot:2
+7 SET NAME=$PIECE(^TMP("BRNMLB",BRNJOB,IEN,IEN2),U,2)
+8 ;
+9 ; if party'=PATIENT then find address in ROI REQ PARTY file
+10 IF NAME'="PATIENT"
Begin DoDot:3
+11 SET X=+$GET(^BRNREC(IEN,23,IEN2,0))
IF 'X
QUIT
+12 SET STREET=$$GET1^DIQ(90264.1,X,.03)
+13 SET CITY=$$GET1^DIQ(90264.1,X,.04)_", "_$$GET1^DIQ(90264.1,X,.05)_" "_$$GET1^DIQ(90264.1,X,.06)
+14 FOR COPY=1:1:BRNCOP
WRITE NAME,!,STREET,!,CITY,!!!!
End DoDot:3
QUIT
+15 ;
+16 ; for PATIENT, reset printable name
+17 SET DFN=$$GET1^DIQ(90264,IEN,.03,"I")
IF 'DFN
QUIT
+18 SET NAME=$$NAMEPRT^BRNU(DFN)
+19 ;
+20 ; for PATIENT, look for mailing address in ROI file
+21 SET STREET=$$GET1^DIQ(90264,IEN,2801)
IF STREET]""
Begin DoDot:3
+22 SET CITY=$$GET1^DIQ(90264,IEN,2802)_", "_$$GET1^DIQ(90264,IEN,2803)_" "_$$GET1^DIQ(90264,IEN,2804)
+23 FOR COPY=1:1:BRNCOP
WRITE NAME,!,STREET,!,CITY,!!!!
End DoDot:3
QUIT
+24 ;
+25 ; else look in Patient Registration
+26 SET STREET=$$GET1^DIQ(9000001,DFN,1602.2)
+27 SET CITY=$$GET1^DIQ(9000001,DFN,1603.2)_", "_$$GET1^DIQ(9000001,DFN,1604.2)_" "_$$GET1^DIQ(9000001,DFN,1605.2)
+28 FOR COPY=1:1:BRNCOP
WRITE NAME,!,STREET,!,CITY,!!!!
End DoDot:2
End DoDot:1
+29 ;
+30 ;close device
+31 DO ^%ZISC
+32 KILL ^TMP("BRNMLB",BRNJOB)
+33 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ;EP -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
