Routine: ACHSVUR

ACHSVUR ; IHS/ITSC/PMF - VENDOR USAGE REPORT ;     [ 10/31/2003  12:12 PM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,18**;JUN 11, 2001

 ;9/11/00   added verification of eligbility dates.  Changes

 ;          are courtesy of Jeanette Kompkoff, presently

 ;          of the Portland office

 ;ACHS*3.1*6 5/2/2003 /ITSC/SET/JVK ADDED FIX FOR PAID DOCUMENTS

 S ACHSIO=IO

BDT ; Enter beginning date.

 S ACHSBDT=$$DATE^ACHS("B","Vendor Usage","ISSUE")

 G K:$D(DUOUT)!$D(DTOUT)!(ACHSBDT<1)

EDT ; Enter the ending date.

 S ACHSEDT=$$DATE^ACHS("E","Vendor Usage","ISSUE")

 G BDT:$D(DUOUT),K:$D(DTOUT)!(ACHSEDT<1),EDT:$$EBB^ACHS(ACHSBDT,ACHSEDT)

DOCS ; Select type of docs to print.

 S ACHSRPT=$$DIR^XBDIR("S^1:ALL documents;2:OPEN documents only","Print which documents","1","","","^D HELP^ACHS(""H1"",""ACHSVUR"")",2)

 G EDT:$D(DUOUT),K:$D(DTOUT)

 S %=$$DIR^XBDIR("Y","Print ONE vendor per page","N","","","^D HELP^ACHS(""H2"",""ACHSVUR"")",2)

 G DOCS:$D(DUOUT),K:$D(DTOUT)

 S ACHSVND=$S(%:"Y",1:"N")

DEV ; Select device for report.

W !

 S %=$$PB^ACHS

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

 I %="B" D VIEWR^XBLM("CALC^ACHSVUR"),EN^XBVK("VALM") D K Q

 K IOP,%ZIS

 S %ZIS="PQ"

 D ^%ZIS,SLV^ACHSFU:$D(IO("S"))

 K %ZIS

 I POP W !,*7,"No device specified." D HOME^%ZIS G K

 G:'$D(IO("Q")) CALC

 K IO("Q")

 I $E(IOST)'="P" W *7,!,"Please queue to printers only." G DEV

 S ZTIO="",ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="CALC^ACHSVUR",ZTDESC="CHS Vendor Report, "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)_" for "_ACHSVND

 F %="ACHSQIO","ACHSVND","ACHSBDT","ACHSRPT","ACHSEDT" S ZTSAVE(%)=""

 D ^%ZTLOAD

 G:'$D(ZTSK) DEV

K ; Kill vars, close device, quit.

 K ACHSBDT,ACHSEDT,ACHSIO,ACHSQIO,ACHSRPT,ACHSVND,DTOUT,DUOUT,ZTSK

 D ^%ZISC

 ;end of interactive portion.  The rest performed by Taskman

CALC ;EP - TaskMan.

 D FC^ACHSUF

 I $D(ACHSERR),ACHSERR=1 G K

 S ACHSTRDT=ACHSBDT-1

 K ^TMP("ACHSVUR",$J)

TRDT ; Loop thru transaction date x-ref.

 S ACHSTRDT=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT))

 G PRINT:+ACHSTRDT=0!(+ACHSTRDT>ACHSEDT)

 S ACHSTYPE=""

TRTYPE ; Loop thru transaction type.

 S ACHSTYPE=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSTYPE))

 G TRDT:ACHSTYPE="",TRTYPE:ACHSTYPE'="I"

 S DA=0

