ACHSVLB ; IHS/ITSC/PMF - PRINT VENDOR LABELS FOR DOCUMENTS ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
A1 ;
K ^TMP("ACHSVLB",$J)
D DISP
I '$D(^TMP("ACHSVLB",$J)) U IO(0) X:$D(IO("S")) ACHSPPC G END
MODE ;
W !!?5,"Print number of copies by [S]election",!?5,"or by number of [D]ocuments to be printed?"
S Y=$$DIR^XBDIR("FO"," [S]el or [D]ocuments ","D","","Press RETURN for ""D"", or enter ""S""","^D HELP^ACHS(""H"",""ACHSVLB"")",2)
G END:$D(DTOUT)!$D(DUOUT),CPY:Y="S",DOCS:Y="D"
;
CPY ;
S ACHS("CPY")=$$DIR^XBDIR("N^1:5","How many copies",1)
G END:$D(DTOUT),A1:$D(DUOUT)
G CVT
;
DOCS ;
S ACHS("DOC")=$$DIR^XBDIR("N^1:100","How many documents per vendor label",30)
G END:$D(DTOUT),A1:$D(DUOUT)
CVT ;
S ACHSVNDR="",ACHS=0
CVT1 ;
S ACHSVNDR=$O(^TMP("ACHSVLB",$J,ACHSVNDR))
G DEV:ACHSVNDR=""
S DA=$O(^TMP("ACHSVLB",$J,ACHSVNDR,0))
I $D(ACHS("CPY")) F ACHSX=0:1 G CVT1:ACHSX=ACHS("CPY") S ACHS=ACHS+1,^TMP("ACHSVLB",$J,ACHS)=DA
F ACHSX=0:0 S ACHS=ACHS+1,^TMP("ACHSVLB",$J,ACHS)=DA,^TMP("ACHSVLB",$J,ACHSVNDR,DA)=$G(^TMP("ACHSVLB",$J,ACHSVNDR,DA))-ACHS("DOC") Q:^(DA)<1
G CVT1
;
DEV ;
K IOP
S %ZIS="PO"
D ^%ZIS,SLV^ACHSFU:$D(IO("S"))
I POP D HOME^%ZIS G END
A2 ;
U IO(0)
X:$D(IO("S")) ACHSPPC
S DIE="^ACHSF(",DA=DUZ(2),DR=".02;.03;IF X=1 S Y="""";.04"
D ^DIE
G:$D(Y) END
S ACHSVS=$P(^ACHSF(DUZ(2),1),U,2),ACHSNOLA=$P(^(1),U,3),ACHSHS=$P(^(1),U,4)
D LINES^ACHSFU
A3 ;
G A2A:$$DIR^XBDIR("Y","Do you wish to print a TEST LABEL","N","","","",2),END:$D(DTOUT),A1:$D(DUOUT)
START ;
S ACHSX=0
D PRINT
END ;
K ^TMP("ACHSVLB",$J),A,ACHS,ACHSHS,ACHSNOLA,ACHSPPC,ACHSPPO,ACHSVNDR,ACHSVS,ACHSWORK,ACHSX,B,C,D,DA,DIC,DIE,DR,J,P,R,ACHSRR,ACHSTOTL
D ^%ZISC
Q
;
A2A ; Print Test Label.
U IO
X:$D(IO("S")) ACHSPPO
K ACHS("TEST")
S A=ACHSNOLA,B=ACHSHS
A2C ;
F ACHS=1:1:3 W !,$E(ACHS("*"),1,24) I A>1 W ?(B+1),$E(ACHS("*"),1,24) I A>2 W ?((2*B)+1),$E(ACHS("*"),1,24) I A>3 W ?((3*B)+1),$E(ACHS("*"),1,24)
F ACHS=1:1:ACHSVS W !
I $D(ACHS("TEST")) G A2
S ACHS("TEST")=""
G A2C
;
PRINT ; For Multiple Labels Across.
S ACHSTOTL=0
F ACHS("I")=1:1:ACHSNOLA S ACHSX=ACHSX+1 Q:'$D(^TMP("ACHSVLB",$J,ACHSX)) S DA=^(ACHSX) I $D(^AUTTVNDR(DA,0)),$D(^(13)) S A=^(13),ACHSTOTL=ACHSTOTL+1 D PR1
Q:ACHSTOTL=0
U IO
X:$D(IO("S")) ACHSPPO
S B=ACHSHS
W !,A(1)
W:ACHSTOTL>1 ?(B+1),A(2)
W:ACHSTOTL>2 ?(2*B+1),A(3)
W:ACHSTOTL>3 ?(3*B+1),A(4)
W !,B(1)
W:ACHSTOTL>1 ?(B+1),B(2)
W:ACHSTOTL>2 ?(2*B+1),B(3)
W:ACHSTOTL>3 ?(3*B+1),B(4)
W !,C(1)
W:ACHSTOTL>1 ?(B+1),C(2)
W:ACHSTOTL>2 ?(2*B+1),C(3)
W:ACHSTOTL>3 ?(3*B+1),C(4)
W !
F %=1:1:4 I $L($G(D(%))) W $G(D(1)) W:ACHSTOTL>1 ?(B+1),$G(D(2)) W:ACHSTOTL>2 ?(2*B+1),$G(D(3)) W:ACHSTOTL>3 ?(3*B+1),$G(D(4)) Q
F ACHS=1:1:ACHSVS W !
Q:+DA=0
G PRINT
;
PR1 ;
S A(ACHSTOTL)=$P(^AUTTVNDR(DA,0),U),B(ACHSTOTL)=$P(A,U),C(ACHSTOTL)=$P(A,U,2)_" "
I +$P(A,U,3),$D(^DIC(5,+$P(A,U,3),0)) S C(ACHSTOTL)=C(ACHSTOTL)_$P(^(0),U,2)_" "
S:A(ACHSTOTL)["," A(ACHSTOTL)=$P(A(ACHSTOTL),",",2)_" "_$P(A(ACHSTOTL),",")
S A(ACHSTOTL)=$E(A(ACHSTOTL),1,35),C(ACHSTOTL)=C(ACHSTOTL)_$P(A,U,4)
S D(ACHSTOTL)=""
I $L($P(A,U,5)) S D(ACHSTOTL)=C(ACHSTOTL),C(ACHSTOTL)=B(ACHSTOTL),B(ACHSTOTL)="Attn: "_$E($P(A,U,5),1,20)
Q
;
DISP ; Display Batches for Printing of Labels.
S (R,ACHSRR)="",ACHS=0
K ACHSWORK
DIS1 ;
S R=$O(^ACHS(7,"CZ",R))
G CEND:'R
DIS2 ;
S ACHSRR=$O(^ACHS(7,"CZ",R,ACHSRR))
G DIS1:'ACHSRR,DIS2:'$D(^ACHS(7,ACHSRR,"D","B"))
S A=""
F ACHSI=0:0 Q:$O(^ACHS(7,ACHSRR,"D","B",A))="" S A=$O(^(A))
S ACHS=ACHS+1
I ACHS=1 W !!?10,"---------------------------------------------------------",!?10,"ITM #",?19,"D A T E",?30,"FIRST DOC #",?45,"LAST DOC #",?60,"# DOC'S",!?10,"---------------------------------------------------------",!!
I ACHS#10=0 W:$$DIR^XBDIR("E"," Enter '^' to CANCEL ") ! G CEND:$D(DUOUT)
S ACHSWORK(ACHS)=ACHSRR_U_$O(^ACHS(7,ACHSRR,"D","B",""))_U_A_U_$P(^ACHS(7,ACHSRR,"D",0),U,4)
W ?10,$J(ACHS,3),?17,$$FMTE^XLFDT($P(^ACHS(7,ACHSRR,0),U,2)),?30,$P(ACHSWORK(ACHS),U,2),?45,$P(ACHSWORK(ACHS),U,3),?61,$J($P(ACHSWORK(ACHS),U,4),3),!
G DIS2
;
CEND ;
I ACHS=0 W !!,"No 'Batches' on File for Printing Labels.",! G SEL
S Y=$$DIR^XBDIR("NO^1:"_ACHS," ENTER ITEM # ","","","Enter Item Number of 'BATCH' of Labels you wish to PRINT.","",2)
Q:$D(DUOUT)!$D(DTOUT)
G SEL:(Y="")
S ACHSRR=+$P(ACHSWORK(Y),U)
D2 ;
F R=0:0 S R=$O(^ACHS(7,ACHSRR,"D",R)) Q:'R S DA=$P(^ACHSF($P(^ACHS(7,ACHSRR,"D",R,0),U,2),"D",$P(^ACHS(7,ACHSRR,"D",R,0),U,3),0),U,8),^TMP("ACHSVLB",$J,$P(^AUTTVNDR(DA,0),U),DA)=$S($D(^TMP("ACHSVLB",$J,$P(^AUTTVNDR(DA,0),U),DA)):^(DA)+1,1:1)
Q
;
SEL ; If user did not select a batch, ask if want to select Vendor(s).
Q:'$$DIR^XBDIR("Y","Want to select the Vendors","N","","You can select vendors from the VENDOR file from which to print labels.","",2)
Q:$D(DUOUT)!$D(DTOUT)
N DIC
S DIC="^AUTTVNDR(",DIC(0)="AEFMNQ"
F D ^DIC Q:+Y<1 S ^TMP("ACHSVLB",$J,$P(^AUTTVNDR(+Y,0),U),+Y)=1
Q
;
H ;EP - From DIR.
;;@;!!?10,"You can either select the number of copies of the label to print"
;;@;!?10,"for each vendor, or you can select the number of documents per"
;;@;!?10,"each label for a vendor."
;;###
;
ACHSVLB ; IHS/ITSC/PMF - PRINT VENDOR LABELS FOR DOCUMENTS ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
A1 ;
+1 KILL ^TMP("ACHSVLB",$JOB)
+2 DO DISP
+3 IF '$DATA(^TMP("ACHSVLB",$JOB))
USE IO(0)
IF $DATA(IO("S"))
XECUTE ACHSPPC
GOTO END
MODE ;
+1 WRITE !!?5,"Print number of copies by [S]election",!?5,"or by number of [D]ocuments to be printed?"
+2 SET Y=$$DIR^XBDIR("FO"," [S]el or [D]ocuments ","D","","Press RETURN for ""D"", or enter ""S""","^D HELP^ACHS(""H"",""ACHSVLB"")",2)
+3 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO END
IF Y="S"
GOTO CPY
IF Y="D"
GOTO DOCS
+4 ;
CPY ;
+1 SET ACHS("CPY")=$$DIR^XBDIR("N^1:5","How many copies",1)
+2 IF $DATA(DTOUT)
GOTO END
IF $DATA(DUOUT)
GOTO A1
+3 GOTO CVT
+4 ;
DOCS ;
+1 SET ACHS("DOC")=$$DIR^XBDIR("N^1:100","How many documents per vendor label",30)
+2 IF $DATA(DTOUT)
GOTO END
IF $DATA(DUOUT)
GOTO A1
CVT ;
+1 SET ACHSVNDR=""
SET ACHS=0
CVT1 ;
+1 SET ACHSVNDR=$ORDER(^TMP("ACHSVLB",$JOB,ACHSVNDR))
+2 IF ACHSVNDR=""
GOTO DEV
+3 SET DA=$ORDER(^TMP("ACHSVLB",$JOB,ACHSVNDR,0))
+4 IF $DATA(ACHS("CPY"))
FOR ACHSX=0:1
IF ACHSX=ACHS("CPY")
GOTO CVT1
SET ACHS=ACHS+1
SET ^TMP("ACHSVLB",$JOB,ACHS)=DA
+5 FOR ACHSX=0:0
SET ACHS=ACHS+1
SET ^TMP("ACHSVLB",$JOB,ACHS)=DA
SET ^TMP("ACHSVLB",$JOB,ACHSVNDR,DA)=$GET(^TMP("ACHSVLB",$JOB,ACHSVNDR,DA))-ACHS("DOC")
IF ^(DA)<1
QUIT
+6 GOTO CVT1
+7 ;
DEV ;
+1 KILL IOP
+2 SET %ZIS="PO"
+3 DO ^%ZIS
IF $DATA(IO("S"))
DO SLV^ACHSFU
+4 IF POP
DO HOME^%ZIS
GOTO END
A2 ;
+1 USE IO(0)
+2 IF $DATA(IO("S"))
XECUTE ACHSPPC
+3 SET DIE="^ACHSF("
SET DA=DUZ(2)
SET DR=".02;.03;IF X=1 S Y="""";.04"
+4 DO ^DIE
+5 IF $DATA(Y)
GOTO END
+6 SET ACHSVS=$PIECE(^ACHSF(DUZ(2),1),U,2)
SET ACHSNOLA=$PIECE(^(1),U,3)
SET ACHSHS=$PIECE(^(1),U,4)
+7 DO LINES^ACHSFU
A3 ;
+1 IF $$DIR^XBDIR("Y","Do you wish to print a TEST LABEL","N","","","",2)
GOTO A2A
IF $DATA(DTOUT)
GOTO END
IF $DATA(DUOUT)
GOTO A1
START ;
+1 SET ACHSX=0
+2 DO PRINT
END ;
+1 KILL ^TMP("ACHSVLB",$JOB),A,ACHS,ACHSHS,ACHSNOLA,ACHSPPC,ACHSPPO,ACHSVNDR,ACHSVS,ACHSWORK,ACHSX,B,C,D,DA,DIC,DIE,DR,J,P,R,ACHSRR,ACHSTOTL
+2 DO ^%ZISC
+3 QUIT
+4 ;
A2A ; Print Test Label.
+1 USE IO
+2 IF $DATA(IO("S"))
XECUTE ACHSPPO
+3 KILL ACHS("TEST")
+4 SET A=ACHSNOLA
SET B=ACHSHS
A2C ;
+1 FOR ACHS=1:1:3
WRITE !,$EXTRACT(ACHS("*"),1,24)
IF A>1
WRITE ?(B+1),$EXTRACT(ACHS("*"),1,24)
IF A>2
WRITE ?((2*B)+1),$EXTRACT(ACHS("*"),1,24)
IF A>3
WRITE ?((3*B)+1),$EXTRACT(ACHS("*"),1,24)
+2 FOR ACHS=1:1:ACHSVS
WRITE !
+3 IF $DATA(ACHS("TEST"))
GOTO A2
+4 SET ACHS("TEST")=""
+5 GOTO A2C
+6 ;
PRINT ; For Multiple Labels Across.
+1 SET ACHSTOTL=0
+2 FOR ACHS("I")=1:1:ACHSNOLA
SET ACHSX=ACHSX+1
IF '$DATA(^TMP("ACHSVLB",$JOB,ACHSX))
QUIT
SET DA=^(ACHSX)
IF $DATA(^AUTTVNDR(DA,0))
IF $DATA(^(13))
SET A=^(13)
SET ACHSTOTL=ACHSTOTL+1
DO PR1
+3 IF ACHSTOTL=0
QUIT
+4 USE IO
+5 IF $DATA(IO("S"))
XECUTE ACHSPPO
+6 SET B=ACHSHS
+7 WRITE !,A(1)
+8 IF ACHSTOTL>1
WRITE ?(B+1),A(2)
+9 IF ACHSTOTL>2
WRITE ?(2*B+1),A(3)
+10 IF ACHSTOTL>3
WRITE ?(3*B+1),A(4)
+11 WRITE !,B(1)
+12 IF ACHSTOTL>1
WRITE ?(B+1),B(2)
+13 IF ACHSTOTL>2
WRITE ?(2*B+1),B(3)
+14 IF ACHSTOTL>3
WRITE ?(3*B+1),B(4)
+15 WRITE !,C(1)
+16 IF ACHSTOTL>1
WRITE ?(B+1),C(2)
+17 IF ACHSTOTL>2
WRITE ?(2*B+1),C(3)
+18 IF ACHSTOTL>3
WRITE ?(3*B+1),C(4)
+19 WRITE !
+20 FOR %=1:1:4
IF $LENGTH($GET(D(%)))
WRITE $GET(D(1))
IF ACHSTOTL>1
WRITE ?(B+1),$GET(D(2))
IF ACHSTOTL>2
WRITE ?(2*B+1),$GET(D(3))
IF ACHSTOTL>3
WRITE ?(3*B+1),$GET(D(4))
QUIT
+21 FOR ACHS=1:1:ACHSVS
WRITE !
+22 IF +DA=0
QUIT
+23 GOTO PRINT
+24 ;
PR1 ;
+1 SET A(ACHSTOTL)=$PIECE(^AUTTVNDR(DA,0),U)
SET B(ACHSTOTL)=$PIECE(A,U)
SET C(ACHSTOTL)=$PIECE(A,U,2)_" "
+2 IF +$PIECE(A,U,3)
IF $DATA(^DIC(5,+$PIECE(A,U,3),0))
SET C(ACHSTOTL)=C(ACHSTOTL)_$PIECE(^(0),U,2)_" "
+3 IF A(ACHSTOTL)[","
SET A(ACHSTOTL)=$PIECE(A(ACHSTOTL),",",2)_" "_$PIECE(A(ACHSTOTL),",")
+4 SET A(ACHSTOTL)=$EXTRACT(A(ACHSTOTL),1,35)
SET C(ACHSTOTL)=C(ACHSTOTL)_$PIECE(A,U,4)
+5 SET D(ACHSTOTL)=""
+6 IF $LENGTH($PIECE(A,U,5))
SET D(ACHSTOTL)=C(ACHSTOTL)
SET C(ACHSTOTL)=B(ACHSTOTL)
SET B(ACHSTOTL)="Attn: "_$EXTRACT($PIECE(A,U,5),1,20)
+7 QUIT
+8 ;
DISP ; Display Batches for Printing of Labels.
+1 SET (R,ACHSRR)=""
SET ACHS=0
+2 KILL ACHSWORK
DIS1 ;
+1 SET R=$ORDER(^ACHS(7,"CZ",R))
+2 IF 'R
GOTO CEND
DIS2 ;
+1 SET ACHSRR=$ORDER(^ACHS(7,"CZ",R,ACHSRR))
+2 IF 'ACHSRR
GOTO DIS1
IF '$DATA(^ACHS(7,ACHSRR,"D","B"))
GOTO DIS2
+3 SET A=""
+4 FOR ACHSI=0:0
IF $ORDER(^ACHS(7,ACHSRR,"D","B",A))=""
QUIT
SET A=$ORDER(^(A))
+5 SET ACHS=ACHS+1
+6 IF ACHS=1
WRITE !!?10,"---------------------------------------------------------",!?10,"ITM #",?19,"D A T E",?30,"FIRST DOC #",?45,"LAST DOC #",?60,"# DOC'S",!?10,"---------------------------------------------------------",!!
+7 IF ACHS#10=0
IF $$DIR^XBDIR("E"," Enter '^' to CANCEL ")
WRITE !
IF $DATA(DUOUT)
GOTO CEND
+8 SET ACHSWORK(ACHS)=ACHSRR_U_$ORDER(^ACHS(7,ACHSRR,"D","B",""))_U_A_U_$PIECE(^ACHS(7,ACHSRR,"D",0),U,4)
+9 WRITE ?10,$JUSTIFY(ACHS,3),?17,$$FMTE^XLFDT($PIECE(^ACHS(7,ACHSRR,0),U,2)),?30,$PIECE(ACHSWORK(ACHS),U,2),?45,$PIECE(ACHSWORK(ACHS),U,3),?61,$JUSTIFY($PIECE(ACHSWORK(ACHS),U,4),3),!
+10 GOTO DIS2
+11 ;
CEND ;
+1 IF ACHS=0
WRITE !!,"No 'Batches' on File for Printing Labels.",!
GOTO SEL
+2 SET Y=$$DIR^XBDIR("NO^1:"_ACHS," ENTER ITEM # ","","","Enter Item Number of 'BATCH' of Labels you wish to PRINT.","",2)
+3 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+4 IF (Y="")
GOTO SEL
+5 SET ACHSRR=+$PIECE(ACHSWORK(Y),U)
D2 ;
+1 FOR R=0:0
SET R=$ORDER(^ACHS(7,ACHSRR,"D",R))
IF 'R
QUIT
SET DA=$PIECE(^ACHSF($PIECE(^ACHS(7,ACHSRR,"D",R,0),U,2),"D",$PIECE(^ACHS(7,ACHSRR,"D",R,0),U,3),0),U,8)
SET ^TMP("ACHSVLB",$JOB,$PIECE(^AUTTVNDR(DA,0),U),DA)=$SELECT($DATA(^TMP("ACHSVLB",$JOB,$PIECE(^AUTTVNDR(DA,0),U),DA)):^(DA)+1,1:1)
+2 QUIT
+3 ;
SEL ; If user did not select a batch, ask if want to select Vendor(s).
+1 IF '$$DIR^XBDIR("Y","Want to select the Vendors","N","","You can select vendors from the VENDOR file from which to print labels.","",2)
QUIT
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+3 NEW DIC
+4 SET DIC="^AUTTVNDR("
SET DIC(0)="AEFMNQ"
+5 FOR
DO ^DIC
IF +Y<1
QUIT
SET ^TMP("ACHSVLB",$JOB,$PIECE(^AUTTVNDR(+Y,0),U),+Y)=1
+6 QUIT
+7 ;
H ;EP - From DIR.
+1 ;;@;!!?10,"You can either select the number of copies of the label to print"
+2 ;;@;!?10,"for each vendor, or you can select the number of documents per"
+3 ;;@;!?10,"each label for a vendor."
+4 ;;###
+5 ;
