ADEPLBL.m

ADEPLBL ; IHS/HQT/MJL  - PRINT MAILING LABELS FROM SORT TEMPLATE ;07:21 PM  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

TEMP ;EP

 ;------->ENTER HERE TO SELECT SEARCH TEMPLATE

 K DUOUT,DTOUT,POP D TEMPL G:Y<1 END G START

FILE ;EP

 ;------->ENTER HERE TO SELECT SPECIFIC PATIENT NAMES

 D ^ADEPLBL1 I $D(DUOUT)!($D(DTOUT)) G END

START ;------->GET POINTER FILE INFO

 D POINT

 ;------->GET LABEL SIZE

 D SIZE

 I $D(DUOUT)!($D(DTOUT)) G END

 ;------->TEST LABEL

 D TLAB

 I $D(POP),POP G END

 I $D(DUOUT)!($D(DTOUT)) G END

 ;------->SELECT DEVICE

 D DEV

 G:POP END

 I $D(IO("Q")) K IO("Q") G END

 I $D(DUOUT)!($D(DTOUT)) G END

ZTM ;EP

 ;------->PRINT LABELS (TASKMAN ENTRY)

 D PRINT

 ;------->END

END K ADEAD1,ADEAD2,ADECNT,ADEDFN,ADEDIC,ADEFLD,ADEFN,ADEGL,ADEIOP,ADEJ,ADENAM,ADEPN,ADESIZ,ADETEM,ADEX,ADEY,^ADEUTL("ADEPLBL",$J)

 ;^ADEUTL("ADEPLBL", is a transient working global

 K ADELKPRN,ADELKDAT,Y,DIC,DIR,DR,DUOUT,DTOUT,ADELKERR

 D ^%ZISC

 I $D(ZTQUEUED) S ZTREQ="@"

 Q

 ;

SIZE S:$D(^ADEUTL("ADEPLBL","SIZE")) ADESIZ=^ADEUTL("ADEPLBL","SIZE")

 S:'$D(ADESIZ) ADESIZ=9

 S DIR(0)="NA^4:20:0"

 S DIR("A")="Enter Number of Lines on Blank Mailing Label: "

 S DIR("B")=ADESIZ

 S DIR("?")="Enter the size (in horizontal lines) of the mailing label"

 D ^DIR

 I $D(DTOUT)!($D(DUOUT)) Q

 S ADESIZ=X

 S ^ADEUTL("ADEPLBL","SIZE")=ADESIZ ;^ADEUTL("ADEPLBL" is transient

 Q

TEMPL K Y,DIC S DIC="^DIBT(",DIC(0)="AEQZ"

 S DIC("S")="D SCRN^ADEPLBL"

 D ^DIC

 Q:Y<1

 S ADETEM=+Y,ADEFN=$P(Y(0),U,4)

 Q

POINT I ADEFN=9000001 S ADEFLD=".01",ADEPN="0;1",ADEGL="^AUPNPAT(" Q

 S ADEFLD=$O(^DD(9000001,0,"PT",ADEFN,0))

 S ADEPN=$P(^DD(ADEFN,ADEFLD,0),U,4)

 S ADEGL=^DIC(ADEFN,0,"GL")

 Q

DEV K POP

 W !!,"Ready to print mailing labels for patient names stored in the "

 W !,$P(^DIBT(ADETEM,0),U)," Search Template"

 I $D(^DD(ADEFN,0,"NM")),$O(^DD(ADEFN,0,"NM",0))]"" W " of the ",$O(^DD(ADEFN,0,"NM",0))," File.",!

 E  W ".",!

 W "Make sure labels are lined up on printer.",!

 S %ZIS="PQ" D ^%ZIS

 I $D(DUOUT)!($D(DTOUT)) W !,?5,"--Try Later" Q

 I $D(IO("Q"))&(($D(IO("S")))!($E(IOST)'="P")) W *7,!,"Please queue to system printers." K IO("Q") D ^%ZISC G DEV

 I $D(IO("Q")) D QUE

 Q

QUE X ^%ZOSF("UCI") S ZTRTN="ZTM^ADEPLBL",ZTUCI=Y,ZTDESC="Print Mailing Labels"

 F ADEX="ADETEM","ADEFLD","ADEPN","ADEGL","ADESIZ" S ZTSAVE(ADEX)=""

 D ^%ZTLOAD

 K ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZTUCI

 Q

PRINT U IO

 K ^ADEUTL("ADEPLBL",$J)

 S ADEX=0

 F ADEY=0:0 S ADEX=$O(^DIBT(ADETEM,1,ADEX)) Q:'+ADEX  D P2

 Q

P2 S ADEDFN=ADEGL_ADEX_","_+ADEPN_")"

 S ADEDFN=$P(@ADEDFN,U,$P(ADEPN,";",2))

 Q:'$D(^DPT(ADEDFN,0))

 Q:$D(^ADEUTL("ADEPLBL",$J,ADEDFN))

 S ^ADEUTL("ADEPLBL",$J,ADEDFN)=""

 S (ADENAM,ADEAD1,ADEAD2)=""

 S DA=ADEDFN,DIC=2

 S DR=.01 K ADELKPRN D ^ADEDCLK S:$D(ADELKPRN) ADENAM=$P(ADELKPRN,",",2)_" "_$P(ADELKPRN,",") ;IHS/HMW **2**

 S DR=.111 K ADELKPRN D ^ADEDCLK S:$D(ADELKPRN) ADEAD1=ADELKPRN

 S DR=.114 K ADELKPRN D ^ADEDCLK S:$D(ADELKPRN) ADEAD2=ADELKPRN

 S DR=.115 K ADELKDAT D ^ADEDCLK I $D(ADELKDAT),ADELKDAT]"" S ADEAD2=ADEAD2_", "_$P(^DIC(5,ADELKDAT,0),U,2) ;IHS/HMW **2**

 S DR=.116 K ADELKPRN D ^ADEDCLK S:$D(ADELKPRN) ADEAD2=ADEAD2_"  "_ADELKPRN

 W ADENAM,!,ADEAD1,!,ADEAD2,!

 F ADEJ=4:1:ADESIZ W ! ;W "LINE ",ADEJ,":",!

 Q

SCRN ;EP

 ;SCREEN FOR USER SEARCH TEMPLATES ON FILES WITH POINTER TO PATIENT FILE

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

 E  Q

 I $P(^DIBT(Y,0),U,5)=DUZ

 E  Q

 I $D(^DIBT(Y,1))

 E  Q

 I ADEFN=9000001!($D(^DD(9000001,0,"PT",ADEFN)))

 Q

TLAB K DUOUT,DTOUT

 W !!,"Do you want to print a test label"

TL1 S %=1 D YN^DICN

 G:%=1 TL2

 I %Y["?" W !?5,"Answer Yes or No" G TLAB

 I %Y[U S DUOUT=1

 Q

TL2 W !,"Line up labels on printer and select Device",!

 K POP S %ZIS="P" D ^%ZIS Q:POP  Q:$D(DUOUT)!($D(DTOUT))

 U IO

 W "LINE 1: NAME",!,"LINE 2: STREET ADDRESS",!,"LINE 3: CITY, STATE  ZIP",!

 F ADEJ=4:1:ADESIZ W "LINE ",ADEJ,":",!

 D ^%ZISC ;equivalent of a CR here

TL3 W !!,"Print another test label"

 S %=1 D YN^DICN

 I %=1 D SIZE Q:$D(DUOUT)!($D(DTOUT))  G TL2

 I %Y["?" W !?5,"Answer Yes or NO" G TL3

 I %Y[U S DUOUT=1 Q

 Q

ADEPLBL   ; IHS/HQT/MJL  - PRINT MAILING LABELS FROM SORT TEMPLATE ;07:21 PM  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

TEMP      ;EP

 +1       ;------->ENTER HERE TO SELECT SEARCH TEMPLATE

 +2        KILL DUOUT,DTOUT,POP

           DO TEMPL

           IF Y<1

               GOTO END

           GOTO START

FILE      ;EP

 +1       ;------->ENTER HERE TO SELECT SPECIFIC PATIENT NAMES

 +2        DO ^ADEPLBL1

           IF $DATA(DUOUT)!($DATA(DTOUT))

               GOTO END

START     ;------->GET POINTER FILE INFO

 +1        DO POINT

 +2       ;------->GET LABEL SIZE

 +3        DO SIZE

 +4        IF $DATA(DUOUT)!($DATA(DTOUT))

               GOTO END

 +5       ;------->TEST LABEL

 +6        DO TLAB

 +7        IF $DATA(POP)

               IF POP

                   GOTO END

 +8        IF $DATA(DUOUT)!($DATA(DTOUT))

               GOTO END

 +9       ;------->SELECT DEVICE

 +10       DO DEV

 +11       IF POP

               GOTO END

 +12       IF $DATA(IO("Q"))

               KILL IO("Q")

               GOTO END

 +13       IF $DATA(DUOUT)!($DATA(DTOUT))

               GOTO END

ZTM       ;EP

 +1       ;------->PRINT LABELS (TASKMAN ENTRY)

 +2        DO PRINT

 +3       ;------->END

END        KILL ADEAD1,ADEAD2,ADECNT,ADEDFN,ADEDIC,ADEFLD,ADEFN,ADEGL,ADEIOP,ADEJ,ADENAM,ADEPN,ADESIZ,ADETEM,ADEX,ADEY,^ADEUTL("ADEPLBL",$JOB)

 +1       ;^ADEUTL("ADEPLBL", is a transient working global

 +2        KILL ADELKPRN,ADELKDAT,Y,DIC,DIR,DR,DUOUT,DTOUT,ADELKERR

 +3        DO ^%ZISC

 +4        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +5        QUIT 

 +6       ;

SIZE       IF $DATA(^ADEUTL("ADEPLBL","SIZE"))

               SET ADESIZ=^ADEUTL("ADEPLBL","SIZE")

 +1        IF '$DATA(ADESIZ)

               SET ADESIZ=9

 +2        SET DIR(0)="NA^4:20:0"

 +3        SET DIR("A")="Enter Number of Lines on Blank Mailing Label: "

 +4        SET DIR("B")=ADESIZ

 +5        SET DIR("?")="Enter the size (in horizontal lines) of the mailing label"

 +6        DO ^DIR

 +7        IF $DATA(DTOUT)!($DATA(DUOUT))

               QUIT 

 +8        SET ADESIZ=X

 +9       ;^ADEUTL("ADEPLBL" is transient

           SET ^ADEUTL("ADEPLBL","SIZE")=ADESIZ

 +10       QUIT 

TEMPL      KILL Y,DIC

           SET DIC="^DIBT("

           SET DIC(0)="AEQZ"

 +1        SET DIC("S")="D SCRN^ADEPLBL"

 +2        DO ^DIC

 +3        IF Y<1

               QUIT 

 +4        SET ADETEM=+Y

           SET ADEFN=$PIECE(Y(0),U,4)

 +5        QUIT 

POINT      IF ADEFN=9000001

               SET ADEFLD=".01"

               SET ADEPN="0;1"

               SET ADEGL="^AUPNPAT("

               QUIT 

 +1        SET ADEFLD=$ORDER(^DD(9000001,0,"PT",ADEFN,0))

 +2        SET ADEPN=$PIECE(^DD(ADEFN,ADEFLD,0),U,4)

 +3        SET ADEGL=^DIC(ADEFN,0,"GL")

 +4        QUIT 

DEV        KILL POP

 +1        WRITE !!,"Ready to print mailing labels for patient names stored in the "

 +2        WRITE !,$PIECE(^DIBT(ADETEM,0),U)," Search Template"

 +3        IF $DATA(^DD(ADEFN,0,"NM"))

               IF $ORDER(^DD(ADEFN,0,"NM",0))]""

                   WRITE " of the ",$ORDER(^DD(ADEFN,0,"NM",0))," File.",!

 +4       IF '$TEST

               WRITE ".",!

 +5        WRITE "Make sure labels are lined up on printer.",!

 +6        SET %ZIS="PQ"

           DO ^%ZIS

 +7        IF $DATA(DUOUT)!($DATA(DTOUT))

               WRITE !,?5,"--Try Later"

               QUIT 

 +8        IF $DATA(IO("Q"))&(($DATA(IO("S")))!($EXTRACT(IOST)'="P"))

               WRITE *7,!,"Please queue to system printers."

               KILL IO("Q")

               DO ^%ZISC

               GOTO DEV

 +9        IF $DATA(IO("Q"))

               DO QUE

 +10       QUIT 

QUE        XECUTE ^%ZOSF("UCI")

           SET ZTRTN="ZTM^ADEPLBL"

           SET ZTUCI=Y

           SET ZTDESC="Print Mailing Labels"

 +1        FOR ADEX="ADETEM","ADEFLD","ADEPN","ADEGL","ADESIZ"

               SET ZTSAVE(ADEX)=""

 +2        DO ^%ZTLOAD

 +3        KILL ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZTUCI

 +4        QUIT 

PRINT      USE IO

 +1        KILL ^ADEUTL("ADEPLBL",$JOB)

 +2        SET ADEX=0

 +3        FOR ADEY=0:0

               SET ADEX=$ORDER(^DIBT(ADETEM,1,ADEX))

               IF '+ADEX

                   QUIT 

               DO P2

 +4        QUIT 

P2         SET ADEDFN=ADEGL_ADEX_","_+ADEPN_")"

 +1        SET ADEDFN=$PIECE(@ADEDFN,U,$PIECE(ADEPN,";",2))

 +2        IF '$DATA(^DPT(ADEDFN,0))

               QUIT 

 +3        IF $DATA(^ADEUTL("ADEPLBL",$JOB,ADEDFN))

               QUIT 

 +4        SET ^ADEUTL("ADEPLBL",$JOB,ADEDFN)=""

 +5        SET (ADENAM,ADEAD1,ADEAD2)=""

 +6        SET DA=ADEDFN

           SET DIC=2

 +7       ;IHS/HMW **2**

           SET DR=.01

           KILL ADELKPRN

           DO ^ADEDCLK

           IF $DATA(ADELKPRN)

               SET ADENAM=$PIECE(ADELKPRN,",",2)_" "_$PIECE(ADELKPRN,",")

 +8        SET DR=.111

           KILL ADELKPRN

           DO ^ADEDCLK

           IF $DATA(ADELKPRN)

               SET ADEAD1=ADELKPRN

 +9        SET DR=.114

           KILL ADELKPRN

           DO ^ADEDCLK

           IF $DATA(ADELKPRN)

               SET ADEAD2=ADELKPRN

 +10      ;IHS/HMW **2**

           SET DR=.115

           KILL ADELKDAT

           DO ^ADEDCLK

           IF $DATA(ADELKDAT)

               IF ADELKDAT]""

                   SET ADEAD2=ADEAD2_", "_$PIECE(^DIC(5,ADELKDAT,0),U,2)

 +11       SET DR=.116

           KILL ADELKPRN

           DO ^ADEDCLK

           IF $DATA(ADELKPRN)

               SET ADEAD2=ADEAD2_"  "_ADELKPRN

 +12       WRITE ADENAM,!,ADEAD1,!,ADEAD2,!

 +13      ;W "LINE ",ADEJ,":",!

           FOR ADEJ=4:1:ADESIZ

               WRITE !

 +14       QUIT 

SCRN      ;EP

 +1       ;SCREEN FOR USER SEARCH TEMPLATES ON FILES WITH POINTER TO PATIENT FILE

 +2        IF $PIECE(^DIBT(Y,0),U,4)]""

               SET ADEFN=$PIECE(^DIBT(Y,0),U,4)

 +3       IF '$TEST

               QUIT 

 +4        IF $PIECE(^DIBT(Y,0),U,5)=DUZ

 +5       IF '$TEST

               QUIT 

 +6        IF $DATA(^DIBT(Y,1))

 +7       IF '$TEST

               QUIT 

 +8        IF ADEFN=9000001!($DATA(^DD(9000001,0,"PT",ADEFN)))

 +9        QUIT 

TLAB       KILL DUOUT,DTOUT

 +1        WRITE !!,"Do you want to print a test label"

TL1        SET %=1

           DO YN^DICN

 +1        IF %=1

               GOTO TL2

 +2        IF %Y["?"

               WRITE !?5,"Answer Yes or No"

               GOTO TLAB

 +3        IF %Y[U

               SET DUOUT=1

 +4        QUIT 

TL2        WRITE !,"Line up labels on printer and select Device",!

 +1        KILL POP

           SET %ZIS="P"

           DO ^%ZIS

           IF POP

               QUIT 

           IF $DATA(DUOUT)!($DATA(DTOUT))

               QUIT 

 +2        USE IO

 +3        WRITE "LINE 1: NAME",!,"LINE 2: STREET ADDRESS",!,"LINE 3: CITY, STATE  ZIP",!

 +4        FOR ADEJ=4:1:ADESIZ

               WRITE "LINE ",ADEJ,":",!

 +5       ;equivalent of a CR here

           DO ^%ZISC

TL3        WRITE !!,"Print another test label"

 +1        SET %=1

           DO YN^DICN

 +2        IF %=1

               DO SIZE

               IF $DATA(DUOUT)!($DATA(DTOUT))

                   QUIT 

               GOTO TL2

 +3        IF %Y["?"

               WRITE !?5,"Answer Yes or NO"

               GOTO TL3

 +4        IF %Y[U

               SET DUOUT=1

               QUIT 

 +5        QUIT