TRANS ; Loop thru transactions, compile report data.

 S DA=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSTYPE,DA))

 G TRDT:+DA=0,TRDT:'$D(^ACHSF(DUZ(2),"D",DA,0))

 ;ACHS*3.1*18 06.08.2010 IHS.OIT.FCJ CHANGED NXT LINE TO PRINT 2 DIG FY

 ;S ACHSDOCN=$P(^ACHSF(DUZ(2),"D",DA,0),U),ACHSVPTR=$P(^(0),U,8),ACHSFY=$P(^(0),U,14),ACHSSTS=$P(^(0),U,12),DFN=$P(^(0),U,22),ACHSBLNK=+$P(^(0),U,3)

 S ACHSDOCN=$P(^ACHSF(DUZ(2),"D",DA,0),U),ACHSVPTR=$P(^(0),U,8),ACHSFY=$E($P(^(0),U,27),3,4),ACHSSTS=$P(^(0),U,12),DFN=$P(^(0),U,22),ACHSBLNK=+$P(^(0),U,3)

 ;get the amount. either the adjusted amount, or, if that doesn't

 ;exist, the payment amount, or, if that doesn't exist, the

 ;obligated amount

 ;pmf  6/26/01  fix bug.  add $p to third line

 . ;/ITSC/JVK/SET ACHS*3.1*6 LN BLEOW

 .; I $D(^ACHSF(DUZ(2),"D",DA,"ZA")) S ACHS("$")=$G(^ACHSF(DUZ(2),"D",DA,"ZA")) Q

 . I $D(^ACHSF(DUZ(2),"D",DA,"ZA")) S ACHS("$")=$G(^ACHSF(DUZ(2),"D",DA,"ZA")),ACHS("$")=+ACHS("$")_"*" Q

 . ;I $D(^ACHSF(DUZ(2),"D",DA,"PA")) S ACHS("$")=$G(^ACHSF(DUZ(2),"D",DA,"PA"))_"*" Q

 . I $D(^ACHSF(DUZ(2),"D",DA,"PA")) S ACHS("$")=$G(^ACHSF(DUZ(2),"D",DA,"PA")),ACHS("$")=+ACHS("$")_"*" Q

 . ;S ACHS("$")=$G(^ACHSF(DUZ(2),"D",DA,0))

 . S ACHS("$")=$P($G(^ACHSF(DUZ(2),"D",DA,0)),U,9)

. Q

 G TRANS:(DFN'=+DFN)&('ACHSBLNK),TRANS:ACHSSTS=4!(ACHSRPT=2&(ACHSSTS>2))!(ACHSVPTR']""),TRANS:'$D(^AUTTVNDR(ACHSVPTR,0)) S ACHSVNDR=$P(^(0),U)

 I 'ACHSBLNK,'$D(^DPT(DFN,0)) G TRANS

 S ACHSDOC=ACHSFY_"-"_ACHSFC_"-"_ACHSDOCN,^TMP("ACHSVUR",$J,ACHSVNDR,ACHSVPTR,ACHSDOC,DA)=$S(ACHSBLNK=0:$P(^DPT(DFN,0),U),ACHSBLNK=1:"* BLANKET",ACHSBLNK=2:"* SPECIAL TRANS",1:"")_U_ACHS("$")

 G TRANS

PRINT ; Kill calc vars, print.

 K ACHSBLNK,ACHSDOCN,ACHSFY,ACHSSTS,ACHSTRDT,ACHSTYPE

 S ACHSVNDR="",(ACHSTOT,ACHSTOT("$"),ACHSPD,ACHSPD("$"))=0,ACHST1=$$C^XBFUNC("VENDOR USAGE REPORT - "_$S(ACHSRPT=2:"OPEN DOCUMENTS ONLY",1:"OPEN AND PAID DOCUMENTS"))

 S ACHST2=$$C^XBFUNC("For the period "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT)),X3=0

 D BRPT^ACHSFU

 X:$D(IO("S")) ACHSPPO

 D HDR

 K ACHSHDR

A ;

 S ACHSVNDR=$O(^TMP("ACHSVUR",$J,ACHSVNDR))

 G ENDPRNT:ACHSVNDR=""

 S ACHSVPTR=0

B ;

 S ACHSVPTR=$O(^TMP("ACHSVUR",$J,ACHSVNDR,ACHSVPTR))

 G A:+ACHSVPTR=0,B:'$D(^AUTTVNDR(ACHSVPTR))

 I ACHSVND="Y",$D(ACHSHDR) D RTRN^ACHS G KILL:$D(DUOUT)!$D(DTOUT) D HDR

 W ACHSVNDR

 S ACHSHDR=""

 I $D(^AUTTVNDR(ACHSVPTR,13)) W ?37,$E($P(^(13),U,2),1,17) S X=$P(^(13),U,3) I X]"",$D(^DIC(5,X,0)) W $S($X>38:", ",1:""),$P(^(0),U,2)

 S ACHSDOC="",(ACHSVDOC,ACHSVDOC("$"))=0

