Routine: AMQQRML

AMQQRML ; IHS/CMI/THL - MAILING LABEL GENERATOR ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;-----

VAR K AMQQQUIT,AMQQLJB

RUN D EXIT

 F AMQQL("RUN")=1:1 S %=$P("FORMAT^TEST^SET",U,AMQQL("RUN")) Q:%=""  D @% Q:$D(AMQQQUIT)

EXIT K AMQQLHO,AMQQLLM,AMQQLTF,AMQQLLC,AMQQLLN,AMQQLCF,AMQQL,AMQQLDA,I,%

FORMAT W @IOF,!!,?15,"*****  ADDRESS LABEL UTILITY  *****",!!

 S DA(1)=DUZ(2)

 S X=$O(^AMQQ(8,DA(1),2,0))

 I X S X=+$G(^AMQQ(8,DA(1),2,X,0)) S:X X=$P($G(^%ZIS(1,X,0)),U)

 S DIC="^AMQQ(8,"_DA(1)_",2,"

 S DIC(0)="AEMQZ"

 S DIC("A")="Select LABEL PRINTING DEVICE: "

 S:X]"" DIC("B")=X

 D ^DIC

 I +Y<1 S AMQQQUIT="" Q

 K AMQQQUIT

 S (DA,AMQQLLP)=+Y

 S DA(1)=DUZ(2)

 S:'$D(^AMQQ(8,DA(1),2)) ^(2,0)="^9009078.02P^^"

 S DIE="^AMQQ(8,"_DA(1)_",2,"

 S DR=".06;.02;.03;.04;.05"

 D ^DIE

 S AMQQLTOP=$P($G(^AMQQ(8,DA(1),2,DA,0)),U,6)

 K DIE,DA,DR,DIC,D,D0,DI,DQ,D1

 I $D(DUOUT)!($D(DTOUT))!('$G(AMQQLLP)) S AMQQRERF="" D OUT Q

 S %=+$G(^AMQQ(8,DUZ(2),2,AMQQLLP,0))

 I '% D OUT Q

 I $G(^%ZIS(1,%,0))="" D OUT Q

 S AMQQLDA=AMQQLLP

 S AMQQLLP=%

 W !!

TEST W "Want to do a test print"

 S %=1

 D YN^DICN

 I $D(DUOUT)!($D(DTOUT))!($E(%Y)=U) Q

 S AMQQL("RUN")=2

 I "Yy"[$E(%Y) S AMQQLTF="" Q

 K AMQQLTF

OUT K DUOUT,DTOUT,POP S AMQQQUIT=""

 W !!,"Query terminated...",*7,!! H 2

SET I $D(AMQQLTF) G SET1

 S %=+^%ZIS(1,AMQQLLP,"SUBTYPE")

 S %=$P(^%ZIS(2,%,0),U)

 I %'["P-" G SET1

 W !!,"Want to run this print job in the background"

 S %=1

 D YN^DICN

 I $D(DUOUT)!($D(DTOUT))!($E(%Y)=U) D OUT Q

 I "Yy"[$E(%Y) S AMQQLJB=""

SET1 ;

 S %=^AMQQ(8,DUZ(2),2,AMQQLDA,0)

 F X=1:1:5 S @("AMQQL"_$P("LP^HO^CW^RH^LL",U,X))=$P(%,U,X)

 S %=AMQQLHO

 F X=1:1:(AMQQLLL-1) S %=%_U_(AMQQLHO+(AMQQLCW*X))

 S AMQQLHT=%

 S AMQQLBC=0

 S AMQQLGR="^UTILITY(""AMQQ"",$J,""LABEL"")"

 I $D(AMQQLTF) D

 .W !

 .S:$G(AMQQLLP) AMQQLPTR=$P(^%ZIS(1,AMQQLLP,0),U)

 .S:$D(AMQQLPTR) %ZIS("B")=AMQQLPTR

 .D ^%ZIS

 .Q:POP

 .U IO D EXAMPLE

 .K %ZIS("B")

PRINT S AMQQRMFL="OUTPUT^AMQQRML"

EXAMPLE W @IOF

 N X,Y,Z

 F X=1:1:AMQQLTOP W !

 F AMQQLTF=1:1:(AMQQLLL*3) S %="JOHN SMITH^1234 S. MAIN ST. XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX^^^TUCSON^3^85745" D OUTPUT

 D ^%ZISC

 W !,"Want to reset label settings"

 S %=1

 D YN^DICN

 I $D(DUOUT)!($D(DTOUT))!($E(%Y)=U) D OUT Q

 I "Yy"[$E(%Y) S AMQQL("RUN")=0 Q

 K AMQQLTF

 S AMQQL("RUN")=2

OUTPUT I $D(AMQQLTF) G S1

 I 'AMQP(0) Q

 I '$D(^DPT(AMQP(0),.11)) Q

 S %=^DPT(AMQP(0),.11)

 S Z=$P(^DPT(AMQP(0),0),U)

 S Z=$P(Z,",",2,9)_" "_$P(Z,",")

 S %=Z_U_%

S1 S Y=0

 S AMQQLLN=0

 S AMQQLBC=AMQQLBC+1

 S $P(%,U,4)=$P(%,U,5)

 S $P(%,U,5)=$P(%,U,6)

 S $P(%,U,6)=$E($P(%,U,7),1,5)

 I $P(%,U,2)="" S $P(%,U,2)="NO ADDRESS LISTED"

 I $P(%,U,4)="" S $P(%,U,4)="NO CITY"

 I $P(%,U,5)="" S $P(%,U,5)="NO STATE"

 E  S $P(%,U,5)=$P($G(^DIC(5,+$P(%,U,5),0)),U,2)

 I $P(%,U,6)="" S $P(%,U,6)="NO ZIP"

 S $P(%,U,4)=$E($P(%,U,4),1,$S($G(AMQQLCW):AMQQLCW-2,1:15))_", "_$P(%,U,5)_" "_$P(%,U,6)

 S $P(%,U,5)=""

 I $P(%,U,3)="" D

 .S $P(%,U,3)=$P(%,U,4)

 .S $P(%,U,4)=$P(%,U,5)

 .S $P(%,U,5)="   "

 S $P(%,U,6)="   "

S2 F X=1:1:6 S Z=$E($P(%,U,X),1,$S($G(AMQQLCW):AMQQLCW-2,1:23)) D GET

 I AMQQLBC=AMQQLLL D FLUSH

GET I Z="",X'=3,X'=4 S Z="            "

 I Z="" Q

 S Y=Y+1

 S @AMQQLGR@(AMQQLBC,Y)=Z

FLUSH ; - EP - FROM AMQQRML

 I $Y<AMQQLTOP F X=1:1:AMQQLTOP W !

 F AMQQLCT=1:1:6 D

 .F AMQQLBF=1:1:AMQQLLL I $D(@AMQQLGR@(AMQQLBF,AMQQLCT)) D

 ..W ?$P(AMQQLHT,U,AMQQLBF),@AMQQLGR@(AMQQLBF,AMQQLCT)

 ..I AMQQLCT>AMQQLLN S AMQQLLN=AMQQLCT

 ..I AMQQLBF=AMQQLLL W !

..Q

.Q

 F X=1:1:(AMQQLRH-AMQQLLN) W !

 K @AMQQLGR

 S AMQQLBC=0

 I $Y+AMQQLTOP>IOSL W @IOF F X=1:1:AMQQLTOP W !

MAILX ; ENTRY POINT FROM AMQQCMPL

 S AMQQRMFL="OUTPUT^AMQQRML"

 I '$D(AMQQLLP) Q

 S IOP=$P(^%ZIS(1,AMQQLLP,0),U)

 D ^%ZIS

 I $D(AMQQLJB) D MAILTASK Q

 U IO D MAILRUN D ^%ZISC

 K AMQQRMFL,AMQQLJB,AMQQLGR,AMQQLLL,AMQQLRH,AMQQLHT,AMQQLLP,AMQQLLN,AMQQLHO,AMQQLCW,AMQQLCT,AMQQLBF,AMQQLBC

MAILRUN X AMQV(0)

 S AMQQLLL=0

 F X=0:0 S X=$O(@AMQQLGR@(X)) Q:'X  S AMQQLLL=X

 I AMQQLLL D FLUSH^AMQQRML

 I IOST["P-" W @IOF

 I $D(ZTQUEUED) D EXIT2^AMQQKILL S ZTREQ="@"

MAILTASK S ZTRTN="MAILRUN^AMQQRML"

 S ZTIO=ION

 S ZTDTH="NOW"

 S ZTDESC="QUERY UTILITY MAILING LABELS"

 F I=1:1 S %=$P("AMQQRMFL;AMQQL*;AMQV(;AMQQ200(;AMQQRV;AMQQNV;AMQQXV;^UTILITY(""AMQQ"",$J,;^UTILITY(""AMQQ RAND"",$J,;^UTILITY(""AMQQ TAX"",$J,",";",I) Q:%=""  S ZTSAVE(%)=""

 D ^%ZTLOAD

 D ^%ZISC

 W !!,$S($D(ZTSK):"Request queued!",1:"Request cancelled!"),!!!

H 3

 W @IOF

HELP ; ENTRY POINT

 S XQH="AMQQLABEL"

 D EN1^XQH

 R !,"<>",X:DTIME

AMQQRML   ; IHS/CMI/THL - MAILING LABEL GENERATOR ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;-----

VAR        KILL AMQQQUIT,AMQQLJB

RUN        DO EXIT

 +1        FOR AMQQL("RUN")=1:1

               SET %=$PIECE("FORMAT^TEST^SET",U,AMQQL("RUN"))

               IF %=""

                   QUIT

               DO @%

               IF $DATA(AMQQQUIT)

                   QUIT

EXIT       KILL AMQQLHO,AMQQLLM,AMQQLTF,AMQQLLC,AMQQLLN,AMQQLCF,AMQQL,AMQQLDA,I,%

 +1        QUIT

 +2       ;

FORMAT     WRITE @IOF,!!,?15,"*****  ADDRESS LABEL UTILITY  *****",!!

 +1        SET DA(1)=DUZ(2)

 +2        SET X=$ORDER(^AMQQ(8,DA(1),2,0))

 +3        IF X

               SET X=+$GET(^AMQQ(8,DA(1),2,X,0))

               IF X

                   SET X=$PIECE($GET(^%ZIS(1,X,0)),U)

 +4        SET DIC="^AMQQ(8,"_DA(1)_",2,"

 +5        SET DIC(0)="AEMQZ"

 +6        SET DIC("A")="Select LABEL PRINTING DEVICE: "

 +7        IF X]""

               SET DIC("B")=X

 +8        DO ^DIC

 +9        IF +Y<1

               SET AMQQQUIT=""

               QUIT

 +10       KILL AMQQQUIT

 +11       SET (DA,AMQQLLP)=+Y

 +12       SET DA(1)=DUZ(2)

 +13       IF '$DATA(^AMQQ(8,DA(1),2))

               SET ^(2,0)="^9009078.02P^^"

 +14       SET DIE="^AMQQ(8,"_DA(1)_",2,"

 +15       SET DR=".06;.02;.03;.04;.05"

 +16       DO ^DIE

 +17       SET AMQQLTOP=$PIECE($GET(^AMQQ(8,DA(1),2,DA,0)),U,6)

 +18       KILL DIE,DA,DR,DIC,D,D0,DI,DQ,D1

 +19       IF $DATA(DUOUT)!($DATA(DTOUT))!('$GET(AMQQLLP))

               SET AMQQRERF=""

               DO OUT

               QUIT

 +20       SET %=+$GET(^AMQQ(8,DUZ(2),2,AMQQLLP,0))

 +21       IF '%

               DO OUT

               QUIT

 +22       IF $GET(^%ZIS(1,%,0))=""

               DO OUT

               QUIT

 +23       SET AMQQLDA=AMQQLLP

 +24       SET AMQQLLP=%

 +25       WRITE !!

 +26       QUIT

 +27      ;

TEST       WRITE "Want to do a test print"

 +1        SET %=1

 +2        DO YN^DICN

 +3        IF $DATA(DUOUT)!($DATA(DTOUT))!($EXTRACT(%Y)=U)

               QUIT

 +4        SET AMQQL("RUN")=2

 +5        IF "Yy"[$EXTRACT(%Y)

               SET AMQQLTF=""

               QUIT

 +6        KILL AMQQLTF

 +7        QUIT

 +8       ;

OUT        KILL DUOUT,DTOUT,POP

           SET AMQQQUIT=""

 +1        WRITE !!,"Query terminated...",*7,!!

           HANG 2

 +2        QUIT

 +3       ;

SET        IF $DATA(AMQQLTF)

               GOTO SET1

 +1        SET %=+^%ZIS(1,AMQQLLP,"SUBTYPE")

 +2        SET %=$PIECE(^%ZIS(2,%,0),U)

 +3        IF %'["P-"

               GOTO SET1

 +4        WRITE !!,"Want to run this print job in the background"

 +5        SET %=1

 +6        DO YN^DICN

 +7        IF $DATA(DUOUT)!($DATA(DTOUT))!($EXTRACT(%Y)=U)

               DO OUT

               QUIT

 +8        IF "Yy"[$EXTRACT(%Y)

               SET AMQQLJB=""

SET1      ;

 +1        SET %=^AMQQ(8,DUZ(2),2,AMQQLDA,0)

 +2        FOR X=1:1:5

               SET @("AMQQL"_$PIECE("LP^HO^CW^RH^LL",U,X))=$PIECE(%,U,X)

 +3        SET %=AMQQLHO

 +4        FOR X=1:1:(AMQQLLL-1)

               SET %=%_U_(AMQQLHO+(AMQQLCW*X))

 +5        SET AMQQLHT=%

 +6        SET AMQQLBC=0

 +7        SET AMQQLGR="^UTILITY(""AMQQ"",$J,""LABEL"")"

 +8        IF $DATA(AMQQLTF)

               Begin DoDot:1

 +9                WRITE !

 +10               IF $GET(AMQQLLP)

                       SET AMQQLPTR=$PIECE(^%ZIS(1,AMQQLLP,0),U)

 +11               IF $DATA(AMQQLPTR)

                       SET %ZIS("B")=AMQQLPTR

 +12               DO ^%ZIS

 +13               IF POP

                       QUIT

 +14               USE IO

                   DO EXAMPLE

 +15               KILL %ZIS("B")

               End DoDot:1

PRINT      SET AMQQRMFL="OUTPUT^AMQQRML"

 +1        QUIT

 +2       ;

EXAMPLE    WRITE @IOF

 +1        NEW X,Y,Z

 +2        FOR X=1:1:AMQQLTOP

               WRITE !

 +3        FOR AMQQLTF=1:1:(AMQQLLL*3)

               SET %="JOHN SMITH^1234 S. MAIN ST. XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX^^^TUCSON^3^85745"

               DO OUTPUT

 +4        DO ^%ZISC

 +5        WRITE !,"Want to reset label settings"

 +6        SET %=1

 +7        DO YN^DICN

 +8        IF $DATA(DUOUT)!($DATA(DTOUT))!($EXTRACT(%Y)=U)

               DO OUT

               QUIT

 +9        IF "Yy"[$EXTRACT(%Y)

               SET AMQQL("RUN")=0

               QUIT

 +10       KILL AMQQLTF

 +11       SET AMQQL("RUN")=2

 +12       QUIT

 +13      ;

OUTPUT     IF $DATA(AMQQLTF)

               GOTO S1

 +1        IF 'AMQP(0)

               QUIT

 +2        IF '$DATA(^DPT(AMQP(0),.11))

               QUIT

 +3        SET %=^DPT(AMQP(0),.11)

 +4        SET Z=$PIECE(^DPT(AMQP(0),0),U)

 +5        SET Z=$PIECE(Z,",",2,9)_" "_$PIECE(Z,",")

 +6        SET %=Z_U_%

S1         SET Y=0

 +1        SET AMQQLLN=0

 +2        SET AMQQLBC=AMQQLBC+1

 +3        SET $PIECE(%,U,4)=$PIECE(%,U,5)

 +4        SET $PIECE(%,U,5)=$PIECE(%,U,6)

 +5        SET $PIECE(%,U,6)=$EXTRACT($PIECE(%,U,7),1,5)

 +6        IF $PIECE(%,U,2)=""

               SET $PIECE(%,U,2)="NO ADDRESS LISTED"

 +7        IF $PIECE(%,U,4)=""

               SET $PIECE(%,U,4)="NO CITY"

 +8        IF $PIECE(%,U,5)=""

               SET $PIECE(%,U,5)="NO STATE"

 +9       IF '$TEST

               SET $PIECE(%,U,5)=$PIECE($GET(^DIC(5,+$PIECE(%,U,5),0)),U,2)

 +10       IF $PIECE(%,U,6)=""

               SET $PIECE(%,U,6)="NO ZIP"

 +11       SET $PIECE(%,U,4)=$EXTRACT($PIECE(%,U,4),1,$SELECT($GET(AMQQLCW):AMQQLCW-2,1:15))_", "_$PIECE(%,U,5)_" "_$PIECE(%,U,6)

 +12       SET $PIECE(%,U,5)=""

 +13       IF $PIECE(%,U,3)=""

               Begin DoDot:1

 +14               SET $PIECE(%,U,3)=$PIECE(%,U,4)

 +15               SET $PIECE(%,U,4)=$PIECE(%,U,5)

 +16               SET $PIECE(%,U,5)="   "

               End DoDot:1

 +17       SET $PIECE(%,U,6)="   "

S2         FOR X=1:1:6

               SET Z=$EXTRACT($PIECE(%,U,X),1,$SELECT($GET(AMQQLCW):AMQQLCW-2,1:23))

               DO GET

 +1        IF AMQQLBC=AMQQLLL

               DO FLUSH

 +2        QUIT

 +3       ;

GET        IF Z=""

               IF X'=3

                   IF X'=4

                       SET Z="            "

 +1        IF Z=""

               QUIT

 +2        SET Y=Y+1

 +3        SET @AMQQLGR@(AMQQLBC,Y)=Z

 +4        QUIT

 +5       ;

FLUSH     ; - EP - FROM AMQQRML

 +1        IF $Y<AMQQLTOP

               FOR X=1:1:AMQQLTOP

                   WRITE !

 +2        FOR AMQQLCT=1:1:6

               Begin DoDot:1

 +3                FOR AMQQLBF=1:1:AMQQLLL

                       IF $DATA(@AMQQLGR@(AMQQLBF,AMQQLCT))

                           Begin DoDot:2

 +4                            WRITE ?$PIECE(AMQQLHT,U,AMQQLBF),@AMQQLGR@(AMQQLBF,AMQQLCT)

 +5                            IF AMQQLCT>AMQQLLN

                                   SET AMQQLLN=AMQQLCT

 +6                            IF AMQQLBF=AMQQLLL

                                   WRITE !

 +7                            QUIT

                           End DoDot:2

 +8                QUIT

               End DoDot:1

 +9        FOR X=1:1:(AMQQLRH-AMQQLLN)

               WRITE !

 +10       KILL @AMQQLGR

 +11       SET AMQQLBC=0

 +12       IF $Y+AMQQLTOP>IOSL

               WRITE @IOF

               FOR X=1:1:AMQQLTOP

                   WRITE !

 +13       QUIT

 +14      ;

MAILX     ; ENTRY POINT FROM AMQQCMPL

 +1        SET AMQQRMFL="OUTPUT^AMQQRML"

 +2        IF '$DATA(AMQQLLP)

               QUIT

 +3        SET IOP=$PIECE(^%ZIS(1,AMQQLLP,0),U)

 +4        DO ^%ZIS

 +5        IF $DATA(AMQQLJB)

               DO MAILTASK

               QUIT

 +6        USE IO

           DO MAILRUN

           DO ^%ZISC

 +7        KILL AMQQRMFL,AMQQLJB,AMQQLGR,AMQQLLL,AMQQLRH,AMQQLHT,AMQQLLP,AMQQLLN,AMQQLHO,AMQQLCW,AMQQLCT,AMQQLBF,AMQQLBC

 +8        QUIT

 +9       ;

MAILRUN    XECUTE AMQV(0)

 +1        SET AMQQLLL=0

 +2        FOR X=0:0

               SET X=$ORDER(@AMQQLGR@(X))

               IF 'X

                   QUIT

               SET AMQQLLL=X

 +3        IF AMQQLLL

               DO FLUSH^AMQQRML

 +4        IF IOST["P-"

               WRITE @IOF

 +5        IF $DATA(ZTQUEUED)

               DO EXIT2^AMQQKILL

               SET ZTREQ="@"

 +6        QUIT

 +7       ;

MAILTASK   SET ZTRTN="MAILRUN^AMQQRML"

 +1        SET ZTIO=ION

 +2        SET ZTDTH="NOW"

 +3        SET ZTDESC="QUERY UTILITY MAILING LABELS"

 +4        FOR I=1:1

               SET %=$PIECE("AMQQRMFL;AMQQL*;AMQV(;AMQQ200(;AMQQRV;AMQQNV;AMQQXV;^UTILITY(""AMQQ"",$J,;^UTILITY(""AMQQ RAND"",$J,;^UTILITY(""AMQQ TAX"",$J,",";",I)

               IF %=""

                   QUIT

               SET ZTSAVE(%)=""

 +5        DO ^%ZTLOAD

 +6        DO ^%ZISC

 +7        WRITE !!,$SELECT($DATA(ZTSK):"Request queued!",1:"Request cancelled!"),!!!

 +8        HANG 3

 +9        WRITE @IOF

 +10       QUIT

 +11      ;

HELP      ; ENTRY POINT

 +1        SET XQH="AMQQLABEL"

 +2        DO EN1^XQH

 +3        READ !,"<>",X:DTIME

 +4        QUIT

 +5       ;

AMQQRML.m