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

ADEPLBL1.m

Go to the documentation of this file. 
  1. ADEPLBL1 ; IHS/HQT/MJL  - MAILING LABELS PART 2 ;10:17 PM  [ 03/24/1999   9:04 AM ]
  1.  ;;6.0;ADE;;APRIL 1999
  1.  ;------->SELECT FILE
  1. INQ ;K Y,DIC,DUOUT,DTOUT S DIC="^DIC(",DIC(0)="AEQZ"
  1.  ;S DIC("S")="I +Y=9000001!($D(^DD(9000001,0,""PT"",+Y)))"
  1.  ;D ^DIC
  1.  ;I Y<1 S DUOUT=1 Q
  1.  S Y=9000001 ;Force file to PATIENT file
  1.  S ADEFN=+Y,ADEDIC=^DIC(ADEFN,0,"GL")
  1.  ;------->KILL ANY OLD MAILING LIST TEMPLATES FOR THIS FILE & USER
  1.  K Y,DIC S DIC="^DIBT(",DIC(0)="Z",X="ADE MAILING LIST"
  1.  S DIC("S")="I $P(^DIBT(Y,0),U,4)=ADEFN,$P(^DIBT(Y,0),U,5)=DUZ"
  1.  D ^DIC
  1.  I Y>0 D KTEM
  1.  ;------->SET UP TEMPLATE
  1.  K Y,DIC S DIC="^DIBT(",DIC(0)="QZ",X="ADE MAILING LIST"
  1.  K DD,DO D FILE^DICN
  1.  S ADETEM=+Y
  1.  S DR="2///NOW;4///"_ADEFN_";5///"_DUZ,DIE="^DIBT(",DA=ADETEM
  1.  D ^DIE
  1.  S ^DIBT(ADETEM,"DIS",0)="^"
  1.  ;------->GET FILE ENTRIES
  1. ENTRIES S ADECNT=0
  1. E1 K Y,DIC S DIC=ADEDIC,DIC(0)="AEQZ"
  1.  S DIC("A")="Select PATIENT NAME for Mailing Label: "
  1.  D ^DIC
  1.  I Y<1 S:'+ADECNT DUOUT=1 Q
  1.  S ^DIBT(ADETEM,1,+Y)="",ADECNT=ADECNT+1
  1.  G E1
  1. KTEM S DIK="^DIBT(",DA=+Y D ^DIK
  1.  Q