C ;

 S ACHSDOC=$O(^TMP("ACHSVUR",$J,ACHSVNDR,ACHSVPTR,ACHSDOC)) G F:ACHSDOC="" S DA=$O(^(ACHSDOC,0)),ACHSNAME=$P(^(DA),U),ACHS("$")=$P(^(DA),U,2)

 G C:'$D(^ACHSF(DUZ(2),"D",DA,0)) S ACHSTOS=$P(^(0),U,4),DFN=$P(^(0),U,22)

 I +ACHSTOS>0 S ACHSTOS=$P($P($P($P(^DD(9002080.01,3,0),U,3),";",ACHSTOS),":",2)," ")

 S (Y,ACHSDOS)=""

 I $D(^ACHSF(DUZ(2),"D",DA,3)),+$P(^(3),U)>0 S Y=+$P(^(3),U),ACHSDOS=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)

D ;

 W !?3,ACHSDOC,?16,ACHSNAME,?49,ACHSTOS,?54,ACHSDOS

 ;start of jeanette's changes

 S ACHSBLNK=$P(^ACHSF(DUZ(2),"D",DA,0),U,3)

 I DFN S INSTYP=$S($D(^AUPNMCR(DFN)):"MCR",$D(^AUPNMCD("B",DFN)):"MCD",$D(^AUPNRRE(DFN)):"RRE",$D(^AUPNPRVT(DFN)):"PRVT",1:"")

 I 'DFN S INSTYP=""

 I (INSTYP="PRVT")&('ACHSBLNK) D PRVTST^ACHSVUR1

 I (INSTYP="MCR")&('ACHSBLNK) D MCRTST^ACHSVUR1

 I (INSTYP="MCD")&('ACHSBLNK) D MCDTST^ACHSVUR1

 I (INSTYP="RRE")&('ACHSBLNK) D RRETST^ACHSVUR1

 ;end of jeanette's changes in this tag

 S X=$FN(+ACHS("$"),",",2)

 I $D(ACHSSTAR) S X=X_ACHSSTAR K ACHSSTAR

 W ?78-$L(X),X

 I ACHS("$")["*" W "*" S ACHSPD=ACHSPD+1,ACHSPD("$")=ACHSPD("$")+ACHS("$")

 I $Y>ACHSBM D RTRN^ACHS G KILL:$D(DUOUT)!$D(DTOUT) D HDR W:$D(ACHSVNDR) ACHSVNDR," (continued)"

E ;

 S ACHSVDOC=ACHSVDOC+1,ACHSVDOC("$")=ACHSVDOC("$")+ACHS("$"),ACHSTOT=ACHSTOT+1,ACHSTOT("$")=ACHSTOT("$")+ACHS("$")

G C

F ;

 S X2="2$",X3=16,X=ACHSVDOC("$")

 D COMMA^%DTC

 W !?10,$$REPEAT^XLFSTR("-",55),!?10,"TOTALS     DOCUMENTS:",$J(ACHSVDOC,5),?42,"DOLLARS:",X,!,$$REPEAT^XLFSTR("-",79),!

G B

ENDPRNT ;

 I ACHSVND="Y" D RTRN^ACHS G KILL:$D(DUOUT)!$D(DTOUT) D HDR

 W !,$$REPEAT^XLFSTR("=",79),!

 S X2="2$",X3=16,X=ACHSPD("$")

 D COMMA^%DTC

 W "TOTAL PAID",?21,"DOCUMENTS:",$J(ACHSPD,5),?42,"DOLLARS:",X,!

 S X=ACHSTOT("$")-ACHSPD("$")

 D COMMA^%DTC

 W "TOTAL OUTSTANDING",?21,"DOCUMENTS:",$J(ACHSTOT-ACHSPD,5),?42,"DOLLARS:",X,!,$$REPEAT^XLFSTR("-",79),!

 S X=ACHSTOT("$")

 D COMMA^%DTC

 W "GRAND TOTALS",?21,"DOCUMENTS:",$J(ACHSTOT,5),?42,"DOLLARS:",X

 D RTRN^ACHS:'$D(IO("S"))

 W @IOF

KILL ; Kill vars, close device, quit.

 X:$D(IO("S")) ACHSPPC

 K DA,DFN,ZTSK,^TMP("ACHSVUR",$J)

 D ERPT^ACHS,EN^XBVK("ACHS"),^ACHSVAR:'$D(ZTQUEUED)

HDR ; Paginate.

 S ACHSPG=ACHSPG+1

 W @IOF,!!?19,"***  CONTRACT HEALTH MANAGEMENT SYSTEM  ***",!,ACHSUSR,?71,"Page",$J(ACHSPG,3),!,ACHSLOC,!,ACHST1,!,ACHSTIME,!,ACHST2

 W !!,"VENDOR",?70,"DOLLARS",!?3,"DOCUMENT #   PATIENT NAME",?48,"TYPE    DOS",?64,"INS  (* = PAID)"

 W !,$$REPEAT^XLFSTR("=",79),!

H1 ;EP - From HELP^ACHS() via ^DIR.

 ;;@;!

 ;;Enter a '1' if you want to list all documents.

 ;;Enter a '2' if you want only OPEN documents to be listed.

 ;;###

H2 ;EP - From HELP^ACHS() via ^DIR.

 ;;@;!

 ;;Enter 'Y' to print one vendor per page.

 ;;'N' to print more than one vendor per page.

 ;;@;!!

 ;;###

ACHSVUR   ; IHS/ITSC/PMF - VENDOR USAGE REPORT ;     [ 10/31/2003  12:12 PM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,18**;JUN 11, 2001

 +2       ;

 +3       ;9/11/00   added verification of eligbility dates.  Changes

 +4       ;          are courtesy of Jeanette Kompkoff, presently

 +5       ;          of the Portland office

 +6       ;ACHS*3.1*6 5/2/2003 /ITSC/SET/JVK ADDED FIX FOR PAID DOCUMENTS

 +7       ;

 +8        SET ACHSIO=IO

BDT       ; Enter beginning date.

 +1        SET ACHSBDT=$$DATE^ACHS("B","Vendor Usage","ISSUE")

 +2        IF $DATA(DUOUT)!$DATA(DTOUT)!(ACHSBDT<1)

               GOTO K

EDT       ; Enter the ending date.

 +1        SET ACHSEDT=$$DATE^ACHS("E","Vendor Usage","ISSUE")

 +2        IF $DATA(DUOUT)

               GOTO BDT

           IF $DATA(DTOUT)!(ACHSEDT<1)

               GOTO K

           IF $$EBB^ACHS(ACHSBDT,ACHSEDT)

               GOTO EDT

DOCS      ; Select type of docs to print.

 +1        SET ACHSRPT=$$DIR^XBDIR("S^1:ALL documents;2:OPEN documents only","Print which documents","1","","","^D HELP^ACHS(""H1"",""ACHSVUR"")",2)

 +2        IF $DATA(DUOUT)

               GOTO EDT

           IF $DATA(DTOUT)

               GOTO K

 +3        SET %=$$DIR^XBDIR("Y","Print ONE vendor per page","N","","","^D HELP^ACHS(""H2"",""ACHSVUR"")",2)

 +4        IF $DATA(DUOUT)

               GOTO DOCS

           IF $DATA(DTOUT)

               GOTO K

 +5        SET ACHSVND=$SELECT(%:"Y",1:"N")

DEV       ; Select device for report.

 +1        WRITE !

 +2        SET %=$$PB^ACHS

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

               DO K

               QUIT

 +4        IF %="B"

               DO VIEWR^XBLM("CALC^ACHSVUR")

               DO EN^XBVK("VALM")

               DO K

               QUIT

 +5        KILL IOP,%ZIS

 +6        SET %ZIS="PQ"

 +7        DO ^%ZIS

           IF $DATA(IO("S"))

               DO SLV^ACHSFU

 +8        KILL %ZIS

 +9        IF POP

               WRITE !,*7,"No device specified."

               DO HOME^%ZIS

               GOTO K

 +10       IF '$DATA(IO("Q"))

               GOTO CALC

 +11       KILL IO("Q")

 +12       IF $EXTRACT(IOST)'="P"

               WRITE *7,!,"Please queue to printers only."

               GOTO DEV

 +13       SET ZTIO=""

           SET ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL

           SET ZTRTN="CALC^ACHSVUR"

           SET ZTDESC="CHS Vendor Report, "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)_" for "_ACHSVND

 +14       FOR %="ACHSQIO","ACHSVND","ACHSBDT","ACHSRPT","ACHSEDT"

               SET ZTSAVE(%)=""

 +15       DO ^%ZTLOAD

 +16       IF '$DATA(ZTSK)

               GOTO DEV

K         ; Kill vars, close device, quit.

 +1        KILL ACHSBDT,ACHSEDT,ACHSIO,ACHSQIO,ACHSRPT,ACHSVND,DTOUT,DUOUT,ZTSK

 +2        DO ^%ZISC

 +3        QUIT

 +4       ;

 +5       ;end of interactive portion.  The rest performed by Taskman

 +6       ;

 +7       ;

CALC      ;EP - TaskMan.

 +1        DO FC^ACHSUF

 +2        IF $DATA(ACHSERR)

               IF ACHSERR=1

                   GOTO K

 +3        SET ACHSTRDT=ACHSBDT-1

 +4        KILL ^TMP("ACHSVUR",$JOB)

 +5       ;

TRDT      ; Loop thru transaction date x-ref.

 +1        SET ACHSTRDT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT))

 +2        IF +ACHSTRDT=0!(+ACHSTRDT>ACHSEDT)

               GOTO PRINT

 +3        SET ACHSTYPE=""

 +4       ;

TRTYPE    ; Loop thru transaction type.

 +1        SET ACHSTYPE=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSTYPE))

 +2        IF ACHSTYPE=""

               GOTO TRDT

           IF ACHSTYPE'="I"

               GOTO TRTYPE

 +3        SET DA=0

 +4       ;

TRANS     ; Loop thru transactions, compile report data.

 +1        SET DA=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSTYPE,DA))

 +2        IF +DA=0

               GOTO TRDT

           IF '$DATA(^ACHSF(DUZ(2),"D",DA,0))

               GOTO TRDT

 +3       ;ACHS*3.1*18 06.08.2010 IHS.OIT.FCJ CHANGED NXT LINE TO PRINT 2 DIG FY

 +4       ;S ACHSDOCN=$P(^ACHSF(DUZ(2),"D",DA,0),U),ACHSVPTR=$P(^(0),U,8),ACHSFY=$P(^(0),U,14),ACHSSTS=$P(^(0),U,12),DFN=$P(^(0),U,22),ACHSBLNK=+$P(^(0),U,3)

 +5        SET ACHSDOCN=$PIECE(^ACHSF(DUZ(2),"D",DA,0),U)

           SET ACHSVPTR=$PIECE(^(0),U,8)

           SET ACHSFY=$EXTRACT($PIECE(^(0),U,27),3,4)

           SET ACHSSTS=$PIECE(^(0),U,12)

           SET DFN=$PIECE(^(0),U,22)

           SET ACHSBLNK=+$PIECE(^(0),U,3)

 +6       ;

 +7       ;get the amount. either the adjusted amount, or, if that doesn't

 +8       ;exist, the payment amount, or, if that doesn't exist, the

 +9       ;obligated amount

 +10      ;pmf  6/26/01  fix bug.  add $p to third line

 +11       Begin DoDot:1

 +12      ;/ITSC/JVK/SET ACHS*3.1*6 LN BLEOW

 +13      ; I $D(^ACHSF(DUZ(2),"D",DA,"ZA")) S ACHS("$")=$G(^ACHSF(DUZ(2),"D",DA,"ZA")) Q

 +14           IF $DATA(^ACHSF(DUZ(2),"D",DA,"ZA"))

                   SET ACHS("$")=$GET(^ACHSF(DUZ(2),"D",DA,"ZA"))

                   SET ACHS("$")=+ACHS("$")_"*"

                   QUIT

 +15      ;I $D(^ACHSF(DUZ(2),"D",DA,"PA")) S ACHS("$")=$G(^ACHSF(DUZ(2),"D",DA,"PA"))_"*" Q

 +16           IF $DATA(^ACHSF(DUZ(2),"D",DA,"PA"))

                   SET ACHS("$")=$GET(^ACHSF(DUZ(2),"D",DA,"PA"))

                   SET ACHS("$")=+ACHS("$")_"*"

                   QUIT

 +17      ;S ACHS("$")=$G(^ACHSF(DUZ(2),"D",DA,0))

 +18           SET ACHS("$")=$PIECE($GET(^ACHSF(DUZ(2),"D",DA,0)),U,9)

 +19           QUIT

           End DoDot:1

 +20      ;

 +21       IF (DFN'=+DFN)&('ACHSBLNK)

               GOTO TRANS

           IF ACHSSTS=4!(ACHSRPT=2&(ACHSSTS>2))!(ACHSVPTR']"")

               GOTO TRANS

           IF '$DATA(^AUTTVNDR(ACHSVPTR,0))

               GOTO TRANS

           SET ACHSVNDR=$PIECE(^(0),U)

 +22       IF 'ACHSBLNK

               IF '$DATA(^DPT(DFN,0))

                   GOTO TRANS

 +23       SET ACHSDOC=ACHSFY_"-"_ACHSFC_"-"_ACHSDOCN

           SET ^TMP("ACHSVUR",$JOB,ACHSVNDR,ACHSVPTR,ACHSDOC,DA)=$SELECT(ACHSBLNK=0:$PIECE(^DPT(DFN,0),U),ACHSBLNK=1:"* BLANKET",ACHSBLNK=2:"* SPECIAL TRANS",1:"")_U_ACHS("$")

 +24       GOTO TRANS

 +25      ;

PRINT     ; Kill calc vars, print.

 +1        KILL ACHSBLNK,ACHSDOCN,ACHSFY,ACHSSTS,ACHSTRDT,ACHSTYPE

 +2       ;

 +3        SET ACHSVNDR=""

           SET (ACHSTOT,ACHSTOT("$"),ACHSPD,ACHSPD("$"))=0

           SET ACHST1=$$C^XBFUNC("VENDOR USAGE REPORT - "_$SELECT(ACHSRPT=2:"OPEN DOCUMENTS ONLY",1:"OPEN AND PAID DOCUMENTS"))

 +4        SET ACHST2=$$C^XBFUNC("For the period "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT))

           SET X3=0

 +5        DO BRPT^ACHSFU

 +6        IF $DATA(IO("S"))

               XECUTE ACHSPPO

 +7        DO HDR

 +8        KILL ACHSHDR

