ADEPLBL1.m

ADEPLBL1 ; IHS/HQT/MJL  - MAILING LABELS PART 2 ;10:17 PM  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

 ;------->SELECT FILE

INQ ;K Y,DIC,DUOUT,DTOUT S DIC="^DIC(",DIC(0)="AEQZ"

 ;S DIC("S")="I +Y=9000001!($D(^DD(9000001,0,""PT"",+Y)))"

 ;D ^DIC

 ;I Y<1 S DUOUT=1 Q

 S Y=9000001 ;Force file to PATIENT file

 S ADEFN=+Y,ADEDIC=^DIC(ADEFN,0,"GL")

 ;------->KILL ANY OLD MAILING LIST TEMPLATES FOR THIS FILE & USER

 K Y,DIC S DIC="^DIBT(",DIC(0)="Z",X="ADE MAILING LIST"

 S DIC("S")="I $P(^DIBT(Y,0),U,4)=ADEFN,$P(^DIBT(Y,0),U,5)=DUZ"

 D ^DIC

 I Y>0 D KTEM

 ;------->SET UP TEMPLATE

 K Y,DIC S DIC="^DIBT(",DIC(0)="QZ",X="ADE MAILING LIST"

 K DD,DO D FILE^DICN

 S ADETEM=+Y

 S DR="2///NOW;4///"_ADEFN_";5///"_DUZ,DIE="^DIBT(",DA=ADETEM

 D ^DIE

 S ^DIBT(ADETEM,"DIS",0)="^"

 ;------->GET FILE ENTRIES

ENTRIES S ADECNT=0

E1 K Y,DIC S DIC=ADEDIC,DIC(0)="AEQZ"

 S DIC("A")="Select PATIENT NAME for Mailing Label: "

 D ^DIC

 I Y<1 S:'+ADECNT DUOUT=1 Q

 S ^DIBT(ADETEM,1,+Y)="",ADECNT=ADECNT+1

 G E1

KTEM S DIK="^DIBT(",DA=+Y D ^DIK

 Q

ADEPLBL1  ; IHS/HQT/MJL  - MAILING LABELS PART 2 ;10:17 PM  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

 +2       ;------->SELECT FILE

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)))"

 +2       ;D ^DIC

 +3       ;I Y<1 S DUOUT=1 Q

 +4       ;Force file to PATIENT file

           SET Y=9000001

 +5        SET ADEFN=+Y

           SET ADEDIC=^DIC(ADEFN,0,"GL")

 +6       ;------->KILL ANY OLD MAILING LIST TEMPLATES FOR THIS FILE & USER

 +7        KILL Y,DIC

           SET DIC="^DIBT("

           SET DIC(0)="Z"

           SET X="ADE MAILING LIST"

 +8        SET DIC("S")="I $P(^DIBT(Y,0),U,4)=ADEFN,$P(^DIBT(Y,0),U,5)=DUZ"

 +9        DO ^DIC

 +10       IF Y>0

               DO KTEM

 +11      ;------->SET UP TEMPLATE

 +12       KILL Y,DIC

           SET DIC="^DIBT("

           SET DIC(0)="QZ"

           SET X="ADE MAILING LIST"

 +13       KILL DD,DO

           DO FILE^DICN

 +14       SET ADETEM=+Y

 +15       SET DR="2///NOW;4///"_ADEFN_";5///"_DUZ

           SET DIE="^DIBT("

           SET DA=ADETEM

 +16       DO ^DIE

 +17       SET ^DIBT(ADETEM,"DIS",0)="^"

 +18      ;------->GET FILE ENTRIES

ENTRIES    SET ADECNT=0

E1         KILL Y,DIC

           SET DIC=ADEDIC

           SET DIC(0)="AEQZ"

 +1        SET DIC("A")="Select PATIENT NAME for Mailing Label: "

 +2        DO ^DIC

 +3        IF Y<1

               IF '+ADECNT

                   SET DUOUT=1

               QUIT 

 +4        SET ^DIBT(ADETEM,1,+Y)=""

           SET ADECNT=ADECNT+1

 +5        GOTO E1

KTEM       SET DIK="^DIBT("

           SET DA=+Y

           DO ^DIK

 +1        QUIT