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

BRNMLB.m

Go to the documentation of this file. 
  1. BRNMLB ; IHS/OIT/LJF - ROI MAILING LABELS  
  1.  ;;2.0;RELEASE OF INFO SYSTEM;*1*;APR 10, 2003
  1.  ;IHS/OIT/LJF 01/24/2008 PATCH 1 Added routine; smae label spacing as Pat Reg
  1.  ;
  1.  ;
  1.  NEW IEN,IEN2,PARTY,NAME,DATE,METH,COUNT,N,BRNCOP,X,Y,ARRAY,BRNJOB
  1.  S BRNJOB=$J
  1.  K ^TMP("BRNMLB",BRNJOB)
  1.  ;
  1.  ; loop through and collect disclosures
  1.  S IEN=0 F  S IEN=+$$READ^BRNU("PO^90264:AEMQZ","Select Disclosure") Q:IEN<1  D
  1.  . K PARTY S COUNT=0
  1.  . ;
  1.  . ; now find receiving parties for labels
  1.  . S IEN2=0 F  S IEN2=$O(^BRNREC(IEN,23,IEN2)) Q:'IEN2  D
  1.  . . S NAME=$$GET1^DIQ(90264.023,IEN2_","_IEN,.01)            ;receiving party name
  1.  . . S DATE=$$GET1^DIQ(90264.023,IEN2_","_IEN,.02) Q:DATE=""  ;no label needed if no disclosure date
  1.  . . S METH=$$GET1^DIQ(90264.023,IEN2_","_IEN,.03)            ;dissemination method
  1.  . . S COUNT=COUNT+1,PARTY(COUNT)=IEN2_U_NAME_U_DATE_U_METH
  1.  . ;
  1.  . I COUNT=0 W !?5,"No receiving party found for labels; Not added to list",! Q
  1.  . ;
  1.  . 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
  1.  . ;
  1.  . ;   if more than one found, see if all need labels
  1.  . E  K ARRAY D
  1.  . . S N=0 F  S N=$O(PARTY(N)) Q:'N  D
  1.  . . . 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)
  1.  . . S Y=$$READ^BRNU("L^1:"_COUNT_":0"," Select ALL Receiving Parties for Labels",,,,.ARRAY) I Y<1 Q
  1.  . . F  S X=$P(Y,",") Q:X=""  D
  1.  . . . S ^TMP("BRNMLB",BRNJOB,IEN,$P(PARTY(X),U))=PARTY(X)
  1.  . . . S Y=$P(Y,",",2,99)
  1.  ;
  1.  ; quit if none found or selected
  1.  I '$D(^TMP("BRNMLB",BRNJOB)) Q
  1.  ;
  1.  ; ask how many copies
  1.  S BRNCOP=$$READ^BRNU("N^1:5","How many COPIES of each label",1) Q:BRNCOP<1
  1.  ;
  1.  ;ask for device
  1.  W !!?15,"(NOTE: Mailing Labels need to be loaded in the printer.)"
  1.  D ZIS^BRNU("PQ","START^BRNMLB","ROI MAILING LABELS","BRNCOP;BRNJOB")
  1.  Q
  1.  ;
  1. START ;EP; entry from queuing; start of print process
  1.  U IO
  1.  NEW IEN,IEN2,NAME,X,STREET,CITY,DFN,COPY
  1.  ;
  1.  ; loop through temp global for receiving parties
  1.  S IEN=0 F  S IEN=$O(^TMP("BRNMLB",BRNJOB,IEN)) Q:'IEN  D
  1.  . S IEN2=0 F  S IEN2=$O(^TMP("BRNMLB",BRNJOB,IEN,IEN2)) Q:'IEN2  D
  1.  . . S NAME=$P(^TMP("BRNMLB",BRNJOB,IEN,IEN2),U,2)
  1.  . . ;
  1.  . . ; if party'=PATIENT then find address in ROI REQ PARTY file
  1.  . . I NAME'="PATIENT" D  Q
  1.  . . . S X=+$G(^BRNREC(IEN,23,IEN2,0)) Q:'X
  1.  . . . S STREET=$$GET1^DIQ(90264.1,X,.03)
  1.  . . . S CITY=$$GET1^DIQ(90264.1,X,.04)_", "_$$GET1^DIQ(90264.1,X,.05)_"  "_$$GET1^DIQ(90264.1,X,.06)
  1.  . . . F COPY=1:1:BRNCOP W NAME,!,STREET,!,CITY,!!!!
  1.  . . ;
  1.  . . ; for PATIENT, reset printable name
  1.  . . S DFN=$$GET1^DIQ(90264,IEN,.03,"I") Q:'DFN
  1.  . . S NAME=$$NAMEPRT^BRNU(DFN)
  1.  . . ;
  1.  . . ; for PATIENT, look for mailing address in ROI file
  1.  . . S STREET=$$GET1^DIQ(90264,IEN,2801) I STREET]"" D  Q
  1.  . . . S CITY=$$GET1^DIQ(90264,IEN,2802)_", "_$$GET1^DIQ(90264,IEN,2803)_"  "_$$GET1^DIQ(90264,IEN,2804)
  1.  . . . F COPY=1:1:BRNCOP W NAME,!,STREET,!,CITY,!!!!
  1.  . . ;
  1.  . . ; else look in Patient Registration
  1.  . . S STREET=$$GET1^DIQ(9000001,DFN,1602.2)
  1.  . . S CITY=$$GET1^DIQ(9000001,DFN,1603.2)_", "_$$GET1^DIQ(9000001,DFN,1604.2)_"  "_$$GET1^DIQ(9000001,DFN,1605.2)
  1.  . . F COPY=1:1:BRNCOP W NAME,!,STREET,!,CITY,!!!!
  1.  ;
  1.  ;close device
  1.  D ^%ZISC
  1.  K ^TMP("BRNMLB",BRNJOB)
  1.  ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ;EP -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)