A         ;

 +1        SET ACHSVNDR=$ORDER(^TMP("ACHSVUR",$JOB,ACHSVNDR))

 +2        IF ACHSVNDR=""

               GOTO ENDPRNT

 +3        SET ACHSVPTR=0

B         ;

 +1        SET ACHSVPTR=$ORDER(^TMP("ACHSVUR",$JOB,ACHSVNDR,ACHSVPTR))

 +2        IF +ACHSVPTR=0

               GOTO A

           IF '$DATA(^AUTTVNDR(ACHSVPTR))

               GOTO B

 +3        IF ACHSVND="Y"

               IF $DATA(ACHSHDR)

                   DO RTRN^ACHS

                   IF $DATA(DUOUT)!$DATA(DTOUT)

                       GOTO KILL

                   DO HDR

 +4        WRITE ACHSVNDR

 +5        SET ACHSHDR=""

 +6        IF $DATA(^AUTTVNDR(ACHSVPTR,13))

               WRITE ?37,$EXTRACT($PIECE(^(13),U,2),1,17)

               SET X=$PIECE(^(13),U,3)

               IF X]""

                   IF $DATA(^DIC(5,X,0))

                       WRITE $SELECT($X>38:", ",1:""),$PIECE(^(0),U,2)

 +7        SET ACHSDOC=""

           SET (ACHSVUR_source.html#xC">CHSVDOCHSVUR_source.html#xC">C,ACHSVUR_source.html#xC">CHSVDOCHSVUR_source.html#xC">C("$"))=0

 +8       ;

C         ;

 +1        SET ACHSVUR_source.html#xC">CHSDOCHSVUR_source.html#xC">C=$ORDER(^TMP("ACHSVUR_source.html#xC">CHSVUR",$JOB,ACHSVUR_source.html#xC">CHSVNDR,ACHSVUR_source.html#xC">CHSVPTR,ACHSVUR_source.html#xC">CHSDOCHSVUR_source.html#xC">C))

           IF ACHSDOC=""

               GOTO F

           SET DA=$ORDER(^(ACHSDOC,0))

           SET ACHSNAME=$PIECE(^(DA),U)

           SET ACHS("$")=$PIECE(^(DA),U,2)

 +2        IF '$DATA(^ACHSF(DUZ(2),"D",DA,0))

               GOTO C

           SET ACHSTOS=$PIECE(^(0),U,4)

           SET DFN=$PIECE(^(0),U,22)

 +3        IF +ACHSTOS>0

               SET ACHSTOS=$PIECE($PIECE($PIECE($PIECE(^DD(9002080.01,3,0),U,3),";",ACHSTOS),":",2)," ")

 +4        SET (Y,ACHSDOS)=""

 +5        IF $DATA(^ACHSF(DUZ(2),"D",DA,3))

               IF +$PIECE(^(3),U)>0

                   SET Y=+$PIECE(^(3),U)

                   SET ACHSDOS=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)

 +6       ;

