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,%
Q
;
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 !!
Q
;
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
Q
;
OUT K DUOUT,DTOUT,POP S AMQQQUIT=""
W !!,"Query terminated...",*7,!! H 2
Q
;
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"
Q
;
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
Q
;
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
Q
;
GET I Z="",X'=3,X'=4 S Z=" "
I Z="" Q
S Y=Y+1
S @AMQQLGR@(AMQQLBC,Y)=Z
Q
;
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 !
Q
;
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
Q
;
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="@"
Q
;
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
Q
;
HELP ; ENTRY POINT
S XQH="AMQQLABEL"
D EN1^XQH
R !,"<>",X:DTIME
Q
;
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 ;
