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