D         ;

 +1        WRITE !?3,ACHSDOC,?16,ACHSNAME,?49,ACHSTOS,?54,ACHSDOS

 +2       ;

 +3       ;start of jeanette's changes

 +4        SET ACHSBLNK=$PIECE(^ACHSF(DUZ(2),"D",DA,0),U,3)

 +5        IF DFN

               SET INSTYP=$SELECT($DATA(^AUPNMCR(DFN)):"MCR",$DATA(^AUPNMCD("B",DFN)):"MCD",$DATA(^AUPNRRE(DFN)):"RRE",$DATA(^AUPNPRVT(DFN)):"PRVT",1:"")

 +6       ;

 +7        IF 'DFN

               SET INSTYP=""

 +8       ;

 +9        IF (INSTYP="PRVT")&('ACHSBLNK)

               DO PRVTST^ACHSVUR1

 +10       IF (INSTYP="MCR")&('ACHSBLNK)

               DO MCRTST^ACHSVUR1

 +11       IF (INSTYP="MCD")&('ACHSBLNK)

               DO MCDTST^ACHSVUR1

 +12       IF (INSTYP="RRE")&('ACHSBLNK)

               DO RRETST^ACHSVUR1

 +13      ;

 +14      ;end of jeanette's changes in this tag

 +15      ;

 +16      ;

 +17       SET X=$FNUMBER(+ACHS("$"),",",2)

 +18       IF $DATA(ACHSSTAR)

               SET X=X_ACHSSTAR

               KILL ACHSSTAR

 +19       WRITE ?78-$LENGTH(X),X

 +20       IF ACHS("$")["*"

               WRITE "*"

               SET ACHSPD=ACHSPD+1

               SET ACHSPD("$")=ACHSPD("$")+ACHS("$")

 +21       IF $Y>ACHSBM

               DO RTRN^ACHS

               IF $DATA(DUOUT)!$DATA(DTOUT)

                   GOTO KILL

               DO HDR

               IF $DATA(ACHSVNDR)

                   WRITE ACHSVNDR," (continued)"

 +22      ;

E         ;

 +1        SET ACHSVUR_source.html#xC">CHSVDOCHSVUR_source.html#xC">C=ACHSVUR_source.html#xC">CHSVDOCHSVUR_source.html#xC">C+1

           SET ACHSVUR_source.html#xC">CHSVDOCHSVUR_source.html#xC">C("$")=ACHSVUR_source.html#xC">CHSVDOCHSVUR_source.html#xC">C("$")+ACHSVUR_source.html#xC">CHS("$")

           SET ACHSTOT=ACHSTOT+1

           SET ACHSTOT("$")=ACHSTOT("$")+ACHS("$")

 +2        GOTO C

 +3       ;

F         ;

 +1        SET X2="2$"

           SET X3=16

           SET X=ACHSVDOC("$")

 +2        DO COMMA^%DTC

 +3        WRITE !?10,$$REPEAT^XLFSTR("-",55),!?10,"TOTALS     DOCUMENTS:",$JUSTIFY(ACHSVDOC,5),?42,"DOLLARS:",X,!,$$REPEAT^XLFSTR("-",79),!

 +4        GOTO B

 +5       ;

ENDPRNT   ;

 +1        IF ACHSVND="Y"

               DO RTRN^ACHS

               IF $DATA(DUOUT)!$DATA(DTOUT)

                   GOTO KILL

               DO HDR

 +2        WRITE !,$$REPEAT^XLFSTR("=",79),!

 +3        SET X2="2$"

           SET X3=16

           SET X=ACHSPD("$")

 +4        DO COMMA^%DTC

 +5        WRITE "TOTAL PAID",?21,"DOCUMENTS:",$JUSTIFY(ACHSPD,5),?42,"DOLLARS:",X,!

 +6        SET X=ACHSTOT("$")-ACHSPD("$")

 +7        DO COMMA^%DTC

 +8        WRITE "TOTAL OUTSTANDING",?21,"DOCUMENTS:",$JUSTIFY(ACHSTOT-ACHSPD,5),?42,"DOLLARS:",X,!,$$REPEAT^XLFSTR("-",79),!

 +9        SET X=ACHSTOT("$")

 +10       DO COMMA^%DTC

 +11       WRITE "GRAND TOTALS",?21,"DOCUMENTS:",$JUSTIFY(ACHSTOT,5),?42,"DOLLARS:",X

 +12       IF '$DATA(IO("S"))

               DO RTRN^ACHS

 +13       WRITE @IOF

KILL      ; Kill vars, close device, quit.

 +1        IF $DATA(IO("S"))

               XECUTE ACHSPPC

 +2        KILL DA,DFN,ZTSK,^TMP("ACHSVUR",$JOB)

 +3        DO ERPT^ACHS

           DO EN^XBVK("ACHS")

           IF '$DATA(ZTQUEUED)

               DO ^ACHSVAR

 +4        QUIT

 +5       ;

HDR       ; Paginate.

 +1        SET ACHSPG=ACHSPG+1

 +2        WRITE @IOF,!!?19,"***  CONTRACT HEALTH MANAGEMENT SYSTEM  ***",!,ACHSUSR,?71,"Page",$JUSTIFY(ACHSPG,3),!,ACHSLOC,!,ACHST1,!,ACHSTIME,!,ACHST2

 +3        WRITE !!,"VENDOR",?70,"DOLLARS",!?3,"DOCUMENT #   PATIENT NAME",?48,"TYPE    DOS",?64,"INS  (* = PAID)"

 +4        WRITE !,$$REPEAT^XLFSTR("=",79),!

 +5        QUIT

 +6       ;

H1        ;EP - From HELP^ACHS() via ^DIR.

 +1       ;;@;!

 +2       ;;Enter a '1' if you want to list all documents.

 +3       ;;Enter a '2' if you want only OPEN documents to be listed.

 +4       ;;###

 +5       ;

H2        ;EP - From HELP^ACHS() via ^DIR.

 +1       ;;@;!

 +2       ;;Enter 'Y' to print one vendor per page.

 +3       ;;'N' to print more than one vendor per page.

 +4       ;;@;!!

 +5       ;;###

 +6       ;

ACHSVUR.m