- 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 ;
